lib/_std.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_std.scm", Time-stamp: <2009-09-05 10:12:12 feeley>
   4
   5 ;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 (##include "header.scm")
  10
  11 ;;;============================================================================
  12
  13 ;; Implementation of exceptions.
  14
  15 (implement-library-type-improper-length-list-exception)
  16
  17 (define-prim (##raise-improper-length-list-exception arg-num proc . args);;;;;;;;;;;
  18   (##extract-procedure-and-arguments
  19    proc
  20    args
  21    arg-num
  22    #f
  23    #f
  24    (lambda (procedure arguments arg-num dummy1 dummy2)
  25      (macro-raise
  26       (macro-make-improper-length-list-exception procedure arguments arg-num)))))
  27
  28 ;;;----------------------------------------------------------------------------
  29
  30 ;; Definition of vector-like data types (i.e. string, vector, s8vector, ...).
  31
  32 (##define-macro (define-prim-vector-procedures
  33                  name
  34                  default-elem-value
  35                  macro-force-elem
  36                  macro-check-elem
  37                  macro-check-elem-list)
  38
  39   (define (sym . lst)
  40     (string->symbol
  41      (apply string-append
  42             (map (lambda (s) (if (symbol? s) (symbol->string s) s))
  43                  lst))))
  44
  45   (let ()
  46
  47     (define macro-check-vect (sym 'macro-check- name))
  48     (define vect-list        (sym name '-list))
  49     (define ##fail-check-vect (sym '##fail-check- name))
  50     (define ##fail-check-vect-list (sym '##fail-check- name '-list))
  51
  52     (define ##vect?          (sym "##" name '?))
  53     (define ##make-vect      (sym '##make- name))
  54     (define ##vect           (sym "##" name))
  55     (define ##vect-length    (sym "##" name '-length))
  56     (define ##vect-ref       (sym "##" name '-ref))
  57     (define ##vect-set!      (sym "##" name '-set!))
  58     (define ##vect->list     (sym "##" name '->list))
  59     (define ##list->vect     (sym '##list-> name))
  60     (define ##vect-copy      (sym "##" name '-copy))
  61     (define ##vect-fill!     (sym "##" name '-fill!))
  62     (define ##subvect        (sym '##sub name))
  63     (define ##append-vects   (sym '##append- name 's))
  64     (define ##vect-append    (sym "##" name '-append))
  65     (define ##subvect-move!  (sym '##sub name '-move!))
  66     (define ##subvect-fill!  (sym '##sub name '-fill!))
  67     (define ##vect-shrink!   (sym "##" name '-shrink!))
  68
  69     (define vect?            (sym name '?))
  70     (define make-vect        (sym 'make- name))
  71     (define vect             (sym name))
  72     (define vect-length      (sym name '-length))
  73     (define vect-ref         (sym name '-ref))
  74     (define vect-set!        (sym name '-set!))
  75     (define vect->list       (sym name '->list))
  76     (define list->vect       (sym 'list-> name))
  77     (define vect-copy        (sym name '-copy))
  78     (define vect-fill!       (sym name '-fill!))
  79     (define subvect          (sym 'sub name))
  80     (define append-vects     (sym 'append- name 's))
  81     (define vect-append      (sym name '-append))
  82     (define subvect-move!    (sym 'sub name '-move!))
  83     (define subvect-fill!    (sym 'sub name '-fill!))
  84     (define vect-shrink!     (sym name '-shrink!))
  85
  86     `(begin
  87
  88        (define-fail-check-type ,name ',name)
  89        (define-fail-check-type ,vect-list ',vect-list)
  90
  91        (define-prim (,##vect? obj))
  92
  93        (define-prim (,vect? obj)
  94          (macro-force-vars (obj)
  95            (,##vect? obj)))
  96
  97        (define-prim (,make-vect k #!optional (f (macro-absent-obj)))
  98          (macro-force-vars (k)
  99            (,macro-force-elem (f)
 100              (let ((fill
 101                     (if (##eq? f (macro-absent-obj))
 102                       ,default-elem-value
 103                       f)))
 104                (macro-check-index k 1 (,make-vect k f)
 105                  (,macro-check-elem fill 2 (,make-vect k f)
 106                    (,##make-vect k fill)))))))
 107
 108        (define-prim (,##vect . lst)
 109          (,##list->vect lst))
 110
 111        ,@(if (eq? name 'vector)
 112            `((define-prim (,vect
 113                            #!optional
 114                            (elem1 (macro-absent-obj))
 115                            (elem2 (macro-absent-obj))
 116                            (elem3 (macro-absent-obj))
 117                            (elem4 (macro-absent-obj))
 118                            #!rest
 119                            others)
 120                (if (##eq? elem1 (macro-absent-obj))
 121                  (,##vect)
 122                  (,macro-force-elem (elem1)
 123                    (,macro-check-elem elem1 1 (,vect elem1 elem2 elem3 elem4 . others)
 124                      (if (##eq? elem2 (macro-absent-obj))
 125                        (,##vect elem1)
 126                        (,macro-force-elem (elem2)
 127                          (,macro-check-elem elem2 2 (,vect elem1 elem2 elem3 elem4 . others)
 128                            (if (##eq? elem3 (macro-absent-obj))
 129                              (,##vect elem1 elem2)
 130                              (,macro-force-elem (elem3)
 131                                (,macro-check-elem elem3 3 (,vect elem1 elem2 elem3 elem4 . others)
 132                                  (if (##eq? elem4 (macro-absent-obj))
 133                                    (,##vect elem1 elem2 elem3)
 134                                    (,macro-force-elem (elem4)
 135                                      (,macro-check-elem elem4 4 (,vect elem1 elem2 elem3 elem4 . others)
 136                                        (if (##null? others)
 137                                          (,##vect elem1 elem2 elem3 elem4)
 138                                          (let loop1 ((x others)
 139                                                      (n 4))
 140                                            (if (##pair? x)
 141                                              (loop1 (##cdr x)
 142                                                     (##fixnum.+ n 1))
 143                                              (let ((vect (,##make-vect n)))
 144                                                (,##vect-set! vect 0 elem1)
 145                                                (,##vect-set! vect 1 elem2)
 146                                                (,##vect-set! vect 2 elem3)
 147                                                (,##vect-set! vect 3 elem4)
 148                                                (let loop2 ((x others)
 149                                                            (i 4))
 150                                                  (if (##pair? x)
 151                                                    (let ((elem (##car x)))
 152                                                      (,macro-force-elem (elem)
 153                                                        (,macro-check-elem elem (##fixnum.+ i 1) (,vect elem1 elem2 elem3 elem4 . others)
 154                                                          (begin
 155                                                            (,##vect-set! vect i elem)
 156                                                            (loop2 (##cdr x)
 157                                                                   (##fixnum.+ i 1))))))
 158                                                    vect))))))))))))))))))))
 159            `((define-prim (,vect . others)
 160                (let loop1 ((x others) (n 0))
 161                  (if (##pair? x)
 162                    (loop1 (##cdr x) (##fixnum.+ n 1))
 163                    (let ((vect (,##make-vect n)))
 164                      (let loop2 ((x others) (i 0))
 165                        (if (##pair? x)
 166                          (let ((elem (##car x)))
 167                            (,macro-force-elem (elem)
 168                              (,macro-check-elem elem (##fixnum.+ i 1) (,vect . others)
 169                                (begin
 170                                  (,##vect-set! vect i elem)
 171                                  (loop2 (##cdr x) (##fixnum.+ i 1))))))
 172                          vect))))))))
 173
 174        (define-prim (,##vect-length vect))
 175
 176        (define-prim (,vect-length vect)
 177          (macro-force-vars (vect)
 178            (,macro-check-vect vect 1 (,vect-length vect)
 179              (,##vect-length vect))))
 180
 181        (define-prim (,##vect-ref vect k))
 182
 183        (define-prim (,vect-ref vect k)
 184          (macro-force-vars (vect k)
 185            (,macro-check-vect vect 1 (,vect-ref vect k)
 186              (macro-check-index-range
 187               k
 188               2
 189               0
 190               (,##vect-length vect)
 191               (,vect-ref vect k)
 192               (,##vect-ref vect k)))))
 193
 194        (define-prim (,##vect-set! vect k val))
 195
 196        (define-prim (,vect-set! vect k val)
 197          (macro-force-vars (vect k)
 198            (,macro-force-elem (val)
 199              (,macro-check-vect vect 1 (,vect-set! vect k val)
 200                (macro-check-subtyped-mutable vect 1 (,vect-set! vect k val)
 201                  (macro-check-index-range
 202                   k
 203                   2
 204                   0
 205                   (,##vect-length vect)
 206                   (,vect-set! vect k val)
 207                   (,macro-check-elem val 3 (,vect-set! vect k val)
 208                     (begin
 209                       (,##vect-set! vect k val)
 210                       (##void)))))))))
 211
 212        (define-prim (,##vect->list vect)
 213          (let loop ((lst '()) (i (##fixnum.- (,##vect-length vect) 1)))
 214            (if (##fixnum.< i 0)
 215              lst
 216              (loop (##cons (,##vect-ref vect i) lst) (##fixnum.- i 1)))))
 217
 218        (define-prim (,vect->list vect)
 219          (macro-force-vars (vect)
 220            (,macro-check-vect vect 1 (,vect->list vect)
 221              (let loop ((lst '()) (i (##fixnum.- (,##vect-length vect) 1)))
 222                (if (##fixnum.< i 0)
 223                  lst
 224                  (loop (##cons (,##vect-ref vect i) lst) (##fixnum.- i 1)))))))
 225
 226        (define-prim (,##list->vect lst)
 227          (let loop1 ((x lst) (n 0))
 228            (if (##pair? x)
 229              (loop1 (##cdr x) (##fixnum.+ n 1))
 230              (let ((vect (,##make-vect n ,default-elem-value)))
 231                (let loop2 ((x lst) (i 0))
 232                  (if (and (##pair? x)      ;; double check in case another
 233                           (##fixnum.< i n));; thread mutates the list
 234                    (let ((elem (##car x)))
 235                      (,##vect-set! vect i elem)
 236                      (loop2 (##cdr x) (##fixnum.+ i 1)))
 237                    vect))))))
 238
 239        (define-prim (,list->vect lst)
 240          (let loop1 ((x lst) (n 0))
 241            (macro-force-vars (x)
 242              (if (##pair? x)
 243                (loop1 (##cdr x) (##fixnum.+ n 1))
 244                (macro-check-list x 1 (,list->vect lst)
 245                  (let ((vect (,##make-vect n ,default-elem-value)))
 246                    (let loop2 ((x lst) (i 0))
 247                      (macro-force-vars (x)
 248                        (if (and (##pair? x)      ;; double check in case another
 249                                 (##fixnum.< i n));; thread mutates the list
 250                          (let ((elem (##car x)))
 251                            (,macro-check-elem-list elem 1 (,list->vect lst)
 252                              (begin
 253                                (,##vect-set! vect i elem)
 254                                (loop2 (##cdr x) (##fixnum.+ i 1)))))
 255                          vect)))))))))
 256
 257        (define-prim (,##vect-fill! vect fill)
 258          (,##subvect-fill! vect 0 (,##vect-length vect) fill))
 259
 260        (define-prim (,vect-fill! vect fill)
 261          (macro-force-vars (vect)
 262            (,macro-force-elem (fill)
 263              (,macro-check-vect vect 1 (,vect-fill! vect fill)
 264                (macro-check-subtyped-mutable vect 1 (,vect-fill! vect fill)
 265                  (,macro-check-elem fill 2 (,vect-fill! vect fill)
 266                    (,##vect-fill! vect fill)))))))
 267
 268        (define-prim (,##vect-copy vect)
 269          (let ((len (,##vect-length vect)))
 270            (,##subvect-move! vect 0 len (,##make-vect len) 0)))
 271
 272        (define-prim (,vect-copy vect)
 273          (macro-force-vars (vect)
 274            (,macro-check-vect vect 1 (,vect-copy vect)
 275              (,##vect-copy vect))))
 276
 277        (define-prim (,##subvect vect start end)
 278          (,##subvect-move!
 279           vect
 280           start
 281           end
 282           (,##make-vect (##fixnum.max (##fixnum.- end start) 0))
 283           0))
 284
 285        (define-prim (,subvect vect start end)
 286          (macro-force-vars (vect start end)
 287            (,macro-check-vect vect 1 (,subvect vect start end)
 288              (macro-check-index-range-incl
 289               start
 290               2
 291               0
 292               (,##vect-length vect)
 293               (,subvect vect start end)
 294               (macro-check-index-range-incl
 295                end
 296                3
 297                start
 298                (,##vect-length vect)
 299                (,subvect vect start end)
 300                (,##subvect vect start end))))))
 301
 302        (define-prim (,##append-vects lst #!optional (vect-append? #f))
 303          (let loop1 ((n 0)
 304                      (lst1 lst)
 305                      (lst2 '())
 306                      (arg-num 1))
 307            (cond ((##pair? lst1)
 308                   (let ((vect (##car lst1)))
 309                     (macro-force-vars (vect)
 310                       (if (##not (,##vect? vect))
 311                           (if vect-append?
 312                               (,##fail-check-vect arg-num '() ,vect-append lst)
 313                               (,##fail-check-vect-list 1 ,append-vects lst))
 314                           (loop1 (##fixnum.+ n (,##vect-length vect))
 315                                  (##cdr lst1)
 316                                  (##cons vect lst2)
 317                                  (##fixnum.+ arg-num 1))))))
 318                  ((##null? lst1)
 319                   (let ((result (,##make-vect n)))
 320                     (let loop2 ((n n)
 321                                 (lst2 lst2))
 322                       (if (##pair? lst2)
 323                           (let* ((vect (##car lst2))
 324                                  (len (,##vect-length vect))
 325                                  (new-n (##fixnum.- n len)))
 326                             (,##subvect-move! vect 0 len result new-n)
 327                             (loop2 new-n (##cdr lst2)))
 328                           result))))
 329                  (else
 330                   (,##fail-check-vect-list 1 ,append-vects lst)))))
 331
 332        (define-prim (,append-vects lst)
 333          (,##append-vects lst #f))
 334
 335        (define-prim (,##vect-append . lst)
 336          (,##append-vects lst #t))
 337
 338        (define-prim (,vect-append . lst)
 339          (,##append-vects lst #t))
 340
 341 #;
 342        (define-prim (,##subvect-move! src-vect src-start src-end dst-vect dst-start)
 343          ;; Copy direction must be selected in case src-vect and
 344          ;; dst-vect are the same object.
 345          (if (##fixnum.< src-start dst-start)
 346            (let loop1 ((i (##fixnum.- src-end 1))
 347                        (j (##fixnum.-
 348                            (##fixnum.+ dst-start
 349                                        (##fixnum.- src-end src-start))
 350                            1)))
 351              (if (##fixnum.< i src-start)
 352                dst-vect
 353                (begin
 354                  (,##vect-set! dst-vect j (,##vect-ref src-vect i))
 355                  (loop1 (##fixnum.- i 1)
 356                         (##fixnum.- j 1)))))
 357            (let loop2 ((i src-start)
 358                        (j dst-start))
 359              (if (##fixnum.< i src-end)
 360                (begin
 361                  (,##vect-set! dst-vect j (,##vect-ref src-vect i))
 362                  (loop2 (##fixnum.+ i 1)
 363                         (##fixnum.+ j 1)))
 364                dst-vect))))
 365
 366        (define-prim (,subvect-move! src-vect src-start src-end dst-vect dst-start)
 367          (macro-force-vars (src-vect src-start src-end dst-vect dst-start)
 368            (,macro-check-vect
 369             src-vect
 370             1
 371             (,subvect-move! src-vect src-start src-end dst-vect dst-start)
 372             (macro-check-index-range-incl
 373              src-start
 374              2
 375              0
 376              (,##vect-length src-vect)
 377              (,subvect-move! src-vect src-start src-end dst-vect dst-start)
 378              (macro-check-index-range-incl
 379               src-end
 380               3
 381               src-start
 382               (,##vect-length src-vect)
 383               (,subvect-move! src-vect src-start src-end dst-vect dst-start)
 384               (,macro-check-vect
 385                dst-vect
 386                4
 387                (,subvect-move! src-vect src-start src-end dst-vect dst-start)
 388                (macro-check-subtyped-mutable
 389                 dst-vect
 390                 4
 391                 (,subvect-move! src-vect src-start src-end dst-vect dst-start)
 392                 (macro-check-index-range-incl
 393                  dst-start
 394                  5
 395                  0
 396                  (##fixnum.- (,##vect-length dst-vect)
 397                              (##fixnum.- src-end src-start))
 398                  (,subvect-move! src-vect src-start src-end dst-vect dst-start)
 399                  (begin
 400                    (,##subvect-move! src-vect src-start src-end dst-vect dst-start)
 401                    (##void))))))))))
 402
 403        (define-prim (,##subvect-fill! vect start end fill)
 404          (let loop ((i (##fixnum.- end 1)))
 405            (if (##fixnum.< i start)
 406              (##void)
 407              (begin
 408                (,##vect-set! vect i fill)
 409                (loop (##fixnum.- i 1))))))
 410
 411        (define-prim (,subvect-fill! vect start end fill)
 412          (macro-force-vars (vect start end)
 413            (,macro-force-elem (fill)
 414              (,macro-check-vect vect 1 (,subvect-fill! vect start end fill)
 415                (macro-check-subtyped-mutable vect 1 (,subvect-fill! vect start end fill)
 416                  (macro-check-index-range-incl
 417                   start
 418                   2
 419                   0
 420                   (,##vect-length vect)
 421                   (,subvect-fill! vect start end fill)
 422                   (macro-check-index-range-incl
 423                    end
 424                    3
 425                    start
 426                    (,##vect-length vect)
 427                    (,subvect-fill! vect start end fill)
 428                    (,macro-check-elem
 429                     fill
 430                     4
 431                     (,subvect-fill! vect start end fill)
 432                     (,##subvect-fill! vect start end fill)))))))))
 433
 434        (define-prim (,##vect-shrink! vect k))
 435
 436        (define-prim (,vect-shrink! vect k)
 437          (macro-force-vars (vect k)
 438            (,macro-check-vect vect 1 (,vect-shrink! vect k)
 439              (macro-check-subtyped-mutable vect 1 (,vect-shrink! vect k)
 440                (macro-check-index-range-incl
 441                 k
 442                 2
 443                 0
 444                 (,##vect-length vect)
 445                 (,vect-shrink! vect k)
 446                 (begin
 447                   (,##vect-shrink! vect k)
 448                   (##void))))))))))
 449
 450 (define-prim-vector-procedures
 451   string
 452   #\nul
 453   macro-force-vars
 454   macro-check-char
 455   macro-check-char-list)
 456
 457 (define-prim-vector-procedures
 458   vector
 459   0
 460   macro-no-force
 461   macro-no-check
 462   macro-no-check)
 463
 464 (define-prim-vector-procedures
 465   s8vector
 466   0
 467   macro-force-vars
 468   macro-check-exact-signed-int8
 469   macro-check-exact-signed-int8-list)
 470
 471 (define-prim-vector-procedures
 472   u8vector
 473   0
 474   macro-force-vars
 475   macro-check-exact-unsigned-int8
 476   macro-check-exact-unsigned-int8-list)
 477
 478 (define-prim-vector-procedures
 479   s16vector
 480   0
 481   macro-force-vars
 482   macro-check-exact-signed-int16
 483   macro-check-exact-signed-int16-list)
 484
 485 (define-prim-vector-procedures
 486   u16vector
 487   0
 488   macro-force-vars
 489   macro-check-exact-unsigned-int16
 490   macro-check-exact-unsigned-int16-list)
 491
 492 (define-prim-vector-procedures
 493   s32vector
 494   0
 495   macro-force-vars
 496   macro-check-exact-signed-int32
 497   macro-check-exact-signed-int32-list)
 498
 499 (define-prim-vector-procedures
 500   u32vector
 501   0
 502   macro-force-vars
 503   macro-check-exact-unsigned-int32
 504   macro-check-exact-unsigned-int32-list)
 505
 506 (define-prim-vector-procedures
 507   s64vector
 508   0
 509   macro-force-vars
 510   macro-check-exact-signed-int64
 511   macro-check-exact-signed-int64-list)
 512
 513 (define-prim-vector-procedures
 514   u64vector
 515   0
 516   macro-force-vars
 517   macro-check-exact-unsigned-int64
 518   macro-check-exact-unsigned-int64-list)
 519
 520 (define-prim-vector-procedures
 521   f32vector
 522   0.
 523   macro-force-vars
 524   macro-check-inexact-real
 525   macro-check-inexact-real-list)
 526
 527 (define-prim-vector-procedures
 528   f64vector
 529   0.
 530   macro-force-vars
 531   macro-check-inexact-real
 532   macro-check-inexact-real-list)
 533
 534 ;;;----------------------------------------------------------------------------
 535
 536 (c-declare #<<c-declare-end
 537
 538 #include "os.h"
 539
 540 c-declare-end
 541 )
 542
 543 (define-prim ##subvector-move!
 544   (c-lambda (scheme-object  ;; src-vect
 545              scheme-object  ;; src-start
 546              scheme-object  ;; src-end
 547              scheme-object  ;; dst-vect
 548              scheme-object) ;; dst-start
 549             scheme-object
 550 #<<end-of-code
 551
 552   void *src = ___CAST(void*,&___FIELD(___arg1,___INT(___arg2)));
 553   void *dst = ___CAST(void*,&___FIELD(___arg4,___INT(___arg5)));
 554   long len = ___INT(___FIXSUB(___arg3,___arg2)) * ___WS;
 555
 556   memmove (dst, src, len);
 557
 558   ___result = ___arg4;
 559
 560 end-of-code
 561 ))
 562
 563 (define-prim ##substring-move!
 564   (c-lambda (scheme-object  ;; src-vect
 565              scheme-object  ;; src-start
 566              scheme-object  ;; src-end
 567              scheme-object  ;; dst-vect
 568              scheme-object) ;; dst-start
 569             scheme-object
 570 #<<end-of-code
 571
 572   void *src =
 573         ___CAST(void*,
 574                 ___CS_SELECT(&___FETCH_U8(___BODY(___arg1),___INT(___arg2)),
 575                              &___FETCH_U16(___BODY(___arg1),___INT(___arg2)),
 576                              &___FETCH_U32(___BODY(___arg1),___INT(___arg2))));
 577   void *dst =
 578         ___CAST(void*,
 579                 ___CS_SELECT(&___FETCH_U8(___BODY(___arg4),___INT(___arg5)),
 580                              &___FETCH_U16(___BODY(___arg4),___INT(___arg5)),
 581                              &___FETCH_U32(___BODY(___arg4),___INT(___arg5))));
 582   long len = ___INT(___FIXSUB(___arg3,___arg2)) * ___CS;
 583
 584   memmove (dst, src, len);
 585
 586   ___result = ___arg4;
 587
 588 end-of-code
 589 ))
 590
 591 (define-prim ##subs8vector-move!
 592   (c-lambda (scheme-object  ;; src-vect
 593              scheme-object  ;; src-start
 594              scheme-object  ;; src-end
 595              scheme-object  ;; dst-vect
 596              scheme-object) ;; dst-start
 597             scheme-object
 598 #<<end-of-code
 599
 600   void *src = ___CAST(void*,&___FETCH_S8(___BODY(___arg1),___INT(___arg2)));
 601   void *dst = ___CAST(void*,&___FETCH_S8(___BODY(___arg4),___INT(___arg5)));
 602   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___S8);
 603
 604   memmove (dst, src, len);
 605
 606   ___result = ___arg4;
 607
 608 end-of-code
 609 ))
 610
 611 (define-prim ##subu8vector-move!
 612   (c-lambda (scheme-object  ;; src-vect
 613              scheme-object  ;; src-start
 614              scheme-object  ;; src-end
 615              scheme-object  ;; dst-vect
 616              scheme-object) ;; dst-start
 617             scheme-object
 618 #<<end-of-code
 619
 620   void *src = ___CAST(void*,&___FETCH_U8(___BODY(___arg1),___INT(___arg2)));
 621   void *dst = ___CAST(void*,&___FETCH_U8(___BODY(___arg4),___INT(___arg5)));
 622   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___U8);
 623
 624   memmove (dst, src, len);
 625
 626   ___result = ___arg4;
 627
 628 end-of-code
 629 ))
 630
 631 (define-prim ##subs16vector-move!
 632   (c-lambda (scheme-object  ;; src-vect
 633              scheme-object  ;; src-start
 634              scheme-object  ;; src-end
 635              scheme-object  ;; dst-vect
 636              scheme-object) ;; dst-start
 637             scheme-object
 638 #<<end-of-code
 639
 640   void *src = ___CAST(void*,&___FETCH_S16(___BODY(___arg1),___INT(___arg2)));
 641   void *dst = ___CAST(void*,&___FETCH_S16(___BODY(___arg4),___INT(___arg5)));
 642   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___S16);
 643
 644   memmove (dst, src, len);
 645
 646   ___result = ___arg4;
 647
 648 end-of-code
 649 ))
 650
 651 (define-prim ##subu16vector-move!
 652   (c-lambda (scheme-object  ;; src-vect
 653              scheme-object  ;; src-start
 654              scheme-object  ;; src-end
 655              scheme-object  ;; dst-vect
 656              scheme-object) ;; dst-start
 657             scheme-object
 658 #<<end-of-code
 659
 660   void *src = ___CAST(void*,&___FETCH_U16(___BODY(___arg1),___INT(___arg2)));
 661   void *dst = ___CAST(void*,&___FETCH_U16(___BODY(___arg4),___INT(___arg5)));
 662   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___U16);
 663
 664   memmove (dst, src, len);
 665
 666   ___result = ___arg4;
 667
 668 end-of-code
 669 ))
 670
 671 (define-prim ##subs32vector-move!
 672   (c-lambda (scheme-object  ;; src-vect
 673              scheme-object  ;; src-start
 674              scheme-object  ;; src-end
 675              scheme-object  ;; dst-vect
 676              scheme-object) ;; dst-start
 677             scheme-object
 678 #<<end-of-code
 679
 680   void *src = ___CAST(void*,&___FETCH_S32(___BODY(___arg1),___INT(___arg2)));
 681   void *dst = ___CAST(void*,&___FETCH_S32(___BODY(___arg4),___INT(___arg5)));
 682   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___S32);
 683
 684   memmove (dst, src, len);
 685
 686   ___result = ___arg4;
 687
 688 end-of-code
 689 ))
 690
 691 (define-prim ##subu32vector-move!
 692   (c-lambda (scheme-object  ;; src-vect
 693              scheme-object  ;; src-start
 694              scheme-object  ;; src-end
 695              scheme-object  ;; dst-vect
 696              scheme-object) ;; dst-start
 697             scheme-object
 698 #<<end-of-code
 699
 700   void *src = ___CAST(void*,&___FETCH_U32(___BODY(___arg1),___INT(___arg2)));
 701   void *dst = ___CAST(void*,&___FETCH_U32(___BODY(___arg4),___INT(___arg5)));
 702   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___U32);
 703
 704   memmove (dst, src, len);
 705
 706   ___result = ___arg4;
 707
 708 end-of-code
 709 ))
 710
 711 (define-prim ##subs64vector-move!
 712   (c-lambda (scheme-object  ;; src-vect
 713              scheme-object  ;; src-start
 714              scheme-object  ;; src-end
 715              scheme-object  ;; dst-vect
 716              scheme-object) ;; dst-start
 717             scheme-object
 718 #<<end-of-code
 719
 720   void *src = ___CAST(void*,&___FETCH_S64(___BODY(___arg1),___INT(___arg2)));
 721   void *dst = ___CAST(void*,&___FETCH_S64(___BODY(___arg4),___INT(___arg5)));
 722   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___S64);
 723
 724   memmove (dst, src, len);
 725
 726   ___result = ___arg4;
 727
 728 end-of-code
 729 ))
 730
 731 (define-prim ##subu64vector-move!
 732   (c-lambda (scheme-object  ;; src-vect
 733              scheme-object  ;; src-start
 734              scheme-object  ;; src-end
 735              scheme-object  ;; dst-vect
 736              scheme-object) ;; dst-start
 737             scheme-object
 738 #<<end-of-code
 739
 740   void *src = ___CAST(void*,&___FETCH_U64(___BODY(___arg1),___INT(___arg2)));
 741   void *dst = ___CAST(void*,&___FETCH_U64(___BODY(___arg4),___INT(___arg5)));
 742   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___U64);
 743
 744   memmove (dst, src, len);
 745
 746   ___result = ___arg4;
 747
 748 end-of-code
 749 ))
 750
 751 (define-prim ##subf32vector-move!
 752   (c-lambda (scheme-object  ;; src-vect
 753              scheme-object  ;; src-start
 754              scheme-object  ;; src-end
 755              scheme-object  ;; dst-vect
 756              scheme-object) ;; dst-start
 757             scheme-object
 758 #<<end-of-code
 759
 760   void *src = ___CAST(void*,___CAST(___F32*,___BODY(___arg1))+___INT(___arg2));
 761   void *dst = ___CAST(void*,___CAST(___F32*,___BODY(___arg4))+___INT(___arg5));
 762   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___F32);
 763
 764   memmove (dst, src, len);
 765
 766   ___result = ___arg4;
 767
 768 end-of-code
 769 ))
 770
 771 (define-prim ##subf64vector-move!
 772   (c-lambda (scheme-object  ;; src-vect
 773              scheme-object  ;; src-start
 774              scheme-object  ;; src-end
 775              scheme-object  ;; dst-vect
 776              scheme-object) ;; dst-start
 777             scheme-object
 778 #<<end-of-code
 779
 780   void *src = ___CAST(void*,___CAST(___F64*,___BODY(___arg1))+___INT(___arg2));
 781   void *dst = ___CAST(void*,___CAST(___F64*,___BODY(___arg4))+___INT(___arg5));
 782   long len = ___INT(___FIXSUB(___arg3,___arg2)) * sizeof (___F64);
 783
 784   memmove (dst, src, len);
 785
 786   ___result = ___arg4;
 787
 788 end-of-code
 789 ))
 790 ;;;----------------------------------------------------------------------------
 791
 792 ;; IEEE Scheme procedures:
 793
 794 (define-prim (##not obj)
 795   (if obj #f #t))
 796
 797 (define-prim (not obj)
 798   (macro-force-vars (obj)
 799     (##not obj)))
 800
 801 (define-prim (boolean? obj)
 802   (macro-force-vars (obj)
 803     (##boolean? obj)))
 804
 805 (define-prim (##boolean? obj)
 806   (or (##eq? obj #t) (##eq? obj #f)))
 807
 808 ;; eqv? is defined in "_num.scm"
 809 ;; eq? and equal? are defined in "_kernel.scm"
 810
 811 (define-fail-check-type pair-mutable 'mutable)
 812 (define-fail-check-type subtyped-mutable 'mutable)
 813 (define-fail-check-type pair 'pair)
 814 (define-fail-check-type pair-list 'pair-list)
 815 (define-fail-check-type list 'list)
 816
 817 (define-prim (##pair? obj))
 818
 819 (define-prim (##pair-mutable? obj))
 820
 821 (define-prim (pair? obj)
 822   (macro-force-vars (obj)
 823     (##pair? obj)))
 824
 825 (define-prim (##cons obj1 obj2))
 826
 827 (define-prim (cons obj1 obj2)
 828   (##cons obj1 obj2))
 829
 830 (##define-macro (define-prim-c...r-procedures from-length to-length)
 831
 832   (define (gen-name pattern)
 833
 834     (define (ads pattern)
 835       (if (= pattern 1)
 836         ""
 837         (string-append (ads (quotient pattern 2))
 838                        (if (odd? pattern) "d" "a"))))
 839
 840     (string->symbol (string-append "c" (ads pattern) "r")))
 841
 842   (define (gen3 i j)
 843     (if (> i j)
 844       `()
 845       (let* ((name
 846               (gen-name i))
 847              (##name
 848               (string->symbol (string-append "##" (symbol->string name)))))
 849
 850         (define (gen1 var pattern)
 851           (if (<= pattern 3)
 852             (if (= pattern 3) `(##cdr ,var) `(##car ,var))
 853             `(let ((x ,(if (odd? pattern) `(##cdr ,var) `(##car ,var))))
 854                ,(gen1 'x (quotient pattern 2)))))
 855
 856         (define (gen2 var pattern)
 857           `(macro-check-pair ,var 1 (,name pair);;;;;;error message confusing?
 858              ,(if (<= pattern 3)
 859                 (if (= pattern 3) `(##cdr ,var) `(##car ,var))
 860                 `(let ((x ,(if (odd? pattern) `(##cdr ,var) `(##car ,var))))
 861                    (macro-force-vars (x)
 862                      ,(gen2 'x (quotient pattern 2)))))))
 863
 864         `((define-prim (,##name pair)
 865             ,(gen1 'pair i))
 866
 867           (define-prim (,name pair)
 868             (macro-force-vars (pair)
 869               ,(gen2 'pair i)))
 870
 871            ,@(gen3 (+ i 1) j)))))
 872
 873   `(begin ,@(gen3 (expt 2 from-length) (- (expt 2 (+ to-length 1)) 1))))
 874
 875 (define-prim-c...r-procedures 1 4) ;; define car to cddddr
 876
 877 (define-prim (##set-car! pair val))
 878
 879 (define-prim (set-car! pair val)
 880   (macro-force-vars (pair)
 881     (macro-check-pair pair 1 (set-car! pair val)
 882       (macro-check-pair-mutable pair 1 (set-car! pair val)
 883         (begin
 884           (##set-car! pair val)
 885           (##void))))))
 886
 887 (define-prim (##set-cdr! pair val))
 888
 889 (define-prim (set-cdr! pair val)
 890   (macro-force-vars (pair)
 891     (macro-check-pair pair 1 (set-cdr! pair val)
 892       (macro-check-pair-mutable pair 1 (set-cdr! pair val)
 893         (begin
 894           (##set-cdr! pair val)
 895           (##void))))))
 896
 897 (define-prim (##null? obj)
 898   (##eq? obj '()))
 899
 900 (define-prim (null? obj)
 901   (macro-force-vars (obj)
 902     (##null? obj)))
 903
 904 (define-prim (list? lst)
 905   ;; This procedure may get into an infinite loop if another thread
 906   ;; mutates "lst" (if lst1 and lst2 each point to disconnected cycles).
 907   (let loop ((lst1 lst) (lst2 lst))
 908     (macro-force-vars (lst1)
 909       (if (##not (##pair? lst1))
 910         (##null? lst1)
 911         (let ((lst1 (##cdr lst1)))
 912           (macro-force-vars (lst1 lst2)
 913             (cond ((##eq? lst1 lst2)
 914                    #f)
 915                   ((##not (##pair? lst2))
 916                    ;; this case is possible if other threads mutate the list
 917                    (##null? lst2))
 918                   ((##pair? lst1)
 919                    (loop (##cdr lst1) (##cdr lst2)))
 920                   (else
 921                    (##null? lst1)))))))))
 922
 923 (define-prim (##list . lst)
 924   lst)
 925
 926 (define-prim (list . lst)
 927   lst)
 928
 929 (define-prim (##length lst)
 930   (let loop ((x lst) (n 0))
 931     (if (##pair? x)
 932       (loop (##cdr x) (##fixnum.+ n 1))
 933       n)))
 934
 935 (define-prim (length lst)
 936   (let loop ((x lst) (n 0))
 937     (macro-force-vars (x)
 938       (if (##pair? x)
 939         (loop (##cdr x) (##fixnum.+ n 1))
 940         (macro-check-list x 1 (length lst)
 941           n)))))
 942
 943 (define-prim (##append lst1 lst2)
 944   (if (##pair? lst1)
 945     (##cons (##car lst1) (##append (##cdr lst1) lst2))
 946     lst2))
 947
 948 (define-prim (append
 949               #!optional
 950               (lst1 (macro-absent-obj))
 951               (lst2 (macro-absent-obj))
 952               #!rest
 953               others)
 954
 955   (define (append-multiple head tail arg-num)
 956     (if (##null? tail)
 957       head
 958       (macro-force-vars (head)
 959         (if (##null? head)
 960           (append-multiple (##car tail) (##cdr tail) (##fixnum.+ arg-num 1))
 961           (list-expected-check
 962            (append-multiple-non-null head
 963                                      tail
 964                                      arg-num
 965                                      (##fixnum.+ arg-num 1)))))))
 966
 967   (define (append-multiple-non-null x lsts arg-num1 arg-num2)
 968     ;; x!=(), returns fixnum on error
 969     (let ((head (##car lsts))
 970           (tail (##cdr lsts)))
 971       (if (##null? tail)
 972         (append-2-non-null x head arg-num1)
 973         (macro-force-vars (head)
 974           (if (##null? head)
 975             (append-multiple-non-null x
 976                                       tail
 977                                       arg-num1
 978                                       (##fixnum.+ arg-num2 1))
 979             (let ((result
 980                    (append-multiple-non-null head
 981                                              tail
 982                                              arg-num2
 983                                              (##fixnum.+ arg-num2 1))))
 984               (macro-if-checks
 985                 (if (##fixnum? result)
 986                   result
 987                   (append-2-non-null x result arg-num1))
 988                 (append-2-non-null x result arg-num1))))))))
 989
 990   (define (append-2-non-null x y arg-num)
 991     ;; x!=(), returns fixnum on error
 992     (if (##pair? x)
 993       (let ((head (##car x))
 994             (tail (##cdr x)))
 995         (macro-force-vars (tail)
 996           (if (##null? tail)
 997             (##cons head y)
 998             (let ((result (append-2-non-null tail y arg-num)))
 999               (macro-if-checks
1000                 (if (##fixnum? result)
1001                   result
1002                   (##cons head result))
1003                 (##cons head result))))))
1004       (macro-if-checks
1005         arg-num ;; error: list expected
1006         y)))
1007
1008   (define (list-expected-check result)
1009     (macro-if-checks
1010       (if (##fixnum? result)
1011         (macro-fail-check-list result (append lst1 lst2 . others))
1012         result)
1013       result))
1014
1015   (cond ((##eq? lst2 (macro-absent-obj))
1016          (if (##eq? lst1 (macro-absent-obj))
1017            '()
1018            lst1))
1019         ((##null? others)
1020          (macro-force-vars (lst1)
1021            (if (##null? lst1)
1022              lst2
1023              (list-expected-check (append-2-non-null lst1 lst2 1)))))
1024         (else
1025          (append-multiple lst1 (##cons lst2 others) 1))))
1026
1027 (define-prim (##reverse lst)
1028   (let loop ((x lst) (result '()))
1029     (if (##pair? x)
1030       (loop (##cdr x) (##cons (##car x) result))
1031       result)))
1032
1033 (define-prim (reverse lst)
1034   (let loop ((x lst) (result '()))
1035     (macro-force-vars (x)
1036       (if (##pair? x)
1037         (loop (##cdr x) (##cons (##car x) result))
1038         (macro-check-list x 1 (reverse lst)
1039           result)))))
1040
1041 (define-prim (list-ref lst k)
1042   (macro-force-vars (k)
1043     (macro-check-index k 2 (list-ref lst k)
1044       (let loop ((x lst) (i k))
1045         (macro-force-vars (x)
1046           (macro-check-pair x 1 (list-ref lst k);;;;;;;error message confusing?
1047             (if (##fixnum.< 0 i)
1048               (loop (##cdr x) (##fixnum.- i 1))
1049               (##car x))))))))
1050
1051 (define-prim (##memq obj lst)
1052   (let loop ((x lst))
1053     (if (##pair? x)
1054       (if (##eq? obj (##car x))
1055         x
1056         (loop (##cdr x)))
1057       #f)))
1058
1059 (define-prim (memq obj lst)
1060   (macro-force-vars (obj)
1061     (let loop ((x lst))
1062       (macro-force-vars (x)
1063         (if (##pair? x)
1064           (let ((y (##car x)))
1065             (macro-force-vars (y)
1066               (if (##eq? obj y)
1067                 x
1068                 (loop (##cdr x)))))
1069           (macro-check-list x 2 (memq obj lst)
1070             #f))))))
1071
1072 (define-prim (memv obj lst)
1073   (macro-force-vars (obj)
1074     (let loop ((x lst))
1075       (macro-force-vars (x)
1076         (if (##pair? x)
1077           (let ((y (##car x)))
1078             (macro-force-vars (y)
1079               (if (let ()
1080                     (##declare (generic)) ;; avoid fixnum specific ##eqv?
1081                     (##eqv? obj y))
1082                 x
1083                 (loop (##cdr x)))))
1084           (macro-check-list x 2 (memv obj lst)
1085             #f))))))
1086
1087 (define-prim (##member obj lst)
1088   (let loop ((x lst))
1089     (if (##pair? x)
1090       (if (##equal? obj (##car x))
1091         x
1092         (loop (##cdr x)))
1093       #f)))
1094
1095 (define-prim (member obj lst)
1096   (let loop ((x lst))
1097     (macro-force-vars (x)
1098       (if (##pair? x)
1099         (let ((y (##car x)))
1100           (if (##equal? obj y)
1101             x
1102             (loop (##cdr x))))
1103         (macro-check-list x 2 (member obj lst)
1104           #f)))))
1105
1106 (define-prim (##assq-cdr obj lst)
1107   (let loop ((x lst))
1108     (if (##pair? x)
1109       (let ((couple (##car x)))
1110         (if (##eq? obj (##cdr couple))
1111           couple
1112           (loop (##cdr x))))
1113         #f)))
1114
1115 (define-prim (##assq obj lst)
1116   (let loop ((x lst))
1117     (if (##pair? x)
1118       (let ((couple (##car x)))
1119         (if (##eq? obj (##car couple))
1120           couple
1121           (loop (##cdr x))))
1122         #f)))
1123
1124 (define-prim (assq obj lst)
1125   (macro-force-vars (obj)
1126     (let loop ((x lst))
1127       (macro-force-vars (x)
1128         (if (##pair? x)
1129           (let ((couple (##car x)))
1130             (macro-force-vars (couple)
1131               (macro-check-pair-list couple 2 (assq obj lst)
1132                 (let ((y (##car couple)))
1133                   (macro-force-vars (y)
1134                     (if (##eq? obj y)
1135                       couple
1136                       (loop (##cdr x))))))))
1137           (macro-check-list x 2 (assq obj lst)
1138             #f))))))
1139
1140 (define-prim (assv obj lst)
1141   (macro-force-vars (obj)
1142     (let loop ((x lst))
1143       (macro-force-vars (x)
1144         (if (##pair? x)
1145           (let ((couple (##car x)))
1146             (macro-force-vars (couple)
1147               (macro-check-pair-list couple 2 (assv obj lst)
1148                 (let ((y (##car couple)))
1149                   (macro-force-vars (y)
1150                     (if (let ()
1151                           (##declare (generic)) ;; avoid fixnum specific ##eqv?
1152                           (##eqv? obj y))
1153                       couple
1154                       (loop (##cdr x))))))))
1155           (macro-check-list x 2 (assv obj lst)
1156             #f))))))
1157
1158 (define-prim (##assoc obj lst)
1159   (let loop ((x lst))
1160     (if (##pair? x)
1161       (let ((couple (##car x)))
1162         (if (##equal? obj (##car couple))
1163           couple
1164           (loop (##cdr x))))
1165       #f)))
1166
1167 (define-prim (assoc obj lst)
1168   (let loop ((x lst))
1169     (macro-force-vars (x)
1170       (if (##pair? x)
1171         (let ((couple (##car x)))
1172           (macro-force-vars (couple)
1173             (macro-check-pair-list couple 2 (assoc obj lst)
1174               (let ((y (##car couple)))
1175                 (if (##equal? obj y)
1176                   couple
1177                   (loop (##cdr x)))))))
1178         (macro-check-list x 2 (assoc obj lst)
1179           #f)))))
1180
1181 (define-fail-check-type symbol 'symbol)
1182
1183 (define-prim (##symbol? obj)
1184   (and (##subtyped? obj)
1185        (##eq? (##subtype obj) (macro-subtype-symbol))))
1186
1187 (define-prim (symbol? obj)
1188   (macro-force-vars (obj)
1189     (##symbol? obj)))
1190
1191 (define-prim (##symbol->string sym)
1192   (let ((name (macro-symbol-name sym)))
1193     (if (##fixnum? name)
1194       (let ((str (##string-append "g" (##number->string name 10))))
1195         (##declare (not interrupts-enabled))
1196         (let ((name (macro-symbol-name sym)))
1197           ;; Double-check in case a different thread has also called
1198           ;; and completed the call to ##symbol->string on this symbol.
1199           (if (##fixnum? name)
1200             (begin
1201               (macro-symbol-name-set! sym str)
1202               str)
1203             name)))
1204       name)))
1205
1206 (define-prim (symbol->string sym)
1207   (macro-force-vars (sym)
1208     (macro-check-symbol sym 1 (symbol->string sym)
1209       (##symbol->string sym))))
1210
1211 (define-prim (##string->symbol str)
1212   (##make-interned-symbol str))
1213
1214 (define-prim (string->symbol str)
1215   (macro-force-vars (str)
1216     (macro-check-string str 1 (string->symbol str)
1217       (##string->symbol str))))
1218
1219 (define-prim (##uninterned-symbol? obj)
1220   (and (##symbol? obj)
1221        (##not (macro-symbol-next obj))))
1222
1223 (define-prim (uninterned-symbol? obj)
1224   (macro-force-vars (obj)
1225     (##uninterned-symbol? obj)))
1226
1227 (define ##symbol-counter 0)
1228
1229 (define-prim (##make-uninterned-symbol
1230               str
1231               #!optional
1232               (hash (macro-absent-obj)))
1233
1234   ;; str must be a nonmutable string
1235
1236   (if (##eq? hash (macro-absent-obj))
1237     (let ((n (##fixnum.+ ##symbol-counter 1)))
1238       ;; Note: it is unimportant if the increment of ##symbol-counter
1239       ;; is not atomic; it simply means a possible close repetition
1240       ;; of the same hash code
1241       (set! ##symbol-counter n)
1242       (macro-make-uninterned-symbol str (##partial-bit-reverse n)))
1243     (macro-make-uninterned-symbol str hash)))
1244
1245 (define-prim (make-uninterned-symbol
1246               str
1247               #!optional
1248               (hash (macro-absent-obj)))
1249   (macro-force-vars (str hash)
1250     (macro-check-string str 1 (make-uninterned-symbol str hash)
1251       (if (##eq? hash (macro-absent-obj))
1252         (##make-uninterned-symbol str)
1253         (macro-check-fixnum-range-incl hash 2 0 536870911 (make-uninterned-symbol str hash)
1254           (##make-uninterned-symbol str hash))))))
1255
1256 ;; Number related procedures are in "_num.scm"
1257
1258 (define-fail-check-type char 'char)
1259 (define-fail-check-type char-list 'char-list)
1260
1261 (define-prim (##char? obj))
1262
1263 (define-prim (char? obj)
1264   (macro-force-vars (obj)
1265     (##char? obj)))
1266
1267 (define-prim-nary-bool (##char=? x y)
1268   #t
1269   #t
1270   (##char=? x y)
1271   macro-no-force
1272   macro-no-check)
1273
1274 (define-prim-nary-bool (char=? x y)
1275   #t
1276   #t
1277   (##char=? x y)
1278   macro-force-vars
1279   macro-check-char)
1280
1281 (define-prim-nary-bool (##char<? x y)
1282   #t
1283   #t
1284   (##char<? x y)
1285   macro-no-force
1286   macro-no-check)
1287
1288 (define-prim-nary-bool (char<? x y)
1289   #t
1290   #t
1291   (##char<? x y)
1292   macro-force-vars
1293   macro-check-char)
1294
1295 (define-prim-nary-bool (##char>? x y)
1296   #t
1297   #t
1298   (##char<? y x)
1299   macro-no-force
1300   macro-no-check)
1301
1302 (define-prim-nary-bool (char>? x y)
1303   #t
1304   #t
1305   (##char<? y x)
1306   macro-force-vars
1307   macro-check-char)
1308
1309 (define-prim-nary-bool (##char<=? x y)
1310   #t
1311   #t
1312   (##not (##char<? y x))
1313   macro-no-force
1314   macro-no-check)
1315
1316 (define-prim-nary-bool (char<=? x y)
1317   #t
1318   #t
1319   (##not (##char<? y x))
1320   macro-force-vars
1321   macro-check-char)
1322
1323 (define-prim-nary-bool (##char>=? x y)
1324   #t
1325   #t
1326   (##not (##char<? x y))
1327   macro-no-force
1328   macro-no-check)
1329
1330 (define-prim-nary-bool (char>=? x y)
1331   #t
1332   #t
1333   (##not (##char<? x y))
1334   macro-force-vars
1335   macro-check-char)
1336
1337 (##define-macro (case-independent-char=? x y)
1338   `(##char=? (##char-downcase ,x) (##char-downcase ,y)))
1339
1340 (##define-macro (case-independent-char<? x y)
1341   `(##char<? (##char-downcase ,x) (##char-downcase ,y)))
1342
1343 (define-prim-nary-bool (##char-ci=? x y)
1344   #t
1345   #t
1346   (case-independent-char=? x y)
1347   macro-no-force
1348   macro-no-check)
1349
1350 (define-prim-nary-bool (char-ci=? x y)
1351   #t
1352   #t
1353   (case-independent-char=? x y)
1354   macro-force-vars
1355   macro-check-char)
1356
1357 (define-prim-nary-bool (##char-ci<? x y)
1358   #t
1359   #t
1360   (case-independent-char<? x y)
1361   macro-no-force
1362   macro-no-check)
1363
1364 (define-prim-nary-bool (char-ci<? x y)
1365   #t
1366   #t
1367   (case-independent-char<? x y)
1368   macro-force-vars
1369   macro-check-char)
1370
1371 (define-prim-nary-bool (##char-ci>? x y)
1372   #t
1373   #t
1374   (case-independent-char<? y x)
1375   macro-no-force
1376   macro-no-check)
1377
1378 (define-prim-nary-bool (char-ci>? x y)
1379   #t
1380   #t
1381   (case-independent-char<? y x)
1382   macro-force-vars
1383   macro-check-char)
1384
1385 (define-prim-nary-bool (##char-ci<=? x y)
1386   #t
1387   #t
1388   (##not (case-independent-char<? y x))
1389   macro-no-force
1390   macro-no-check)
1391
1392 (define-prim-nary-bool (char-ci<=? x y)
1393   #t
1394   #t
1395   (##not (case-independent-char<? y x))
1396   macro-force-vars
1397   macro-check-char)
1398
1399 (define-prim-nary-bool (##char-ci>=? x y)
1400   #t
1401   #t
1402   (##not (case-independent-char<? x y))
1403   macro-no-force
1404   macro-no-check)
1405
1406 (define-prim-nary-bool (char-ci>=? x y)
1407   #t
1408   #t
1409   (##not (case-independent-char<? x y))
1410   macro-force-vars
1411   macro-check-char)
1412
1413 (define-prim (##char-alphabetic? c))
1414
1415 (define-prim (char-alphabetic? c)
1416   (macro-force-vars (c)
1417     (macro-check-char c 1 (char-alphabetic? c)
1418       (##char-alphabetic? c))))
1419
1420 (define-prim (##char-numeric? c))
1421
1422 (define-prim (char-numeric? c)
1423   (macro-force-vars (c)
1424     (macro-check-char c 1 (char-numeric? c)
1425       (##char-numeric? c))))
1426
1427 (define-prim (##char-whitespace? c))
1428
1429 (define-prim (char-whitespace? c)
1430   (macro-force-vars (c)
1431     (macro-check-char c 1 (char-whitespace? c)
1432       (##char-whitespace? c))))
1433
1434 (define-prim (##char-upper-case? c))
1435
1436 (define-prim (char-upper-case? c)
1437   (macro-force-vars (c)
1438     (macro-check-char c 1 (char-upper-case? c)
1439       (##char-upper-case? c))))
1440
1441 (define-prim (##char-lower-case? c))
1442
1443 (define-prim (char-lower-case? c)
1444   (macro-force-vars (c)
1445     (macro-check-char c 1 (char-lower-case? c)
1446       (##char-lower-case? c))))
1447
1448 (define-prim (char->integer c)
1449   (macro-force-vars (c)
1450     (macro-check-char c 1 (char->integer c)
1451       (##fixnum.<-char c))))
1452
1453 (define-prim (integer->char n)
1454   (macro-force-vars (n)
1455     (macro-check-fixnum-range-incl n 1 0 ##max-char (integer->char n)
1456       (if (or (##fixnum.< n #xd800)
1457               (##fixnum.< #xdfff n))
1458         (##fixnum.->char n)
1459         (##raise-range-exception 1 integer->char n)))))
1460
1461 (define-prim (##char-upcase c))
1462
1463 (define-prim (char-upcase c)
1464   (macro-force-vars (c)
1465     (macro-check-char c 1 (char-upcase c)
1466       (##char-upcase c))))
1467
1468 (define-prim (##char-downcase c))
1469
1470 (define-prim (char-downcase c)
1471   (macro-force-vars (c)
1472     (macro-check-char c 1 (char-downcase c)
1473       (##char-downcase c))))
1474
1475 (define-prim (##string=? str1 str2)
1476   (or (##eq? str1 str2)
1477       (let ((len1 (##string-length str1)))
1478         (if (##eq? len1 (##string-length str2))
1479           (let loop ((i (##fixnum.- len1 1)))
1480             (cond ((##fixnum.< i 0)
1481                    #t)
1482                   ((##char=? (##string-ref str1 i) (##string-ref str2 i))
1483                    (loop (##fixnum.- i 1)))
1484                   (else
1485                    #f)))
1486           #f))))
1487
1488 (define-prim-nary-bool (string=? str1 str2)
1489   #t
1490   #t
1491   (##string=? str1 str2)
1492   macro-force-vars
1493   macro-check-string)
1494
1495 (define-prim (##string<? str1 str2)
1496   (and (##not (##eq? str1 str2))
1497        (let ((len1 (##string-length str1))
1498              (len2 (##string-length str2)))
1499          (let ((n (##fixnum.min len1 len2)))
1500            (let loop ((i 0))
1501              (if (##fixnum.< i n)
1502                (let ((c1 (##string-ref str1 i))
1503                      (c2 (##string-ref str2 i)))
1504                  (if (##char=? c1 c2)
1505                    (loop (##fixnum.+ i 1))
1506                    (##char<? c1 c2)))
1507                (##fixnum.< n len2)))))))
1508
1509 (define-prim-nary-bool (string<? str1 str2)
1510   #t
1511   #t
1512   (##string<? str1 str2)
1513   macro-force-vars
1514   macro-check-string)
1515
1516 (define-prim-nary-bool (string>? str1 str2)
1517   #t
1518   #t
1519   (##string<? str2 str1)
1520   macro-force-vars
1521   macro-check-string)
1522
1523 (define-prim-nary-bool (string<=? str1 str2)
1524   #t
1525   #t
1526   (##not (##string<? str2 str1))
1527   macro-force-vars
1528   macro-check-string)
1529
1530 (define-prim-nary-bool (string>=? str1 str2)
1531   #t
1532   #t
1533   (##not (##string<? str1 str2))
1534   macro-force-vars
1535   macro-check-string)
1536
1537 (define-prim (##string-ci=? str1 str2)
1538   (or (##eq? str1 str2)
1539       (let ((len1 (##string-length str1)))
1540         (if (##eq? len1 (##string-length str2))
1541           (let loop ((i (##fixnum.- len1 1)))
1542             (cond ((##fixnum.< i 0)
1543                    #t)
1544                   ((##char=? (##char-downcase (##string-ref str1 i))
1545                              (##char-downcase (##string-ref str2 i)))
1546                    (loop (##fixnum.- i 1)))
1547                   (else
1548                    #f)))
1549           #f))))
1550
1551 (define-prim-nary-bool (string-ci=? str1 str2)
1552   #t
1553   #t
1554   (##string-ci=? str1 str2)
1555   macro-force-vars
1556   macro-check-string)
1557
1558 (define-prim (##string-ci<? str1 str2)
1559   (and (##not (##eq? str1 str2))
1560        (let ((len1 (##string-length str1))
1561              (len2 (##string-length str2)))
1562          (let ((n (##fixnum.min len1 len2)))
1563            (let loop ((i 0))
1564              (if (##fixnum.< i n)
1565                (let ((c1 (##char-downcase (##string-ref str1 i)))
1566                      (c2 (##char-downcase (##string-ref str2 i))))
1567                  (if (##char=? c1 c2)
1568                    (loop (##fixnum.+ i 1))
1569                    (##char<? c1 c2)))
1570                (##fixnum.< n len2)))))))
1571
1572 (define-prim-nary-bool (string-ci<? str1 str2)
1573   #t
1574   #t
1575   (##string-ci<? str1 str2)
1576   macro-force-vars
1577   macro-check-string)
1578
1579 (define-prim-nary-bool (string-ci>? str1 str2)
1580   #t
1581   #t
1582   (##string-ci<? str2 str1)
1583   macro-force-vars
1584   macro-check-string)
1585
1586 (define-prim-nary-bool (string-ci<=? str1 str2)
1587   #t
1588   #t
1589   (##not (##string-ci<? str2 str1))
1590   macro-force-vars
1591   macro-check-string)
1592
1593 (define-prim-nary-bool (string-ci>=? str1 str2)
1594   #t
1595   #t
1596   (##not (##string-ci<? str1 str2))
1597   macro-force-vars
1598   macro-check-string)
1599
1600 (define-prim (##copy-string-list lst)
1601
1602   (define (copy lst i)
1603     (macro-force-vars (lst)
1604       (cond ((##pair? lst)
1605              (let ((str (##car lst)))
1606                (macro-force-vars (str)
1607                  (if (##string? str)
1608                    (let ((x (copy (##cdr lst) (##fixnum.+ i 1))))
1609                      (if (##fixnum? x)
1610                        x
1611                        (##cons str x)))
1612                    i))))
1613             ((##null? lst)
1614              '())
1615             (else
1616              0))))
1617
1618   (copy lst 1))
1619
1620 (define-fail-check-type procedure 'procedure)
1621
1622 (define-prim (##procedure? obj)
1623   (and (##subtyped? obj)
1624        (##eq? (##subtype obj) (macro-subtype-procedure))))
1625
1626 (define-prim (procedure? obj)
1627   (macro-force-vars (obj)
1628     (##procedure? obj)))
1629
1630 ;; apply is in "_kernel.scm"
1631
1632 (define-prim (##map proc lst)
1633   (let loop ((x lst))
1634     (if (##pair? x)
1635       (##cons (proc (##car x)) (loop (##cdr x)))
1636       '())))
1637
1638 (define-prim (map proc x . y)
1639   (macro-force-vars (proc)
1640     (macro-check-procedure proc 1 (map proc x . y)
1641       (let ()
1642
1643         (define (proper-list-length lst)
1644           (let loop ((lst lst) (n 0))
1645             (macro-force-vars (lst)
1646               (cond ((##pair? lst)
1647                      (loop (##cdr lst) (##fixnum.+ n 1)))
1648                     ((##null? lst)
1649                      n)
1650                     (else
1651                      #f)))))
1652
1653         (define (map-1 lst1)
1654           (macro-force-vars (lst1)
1655             (if (##pair? lst1)
1656               (let ((result (proc (##car lst1))))
1657                 (##cons result (map-1 (##cdr lst1))))
1658               '())))
1659
1660         (define (cars lsts)
1661           (if (##pair? lsts)
1662             (let ((lst1 (##car lsts)))
1663               (macro-force-vars (lst1)
1664                 (let ((head (##car lst1)))
1665                   (let ((tail (cars (##cdr lsts))))
1666                     (##cons head tail)))))
1667             '()))
1668
1669         (define (cdrs lsts)
1670           (if (##pair? lsts)
1671             (let ((lst1 (##car lsts)))
1672               (macro-force-vars (lst1)
1673                 (let ((head (##cdr lst1)))
1674                   (if (##pair? head)
1675                     (let ((tail (cdrs (##cdr lsts))))
1676                       (and tail
1677                            (##cons head tail)))
1678                     #f))))
1679             '()))
1680
1681         (define (map-n lsts)
1682           (if lsts
1683             (let ((result (##apply proc (cars lsts))))
1684               (##cons result (map-n (cdrs lsts))))
1685             '()))
1686
1687         (cond ((##null? y)
1688                (macro-if-checks
1689                  (let ((len1 (proper-list-length x)))
1690                    (if len1
1691                      (map-1 x)
1692                      (macro-fail-check-list 2 (map proc x . y))))
1693                  (map-1 x)))
1694               (else
1695                (macro-if-checks
1696                  (let ((len1 (proper-list-length x)))
1697                    (if len1
1698                      (let loop ((lsts y) (arg-num 3))
1699                        (if (##null? lsts)
1700                          (if (##null? x)
1701                            '()
1702                            (map-n (##cons x y)))
1703                          (let ((len2 (proper-list-length (##car lsts))))
1704                            (if (##eq? len1 len2)
1705                              (loop (##cdr lsts) (##fixnum.+ arg-num 1))
1706                              (if len2
1707                                (##raise-improper-length-list-exception
1708                                 arg-num
1709                                 '()
1710                                 map
1711                                 proc
1712                                 x
1713                                 y)
1714                                (macro-fail-check-list
1715                                 arg-num
1716                                 (map proc x . y)))))))
1717                      (macro-fail-check-list 2 (map proc x . y))))
1718                  (if (##null? x)
1719                    '()
1720                    (map-n (##cons x y))))))))))
1721
1722 (define-prim (##for-each proc lst)
1723   (let loop ((x lst))
1724     (if (##pair? x)
1725       (begin
1726         (proc (##car x))
1727         (loop (##cdr x)))
1728       (##void))))
1729
1730 (define-prim (for-each proc x . y)
1731   (macro-force-vars (proc)
1732     (macro-check-procedure proc 1 (for-each proc x . y)
1733       (let ()
1734
1735         (define (proper-list-length lst)
1736           (let loop ((lst lst) (n 0))
1737             (macro-force-vars (lst)
1738               (cond ((##pair? lst)
1739                      (loop (##cdr lst) (##fixnum.+ n 1)))
1740                     ((##null? lst)
1741                      n)
1742                     (else
1743                      #f)))))
1744
1745         (define (for-each-1 lst1)
1746           (macro-force-vars (lst1)
1747             (if (##pair? lst1)
1748               (let ((result (proc (##car lst1))))
1749                 (for-each-1 (##cdr lst1)))
1750               (##void))))
1751
1752         (define (cars lsts)
1753           (if (##pair? lsts)
1754             (let ((lst1 (##car lsts)))
1755               (macro-force-vars (lst1)
1756                 (let ((head (##car lst1)))
1757                   (let ((tail (cars (##cdr lsts))))
1758                     (##cons head tail)))))
1759             '()))
1760
1761         (define (cdrs lsts)
1762           (if (##pair? lsts)
1763             (let ((lst1 (##car lsts)))
1764               (macro-force-vars (lst1)
1765                 (let ((head (##cdr lst1)))
1766                   (if (##pair? head)
1767                     (let ((tail (cdrs (##cdr lsts))))
1768                       (and tail
1769                            (##cons head tail)))
1770                     #f))))
1771             '()))
1772
1773         (define (for-each-n lsts)
1774           (let ((tails (cdrs lsts)))
1775             (if tails
1776               (begin
1777                 (##apply proc (cars lsts))
1778                 (for-each-n tails))
1779               (##apply proc (cars lsts)))))
1780
1781         (cond ((##null? y)
1782                (macro-if-checks
1783                  (let ((len1 (proper-list-length x)))
1784                    (if len1
1785                      (for-each-1 x)
1786                      (macro-fail-check-list 2 (for-each proc x . y))))
1787                  (for-each-1 x)))
1788               (else
1789                (macro-if-checks
1790                  (let ((len1 (proper-list-length x)))
1791                    (if len1
1792                      (let loop ((lsts y) (arg-num 3))
1793                        (if (##null? lsts)
1794                          (if (##pair? x)
1795                            (for-each-n (##cons x y))
1796                            (##void))
1797                          (let ((len2 (proper-list-length (##car lsts))))
1798                            (if (##eq? len1 len2)
1799                              (loop (##cdr lsts) (##fixnum.+ arg-num 1))
1800                              (if len2
1801                                (##raise-improper-length-list-exception
1802                                 arg-num
1803                                 '()
1804                                 for-each
1805                                 proc
1806                                 x
1807                                 y)
1808                                (macro-fail-check-list
1809                                 arg-num
1810                                 (for-each proc x . y)))))))
1811                      (macro-fail-check-list 2 (for-each proc x . y))))
1812                  (if (##pair? x)
1813                    (for-each-n (##cons x y))
1814                    (##void)))))))))
1815
1816 ;; call-with-current-continuation is in "_kernel.scm"
1817
1818 ;; Port related procedures are in "_io.scm"
1819
1820 ;;;----------------------------------------------------------------------------
1821
1822 ;; R4RS Scheme procedures:
1823
1824 (define-prim (list-tail lst k)
1825   (macro-force-vars (k)
1826     (macro-check-index k 2 (list-tail lst k)
1827       (let loop ((x lst) (i k))
1828         (if (##fixnum.< 0 i)
1829           (macro-force-vars (x)
1830             (macro-check-pair x 1 (list-tail lst k);;;;;;;;;;error message confusing?
1831               (loop (##cdr x) (##fixnum.- i 1))))
1832           x)))))
1833
1834 (define-prim (##make-promise thunk)
1835   (macro-make-promise thunk))
1836
1837 (define-prim (##force obj))
1838
1839 (define-prim (force obj)
1840   (##force obj))
1841
1842 ;; Port related procedures are in "_io.scm"
1843
1844 ;;;----------------------------------------------------------------------------
1845
1846 ;; R5RS Scheme procedures:
1847
1848 ;; values, call-with-values and dynamic-wind are in "_thread.scm"
1849
1850 ;;(eval expr env)
1851 ;;(scheme-report-environment version)
1852 ;;(null-environment version)
1853 ;;(interaction-environment)
1854
1855 ;;;----------------------------------------------------------------------------
1856
1857 ;; Multilisp procedures:
1858
1859 (define-prim (touch obj)
1860   (##force obj))
1861
1862 ;;;----------------------------------------------------------------------------
1863
1864 ;; DSSSL procedures:
1865
1866 (define-fail-check-type keyword 'keyword)
1867
1868 (define-prim (##keyword? obj)
1869   (and (##subtyped? obj)
1870        (##eq? (##subtype obj) (macro-subtype-keyword))))
1871
1872 (define-prim (keyword? obj)
1873   (##keyword? obj))
1874
1875 (define-prim (##keyword->string key)
1876   (let ((name (macro-keyword-name key)))
1877     (if (##fixnum? name)
1878       (let ((str (##string-append "g" (##number->string name 10))))
1879         (##declare (not interrupts-enabled))
1880         (let ((name (macro-keyword-name key)))
1881           ;; Double-check in case a different thread has also called
1882           ;; and completed the call to ##keyword->string on this keyword.
1883           (if (##fixnum? name)
1884             (begin
1885               (macro-keyword-name-set! key str)
1886               str)
1887             name)))
1888       name)))
1889
1890 (define-prim (keyword->string key)
1891   (macro-force-vars (key)
1892     (macro-check-keyword key 1 (keyword->string key)
1893       (##keyword->string key))))
1894
1895 (define-prim (##string->keyword str)
1896   (##make-interned-keyword str))
1897
1898 (define-prim (string->keyword str)
1899   (macro-force-vars (str)
1900     (macro-check-string str 1 (string->keyword str)
1901       (##string->keyword str))))
1902
1903 (define-prim (##uninterned-keyword? obj)
1904   (and (##keyword? obj)
1905        (##not (macro-keyword-next obj))))
1906
1907 (define-prim (uninterned-keyword? obj)
1908   (macro-force-vars (obj)
1909     (##uninterned-keyword? obj)))
1910
1911 (define ##keyword-counter 0)
1912
1913 (define-prim (##make-uninterned-keyword
1914               str
1915               #!optional
1916               (hash (macro-absent-obj)))
1917
1918   ;; str must be a nonmutable string
1919
1920   (if (##eq? hash (macro-absent-obj))
1921     (let ((n (##fixnum.+ ##keyword-counter 1)))
1922       ;; Note: it is unimportant if the increment of ##keyword-counter
1923       ;; is not atomic; it simply means a possible close repetition
1924       ;; of the same hash code
1925       (set! ##keyword-counter n)
1926       (macro-make-uninterned-keyword str (##partial-bit-reverse n)))
1927     (macro-make-uninterned-keyword str hash)))
1928
1929 (define-prim (make-uninterned-keyword
1930               str
1931               #!optional
1932               (hash (macro-absent-obj)))
1933   (macro-force-vars (str hash)
1934     (macro-check-string str 1 (make-uninterned-keyword str hash)
1935       (if (##eq? hash (macro-absent-obj))
1936         (##make-uninterned-keyword str)
1937         (macro-check-fixnum-range-incl hash 2 0 536870911 (make-uninterned-keyword str hash)
1938           (##make-uninterned-keyword str hash))))))
1939
1940 (define-prim (##partial-bit-reverse i)
1941
1942   (##define-macro (bit n)
1943     `(##fixnum.arithmetic-shift-left
1944       (##fixnum.bitwise-and i ,(expt 2 n)) ,(- 28 (* 2 n))))
1945
1946   (##fixnum.+
1947    (bit 0)
1948    (##fixnum.+
1949     (bit 1)
1950     (##fixnum.+
1951      (bit 2)
1952      (##fixnum.+
1953       (bit 3)
1954       (##fixnum.+
1955        (bit 4)
1956        (##fixnum.+
1957         (bit 5)
1958         (##fixnum.+
1959          (bit 6)
1960          (##fixnum.+
1961           (bit 7)
1962           (##fixnum.+
1963            (bit 8)
1964            (##fixnum.+
1965             (bit 9)
1966             (##fixnum.+
1967              (bit 10)
1968              (##fixnum.+
1969               (bit 11)
1970               (##fixnum.+
1971                (bit 12)
1972                (##fixnum.+
1973                 (bit 13)
1974                 (bit 14))))))))))))))))
1975
1976 ;;;============================================================================