lib/sys.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_system.scm", Time-stamp: <2007-05-27 22:55:08 feeley>
   4
   5 ;;; Copyright (c) 1994-2007 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.vector? obj)
  35   (##eq? (##subtype obj) (macro-subtype-vector)))
  36
  37 (define-prim (##subtyped.symbol? obj)
  38   (##eq? (##subtype obj) (macro-subtype-symbol)))
  39
  40 (define-prim (##subtyped.flonum? obj)
  41   (##eq? (##subtype obj) (macro-subtype-flonum)))
  42
  43 (define-prim (##subtyped.bignum? obj)
  44   (##eq? (##subtype obj) (macro-subtype-bignum)))
  45
  46 (define-prim (##special? obj)
  47   (##eq? (##type obj) (macro-type-special)))
  48
  49 ;; (##vector? obj) is defined in "_std.scm"
  50
  51 (define-prim (##ratnum? obj)
  52   (and (##subtyped? obj)
  53        (##eq? (##subtype obj) (macro-subtype-ratnum))))
  54
  55 (define-prim (##cpxnum? obj)
  56   (and (##subtyped? obj)
  57        (##eq? (##subtype obj) (macro-subtype-cpxnum))))
  58
  59 (define-prim (##structure? obj)
  60   (and (##subtyped? obj)
  61        (##eq? (##subtype obj) (macro-subtype-structure))))
  62
  63 (define-prim (##values? obj)
  64   (and (##subtyped? obj)
  65        (##eq? (##subtype obj) (macro-subtype-boxvalues))
  66        (##not (##fixnum.= (##vector-length obj) 1))))
  67
  68 (define-prim (##meroon? obj)
  69   (and (##subtyped? obj)
  70        (##eq? (##subtype obj) (macro-subtype-meroon))))
  71
  72 (define-prim (##frame? obj)
  73   (and (##subtyped? obj)
  74        (##eq? (##subtype obj) (macro-subtype-frame))))
  75
  76 (define-prim (##continuation? obj)
  77   (and (##subtyped? obj)
  78        (##eq? (##subtype obj) (macro-subtype-continuation))))
  79
  80 (define-prim (##promise? obj)
  81   (and (##subtyped? obj)
  82        (##eq? (##subtype obj) (macro-subtype-promise))))
  83
  84 (define-prim (##return? obj)
  85   (and (##subtyped? obj)
  86        (##eq? (##subtype obj) (macro-subtype-return))))
  87
  88 (define-prim (##foreign? obj)
  89   (and (##subtyped? obj)
  90        (##eq? (##subtype obj) (macro-subtype-foreign))))
  91
  92 ;; (##string? obj) is defined in "_std.scm"
  93 ;; (##s8vector? obj) is defined in "_std.scm"
  94 ;; (##u8vector? obj) is defined in "_std.scm"
  95 ;; (##s16vector? obj) is defined in "_std.scm"
  96 ;; (##u16vector? obj) is defined in "_std.scm"
  97 ;; (##s32vector? obj) is defined in "_std.scm"
  98 ;; (##u32vector? obj) is defined in "_std.scm"
  99 ;; (##s64vector? obj) is defined in "_std.scm"
 100 ;; (##u64vector? obj) is defined in "_std.scm"
 101 ;; (##f32vector? obj) is defined in "_std.scm"
 102 ;; (##f64vector? obj) is defined in "_std.scm"
 103
 104 (define-prim (##flonum? obj)
 105   (and (##subtyped? obj)
 106        (##eq? (##subtype obj) (macro-subtype-flonum))))
 107
 108 (define-prim (##bignum? obj)
 109   (and (##subtyped? obj)
 110        (##eq? (##subtype obj) (macro-subtype-bignum))))
 111
 112 (define-prim (##unbound? obj))
 113
 114 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 115
 116 ;;; Procedures for front end
 117
 118 (define-prim (##quasi-append lst1 lst2)
 119   (macro-force-vars (lst1)
 120     (if (##pair? lst1)
 121       (let ((result (##cons (##car lst1) '())))
 122         (##set-cdr!
 123           (let loop ((end result) (x (##cdr lst1)))
 124             (macro-force-vars (x)
 125               (if (##pair? x)
 126                 (let ((tail (##cons (##car x) '())))
 127                   (##set-cdr! end tail)
 128                   (loop tail (##cdr x)))
 129                 end)))
 130           lst2)
 131         result)
 132       lst2)))
 133
 134 (define-prim (##quasi-list . lst)
 135   lst)
 136
 137 (define-prim (##quasi-cons obj1 obj2)
 138   (##cons obj1 obj2))
 139
 140 (define-prim (##quasi-list->vector lst)
 141   (let loop1 ((x lst) (n 0))
 142     (macro-force-vars (x)
 143       (if (##pair? x)
 144         (loop1 (##cdr x) (##fixnum.+ n 1))
 145         (let ((vect (##make-vector n 0)))
 146           (let loop2 ((x lst) (i 0))
 147             (macro-force-vars (x)
 148               (if (and (##pair? x)      ;; double check in case another
 149                        (##fixnum.< i n));; thread mutates the list
 150                 (begin
 151                   (##vector-set! vect i (##car x))
 152                   (loop2 (##cdr x) (##fixnum.+ i 1)))
 153                 vect))))))))
 154
 155 (define-prim (##case-memv obj lst)
 156   (macro-force-vars (obj)
 157     (let loop ((x lst))
 158       (if (##pair? x)
 159         (if (let () (##declare (generic)) (##eqv? obj (##car x)))
 160           x
 161           (loop (##cdr x)))
 162         #f))))
 163
 164 ;;;----------------------------------------------------------------------------
 165
 166 ;;; Object equality.
 167
 168 (define-prim (##eqv? obj1 obj2)
 169   (macro-number-dispatch obj1 (##eq? obj1 obj2)
 170     (and (##fixnum? obj2) (##fixnum.= obj1 obj2)) ;; obj1 = fixnum
 171     (and (##bignum? obj2) (##bignum.= obj1 obj2)) ;; obj1 = bignum
 172     (and (##ratnum? obj2) (##ratnum.= obj1 obj2)) ;; obj1 = ratnum
 173     (and (##flonum? obj2) (##bvector-equal? obj1 obj2)) ;; obj1 = flonum
 174     (and (##cpxnum? obj2) ;; obj1 = cpxnum
 175          (##eqv? (macro-cpxnum-real obj1) (macro-cpxnum-real obj2))
 176          (##eqv? (macro-cpxnum-imag obj1) (macro-cpxnum-imag obj2)))))
 177
 178 (define-prim (eqv? obj1 obj2)
 179   (macro-force-vars (obj1 obj2)
 180     (let ()
 181       (##declare (generic)) ;; avoid fixnum specific ##eqv?
 182       (##eqv? obj1 obj2))))
 183
 184 (define-prim (##eq? obj1 obj2))
 185
 186 (define-prim (eq? obj1 obj2)
 187   (macro-force-vars (obj1 obj2)
 188     (##eq? obj1 obj2)))
 189
 190 (define-prim (##bvector-equal? obj1 obj2)
 191
 192   (define (equal obj1 obj2 len)
 193     (let loop ((i (##fixnum.- len 1)))
 194       (or (##fixnum.< i 0)
 195           (and (##fixnum.= (##u16vector-ref obj1 i)
 196                            (##u16vector-ref obj2 i))
 197                (loop (##fixnum.- i 1))))))
 198
 199   (let ((len-obj1 (##u8vector-length obj1)))
 200     (and (##fixnum.= len-obj1 (##u8vector-length obj2))
 201          (if (##fixnum.odd? len-obj1)
 202            (let ((i (##fixnum.- len-obj1 1)))
 203              (and (##fixnum.= (##u8vector-ref obj1 i)
 204                               (##u8vector-ref obj2 i))
 205                   (equal obj1
 206                          obj2
 207                          (##fixnum.arithmetic-shift-right len-obj1 1))))
 208            (equal obj1
 209                   obj2
 210                   (##fixnum.arithmetic-shift-right len-obj1 1))))))
 211
 212 (define-prim (##equal? obj1 obj2)
 213
 214   (define (eqv obj1 obj2)
 215     (##declare (generic)) ;; avoid fixnum specific ##eqv?
 216     (##eqv? obj1 obj2))
 217
 218   (define (structure-equal obj1 obj2 type len)
 219     (or (##not type) ;; have we reached root of inheritance chain?
 220         (let ((fields (##type-fields type)))
 221           (let loop ((i*3 (##fixnum.- (##vector-length fields) 3))
 222                      (len len))
 223             (if (##fixnum.< i*3 0)
 224               (structure-equal obj1 obj2 (##type-super type) len)
 225               (let ((field-attributes
 226                      (##vector-ref fields (##fixnum.+ i*3 1)))
 227                     (len-1
 228                      (##fixnum.- len 1)))
 229                 (and (or (##not (##fixnum.=
 230                                  (##fixnum.bitwise-and field-attributes 4)
 231                                  0))
 232                          (equal (##unchecked-structure-ref
 233                                  obj1
 234                                  len-1
 235                                  type
 236                                  #f)
 237                                 (##unchecked-structure-ref
 238                                  obj2
 239                                  len-1
 240                                  type
 241                                  #f)))
 242                      (loop (##fixnum.- i*3 3)
 243                            len-1))))))))
 244
 245   (define (equal obj1 obj2)
 246     (macro-force-vars (obj1 obj2)
 247       (cond ((##eq? obj1 obj2)
 248              #t)
 249             ((##pair? obj1)
 250              (and (##pair? obj2)
 251                   (equal (##car obj1) (##car obj2))
 252                   (equal (##cdr obj1) (##cdr obj2))))
 253             ((##subtyped? obj1)
 254              (and (##subtyped? obj2)
 255                   (let ((subtype-obj1 (##subtype obj1)))
 256                     (and (##fixnum.= subtype-obj1 (##subtype obj2))
 257                          (cond ((macro-subtype-bvector? subtype-obj1)
 258                                 (##bvector-equal? obj1 obj2))
 259                                ((##vector? obj1)
 260                                 (let ((len-obj1 (##vector-length obj1)))
 261                                   (and (##fixnum.= len-obj1
 262                                                    (##vector-length obj2))
 263                                        (let loop ((i (##fixnum.- len-obj1 1)))
 264                                          (or (##fixnum.< i 0)
 265                                              (and (equal (##vector-ref obj1 i)
 266                                                          (##vector-ref obj2 i))
 267                                                   (loop (##fixnum.- i 1))))))))
 268                                ((macro-table? obj1)
 269                                 (and (macro-table? obj2)
 270                                      (##table-equal? obj1 obj2)))
 271                                ((##structure? obj1)
 272                                 (and (##structure? obj2)
 273                                      (let* ((type-obj1
 274                                              (##structure-type obj1))
 275                                             (type-obj2
 276                                              (##structure-type obj2))
 277                                             (type-id-obj1
 278                                              (##type-id type-obj1))
 279                                             (type-id-obj2
 280                                              (##type-id type-obj2)))
 281                                        (and (##eq? type-id-obj1
 282                                                    type-id-obj2)
 283                                             (let ((len-obj1
 284                                                    (##vector-length obj1)))
 285                                               (and (##fixnum.=
 286                                                     len-obj1
 287                                                     (##vector-length obj2))
 288                                                    (##fixnum.= ;; not opaque?
 289                                                     (##fixnum.bitwise-and
 290                                                      (##type-flags type-obj1)
 291                                                      1)
 292                                                     0)
 293                                                    (structure-equal
 294                                                     obj1
 295                                                     obj2
 296                                                     type-obj1
 297                                                     len-obj1)))))))
 298                                ((##box? obj1)
 299                                 (and (##box? obj2)
 300                                      (equal (##unbox obj1)
 301                                             (##unbox obj2))))
 302                                (else
 303                                 (eqv obj1 obj2)))))))
 304           (else
 305            (eqv obj1 obj2)))))
 306
 307   (equal obj1 obj2))
 308
 309 (define-prim (equal? obj1 obj2)
 310   (##equal? obj1 obj2))
 311
 312 ;;;----------------------------------------------------------------------------
 313
 314 ;;; Object hashing.
 315
 316 (define-prim (##symbol-hash sym)
 317   (macro-symbol-hash sym))
 318
 319 (define-prim (symbol-hash sym)
 320   (macro-force-vars (sym)
 321     (macro-check-symbol sym 1 (symbol-hash sym)
 322       (##symbol-hash sym))))
 323
 324 (define-prim (##keyword-hash key)
 325   (macro-keyword-hash key))
 326
 327 (define-prim (keyword-hash key)
 328   (macro-force-vars (key)
 329     (macro-check-keyword key 1 (keyword-hash key)
 330       (##keyword-hash key))))
 331
 332 (define-prim (##eq?-hash obj)
 333
 334   ;; for all obj2 we must have that (##eq? obj obj2) implies that
 335   ;; (= (##eq?-hash obj) (##eq?-hash obj2))
 336
 337   (cond ((##not (##mem-allocated? obj))
 338          (##fixnum.bitwise-and
 339           (##type-cast obj (macro-type-fixnum))
 340           (macro-max-fixnum32)))
 341         ((##symbol? obj)
 342          (##symbol-hash obj))
 343         ((##keyword? obj)
 344          (##keyword-hash obj))
 345         (else
 346          (##fixnum.bitwise-and
 347           (let ((sn (##object->serial-number obj)))
 348             (if (##fixnum? sn)
 349               sn
 350               (##fixnum.arithmetic-shift-left
 351                (##bignum.mdigit-ref sn 0)
 352                10)))
 353           (macro-max-fixnum32)))))
 354
 355 (define-prim (eq?-hash obj)
 356   (macro-force-vars (obj)
 357     (##eq?-hash obj)))
 358
 359 (define-prim (##eqv?-hash obj)
 360
 361   ;; for all obj2 we must have that (##eqv? obj obj2) implies that
 362   ;; (= (##eqv?-hash obj) (##eqv?-hash obj2))
 363
 364   (define (combine a b)
 365     (##fixnum.bitwise-and
 366      (##fixnum.* (##fixnum.+ a (##fixnum.arithmetic-shift-left b 1))
 367                  331804471)
 368      (macro-max-fixnum32)))
 369
 370   (define (hash obj)
 371     (macro-number-dispatch obj
 372       (##eq?-hash obj) ;; obj = not a number
 373       (##fixnum.bitwise-and obj (macro-max-fixnum32)) ;; obj = fixnum
 374       (##modulo obj 331804481) ;; obj = bignum
 375       (combine (hash (macro-ratnum-numerator obj)) ;; obj = ratnum
 376                (hash (macro-ratnum-denominator obj)))
 377       (combine (##u16vector-ref obj 0) ;; obj = flonum
 378                (combine (##u16vector-ref obj 1)
 379                         (combine (##u16vector-ref obj 2)
 380                                  (##u16vector-ref obj 3))))
 381       (combine (hash (macro-cpxnum-real obj)) ;; obj = cpxnum
 382                (hash (macro-cpxnum-imag obj)))))
 383
 384   (hash obj))
 385
 386 (define-prim (eqv?-hash obj)
 387   (macro-force-vars (obj)
 388     (##eqv?-hash obj)))
 389
 390 (define-prim (##equal?-hash obj)
 391
 392   ;; for all obj2 we must have that (##equal? obj obj2) implies that
 393   ;; (= (##equal?-hash obj) (##equal?-hash obj2))
 394
 395   (define (combine a b)
 396     (##fixnum.bitwise-and
 397      (##fixnum.* (##fixnum.+ a (##fixnum.arithmetic-shift-left b 1))
 398                  331804471)
 399      (macro-max-fixnum32)))
 400
 401   (define (bvector-hash obj)
 402
 403     (define (u16vect-hash i h)
 404       (if (##fixnum.< i 0)
 405         h
 406         (u16vect-hash (##fixnum.- i 1)
 407                       (combine (##u16vector-ref obj i) h))))
 408
 409     (let ((len (##u8vector-length obj)))
 410       (u16vect-hash (##fixnum.- (##fixnum.arithmetic-shift-right len 1) 1)
 411                     (##fixnum.bitwise-xor
 412                      (if (##fixnum.odd? len)
 413                        (##u8vector-ref obj (##fixnum.- len 1))
 414                        256)
 415                      (##fixnum.+ len
 416                                  (##fixnum.arithmetic-shift-left
 417                                   (##subtype obj)
 418                                   20))))))
 419
 420   (define (structure-hash obj type len h)
 421     (if (##not type) ;; have we reached root of inheritance chain?
 422       h
 423       (let ((fields (##type-fields type)))
 424         (let loop ((h 0)
 425                    (i*3 (##fixnum.- (##vector-length fields) 3))
 426                    (len len))
 427           (if (##fixnum.< i*3 0)
 428             (structure-hash obj (##type-super type) len h)
 429             (let ((field-attributes
 430                    (##vector-ref fields (##fixnum.+ i*3 1)))
 431                   (len-1
 432                    (##fixnum.- len 1)))
 433               (loop (if (##fixnum.=
 434                          (##fixnum.bitwise-and field-attributes 4)
 435                          0)
 436                       (combine (hash (##unchecked-structure-ref
 437                                       obj
 438                                       len-1
 439                                       type
 440                                       #f))
 441                                h)
 442                       h)
 443                     (##fixnum.- i*3 3)
 444                     len-1)))))))
 445
 446   (define (hash obj)
 447     (macro-force-vars (obj)
 448       (cond ((##pair? obj)
 449              (combine (hash (##car obj))
 450                       (hash (##cdr obj))))
 451             ((##subtyped? obj)
 452              (cond ((macro-subtype-bvector? (##subtype obj))
 453                     (cond ((##string? obj)
 454                            (##string=?-hash obj))
 455                           ((or (##flonum? obj)
 456                                (##bignum? obj))
 457                            (##eqv?-hash obj))
 458                           (else
 459                            (bvector-hash obj))))
 460                    ((##symbol? obj)
 461                     (##symbol-hash obj))
 462                    ((##keyword? obj)
 463                     (##keyword-hash obj))
 464                    ((##vector? obj)
 465                     (let loop ((i (##fixnum.- (##vector-length obj) 1))
 466                                (h 383479237))
 467                       (if (##fixnum.< i 0)
 468                         h
 469                         (loop (##fixnum.- i 1)
 470                               (combine (hash (##vector-ref obj i))
 471                                        h)))))
 472                    ((macro-table? obj)
 473                     (##table-equal?-hash obj))
 474                    ((##structure? obj)
 475                     (let* ((type
 476                             (##structure-type obj))
 477                            (type-id
 478                             (##type-id type)))
 479                       (if (##fixnum.= ;; not opaque?
 480                            (##fixnum.bitwise-and
 481                             (##type-flags type)
 482                             1)
 483                            0)
 484                         (structure-hash obj
 485                                         type
 486                                         (##vector-length obj)
 487                                         (hash type-id))
 488                         (##eq?-hash obj))))
 489                    ((##box? obj)
 490                     (combine (hash (##unbox obj))
 491                              153391703))
 492                    (else
 493                     (##eqv?-hash obj))))
 494             (else
 495              (##eqv?-hash obj)))))
 496
 497   (hash obj))
 498
 499 (define-prim (equal?-hash obj)
 500   (macro-force-vars (obj)
 501     (##equal?-hash obj)))
 502
 503 (define-prim (##string=?-hash str)
 504
 505   ;; for all str2 we must have that (##string=? str str2) implies that
 506   ;; (= (##string=?-hash str) (##string=?-hash str2))
 507
 508   (let ((len (##string-length str)))
 509     (let loop ((h 0) (i 0))
 510       (if (##fixnum.< i len)
 511         (loop (##fixnum.bitwise-and
 512                (##fixnum.* (##fixnum.+
 513                             (##fixnum.arithmetic-shift-right h 8)
 514                             (##fixnum.<-char (##string-ref str i)))
 515                            331804471)
 516                (macro-max-fixnum32))
 517               (##fixnum.+ i 1))
 518         h))))
 519
 520 (define-prim (string=?-hash str)
 521   (macro-force-vars (str)
 522     (macro-check-string str 1 (string=?-hash str)
 523       (##string=?-hash str))))
 524
 525 (define-prim (##string-ci=?-hash str)
 526
 527   ;; for all str2 we must have that (##string-ci=? str str2) implies that
 528   ;; (= (##string-ci=?-hash str) (##string-ci=?-hash str2))
 529
 530   (let ((len (##string-length str)))
 531     (let loop ((h 0) (i 0))
 532       (if (##fixnum.< i len)
 533         (loop (##fixnum.bitwise-and
 534                (##fixnum.* (##fixnum.+
 535                             (##fixnum.arithmetic-shift-right h 8)
 536                             (##fixnum.<-char
 537                              (##char-downcase (##string-ref str i))))
 538                            331804471)
 539                (macro-max-fixnum32))
 540               (##fixnum.+ i 1))
 541         h))))
 542
 543 (define-prim (string-ci=?-hash str)
 544   (macro-force-vars (str)
 545     (macro-check-string str 1 (string-ci=?-hash str)
 546       (##string-ci=?-hash str))))
 547
 548 (define-prim (##generic-hash obj)
 549   0)
 550
 551 ;;;----------------------------------------------------------------------------
 552
 553 ;;; Tables.
 554
 555 (implement-library-type-invalid-hash-number-exception)
 556
 557 (define-prim (##raise-invalid-hash-number-exception proc . args)
 558   (##extract-procedure-and-arguments
 559    proc
 560    args
 561    #f
 562    #f
 563    #f
 564    (lambda (procedure arguments dummy1 dummy2 dummy3)
 565      (macro-raise
 566       (macro-make-invalid-hash-number-exception
 567        procedure
 568        arguments)))))
 569
 570 (implement-library-type-unbound-table-key-exception)
 571
 572 (define-prim (##raise-unbound-table-key-exception proc . args)
 573   (##extract-procedure-and-arguments
 574    proc
 575    args
 576    #f
 577    #f
 578    #f
 579    (lambda (procedure arguments dummy1 dummy2 dummy3)
 580      (macro-raise
 581       (macro-make-unbound-table-key-exception
 582        procedure
 583        arguments)))))
 584
 585 (define-prim (##gc-hash-table? obj)
 586   (and (##subtyped? obj)
 587        (##eq? (##subtype obj) (macro-subtype-weak))
 588        (##not (##fixnum.= (##vector-length obj) (macro-will-size)))))
 589
 590 (define-prim (##gc-hash-table-ref gcht key))
 591 (define-prim (##gc-hash-table-set! gcht key val))
 592 (define-prim (##gc-hash-table-rehash! gcht-src gcht-dst))
 593
 594 (define-prim (##smallest-prime-no-less-than n) ;; n >= 3
 595   (let loop1 ((n (if (##fixnum.even? n) (##fixnum.+ n 1) n)))
 596     (let loop2 ((d 3))
 597       (cond ((##fixnum.< n (##fixnum.* d d))
 598              n)
 599             ((##fixnum.zero? (##fixnum.modulo n d))
 600              (loop1 (##fixnum.+ n 2)))
 601             (else
 602              (loop2 (##fixnum.+ d 2)))))))
 603
 604 (define-prim (##gc-hash-table-resize! gcht loads)
 605   (let* ((count
 606           (macro-gc-hash-table-count gcht))
 607          (n
 608           (##flonum.->fixnum
 609            (##flonum./ (##flonum.<-fixnum count)
 610                        (##f64vector-ref loads 1)))))
 611     (##gc-hash-table-allocate
 612      n
 613      (##fixnum.bitwise-and
 614       (macro-gc-hash-table-flags gcht)
 615       (##fixnum.bitwise-not
 616        (macro-gc-hash-table-flag-need-rehash)))
 617      loads)))
 618
 619 (define-prim (##gc-hash-table-allocate n flags loads)
 620   (if (##fixnum.< (macro-gc-hash-table-minimal-nb-entries) n)
 621     (let* ((nb-entries
 622             (##smallest-prime-no-less-than (##fixnum.+ n 1)))
 623            (min-count
 624             (##flonum.->fixnum
 625              (##flonum.* (##flonum.<-fixnum n)
 626                          (##f64vector-ref loads 0))))
 627            (free
 628             (##fixnum.+ 1
 629                         (##flonum.->fixnum
 630                          (##flonum.* (##flonum.<-fixnum
 631                                       (##fixnum.- nb-entries 1))
 632                                      (##f64vector-ref loads 2))))))
 633       (macro-make-gc-hash-table
 634        flags
 635        0
 636        min-count
 637        free
 638        nb-entries))
 639     (macro-make-minimal-gc-hash-table
 640      flags
 641      0)))
 642
 643 (define-prim (##gc-hash-table-for-each proc ht)
 644   (##declare (not interrupts-enabled))
 645   (if (##gc-hash-table? ht)
 646     (let loop ((i (macro-gc-hash-table-key0)))
 647       (if (##fixnum.< i (##vector-length ht))
 648         (let ((key (##vector-ref ht i)))
 649           (if (and (##not (##eq? key (macro-unused-obj)))
 650                    (##not (##eq? key (macro-deleted-obj))))
 651             (proc key (##vector-ref ht (##fixnum.+ i 1))))
 652           (let ()
 653             (##declare (interrupts-enabled))
 654             (loop (##fixnum.+ i 2))))
 655         (##void)))
 656     (##void)))
 657
 658 (define-prim (##gc-hash-table-search proc ht)
 659   (##declare (not interrupts-enabled))
 660   (if (##gc-hash-table? ht)
 661     (let loop ((i (macro-gc-hash-table-key0)))
 662       (if (##fixnum.< i (##vector-length ht))
 663         (let ((key (##vector-ref ht i)))
 664           (or (and (##not (##eq? key (macro-unused-obj)))
 665                    (##not (##eq? key (macro-deleted-obj)))
 666                    (proc key (##vector-ref ht (##fixnum.+ i 1))))
 667               (let ()
 668                 (##declare (interrupts-enabled))
 669                 (loop (##fixnum.+ i 2)))))
 670         #f))
 671     #f))
 672
 673 (define-prim (##gc-hash-table-foldl f base proc ht)
 674   (##declare (not interrupts-enabled))
 675   (if (##gc-hash-table? ht)
 676     (let loop ((i (macro-gc-hash-table-key0)) (base base))
 677       (if (##fixnum.< i (##vector-length ht))
 678         (let ((key (##vector-ref ht i)))
 679           (if (and (##not (##eq? key (macro-unused-obj)))
 680                    (##not (##eq? key (macro-deleted-obj))))
 681             (let ((new-base
 682                    (f base (proc key (##vector-ref ht (##fixnum.+ i 1))))))
 683               (##declare (interrupts-enabled))
 684               (loop (##fixnum.+ i 2) new-base))
 685             (let ()
 686               (##declare (interrupts-enabled))
 687               (loop (##fixnum.+ i 2) base))))
 688         base))
 689     base))
 690
 691 (define-prim (##mem-allocated? obj)
 692   (let ((type (##type obj)))
 693     (or (##fixnum.= type (macro-type-subtyped))
 694         (##fixnum.= type (macro-type-pair)))))
 695
 696 (implement-type-table)
 697
 698 (define-fail-check-type table (macro-type-table))
 699
 700 (define-check-type table (macro-type-table)
 701   macro-table?)
 702
 703 (define-prim (table? obj)
 704   (macro-table? obj))
 705
 706 (define-prim (##make-table
 707               #!optional
 708               (size (macro-absent-obj))
 709               (init (macro-absent-obj))
 710               (weak-keys (macro-absent-obj))
 711               (weak-values (macro-absent-obj))
 712               (test (macro-absent-obj))
 713               (hash (macro-absent-obj))
 714               (min-load (macro-absent-obj))
 715               (max-load (macro-absent-obj)))
 716
 717   (define-macro (macro-default-weak-keys)   0)
 718   (define-macro (macro-default-weak-values) 0)
 719
 720   (define-macro (macro-default-min-load) 0.45)
 721   (define-macro (macro-default-max-load) 0.90)
 722
 723   (define-macro (macro-load-range-lo)    0.05)
 724   (define-macro (macro-load-range-hi)    0.95)
 725   (define-macro (macro-load-min-max-gap) 0.20)
 726
 727   (define (check-size arg-num)
 728     (if (##eq? size (macro-absent-obj))
 729       (check-weak-keys 0
 730                        arg-num)
 731       (let ((arg-num (##fixnum.+ arg-num 2)))
 732         (macro-check-index
 733          size
 734          arg-num
 735          (make-table size: size
 736                      init: init
 737                      weak-keys: weak-keys
 738                      weak-values: weak-values
 739                      test: test
 740                      hash: hash
 741                      min-load: min-load
 742                      max-load: max-load)
 743          (check-weak-keys (##fixnum.min size 2000000) ;; avoid fixnum overflows
 744                           arg-num)))))
 745
 746   (define (check-weak-keys siz arg-num)
 747     (if (##eq? weak-keys (macro-absent-obj))
 748       (check-weak-values siz
 749                          (macro-default-weak-keys)
 750                          arg-num)
 751       (let ((arg-num (##fixnum.+ arg-num 2)))
 752         (check-weak-values siz
 753                            (if weak-keys
 754                              (macro-gc-hash-table-flag-weak-keys)
 755                              0)
 756                            arg-num))))
 757
 758   (define (check-weak-values siz flags arg-num)
 759     (if (##eq? weak-values (macro-absent-obj))
 760       (check-test siz
 761                   (##fixnum.+ flags
 762                               (macro-default-weak-values))
 763                   arg-num)
 764       (let ((arg-num (##fixnum.+ arg-num 2)))
 765         (check-test siz
 766                     (##fixnum.+ flags
 767                                 (if weak-values
 768                                   (macro-gc-hash-table-flag-weak-vals)
 769                                   0))
 770                     arg-num))))
 771
 772   (define (check-test siz flags arg-num)
 773     (if (##eq? test (macro-absent-obj))
 774       (check-hash siz
 775                   flags
 776                   ##equal?
 777                   arg-num)
 778       (let ((arg-num (##fixnum.+ arg-num 2)))
 779         (macro-check-procedure
 780          test
 781          arg-num
 782          (make-table size: size
 783                      init: init
 784                      weak-keys: weak-keys
 785                      weak-values: weak-values
 786                      test: test
 787                      hash: hash
 788                      min-load: min-load
 789                      max-load: max-load)
 790          (check-hash siz
 791                      flags
 792                      test
 793                      arg-num)))))
 794
 795   (define (check-hash siz flags test-fn arg-num)
 796     (if (##eq? hash (macro-absent-obj))
 797       (cond ((or (##eq? test-fn ##eq?) (##eq? test-fn eq?))
 798              (check-loads siz
 799                           flags
 800                           #f
 801                           #f
 802                           arg-num))
 803             ((or (##eq? test-fn ##eqv?) (##eq? test-fn eqv?))
 804              (check-loads siz
 805                           flags
 806                           test-fn
 807                           ##eqv?-hash
 808                           arg-num))
 809             ((or (##eq? test-fn ##equal?) (##eq? test-fn equal?))
 810              (check-loads siz
 811                           flags
 812                           test-fn
 813                           ##equal?-hash
 814                           arg-num))
 815             ((or (##eq? test-fn ##string=?) (##eq? test-fn string=?))
 816              (check-loads siz
 817                           flags
 818                           test-fn
 819                           string=?-hash
 820                           arg-num))
 821             ((or (##eq? test-fn ##string-ci=?) (##eq? test-fn string-ci=?))
 822              (check-loads siz
 823                           flags
 824                           test-fn
 825                           string-ci=?-hash
 826                           arg-num))
 827             (else
 828              (check-loads siz
 829                           flags
 830                           test-fn
 831                           ##generic-hash
 832                           arg-num)))
 833       (let ((arg-num (##fixnum.+ arg-num 2)))
 834         (macro-check-procedure
 835          hash
 836          arg-num
 837          (make-table size: size
 838                      init: init
 839                      weak-keys: weak-keys
 840                      weak-values: weak-values
 841                      test: test
 842                      hash: hash
 843                      min-load: min-load
 844                      max-load: max-load)
 845          (check-loads siz
 846                       flags
 847                       test-fn
 848                       hash
 849                       arg-num)))))
 850
 851   (define (check-loads siz flags test-fn hash-fn arg-num)
 852     (if (and (##eq? min-load (macro-absent-obj))
 853              (##eq? max-load (macro-absent-obj)))
 854       (checks-done siz
 855                    flags
 856                    test-fn
 857                    hash-fn
 858                    '#f64(.45 .6363961030678927 .9)
 859                    arg-num)
 860       (check-min-load siz
 861                       flags
 862                       test-fn
 863                       hash-fn
 864                       (##f64vector (macro-default-min-load)
 865                                    (macro-inexact-+0)
 866                                    (macro-default-max-load))
 867                       arg-num)))
 868
 869   (define (check-min-load siz flags test-fn hash-fn loads arg-num)
 870     (if (##eq? min-load (macro-absent-obj))
 871       (check-max-load siz
 872                       flags
 873                       test-fn
 874                       hash-fn
 875                       loads
 876                       arg-num)
 877       (let ((arg-num (##fixnum.+ arg-num 2)))
 878         (if (##not (##real? min-load))
 879           (##fail-check-real
 880            arg-num
 881            (##list size: size
 882                    init: init
 883                    weak-keys: weak-keys
 884                    weak-values: weak-values
 885                    test: test
 886                    hash: hash
 887                    min-load: min-load
 888                    max-load: max-load)
 889            make-table)
 890           (begin
 891             (##f64vector-set! loads 0 (macro-real->inexact min-load))
 892             (check-max-load siz
 893                             flags
 894                             test-fn
 895                             hash-fn
 896                             loads
 897                             arg-num))))))
 898
 899   (define (check-max-load siz flags test-fn hash-fn loads arg-num)
 900     (if (##eq? max-load (macro-absent-obj))
 901       (check-loads-done siz
 902                         flags
 903                         test-fn
 904                         hash-fn
 905                         loads
 906                         arg-num)
 907       (let ((arg-num (##fixnum.+ arg-num 2)))
 908         (if (##not (##real? max-load))
 909           (##fail-check-real
 910            arg-num
 911            (##list size: size
 912                    init: init
 913                    weak-keys: weak-keys
 914                    weak-values: weak-values
 915                    test: test
 916                    hash: hash
 917                    min-load: min-load
 918                    max-load: max-load)
 919            make-table)
 920           (begin
 921             (##f64vector-set! loads 2 (macro-real->inexact max-load))
 922             (check-loads-done siz
 923                               flags
 924                               test-fn
 925                               hash-fn
 926                               loads
 927                               arg-num))))))
 928
 929   (define (check-loads-done siz flags test-fn hash-fn loads arg-num)
 930     (##f64vector-set!
 931      loads
 932      0
 933      (##flonum.min (##flonum.- (macro-load-range-hi)
 934                                (macro-load-min-max-gap))
 935                    (##flonum.max (macro-load-range-lo)
 936                                  (##f64vector-ref loads 0))))
 937     (##f64vector-set!
 938      loads
 939      2
 940      (##flonum.min (macro-load-range-hi)
 941                    (##flonum.max (##flonum.+ (##f64vector-ref loads 0)
 942                                              (macro-load-min-max-gap))
 943                                  (##f64vector-ref loads 2))))
 944     (##f64vector-set!
 945      loads
 946      1
 947      (##flonum.sqrt (##flonum.* (##f64vector-ref loads 0)
 948                                 (##f64vector-ref loads 2))))
 949     (checks-done siz
 950                  flags
 951                  test-fn
 952                  hash-fn
 953                  loads
 954                  arg-num))
 955
 956   (define (checks-done siz flags test-fn hash-fn loads arg-num)
 957     (macro-make-table (if (and #f ;; don't make a special case for eq? tables
 958                                (##not test-fn)
 959                                (##eq? weak-keys (macro-absent-obj)))
 960                         (##fixnum.bitwise-ior
 961                          flags
 962                          (macro-gc-hash-table-flag-weak-keys))
 963                         flags)
 964                       test-fn
 965                       hash-fn
 966                       loads
 967                       siz
 968                       init))
 969
 970   (check-size 0))
 971
 972 (define-prim (make-table
 973               #!key
 974               (size (macro-absent-obj))
 975               (init (macro-absent-obj))
 976               (weak-keys (macro-absent-obj))
 977               (weak-values (macro-absent-obj))
 978               (test (macro-absent-obj))
 979               (hash (macro-absent-obj))
 980               (min-load (macro-absent-obj))
 981               (max-load (macro-absent-obj)))
 982   (##make-table
 983    size
 984    init
 985    weak-keys
 986    weak-values
 987    test
 988    hash
 989    min-load
 990    max-load))
 991
 992 (define (##table-get-eq-gcht table key)
 993   (##declare (not interrupts-enabled))
 994   (if (##mem-allocated? key)
 995     (##table-get-gcht table)
 996     (##table-get-gcht-not-mem-alloc table)))
 997
 998 (define (##table-get-gcht-not-mem-alloc table)
 999   (##declare (not interrupts-enabled))
1000   (or (macro-table-hash table)
1001       (let* ((n ;; initial size
1002               (let ((gcht (macro-table-gcht table)))
1003                 (if (##fixnum? gcht)
1004                   gcht
1005                   (macro-gc-hash-table-nb-entries gcht))))
1006              (gcht
1007               (##gc-hash-table-allocate
1008                n
1009                (macro-table-flags table)
1010                (macro-table-loads table))))
1011         (macro-table-hash-set! table gcht)
1012         gcht)))
1013
1014 (define (##table-get-gcht table)
1015   (##declare (not interrupts-enabled))
1016   (let ((gcht (macro-table-gcht table)))
1017     (if (##fixnum? gcht)
1018       (let* ((n ;; initial size
1019               gcht)
1020              (gcht
1021               (##gc-hash-table-allocate
1022                n
1023                (##fixnum.bitwise-ior
1024                 (macro-gc-hash-table-flag-mem-alloc-keys)
1025                 (macro-table-flags table))
1026                (macro-table-loads table))))
1027         (macro-table-gcht-set! table gcht)
1028         gcht)
1029       gcht)))
1030
1031 (define-prim (##table-length table)
1032
1033   (##declare (not interrupts-enabled))
1034
1035   (define (count ht)
1036     (if (##gc-hash-table? ht)
1037       (macro-gc-hash-table-count ht)
1038       0))
1039
1040   (if (macro-table-test table)
1041     (count (macro-table-gcht table))
1042     (##fixnum.+ (count (macro-table-hash table))
1043                 (count (macro-table-gcht table)))))
1044
1045 (define-prim (table-length table)
1046   (macro-force-vars (table)
1047     (macro-check-table table 1 (table-length table)
1048       (##table-length table))))
1049
1050 (define-prim (##table-access table key found not-found val)
1051   (##declare (not interrupts-enabled))
1052   (let ((f (macro-table-hash table)))
1053     (let loop1 ((h (f key)))
1054       (if (##not (##fixnum? h))
1055         (loop1 (##raise-invalid-hash-number-exception f key))
1056         (let* ((gcht
1057                 (let ((gcht (##table-get-gcht table)))
1058                   (if (##not
1059                        (##fixnum.= 0
1060                                    (##fixnum.bitwise-and
1061                                     (macro-gc-hash-table-flags gcht)
1062                                     (macro-gc-hash-table-flag-need-rehash))))
1063                       (begin
1064                         (##table-resize! table)
1065                         (macro-table-gcht table))
1066                       gcht)))
1067                (size
1068                 (macro-gc-hash-table-nb-entries gcht))
1069                (probe2
1070                 (##fixnum.arithmetic-shift-left
1071                  (##fixnum.modulo h size)
1072                  1))
1073                (step2
1074                 (##fixnum.arithmetic-shift-left
1075                  (##fixnum.+ (##fixnum.modulo h (##fixnum.- size 1)) 1)
1076                  1))
1077                (size2
1078                 (##fixnum.arithmetic-shift-left size 1))
1079                (test
1080                 (macro-table-test table)))
1081           (let loop2 ((probe2 probe2)
1082                       (deleted2 #f))
1083             (let ((k (macro-gc-hash-table-key-ref gcht probe2)))
1084               (cond ((##eq? k (macro-unused-obj))
1085                      (not-found table key gcht probe2 deleted2 val))
1086                     ((##eq? k (macro-deleted-obj))
1087                      (let ((next-probe2 (##fixnum.- probe2 step2)))
1088                        (loop2 (if (##fixnum.< next-probe2 0)
1089                                 (##fixnum.+ next-probe2 size2)
1090                                 next-probe2)
1091                               (or deleted2 probe2))))
1092                     ((test key k)
1093                      (found table key gcht probe2 val))
1094                     (else
1095                      (let ((next-probe2 (##fixnum.- probe2 step2)))
1096                        (loop2 (if (##fixnum.< next-probe2 0)
1097                                 (##fixnum.+ next-probe2 size2)
1098                                 next-probe2)
1099                               deleted2)))))))))))
1100
1101 (define-prim (##table-ref
1102               table
1103               key
1104               #!optional
1105               (default-value (macro-absent-obj)))
1106   (##declare (not interrupts-enabled))
1107   (let ((test (macro-table-test table)))
1108     (if test
1109
1110       (##table-access
1111        table
1112        key
1113        (lambda (table key gcht probe2 default-value)
1114          ;; key was found at position "probe2" so just return value field
1115          (macro-gc-hash-table-val-ref gcht probe2))
1116        (lambda (table key gcht probe2 deleted2 default-value)
1117          ;; key was not found (search ended at position "probe2" and the
1118          ;; first deleted entry encountered is at position "deleted2")
1119          (cond ((##not (##eq? default-value (macro-absent-obj)))
1120                 default-value)
1121                ((##not (##eq? (macro-table-init table) (macro-absent-obj)))
1122                 (macro-table-init table))
1123                (else
1124                 (##raise-unbound-table-key-exception
1125                  table-ref
1126                  table
1127                  key))))
1128        default-value)
1129
1130       (let* ((gcht (##table-get-eq-gcht table key))
1131              (val (##gc-hash-table-ref gcht key)))
1132         (if (##eq? val (macro-unused-obj))
1133           (cond ((##not (##eq? default-value (macro-absent-obj)))
1134                  default-value)
1135                 ((##not (##eq? (macro-table-init table) (macro-absent-obj)))
1136                  (macro-table-init table))
1137                 (else
1138                  (##raise-unbound-table-key-exception
1139                   table-ref
1140                   table
1141                   key)))
1142           val)))))
1143
1144 (define-prim (table-ref
1145               table
1146               key
1147               #!optional
1148               (default-value (macro-absent-obj)))
1149   (macro-force-vars (table key default-value)
1150     (macro-check-table table 1 (table-ref table key default-value)
1151       (##table-ref table key default-value))))
1152
1153 (define-prim (##table-resize! table)
1154   (##declare (not interrupts-enabled))
1155   (let ((gcht (macro-table-gcht table)))
1156     (let ((new-gcht
1157            (##gc-hash-table-resize! gcht (macro-table-loads table))))
1158       (macro-table-gcht-set! table new-gcht)
1159       (let loop ((i (macro-gc-hash-table-key0)))
1160         (if (##fixnum.< i (##vector-length gcht))
1161           (let ((key (##vector-ref gcht i)))
1162             (if (and (##not (##eq? key (macro-unused-obj)))
1163                      (##not (##eq? key (macro-deleted-obj))))
1164               (let ((val (##vector-ref gcht (##fixnum.+ i 1))))
1165                 (##table-set! table key val)))
1166             (let ()
1167               (##declare (interrupts-enabled))
1168               (loop (##fixnum.+ i 2))))
1169           (##void))))))
1170
1171 (define-prim (##table-set!
1172               table
1173               key
1174               #!optional
1175               (val (macro-absent-obj)))
1176   (##declare (not interrupts-enabled))
1177   (let ((test (macro-table-test table)))
1178     (if test
1179
1180       (##table-access
1181        table
1182        key
1183        (lambda (table key gcht probe2 val)
1184          ;; key was found at position "probe2"
1185          (if (##eq? val (macro-absent-obj))
1186            (let ((count (##fixnum.- (macro-gc-hash-table-count gcht) 1)))
1187              (macro-gc-hash-table-count-set! gcht count)
1188              (macro-gc-hash-table-key-set! gcht probe2 (macro-deleted-obj))
1189              (macro-gc-hash-table-val-set! gcht probe2 (macro-unused-obj))
1190              (if (##fixnum.< count (macro-gc-hash-table-min-count gcht))
1191                (##table-resize! table)
1192                (##void)))
1193            (begin
1194              (macro-gc-hash-table-val-set! gcht probe2 val)
1195              (##void))))
1196        (lambda (table key gcht probe2 deleted2 val)
1197          ;; key was not found (search ended at position "probe2" and the
1198          ;; first deleted entry encountered is at position "deleted2")
1199          (if (##eq? val (macro-absent-obj))
1200            (##void)
1201            (if deleted2
1202              (let ((count (##fixnum.+ (macro-gc-hash-table-count gcht) 1)))
1203                (macro-gc-hash-table-count-set! gcht count)
1204                (macro-gc-hash-table-key-set! gcht deleted2 key)
1205                (macro-gc-hash-table-val-set! gcht deleted2 val)
1206                (##void))
1207              (let ((count (##fixnum.+ (macro-gc-hash-table-count gcht) 1))
1208                    (free (##fixnum.- (macro-gc-hash-table-free gcht) 1)))
1209                (macro-gc-hash-table-count-set! gcht count)
1210                (macro-gc-hash-table-free-set! gcht free)
1211                (macro-gc-hash-table-key-set! gcht probe2 key)
1212                (macro-gc-hash-table-val-set! gcht probe2 val)
1213                (if (##fixnum.< free 0)
1214                  (##table-resize! table)
1215                  (##void))))))
1216        val)
1217
1218       (let ((gcht (##table-get-eq-gcht table key)))
1219         (if (##gc-hash-table-set! gcht key val)
1220           (let ((new-gcht
1221                  (##gc-hash-table-rehash!
1222                   gcht
1223                   (##gc-hash-table-resize! gcht (macro-table-loads table)))))
1224             (if (##mem-allocated? key)
1225               (macro-table-gcht-set! table new-gcht)
1226               (macro-table-hash-set! table new-gcht))))
1227         (##void)))))
1228
1229 (define-prim (table-set!
1230               table
1231               key
1232               #!optional
1233               (val (macro-absent-obj)))
1234   (macro-force-vars (table key val)
1235     (macro-check-table table 1 (table-set! table key val)
1236       (##table-set! table key val))))
1237
1238 (define-prim (##table-search proc table)
1239   (or (##gc-hash-table-search proc (macro-table-gcht table))
1240       (and (##not (macro-table-test table))
1241            (##gc-hash-table-search proc (macro-table-hash table)))))
1242
1243 (define-prim (table-search proc table)
1244   (macro-force-vars (proc table)
1245     (macro-check-procedure proc 1 (table-search proc table)
1246       (macro-check-table table 2 (table-search proc table)
1247         (##table-search proc table)))))
1248
1249 (define-prim (##table-for-each proc table)
1250   (##gc-hash-table-for-each proc (macro-table-gcht table))
1251   (if (##not (macro-table-test table))
1252     (##gc-hash-table-for-each proc (macro-table-hash table))))
1253
1254 (define-prim (table-for-each proc table)
1255   (macro-force-vars (proc table)
1256     (macro-check-procedure proc 1 (table-for-each proc table)
1257       (macro-check-table table 2 (table-for-each proc table)
1258         (##table-for-each proc table)))))
1259
1260 (define-prim (##table-foldl f base proc table)
1261   (let ((x (##gc-hash-table-foldl f base proc (macro-table-gcht table))))
1262     (if (macro-table-test table)
1263       x
1264       (##gc-hash-table-foldl f x proc (macro-table-hash table)))))
1265
1266 (define-prim (##table->list table)
1267   (let ((cons (lambda (x y) (##cons x y)))
1268         (rcons (lambda (x y) (##cons y x))))
1269     (##table-foldl rcons '() cons table)))
1270
1271 (define-prim (table->list table)
1272   (macro-force-vars (table)
1273     (macro-check-table table 1 (table->list table)
1274       (##table->list table))))
1275
1276 (define-prim (##list->table
1277               lst
1278               #!optional
1279               (size (macro-absent-obj))
1280               (init (macro-absent-obj))
1281               (weak-keys (macro-absent-obj))
1282               (weak-values (macro-absent-obj))
1283               (test (macro-absent-obj))
1284               (hash (macro-absent-obj))
1285               (min-load (macro-absent-obj))
1286               (max-load (macro-absent-obj)))
1287   (let ((table
1288          (##make-table
1289           size
1290           init
1291           weak-keys
1292           weak-values
1293           test
1294           hash
1295           min-load
1296           max-load)))
1297     (let loop ((x lst))
1298       (macro-force-vars (x)
1299         (if (##pair? x)
1300           (let ((couple (##car x)))
1301             (macro-force-vars (couple)
1302               (macro-check-pair-list
1303                couple
1304                1
1305                (list->table lst
1306                             size: size
1307                             init: init
1308                             weak-keys: weak-keys
1309                             weak-values: weak-values
1310                             test: test
1311                             hash: hash
1312                             min-load: min-load
1313                             max-load: max-load)
1314                (let ((key (##car couple)))
1315                  (if (##eq? table (##table-ref table key table))
1316                    (##table-set! table key (##cdr couple)))
1317                  (loop (##cdr x))))))
1318           (macro-check-list
1319            x
1320            1
1321            (list->table lst
1322                         size: size
1323                         init: init
1324                         weak-keys: weak-keys
1325                         weak-values: weak-values
1326                         test: test
1327                         hash: hash
1328                         min-load: min-load
1329                         max-load: max-load)
1330            table))))))
1331
1332 (define-prim (list->table
1333               lst
1334               #!key
1335               (size (macro-absent-obj))
1336               (init (macro-absent-obj))
1337               (weak-keys (macro-absent-obj))
1338               (weak-values (macro-absent-obj))
1339               (test (macro-absent-obj))
1340               (hash (macro-absent-obj))
1341               (min-load (macro-absent-obj))
1342               (max-load (macro-absent-obj)))
1343   (##list->table
1344    lst
1345    size
1346    init
1347    weak-keys
1348    weak-values
1349    test
1350    hash
1351    min-load
1352    max-load))
1353
1354 (define-prim (##table-copy table)
1355   (let* ((size
1356           (##table-length table))
1357          (init
1358           (macro-table-init table))
1359          (flags
1360           (macro-table-flags table))
1361          (weak-keys
1362           (##not (##fixnum.= 0 (##fixnum.bitwise-and
1363                                 flags
1364                                 (macro-gc-hash-table-flag-weak-keys)))))
1365          (weak-values
1366           (##not (##fixnum.= 0 (##fixnum.bitwise-and
1367                                 flags
1368                                 (macro-gc-hash-table-flag-weak-vals)))))
1369          (test-field
1370           (macro-table-test table))
1371          (test
1372           (or test-field
1373               (macro-absent-obj)))
1374          (hash
1375           (if test-field
1376             (macro-table-hash table)
1377             (macro-absent-obj)))
1378          (loads
1379           (macro-table-loads table))
1380          (min-load
1381           (##f64vector-ref loads 0))
1382          (max-load
1383           (##f64vector-ref loads 2)))
1384     (let ((t
1385            (##make-table
1386             size
1387             init
1388             weak-keys
1389             weak-values
1390             test
1391             hash
1392             min-load
1393             max-load)))
1394       (##table-for-each
1395        (lambda (k v)
1396          (##table-set! t k v))
1397        table)
1398       t)))
1399
1400 (define-prim (table-copy table)
1401   (macro-force-vars (table)
1402     (macro-check-table table 1 (table-copy table)
1403       (##table-copy table))))
1404
1405 (define-prim (##table-equal? table1 table2)
1406
1407   (##declare (not interrupts-enabled))
1408
1409   (and (##fixnum.= (macro-table-flags table1)
1410                    (macro-table-flags table2))
1411        (##eq? (macro-table-test table1)
1412               (macro-table-test table2))
1413        (if (macro-table-test table1)
1414          (##eq? (macro-table-hash table1)
1415                 (macro-table-hash table2))
1416          #t)
1417        (let* ((len1 (##table-length table1))
1418               (len2 (##table-length table2)))
1419          (and (##fixnum.= len1 len2)
1420               (##not (##table-search
1421                       (lambda (key1 val1)
1422                         (let ((val2
1423                                (##table-ref table2 key1 (macro-unused-obj))))
1424                           (##not (##equal? val1 val2))))
1425                       table1))))))
1426
1427 (define-prim (##table-equal?-hash table)
1428
1429   (define (combine a b)
1430     (##fixnum.bitwise-and
1431      (##fixnum.* (##fixnum.+ a (##fixnum.arithmetic-shift-left b 1))
1432                  331804471)
1433      (macro-max-fixnum32)))
1434
1435   (##table-foldl
1436    (lambda (a b) ;; must be associative and commutative
1437      (##fixnum.bitwise-xor a b))
1438    (combine
1439     (macro-table-flags table)
1440     (combine
1441      (##eq?-hash (macro-table-test table))
1442      (combine
1443       (if (macro-table-test table)
1444         (##eq?-hash (macro-table-hash table))
1445         0)
1446       (##table-length table))))
1447    (lambda (key val)
1448      (combine
1449       (if (macro-table-test table)
1450         (let ((f (macro-table-hash table)))
1451           (f key))
1452         0)
1453       (##equal?-hash val)))
1454    table))
1455
1456 ;;;----------------------------------------------------------------------------
1457
1458 ;;; Serial numbers.
1459
1460 (implement-library-type-unbound-serial-number-exception)
1461
1462 (define-prim (##raise-unbound-serial-number-exception proc . args)
1463   (##extract-procedure-and-arguments
1464    proc
1465    args
1466    #f
1467    #f
1468    #f
1469    (lambda (procedure arguments dummy1 dummy2 dummy3)
1470      (macro-raise
1471       (macro-make-unbound-serial-number-exception
1472        procedure
1473        arguments)))))
1474
1475 (define ##last-serial-number 0)
1476
1477 (define ##object-to-serial-number-table (##make-table 0 #f #t #f ##eq?))
1478 (define ##serial-number-to-object-table (##make-table 0 #f #f #t ##eq?))
1479
1480 (define-prim (##object->serial-number obj)
1481   (let loop ()
1482     (##declare (not interrupts-enabled))
1483     (or (##table-ref ##object-to-serial-number-table obj #f)
1484         (let* ((n ##last-serial-number)
1485                (n+1 (or (##fixnum.+? n 1) 0)))
1486           (set! ##last-serial-number n+1)
1487           (if (##table-ref ##serial-number-to-object-table n+1 #f)
1488             (loop)
1489             (begin
1490               (##table-set! ##object-to-serial-number-table obj n+1)
1491               (##table-set! ##serial-number-to-object-table n+1 obj)
1492               n+1))))))
1493
1494 (define-prim (object->serial-number obj)
1495   (##object->serial-number obj))
1496
1497 (define-prim (##serial-number->object
1498               sn
1499               #!optional
1500               (default-value (macro-absent-obj)))
1501   (let ((result
1502          (##table-ref ##serial-number-to-object-table sn (macro-unused-obj))))
1503     (cond ((##not (##eq? result (macro-unused-obj)))
1504            result)
1505           ((##eq? default-value (macro-absent-obj))
1506            (##raise-unbound-serial-number-exception serial-number->object sn))
1507           (else
1508            default-value))))
1509
1510 (define-prim (serial-number->object
1511               sn
1512               #!optional
1513               (default-value (macro-absent-obj)))
1514   (macro-force-vars (sn default-value)
1515     (macro-check-index sn 1 (serial-number->object sn default-value)
1516       (##serial-number->object sn default-value))))
1517
1518 ;;;============================================================================
1519
1520 ;;; Binary serialization/deserialization.
1521
1522 ;;;============================================================================
1523
1524 ;;; General object representation.
1525
1526 ;;; Type tags.
1527
1528 (##define-macro (macro-type-fixnum)   0)
1529 (##define-macro (macro-type-subtyped) 1)
1530 (##define-macro (macro-type-special)  2)
1531 (##define-macro (macro-type-pair)     3)
1532
1533 ;;; Subtype tags.
1534
1535 (##define-macro (macro-subtype-vector)       0)
1536 (##define-macro (macro-subtype-pair)         1)
1537 (##define-macro (macro-subtype-ratnum)       2)
1538 (##define-macro (macro-subtype-cpxnum)       3)
1539 (##define-macro (macro-subtype-structure)    4)
1540 (##define-macro (macro-subtype-boxvalues)    5)
1541 (##define-macro (macro-subtype-meroon)       6)
1542
1543 (##define-macro (macro-subtype-symbol)       8)
1544 (##define-macro (macro-subtype-keyword)      9)
1545 (##define-macro (macro-subtype-frame)        10)
1546 (##define-macro (macro-subtype-continuation) 11)
1547 (##define-macro (macro-subtype-promise)      12)
1548 (##define-macro (macro-subtype-weak)         13)
1549 (##define-macro (macro-subtype-procedure)    14)
1550 (##define-macro (macro-subtype-return)       15)
1551
1552 (##define-macro (macro-subtype-foreign)      18)
1553 (##define-macro (macro-subtype-string)       19)
1554 (##define-macro (macro-subtype-s8vector)     20)
1555 (##define-macro (macro-subtype-u8vector)     21)
1556 (##define-macro (macro-subtype-s16vector)    22)
1557 (##define-macro (macro-subtype-u16vector)    23)
1558 (##define-macro (macro-subtype-s32vector)    24)
1559 (##define-macro (macro-subtype-u32vector)    25)
1560 (##define-macro (macro-subtype-f32vector)    26)
1561
1562 ;; for alignment these 5 must be last:
1563 (##define-macro (macro-subtype-s64vector)    27)
1564 (##define-macro (macro-subtype-u64vector)    28)
1565 (##define-macro (macro-subtype-f64vector)    29)
1566 (##define-macro (macro-subtype-flonum)       30)
1567 (##define-macro (macro-subtype-bignum)       31)
1568
1569 (##define-macro (macro-absent-obj)  `(##type-cast -6 2))
1570 (##define-macro (macro-unused-obj)  `(##type-cast -14 2))
1571 (##define-macro (macro-deleted-obj) `(##type-cast -15 2))
1572
1573 (##define-macro (macro-slot index struct . val)
1574   (if (null? val)
1575     `(##vector-ref ,struct ,index)
1576     `(##vector-set! ,struct ,index ,@val)))
1577
1578 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1579
1580 ;;; Symbol objects
1581
1582 ;; A symbol is represented by an object vector of length 4
1583 ;; slot 0 = symbol name (a string or a fixnum <n> for a symbol named "g<n>")
1584 ;; slot 1 = hash code (non-negative fixnum)
1585 ;; slot 2 = link to next symbol in symbol table (#f for uninterned)
1586 ;; slot 3 = pointer to corresponding global variable (0 if none exists)
1587
1588 (##define-macro (macro-make-uninterned-symbol name hash)
1589   `(##subtype-set!
1590     (##vector ,name ,hash #f 0)
1591     (macro-subtype-symbol)))
1592
1593 (##define-macro (macro-symbol-name s)        `(macro-slot 0 ,s))
1594 (##define-macro (macro-symbol-name-set! s x) `(macro-slot 0 ,s ,x))
1595 (##define-macro (macro-symbol-hash s)        `(macro-slot 1 ,s))
1596 (##define-macro (macro-symbol-hash-set! s x) `(macro-slot 1 ,s ,x))
1597 (##define-macro (macro-symbol-next s)        `(macro-slot 2 ,s))
1598 (##define-macro (macro-symbol-next-set! s x) `(macro-slot 2 ,s ,x))
1599
1600 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1601
1602 ;;; Keyword objects
1603
1604 ;; A keyword is represented by an object vector of length 3
1605 ;; slot 0 = keyword name (a string or a fixnum <n> for a keyword named "g<n>")
1606 ;; slot 1 = hash code (non-negative fixnum)
1607 ;; slot 2 = link to next keyword in keyword table (#f for uninterned)
1608
1609 (##define-macro (macro-make-uninterned-keyword name hash)
1610   `(##subtype-set!
1611     (##vector ,name ,hash #f)
1612     (macro-subtype-keyword)))
1613
1614 (##define-macro (macro-keyword-name k)        `(macro-slot 0 ,k))
1615 (##define-macro (macro-keyword-name-set! k x) `(macro-slot 0 ,k ,x))
1616 (##define-macro (macro-keyword-hash k)        `(macro-slot 1 ,k))
1617 (##define-macro (macro-keyword-hash-set! k x) `(macro-slot 1 ,k ,x))
1618 (##define-macro (macro-keyword-next k)        `(macro-slot 2 ,k))
1619 (##define-macro (macro-keyword-next-set! k x) `(macro-slot 2 ,k ,x))
1620
1621 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1622
1623 (##define-macro (macro-ratnum-make num den)
1624   `(##subtype-set!
1625     (##vector ,num ,den)
1626     (macro-subtype-ratnum)))
1627
1628 (##define-macro (macro-ratnum-numerator r)          `(macro-slot 0 ,r))
1629 (##define-macro (macro-ratnum-numerator-set! r x)   `(macro-slot 0 ,r ,x))
1630 (##define-macro (macro-ratnum-denominator r)        `(macro-slot 1 ,r))
1631 (##define-macro (macro-ratnum-denominator-set! r x) `(macro-slot 1 ,r ,x))
1632
1633 (##define-macro (macro-cpxnum-make r i)
1634   `(##subtype-set!
1635     (##vector ,r ,i)
1636     (macro-subtype-cpxnum)))
1637
1638 (##define-macro (macro-cpxnum-real c)        `(macro-slot 0 ,c))
1639 (##define-macro (macro-cpxnum-real-set! c x) `(macro-slot 0 ,c ,x))
1640 (##define-macro (macro-cpxnum-imag c)        `(macro-slot 1 ,c))
1641 (##define-macro (macro-cpxnum-imag-set! c x) `(macro-slot 1 ,c ,x))
1642
1643 ;;;----------------------------------------------------------------------------
1644
1645 (##define-macro (shared-tag-mask)    #x80)
1646 (##define-macro (shared-tag)         #x80)
1647
1648 (##define-macro (other-tag-mask)     #xf0)
1649 (##define-macro (symbol-tag)         #x00)
1650 (##define-macro (string-tag)         #x10)
1651 (##define-macro (vector-tag)         #x20)
1652 (##define-macro (structure-tag)      #x30)
1653 (##define-macro (subprocedure-tag)   #x40)
1654 (##define-macro (exact-int-tag)      #x50)
1655
1656 (##define-macro (character-tag)      #x60)
1657 (##define-macro (flonum-tag)         #x61)
1658 (##define-macro (ratnum-tag)         #x62)
1659 (##define-macro (cpxnum-tag)         #x63)
1660 (##define-macro (pair-tag)           #x64)
1661 (##define-macro (continuation-tag)   #x65)
1662 (##define-macro (boxvalues-tag)      #x66)
1663 (##define-macro (ui-symbol-tag)      #x67)
1664 (##define-macro (keyword-tag)        #x68)
1665 (##define-macro (ui-keyword-tag)     #x69)
1666 (##define-macro (closure-tag)        #x6a)
1667 (##define-macro (frame-tag)          #x6b)
1668 (##define-macro (gchashtable-tag)    #x6c)
1669 (##define-macro (meroon-tag)         #x6d)
1670 (##define-macro (homvector-tag)      #x6e)
1671
1672 (##define-macro (false-tag)          #x70)
1673 (##define-macro (true-tag)           #x71)
1674 (##define-macro (nil-tag)            #x72)
1675 (##define-macro (eof-tag)            #x73)
1676 (##define-macro (void-tag)           #x74)
1677 (##define-macro (absent-tag)         #x75)
1678 (##define-macro (unbound-tag)        #x76)
1679 (##define-macro (unbound2-tag)       #x77)
1680 (##define-macro (optional-tag)       #x78)
1681 (##define-macro (key-tag)            #x79)
1682 (##define-macro (rest-tag)           #x7a)
1683 (##define-macro (unused-tag)         #x7b)
1684 (##define-macro (deleted-tag)        #x7c)
1685
1686 (##define-macro (s8vector-tag)       #x00)
1687 (##define-macro (u8vector-tag)       #x01)
1688 (##define-macro (s16vector-tag)      #x02)
1689 (##define-macro (u16vector-tag)      #x03)
1690 (##define-macro (s32vector-tag)      #x04)
1691 (##define-macro (u32vector-tag)      #x05)
1692 (##define-macro (f32vector-tag)      #x06)
1693 (##define-macro (s64vector-tag)      #x07)
1694 (##define-macro (u64vector-tag)      #x08)
1695 (##define-macro (f64vector-tag)      #x09)
1696
1697 (##define-macro (structure? obj) `(##structure? ,obj))
1698 (##define-macro (gc-hash-table? obj) `(##gc-hash-table? ,obj))
1699 (##define-macro (fixnum? obj) `(##fixnum? ,obj))
1700
1701 (define-prim (##object->u8vector
1702               obj
1703               #!optional
1704               (transform (macro-absent-obj)))
1705
1706 (##define-macro (subtype-set! obj subtype)
1707   `(##subtype-set! ,obj ,subtype))
1708
1709 (##define-macro (subvector-move! src-vect src-start src-end dst-vect dst-start)
1710   `(##subvector-move! ,src-vect ,src-start ,src-end ,dst-vect ,dst-start))
1711
1712 (##define-macro (max-fixnum)
1713   `##max-fixnum)
1714
1715 (##define-macro (max-char)
1716   `##max-char)
1717
1718
1719 (##define-macro (continuation? obj)
1720   `(##continuation? ,obj))
1721
1722 (##define-macro (continuation-frame cont)
1723   `(##continuation-frame ,cont))
1724
1725 (##define-macro (continuation-denv cont)
1726   `(##continuation-denv ,cont))
1727
1728 (##define-macro (frame? obj)
1729   `(##frame? ,obj))
1730
1731 (##define-macro (frame-fs frame)
1732   `(##frame-fs ,frame))
1733
1734 (##define-macro (frame-ret frame)
1735   `(##frame-ret ,frame))
1736
1737 (##define-macro (frame-ref frame i)
1738   `(##frame-ref ,frame ,i))
1739
1740 (##define-macro (frame-slot-live? frame i)
1741   `(##frame-slot-live? ,frame ,i))
1742
1743 (##define-macro (subprocedure-parent-name subproc)
1744   `(##subprocedure-parent-name ,subproc))
1745
1746 (##define-macro (subprocedure-id subproc)
1747   `(##subprocedure-id ,subproc))
1748
1749 (##define-macro (subprocedure-nb-closed subproc)
1750   `(##subprocedure-nb-closed ,subproc))
1751
1752 (##define-macro (closure? obj)
1753   `(##closure? ,obj))
1754
1755 (##define-macro (closure-code closure)
1756   `(##closure-code ,closure))
1757
1758 (##define-macro (closure-ref closure i)
1759   `(##closure-ref ,closure ,i))
1760
1761 (##define-macro (extract-bit-field size position n)
1762   `(##extract-bit-field ,size ,position ,n))
1763
1764 (##define-macro (bignum? obj)
1765   `(##bignum? ,obj))
1766
1767 (##define-macro (subtyped? obj)
1768   `(##subtyped? ,obj))
1769
1770 (##define-macro (flonum? obj)
1771   `(##flonum? ,obj))
1772
1773 (##define-macro (ratnum? obj)
1774   `(##ratnum? ,obj))
1775
1776 (##define-macro (cpxnum? obj)
1777   `(##cpxnum? ,obj))
1778
1779 (##define-macro (boxvalues? obj)
1780   `(##fixnum.= (##subtype ,obj) (macro-subtype-boxvalues)))
1781
1782
1783 (##define-macro (make-string . args)
1784   `(##make-string ,@args))
1785
1786 (##define-macro (string? . args)
1787   `(##string? ,@args))
1788
1789 (##define-macro (string-length str)
1790   `(##string-length ,str))
1791
1792 (##define-macro (string-ref str i)
1793   `(##string-ref ,str ,i))
1794
1795 (##define-macro (string-set! str i x)
1796   `(##string-set! ,str ,i ,x))
1797
1798
1799 (##define-macro (make-vector . args)
1800   `(##make-vector ,@args))
1801
1802 (##define-macro (vector? . args)
1803   `(##vector? ,@args))
1804
1805 (##define-macro (vector-length vect)
1806   `(##vector-length ,vect))
1807
1808 (##define-macro (vector-ref vect i)
1809   `(##vector-ref ,vect ,i))
1810
1811 (##define-macro (vector-set! vect i x)
1812   `(##vector-set! ,vect ,i ,x))
1813
1814
1815 (##define-macro (make-s8vector . args)
1816   `(##make-s8vector ,@args))
1817
1818 (##define-macro (s8vector? . args)
1819   `(##s8vector? ,@args))
1820
1821 (##define-macro (s8vector-length s8vect)
1822   `(##s8vector-length ,s8vect))
1823
1824 (##define-macro (s8vector-ref s8vect i)
1825   `(##s8vector-ref ,s8vect ,i))
1826
1827 (##define-macro (s8vector-set! s8vect i x)
1828   `(##s8vector-set! ,s8vect ,i ,x))
1829
1830 (##define-macro (s8vector-shrink! s8vect len)
1831   `(##s8vector-shrink! ,s8vect ,len))
1832
1833 (##define-macro (make-u8vector . args)
1834   `(##make-u8vector ,@args))
1835
1836 (##define-macro (u8vector? . args)
1837   `(##u8vector? ,@args))
1838
1839 (##define-macro (u8vector-length u8vect)
1840   `(##u8vector-length ,u8vect))
1841
1842 (##define-macro (u8vector-ref u8vect i)
1843   `(##u8vector-ref ,u8vect ,i))
1844
1845 (##define-macro (u8vector-set! u8vect i x)
1846   `(##u8vector-set! ,u8vect ,i ,x))
1847
1848 (##define-macro (u8vector-shrink! u8vect len)
1849   `(##u8vector-shrink! ,u8vect ,len))
1850
1851 (##define-macro (fifo->u8vector fifo start end)
1852   `(##fifo->u8vector ,fifo ,start ,end))
1853
1854
1855 (##define-macro (make-s16vector . args)
1856   `(##make-s16vector ,@args))
1857
1858 (##define-macro (s16vector? . args)
1859   `(##s16vector? ,@args))
1860
1861 (##define-macro (s16vector-length s16vect)
1862   `(##s16vector-length ,s16vect))
1863
1864 (##define-macro (s16vector-ref s16vect i)
1865   `(##s16vector-ref ,s16vect ,i))
1866
1867 (##define-macro (s16vector-set! s16vect i x)
1868   `(##s16vector-set! ,s16vect ,i ,x))
1869
1870 (##define-macro (s16vector-shrink! s16vect len)
1871   `(##s16vector-shrink! ,s16vect ,len))
1872
1873 (##define-macro (make-u16vector . args)
1874   `(##make-u16vector ,@args))
1875
1876 (##define-macro (u16vector? . args)
1877   `(##u16vector? ,@args))
1878
1879 (##define-macro (u16vector-length u16vect)
1880   `(##u16vector-length ,u16vect))
1881
1882 (##define-macro (u16vector-ref u16vect i)
1883   `(##u16vector-ref ,u16vect ,i))
1884
1885 (##define-macro (u16vector-set! u16vect i x)
1886   `(##u16vector-set! ,u16vect ,i ,x))
1887
1888 (##define-macro (u16vector-shrink! u16vect len)
1889   `(##u16vector-shrink! ,u16vect ,len))
1890
1891
1892 (##define-macro (make-s32vector . args)
1893   `(##make-s32vector ,@args))
1894
1895 (##define-macro (s32vector? . args)
1896   `(##s32vector? ,@args))
1897
1898 (##define-macro (s32vector-length s32vect)
1899   `(##s32vector-length ,s32vect))
1900
1901 (##define-macro (s32vector-ref s32vect i)
1902   `(##s32vector-ref ,s32vect ,i))
1903
1904 (##define-macro (s32vector-set! s32vect i x)
1905   `(##s32vector-set! ,s32vect ,i ,x))
1906
1907 (##define-macro (s32vector-shrink! s32vect len)
1908   `(##s32vector-shrink! ,s32vect ,len))
1909
1910 (##define-macro (make-u32vector . args)
1911   `(##make-u32vector ,@args))
1912
1913 (##define-macro (u32vector? . args)
1914   `(##u32vector? ,@args))
1915
1916 (##define-macro (u32vector-length u32vect)
1917   `(##u32vector-length ,u32vect))
1918
1919 (##define-macro (u32vector-ref u32vect i)
1920   `(##u32vector-ref ,u32vect ,i))
1921
1922 (##define-macro (u32vector-set! u32vect i x)
1923   `(##u32vector-set! ,u32vect ,i ,x))
1924
1925 (##define-macro (u32vector-shrink! u32vect len)
1926   `(##u32vector-shrink! ,u32vect ,len))
1927
1928
1929 (##define-macro (make-s64vector . args)
1930   `(##make-s64vector ,@args))
1931
1932 (##define-macro (s64vector? . args)
1933   `(##s64vector? ,@args))
1934
1935 (##define-macro (s64vector-length s64vect)
1936   `(##s64vector-length ,s64vect))
1937
1938 (##define-macro (s64vector-ref s64vect i)
1939   `(##s64vector-ref ,s64vect ,i))
1940
1941 (##define-macro (s64vector-set! s64vect i x)
1942   `(##s64vector-set! ,s64vect ,i ,x))
1943
1944 (##define-macro (s64vector-shrink! s64vect len)
1945   `(##s64vector-shrink! ,s64vect ,len))
1946
1947 (##define-macro (make-u64vector . args)
1948   `(##make-u64vector ,@args))
1949
1950 (##define-macro (u64vector? . args)
1951   `(##u64vector? ,@args))
1952
1953 (##define-macro (u64vector-length u64vect)
1954   `(##u64vector-length ,u64vect))
1955
1956 (##define-macro (u64vector-ref u64vect i)
1957   `(##u64vector-ref ,u64vect ,i))
1958
1959 (##define-macro (u64vector-set! u64vect i x)
1960   `(##u64vector-set! ,u64vect ,i ,x))
1961
1962 (##define-macro (u64vector-shrink! u64vect len)
1963   `(##u64vector-shrink! ,u64vect ,len))
1964
1965
1966 (##define-macro (make-f32vector . args)
1967   `(##make-f32vector ,@args))
1968
1969 (##define-macro (f32vector? . args)
1970   `(##f32vector? ,@args))
1971
1972 (##define-macro (f32vector-length f32vect)
1973   `(##f32vector-length ,f32vect))
1974
1975 (##define-macro (f32vector-ref f32vect i)
1976   `(##f32vector-ref ,f32vect ,i))
1977
1978 (##define-macro (f32vector-set! f32vect i x)
1979   `(##f32vector-set! ,f32vect ,i ,x))
1980
1981 (##define-macro (f32vector-shrink! f32vect len)
1982   `(##f32vector-shrink! ,f32vect ,len))
1983
1984 (##define-macro (make-f64vector . args)
1985   `(##make-f64vector ,@args))
1986
1987 (##define-macro (f64vector? . args)
1988   `(##f64vector? ,@args))
1989
1990 (##define-macro (f64vector-length f64vect)
1991   `(##f64vector-length ,f64vect))
1992
1993 (##define-macro (f64vector-ref f64vect i)
1994   `(##f64vector-ref ,f64vect ,i))
1995
1996 (##define-macro (f64vector-set! f64vect i x)
1997   `(##f64vector-set! ,f64vect ,i ,x))
1998
1999 (##define-macro (f64vector-shrink! f64vect len)
2000   `(##f64vector-shrink! ,f64vect ,len))
2001
2002
2003 (##define-macro (symbol? . args)
2004   `(##symbol? ,@args))
2005
2006 (##define-macro (symbol->string . args)
2007   `(##symbol->string ,@args))
2008
2009 (##define-macro (string->symbol . args)
2010   `(##string->symbol ,@args))
2011
2012 (##define-macro (keyword? . args)
2013   `(##keyword? ,@args))
2014
2015 (##define-macro (keyword->string . args)
2016   `(##keyword->string ,@args))
2017
2018 (##define-macro (string->keyword . args)
2019   `(##string->keyword ,@args))
2020
2021
2022 (##define-macro (+ . args)
2023   `(##fixnum.+ ,@args))
2024
2025 (##define-macro (- . args)
2026   `(##fixnum.- ,@args))
2027
2028 (##define-macro (* . args)
2029   `(##fixnum.* ,@args))
2030
2031 (##define-macro (< . args)
2032   `(##fixnum.< ,@args))
2033
2034 (##define-macro (> . args)
2035   `(##fixnum.> ,@args))
2036
2037 (##define-macro (= . args)
2038   `(##fixnum.= ,@args))
2039
2040 (##define-macro (>= . args)
2041   `(##fixnum.>= ,@args))
2042
2043 (##define-macro (<= . args)
2044   `(##fixnum.<= ,@args))
2045
2046 (##define-macro (bitwise-and . args)
2047   `(##fixnum.bitwise-and ,@args))
2048
2049 (##define-macro (bitwise-ior . args)
2050   `(##fixnum.bitwise-ior ,@args))
2051
2052 (##define-macro (arithmetic-shift-left . args)
2053   `(##fixnum.arithmetic-shift-left ,@args))
2054
2055 (##define-macro (arithmetic-shift-right . args)
2056   `(##fixnum.arithmetic-shift-right ,@args))
2057
2058 (##define-macro (generic.+ . args)
2059   `(##+ ,@args))
2060
2061 (##define-macro (generic.arithmetic-shift . args)
2062   `(##arithmetic-shift ,@args))
2063
2064 (##define-macro (generic.bit-set? . args)
2065   `(##bit-set? ,@args))
2066
2067 (##define-macro (generic.bitwise-ior . args)
2068   `(##bitwise-ior ,@args))
2069
2070 (##define-macro (generic.extract-bit-field . args)
2071   `(##extract-bit-field ,@args))
2072
2073 (##define-macro (generic.gcd . args)
2074   `(##gcd ,@args))
2075
2076 (##define-macro (generic.negative? . args)
2077   `(##negative? ,@args))
2078
2079 (##define-macro (integer-length . args)
2080   `(##integer-length ,@args))
2081
2082 (##define-macro (make-table . args)
2083   `(##make-table 0 #f #f #f ##eq?))
2084
2085 (##define-macro (table-ref . args)
2086   `(##table-ref ,@args))
2087
2088 (##define-macro (table-set! . args)
2089   `(##table-set! ,@args))
2090
2091 (##define-macro (uninterned-keyword? . args)
2092   `(##uninterned-keyword? ,@args))
2093
2094 (##define-macro (uninterned-symbol? . args)
2095   `(##uninterned-symbol? ,@args))
2096
2097
2098 (##define-macro (char->integer . args)
2099   `(##fixnum.<-char ,@args))
2100
2101 (##define-macro (integer->char . args)
2102   `(##fixnum.->char ,@args))
2103
2104
2105 (##define-macro (vector . args)
2106   `(##vector ,@args))
2107
2108
2109 (##define-macro (cons . args)
2110   `(##cons ,@args))
2111
2112 (##define-macro (pair? . args)
2113   `(##pair? ,@args))
2114
2115 (##define-macro (car . args)
2116   `(##car ,@args))
2117
2118 (##define-macro (cdr . args)
2119   `(##cdr ,@args))
2120
2121 (##define-macro (set-car! . args)
2122   `(##set-car! ,@args))
2123
2124 (##define-macro (set-cdr! . args)
2125   `(##set-cdr! ,@args))
2126
2127
2128 (##define-macro (procedure? . args)
2129   `(##procedure? ,@args))
2130
2131 (##define-macro (char? . args)
2132   `(##char? ,@args))
2133
2134 (##define-macro (real? . args)
2135   `(##real? ,@args))
2136
2137 (##define-macro (not . args)
2138   `(##not ,@args))
2139
2140 (##define-macro (eq? . args)
2141   `(##eq? ,@args))
2142
2143 ;;; Representation of fifos.
2144
2145 (##define-macro (macro-make-fifo)
2146   `(let ((fifo (##cons '() '())))
2147      (macro-fifo-tail-set! fifo fifo)
2148      fifo))
2149
2150 (##define-macro (macro-fifo-next fifo)        `(##cdr ,fifo))
2151 (##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
2152 (##define-macro (macro-fifo-tail fifo)        `(##car ,fifo))
2153 (##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
2154 (##define-macro (macro-fifo-elem fifo)        `(##car ,fifo))
2155 (##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
2156
2157 (##define-macro (macro-fifo->list fifo)
2158   `(macro-fifo-next ,fifo))
2159
2160 (##define-macro (macro-fifo-remove-all! fifo)
2161   `(let ((fifo ,fifo))
2162
2163      (##declare (not interrupts-enabled))
2164
2165      (let ((head (macro-fifo-next fifo)))
2166        (macro-fifo-tail-set! fifo fifo)
2167        (macro-fifo-next-set! fifo '())
2168        head)))
2169
2170 (##define-macro (macro-fifo-remove-head! fifo)
2171   `(let ((fifo ,fifo))
2172
2173      (##declare (not interrupts-enabled))
2174
2175      (let ((head (macro-fifo-next fifo)))
2176        (if (##pair? head)
2177          (let ((next (macro-fifo-next head)))
2178            (if (##null? next)
2179              (macro-fifo-tail-set! fifo fifo))
2180            (macro-fifo-next-set! fifo next)
2181            (macro-fifo-next-set! head '())))
2182        head)))
2183
2184 (##define-macro (macro-fifo-insert-at-tail! fifo elem)
2185   `(let ((fifo ,fifo) (elem ,elem))
2186      (let ((x (##cons elem '())))
2187
2188        (##declare (not interrupts-enabled))
2189
2190        (let ((tail (macro-fifo-tail fifo)))
2191          (macro-fifo-next-set! tail x)
2192          (macro-fifo-tail-set! fifo x)
2193          (##void)))))
2194
2195 (##define-macro (macro-fifo-insert-at-head! fifo elem)
2196   `(let ((fifo ,fifo) (elem ,elem))
2197      (let ((x (##cons elem '())))
2198
2199        (##declare (not interrupts-enabled))
2200
2201        ;; To obtain an atomic update of the fifo, we must force a
2202        ;; garbage-collection to occur right away if needed by the
2203        ;; ##cons, so that any finalization that might mutate this fifo
2204        ;; will be done before updating the fifo.
2205
2206        (##check-heap-limit)
2207
2208        (let ((head (macro-fifo-next fifo)))
2209          (if (##null? head)
2210            (macro-fifo-tail-set! fifo x))
2211          (macro-fifo-next-set! fifo x)
2212          (macro-fifo-next-set! x head)
2213          (##void)))))
2214
2215 (##define-macro (macro-fifo-advance-to-tail! fifo)
2216   `(let ((fifo ,fifo))
2217      ;; It is assumed that the fifo contains at least one element
2218      ;; (i.e. the fifo's tail does not change).
2219      (let ((new-head (macro-fifo-tail fifo)))
2220        (macro-fifo-next-set! fifo new-head)
2221        (macro-fifo-elem new-head))))
2222
2223 (##define-macro (macro-fifo-advance! fifo)
2224   `(let ((fifo ,fifo))
2225      ;; It is assumed that the fifo contains at least two elements
2226      ;; (i.e. the fifo's tail does not change).
2227      (let* ((head (macro-fifo-next fifo))
2228             (new-head (macro-fifo-next head)))
2229        (macro-fifo-next-set! fifo new-head)
2230        (macro-fifo-elem new-head))))
2231
2232
2233   (define (cannot-serialize obj)
2234     (error "can't serialize" obj))
2235
2236   (define chunk-len 256) ;; must be a power of 2
2237
2238   (define state
2239     (vector 0
2240             (macro-make-fifo)
2241             0
2242             (make-table test: ##eq?)
2243             (if (eq? transform (macro-absent-obj))
2244                 (lambda (x) x)
2245                 transform)))
2246
2247   (define (write-u8 x)
2248     (let ((ptr (vector-ref state 0)))
2249       (vector-set! state 0 (+ ptr 1))
2250       (let ((fifo (vector-ref state 1))
2251             (i (bitwise-and ptr (- chunk-len 1))))
2252         (u8vector-set!
2253          (if (= i 0)
2254              (let ((chunk (make-u8vector chunk-len)))
2255                (macro-fifo-insert-at-tail! fifo chunk)
2256                chunk)
2257              (macro-fifo-elem (macro-fifo-tail fifo)))
2258          i
2259          x))))
2260
2261   (define (get-output-u8vector)
2262     (let ((ptr (vector-ref state 0))
2263           (fifo (vector-ref state 1)))
2264       (if (and (< 0 ptr) (<= ptr chunk-len))
2265           (let ((u8vect (macro-fifo-elem (macro-fifo-tail fifo))))
2266             (u8vector-shrink! u8vect ptr)
2267             u8vect)
2268           (fifo->u8vector fifo 0 ptr))))
2269
2270   (define (share obj)
2271     (let ((n (table-ref (vector-ref state 3) obj #f)))
2272       (if n
2273           (begin
2274             (serialize-shared! n)
2275             #t)
2276           #f)))
2277
2278   (define (alloc! obj)
2279     (let ((n (vector-ref state 2)))
2280       (vector-set! state 2 (+ n 1))
2281       (table-set! (vector-ref state 3) obj n)))
2282
2283   (define (serialize-shared! n)
2284     (let ((lo (bitwise-and n #x7f))
2285           (hi (arithmetic-shift-right n 7)))
2286       (write-u8 (bitwise-ior (shared-tag) lo))
2287       (serialize-nonneg-fixnum! hi)))
2288
2289   (define (serialize-nonneg-fixnum! n)
2290     (let ((lo (bitwise-and n #x7f))
2291           (hi (arithmetic-shift-right n 7)))
2292       (if (= hi 0)
2293           (write-u8 lo)
2294           (begin
2295             (write-u8 (bitwise-ior #x80 lo))
2296             (serialize-nonneg-fixnum! hi)))))
2297
2298   (define (serialize-flonum-32! n)
2299     (serialize-exact-int-of-length!
2300      (##flonum.->ieee754-32 n)
2301      4))
2302
2303   (define (serialize-flonum-64! n)
2304     (serialize-exact-int-of-length!
2305      (##flonum.->ieee754-64 n)
2306      8))
2307
2308   (define (serialize-exact-int-of-length! n len)
2309     (if (fixnum? n)
2310         (let loop ((n n) (len len))
2311           (if (> len 0)
2312               (begin
2313                 (write-u8 (bitwise-and n #xff))
2314                 (loop (arithmetic-shift-right n 8) (- len 1)))))
2315         (let* ((len/2 (arithmetic-shift-right len 1))
2316                (len/2*8 (* len/2 8)))
2317           (serialize-exact-int-of-length!
2318            (generic.extract-bit-field len/2*8 0 n)
2319            len/2)
2320           (serialize-exact-int-of-length!
2321            (generic.arithmetic-shift n (- len/2*8))
2322            (- len len/2)))))
2323
2324   (define (exact-int-length n signed?)
2325     (arithmetic-shift-right
2326      (+ (integer-length n) (if signed? 8 7))
2327      3))
2328
2329   (define (serialize-exact-int! n)
2330     (or (share n)
2331         (let ((len (exact-int-length n #t)))
2332           (if (<= len 4)
2333               (write-u8 (bitwise-ior (exact-int-tag) (- #x0f len)))
2334               (begin
2335                 (write-u8 (bitwise-ior (exact-int-tag) #x0f))
2336                 (serialize-nonneg-fixnum! len)))
2337           (serialize-exact-int-of-length! n len)
2338           (alloc! n))))
2339
2340   (define (serialize-vector-like! vect tag)
2341     (let ((len (vector-length vect)))
2342       (if (< len #x0f)
2343           (begin
2344             (write-u8 (bitwise-ior tag len))
2345             (serialize-subvector! vect 0 len))
2346           (serialize-vector-like-long! vect (bitwise-ior tag #x0f)))))
2347
2348   (define (serialize-vector-like-long! vect tag)
2349     (let ((len (vector-length vect)))
2350       (write-u8 tag)
2351       (serialize-nonneg-fixnum! len)
2352       (serialize-subvector! vect 0 len)))
2353
2354   (define (serialize-subvector! vect start end)
2355     (let loop ((i start))
2356       (if (< i end)
2357           (begin
2358             (serialize! (vector-ref vect i))
2359             (loop (+ i 1))))))
2360
2361   (define (serialize-string-like! str tag mask)
2362     (let ((len (string-length str)))
2363       (if (< len mask)
2364           (begin
2365             (write-u8 (bitwise-ior tag len))
2366             (serialize-string! str))
2367           (begin
2368             (write-u8 (bitwise-ior tag mask))
2369             (serialize-nonneg-fixnum! len)
2370             (serialize-string! str)))))
2371
2372   (define (serialize-string! str)
2373     (serialize-elements!
2374      0
2375      (string-length str)
2376      (lambda (i)
2377        (serialize-nonneg-fixnum! (char->integer (string-ref str i))))))
2378
2379   (define (serialize-elements! start end serialize-element!)
2380     (let loop ((i start))
2381       (if (< i end)
2382           (begin
2383             (serialize-element! i)
2384             (loop (+ i 1))))))
2385
2386   (define (serialize-homintvector! vect vect-tag vect-length vect-ref elem-len)
2387     (or (share vect)
2388         (let ((len (vect-length vect)))
2389           (write-u8 (homvector-tag))
2390           (serialize-nonneg-fixnum!
2391            (bitwise-ior vect-tag (arithmetic-shift-left len 4)))
2392           (serialize-elements!
2393            0
2394            len
2395            (lambda (i)
2396              (serialize-exact-int-of-length!
2397               (vect-ref vect i)
2398               elem-len)))
2399           (alloc! vect))))
2400
2401   (define (serialize-homfloatvector! vect vect-tag vect-length vect-ref f32?)
2402     (or (share vect)
2403         (let ((len (vect-length vect)))
2404           (write-u8 (homvector-tag))
2405           (serialize-nonneg-fixnum!
2406            (bitwise-ior vect-tag (arithmetic-shift-left len 4)))
2407           (serialize-elements!
2408            0
2409            len
2410            (lambda (i)
2411              (let ((n (vect-ref vect i)))
2412                (if f32?
2413                    (serialize-flonum-32! n)
2414                    (serialize-flonum-64! n)))))
2415           (alloc! vect))))
2416
2417   (define (serialize-subprocedure! subproc tag mask)
2418     (or (share subproc)
2419         (let ((parent-name (subprocedure-parent-name subproc)))
2420           (if (not parent-name)
2421               (cannot-serialize subproc)
2422               (let ((subproc-id (subprocedure-id subproc)))
2423                 (if (< subproc-id mask)
2424                     (write-u8 (bitwise-ior tag subproc-id))
2425                     (begin
2426                       (write-u8 (bitwise-ior tag mask))
2427                       (serialize-nonneg-fixnum! subproc-id)))
2428                 (serialize! (##system-version))
2429                 (or (share parent-name)
2430                     (let ((str (symbol->string parent-name)))
2431                       (serialize-string-like! str 0 #x7f)
2432                       (alloc! parent-name)))
2433                 (alloc! subproc))))))
2434
2435   (define (serialize! obj)
2436     (let* ((transform (vector-ref state 4))
2437            (obj (transform obj)))
2438       (cond ((subtyped? obj)
2439
2440              (cond ((symbol? obj)
2441                     (or (share obj)
2442                         (begin
2443                           (if (uninterned-symbol? obj)
2444                               (begin
2445                                 (write-u8 (ui-symbol-tag))
2446                                 (serialize-string-like!
2447                                  (symbol->string obj)
2448                                  0
2449                                  #xff)
2450                                 (serialize-exact-int-of-length!
2451                                  (##symbol-hash obj)
2452                                  4))
2453                               (serialize-string-like!
2454                                (symbol->string obj)
2455                                (symbol-tag)
2456                                #x0f))
2457                           (write-u8 (if (##global-var? obj) 1 0))
2458                           (alloc! obj))))
2459
2460                    ((keyword? obj)
2461                     (or (share obj)
2462                         (begin
2463                           (if (uninterned-keyword? obj)
2464                               (begin
2465                                 (write-u8 (ui-keyword-tag))
2466                                 (serialize-string-like!
2467                                  (keyword->string obj)
2468                                  0
2469                                  #xff)
2470                                 (serialize-exact-int-of-length!
2471                                  (##keyword-hash obj)
2472                                  4))
2473                               (serialize-string-like!
2474                                (keyword->string obj)
2475                                (keyword-tag)
2476                                0))
2477                           (alloc! obj))))
2478
2479                    ((string? obj)
2480                     (or (share obj)
2481                         (begin
2482                           (serialize-string-like!
2483                            obj
2484                            (string-tag)
2485                            #x0f)
2486                           (alloc! obj))))
2487
2488                    ((vector? obj)
2489                     (or (share obj)
2490                         (begin
2491                           (alloc! obj)
2492                           (serialize-vector-like! obj (vector-tag)))))
2493
2494                    ((structure? obj)
2495                     (if (or (macro-thread? obj)
2496                             (macro-tgroup? obj)
2497                             (macro-mutex? obj)
2498                             (macro-condvar? obj))
2499                       (cannot-serialize obj)
2500                       (or (share obj)
2501                           (begin
2502                             (alloc! obj)
2503                             (serialize-vector-like! obj (structure-tag))))))
2504
2505                    ((procedure? obj)
2506                     (if (closure? obj)
2507
2508                         (or (share obj)
2509                             (begin
2510                               (write-u8 (closure-tag))
2511                               (let* ((subproc
2512                                       (closure-code obj))
2513                                      (nb-closed
2514                                       (subprocedure-nb-closed subproc)))
2515                                 (serialize-subprocedure! subproc 0 #x7f)
2516                                 (alloc! obj)
2517                                 (serialize-subvector! obj 1 (+ nb-closed 1)))))
2518
2519                         (serialize-subprocedure! obj (subprocedure-tag) #x0f)))
2520
2521                    ((flonum? obj)
2522                     (or (share obj)
2523                         (begin
2524                           (write-u8 (flonum-tag))
2525                           (serialize-flonum-64! obj)
2526                           (alloc! obj))))
2527
2528                    ((bignum? obj)
2529                     (serialize-exact-int! obj))
2530
2531                    ((ratnum? obj)
2532                     (or (share obj)
2533                         (begin
2534                           (write-u8 (ratnum-tag))
2535                           (serialize! (macro-ratnum-numerator obj))
2536                           (serialize! (macro-ratnum-denominator obj))
2537                           (alloc! obj))))
2538
2539                    ((cpxnum? obj)
2540                     (or (share obj)
2541                         (begin
2542                           (write-u8 (cpxnum-tag))
2543                           (serialize! (macro-cpxnum-real obj))
2544                           (serialize! (macro-cpxnum-imag obj))
2545                           (alloc! obj))))
2546
2547                    ((continuation? obj)
2548                     (let ()
2549
2550                       (define (serialize-cont-frame! cont)
2551                         (write-u8 (frame-tag))
2552                         (let ((subproc (##continuation-ret cont))
2553                               (fs (##continuation-fs cont)))
2554                           (serialize-subprocedure! subproc 0 #x7f)
2555                           (alloc! (##cons 11 22))
2556                           (let loop ((i fs))
2557                             (if (##fixnum.> i 0)
2558                                 (begin
2559                                   (serialize-cont-frame-ref! cont i)
2560                                   (loop (##fixnum.- i 1)))))))
2561
2562                       (define (serialize-cont-frame-ref! cont i)
2563                         (let* ((fs (##continuation-fs cont))
2564                                (j (##fixnum.+ (##fixnum.- fs i) 1)))
2565                           (if (##continuation-slot-live? cont j)
2566                               (if (##fixnum.= j (##fixnum.+ (##continuation-link cont) 1))
2567                                   (let ((next (##continuation-next cont)))
2568                                     (if next
2569                                         (serialize-cont-frame! next)
2570                                         (serialize! 0)))
2571                                   (serialize! (##continuation-ref cont j))))))
2572
2573                       (or (share obj)
2574                           (begin
2575                             (alloc! obj)
2576                             (write-u8 (continuation-tag))
2577                             (serialize-cont-frame! obj)
2578                             (serialize! (continuation-denv obj))))))
2579
2580                    ((frame? obj)
2581                     (or (share obj)
2582                         (begin
2583                           (write-u8 (frame-tag))
2584                           (let* ((subproc (frame-ret obj))
2585                                  (fs (frame-fs obj)))
2586                             (serialize-subprocedure! subproc 0 #x7f)
2587                             (alloc! obj)
2588                             (let loop ((i 1))
2589                               (if (<= i fs)
2590                                   (begin
2591                                     (if (frame-slot-live? obj i)
2592                                         (serialize! (frame-ref obj i)))
2593                                     (loop (+ i 1)))))))))
2594
2595                    ((boxvalues? obj)
2596                     (or (share obj)
2597                         (begin
2598                           (alloc! obj)
2599                           (serialize-vector-like-long! obj (boxvalues-tag)))))
2600
2601                    ((gc-hash-table? obj)
2602                     (or (share obj)
2603                         (begin
2604                           (alloc! obj)
2605                           (write-u8 (gchashtable-tag))
2606                           (let ()
2607                             (##declare (not interrupts-enabled))
2608                             (let ((len
2609                                    (vector-length obj))
2610                                   (flags
2611                                    (macro-gc-hash-table-flags obj))
2612                                   (count
2613                                    (macro-gc-hash-table-count obj))
2614                                   (min-count
2615                                    (macro-gc-hash-table-min-count obj))
2616                                   (free
2617                                    (macro-gc-hash-table-free obj)))
2618                               (serialize-nonneg-fixnum! len)
2619                               (serialize-nonneg-fixnum! flags)
2620                               (serialize-nonneg-fixnum! count)
2621                               (serialize-nonneg-fixnum! min-count)
2622                               (serialize-nonneg-fixnum! free))
2623                             (let loop ((i (macro-gc-hash-table-key0)))
2624                               (if (< i (vector-length obj))
2625                                   (let ((key (vector-ref obj i)))
2626                                     (if (and (not (eq? key (macro-unused-obj)))
2627                                              (not (eq? key (macro-deleted-obj))))
2628                                         (let ((val (vector-ref obj (+ i 1))))
2629                                           (serialize! key)
2630                                           (serialize! val)))
2631                                     (let ()
2632                                       (##declare (interrupts-enabled))
2633                                       (loop (+ i 2))))
2634                                   (serialize! (macro-unused-obj))))))))
2635
2636                    ((s8vector? obj)
2637                     (serialize-homintvector!
2638                      obj
2639                      (s8vector-tag)
2640                      (lambda (v) (s8vector-length v))
2641                      (lambda (v i) (s8vector-ref v i))
2642                      1))
2643
2644                    ((u8vector? obj)
2645                     (serialize-homintvector!
2646                      obj
2647                      (u8vector-tag)
2648                      (lambda (v) (u8vector-length v))
2649                      (lambda (v i) (u8vector-ref v i))
2650                      1))
2651
2652                    ((s16vector? obj)
2653                     (serialize-homintvector!
2654                      obj
2655                      (s16vector-tag)
2656                      (lambda (v) (s16vector-length v))
2657                      (lambda (v i) (s16vector-ref v i))
2658                      2))
2659
2660                    ((u16vector? obj)
2661                     (serialize-homintvector!
2662                      obj
2663                      (u16vector-tag)
2664                      (lambda (v) (u16vector-length v))
2665                      (lambda (v i) (u16vector-ref v i))
2666                      2))
2667
2668                    ((s32vector? obj)
2669                     (serialize-homintvector!
2670                      obj
2671                      (s32vector-tag)
2672                      (lambda (v) (s32vector-length v))
2673                      (lambda (v i) (s32vector-ref v i))
2674                      4))
2675
2676                    ((u32vector? obj)
2677                     (serialize-homintvector!
2678                      obj
2679                      (u32vector-tag)
2680                      (lambda (v) (u32vector-length v))
2681                      (lambda (v i) (u32vector-ref v i))
2682                      4))
2683
2684                    ((s64vector? obj)
2685                     (serialize-homintvector!
2686                      obj
2687                      (s64vector-tag)
2688                      (lambda (v) (s64vector-length v))
2689                      (lambda (v i) (s64vector-ref v i))
2690                      8))
2691
2692                    ((u64vector? obj)
2693                     (serialize-homintvector!
2694                      obj
2695                      (u64vector-tag)
2696                      (lambda (v) (u64vector-length v))
2697                      (lambda (v i) (u64vector-ref v i))
2698                      8))
2699
2700                    ((f32vector? obj)
2701                     (serialize-homfloatvector!
2702                      obj
2703                      (f32vector-tag)
2704                      (lambda (v) (f32vector-length v))
2705                      (lambda (v i) (f32vector-ref v i))
2706                      #t))
2707
2708                    ((f64vector? obj)
2709                     (serialize-homfloatvector!
2710                      obj
2711                      (f64vector-tag)
2712                      (lambda (v) (f64vector-length v))
2713                      (lambda (v i) (f64vector-ref v i))
2714                      #f))
2715
2716                    (else
2717                     (cannot-serialize obj))))
2718
2719             ((pair? obj)
2720              (or (share obj)
2721                  (begin
2722                    (alloc! obj)
2723                    (write-u8 (pair-tag))
2724                    (serialize! (car obj))
2725                    (serialize! (cdr obj)))))
2726
2727             ((fixnum? obj)
2728              (cond ((and (>= obj #x00)
2729                          (< obj #x0b))
2730                     (write-u8 (bitwise-ior (exact-int-tag) obj)))
2731                    ((and (>= obj #x-80)
2732                          (< obj #x80))
2733                     (write-u8 (bitwise-ior (exact-int-tag) #x0e))
2734                     (write-u8 (bitwise-and obj #xff)))
2735                    (else
2736                     (serialize-exact-int! obj))))
2737
2738             ((char? obj)
2739              (let ((n (char->integer obj)))
2740                (write-u8 (character-tag))
2741                (serialize-nonneg-fixnum! n)))
2742
2743             ((eq? obj #f)                  (write-u8 (false-tag)))
2744             ((eq? obj #t)                  (write-u8 (true-tag)))
2745             ((eq? obj '())                 (write-u8 (nil-tag)))
2746             ((eq? obj #!eof)               (write-u8 (eof-tag)))
2747             ((eq? obj #!void)              (write-u8 (void-tag)))
2748             ((eq? obj (macro-absent-obj))  (write-u8 (absent-tag)))
2749             ((eq? obj #!unbound)           (write-u8 (unbound-tag)))
2750             ((eq? obj #!unbound2)          (write-u8 (unbound2-tag)))
2751             ((eq? obj #!optional)          (write-u8 (optional-tag)))
2752             ((eq? obj #!key)               (write-u8 (key-tag)))
2753             ((eq? obj #!rest)              (write-u8 (rest-tag)))
2754             ((eq? obj (macro-unused-obj))  (write-u8 (unused-tag)))
2755             ((eq? obj (macro-deleted-obj)) (write-u8 (deleted-tag)))
2756
2757             (else
2758              (cannot-serialize obj)))))
2759
2760   (serialize! obj)
2761
2762   (get-output-u8vector))
2763
2764 (define-prim (object->u8vector
2765               obj
2766               #!optional
2767               (transform (macro-absent-obj)))
2768   (macro-force-vars (obj transform)
2769     (if (eq? transform (macro-absent-obj))
2770         (##object->u8vector obj)
2771         (macro-check-procedure transform 2 (object->u8vector obj transform)
2772           (##object->u8vector obj transform)))))
2773
2774 (define-prim (##u8vector->object
2775               u8vect
2776               #!optional
2777               (transform (macro-absent-obj)))
2778
2779 (##define-macro (subtype-set! obj subtype)
2780   `(##subtype-set! ,obj ,subtype))
2781
2782 (##define-macro (subvector-move! src-vect src-start src-end dst-vect dst-start)
2783   `(##subvector-move! ,src-vect ,src-start ,src-end ,dst-vect ,dst-start))
2784
2785 (##define-macro (max-fixnum)
2786   `##max-fixnum)
2787
2788 (##define-macro (max-char)
2789   `##max-char)
2790
2791
2792 (##define-macro (continuation? obj)
2793   `(##continuation? ,obj))
2794
2795 (##define-macro (continuation-frame cont)
2796   `(##continuation-frame ,cont))
2797
2798 (##define-macro (continuation-denv cont)
2799   `(##continuation-denv ,cont))
2800
2801 (##define-macro (frame? obj)
2802   `(##frame? ,obj))
2803
2804 (##define-macro (frame-fs frame)
2805   `(##frame-fs ,frame))
2806
2807 (##define-macro (frame-ret frame)
2808   `(##frame-ret ,frame))
2809
2810 (##define-macro (frame-ref frame i)
2811   `(##frame-ref ,frame ,i))
2812
2813 (##define-macro (frame-slot-live? frame i)
2814   `(##frame-slot-live? ,frame ,i))
2815
2816 (##define-macro (subprocedure-parent-name subproc)
2817   `(##subprocedure-parent-name ,subproc))
2818
2819 (##define-macro (subprocedure-id subproc)
2820   `(##subprocedure-id ,subproc))
2821
2822 (##define-macro (subprocedure-nb-closed subproc)
2823   `(##subprocedure-nb-closed ,subproc))
2824
2825 (##define-macro (closure? obj)
2826   `(##closure? ,obj))
2827
2828 (##define-macro (closure-code closure)
2829   `(##closure-code ,closure))
2830
2831 (##define-macro (closure-ref closure i)
2832   `(##closure-ref ,closure ,i))
2833
2834 (##define-macro (extract-bit-field size position n)
2835   `(##extract-bit-field ,size ,position ,n))
2836
2837 (##define-macro (bignum? obj)
2838   `(##bignum? ,obj))
2839
2840 (##define-macro (subtyped? obj)
2841   `(##subtyped? ,obj))
2842
2843 (##define-macro (flonum? obj)
2844   `(##flonum? ,obj))
2845
2846 (##define-macro (ratnum? obj)
2847   `(##ratnum? ,obj))
2848
2849 (##define-macro (cpxnum? obj)
2850   `(##cpxnum? ,obj))
2851
2852 (##define-macro (boxvalues? obj)
2853   `(##fixnum.= (##subtype ,obj) (macro-subtype-boxvalues)))
2854
2855
2856 (##define-macro (make-string . args)
2857   `(##make-string ,@args))
2858
2859 (##define-macro (string? . args)
2860   `(##string? ,@args))
2861
2862 (##define-macro (string-length str)
2863   `(##string-length ,str))
2864
2865 (##define-macro (string-ref str i)
2866   `(##string-ref ,str ,i))
2867
2868 (##define-macro (string-set! str i x)
2869   `(##string-set! ,str ,i ,x))
2870
2871
2872 (##define-macro (make-vector . args)
2873   `(##make-vector ,@args))
2874
2875 (##define-macro (vector? . args)
2876   `(##vector? ,@args))
2877
2878 (##define-macro (vector-length vect)
2879   `(##vector-length ,vect))
2880
2881 (##define-macro (vector-ref vect i)
2882   `(##vector-ref ,vect ,i))
2883
2884 (##define-macro (vector-set! vect i x)
2885   `(##vector-set! ,vect ,i ,x))
2886
2887
2888 (##define-macro (make-s8vector . args)
2889   `(##make-s8vector ,@args))
2890
2891 (##define-macro (s8vector? . args)
2892   `(##s8vector? ,@args))
2893
2894 (##define-macro (s8vector-length s8vect)
2895   `(##s8vector-length ,s8vect))
2896
2897 (##define-macro (s8vector-ref s8vect i)
2898   `(##s8vector-ref ,s8vect ,i))
2899
2900 (##define-macro (s8vector-set! s8vect i x)
2901   `(##s8vector-set! ,s8vect ,i ,x))
2902
2903 (##define-macro (s8vector-shrink! s8vect len)
2904   `(##s8vector-shrink! ,s8vect ,len))
2905
2906 (##define-macro (make-u8vector . args)
2907   `(##make-u8vector ,@args))
2908
2909 (##define-macro (u8vector? . args)
2910   `(##u8vector? ,@args))
2911
2912 (##define-macro (u8vector-length u8vect)
2913   `(##u8vector-length ,u8vect))
2914
2915 (##define-macro (u8vector-ref u8vect i)
2916   `(##u8vector-ref ,u8vect ,i))
2917
2918 (##define-macro (u8vector-set! u8vect i x)
2919   `(##u8vector-set! ,u8vect ,i ,x))
2920
2921 (##define-macro (u8vector-shrink! u8vect len)
2922   `(##u8vector-shrink! ,u8vect ,len))
2923
2924 (##define-macro (fifo->u8vector fifo start end)
2925   `(##fifo->u8vector ,fifo ,start ,end))
2926
2927
2928 (##define-macro (make-s16vector . args)
2929   `(##make-s16vector ,@args))
2930
2931 (##define-macro (s16vector? . args)
2932   `(##s16vector? ,@args))
2933
2934 (##define-macro (s16vector-length s16vect)
2935   `(##s16vector-length ,s16vect))
2936
2937 (##define-macro (s16vector-ref s16vect i)
2938   `(##s16vector-ref ,s16vect ,i))
2939
2940 (##define-macro (s16vector-set! s16vect i x)
2941   `(##s16vector-set! ,s16vect ,i ,x))
2942
2943 (##define-macro (s16vector-shrink! s16vect len)
2944   `(##s16vector-shrink! ,s16vect ,len))
2945
2946 (##define-macro (make-u16vector . args)
2947   `(##make-u16vector ,@args))
2948
2949 (##define-macro (u16vector? . args)
2950   `(##u16vector? ,@args))
2951
2952 (##define-macro (u16vector-length u16vect)
2953   `(##u16vector-length ,u16vect))
2954
2955 (##define-macro (u16vector-ref u16vect i)
2956   `(##u16vector-ref ,u16vect ,i))
2957
2958 (##define-macro (u16vector-set! u16vect i x)
2959   `(##u16vector-set! ,u16vect ,i ,x))
2960
2961 (##define-macro (u16vector-shrink! u16vect len)
2962   `(##u16vector-shrink! ,u16vect ,len))
2963
2964
2965 (##define-macro (make-s32vector . args)
2966   `(##make-s32vector ,@args))
2967
2968 (##define-macro (s32vector? . args)
2969   `(##s32vector? ,@args))
2970
2971 (##define-macro (s32vector-length s32vect)
2972   `(##s32vector-length ,s32vect))
2973
2974 (##define-macro (s32vector-ref s32vect i)
2975   `(##s32vector-ref ,s32vect ,i))
2976
2977 (##define-macro (s32vector-set! s32vect i x)
2978   `(##s32vector-set! ,s32vect ,i ,x))
2979
2980 (##define-macro (s32vector-shrink! s32vect len)
2981   `(##s32vector-shrink! ,s32vect ,len))
2982
2983 (##define-macro (make-u32vector . args)
2984   `(##make-u32vector ,@args))
2985
2986 (##define-macro (u32vector? . args)
2987   `(##u32vector? ,@args))
2988
2989 (##define-macro (u32vector-length u32vect)
2990   `(##u32vector-length ,u32vect))
2991
2992 (##define-macro (u32vector-ref u32vect i)
2993   `(##u32vector-ref ,u32vect ,i))
2994
2995 (##define-macro (u32vector-set! u32vect i x)
2996   `(##u32vector-set! ,u32vect ,i ,x))
2997
2998 (##define-macro (u32vector-shrink! u32vect len)
2999   `(##u32vector-shrink! ,u32vect ,len))
3000
3001
3002 (##define-macro (make-s64vector . args)
3003   `(##make-s64vector ,@args))
3004
3005 (##define-macro (s64vector? . args)
3006   `(##s64vector? ,@args))
3007
3008 (##define-macro (s64vector-length s64vect)
3009   `(##s64vector-length ,s64vect))
3010
3011 (##define-macro (s64vector-ref s64vect i)
3012   `(##s64vector-ref ,s64vect ,i))
3013
3014 (##define-macro (s64vector-set! s64vect i x)
3015   `(##s64vector-set! ,s64vect ,i ,x))
3016
3017 (##define-macro (s64vector-shrink! s64vect len)
3018   `(##s64vector-shrink! ,s64vect ,len))
3019
3020 (##define-macro (make-u64vector . args)
3021   `(##make-u64vector ,@args))
3022
3023 (##define-macro (u64vector? . args)
3024   `(##u64vector? ,@args))
3025
3026 (##define-macro (u64vector-length u64vect)
3027   `(##u64vector-length ,u64vect))
3028
3029 (##define-macro (u64vector-ref u64vect i)
3030   `(##u64vector-ref ,u64vect ,i))
3031
3032 (##define-macro (u64vector-set! u64vect i x)
3033   `(##u64vector-set! ,u64vect ,i ,x))
3034
3035 (##define-macro (u64vector-shrink! u64vect len)
3036   `(##u64vector-shrink! ,u64vect ,len))
3037
3038
3039 (##define-macro (make-f32vector . args)
3040   `(##make-f32vector ,@args))
3041
3042 (##define-macro (f32vector? . args)
3043   `(##f32vector? ,@args))
3044
3045 (##define-macro (f32vector-length f32vect)
3046   `(##f32vector-length ,f32vect))
3047
3048 (##define-macro (f32vector-ref f32vect i)
3049   `(##f32vector-ref ,f32vect ,i))
3050
3051 (##define-macro (f32vector-set! f32vect i x)
3052   `(##f32vector-set! ,f32vect ,i ,x))
3053
3054 (##define-macro (f32vector-shrink! f32vect len)
3055   `(##f32vector-shrink! ,f32vect ,len))
3056
3057 (##define-macro (make-f64vector . args)
3058   `(##make-f64vector ,@args))
3059
3060 (##define-macro (f64vector? . args)
3061   `(##f64vector? ,@args))
3062
3063 (##define-macro (f64vector-length f64vect)
3064   `(##f64vector-length ,f64vect))
3065
3066 (##define-macro (f64vector-ref f64vect i)
3067   `(##f64vector-ref ,f64vect ,i))
3068
3069 (##define-macro (f64vector-set! f64vect i x)
3070   `(##f64vector-set! ,f64vect ,i ,x))
3071
3072 (##define-macro (f64vector-shrink! f64vect len)
3073   `(##f64vector-shrink! ,f64vect ,len))
3074
3075
3076 (##define-macro (symbol? . args)
3077   `(##symbol? ,@args))
3078
3079 (##define-macro (symbol->string . args)
3080   `(##symbol->string ,@args))
3081
3082 (##define-macro (string->symbol . args)
3083   `(##string->symbol ,@args))
3084
3085 (##define-macro (keyword? . args)
3086   `(##keyword? ,@args))
3087
3088 (##define-macro (keyword->string . args)
3089   `(##keyword->string ,@args))
3090
3091 (##define-macro (string->keyword . args)
3092   `(##string->keyword ,@args))
3093
3094
3095 (##define-macro (+ . args)
3096   `(##fixnum.+ ,@args))
3097
3098 (##define-macro (- . args)
3099   `(##fixnum.- ,@args))
3100
3101 (##define-macro (* . args)
3102   `(##fixnum.* ,@args))
3103
3104 (##define-macro (< . args)
3105   `(##fixnum.< ,@args))
3106
3107 (##define-macro (> . args)
3108   `(##fixnum.> ,@args))
3109
3110 (##define-macro (= . args)
3111   `(##fixnum.= ,@args))
3112
3113 (##define-macro (>= . args)
3114   `(##fixnum.>= ,@args))
3115
3116 (##define-macro (<= . args)
3117   `(##fixnum.<= ,@args))
3118
3119 (##define-macro (bitwise-and . args)
3120   `(##fixnum.bitwise-and ,@args))
3121
3122 (##define-macro (bitwise-ior . args)
3123   `(##fixnum.bitwise-ior ,@args))
3124
3125 (##define-macro (arithmetic-shift-left . args)
3126   `(##fixnum.arithmetic-shift-left ,@args))
3127
3128 (##define-macro (arithmetic-shift-right . args)
3129   `(##fixnum.arithmetic-shift-right ,@args))
3130
3131 (##define-macro (generic.+ . args)
3132   `(##+ ,@args))
3133
3134 (##define-macro (generic.arithmetic-shift . args)
3135   `(##arithmetic-shift ,@args))
3136
3137 (##define-macro (generic.bit-set? . args)
3138   `(##bit-set? ,@args))
3139
3140 (##define-macro (generic.bitwise-ior . args)
3141   `(##bitwise-ior ,@args))
3142
3143 (##define-macro (generic.extract-bit-field . args)
3144   `(##extract-bit-field ,@args))
3145
3146 (##define-macro (generic.gcd . args)
3147   `(##gcd ,@args))
3148
3149 (##define-macro (generic.negative? . args)
3150   `(##negative? ,@args))
3151
3152 (##define-macro (integer-length . args)
3153   `(##integer-length ,@args))
3154
3155 (##define-macro (make-table . args)
3156   `(##make-table 0 #f #f #f ##eq?))
3157
3158 (##define-macro (table-ref . args)
3159   `(##table-ref ,@args))
3160
3161 (##define-macro (table-set! . args)
3162   `(##table-set! ,@args))
3163
3164 (##define-macro (uninterned-keyword? . args)
3165   `(##uninterned-keyword? ,@args))
3166
3167 (##define-macro (uninterned-symbol? . args)
3168   `(##uninterned-symbol? ,@args))
3169
3170
3171 (##define-macro (char->integer . args)
3172   `(##fixnum.<-char ,@args))
3173
3174 (##define-macro (integer->char . args)
3175   `(##fixnum.->char ,@args))
3176
3177
3178 (##define-macro (vector . args)
3179   `(##vector ,@args))
3180
3181
3182 (##define-macro (cons . args)
3183   `(##cons ,@args))
3184
3185 (##define-macro (pair? . args)
3186   `(##pair? ,@args))
3187
3188 (##define-macro (car . args)
3189   `(##car ,@args))
3190
3191 (##define-macro (cdr . args)
3192   `(##cdr ,@args))
3193
3194 (##define-macro (set-car! . args)
3195   `(##set-car! ,@args))
3196
3197 (##define-macro (set-cdr! . args)
3198   `(##set-cdr! ,@args))
3199
3200
3201 (##define-macro (procedure? . args)
3202   `(##procedure? ,@args))
3203
3204 (##define-macro (char? . args)
3205   `(##char? ,@args))
3206
3207 (##define-macro (real? . args)
3208   `(##real? ,@args))
3209
3210 (##define-macro (not . args)
3211   `(##not ,@args))
3212
3213 (##define-macro (eq? . args)
3214   `(##eq? ,@args))
3215
3216 ;;; Representation of fifos.
3217
3218 (##define-macro (macro-make-fifo)
3219   `(let ((fifo (##cons '() '())))
3220      (macro-fifo-tail-set! fifo fifo)
3221      fifo))
3222
3223 (##define-macro (macro-fifo-next fifo)        `(##cdr ,fifo))
3224 (##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
3225 (##define-macro (macro-fifo-tail fifo)        `(##car ,fifo))
3226 (##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
3227 (##define-macro (macro-fifo-elem fifo)        `(##car ,fifo))
3228 (##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
3229
3230 (##define-macro (macro-fifo->list fifo)
3231   `(macro-fifo-next ,fifo))
3232
3233 (##define-macro (macro-fifo-remove-all! fifo)
3234   `(let ((fifo ,fifo))
3235
3236      (##declare (not interrupts-enabled))
3237
3238      (let ((head (macro-fifo-next fifo)))
3239        (macro-fifo-tail-set! fifo fifo)
3240        (macro-fifo-next-set! fifo '())
3241        head)))
3242
3243 (##define-macro (macro-fifo-remove-head! fifo)
3244   `(let ((fifo ,fifo))
3245
3246      (##declare (not interrupts-enabled))
3247
3248      (let ((head (macro-fifo-next fifo)))
3249        (if (##pair? head)
3250          (let ((next (macro-fifo-next head)))
3251            (if (##null? next)
3252              (macro-fifo-tail-set! fifo fifo))
3253            (macro-fifo-next-set! fifo next)
3254            (macro-fifo-next-set! head '())))
3255        head)))
3256
3257 (##define-macro (macro-fifo-insert-at-tail! fifo elem)
3258   `(let ((fifo ,fifo) (elem ,elem))
3259      (let ((x (##cons elem '())))
3260
3261        (##declare (not interrupts-enabled))
3262
3263        (let ((tail (macro-fifo-tail fifo)))
3264          (macro-fifo-next-set! tail x)
3265          (macro-fifo-tail-set! fifo x)
3266          (##void)))))
3267
3268 (##define-macro (macro-fifo-insert-at-head! fifo elem)
3269   `(let ((fifo ,fifo) (elem ,elem))
3270      (let ((x (##cons elem '())))
3271
3272        (##declare (not interrupts-enabled))
3273
3274        ;; To obtain an atomic update of the fifo, we must force a
3275        ;; garbage-collection to occur right away if needed by the
3276        ;; ##cons, so that any finalization that might mutate this fifo
3277        ;; will be done before updating the fifo.
3278
3279        (##check-heap-limit)
3280
3281        (let ((head (macro-fifo-next fifo)))
3282          (if (##null? head)
3283            (macro-fifo-tail-set! fifo x))
3284          (macro-fifo-next-set! fifo x)
3285          (macro-fifo-next-set! x head)
3286          (##void)))))
3287
3288 (##define-macro (macro-fifo-advance-to-tail! fifo)
3289   `(let ((fifo ,fifo))
3290      ;; It is assumed that the fifo contains at least one element
3291      ;; (i.e. the fifo's tail does not change).
3292      (let ((new-head (macro-fifo-tail fifo)))
3293        (macro-fifo-next-set! fifo new-head)
3294        (macro-fifo-elem new-head))))
3295
3296 (##define-macro (macro-fifo-advance! fifo)
3297   `(let ((fifo ,fifo))
3298      ;; It is assumed that the fifo contains at least two elements
3299      ;; (i.e. the fifo's tail does not change).
3300      (let* ((head (macro-fifo-next fifo))
3301             (new-head (macro-fifo-next head)))
3302        (macro-fifo-next-set! fifo new-head)
3303        (macro-fifo-elem new-head))))
3304
3305
3306   (define (err)
3307     (error "deserialization error"))
3308
3309   (define state
3310     (vector 0
3311             u8vect
3312             0
3313             (make-vector 64)
3314             (if (eq? transform (macro-absent-obj))
3315                 (lambda (x) x)
3316                 transform)))
3317
3318   (define (read-u8)
3319     (let ((ptr (vector-ref state 0))
3320           (u8vect (vector-ref state 1)))
3321       (if (< ptr (u8vector-length u8vect))
3322           (begin
3323             (vector-set! state 0 (+ ptr 1))
3324             (u8vector-ref u8vect ptr))
3325           (err))))
3326
3327   (define (eof?)
3328     (let ((ptr (vector-ref state 0))
3329           (u8vect (vector-ref state 1)))
3330       (= ptr (u8vector-length u8vect))))
3331
3332   (define (alloc! obj)
3333     (let* ((n (vector-ref state 2))
3334            (vect (vector-ref state 3))
3335            (len (vector-length vect)))
3336       (vector-set! state 2 (+ n 1))
3337       (if (= n len)
3338           (let* ((new-len (+ (arithmetic-shift-right (* len 3) 1) 1))
3339                  (new-vect (make-vector new-len)))
3340             (vector-set! state 3 new-vect)
3341             (subvector-move! vect 0 n new-vect 0)
3342             (vector-set! new-vect n obj))
3343           (vector-set! vect n obj))
3344       n))
3345
3346   (define (shared-ref i)
3347     (let* ((n (vector-ref state 2))
3348            (vect (vector-ref state 3)))
3349       (if (< i n)
3350           (vector-ref vect i)
3351           (err))))
3352
3353   (define (deserialize-nonneg-fixnum! n shift)
3354     (let loop ((n n)
3355                (shift shift)
3356                (range (arithmetic-shift-right (max-fixnum) shift)))
3357       (if (= range 0)
3358           (err)
3359           (let ((x (read-u8)))
3360             (if (< x #x80)
3361                 (if (< range x)
3362                     (err)
3363                     (bitwise-ior n (arithmetic-shift-left x shift)))
3364                 (let ((b (bitwise-and x #x7f)))
3365                   (if (< range b)
3366                       (err)
3367                       (loop (bitwise-ior n (arithmetic-shift-left b shift))
3368                             (+ shift 7)
3369                             (arithmetic-shift-right range 7)))))))))
3370
3371   (define (deserialize-flonum-32!)
3372     (let ((n (deserialize-nonneg-exact-int-of-length! 4)))
3373       (##flonum.<-ieee754-32 n)))
3374
3375   (define (deserialize-flonum-64!)
3376     (let ((n (deserialize-nonneg-exact-int-of-length! 8)))
3377       (##flonum.<-ieee754-64 n)))
3378
3379   (define (deserialize-nonneg-exact-int-of-length! len)
3380     (if (<= len 3) ;; result fits in a 32 bit fixnum?
3381         (let ((a (read-u8)))
3382           (if (= len 1)
3383               a
3384               (+ a
3385                  (arithmetic-shift-left
3386                   (let ((b (read-u8)))
3387                     (if (= len 2)
3388                         b
3389                         (+ b
3390                            (arithmetic-shift-left
3391                             (let ((c (read-u8)))
3392                               c)
3393                             8))))
3394                   8))))
3395         (let* ((len/2 (arithmetic-shift-right len 1))
3396                (a (deserialize-nonneg-exact-int-of-length! len/2))
3397                (b (deserialize-nonneg-exact-int-of-length! (- len len/2))))
3398           (generic.bitwise-ior a (generic.arithmetic-shift b (* 8 len/2))))))
3399
3400   (define (deserialize-exact-int-of-length! len)
3401     (let ((n (deserialize-nonneg-exact-int-of-length! len)))
3402       (if (generic.bit-set? (- (* 8 len) 1) n)
3403           (generic.+ n (generic.arithmetic-shift -1 (* 8 len)))
3404           n)))
3405
3406   (define (deserialize-string! x mask)
3407     (deserialize-string-of-length!
3408      (let ((lo (bitwise-and x mask)))
3409        (if (< lo mask)
3410            lo
3411            (deserialize-nonneg-fixnum! 0 0)))))
3412
3413   (define (deserialize-string-of-length! len)
3414     (let ((obj (make-string len)))
3415       (let loop ((i 0))
3416         (if (< i len)
3417             (let ((n (deserialize-nonneg-fixnum! 0 0)))
3418               (if (<= n (max-char))
3419                   (begin
3420                     (string-set! obj i (integer->char n))
3421                     (loop (+ i 1)))
3422                   (err)))
3423             obj))))
3424
3425   (define (deserialize-vector-like! subtype x)
3426     (let* ((len (bitwise-and x #x0f)))
3427       (if (< len #x0f)
3428           (deserialize-vector-like-fill! subtype len)
3429           (deserialize-vector-like-long! subtype))))
3430
3431   (define (deserialize-vector-like-long! subtype)
3432     (let ((len (deserialize-nonneg-fixnum! 0 0)))
3433       (deserialize-vector-like-fill! subtype len)))
3434
3435   (define (deserialize-vector-like-fill! subtype len)
3436     (let ((obj (make-vector len)))
3437       (alloc! obj)
3438       (let loop ((i 0))
3439         (if (< i len)
3440             (begin
3441               (vector-set! obj i (deserialize!))
3442               (loop (+ i 1)))
3443             (begin
3444               (subtype-set! obj subtype)
3445               obj)))))
3446
3447   (define (deserialize-homintvector! make-vect vect-set! elem-len signed? len)
3448     (let ((obj (make-vect len)))
3449       (let loop ((i 0))
3450         (if (< i len)
3451             (begin
3452               (vect-set!
3453                obj
3454                i
3455                (if signed?
3456                    (deserialize-exact-int-of-length! elem-len)
3457                    (deserialize-nonneg-exact-int-of-length! elem-len)))
3458               (loop (+ i 1)))
3459             (begin
3460               (alloc! obj)
3461               obj)))))
3462
3463   (define (deserialize-homfloatvector! make-vect vect-set! len f32?)
3464     (let ((obj (make-vect len)))
3465       (let loop ((i 0))
3466         (if (< i len)
3467             (begin
3468               (vect-set!
3469                obj
3470                i
3471                (if f32?
3472                    (deserialize-flonum-32!)
3473                    (deserialize-flonum-64!)))
3474               (loop (+ i 1)))
3475             (begin
3476               (alloc! obj)
3477               obj)))))
3478
3479   (define (deserialize-subprocedure!)
3480     (let ((x (read-u8)))
3481       (if (>= x (shared-tag))
3482           (shared-ref
3483            (deserialize-nonneg-fixnum! (bitwise-and x #x7f) 7))
3484           (let ((subproc-id
3485                  (let ((id (bitwise-and x #x7f)))
3486                    (if (< id #x7f)
3487                        id
3488                        (deserialize-nonneg-fixnum! 0 0)))))
3489             (deserialize-subprocedure-with-id! subproc-id)))))
3490
3491   (define (deserialize-subprocedure-with-id! subproc-id)
3492     (let ((v (deserialize!)))
3493       (if (not (eq? v (##system-version)))
3494           (err)
3495           (let* ((x
3496                   (read-u8))
3497                  (parent-name
3498                   (if (>= x (shared-tag))
3499                       (let ((name
3500                              (shared-ref
3501                               (deserialize-nonneg-fixnum!
3502                                (bitwise-and x #x7f)
3503                                7))))
3504                         (if (not (symbol? name))
3505                             (err)
3506                             name))
3507                       (let ((name
3508                              (string->symbol (deserialize-string! x #x7f))))
3509                         (alloc! name)
3510                         name)))
3511                  (parent
3512                   (##global-var-primitive-ref
3513                    (##make-global-var parent-name))))
3514             (if (not (procedure? parent)) ;; should also check subproc-id
3515                 (err)
3516                 (let ((obj (##make-subprocedure parent subproc-id)))
3517                   (alloc! obj)
3518                   obj))))))
3519
3520   (define (create-global-var-if-needed sym)
3521     (let ((x (read-u8)))
3522       (if (= x 1)
3523           (##make-global-var sym))))
3524
3525   (define (deserialize-without-transform!)
3526     (let ((x (read-u8)))
3527
3528       (cond ((>= x (shared-tag))
3529              (shared-ref
3530               (deserialize-nonneg-fixnum! (bitwise-and x #x7f) 7)))
3531
3532             ((>= x (false-tag))
3533              (cond ((= x (false-tag))
3534                     #f)
3535
3536                    ((= x (true-tag))
3537                     #t)
3538
3539                    ((= x (nil-tag))
3540                     '())
3541
3542                    ((= x (eof-tag))
3543                     #!eof)
3544
3545                    ((= x (void-tag))
3546                     #!void)
3547
3548                    ((= x (absent-tag))
3549                     (macro-absent-obj))
3550
3551                    ((= x (unbound-tag))
3552                     #!unbound)
3553
3554                    ((= x (unbound2-tag))
3555                     #!unbound2)
3556
3557                    ((= x (optional-tag))
3558                     #!optional)
3559
3560                    ((= x (key-tag))
3561                     #!key)
3562
3563                    ((= x (rest-tag))
3564                     #!rest)
3565
3566                    ((= x (unused-tag))
3567                     (macro-unused-obj))
3568
3569                    ((= x (deleted-tag))
3570                     (macro-deleted-obj))
3571
3572                    (else
3573                     (err))))
3574
3575             ((>= x (character-tag))
3576              (cond ((= x (character-tag))
3577                     (let ((n (deserialize-nonneg-fixnum! 0 0)))
3578                       (if (<= n (max-char))
3579                           (integer->char n)
3580                           (err))))
3581
3582                    ((= x (flonum-tag))
3583                     (let ((obj (deserialize-flonum-64!)))
3584                       (alloc! obj)
3585                       obj))
3586
3587                    ((= x (ratnum-tag))
3588                     (let* ((num (deserialize!))
3589                            (den (deserialize!)))
3590                       (if (or (and (fixnum? den)
3591                                    (<= den 1))
3592                               (and (bignum? den)
3593                                    (generic.negative? den))
3594                               (not (eq? 1 (generic.gcd num den))))
3595                           (err)
3596                           (let ((obj (macro-ratnum-make num den)))
3597                             (alloc! obj)
3598                             obj))))
3599
3600                    ((= x (cpxnum-tag))
3601                     (let* ((real (deserialize!))
3602                            (imag (deserialize!)))
3603                       (if (or (not (real? real))
3604                               (not (real? imag)))
3605                           (err)
3606                           (let ((obj (macro-cpxnum-make real imag)))
3607                             (alloc! obj)
3608                             obj))))
3609
3610                    ((= x (pair-tag))
3611                     (let ((obj (cons #f #f)))
3612                       (alloc! obj)
3613                       (let* ((a (deserialize!))
3614                              (d (deserialize!)))
3615                         (set-car! obj a)
3616                         (set-cdr! obj d)
3617                         obj)))
3618
3619                    ((= x (continuation-tag))
3620                     (let ((obj (vector #f #f)))
3621                       (alloc! obj)
3622                       (let* ((frame (deserialize!))
3623                              (denv (deserialize!)))
3624                         (if (not (frame? frame)) ;; should also check denv
3625                             (err)
3626                             (begin
3627                               (vector-set! obj 0 frame)
3628                               (vector-set! obj 1 denv)
3629                               (subtype-set! obj (macro-subtype-continuation))
3630                               obj)))))
3631
3632                    ((= x (boxvalues-tag))
3633                     (deserialize-vector-like-long!
3634                      (macro-subtype-boxvalues)))
3635
3636                    ((= x (ui-symbol-tag))
3637                     (let* ((y (read-u8))
3638                            (name (deserialize-string! y #xff))
3639                            (hash (deserialize-exact-int-of-length! 4))
3640                            (obj (macro-make-uninterned-symbol name hash)))
3641                       (create-global-var-if-needed obj)
3642                       (alloc! obj)
3643                       obj))
3644
3645                    ((= x (keyword-tag))
3646                     (let* ((name (deserialize-string! 0 0))
3647                            (obj (string->keyword name)))
3648                       (alloc! obj)
3649                       obj))
3650
3651                    ((= x (ui-keyword-tag))
3652                     (let* ((y (read-u8))
3653                            (name (deserialize-string! y #xff))
3654                            (hash (deserialize-exact-int-of-length! 4))
3655                            (obj (macro-make-uninterned-keyword name hash)))
3656                       (alloc! obj)
3657                       obj))
3658
3659                    ((= x (closure-tag))
3660                     (let ((subproc (deserialize-subprocedure!)))
3661                       (if #f;;;;;;;not subprocedure
3662                           (err)
3663                           (let ((nb-closed
3664                                  (subprocedure-nb-closed subproc)))
3665                             (if #f;;;;; nb-closed = 0
3666                                 (err)
3667                                 (let ((obj (make-vector (+ nb-closed 1))))
3668                                   (vector-set! obj 0 subproc)
3669                                   (alloc! obj)
3670                                   (let loop ((i 1))
3671                                     (if (<= i nb-closed)
3672                                         (begin
3673                                           (vector-set! obj i (deserialize!))
3674                                           (loop (+ i 1)))
3675                                         (begin
3676                                           (subtype-set!
3677                                            obj
3678                                            (macro-subtype-procedure))
3679                                           obj)))))))))
3680
3681                    ((= x (frame-tag))
3682                     (let ((subproc (deserialize-subprocedure!)))
3683                       (if (not (##return? subproc))
3684                           (err)
3685                           (let* ((fs (##return-fs subproc))
3686                                  (obj (make-vector (+ fs 1))))
3687                             (vector-set! obj 0 subproc)
3688                             (alloc! obj)
3689                             (let loop ((i 1))
3690                               (if (<= i fs)
3691                                   (begin
3692                                     (vector-set!
3693                                      obj
3694                                      (+ (- fs i) 1)
3695                                      (if (frame-slot-live? obj i)
3696                                          (deserialize!)
3697                                          0))
3698                                     (loop (+ i 1)))
3699                                   (begin
3700                                     (subtype-set! obj (macro-subtype-frame))
3701                                     obj)))))))
3702
3703                    ((= x (gchashtable-tag))
3704                     (let* ((len (deserialize-nonneg-fixnum! 0 0))
3705                            (flags (deserialize-nonneg-fixnum! 0 0))
3706                            (count (deserialize-nonneg-fixnum! 0 0))
3707                            (min-count (deserialize-nonneg-fixnum! 0 0))
3708                            (free (deserialize-nonneg-fixnum! 0 0)))
3709                       (if #f;;;;;;;;parameters OK?
3710                           (err)
3711                           (let ((obj (make-vector len (macro-unused-obj))))
3712                             (alloc! obj)
3713                             (macro-gc-hash-table-flags-set!
3714                              obj
3715                              (bitwise-ior ;; force rehash at next access!
3716                               flags
3717                               (macro-gc-hash-table-flag-need-rehash)))
3718                             (macro-gc-hash-table-count-set! obj count)
3719                             (macro-gc-hash-table-min-count-set! obj min-count)
3720                             (macro-gc-hash-table-free-set! obj free)
3721                             (let loop ((i (macro-gc-hash-table-key0)))
3722                               (if (< i (vector-length obj))
3723                                   (let ((key (deserialize!)))
3724                                     (if (not (eq? key (macro-unused-obj)))
3725                                         (let ((val (deserialize!)))
3726                                           (vector-set! obj i key)
3727                                           (vector-set! obj (+ i 1) val)
3728                                           (loop (+ i 2)))
3729                                         (begin
3730                                           (subtype-set!
3731                                            obj
3732                                            (macro-subtype-weak))
3733                                           obj)))
3734                                   (err)))))))
3735
3736                    ((= x (meroon-tag))
3737                     (deserialize-vector-like-long!
3738                      (macro-subtype-meroon)))
3739
3740                    ((= x (homvector-tag))
3741                     (let* ((len/type
3742                             (deserialize-nonneg-fixnum! 0 0))
3743                            (len
3744                             (arithmetic-shift-right len/type 4))
3745                            (type
3746                             (bitwise-and len/type #x0f)))
3747                       (cond ((= type (s8vector-tag))
3748                              (deserialize-homintvector!
3749                               (lambda (n) (make-s8vector n))
3750                               (lambda (v i n) (s8vector-set! v i n))
3751                               1
3752                               #t
3753                               len))
3754                             ((= type (u8vector-tag))
3755                              (deserialize-homintvector!
3756                               (lambda (n) (make-u8vector n))
3757                               (lambda (v i n) (u8vector-set! v i n))
3758                               1
3759                               #f
3760                               len))
3761                             ((= type (s16vector-tag))
3762                              (deserialize-homintvector!
3763                               (lambda (n) (make-s16vector n))
3764                               (lambda (v i n) (s16vector-set! v i n))
3765                               2
3766                               #t
3767                               len))
3768                             ((= type (u16vector-tag))
3769                              (deserialize-homintvector!
3770                               (lambda (n) (make-u16vector n))
3771                               (lambda (v i n) (u16vector-set! v i n))
3772                               2
3773                               #f
3774                               len))
3775                             ((= type (s32vector-tag))
3776                              (deserialize-homintvector!
3777                               (lambda (n) (make-s32vector n))
3778                               (lambda (v i n) (s32vector-set! v i n))
3779                               4
3780                               #t
3781                               len))
3782                             ((= type (u32vector-tag))
3783                              (deserialize-homintvector!
3784                               (lambda (n) (make-u32vector n))
3785                               (lambda (v i n) (u32vector-set! v i n))
3786                               4
3787                               #f
3788                               len))
3789                             ((= type (s64vector-tag))
3790                              (deserialize-homintvector!
3791                               (lambda (n) (make-s64vector n))
3792                               (lambda (v i n) (s64vector-set! v i n))
3793                               8
3794                               #t
3795                               len))
3796                             ((= type (u64vector-tag))
3797                              (deserialize-homintvector!
3798                               (lambda (n) (make-u64vector n))
3799                               (lambda (v i n) (u64vector-set! v i n))
3800                               8
3801                               #f
3802                               len))
3803                             ((= type (f32vector-tag))
3804                              (deserialize-homfloatvector!
3805                               (lambda (n) (make-f32vector n))
3806                               (lambda (v i n) (f32vector-set! v i n))
3807                               len
3808                               #t))
3809                             ((= type (f64vector-tag))
3810                              (deserialize-homfloatvector!
3811                               (lambda (n) (make-f64vector n))
3812                               (lambda (v i n) (f64vector-set! v i n))
3813                               len
3814                               #f))
3815                             (else
3816                              (err)))))
3817
3818                    (else
3819                     (err))))
3820
3821             ((>= x (exact-int-tag))
3822              (let ((lo (bitwise-and x #x0f)))
3823                (if (< lo #x0b)
3824                    lo
3825                    (let* ((len
3826                            (if (= lo #x0f)
3827                                (deserialize-nonneg-fixnum! 0 0)
3828                                (- #x0f lo)))
3829                           (n
3830                            (deserialize-exact-int-of-length! len)))
3831                      (if (= lo #x0e)
3832                          n
3833                          (begin
3834                            (alloc! n)
3835                            n))))))
3836
3837             ((>= x (subprocedure-tag))
3838              (let ((subproc-id
3839                     (let ((id (bitwise-and x #x0f)))
3840                       (if (< id #x0f)
3841                           id
3842                           (deserialize-nonneg-fixnum! 0 0)))))
3843                (deserialize-subprocedure-with-id! subproc-id)))
3844
3845             ((>= x (structure-tag))
3846              (deserialize-vector-like!
3847               (macro-subtype-structure)
3848               x))
3849
3850             ((>= x (vector-tag))
3851              (deserialize-vector-like!
3852               (macro-subtype-vector)
3853               x))
3854
3855             ((>= x (string-tag))
3856              (let ((obj (deserialize-string! x #x0f)))
3857                (alloc! obj)
3858                obj))
3859
3860             (else ;; symbol-tag
3861              (let* ((name (deserialize-string! x #x0f))
3862                     (obj (string->symbol name)))
3863                (create-global-var-if-needed obj)
3864                (alloc! obj)
3865                obj)))))
3866
3867   (define (deserialize!)
3868     (let* ((obj (deserialize-without-transform!))
3869            (transform (vector-ref state 4)))
3870       (transform obj)))
3871
3872   (let ((obj (deserialize!)))
3873     (if (eof?)
3874         obj
3875         (err))))
3876
3877 (define-prim (u8vector->object
3878               u8vect
3879               #!optional
3880               (transform (macro-absent-obj)))
3881   (macro-force-vars (u8vect transform)
3882     (macro-check-u8vector u8vect 1 (u8vector->object u8vect transform)
3883       (if (eq? transform (macro-absent-obj))
3884           (##u8vector->object u8vect)
3885           (macro-check-procedure transform 2 (u8vector->object u8vect transform)
3886             (##u8vector->object u8vect transform))))))
3887
3888 ;;;============================================================================
3889
3890 ;;; Termite specific serialization/deserialization.
3891
3892 (define-prim (##obj->u8vector obj)
3893
3894 (##define-macro (subtype-set! obj subtype)
3895   `(##subtype-set! ,obj ,subtype))
3896
3897 (##define-macro (subvector-move! src-vect src-start src-end dst-vect dst-start)
3898   `(##subvector-move! ,src-vect ,src-start ,src-end ,dst-vect ,dst-start))
3899
3900 (##define-macro (max-fixnum)
3901   `##max-fixnum)
3902
3903 (##define-macro (max-char)
3904   `##max-char)
3905
3906
3907 (##define-macro (continuation? obj)
3908   `(##continuation? ,obj))
3909
3910 (##define-macro (continuation-frame cont)
3911   `(##continuation-frame ,cont))
3912
3913 (##define-macro (continuation-denv cont)
3914   `(##continuation-denv ,cont))
3915
3916 (##define-macro (frame? obj)
3917   `(##frame? ,obj))
3918
3919 (##define-macro (frame-fs frame)
3920   `(##frame-fs ,frame))
3921
3922 (##define-macro (frame-ret frame)
3923   `(##frame-ret ,frame))
3924
3925 (##define-macro (frame-ref frame i)
3926   `(##frame-ref ,frame ,i))
3927
3928 (##define-macro (frame-slot-live? frame i)
3929   `(##frame-slot-live? ,frame ,i))
3930
3931 (##define-macro (subprocedure-parent-name subproc)
3932   `(##subprocedure-parent-name ,subproc))
3933
3934 (##define-macro (subprocedure-id subproc)
3935   `(##subprocedure-id ,subproc))
3936
3937 (##define-macro (subprocedure-nb-closed subproc)
3938   `(##subprocedure-nb-closed ,subproc))
3939
3940 (##define-macro (closure? obj)
3941   `(##closure? ,obj))
3942
3943 (##define-macro (closure-code closure)
3944   `(##closure-code ,closure))
3945
3946 (##define-macro (closure-ref closure i)
3947   `(##closure-ref ,closure ,i))
3948
3949 (##define-macro (extract-bit-field size position n)
3950   `(##extract-bit-field ,size ,position ,n))
3951
3952 (##define-macro (bignum? obj)
3953   `(##bignum? ,obj))
3954
3955 (##define-macro (subtyped? obj)
3956   `(##subtyped? ,obj))
3957
3958 (##define-macro (flonum? obj)
3959   `(##flonum? ,obj))
3960
3961 (##define-macro (ratnum? obj)
3962   `(##ratnum? ,obj))
3963
3964 (##define-macro (cpxnum? obj)
3965   `(##cpxnum? ,obj))
3966
3967 (##define-macro (boxvalues? obj)
3968   `(##fixnum.= (##subtype ,obj) (macro-subtype-boxvalues)))
3969
3970
3971 (##define-macro (make-string . args)
3972   `(##make-string ,@args))
3973
3974 (##define-macro (string? . args)
3975   `(##string? ,@args))
3976
3977 (##define-macro (string-length str)
3978   `(##string-length ,str))
3979
3980 (##define-macro (string-ref str i)
3981   `(##string-ref ,str ,i))
3982
3983 (##define-macro (string-set! str i x)
3984   `(##string-set! ,str ,i ,x))
3985
3986
3987 (##define-macro (make-vector . args)
3988   `(##make-vector ,@args))
3989
3990 (##define-macro (vector? . args)
3991   `(##vector? ,@args))
3992
3993 (##define-macro (vector-length vect)
3994   `(##vector-length ,vect))
3995
3996 (##define-macro (vector-ref vect i)
3997   `(##vector-ref ,vect ,i))
3998
3999 (##define-macro (vector-set! vect i x)
4000   `(##vector-set! ,vect ,i ,x))
4001
4002
4003 (##define-macro (make-s8vector . args)
4004   `(##make-s8vector ,@args))
4005
4006 (##define-macro (s8vector? . args)
4007   `(##s8vector? ,@args))
4008
4009 (##define-macro (s8vector-length s8vect)
4010   `(##s8vector-length ,s8vect))
4011
4012 (##define-macro (s8vector-ref s8vect i)
4013   `(##s8vector-ref ,s8vect ,i))
4014
4015 (##define-macro (s8vector-set! s8vect i x)
4016   `(##s8vector-set! ,s8vect ,i ,x))
4017
4018 (##define-macro (s8vector-shrink! s8vect len)
4019   `(##s8vector-shrink! ,s8vect ,len))
4020
4021 (##define-macro (make-u8vector . args)
4022   `(##make-u8vector ,@args))
4023
4024 (##define-macro (u8vector? . args)
4025   `(##u8vector? ,@args))
4026
4027 (##define-macro (u8vector-length u8vect)
4028   `(##u8vector-length ,u8vect))
4029
4030 (##define-macro (u8vector-ref u8vect i)
4031   `(##u8vector-ref ,u8vect ,i))
4032
4033 (##define-macro (u8vector-set! u8vect i x)
4034   `(##u8vector-set! ,u8vect ,i ,x))
4035
4036 (##define-macro (u8vector-shrink! u8vect len)
4037   `(##u8vector-shrink! ,u8vect ,len))
4038
4039 (##define-macro (fifo->u8vector fifo start end)
4040   `(##fifo->u8vector ,fifo ,start ,end))
4041
4042
4043 (##define-macro (make-s16vector . args)
4044   `(##make-s16vector ,@args))
4045
4046 (##define-macro (s16vector? . args)
4047   `(##s16vector? ,@args))
4048
4049 (##define-macro (s16vector-length s16vect)
4050   `(##s16vector-length ,s16vect))
4051
4052 (##define-macro (s16vector-ref s16vect i)
4053   `(##s16vector-ref ,s16vect ,i))
4054
4055 (##define-macro (s16vector-set! s16vect i x)
4056   `(##s16vector-set! ,s16vect ,i ,x))
4057
4058 (##define-macro (s16vector-shrink! s16vect len)
4059   `(##s16vector-shrink! ,s16vect ,len))
4060
4061 (##define-macro (make-u16vector . args)
4062   `(##make-u16vector ,@args))
4063
4064 (##define-macro (u16vector? . args)
4065   `(##u16vector? ,@args))
4066
4067 (##define-macro (u16vector-length u16vect)
4068   `(##u16vector-length ,u16vect))
4069
4070 (##define-macro (u16vector-ref u16vect i)
4071   `(##u16vector-ref ,u16vect ,i))
4072
4073 (##define-macro (u16vector-set! u16vect i x)
4074   `(##u16vector-set! ,u16vect ,i ,x))
4075
4076 (##define-macro (u16vector-shrink! u16vect len)
4077   `(##u16vector-shrink! ,u16vect ,len))
4078
4079
4080 (##define-macro (make-s32vector . args)
4081   `(##make-s32vector ,@args))
4082
4083 (##define-macro (s32vector? . args)
4084   `(##s32vector? ,@args))
4085
4086 (##define-macro (s32vector-length s32vect)
4087   `(##s32vector-length ,s32vect))
4088
4089 (##define-macro (s32vector-ref s32vect i)
4090   `(##s32vector-ref ,s32vect ,i))
4091
4092 (##define-macro (s32vector-set! s32vect i x)
4093   `(##s32vector-set! ,s32vect ,i ,x))
4094
4095 (##define-macro (s32vector-shrink! s32vect len)
4096   `(##s32vector-shrink! ,s32vect ,len))
4097
4098 (##define-macro (make-u32vector . args)
4099   `(##make-u32vector ,@args))
4100
4101 (##define-macro (u32vector? . args)
4102   `(##u32vector? ,@args))
4103
4104 (##define-macro (u32vector-length u32vect)
4105   `(##u32vector-length ,u32vect))
4106
4107 (##define-macro (u32vector-ref u32vect i)
4108   `(##u32vector-ref ,u32vect ,i))
4109
4110 (##define-macro (u32vector-set! u32vect i x)
4111   `(##u32vector-set! ,u32vect ,i ,x))
4112
4113 (##define-macro (u32vector-shrink! u32vect len)
4114   `(##u32vector-shrink! ,u32vect ,len))
4115
4116
4117 (##define-macro (make-s64vector . args)
4118   `(##make-s64vector ,@args))
4119
4120 (##define-macro (s64vector? . args)
4121   `(##s64vector? ,@args))
4122
4123 (##define-macro (s64vector-length s64vect)
4124   `(##s64vector-length ,s64vect))
4125
4126 (##define-macro (s64vector-ref s64vect i)
4127   `(##s64vector-ref ,s64vect ,i))
4128
4129 (##define-macro (s64vector-set! s64vect i x)
4130   `(##s64vector-set! ,s64vect ,i ,x))
4131
4132 (##define-macro (s64vector-shrink! s64vect len)
4133   `(##s64vector-shrink! ,s64vect ,len))
4134
4135 (##define-macro (make-u64vector . args)
4136   `(##make-u64vector ,@args))
4137
4138 (##define-macro (u64vector? . args)
4139   `(##u64vector? ,@args))
4140
4141 (##define-macro (u64vector-length u64vect)
4142   `(##u64vector-length ,u64vect))
4143
4144 (##define-macro (u64vector-ref u64vect i)
4145   `(##u64vector-ref ,u64vect ,i))
4146
4147 (##define-macro (u64vector-set! u64vect i x)
4148   `(##u64vector-set! ,u64vect ,i ,x))
4149
4150 (##define-macro (u64vector-shrink! u64vect len)
4151   `(##u64vector-shrink! ,u64vect ,len))
4152
4153
4154 (##define-macro (make-f32vector . args)
4155   `(##make-f32vector ,@args))
4156
4157 (##define-macro (f32vector? . args)
4158   `(##f32vector? ,@args))
4159
4160 (##define-macro (f32vector-length f32vect)
4161   `(##f32vector-length ,f32vect))
4162
4163 (##define-macro (f32vector-ref f32vect i)
4164   `(##f32vector-ref ,f32vect ,i))
4165
4166 (##define-macro (f32vector-set! f32vect i x)
4167   `(##f32vector-set! ,f32vect ,i ,x))
4168
4169 (##define-macro (f32vector-shrink! f32vect len)
4170   `(##f32vector-shrink! ,f32vect ,len))
4171
4172 (##define-macro (make-f64vector . args)
4173   `(##make-f64vector ,@args))
4174
4175 (##define-macro (f64vector? . args)
4176   `(##f64vector? ,@args))
4177
4178 (##define-macro (f64vector-length f64vect)
4179   `(##f64vector-length ,f64vect))
4180
4181 (##define-macro (f64vector-ref f64vect i)
4182   `(##f64vector-ref ,f64vect ,i))
4183
4184 (##define-macro (f64vector-set! f64vect i x)
4185   `(##f64vector-set! ,f64vect ,i ,x))
4186
4187 (##define-macro (f64vector-shrink! f64vect len)
4188   `(##f64vector-shrink! ,f64vect ,len))
4189
4190
4191 (##define-macro (symbol? . args)
4192   `(##symbol? ,@args))
4193
4194 (##define-macro (symbol->string . args)
4195   `(##symbol->string ,@args))
4196
4197 (##define-macro (string->symbol . args)
4198   `(##string->symbol ,@args))
4199
4200 (##define-macro (keyword? . args)
4201   `(##keyword? ,@args))
4202
4203 (##define-macro (keyword->string . args)
4204   `(##keyword->string ,@args))
4205
4206 (##define-macro (string->keyword . args)
4207   `(##string->keyword ,@args))
4208
4209
4210 (##define-macro (+ . args)
4211   `(##fixnum.+ ,@args))
4212
4213 (##define-macro (- . args)
4214   `(##fixnum.- ,@args))
4215
4216 (##define-macro (* . args)
4217   `(##fixnum.* ,@args))
4218
4219 (##define-macro (< . args)
4220   `(##fixnum.< ,@args))
4221
4222 (##define-macro (> . args)
4223   `(##fixnum.> ,@args))
4224
4225 (##define-macro (= . args)
4226   `(##fixnum.= ,@args))
4227
4228 (##define-macro (>= . args)
4229   `(##fixnum.>= ,@args))
4230
4231 (##define-macro (<= . args)
4232   `(##fixnum.<= ,@args))
4233
4234 (##define-macro (bitwise-and . args)
4235   `(##fixnum.bitwise-and ,@args))
4236
4237 (##define-macro (bitwise-ior . args)
4238   `(##fixnum.bitwise-ior ,@args))
4239
4240 (##define-macro (arithmetic-shift-left . args)
4241   `(##fixnum.arithmetic-shift-left ,@args))
4242
4243 (##define-macro (arithmetic-shift-right . args)
4244   `(##fixnum.arithmetic-shift-right ,@args))
4245
4246 (##define-macro (generic.+ . args)
4247   `(##+ ,@args))
4248
4249 (##define-macro (generic.arithmetic-shift . args)
4250   `(##arithmetic-shift ,@args))
4251
4252 (##define-macro (generic.bit-set? . args)
4253   `(##bit-set? ,@args))
4254
4255 (##define-macro (generic.bitwise-ior . args)
4256   `(##bitwise-ior ,@args))
4257
4258 (##define-macro (generic.extract-bit-field . args)
4259   `(##extract-bit-field ,@args))
4260
4261 (##define-macro (generic.gcd . args)
4262   `(##gcd ,@args))
4263
4264 (##define-macro (generic.negative? . args)
4265   `(##negative? ,@args))
4266
4267 (##define-macro (integer-length . args)
4268   `(##integer-length ,@args))
4269
4270 (##define-macro (make-table . args)
4271   `(##make-table 0 #f #f #f ##eq?))
4272
4273 (##define-macro (table-ref . args)
4274   `(##table-ref ,@args))
4275
4276 (##define-macro (table-set! . args)
4277   `(##table-set! ,@args))
4278
4279 (##define-macro (uninterned-keyword? . args)
4280   `(##uninterned-keyword? ,@args))
4281
4282 (##define-macro (uninterned-symbol? . args)
4283   `(##uninterned-symbol? ,@args))
4284
4285
4286 (##define-macro (char->integer . args)
4287   `(##fixnum.<-char ,@args))
4288
4289 (##define-macro (integer->char . args)
4290   `(##fixnum.->char ,@args))
4291
4292
4293 (##define-macro (vector . args)
4294   `(##vector ,@args))
4295
4296
4297 (##define-macro (cons . args)
4298   `(##cons ,@args))
4299
4300 (##define-macro (pair? . args)
4301   `(##pair? ,@args))
4302
4303 (##define-macro (car . args)
4304   `(##car ,@args))
4305
4306 (##define-macro (cdr . args)
4307   `(##cdr ,@args))
4308
4309 (##define-macro (set-car! . args)
4310   `(##set-car! ,@args))
4311
4312 (##define-macro (set-cdr! . args)
4313   `(##set-cdr! ,@args))
4314
4315
4316 (##define-macro (procedure? . args)
4317   `(##procedure? ,@args))
4318
4319 (##define-macro (char? . args)
4320   `(##char? ,@args))
4321
4322 (##define-macro (real? . args)
4323   `(##real? ,@args))
4324
4325 (##define-macro (not . args)
4326   `(##not ,@args))
4327
4328 (##define-macro (eq? . args)
4329   `(##eq? ,@args))
4330
4331 ;;; Representation of fifos.
4332
4333 (##define-macro (macro-make-fifo)
4334   `(let ((fifo (##cons '() '())))
4335      (macro-fifo-tail-set! fifo fifo)
4336      fifo))
4337
4338 (##define-macro (macro-fifo-next fifo)        `(##cdr ,fifo))
4339 (##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
4340 (##define-macro (macro-fifo-tail fifo)        `(##car ,fifo))
4341 (##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
4342 (##define-macro (macro-fifo-elem fifo)        `(##car ,fifo))
4343 (##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
4344
4345 (##define-macro (macro-fifo->list fifo)
4346   `(macro-fifo-next ,fifo))
4347
4348 (##define-macro (macro-fifo-remove-all! fifo)
4349   `(let ((fifo ,fifo))
4350
4351      (##declare (not interrupts-enabled))
4352
4353      (let ((head (macro-fifo-next fifo)))
4354        (macro-fifo-tail-set! fifo fifo)
4355        (macro-fifo-next-set! fifo '())
4356        head)))
4357
4358 (##define-macro (macro-fifo-remove-head! fifo)
4359   `(let ((fifo ,fifo))
4360
4361      (##declare (not interrupts-enabled))
4362
4363      (let ((head (macro-fifo-next fifo)))
4364        (if (##pair? head)
4365          (let ((next (macro-fifo-next head)))
4366            (if (##null? next)
4367              (macro-fifo-tail-set! fifo fifo))
4368            (macro-fifo-next-set! fifo next)
4369            (macro-fifo-next-set! head '())))
4370        head)))
4371
4372 (##define-macro (macro-fifo-insert-at-tail! fifo elem)
4373   `(let ((fifo ,fifo) (elem ,elem))
4374      (let ((x (##cons elem '())))
4375
4376        (##declare (not interrupts-enabled))
4377
4378        (let ((tail (macro-fifo-tail fifo)))
4379          (macro-fifo-next-set! tail x)
4380          (macro-fifo-tail-set! fifo x)
4381          (##void)))))
4382
4383 (##define-macro (macro-fifo-insert-at-head! fifo elem)
4384   `(let ((fifo ,fifo) (elem ,elem))
4385      (let ((x (##cons elem '())))
4386
4387        (##declare (not interrupts-enabled))
4388
4389        ;; To obtain an atomic update of the fifo, we must force a
4390        ;; garbage-collection to occur right away if needed by the
4391        ;; ##cons, so that any finalization that might mutate this fifo
4392        ;; will be done before updating the fifo.
4393
4394        (##check-heap-limit)
4395
4396        (let ((head (macro-fifo-next fifo)))
4397          (if (##null? head)
4398            (macro-fifo-tail-set! fifo x))
4399          (macro-fifo-next-set! fifo x)
4400          (macro-fifo-next-set! x head)
4401          (##void)))))
4402
4403 (##define-macro (macro-fifo-advance-to-tail! fifo)
4404   `(let ((fifo ,fifo))
4405      ;; It is assumed that the fifo contains at least one element
4406      ;; (i.e. the fifo's tail does not change).
4407      (let ((new-head (macro-fifo-tail fifo)))
4408        (macro-fifo-next-set! fifo new-head)
4409        (macro-fifo-elem new-head))))
4410
4411 (##define-macro (macro-fifo-advance! fifo)
4412   `(let ((fifo ,fifo))
4413      ;; It is assumed that the fifo contains at least two elements
4414      ;; (i.e. the fifo's tail does not change).
4415      (let* ((head (macro-fifo-next fifo))
4416             (new-head (macro-fifo-next head)))
4417        (macro-fifo-next-set! fifo new-head)
4418        (macro-fifo-elem new-head))))
4419
4420
4421   (define (cannot-serialize obj)
4422     (error "can't serialize" obj))
4423
4424   (define chunk-len 256) ;; must be a power of 2
4425
4426   (define state
4427     (vector 0
4428             (macro-make-fifo)
4429             0
4430             (make-table test: ##eq?)))
4431
4432   (define (write-u8 x)
4433     (let ((ptr (vector-ref state 0)))
4434       (vector-set! state 0 (+ ptr 1))
4435       (let ((fifo (vector-ref state 1))
4436             (i (bitwise-and ptr (- chunk-len 1))))
4437         (u8vector-set!
4438          (if (= i 0)
4439              (let ((chunk (make-u8vector chunk-len)))
4440                (macro-fifo-insert-at-tail! fifo chunk)
4441                chunk)
4442              (macro-fifo-elem (macro-fifo-tail fifo)))
4443          i
4444          x))))
4445
4446   (define (get-output-u8vector)
4447     (let ((ptr (vector-ref state 0))
4448           (fifo (vector-ref state 1)))
4449       (if (and (< 0 ptr) (<= ptr chunk-len))
4450           (let ((u8vect (macro-fifo-elem (macro-fifo-tail fifo))))
4451             (u8vector-shrink! u8vect ptr)
4452             u8vect)
4453           (fifo->u8vector fifo 0 ptr))))
4454
4455   (define (share obj)
4456     (let ((n (table-ref (vector-ref state 3) obj #f)))
4457       (if n
4458           (begin
4459             (serialize-shared! n)
4460             #t)
4461           #f)))
4462
4463   (define (alloc! obj)
4464     (let ((n (vector-ref state 2)))
4465       (vector-set! state 2 (+ n 1))
4466       (table-set! (vector-ref state 3) obj n)))
4467
4468   (define (serialize-shared! n)
4469     (let ((lo (bitwise-and n #x7f))
4470           (hi (arithmetic-shift-right n 7)))
4471       (write-u8 (bitwise-ior (shared-tag) lo))
4472       (serialize-nonneg-fixnum! hi)))
4473
4474   (define (serialize-nonneg-fixnum! n)
4475     (let ((lo (bitwise-and n #x7f))
4476           (hi (arithmetic-shift-right n 7)))
4477       (if (= hi 0)
4478           (write-u8 lo)
4479           (begin
4480             (write-u8 (bitwise-ior #x80 lo))
4481             (serialize-nonneg-fixnum! hi)))))
4482
4483   (define (serialize-flonum-32! n)
4484     (serialize-exact-int-of-length!
4485      (##flonum.->ieee754-32 n)
4486      4))
4487
4488   (define (serialize-flonum-64! n)
4489     (serialize-exact-int-of-length!
4490      (##flonum.->ieee754-64 n)
4491      8))
4492
4493   (define (serialize-exact-int-of-length! n len)
4494     (if (fixnum? n)
4495         (let loop ((n n) (len len))
4496           (if (> len 0)
4497               (begin
4498                 (write-u8 (bitwise-and n #xff))
4499                 (loop (arithmetic-shift-right n 8) (- len 1)))))
4500         (let* ((len/2 (arithmetic-shift-right len 1))
4501                (len/2*8 (* len/2 8)))
4502           (serialize-exact-int-of-length!
4503            (generic.extract-bit-field len/2*8 0 n)
4504            len/2)
4505           (serialize-exact-int-of-length!
4506            (generic.arithmetic-shift n (- len/2*8))
4507            (- len len/2)))))
4508
4509   (define (exact-int-length n signed?)
4510     (arithmetic-shift-right
4511      (+ (integer-length n) (if signed? 8 7))
4512      3))
4513
4514   (define (serialize-exact-int! n)
4515     (or (share n)
4516         (let ((len (exact-int-length n #t)))
4517           (if (<= len 4)
4518               (write-u8 (bitwise-ior (exact-int-tag) (- #x0f len)))
4519               (begin
4520                 (write-u8 (bitwise-ior (exact-int-tag) #x0f))
4521                 (serialize-nonneg-fixnum! len)))
4522           (serialize-exact-int-of-length! n len)
4523           (alloc! n))))
4524
4525   (define (serialize-vector-like! vect tag)
4526     (let ((len (vector-length vect)))
4527       (if (< len #x0f)
4528           (begin
4529             (write-u8 (bitwise-ior tag len))
4530             (serialize-subvector! vect 0 len))
4531           (serialize-vector-like-long! vect (bitwise-ior tag #x0f)))))
4532
4533   (define (serialize-vector-like-long! vect tag)
4534     (let ((len (vector-length vect)))
4535       (write-u8 tag)
4536       (serialize-nonneg-fixnum! len)
4537       (serialize-subvector! vect 0 len)))
4538
4539   (define (serialize-subvector! vect start end)
4540     (let loop ((i start))
4541       (if (< i end)
4542           (begin
4543             (serialize! (vector-ref vect i))
4544             (loop (+ i 1))))))
4545
4546   (define (serialize-string-like! str tag mask)
4547     (let ((len (string-length str)))
4548       (if (< len mask)
4549           (begin
4550             (write-u8 (bitwise-ior tag len))
4551             (serialize-string! str))
4552           (begin
4553             (write-u8 (bitwise-ior tag mask))
4554             (serialize-nonneg-fixnum! len)
4555             (serialize-string! str)))))
4556
4557   (define (serialize-string! str)
4558     (serialize-elements!
4559      0
4560      (string-length str)
4561      (lambda (i)
4562        (serialize-nonneg-fixnum! (char->integer (string-ref str i))))))
4563
4564   (define (serialize-elements! start end serialize-element!)
4565     (let loop ((i start))
4566       (if (< i end)
4567           (begin
4568             (serialize-element! i)
4569             (loop (+ i 1))))))
4570
4571   (define (serialize-homintvector! vect vect-tag vect-length vect-ref elem-len)
4572     (or (share vect)
4573         (let ((len (vect-length vect)))
4574           (write-u8 (homvector-tag))
4575           (serialize-nonneg-fixnum!
4576            (bitwise-ior vect-tag (arithmetic-shift-left len 4)))
4577           (serialize-elements!
4578            0
4579            len
4580            (lambda (i)
4581              (serialize-exact-int-of-length!
4582               (vect-ref vect i)
4583               elem-len)))
4584           (alloc! vect))))
4585
4586   (define (serialize-homfloatvector! vect vect-tag vect-length vect-ref f32?)
4587     (or (share vect)
4588         (let ((len (vect-length vect)))
4589           (write-u8 (homvector-tag))
4590           (serialize-nonneg-fixnum!
4591            (bitwise-ior vect-tag (arithmetic-shift-left len 4)))
4592           (serialize-elements!
4593            0
4594            len
4595            (lambda (i)
4596              (let ((n (vect-ref vect i)))
4597                (if f32?
4598                    (serialize-flonum-32! n)
4599                    (serialize-flonum-64! n)))))
4600           (alloc! vect))))
4601
4602   (define (serialize-subprocedure! subproc tag mask)
4603     (or (share subproc)
4604         (let ((parent-name (subprocedure-parent-name subproc)))
4605           (if (not parent-name)
4606               (cannot-serialize subproc)
4607               (let ((subproc-id (subprocedure-id subproc)))
4608                 (if (< subproc-id mask)
4609                     (write-u8 (bitwise-ior tag subproc-id))
4610                     (begin
4611                       (write-u8 (bitwise-ior tag mask))
4612                       (serialize-nonneg-fixnum! subproc-id)))
4613                 (serialize! (##system-version))
4614                 (or (share parent-name)
4615                     (let ((str (symbol->string parent-name)))
4616                       (serialize-string-like! str 0 #x7f)
4617                       (alloc! parent-name)))
4618                 (alloc! subproc))))))
4619
4620   (define (serialize! obj)
4621     (let ((obj (serialize-hook obj)))
4622       (cond ((subtyped? obj)
4623
4624              (cond ((symbol? obj)
4625                     (or (share obj)
4626                         (begin
4627                           (if (uninterned-symbol? obj)
4628                               (begin
4629                                 (write-u8 (ui-symbol-tag))
4630                                 (serialize-string-like!
4631                                  (symbol->string obj)
4632                                  0
4633                                  #xff)
4634                                 (serialize-exact-int-of-length!
4635                                  (##symbol-hash obj)
4636                                  4))
4637                               (serialize-string-like!
4638                                (symbol->string obj)
4639                                (symbol-tag)
4640                                #x0f))
4641                           (write-u8 (if (##global-var? obj) 1 0))
4642                           (alloc! obj))))
4643
4644                    ((keyword? obj)
4645                     (or (share obj)
4646                         (begin
4647                           (if (uninterned-keyword? obj)
4648                               (begin
4649                                 (write-u8 (ui-keyword-tag))
4650                                 (serialize-string-like!
4651                                  (keyword->string obj)
4652                                  0
4653                                  #xff)
4654                                 (serialize-exact-int-of-length!
4655                                  (##keyword-hash obj)
4656                                  4))
4657                               (serialize-string-like!
4658                                (keyword->string obj)
4659                                (keyword-tag)
4660                                0))
4661                           (alloc! obj))))
4662
4663                    ((string? obj)
4664                     (or (share obj)
4665                         (begin
4666                           (serialize-string-like!
4667                            obj
4668                            (string-tag)
4669                            #x0f)
4670                           (alloc! obj))))
4671
4672                    ((vector? obj)
4673                     (or (share obj)
4674                         (begin
4675                           (alloc! obj)
4676                           (serialize-vector-like! obj (vector-tag)))))
4677
4678                    ((structure? obj)
4679                     (if (or (macro-thread? obj)
4680                             (macro-tgroup? obj)
4681                             (macro-mutex? obj)
4682                             (macro-condvar? obj))
4683                       (cannot-serialize obj)
4684                       (or (share obj)
4685                           (begin
4686                             (alloc! obj)
4687                             (serialize-vector-like! obj (structure-tag))))))
4688
4689                    ((procedure? obj)
4690                     (if (closure? obj)
4691
4692                         (or (share obj)
4693                             (begin
4694                               (write-u8 (closure-tag))
4695                               (let* ((subproc
4696                                       (closure-code obj))
4697                                      (nb-closed
4698                                       (subprocedure-nb-closed subproc)))
4699                                 (serialize-subprocedure! subproc 0 #x7f)
4700                                 (alloc! obj)
4701                                 (serialize-subvector! obj 1 (+ nb-closed 1)))))
4702
4703                         (serialize-subprocedure! obj (subprocedure-tag) #x0f)))
4704
4705                    ((flonum? obj)
4706                     (or (share obj)
4707                         (begin
4708                           (write-u8 (flonum-tag))
4709                           (serialize-flonum-64! obj)
4710                           (alloc! obj))))
4711
4712                    ((bignum? obj)
4713                     (serialize-exact-int! obj))
4714
4715                    ((ratnum? obj)
4716                     (or (share obj)
4717                         (begin
4718                           (write-u8 (ratnum-tag))
4719                           (serialize! (macro-ratnum-numerator obj))
4720                           (serialize! (macro-ratnum-denominator obj))
4721                           (alloc! obj))))
4722
4723                    ((cpxnum? obj)
4724                     (or (share obj)
4725                         (begin
4726                           (write-u8 (cpxnum-tag))
4727                           (serialize! (macro-cpxnum-real obj))
4728                           (serialize! (macro-cpxnum-imag obj))
4729                           (alloc! obj))))
4730
4731                    ((continuation? obj)
4732                     (let ()
4733
4734                       (define (serialize-cont-frame! cont)
4735                         (write-u8 (frame-tag))
4736                         (let ((subproc (##continuation-ret cont))
4737                               (fs (##continuation-fs cont)))
4738                           (serialize-subprocedure! subproc 0 #x7f)
4739                           (alloc! (##cons 11 22))
4740                           (let loop ((i fs))
4741                             (if (##fixnum.> i 0)
4742                                 (begin
4743                                   (serialize-cont-frame-ref! cont i)
4744                                   (loop (##fixnum.- i 1)))))))
4745
4746                       (define (serialize-cont-frame-ref! cont i)
4747                         (let* ((fs (##continuation-fs cont))
4748                                (j (##fixnum.+ (##fixnum.- fs i) 1)))
4749                           (if (##continuation-slot-live? cont j)
4750                               (if (##fixnum.= j (##fixnum.+ (##continuation-link cont) 1))
4751                                   (let ((next (##continuation-next cont)))
4752                                     (if next
4753                                         (serialize-cont-frame! next)
4754                                         (serialize! 0)))
4755                                   (serialize! (##continuation-ref cont j))))))
4756
4757                       (or (share obj)
4758                           (begin
4759                             (alloc! obj)
4760                             (write-u8 (continuation-tag))
4761                             (serialize-cont-frame! obj)
4762                             (serialize! (continuation-denv obj))))))
4763
4764                    ((frame? obj)
4765                     (or (share obj)
4766                         (begin
4767                           (write-u8 (frame-tag))
4768                           (let* ((subproc (frame-ret obj))
4769                                  (fs (frame-fs obj)))
4770                             (serialize-subprocedure! subproc 0 #x7f)
4771                             (alloc! obj)
4772                             (let loop ((i 1))
4773                               (if (<= i fs)
4774                                   (begin
4775                                     (if (frame-slot-live? obj i)
4776                                         (serialize! (frame-ref obj i)))
4777                                     (loop (+ i 1)))))))))
4778
4779                    ((boxvalues? obj)
4780                     (or (share obj)
4781                         (begin
4782                           (alloc! obj)
4783                           (serialize-vector-like-long! obj (boxvalues-tag)))))
4784
4785                    ((gc-hash-table? obj)
4786                     (or (share obj)
4787                         (begin
4788                           (alloc! obj)
4789                           (write-u8 (gchashtable-tag))
4790                           (let ()
4791                             (##declare (not interrupts-enabled))
4792                             (let ((len
4793                                    (vector-length obj))
4794                                   (flags
4795                                    (macro-gc-hash-table-flags obj))
4796                                   (count
4797                                    (macro-gc-hash-table-count obj))
4798                                   (min-count
4799                                    (macro-gc-hash-table-min-count obj))
4800                                   (free
4801                                    (macro-gc-hash-table-free obj)))
4802                               (serialize-nonneg-fixnum! len)
4803                               (serialize-nonneg-fixnum! flags)
4804                               (serialize-nonneg-fixnum! count)
4805                               (serialize-nonneg-fixnum! min-count)
4806                               (serialize-nonneg-fixnum! free))
4807                             (let loop ((i (macro-gc-hash-table-key0)))
4808                               (if (< i (vector-length obj))
4809                                   (let ((key (vector-ref obj i)))
4810                                     (if (and (not (eq? key (macro-unused-obj)))
4811                                              (not (eq? key (macro-deleted-obj))))
4812                                         (let ((val (vector-ref obj (+ i 1))))
4813                                           (serialize! key)
4814                                           (serialize! val)))
4815                                     (let ()
4816                                       (##declare (interrupts-enabled))
4817                                       (loop (+ i 2))))
4818                                   (serialize! (macro-unused-obj))))))))
4819
4820                    ((s8vector? obj)
4821                     (serialize-homintvector!
4822                      obj
4823                      (s8vector-tag)
4824                      (lambda (v) (s8vector-length v))
4825                      (lambda (v i) (s8vector-ref v i))
4826                      1))
4827
4828                    ((u8vector? obj)
4829                     (serialize-homintvector!
4830                      obj
4831                      (u8vector-tag)
4832                      (lambda (v) (u8vector-length v))
4833                      (lambda (v i) (u8vector-ref v i))
4834                      1))
4835
4836                    ((s16vector? obj)
4837                     (serialize-homintvector!
4838                      obj
4839                      (s16vector-tag)
4840                      (lambda (v) (s16vector-length v))
4841                      (lambda (v i) (s16vector-ref v i))
4842                      2))
4843
4844                    ((u16vector? obj)
4845                     (serialize-homintvector!
4846                      obj
4847                      (u16vector-tag)
4848                      (lambda (v) (u16vector-length v))
4849                      (lambda (v i) (u16vector-ref v i))
4850                      2))
4851
4852                    ((s32vector? obj)
4853                     (serialize-homintvector!
4854                      obj
4855                      (s32vector-tag)
4856                      (lambda (v) (s32vector-length v))
4857                      (lambda (v i) (s32vector-ref v i))
4858                      4))
4859
4860                    ((u32vector? obj)
4861                     (serialize-homintvector!
4862                      obj
4863                      (u32vector-tag)
4864                      (lambda (v) (u32vector-length v))
4865                      (lambda (v i) (u32vector-ref v i))
4866                      4))
4867
4868                    ((s64vector? obj)
4869                     (serialize-homintvector!
4870                      obj
4871                      (s64vector-tag)
4872                      (lambda (v) (s64vector-length v))
4873                      (lambda (v i) (s64vector-ref v i))
4874                      8))
4875
4876                    ((u64vector? obj)
4877                     (serialize-homintvector!
4878                      obj
4879                      (u64vector-tag)
4880                      (lambda (v) (u64vector-length v))
4881                      (lambda (v i) (u64vector-ref v i))
4882                      8))
4883
4884                    ((f32vector? obj)
4885                     (serialize-homfloatvector!
4886                      obj
4887                      (f32vector-tag)
4888                      (lambda (v) (f32vector-length v))
4889                      (lambda (v i) (f32vector-ref v i))
4890                      #t))
4891
4892                    ((f64vector? obj)
4893                     (serialize-homfloatvector!
4894                      obj
4895                      (f64vector-tag)
4896                      (lambda (v) (f64vector-length v))
4897                      (lambda (v i) (f64vector-ref v i))
4898                      #f))
4899
4900                    (else
4901                     (cannot-serialize obj))))
4902
4903             ((pair? obj)
4904              (or (share obj)
4905                  (begin
4906                    (alloc! obj)
4907                    (write-u8 (pair-tag))
4908                    (serialize! (car obj))
4909                    (serialize! (cdr obj)))))
4910
4911             ((fixnum? obj)
4912              (cond ((and (>= obj #x00)
4913                          (< obj #x0b))
4914                     (write-u8 (bitwise-ior (exact-int-tag) obj)))
4915                    ((and (>= obj #x-80)
4916                          (< obj #x80))
4917                     (write-u8 (bitwise-ior (exact-int-tag) #x0e))
4918                     (write-u8 (bitwise-and obj #xff)))
4919                    (else
4920                     (serialize-exact-int! obj))))
4921
4922             ((char? obj)
4923              (let ((n (char->integer obj)))
4924                (write-u8 (character-tag))
4925                (serialize-nonneg-fixnum! n)))
4926
4927             ((eq? obj #f)                  (write-u8 (false-tag)))
4928             ((eq? obj #t)                  (write-u8 (true-tag)))
4929             ((eq? obj '())                 (write-u8 (nil-tag)))
4930             ((eq? obj #!eof)               (write-u8 (eof-tag)))
4931             ((eq? obj #!void)              (write-u8 (void-tag)))
4932             ((eq? obj (macro-absent-obj))  (write-u8 (absent-tag)))
4933             ((eq? obj #!unbound)           (write-u8 (unbound-tag)))
4934             ((eq? obj #!unbound2)          (write-u8 (unbound2-tag)))
4935             ((eq? obj #!optional)          (write-u8 (optional-tag)))
4936             ((eq? obj #!key)               (write-u8 (key-tag)))
4937             ((eq? obj #!rest)              (write-u8 (rest-tag)))
4938             ((eq? obj (macro-unused-obj))  (write-u8 (unused-tag)))
4939             ((eq? obj (macro-deleted-obj)) (write-u8 (deleted-tag)))
4940
4941             (else
4942              (cannot-serialize obj)))))
4943
4944   (serialize! obj)
4945
4946   (get-output-u8vector))
4947
4948 (define-prim (obj->u8vector obj)
4949   (macro-force-vars (obj)
4950     (##obj->u8vector obj)))
4951
4952 (define-prim (##u8vector->obj u8vect)
4953
4954 (##define-macro (subtype-set! obj subtype)
4955   `(##subtype-set! ,obj ,subtype))
4956
4957 (##define-macro (subvector-move! src-vect src-start src-end dst-vect dst-start)
4958   `(##subvector-move! ,src-vect ,src-start ,src-end ,dst-vect ,dst-start))
4959
4960 (##define-macro (max-fixnum)
4961   `##max-fixnum)
4962
4963 (##define-macro (max-char)
4964   `##max-char)
4965
4966
4967 (##define-macro (continuation? obj)
4968   `(##continuation? ,obj))
4969
4970 (##define-macro (continuation-frame cont)
4971   `(##continuation-frame ,cont))
4972
4973 (##define-macro (continuation-denv cont)
4974   `(##continuation-denv ,cont))
4975
4976 (##define-macro (frame? obj)
4977   `(##frame? ,obj))
4978
4979 (##define-macro (frame-fs frame)
4980   `(##frame-fs ,frame))
4981
4982 (##define-macro (frame-ret frame)
4983   `(##frame-ret ,frame))
4984
4985 (##define-macro (frame-ref frame i)
4986   `(##frame-ref ,frame ,i))
4987
4988 (##define-macro (frame-slot-live? frame i)
4989   `(##frame-slot-live? ,frame ,i))
4990
4991 (##define-macro (subprocedure-parent-name subproc)
4992   `(##subprocedure-parent-name ,subproc))
4993
4994 (##define-macro (subprocedure-id subproc)
4995   `(##subprocedure-id ,subproc))
4996
4997 (##define-macro (subprocedure-nb-closed subproc)
4998   `(##subprocedure-nb-closed ,subproc))
4999
5000 (##define-macro (closure? obj)
5001   `(##closure? ,obj))
5002
5003 (##define-macro (closure-code closure)
5004   `(##closure-code ,closure))
5005
5006 (##define-macro (closure-ref closure i)
5007   `(##closure-ref ,closure ,i))
5008
5009 (##define-macro (extract-bit-field size position n)
5010   `(##extract-bit-field ,size ,position ,n))
5011
5012 (##define-macro (bignum? obj)
5013   `(##bignum? ,obj))
5014
5015 (##define-macro (subtyped? obj)
5016   `(##subtyped? ,obj))
5017
5018 (##define-macro (flonum? obj)
5019   `(##flonum? ,obj))
5020
5021 (##define-macro (ratnum? obj)
5022   `(##ratnum? ,obj))
5023
5024 (##define-macro (cpxnum? obj)
5025   `(##cpxnum? ,obj))
5026
5027 (##define-macro (boxvalues? obj)
5028   `(##fixnum.= (##subtype ,obj) (macro-subtype-boxvalues)))
5029
5030
5031 (##define-macro (make-string . args)
5032   `(##make-string ,@args))
5033
5034 (##define-macro (string? . args)
5035   `(##string? ,@args))
5036
5037 (##define-macro (string-length str)
5038   `(##string-length ,str))
5039
5040 (##define-macro (string-ref str i)
5041   `(##string-ref ,str ,i))
5042
5043 (##define-macro (string-set! str i x)
5044   `(##string-set! ,str ,i ,x))
5045
5046
5047 (##define-macro (make-vector . args)
5048   `(##make-vector ,@args))
5049
5050 (##define-macro (vector? . args)
5051   `(##vector? ,@args))
5052
5053 (##define-macro (vector-length vect)
5054   `(##vector-length ,vect))
5055
5056 (##define-macro (vector-ref vect i)
5057   `(##vector-ref ,vect ,i))
5058
5059 (##define-macro (vector-set! vect i x)
5060   `(##vector-set! ,vect ,i ,x))
5061
5062
5063 (##define-macro (make-s8vector . args)
5064   `(##make-s8vector ,@args))
5065
5066 (##define-macro (s8vector? . args)
5067   `(##s8vector? ,@args))
5068
5069 (##define-macro (s8vector-length s8vect)
5070   `(##s8vector-length ,s8vect))
5071
5072 (##define-macro (s8vector-ref s8vect i)
5073   `(##s8vector-ref ,s8vect ,i))
5074
5075 (##define-macro (s8vector-set! s8vect i x)
5076   `(##s8vector-set! ,s8vect ,i ,x))
5077
5078 (##define-macro (s8vector-shrink! s8vect len)
5079   `(##s8vector-shrink! ,s8vect ,len))
5080
5081 (##define-macro (make-u8vector . args)
5082   `(##make-u8vector ,@args))
5083
5084 (##define-macro (u8vector? . args)
5085   `(##u8vector? ,@args))
5086
5087 (##define-macro (u8vector-length u8vect)
5088   `(##u8vector-length ,u8vect))
5089
5090 (##define-macro (u8vector-ref u8vect i)
5091   `(##u8vector-ref ,u8vect ,i))
5092
5093 (##define-macro (u8vector-set! u8vect i x)
5094   `(##u8vector-set! ,u8vect ,i ,x))
5095
5096 (##define-macro (u8vector-shrink! u8vect len)
5097   `(##u8vector-shrink! ,u8vect ,len))
5098
5099 (##define-macro (fifo->u8vector fifo start end)
5100   `(##fifo->u8vector ,fifo ,start ,end))
5101
5102
5103 (##define-macro (make-s16vector . args)
5104   `(##make-s16vector ,@args))
5105
5106 (##define-macro (s16vector? . args)
5107   `(##s16vector? ,@args))
5108
5109 (##define-macro (s16vector-length s16vect)
5110   `(##s16vector-length ,s16vect))
5111
5112 (##define-macro (s16vector-ref s16vect i)
5113   `(##s16vector-ref ,s16vect ,i))
5114
5115 (##define-macro (s16vector-set! s16vect i x)
5116   `(##s16vector-set! ,s16vect ,i ,x))
5117
5118 (##define-macro (s16vector-shrink! s16vect len)
5119   `(##s16vector-shrink! ,s16vect ,len))
5120
5121 (##define-macro (make-u16vector . args)
5122   `(##make-u16vector ,@args))
5123
5124 (##define-macro (u16vector? . args)
5125   `(##u16vector? ,@args))
5126
5127 (##define-macro (u16vector-length u16vect)
5128   `(##u16vector-length ,u16vect))
5129
5130 (##define-macro (u16vector-ref u16vect i)
5131   `(##u16vector-ref ,u16vect ,i))
5132
5133 (##define-macro (u16vector-set! u16vect i x)
5134   `(##u16vector-set! ,u16vect ,i ,x))
5135
5136 (##define-macro (u16vector-shrink! u16vect len)
5137   `(##u16vector-shrink! ,u16vect ,len))
5138
5139
5140 (##define-macro (make-s32vector . args)
5141   `(##make-s32vector ,@args))
5142
5143 (##define-macro (s32vector? . args)
5144   `(##s32vector? ,@args))
5145
5146 (##define-macro (s32vector-length s32vect)
5147   `(##s32vector-length ,s32vect))
5148
5149 (##define-macro (s32vector-ref s32vect i)
5150   `(##s32vector-ref ,s32vect ,i))
5151
5152 (##define-macro (s32vector-set! s32vect i x)
5153   `(##s32vector-set! ,s32vect ,i ,x))
5154
5155 (##define-macro (s32vector-shrink! s32vect len)
5156   `(##s32vector-shrink! ,s32vect ,len))
5157
5158 (##define-macro (make-u32vector . args)
5159   `(##make-u32vector ,@args))
5160
5161 (##define-macro (u32vector? . args)
5162   `(##u32vector? ,@args))
5163
5164 (##define-macro (u32vector-length u32vect)
5165   `(##u32vector-length ,u32vect))
5166
5167 (##define-macro (u32vector-ref u32vect i)
5168   `(##u32vector-ref ,u32vect ,i))
5169
5170 (##define-macro (u32vector-set! u32vect i x)
5171   `(##u32vector-set! ,u32vect ,i ,x))
5172
5173 (##define-macro (u32vector-shrink! u32vect len)
5174   `(##u32vector-shrink! ,u32vect ,len))
5175
5176
5177 (##define-macro (make-s64vector . args)
5178   `(##make-s64vector ,@args))
5179
5180 (##define-macro (s64vector? . args)
5181   `(##s64vector? ,@args))
5182
5183 (##define-macro (s64vector-length s64vect)
5184   `(##s64vector-length ,s64vect))
5185
5186 (##define-macro (s64vector-ref s64vect i)
5187   `(##s64vector-ref ,s64vect ,i))
5188
5189 (##define-macro (s64vector-set! s64vect i x)
5190   `(##s64vector-set! ,s64vect ,i ,x))
5191
5192 (##define-macro (s64vector-shrink! s64vect len)
5193   `(##s64vector-shrink! ,s64vect ,len))
5194
5195 (##define-macro (make-u64vector . args)
5196   `(##make-u64vector ,@args))
5197
5198 (##define-macro (u64vector? . args)
5199   `(##u64vector? ,@args))
5200
5201 (##define-macro (u64vector-length u64vect)
5202   `(##u64vector-length ,u64vect))
5203
5204 (##define-macro (u64vector-ref u64vect i)
5205   `(##u64vector-ref ,u64vect ,i))
5206
5207 (##define-macro (u64vector-set! u64vect i x)
5208   `(##u64vector-set! ,u64vect ,i ,x))
5209
5210 (##define-macro (u64vector-shrink! u64vect len)
5211   `(##u64vector-shrink! ,u64vect ,len))
5212
5213
5214 (##define-macro (make-f32vector . args)
5215   `(##make-f32vector ,@args))
5216
5217 (##define-macro (f32vector? . args)
5218   `(##f32vector? ,@args))
5219
5220 (##define-macro (f32vector-length f32vect)
5221   `(##f32vector-length ,f32vect))
5222
5223 (##define-macro (f32vector-ref f32vect i)
5224   `(##f32vector-ref ,f32vect ,i))
5225
5226 (##define-macro (f32vector-set! f32vect i x)
5227   `(##f32vector-set! ,f32vect ,i ,x))
5228
5229 (##define-macro (f32vector-shrink! f32vect len)
5230   `(##f32vector-shrink! ,f32vect ,len))
5231
5232 (##define-macro (make-f64vector . args)
5233   `(##make-f64vector ,@args))
5234
5235 (##define-macro (f64vector? . args)
5236   `(##f64vector? ,@args))
5237
5238 (##define-macro (f64vector-length f64vect)
5239   `(##f64vector-length ,f64vect))
5240
5241 (##define-macro (f64vector-ref f64vect i)
5242   `(##f64vector-ref ,f64vect ,i))
5243
5244 (##define-macro (f64vector-set! f64vect i x)
5245   `(##f64vector-set! ,f64vect ,i ,x))
5246
5247 (##define-macro (f64vector-shrink! f64vect len)
5248   `(##f64vector-shrink! ,f64vect ,len))
5249
5250
5251 (##define-macro (symbol? . args)
5252   `(##symbol? ,@args))
5253
5254 (##define-macro (symbol->string . args)
5255   `(##symbol->string ,@args))
5256
5257 (##define-macro (string->symbol . args)
5258   `(##string->symbol ,@args))
5259
5260 (##define-macro (keyword? . args)
5261   `(##keyword? ,@args))
5262
5263 (##define-macro (keyword->string . args)
5264   `(##keyword->string ,@args))
5265
5266 (##define-macro (string->keyword . args)
5267   `(##string->keyword ,@args))
5268
5269
5270 (##define-macro (+ . args)
5271   `(##fixnum.+ ,@args))
5272
5273 (##define-macro (- . args)
5274   `(##fixnum.- ,@args))
5275
5276 (##define-macro (* . args)
5277   `(##fixnum.* ,@args))
5278
5279 (##define-macro (< . args)
5280   `(##fixnum.< ,@args))
5281
5282 (##define-macro (> . args)
5283   `(##fixnum.> ,@args))
5284
5285 (##define-macro (= . args)
5286   `(##fixnum.= ,@args))
5287
5288 (##define-macro (>= . args)
5289   `(##fixnum.>= ,@args))
5290
5291 (##define-macro (<= . args)
5292   `(##fixnum.<= ,@args))
5293
5294 (##define-macro (bitwise-and . args)
5295   `(##fixnum.bitwise-and ,@args))
5296
5297 (##define-macro (bitwise-ior . args)
5298   `(##fixnum.bitwise-ior ,@args))
5299
5300 (##define-macro (arithmetic-shift-left . args)
5301   `(##fixnum.arithmetic-shift-left ,@args))
5302
5303 (##define-macro (arithmetic-shift-right . args)
5304   `(##fixnum.arithmetic-shift-right ,@args))
5305
5306 (##define-macro (generic.+ . args)
5307   `(##+ ,@args))
5308
5309 (##define-macro (generic.arithmetic-shift . args)
5310   `(##arithmetic-shift ,@args))
5311
5312 (##define-macro (generic.bit-set? . args)
5313   `(##bit-set? ,@args))
5314
5315 (##define-macro (generic.bitwise-ior . args)
5316   `(##bitwise-ior ,@args))
5317
5318 (##define-macro (generic.extract-bit-field . args)
5319   `(##extract-bit-field ,@args))
5320
5321 (##define-macro (generic.gcd . args)
5322   `(##gcd ,@args))
5323
5324 (##define-macro (generic.negative? . args)
5325   `(##negative? ,@args))
5326
5327 (##define-macro (integer-length . args)
5328   `(##integer-length ,@args))
5329
5330 (##define-macro (make-table . args)
5331   `(##make-table 0 #f #f #f ##eq?))
5332
5333 (##define-macro (table-ref . args)
5334   `(##table-ref ,@args))
5335
5336 (##define-macro (table-set! . args)
5337   `(##table-set! ,@args))
5338
5339 (##define-macro (uninterned-keyword? . args)
5340   `(##uninterned-keyword? ,@args))
5341
5342 (##define-macro (uninterned-symbol? . args)
5343   `(##uninterned-symbol? ,@args))
5344
5345
5346 (##define-macro (char->integer . args)
5347   `(##fixnum.<-char ,@args))
5348
5349 (##define-macro (integer->char . args)
5350   `(##fixnum.->char ,@args))
5351
5352
5353 (##define-macro (vector . args)
5354   `(##vector ,@args))
5355
5356
5357 (##define-macro (cons . args)
5358   `(##cons ,@args))
5359
5360 (##define-macro (pair? . args)
5361   `(##pair? ,@args))
5362
5363 (##define-macro (car . args)
5364   `(##car ,@args))
5365
5366 (##define-macro (cdr . args)
5367   `(##cdr ,@args))
5368
5369 (##define-macro (set-car! . args)
5370   `(##set-car! ,@args))
5371
5372 (##define-macro (set-cdr! . args)
5373   `(##set-cdr! ,@args))
5374
5375
5376 (##define-macro (procedure? . args)
5377   `(##procedure? ,@args))
5378
5379 (##define-macro (char? . args)
5380   `(##char? ,@args))
5381
5382 (##define-macro (real? . args)
5383   `(##real? ,@args))
5384
5385 (##define-macro (not . args)
5386   `(##not ,@args))
5387
5388 (##define-macro (eq? . args)
5389   `(##eq? ,@args))
5390
5391 ;;; Representation of fifos.
5392
5393 (##define-macro (macro-make-fifo)
5394   `(let ((fifo (##cons '() '())))
5395      (macro-fifo-tail-set! fifo fifo)
5396      fifo))
5397
5398 (##define-macro (macro-fifo-next fifo)        `(##cdr ,fifo))
5399 (##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
5400 (##define-macro (macro-fifo-tail fifo)        `(##car ,fifo))
5401 (##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
5402 (##define-macro (macro-fifo-elem fifo)        `(##car ,fifo))
5403 (##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
5404
5405 (##define-macro (macro-fifo->list fifo)
5406   `(macro-fifo-next ,fifo))
5407
5408 (##define-macro (macro-fifo-remove-all! fifo)
5409   `(let ((fifo ,fifo))
5410
5411      (##declare (not interrupts-enabled))
5412
5413      (let ((head (macro-fifo-next fifo)))
5414        (macro-fifo-tail-set! fifo fifo)
5415        (macro-fifo-next-set! fifo '())
5416        head)))
5417
5418 (##define-macro (macro-fifo-remove-head! fifo)
5419   `(let ((fifo ,fifo))
5420
5421      (##declare (not interrupts-enabled))
5422
5423      (let ((head (macro-fifo-next fifo)))
5424        (if (##pair? head)
5425          (let ((next (macro-fifo-next head)))
5426            (if (##null? next)
5427              (macro-fifo-tail-set! fifo fifo))
5428            (macro-fifo-next-set! fifo next)
5429            (macro-fifo-next-set! head '())))
5430        head)))
5431
5432 (##define-macro (macro-fifo-insert-at-tail! fifo elem)
5433   `(let ((fifo ,fifo) (elem ,elem))
5434      (let ((x (##cons elem '())))
5435
5436        (##declare (not interrupts-enabled))
5437
5438        (let ((tail (macro-fifo-tail fifo)))
5439          (macro-fifo-next-set! tail x)
5440          (macro-fifo-tail-set! fifo x)
5441          (##void)))))
5442
5443 (##define-macro (macro-fifo-insert-at-head! fifo elem)
5444   `(let ((fifo ,fifo) (elem ,elem))
5445      (let ((x (##cons elem '())))
5446
5447        (##declare (not interrupts-enabled))
5448
5449        ;; To obtain an atomic update of the fifo, we must force a
5450        ;; garbage-collection to occur right away if needed by the
5451        ;; ##cons, so that any finalization that might mutate this fifo
5452        ;; will be done before updating the fifo.
5453
5454        (##check-heap-limit)
5455
5456        (let ((head (macro-fifo-next fifo)))
5457          (if (##null? head)
5458            (macro-fifo-tail-set! fifo x))
5459          (macro-fifo-next-set! fifo x)
5460          (macro-fifo-next-set! x head)
5461          (##void)))))
5462
5463 (##define-macro (macro-fifo-advance-to-tail! fifo)
5464   `(let ((fifo ,fifo))
5465      ;; It is assumed that the fifo contains at least one element
5466      ;; (i.e. the fifo's tail does not change).
5467      (let ((new-head (macro-fifo-tail fifo)))
5468        (macro-fifo-next-set! fifo new-head)
5469        (macro-fifo-elem new-head))))
5470
5471 (##define-macro (macro-fifo-advance! fifo)
5472   `(let ((fifo ,fifo))
5473      ;; It is assumed that the fifo contains at least two elements
5474      ;; (i.e. the fifo's tail does not change).
5475      (let* ((head (macro-fifo-next fifo))
5476             (new-head (macro-fifo-next head)))
5477        (macro-fifo-next-set! fifo new-head)
5478        (macro-fifo-elem new-head))))
5479
5480
5481   (define (err)
5482     (error "deserialization error"))
5483
5484   (define state
5485     (vector 0
5486             u8vect
5487             0
5488             (make-vector 64)))
5489
5490   (define (read-u8)
5491     (let ((ptr (vector-ref state 0))
5492           (u8vect (vector-ref state 1)))
5493       (if (< ptr (u8vector-length u8vect))
5494           (begin
5495             (vector-set! state 0 (+ ptr 1))
5496             (u8vector-ref u8vect ptr))
5497           (err))))
5498
5499   (define (eof?)
5500     (let ((ptr (vector-ref state 0))
5501           (u8vect (vector-ref state 1)))
5502       (= ptr (u8vector-length u8vect))))
5503
5504   (define (alloc! obj)
5505     (let* ((n (vector-ref state 2))
5506            (vect (vector-ref state 3))
5507            (len (vector-length vect)))
5508       (vector-set! state 2 (+ n 1))
5509       (if (= n len)
5510           (let* ((new-len (+ (arithmetic-shift-right (* len 3) 1) 1))
5511                  (new-vect (make-vector new-len)))
5512             (vector-set! state 3 new-vect)
5513             (subvector-move! vect 0 n new-vect 0)
5514             (vector-set! new-vect n obj))
5515           (vector-set! vect n obj))
5516       n))
5517
5518   (define (shared-ref i)
5519     (let* ((n (vector-ref state 2))
5520            (vect (vector-ref state 3)))
5521       (if (< i n)
5522           (vector-ref vect i)
5523           (err))))
5524
5525   (define (deserialize-nonneg-fixnum! n shift)
5526     (let loop ((n n)
5527                (shift shift)
5528                (range (arithmetic-shift-right (max-fixnum) shift)))
5529       (if (= range 0)
5530           (err)
5531           (let ((x (read-u8)))
5532             (if (< x #x80)
5533                 (if (< range x)
5534                     (err)
5535                     (bitwise-ior n (arithmetic-shift-left x shift)))
5536                 (let ((b (bitwise-and x #x7f)))
5537                   (if (< range b)
5538                       (err)
5539                       (loop (bitwise-ior n (arithmetic-shift-left b shift))
5540                             (+ shift 7)
5541                             (arithmetic-shift-right range 7)))))))))
5542
5543   (define (deserialize-flonum-32!)
5544     (let ((n (deserialize-nonneg-exact-int-of-length! 4)))
5545       (##flonum.<-ieee754-32 n)))
5546
5547   (define (deserialize-flonum-64!)
5548     (let ((n (deserialize-nonneg-exact-int-of-length! 8)))
5549       (##flonum.<-ieee754-64 n)))
5550
5551   (define (deserialize-nonneg-exact-int-of-length! len)
5552     (if (<= len 3) ;; result fits in a 32 bit fixnum?
5553         (let ((a (read-u8)))
5554           (if (= len 1)
5555               a
5556               (+ a
5557                  (arithmetic-shift-left
5558                   (let ((b (read-u8)))
5559                     (if (= len 2)
5560                         b
5561                         (+ b
5562                            (arithmetic-shift-left
5563                             (let ((c (read-u8)))
5564                               c)
5565                             8))))
5566                   8))))
5567         (let* ((len/2 (arithmetic-shift-right len 1))
5568                (a (deserialize-nonneg-exact-int-of-length! len/2))
5569                (b (deserialize-nonneg-exact-int-of-length! (- len len/2))))
5570           (generic.bitwise-ior a (generic.arithmetic-shift b (* 8 len/2))))))
5571
5572   (define (deserialize-exact-int-of-length! len)
5573     (let ((n (deserialize-nonneg-exact-int-of-length! len)))
5574       (if (generic.bit-set? (- (* 8 len) 1) n)
5575           (generic.+ n (generic.arithmetic-shift -1 (* 8 len)))
5576           n)))
5577
5578   (define (deserialize-string! x mask)
5579     (deserialize-string-of-length!
5580      (let ((lo (bitwise-and x mask)))
5581        (if (< lo mask)
5582            lo
5583            (deserialize-nonneg-fixnum! 0 0)))))
5584
5585   (define (deserialize-string-of-length! len)
5586     (let ((obj (make-string len)))
5587       (let loop ((i 0))
5588         (if (< i len)
5589             (let ((n (deserialize-nonneg-fixnum! 0 0)))
5590               (if (<= n (max-char))
5591                   (begin
5592                     (string-set! obj i (integer->char n))
5593                     (loop (+ i 1)))
5594                   (err)))
5595             obj))))
5596
5597   (define (deserialize-vector-like! subtype x)
5598     (let* ((len (bitwise-and x #x0f)))
5599       (if (< len #x0f)
5600           (deserialize-vector-like-fill! subtype len)
5601           (deserialize-vector-like-long! subtype))))
5602
5603   (define (deserialize-vector-like-long! subtype)
5604     (let ((len (deserialize-nonneg-fixnum! 0 0)))
5605       (deserialize-vector-like-fill! subtype len)))
5606
5607   (define (deserialize-vector-like-fill! subtype len)
5608     (let ((obj (make-vector len)))
5609       (alloc! obj)
5610       (let loop ((i 0))
5611         (if (< i len)
5612             (begin
5613               (vector-set! obj i (deserialize!))
5614               (loop (+ i 1)))
5615             (begin
5616               (subtype-set! obj subtype)
5617               obj)))))
5618
5619   (define (deserialize-homintvector! make-vect vect-set! elem-len signed? len)
5620     (let ((obj (make-vect len)))
5621       (let loop ((i 0))
5622         (if (< i len)
5623             (begin
5624               (vect-set!
5625                obj
5626                i
5627                (if signed?
5628                    (deserialize-exact-int-of-length! elem-len)
5629                    (deserialize-nonneg-exact-int-of-length! elem-len)))
5630               (loop (+ i 1)))
5631             (begin
5632               (alloc! obj)
5633               obj)))))
5634
5635   (define (deserialize-homfloatvector! make-vect vect-set! len f32?)
5636     (let ((obj (make-vect len)))
5637       (let loop ((i 0))
5638         (if (< i len)
5639             (begin
5640               (vect-set!
5641                obj
5642                i
5643                (if f32?
5644                    (deserialize-flonum-32!)
5645                    (deserialize-flonum-64!)))
5646               (loop (+ i 1)))
5647             (begin
5648               (alloc! obj)
5649               obj)))))
5650
5651   (define (deserialize-subprocedure!)
5652     (let ((x (read-u8)))
5653       (if (>= x (shared-tag))
5654           (shared-ref
5655            (deserialize-nonneg-fixnum! (bitwise-and x #x7f) 7))
5656           (let ((subproc-id
5657                  (let ((id (bitwise-and x #x7f)))
5658                    (if (< id #x7f)
5659                        id
5660                        (deserialize-nonneg-fixnum! 0 0)))))
5661             (deserialize-subprocedure-with-id! subproc-id)))))
5662
5663   (define (deserialize-subprocedure-with-id! subproc-id)
5664     (let ((v (deserialize!)))
5665       (if (not (eq? v (##system-version)))
5666           (err)
5667           (let* ((x
5668                   (read-u8))
5669                  (parent-name
5670                   (if (>= x (shared-tag))
5671                       (let ((name
5672                              (shared-ref
5673                               (deserialize-nonneg-fixnum!
5674                                (bitwise-and x #x7f)
5675                                7))))
5676                         (if (not (symbol? name))
5677                             (err)
5678                             name))
5679                       (let ((name
5680                              (string->symbol (deserialize-string! x #x7f))))
5681                         (alloc! name)
5682                         name)))
5683                  (parent
5684                   (##global-var-primitive-ref
5685                    (##make-global-var parent-name))))
5686             (if (not (procedure? parent)) ;; should also check subproc-id
5687                 (err)
5688                 (let ((obj (##make-subprocedure parent subproc-id)))
5689                   (alloc! obj)
5690                   obj))))))
5691
5692   (define (create-global-var-if-needed sym)
5693     (let ((x (read-u8)))
5694       (if (= x 1)
5695           (##make-global-var sym))))
5696
5697   (define (deserialize-without-transform!)
5698     (let ((x (read-u8)))
5699
5700       (cond ((>= x (shared-tag))
5701              (shared-ref
5702               (deserialize-nonneg-fixnum! (bitwise-and x #x7f) 7)))
5703
5704             ((>= x (false-tag))
5705              (cond ((= x (false-tag))
5706                     #f)
5707
5708                    ((= x (true-tag))
5709                     #t)
5710
5711                    ((= x (nil-tag))
5712                     '())
5713
5714                    ((= x (eof-tag))
5715                     #!eof)
5716
5717                    ((= x (void-tag))
5718                     #!void)
5719
5720                    ((= x (absent-tag))
5721                     (macro-absent-obj))
5722
5723                    ((= x (unbound-tag))
5724                     #!unbound)
5725
5726                    ((= x (unbound2-tag))
5727                     #!unbound2)
5728
5729                    ((= x (optional-tag))
5730                     #!optional)
5731
5732                    ((= x (key-tag))
5733                     #!key)
5734
5735                    ((= x (rest-tag))
5736                     #!rest)
5737
5738                    ((= x (unused-tag))
5739                     (macro-unused-obj))
5740
5741                    ((= x (deleted-tag))
5742                     (macro-deleted-obj))
5743
5744                    (else
5745                     (err))))
5746
5747             ((>= x (character-tag))
5748              (cond ((= x (character-tag))
5749                     (let ((n (deserialize-nonneg-fixnum! 0 0)))
5750                       (if (<= n (max-char))
5751                           (integer->char n)
5752                           (err))))
5753
5754                    ((= x (flonum-tag))
5755                     (let ((obj (deserialize-flonum-64!)))
5756                       (alloc! obj)
5757                       obj))
5758
5759                    ((= x (ratnum-tag))
5760                     (let* ((num (deserialize!))
5761                            (den (deserialize!)))
5762                       (if (or (and (fixnum? den)
5763                                    (<= den 1))
5764                               (and (bignum? den)
5765                                    (generic.negative? den))
5766                               (not (eq? 1 (generic.gcd num den))))
5767                           (err)
5768                           (let ((obj (macro-ratnum-make num den)))
5769                             (alloc! obj)
5770                             obj))))
5771
5772                    ((= x (cpxnum-tag))
5773                     (let* ((real (deserialize!))
5774                            (imag (deserialize!)))
5775                       (if (or (not (real? real))
5776                               (not (real? imag)))
5777                           (err)
5778                           (let ((obj (macro-cpxnum-make real imag)))
5779                             (alloc! obj)
5780                             obj))))
5781
5782                    ((= x (pair-tag))
5783                     (let ((obj (cons #f #f)))
5784                       (alloc! obj)
5785                       (let* ((a (deserialize!))
5786                              (d (deserialize!)))
5787                         (set-car! obj a)
5788                         (set-cdr! obj d)
5789                         obj)))
5790
5791                    ((= x (continuation-tag))
5792                     (let ((obj (vector #f #f)))
5793                       (alloc! obj)
5794                       (let* ((frame (deserialize!))
5795                              (denv (deserialize!)))
5796                         (if (not (frame? frame)) ;; should also check denv
5797                             (err)
5798                             (begin
5799                               (vector-set! obj 0 frame)
5800                               (vector-set! obj 1 denv)
5801                               (subtype-set! obj (macro-subtype-continuation))
5802                               obj)))))
5803
5804                    ((= x (boxvalues-tag))
5805                     (deserialize-vector-like-long!
5806                      (macro-subtype-boxvalues)))
5807
5808                    ((= x (ui-symbol-tag))
5809                     (let* ((y (read-u8))
5810                            (name (deserialize-string! y #xff))
5811                            (hash (deserialize-exact-int-of-length! 4))
5812                            (obj (macro-make-uninterned-symbol name hash)))
5813                       (create-global-var-if-needed obj)
5814                       (alloc! obj)
5815                       obj))
5816
5817                    ((= x (keyword-tag))
5818                     (let* ((name (deserialize-string! 0 0))
5819                            (obj (string->keyword name)))
5820                       (alloc! obj)
5821                       obj))
5822
5823                    ((= x (ui-keyword-tag))
5824                     (let* ((y (read-u8))
5825                            (name (deserialize-string! y #xff))
5826                            (hash (deserialize-exact-int-of-length! 4))
5827                            (obj (macro-make-uninterned-keyword name hash)))
5828                       (alloc! obj)
5829                       obj))
5830
5831                    ((= x (closure-tag))
5832                     (let ((subproc (deserialize-subprocedure!)))
5833                       (if #f;;;;;;;not subprocedure
5834                           (err)
5835                           (let ((nb-closed
5836                                  (subprocedure-nb-closed subproc)))
5837                             (if #f;;;;; nb-closed = 0
5838                                 (err)
5839                                 (let ((obj (make-vector (+ nb-closed 1))))
5840                                   (vector-set! obj 0 subproc)
5841                                   (alloc! obj)
5842                                   (let loop ((i 1))
5843                                     (if (<= i nb-closed)
5844                                         (begin
5845                                           (vector-set! obj i (deserialize!))
5846                                           (loop (+ i 1)))
5847                                         (begin
5848                                           (subtype-set!
5849                                            obj
5850                                            (macro-subtype-procedure))
5851                                           obj)))))))))
5852
5853                    ((= x (frame-tag))
5854                     (let ((subproc (deserialize-subprocedure!)))
5855                       (if (not (##return? subproc))
5856                           (err)
5857                           (let* ((fs (##return-fs subproc))
5858                                  (obj (make-vector (+ fs 1))))
5859                             (vector-set! obj 0 subproc)
5860                             (alloc! obj)
5861                             (let loop ((i 1))
5862                               (if (<= i fs)
5863                                   (begin
5864                                     (vector-set!
5865                                      obj
5866                                      (+ (- fs i) 1)
5867                                      (if (frame-slot-live? obj i)
5868                                          (deserialize!)
5869                                          0))
5870                                     (loop (+ i 1)))
5871                                   (begin
5872                                     (subtype-set! obj (macro-subtype-frame))
5873                                     obj)))))))
5874
5875                    ((= x (gchashtable-tag))
5876                     (let* ((len (deserialize-nonneg-fixnum! 0 0))
5877                            (flags (deserialize-nonneg-fixnum! 0 0))
5878                            (count (deserialize-nonneg-fixnum! 0 0))
5879                            (min-count (deserialize-nonneg-fixnum! 0 0))
5880                            (free (deserialize-nonneg-fixnum! 0 0)))
5881                       (if #f;;;;;;;;parameters OK?
5882                           (err)
5883                           (let ((obj (make-vector len (macro-unused-obj))))
5884                             (alloc! obj)
5885                             (macro-gc-hash-table-flags-set!
5886                              obj
5887                              (bitwise-ior ;; force rehash at next access!
5888                               flags
5889                               (macro-gc-hash-table-flag-need-rehash)))
5890                             (macro-gc-hash-table-count-set! obj count)
5891                             (macro-gc-hash-table-min-count-set! obj min-count)
5892                             (macro-gc-hash-table-free-set! obj free)
5893                             (let loop ((i (macro-gc-hash-table-key0)))
5894                               (if (< i (vector-length obj))
5895                                   (let ((key (deserialize!)))
5896                                     (if (not (eq? key (macro-unused-obj)))
5897                                         (let ((val (deserialize!)))
5898                                           (vector-set! obj i key)
5899                                           (vector-set! obj (+ i 1) val)
5900                                           (loop (+ i 2)))
5901                                         (begin
5902                                           (subtype-set!
5903                                            obj
5904                                            (macro-subtype-weak))
5905                                           obj)))
5906                                   (err)))))))
5907
5908                    ((= x (meroon-tag))
5909                     (deserialize-vector-like-long!
5910                      (macro-subtype-meroon)))
5911
5912                    ((= x (homvector-tag))
5913                     (let* ((len/type
5914                             (deserialize-nonneg-fixnum! 0 0))
5915                            (len
5916                             (arithmetic-shift-right len/type 4))
5917                            (type
5918                             (bitwise-and len/type #x0f)))
5919                       (cond ((= type (s8vector-tag))
5920                              (deserialize-homintvector!
5921                               (lambda (n) (make-s8vector n))
5922                               (lambda (v i n) (s8vector-set! v i n))
5923                               1
5924                               #t
5925                               len))
5926                             ((= type (u8vector-tag))
5927                              (deserialize-homintvector!
5928                               (lambda (n) (make-u8vector n))
5929                               (lambda (v i n) (u8vector-set! v i n))
5930                               1
5931                               #f
5932                               len))
5933                             ((= type (s16vector-tag))
5934                              (deserialize-homintvector!
5935                               (lambda (n) (make-s16vector n))
5936                               (lambda (v i n) (s16vector-set! v i n))
5937                               2
5938                               #t
5939                               len))
5940                             ((= type (u16vector-tag))
5941                              (deserialize-homintvector!
5942                               (lambda (n) (make-u16vector n))
5943                               (lambda (v i n) (u16vector-set! v i n))
5944                               2
5945                               #f
5946                               len))
5947                             ((= type (s32vector-tag))
5948                              (deserialize-homintvector!
5949                               (lambda (n) (make-s32vector n))
5950                               (lambda (v i n) (s32vector-set! v i n))
5951                               4
5952                               #t
5953                               len))
5954                             ((= type (u32vector-tag))
5955                              (deserialize-homintvector!
5956                               (lambda (n) (make-u32vector n))
5957                               (lambda (v i n) (u32vector-set! v i n))
5958                               4
5959                               #f
5960                               len))
5961                             ((= type (s64vector-tag))
5962                              (deserialize-homintvector!
5963                               (lambda (n) (make-s64vector n))
5964                               (lambda (v i n) (s64vector-set! v i n))
5965                               8
5966                               #t
5967                               len))
5968                             ((= type (u64vector-tag))
5969                              (deserialize-homintvector!
5970                               (lambda (n) (make-u64vector n))
5971                               (lambda (v i n) (u64vector-set! v i n))
5972                               8
5973                               #f
5974                               len))
5975                             ((= type (f32vector-tag))
5976                              (deserialize-homfloatvector!
5977                               (lambda (n) (make-f32vector n))
5978                               (lambda (v i n) (f32vector-set! v i n))
5979                               len
5980                               #t))
5981                             ((= type (f64vector-tag))
5982                              (deserialize-homfloatvector!
5983                               (lambda (n) (make-f64vector n))
5984                               (lambda (v i n) (f64vector-set! v i n))
5985                               len
5986                               #f))
5987                             (else
5988                              (err)))))
5989
5990                    (else
5991                     (err))))
5992
5993             ((>= x (exact-int-tag))
5994              (let ((lo (bitwise-and x #x0f)))
5995                (if (< lo #x0b)
5996                    lo
5997                    (let* ((len
5998                            (if (= lo #x0f)
5999                                (deserialize-nonneg-fixnum! 0 0)
6000                                (- #x0f lo)))
6001                           (n
6002                            (deserialize-exact-int-of-length! len)))
6003                      (if (= lo #x0e)
6004                          n
6005                          (begin
6006                            (alloc! n)
6007                            n))))))
6008
6009             ((>= x (subprocedure-tag))
6010              (let ((subproc-id
6011                     (let ((id (bitwise-and x #x0f)))
6012                       (if (< id #x0f)
6013                           id
6014                           (deserialize-nonneg-fixnum! 0 0)))))
6015                (deserialize-subprocedure-with-id! subproc-id)))
6016
6017             ((>= x (structure-tag))
6018              (deserialize-vector-like!
6019               (macro-subtype-structure)
6020               x))
6021
6022             ((>= x (vector-tag))
6023              (deserialize-vector-like!
6024               (macro-subtype-vector)
6025               x))
6026
6027             ((>= x (string-tag))
6028              (let ((obj (deserialize-string! x #x0f)))
6029                (alloc! obj)
6030                obj))
6031
6032             (else ;; symbol-tag
6033              (let* ((name (deserialize-string! x #x0f))
6034                     (obj (string->symbol name)))
6035                (create-global-var-if-needed obj)
6036                (alloc! obj)
6037                obj)))))
6038
6039   (define (deserialize!)
6040     (let ((obj (deserialize-without-transform!)))
6041       (deserialize-hook obj)))
6042
6043   (let ((obj (deserialize!)))
6044     (if (eof?)
6045         obj
6046         (err))))
6047
6048 (define-prim (u8vector->obj u8vect)
6049   (macro-force-vars (u8vect)
6050     (macro-check-u8vector u8vect 1 (u8vector->obj u8vect)
6051       (##u8vector->obj u8vect))))