lib/_nonstd.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_nonstd.scm"
   4
   5 ;;; Copyright (c) 1994-2012 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-error-exception)
  16
  17 (define-prim (##raise-error-exception message parameters)
  18   (macro-raise
  19    (macro-make-error-exception
  20     message
  21     parameters)))
  22
  23 (implement-library-type-unbound-os-environment-variable-exception)
  24
  25 (define-prim (##raise-unbound-os-environment-variable-exception proc . args)
  26   (##extract-procedure-and-arguments
  27    proc
  28    args
  29    #f
  30    #f
  31    #f
  32    (lambda (procedure arguments dummy1 dummy2 dummy3)
  33      (macro-raise
  34       (macro-make-unbound-os-environment-variable-exception
  35        procedure
  36        arguments)))))
  37
  38 ;;;----------------------------------------------------------------------------
  39
  40 ;;; Define type checking procedures.
  41
  42 (define-fail-check-type string-or-nonnegative-fixnum
  43   'string-or-nonnegative-fixnum)
  44
  45 (define-fail-check-type will
  46   'will)
  47
  48 (define-fail-check-type box
  49   'box)
  50
  51 ;;;----------------------------------------------------------------------------
  52
  53 ;;; Non-standard procedures and special forms
  54
  55 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  56
  57 (define-prim (##deconstruct-call src size proc)
  58   (let* ((code (##source-strip src))
  59          (n (##proper-length code)))
  60     (if (or (##not n)
  61             (if (##fx< 0 size)
  62                 (##not (##fx= n size))
  63                 (##fx< n (##fx- 0 size))))
  64       (##raise-expression-parsing-exception
  65        'ill-formed-special-form
  66        src
  67        (##source-strip (##car code)))
  68       (##apply proc (##cdr code)))))
  69
  70 (define-prim (##expand-source-template src template)
  71   (let ((locat (##source-locat src)))
  72
  73     (define (expand template)
  74       (cond ((##source? template)
  75              template)
  76             ((##pair? template)
  77              (##make-source
  78               (expand-list template)
  79               locat))
  80             ((##vector? template)
  81              (##make-source
  82               (##list->vector (expand-list (##vector->list template)))
  83               locat))
  84             (else
  85              (##make-source
  86               template
  87               locat))))
  88
  89     (define (expand-list template)
  90       (cond ((or (##source? template)
  91                  (##null? template))
  92              template)
  93             ((##pair? template)
  94              (##cons (expand (##car template))
  95                      (expand-list (##cdr template))))
  96             (else
  97              (##make-source
  98               template
  99               locat))))
 100
 101     (expand template)))
 102
 103 (define-prim (##source-strip x)
 104   (if (##source? x)
 105       (##source-code x)
 106       x))
 107
 108 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 109
 110 (define-prim (error message . parameters)
 111   (##raise-error-exception message parameters))
 112
 113 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 114
 115 (define-runtime-syntax parameterize
 116   (lambda (src)
 117     (##deconstruct-call
 118      src
 119      -2
 120      (lambda (bindings . body)
 121        (##expand-source-template
 122         src
 123         (##parameterize-build
 124          src
 125          bindings
 126          body))))))
 127
 128 (define-prim (##parameterize-build src bindings body)
 129
 130   (define (build bindings rev-params-vals)
 131     (cond ((##pair? bindings)
 132            (let ((binding (##source-strip (##car bindings))))
 133              (##shape src (##sourcify binding src) 2)
 134              (let* ((param (##source-strip (##car binding)))
 135                     (val (##source-strip (##cadr binding))))
 136                (build (##cdr bindings)
 137                       (##cons (##cons (##cons (##gensym) param)
 138                                       (##cons (##gensym) val))
 139                               rev-params-vals)))))
 140           ((##null? bindings)
 141            (if (##null? rev-params-vals)
 142              (##cons 'let (##cons '() body))
 143              (let ((params-vals (##reverse rev-params-vals)))
 144
 145                (define (bind params-vals)
 146                  (if (##null? params-vals)
 147                    (##cons 'let (##cons '() body))
 148                    (let* ((param-val (##car params-vals))
 149                           (param (##car param-val))
 150                           (val (##cdr param-val)))
 151                      (##list '##parameterize
 152                              (##car param)
 153                              (##car val)
 154                              (##list 'lambda
 155                                      '()
 156                                      (bind (##cdr params-vals)))))))
 157
 158                (##list 'let
 159                        (let loop ((lst rev-params-vals) (bs '()))
 160                          (if (##null? lst)
 161                            bs
 162                            (let* ((param-val (##car lst))
 163                                   (param (##car param-val))
 164                                   (val (##cdr param-val)))
 165                              (loop (##cdr lst)
 166                                    (##cons (##list (##car param)
 167                                                    (##cdr param))
 168                                            (##cons (##list (##car val)
 169                                                            (##cdr val))
 170                                                    bs))))))
 171                        (bind params-vals)))))
 172           (else
 173            (##raise-expression-parsing-exception
 174             'ill-formed-binding-list
 175             src))))
 176
 177   (build (##source-strip bindings)
 178          '()))
 179
 180 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 181
 182 (define-runtime-syntax cond-expand
 183   (lambda (src)
 184     (##deconstruct-call
 185      src
 186      -1
 187      (lambda clauses
 188        (##expand-source-template
 189         src
 190         (##cond-expand-build
 191          src
 192          clauses))))))
 193
 194 (define-prim (##cond-expand-build src clauses)
 195
 196   (define (satisfied? feature-requirement)
 197     (cond ((##symbol? feature-requirement)
 198            (if (##member feature-requirement ##cond-expand-features)
 199              #t
 200              #f))
 201           ((##pair? feature-requirement)
 202            (let ((first (##source-strip (##car feature-requirement))))
 203              (cond ((##eq? first 'not)
 204                     (##shape src (##sourcify feature-requirement src) 2)
 205                     (##not (satisfied? (##source-strip (##cadr feature-requirement)))))
 206                    ((or (##eq? first 'and) (##eq? first 'or))
 207                     (##shape src (##sourcify feature-requirement src) -1)
 208                     (let loop ((lst (##cdr feature-requirement)))
 209                       (if (##pair? lst)
 210                         (let ((x (##source-strip (##car lst))))
 211                           (if (##eq? (satisfied? x) (##eq? first 'and))
 212                             (loop (##cdr lst))
 213                             (##not (##eq? first 'and))))
 214                         (##eq? first 'and))))
 215                    (else
 216                     (macro-raise
 217                      (macro-make-expression-parsing-exception
 218                       'ill-formed-cond-expand
 219                       src
 220                       '()))))))
 221           (else
 222            (macro-raise
 223             (macro-make-expression-parsing-exception
 224              'ill-formed-cond-expand
 225              src
 226              '())))))
 227
 228   (define (build clauses)
 229     (if (##pair? clauses)
 230       (let ((clause (##source-strip (##car clauses))))
 231         (##shape src (##sourcify clause src) -1)
 232         (let ((feature-requirement (##source-strip (##car clause))))
 233           (if (or (and (##eq? feature-requirement 'else)
 234                        (##null? (##cdr clauses)))
 235                   (satisfied? feature-requirement))
 236             (##cons 'begin (##cdr clause))
 237             (build (##cdr clauses)))))
 238       (macro-raise
 239        (macro-make-expression-parsing-exception
 240         'unfulfilled-cond-expand
 241         src
 242         '()))))
 243
 244   (build clauses))
 245
 246 (##define-macro (generate-cond-expand-features)
 247
 248   (define gambits '(gambit GAMBIT Gambit gambit-c GAMBIT-C Gambit-C))
 249
 250   `'(,@gambits
 251      srfi-0 SRFI-0
 252      srfi-4 SRFI-4
 253      srfi-6 SRFI-6
 254      srfi-8 SRFI-8
 255      srfi-9 SRFI-9
 256      srfi-18 SRFI-18
 257      srfi-21 SRFI-21
 258      srfi-22 SRFI-22
 259      srfi-23 SRFI-23
 260      srfi-27 SRFI-27
 261      srfi-30 SRFI-30
 262 ;;     srfi-38 SRFI-38
 263      srfi-39 SRFI-39
 264      srfi-88 SRFI-88
 265 ;;     srfi-89 SRFI-89
 266 ;;     srfi-90 SRFI-90
 267 ;;     srfi-91 SRFI-91
 268     ))
 269
 270 (define ##cond-expand-features #f)
 271 (set! ##cond-expand-features (generate-cond-expand-features))
 272
 273 (define-runtime-macro (define-cond-expand-feature feature)
 274   (set! ##cond-expand-features (##cons feature ##cond-expand-features))
 275   `(begin))
 276
 277 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 278
 279 (define-runtime-syntax receive
 280   (lambda (src)
 281     (##deconstruct-call
 282      src
 283      -4
 284      (lambda (formals expression . body)
 285        (##expand-source-template
 286         src
 287         `(##call-with-values
 288           (lambda () ,expression)
 289           (lambda ,formals ,@body)))))))
 290
 291 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 292
 293 (define-prim (##type-field-count type)
 294   (if type
 295     (let ((fields (##type-fields type)))
 296       (##fixnum.+ (##type-field-count (##type-super type))
 297                   (##fixnum.quotient (##vector-length fields) 3)))
 298     0))
 299
 300 (define-prim (##type-all-fields type)
 301   (if type
 302     (let ((fields (##type-fields type)))
 303       (##append (##type-all-fields (##type-super type))
 304                 (##vector->list fields)))
 305     '()))
 306
 307 (define-prim (##define-type-expand
 308               form-name
 309               super-type-static
 310               super-type-dynamic-expr
 311               args)
 312
 313   (define (generate
 314            name
 315            flags
 316            id
 317            extender
 318            constructor
 319            constant-constructor
 320            predicate
 321            implementer
 322            type-exhibitor
 323            prefix
 324            fields
 325            total-fields)
 326
 327     (define (generate-fields)
 328       (let loop ((lst1 (##reverse fields))
 329                  (lst2 '()))
 330         (if (##pair? lst1)
 331           (let* ((field
 332                   (##car lst1))
 333                  (descr
 334                   (##cdr field))
 335                  (field-name
 336                   (##vector-ref descr 0))
 337                  (options
 338                   (##vector-ref descr 4))
 339                  (attributes
 340                   (##vector-ref descr 5))
 341                  (init
 342                   (cond ((##assq 'init: attributes)
 343                          =>
 344                          (lambda (x) (##constant-expression-value (##cdr x))))
 345                         (else
 346                          #f))))
 347             (loop (##cdr lst1)
 348                   (##cons field-name
 349                           (##cons options
 350                                   (##cons init
 351                                           lst2)))))
 352           (##list->vector lst2))))
 353
 354     (define (all-fields->rev-field-alist all-fields)
 355       (let loop ((i 1)
 356                  (lst all-fields)
 357                  (rev-field-alist '()))
 358         (if (##pair? lst)
 359           (let* ((field-name
 360                   (##car lst))
 361                  (rest1
 362                   (##cdr lst))
 363                  (options
 364                   (##car rest1))
 365                  (rest2
 366                   (##cdr rest1))
 367                  (val
 368                   (##car rest2))
 369                  (rest3
 370                   (##cdr rest2)))
 371             (loop (##fixnum.+ i 1)
 372                   rest3
 373                   (##cons (##cons field-name
 374                                   (##vector i
 375                                             options
 376                                             val
 377                                             (generate-parameter i)))
 378                           rev-field-alist)))
 379           rev-field-alist)))
 380
 381     (define (generate-parameter i)
 382       (##string->symbol
 383        (##string-append "p"
 384                         (##number->string i 10))))
 385
 386     (define (generate-parameters rev-field-alist)
 387       (if (##pair? constructor)
 388         (##map (lambda (field-name)
 389                  (let ((x (##assq field-name rev-field-alist)))
 390                    (##vector-ref (##cdr x) 3)))
 391                (##cdr constructor))
 392         (let loop ((lst rev-field-alist)
 393                    (parameters '()))
 394           (if (##pair? lst)
 395             (let ((x (##car lst)))
 396               (loop (##cdr lst)
 397                     (let* ((options
 398                             (##vector-ref (##cdr x) 1))
 399                            (has-init?
 400                             (##not (##fixnum.= (##fixnum.bitwise-and options 8)
 401                                                0))))
 402                       (if has-init?
 403                         parameters
 404                         (##cons (##vector-ref (##cdr x) 3)
 405                                 parameters)))))
 406             parameters))))
 407
 408     (define (generate-initializations field-alist parameters in-macro?)
 409       (##map (lambda (x)
 410                (let* ((field-index (##vector-ref (##cdr x) 0))
 411                       (options (##vector-ref (##cdr x) 1))
 412                       (val (##vector-ref (##cdr x) 2))
 413                       (parameter (##vector-ref (##cdr x) 3)))
 414                  (if (##memq parameter parameters)
 415                    parameter
 416                    (make-quote
 417                     (if in-macro?
 418                       (make-quote val)
 419                       val)))))
 420              field-alist))
 421
 422     (define (make-quote x)
 423       (##list 'quote x))
 424
 425     (let* ((macros?
 426             (##not (##fixnum.= (##fixnum.bitwise-and flags 4) 0)))
 427            (generative?
 428             (##not id))
 429            (augmented-id-str
 430             (##string-append
 431              "##type-"
 432              (##number->string total-fields 10)
 433              "-"
 434              (##symbol->string (if generative? name id))))
 435            (type-fields
 436             (generate-fields))
 437            (type-static
 438             (##structure
 439              ##type-type
 440              (if generative?
 441                (##make-uninterned-symbol augmented-id-str)
 442                (##string->symbol augmented-id-str))
 443              name
 444              flags
 445              super-type-static
 446              type-fields))
 447            (type-expression
 448             (if generative?
 449               (##string->symbol augmented-id-str)
 450               `',type-static))
 451            (type-id-expression
 452             (if generative?
 453               `(let ()
 454                  (##declare (extended-bindings) (not safe))
 455                  (##type-id ,type-expression))
 456               `',(##type-id type-static)))
 457            (all-fields
 458             (##type-all-fields type-static))
 459            (rev-field-alist
 460             (all-fields->rev-field-alist all-fields))
 461            (field-alist
 462             (##reverse rev-field-alist))
 463            (parameters
 464             (generate-parameters rev-field-alist)))
 465
 466       (define (generate-getter-and-setter field tail)
 467         (let* ((descr
 468                 (##cdr field))
 469                (field-name
 470                 (##vector-ref descr 0))
 471                (field-index
 472                 (##vector-ref descr 1))
 473                (getter
 474                 (##vector-ref descr 2))
 475                (setter
 476                 (##vector-ref descr 3))
 477                (getter-def
 478                 (if getter
 479                   (let ((getter-name
 480                          (if (##eq? getter #t)
 481                            (##symbol-append prefix
 482                                             name
 483                                             '-
 484                                             field-name)
 485                            getter))
 486                         (getter-method
 487                          (if extender
 488                            '##structure-ref
 489                            '##direct-structure-ref)))
 490                     (if macros?
 491                       `((##define-macro (,getter-name obj)
 492                           (##list '(let ()
 493                                      (##declare (extended-bindings))
 494                                      ,getter-method)
 495                                   obj
 496                                   ,field-index
 497                                   ',type-expression
 498                                   #f)))
 499                       `((define (,getter-name obj)
 500                           ((let ()
 501                              (##declare (extended-bindings))
 502                              ,getter-method)
 503                            obj
 504                            ,field-index
 505                            ,type-expression
 506                            ,getter-name)))))
 507                   `()))
 508                (setter-def
 509                 (if setter
 510                   (let ((setter-name
 511                          (if (##eq? setter #t)
 512                            (##symbol-append prefix
 513                                             name
 514                                             '-
 515                                             field-name
 516                                             '-set!)
 517                            setter))
 518                         (setter-method
 519                          (if extender
 520                            '##structure-set!
 521                            '##direct-structure-set!)))
 522                     (if macros?
 523                       `((##define-macro (,setter-name obj val)
 524                           (##list '(let ()
 525                                      (##declare (extended-bindings))
 526                                      ,setter-method)
 527                                   obj
 528                                   val
 529                                   ,field-index
 530                                   ',type-expression
 531                                   #f)))
 532                       `((define (,setter-name obj val)
 533                           ((let ()
 534                              (##declare (extended-bindings))
 535                              ,setter-method)
 536                            obj
 537                            val
 538                            ,field-index
 539                            ,type-expression
 540                            ,setter-name)))))
 541                   `())))
 542           (##append getter-def (##append setter-def tail))))
 543
 544       (define (generate-structure-type-definition)
 545         `(define ,type-expression
 546            ((let ()
 547               (##declare (extended-bindings))
 548               ##structure)
 549             ##type-type
 550             ((let ()
 551                (##declare (extended-bindings))
 552                ##make-uninterned-symbol)
 553              ,augmented-id-str)
 554             ',name
 555             ',(##type-flags type-static)
 556             ,super-type-dynamic-expr
 557             ',(##type-fields type-static))))
 558
 559       (define (generate-constructor-predicate-getters-setters)
 560         `(,@(if type-exhibitor
 561               (if macros?
 562                 `((##define-macro (,type-exhibitor)
 563                     ',type-expression))
 564                 `((define (,type-exhibitor)
 565                     ,type-expression)))
 566               '())
 567
 568           ,@(if constructor
 569               (let ((constructor-name
 570                      (if (##pair? constructor)
 571                        (##car constructor)
 572                        constructor)))
 573                 (if macros?
 574                   `((##define-macro (,constructor-name ,@parameters)
 575                       (##list '(let ()
 576                                  (##declare (extended-bindings))
 577                                  ##structure)
 578                               ',type-expression
 579                               ,@(generate-initializations
 580                                  field-alist
 581                                  parameters
 582                                  #t))))
 583                   `((define (,constructor-name ,@parameters)
 584                       (##declare (extended-bindings))
 585                       (##structure
 586                        ,type-expression
 587                        ,@(generate-initializations
 588                           field-alist
 589                           parameters
 590                           #f))))))
 591               '())
 592
 593           ,@(if constant-constructor
 594               `((##define-macro (,constant-constructor ,@parameters)
 595                   (##define-type-construct-constant
 596                    ',constant-constructor
 597                    ,type-expression
 598                    ,@(generate-initializations
 599                       field-alist
 600                       parameters
 601                       #t))))
 602               '())
 603
 604           ,@(if predicate
 605               (if macros?
 606                 `((##define-macro (,predicate obj)
 607                     ,(if extender
 608                        ``(let ((obj ,,'obj))
 609                            (##declare (extended-bindings))
 610                            (and (##structure? obj)
 611                                 (let ((t0 (##structure-type obj))
 612                                       (type-id ,',type-id-expression))
 613                                   (or (##eq? (##type-id t0) type-id)
 614                                       (let ((t1 (##type-super t0)))
 615                                         (and t1
 616                                              (or (##eq? (##type-id t1) type-id)
 617                                                  (##structure-instance-of? obj type-id))))))))
 618                        ``((let ()
 619                             (##declare (extended-bindings))
 620                             ##structure-direct-instance-of?)
 621                           ,,'obj
 622                           ,',type-id-expression))))
 623                 `((define (,predicate obj)
 624                     (##declare (extended-bindings))
 625                     ,(if extender
 626                        `(##structure-instance-of?
 627                          obj
 628                          ,type-id-expression)
 629                        `(##structure-direct-instance-of?
 630                          obj
 631                          ,type-id-expression)))))
 632               '())
 633
 634           ,@(let loop ((lst1 (##reverse fields))
 635                        (lst2 '()))
 636               (if (##pair? lst1)
 637                 (loop (##cdr lst1)
 638                       (generate-getter-and-setter (##car lst1) lst2))
 639                 lst2))))
 640
 641       (define (generate-definitions)
 642         (if generative?
 643           (##cons (generate-structure-type-definition)
 644                   (generate-constructor-predicate-getters-setters))
 645           (generate-constructor-predicate-getters-setters)))
 646
 647       `(begin
 648
 649          ,@(if extender
 650              (##list `(##define-macro (,extender . args)
 651                         (##define-type-expand
 652                          ',extender
 653                          ',type-static
 654                          ',type-expression
 655                          args)))
 656              '())
 657
 658          ,@(if implementer
 659              (if macros?
 660                (##cons `(##define-macro (,implementer)
 661                           ',(if generative?
 662                               (generate-structure-type-definition)
 663                               '(begin)))
 664                        (generate-constructor-predicate-getters-setters))
 665                (##list `(##define-macro (,implementer)
 666                           ',(##cons 'begin
 667                                     (generate-definitions)))))
 668              (generate-definitions)))))
 669
 670   (let ((expansion
 671          (##define-type-parser
 672           form-name
 673           super-type-static
 674           args
 675           generate)))
 676     (if ##define-type-expansion-show?
 677       (pp expansion ##stdout-port))
 678     expansion))
 679
 680 (define ##define-type-expansion-show? #f)
 681 (set! ##define-type-expansion-show? #f)
 682
 683 (define-prim (##define-type-parser
 684               form-name
 685               super-type-static
 686               args
 687               cont)
 688
 689   (define (err)
 690     (##ill-formed-special-form form-name args))
 691
 692   (define (parse-attributes name rest)
 693     (let loop1 ((lst rest)
 694                 (field-index (##type-field-count super-type-static))
 695                 (options 0)
 696                 (flags '())
 697                 (rev-fields '()))
 698
 699       (define allowed-field-options
 700         '((printable:     . (-2 . 0))
 701           (unprintable:   . (-2 . 1))
 702           (read-write:    . (-3 . 0))
 703           (read-only:     . (-3 . 2))
 704           (equality-test: . (-5 . 0))
 705           (equality-skip: . (-5 . 4))))
 706
 707       (define (update-options options opt)
 708         (let* ((x (##cdr opt))
 709                (m (##car x))
 710                (b (##cdr x)))
 711           (##fixnum.bitwise-ior (##fixnum.bitwise-and options m) b)))
 712
 713       (define (parse-field-attributes
 714                field-name
 715                getter
 716                setter
 717                local-options
 718                rest)
 719         (let loop2 ((lst2 rest)
 720                     (local-options local-options)
 721                     (attributes '()))
 722           (cond ((##pair? lst2)
 723                  (let ((attribute (##car lst2)))
 724                    (cond ((##assq attribute
 725                                   '((init: . (-9 . 8))))
 726                           =>
 727                           (lambda (opt)
 728                             (let ((rest (##cdr lst2)))
 729                               (if (and (##pair? rest)
 730                                        (##not (##assq attribute attributes)))
 731                                 (let ((val (##car rest)))
 732                                   (if (##constant-expression? val)
 733                                     (loop2 (##cdr rest)
 734                                            (update-options local-options opt)
 735                                            (##cons (##cons attribute val)
 736                                                    attributes))
 737                                     (err)))
 738                                 (err)))))
 739                          ((##assq attribute
 740                                   allowed-field-options)
 741                           =>
 742                           (lambda (opt)
 743                             (loop2 (##cdr lst2)
 744                                    (update-options local-options opt)
 745                                    attributes)))
 746                          (else
 747                           (err)))))
 748                 ((##null? lst2)
 749                  (let ((read-only?
 750                         (##not
 751                          (##fixnum.= (##fixnum.bitwise-and local-options 2)
 752                                      0))))
 753                    (if (and (##symbol? setter)
 754                             read-only?)
 755                      (err)
 756                      (loop1 (##cdr lst)
 757                             (##fixnum.+ field-index 1)
 758                             options
 759                             flags
 760                             (##cons (##cons field-name
 761                                             (##vector
 762                                              field-name
 763                                              (##fixnum.+ field-index 1)
 764                                              getter
 765                                              (if read-only? #f setter)
 766                                              local-options
 767                                              attributes))
 768                                     rev-fields)))))
 769                 (else
 770                  (err)))))
 771
 772       (cond ((##pair? lst)
 773              (let ((next (##car lst)))
 774                (cond ((##symbol? next)
 775                       (if (##not (##assq next rev-fields))
 776                         (parse-field-attributes
 777                          next
 778                          #t
 779                          #t
 780                          options
 781                          '())
 782                         (err)))
 783                      ((##pair? next)
 784                       (let* ((field-name (##car next))
 785                              (rest (##cdr next)))
 786                         (if (and (##symbol? field-name)
 787                                  (##not (##assq field-name rev-fields)))
 788                           (if (##pair? rest)
 789                             (let ((getter (##car rest)))
 790                               (if (##symbol? getter)
 791                                 (let ((rest (##cdr rest)))
 792                                   (if (##pair? rest)
 793                                     (let ((setter (##car rest)))
 794                                       (if (##symbol? setter)
 795                                         (parse-field-attributes
 796                                          field-name
 797                                          getter
 798                                          setter
 799                                          (##fixnum.bitwise-and options -3)
 800                                          (##cdr rest))
 801                                         (parse-field-attributes
 802                                          field-name
 803                                          getter
 804                                          #f
 805                                          (##fixnum.bitwise-ior options 2)
 806                                          rest)))
 807                                     (parse-field-attributes
 808                                      field-name
 809                                      getter
 810                                      #f
 811                                      (##fixnum.bitwise-ior options 2)
 812                                      rest)))
 813                                 (parse-field-attributes
 814                                  field-name
 815                                  #t
 816                                  #t
 817                                  options
 818                                  rest)))
 819                             (parse-field-attributes
 820                              field-name
 821                              #t
 822                              #t
 823                              options
 824                              rest))
 825                           (err))))
 826                      ((##member next
 827                                 '(id:
 828                                   constructor:
 829                                   constant-constructor:
 830                                   predicate:
 831                                   extender:
 832                                   implementer:
 833                                   type-exhibitor:
 834                                   prefix:))
 835                       (let ((rest (##cdr lst)))
 836                         (if (and (##pair? rest)
 837                                  (##not (##assq next flags)))
 838                           (let ((val (##car rest)))
 839                             (if (cond ((##eq? next 'constructor:)
 840                                        (if (##pair? val)
 841                                          (if (##symbol? (##car val))
 842                                            (let loop ((lst1 (##cdr val))
 843                                                       (lst2 '()))
 844                                              (if (##pair? lst1)
 845                                                (let ((x (##car lst1)))
 846                                                  (if (and (##symbol? x)
 847                                                           (##not (##member
 848                                                                   x
 849                                                                   lst2)))
 850                                                    (loop (##cdr lst1)
 851                                                          (##cons x lst2))
 852                                                    #f))
 853                                                (##null? lst1)))
 854                                            #f)
 855                                          (or (##not val)
 856                                              (##symbol? val))))
 857                                       (else
 858                                        (or (##symbol? val)
 859                                            (and (##memq
 860                                                  next
 861                                                  '(predicate:
 862                                                    constant-constructor:))
 863                                                 (##not val)))))
 864                               (loop1 (##cdr rest)
 865                                      field-index
 866                                      options
 867                                      (##cons (##cons next val) flags)
 868                                      rev-fields)
 869                               (err)))
 870                           (err))))
 871                      ((##member next
 872                                 '(opaque:
 873                                   macros:))
 874                       (if (##not (##assq next flags))
 875                         (loop1 (##cdr lst)
 876                                field-index
 877                                options
 878                                (##cons (##cons next #t) flags)
 879                                rev-fields)
 880                         (err)))
 881                      ((##assq next
 882                               allowed-field-options)
 883                       =>
 884                       (lambda (opt)
 885                         (loop1 (##cdr lst)
 886                                field-index
 887                                (update-options options opt)
 888                                flags
 889                                rev-fields)))
 890                      (else
 891                       (err)))))
 892             ((##null? lst)
 893              (let* ((fields
 894                      (##reverse rev-fields))
 895                     (prefix
 896                      (cond ((##assq 'prefix: flags)
 897                             =>
 898                             ##cdr)
 899                            (else
 900                             '||)))
 901                     (id
 902                      (cond ((##assq 'id: flags)
 903                             =>
 904                             ##cdr)
 905                            (else
 906                             #f)))
 907                     (extender
 908                      (cond ((##assq 'extender: flags)
 909                             =>
 910                             ##cdr)
 911                            (else
 912                             #f)))
 913                     (constructor
 914                      (cond ((##assq 'constructor: flags)
 915                             =>
 916                             (lambda (x)
 917                               (let ((constructor (##cdr x)))
 918                                 (if (##pair? constructor)
 919                                   (##for-each (lambda (sym)
 920                                                 (if (##not (##assq sym fields))
 921                                                   (err)))
 922                                               (##cdr constructor)))
 923                                 constructor)))
 924                            (else
 925                             (##symbol-append prefix
 926                                              'make-
 927                                              name))))
 928                     (constant-constructor
 929                      (cond ((##assq 'constant-constructor: flags)
 930                             =>
 931                             ##cdr)
 932                            ((or (##not constructor)
 933                                 (##not id))
 934                             #f)
 935                            (else
 936                             (##symbol-append prefix
 937                                              'make-constant-
 938                                              name))))
 939                     (predicate
 940                      (cond ((##assq 'predicate: flags)
 941                             =>
 942                             ##cdr)
 943                            (else
 944                             (##symbol-append prefix
 945                                              name
 946                                              '?))))
 947                     (implementer
 948                      (cond ((##assq 'implementer: flags)
 949                             =>
 950                             ##cdr)
 951                            (else
 952                             #f)))
 953                     (type-exhibitor
 954                      (cond ((##assq 'type-exhibitor: flags)
 955                             =>
 956                             ##cdr)
 957                            (else
 958                             #f))))
 959                (if (or (and constant-constructor
 960                             (or (##not constructor)
 961                                 (##not id)))
 962                        (and id
 963                             super-type-static
 964                             (##fixnum.=
 965                              (##fixnum.bitwise-and
 966                               (##type-flags super-type-static)
 967                               16)
 968                              0)))
 969                  (err)
 970                  (cont
 971                   name
 972                   (##fixnum.+ (if (or (##assq 'opaque: flags)
 973                                       (and super-type-static
 974                                            (##not
 975                                             (##fixnum.=
 976                                              (##fixnum.bitwise-and
 977                                               (##type-flags super-type-static)
 978                                               1)
 979                                              0))))
 980                                 1
 981                                 0)
 982                               (if extender 2 0)
 983                               (if (##assq 'macros: flags) 4 0)
 984                               (if constructor 8 0)
 985                               (if id 16 0))
 986                   id
 987                   extender
 988                   constructor
 989                   constant-constructor
 990                   predicate
 991                   implementer
 992                   type-exhibitor
 993                   prefix
 994                   fields
 995                   field-index))))
 996             (else
 997              (err)))))
 998
 999   (if (##pair? args)
1000     (let* ((name (##car args))
1001            (rest (##cdr args)))
1002       (if (##symbol? name)
1003         (parse-attributes name rest)
1004         (err)))
1005     (err)))
1006
1007 (define-prim (##define-type-construct-constant form-name type . fields)
1008   (let loop ((lst1 fields)
1009              (lst2 '()))
1010     (if (##pair? lst1)
1011       (let ((field (##car lst1)))
1012         (if (##constant-expression? field)
1013           (loop (##cdr lst1)
1014                 (##cons (##constant-expression-value field)
1015                         lst2))
1016           (##ill-formed-special-form form-name fields)))
1017       `',(##apply ##structure
1018                   (##cons type (##reverse lst2))))))
1019
1020 (define-prim (##ill-formed-special-form form-name args)
1021   (##raise-expression-parsing-exception
1022    'ill-formed-special-form
1023    (##sourcify
1024     (##cons form-name args)
1025     (##make-source #f #f))
1026    form-name))
1027
1028 (define-prim (##constant-expression? expr)
1029   (or (##self-eval? expr)
1030       (and (##pair? expr)
1031            (##eq? (##car expr) 'quote)
1032            (let ((rest (##cdr expr)))
1033              (and (##pair? rest)
1034                   (##null? (##cdr rest)))))))
1035
1036 (define-prim (##constant-expression-value expr)
1037   (if (##self-eval? expr)
1038     expr
1039     (##cadr expr)))
1040
1041 (define-prim (##symbol-append . symbols)
1042   (##string->symbol
1043    (##apply ##string-append
1044             (##map ##symbol->string symbols))))
1045
1046 (define-runtime-macro (define-type . args)
1047   (##define-type-expand 'define-type #f #f args))
1048
1049 (define-runtime-macro (define-structure . args)
1050   (##define-type-expand 'define-structure #f #f args))
1051
1052 (define-runtime-macro (define-record-type name constructor predicate . fields)
1053   `(define-type ,name
1054      constructor: ,constructor
1055      predicate: ,predicate
1056      ,@fields))
1057
1058 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1059
1060 (define-runtime-macro (define-type-of-thread . args)
1061   (##define-type-expand
1062    'define-type-of-thread
1063    (macro-type-thread)
1064    (##list 'quote (macro-type-thread))
1065    args))
1066
1067 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1068
1069 (define-prim (gc-report-set! report?);;;;;;;;;;;;;;;;;;;;;;
1070   (##gc-report-set! report?))
1071
1072 (define ##gc-report? #f)
1073
1074 (define-prim (##gc-report-set! report?)
1075   (##declare (not interrupts-enabled))
1076   (set! ##gc-report? (if report? #t #f)))
1077
1078 (define-prim (##display-gc-report)
1079
1080   ;;;;;;;;;;; report is not accurate on 64 bit machines
1081
1082   (if (let* ((settings
1083               (##set-debug-settings! 0 0))
1084              (level
1085               (macro-debug-settings-level settings)))
1086         (or (##fixnum.< 1 level)
1087             ##gc-report?))
1088     (let* ((stats
1089             (##process-statistics))
1090            (last-gc-real-time
1091             (##f64vector-ref stats 14))
1092            (last-gc-heap-size
1093             (##f64vector-ref stats 15))
1094            (last-gc-alloc
1095             (##f64vector-ref stats 16))
1096            (last-gc-live
1097             (##f64vector-ref stats 17))
1098            (last-gc-movable
1099             (##f64vector-ref stats 18))
1100            (last-gc-nonmovable
1101             (##f64vector-ref stats 19))
1102            (output-port
1103             (##repl-output-port)))
1104
1105       (define (scale x m)
1106         (##flonum.->exact-int (##flonum.round (##flonum.* x m))))
1107
1108       (define (mem bytes suffix)
1109
1110         (define (show x*1000 unit)
1111
1112           (define (decimals d)
1113             (let* ((n (##round (##/ x*1000 (##expt 10 (##fixnum.- 3 d)))))
1114                    (n-str (##number->string n 10))
1115                    (n-str-len (##string-length n-str))
1116                    (str (if (##fixnum.< n-str-len d)
1117                           (##string-append
1118                            (##make-string (##fixnum.- d n-str-len) #\0)
1119                            n-str)
1120                           n-str))
1121                    (len (##string-length str))
1122                    (split (##fixnum.- len d)))
1123               (##write-string
1124                (if (##fixnum.= d 0)
1125                  str
1126                  (##string-append (##substring str 0 split)
1127                                   "."
1128                                   (##substring str split len)))
1129                output-port)
1130               (##write-string unit output-port)))
1131
1132           (cond ((##< x*1000 10000)
1133                  (decimals 2))
1134                 ((##< x*1000 100000)
1135                  (decimals 1))
1136                 (else
1137                  (decimals 0))))
1138
1139         (let ((k (scale bytes 9.765625e-1)))
1140           (if (##< k 1024000)
1141             (show k "K")
1142             (let ((m (scale bytes 9.5367431640625e-4)))
1143               (if (##< m 1024000)
1144                 (show m "M")
1145                 (let ((g (scale bytes 9.313225746154785e-7)))
1146                   (show g "G"))))))
1147         (##write-string suffix output-port))
1148
1149       (##write-string "*** GC: " output-port)
1150       (##write (scale last-gc-real-time 1000.0) output-port)
1151       (##write-string " ms, " output-port)
1152       (mem last-gc-alloc " alloc, ")
1153       (mem last-gc-heap-size " heap, ")
1154       (mem last-gc-live " live (")
1155       (##write (scale (##flonum./ last-gc-live last-gc-heap-size) 100.0) output-port)
1156       (##write-string "% " output-port)
1157       (##write (##flonum.->exact-int last-gc-movable) output-port)
1158       (##write-string "+" output-port)
1159       (##write (##flonum.->exact-int last-gc-nonmovable) output-port)
1160       (##write-string ")" output-port)
1161       (##newline output-port)
1162       #t)))
1163
1164 (##add-gc-interrupt-job! ##display-gc-report)
1165
1166 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1167
1168 (define-prim (##void))
1169
1170 (define-prim (void)
1171   (##void))
1172
1173 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1174
1175 (define-prim (process-times)
1176   (##process-times))
1177
1178 (define-prim (cpu-time)
1179   (let ((v (##process-times)))
1180     (##+ (##f64vector-ref v 0) (##f64vector-ref v 1))))
1181
1182 (define-prim (real-time)
1183   (let ((v (##process-times)))
1184     (##f64vector-ref v 2)))
1185
1186 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1187
1188 (define ##gensym-counter -1)
1189
1190 (define-prim (##gensym #!optional (p (macro-absent-obj)))
1191   (let ((prefix
1192          (if (##eq? p (macro-absent-obj))
1193            'g
1194            p)))
1195     (macro-check-symbol prefix 1 (gensym p)
1196       (let ((new-count
1197              (##fixnum.modulo
1198               (##fixnum.+ ##gensym-counter 1)
1199               1000000)))
1200         ;; Note: it is unimportant if the increment of ##gensym-counter
1201         ;; is not atomic; it simply means a possible close repetition
1202         ;; of the same name
1203         (set! ##gensym-counter new-count)
1204         (##make-uninterned-symbol
1205          (if (##eq? prefix 'g)
1206            new-count ;; ##symbol->string will create the string
1207            (##string-append (##symbol->string prefix)
1208                             (##number->string new-count 10))))))))
1209
1210 (define-prim (gensym #!optional (p (macro-absent-obj)))
1211   (macro-force-vars (p)
1212     (##gensym p)))
1213
1214 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1215
1216 (##define-macro (macro-will-size) 3)
1217
1218 (define-prim (##will? obj)
1219   (and (##subtyped? obj)
1220        (##eq? (##subtype obj) (macro-subtype-weak))
1221        (##fixnum.= (##vector-length obj) (macro-will-size))))
1222
1223 (define-prim (will? x)
1224   (macro-force-vars (x)
1225     (##will? x)))
1226
1227 (define-prim (##make-will testator action)
1228   (macro-make-will testator action))
1229
1230 (define-prim (make-will testator action)
1231   (macro-force-vars (action)
1232     (macro-check-procedure action 2 (make-will testator action)
1233       (macro-make-will testator action))))
1234
1235 (define-prim (##will-testator will)
1236   (macro-will-testator will))
1237
1238 (define-prim (will-testator will)
1239   (macro-force-vars (will)
1240     (macro-check-will will 1 (will-testator will)
1241       (macro-will-testator will))))
1242
1243 (define-prim (##will-execute! will)
1244   (macro-will-execute! will))
1245
1246 (define-prim (will-execute! will)
1247   (macro-force-vars (will)
1248     (macro-check-will will 1 (will-execute! will)
1249       (macro-will-execute! will))))
1250
1251 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1252
1253 (define-prim (##box? obj)
1254   (and (##subtyped? obj)
1255        (##eq? (##subtype obj) (macro-subtype-boxvalues))
1256        (##fixnum.= (##vector-length obj) 1)))
1257
1258 (define-prim (box? obj)
1259   (macro-force-vars (obj)
1260     (##box? obj)))
1261
1262 (define-prim (##box obj)
1263   (##subtype-set! (##vector obj) (macro-subtype-boxvalues)))
1264
1265 (define-prim (box obj)
1266   (##box obj))
1267
1268 (define-prim (##unbox box)
1269   (##vector-ref box 0))
1270
1271 (define-prim (unbox box)
1272   (macro-force-vars (box)
1273     (macro-check-box box 1 (unbox box)
1274       (##unbox box))))
1275
1276 (define-prim (##set-box! box val)
1277   (##vector-set! box 0 val))
1278
1279 (define-prim (set-box! box val)
1280   (macro-force-vars (box)
1281     (macro-check-box box 1 (set-box! box val)
1282       (begin
1283         (##set-box! box val)
1284         (##void)))))
1285
1286 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1287
1288 (define-prim (exit #!optional (status (macro-absent-obj)))
1289   (if (##eq? status (macro-absent-obj))
1290     (##exit)
1291     (macro-force-vars (status)
1292       (macro-check-exact-unsigned-int8 status 1 (exit status)
1293         (##exit status)))))
1294
1295 (define-prim (##getenv name #!optional (default-value (macro-absent-obj)))
1296   (let ((result (##os-getenv name)))
1297     (cond ((##fixnum? result)
1298            (##raise-os-exception #f result getenv name default-value))
1299           ((##not result)
1300            (if (##eq? default-value (macro-absent-obj))
1301              (##raise-unbound-os-environment-variable-exception
1302               getenv
1303               name)
1304              default-value))
1305           (else
1306            result))))
1307
1308 (define-prim (getenv name #!optional (default-value (macro-absent-obj)))
1309   (macro-force-vars (name)
1310     (macro-check-string name 1 (getenv name default-value)
1311       (##getenv name default-value))))
1312
1313 (define-prim (##setenv name #!optional (value (macro-absent-obj)))
1314   (let ((code (##os-setenv name value)))
1315     (if (##fixnum.< code 0)
1316       (##raise-os-exception #f code setenv name value)
1317       (##void))))
1318
1319 (define-prim (setenv name #!optional (value (macro-absent-obj)))
1320   (macro-force-vars (name value)
1321     (macro-check-string name 1 (setenv name value)
1322       (if (##eq? value (macro-absent-obj))
1323         (##setenv name)
1324         (macro-check-string value 2 (setenv name value)
1325           (##setenv name value))))))
1326
1327 (define-prim (command-line)
1328   ##processed-command-line)
1329
1330 (define-prim (##shell-command-blocking cmd)
1331   ;; DEPRECATED
1332   (let ((code (##os-shell-command cmd (##current-directory))))
1333     (if (##fixnum.< code 0)
1334       (##raise-os-exception #f code ##shell-command-blocking cmd)
1335       code)))
1336
1337 (define ##shell-program #f)
1338
1339 (define-prim (##get-shell-program)
1340
1341   (define unix-shell-program    '("/bin/sh" . "-c"))
1342   (define windows-shell-program '("CMD.EXE" . "/C"))
1343   (define default-shell-program '("sh"      . "-c"))
1344
1345   (or ##shell-program
1346       (let ((sp
1347              (if (##file-exists? (##car unix-shell-program))
1348                  unix-shell-program
1349                  (if (##getenv "HOME" #f)
1350                      default-shell-program
1351                      (let ((comspec (##getenv "COMSPEC" #f)))
1352                        (if comspec
1353                            (##cons comspec "/C")
1354                            windows-shell-program))))))
1355         (set! ##shell-program sp)
1356         sp)))
1357
1358 (define-prim (##shell-command cmd)
1359   (let* ((shell-prog
1360           (##get-shell-program))
1361          (path-or-settings
1362           (##list path: (##car shell-prog)
1363                   arguments:
1364                   (##list
1365                    (##cdr shell-prog)
1366                    cmd)
1367                   stdin-redirection: #f
1368                   stdout-redirection: #f
1369                   stderr-redirection: #f)))
1370     (##open-process-generic
1371      (macro-direction-inout)
1372      #t
1373      (lambda (port)
1374        (##close-port port)
1375        (##process-status port))
1376      open-process
1377      path-or-settings)))
1378
1379 #;
1380 (define-prim (##escape-string str escape-char to-escape)
1381   (let* ((len
1382           (##string-length str))
1383          (nb-escapes
1384           (let loop1 ((i (##fixnum.- len 1))
1385                       (n 0))
1386             (if (##fixnum.< i 0)
1387                 n
1388                 (let ((c (##string-ref str i)))
1389                   (loop1 (##fixnum.- i 1)
1390                          (if (##memq c to-escape)
1391                              (##fixnum.+ n 1)
1392                              n))))))
1393          (escaped-len
1394           (##fixnum.+ len nb-escapes))
1395          (escaped-str
1396           (##make-string escaped-len 0)))
1397     (let loop2 ((i (##fixnum.- len 1))
1398                 (j (##fixnum.- escaped-len 1)))
1399       (if (and (##not (##fixnum.< i 0)) (##not (##fixnum.< j 0)))
1400           (let ((c (##string-ref str i)))
1401             (##string-set! escaped-str j c)
1402             (loop2 (##fixnum.- i 1)
1403                    (if (and (##fixnum.< 0 j)
1404                             (##memq c to-escape))
1405                        (let ()
1406                          (##string-set! escaped-str
1407                                         (##fixnum.- j 1)
1408                                         escape-char)
1409                          (##fixnum.- j 2))
1410                        (##fixnum.- j 1))))
1411           escaped-str))))
1412
1413 (define-prim (shell-command cmd)
1414   (macro-force-vars (cmd)
1415     (macro-check-string cmd 1 (shell-command cmd)
1416       (##shell-command cmd))))
1417
1418 ;;;----------------------------------------------------------------------------
1419
1420 ;;; Implementation of file-info objects.
1421
1422 (implement-library-type-file-info)
1423
1424 (define-prim (##file-info
1425               path
1426               #!optional
1427               (chase? (macro-absent-obj)))
1428   (let* ((resolved-path
1429           (##path-resolve path))
1430          (result
1431           (##os-file-info resolved-path
1432                           (if (##eq? chase? (macro-absent-obj))
1433                               #t
1434                               chase?))))
1435     (if (##fixnum? result)
1436       result
1437       (begin
1438         (let ((type
1439                (case (##vector-ref result 1)
1440                  ((1)  'regular)
1441                  ((2)  'directory)
1442                  ((3)  'character-special)
1443                  ((4)  'block-special)
1444                  ((5)  'fifo)
1445                  ((6)  'symbolic-link)
1446                  ((7)  'socket)
1447                  (else 'unknown))))
1448           (##vector-set! result 1 type))
1449         (##vector-set! result 9
1450           (macro-make-time (##vector-ref result 9) #f #f #f))
1451         (##vector-set! result 10
1452           (macro-make-time (##vector-ref result 10) #f #f #f))
1453         (##vector-set! result 11
1454           (macro-make-time (##vector-ref result 11) #f #f #f))
1455         (##vector-set! result 13
1456           (macro-make-time (##vector-ref result 13) #f #f #f))
1457         (##structure-type-set! result (macro-type-file-info))
1458         (##subtype-set! result (macro-subtype-structure))
1459         result))))
1460
1461 (define-prim (file-info
1462               path
1463               #!optional
1464               (chase? (macro-absent-obj)))
1465   (macro-force-vars (path chase?)
1466     (macro-check-string path 1 (file-info path chase?)
1467       (let ((info (##file-info path chase?)))
1468         (if (##fixnum? info)
1469           (##raise-os-exception #f info file-info path chase?)
1470           info)))))
1471
1472 (define-prim (file-type path)
1473   (macro-force-vars (path)
1474     (macro-check-string path 1 (file-type path)
1475       (let ((info (##file-info path)))
1476         (if (##fixnum? info)
1477           (##raise-os-exception #f info file-type path)
1478           (macro-file-info-type info))))))
1479
1480 (define-prim (file-device path)
1481   (macro-force-vars (path)
1482     (macro-check-string path 1 (file-device path)
1483       (let ((info (##file-info path)))
1484         (if (##fixnum? info)
1485           (##raise-os-exception #f info file-device path)
1486           (macro-file-info-device info))))))
1487
1488 (define-prim (file-inode path)
1489   (macro-force-vars (path)
1490     (macro-check-string path 1 (file-inode path)
1491       (let ((info (##file-info path)))
1492         (if (##fixnum? info)
1493           (##raise-os-exception #f info file-inode path)
1494           (macro-file-info-inode info))))))
1495
1496 (define-prim (file-mode path)
1497   (macro-force-vars (path)
1498     (macro-check-string path 1 (file-mode path)
1499       (let ((info (##file-info path)))
1500         (if (##fixnum? info)
1501           (##raise-os-exception #f info file-mode path)
1502           (macro-file-info-mode info))))))
1503
1504 (define-prim (file-number-of-links path)
1505   (macro-force-vars (path)
1506     (macro-check-string path 1 (file-number-of-links path)
1507       (let ((info (##file-info path)))
1508         (if (##fixnum? info)
1509           (##raise-os-exception #f info file-number-of-links path)
1510           (macro-file-info-number-of-links info))))))
1511
1512 (define-prim (file-owner path)
1513   (macro-force-vars (path)
1514     (macro-check-string path 1 (file-owner path)
1515       (let ((info (##file-info path)))
1516         (if (##fixnum? info)
1517           (##raise-os-exception #f info file-owner path)
1518           (macro-file-info-owner info))))))
1519
1520 (define-prim (file-group path)
1521   (macro-force-vars (path)
1522     (macro-check-string path 1 (file-group path)
1523       (let ((info (##file-info path)))
1524         (if (##fixnum? info)
1525           (##raise-os-exception #f info file-group path)
1526           (macro-file-info-group info))))))
1527
1528 (define-prim (file-size path)
1529   (macro-force-vars (path)
1530     (macro-check-string path 1 (file-size path)
1531       (let ((info (##file-info path)))
1532         (if (##fixnum? info)
1533           (##raise-os-exception #f info file-size path)
1534           (macro-file-info-size info))))))
1535
1536 (define-prim (file-last-access-time path)
1537   (macro-force-vars (path)
1538     (macro-check-string path 1 (file-last-access-time path)
1539       (let ((info (##file-info path)))
1540         (if (##fixnum? info)
1541           (##raise-os-exception #f info file-last-access-time path)
1542           (macro-file-info-last-access-time info))))))
1543
1544 (define-prim (file-last-modification-time path)
1545   (macro-force-vars (path)
1546     (macro-check-string path 1 (file-last-modification-time path)
1547       (let ((info (##file-info path)))
1548         (if (##fixnum? info)
1549           (##raise-os-exception #f info file-last-modification-time path)
1550           (macro-file-info-last-modification-time info))))))
1551
1552 (define-prim (file-last-change-time path)
1553   (macro-force-vars (path)
1554     (macro-check-string path 1 (file-last-change-time path)
1555       (let ((info (##file-info path)))
1556         (if (##fixnum? info)
1557           (##raise-os-exception #f info file-last-change-time path)
1558           (macro-file-info-last-change-time info))))))
1559
1560 (define-prim (file-attributes path)
1561   (macro-force-vars (path)
1562     (macro-check-string path 1 (file-attributes path)
1563       (let ((info (##file-info path)))
1564         (if (##fixnum? info)
1565           (##raise-os-exception #f info file-attributes path)
1566           (macro-file-info-attributes info))))))
1567
1568 (define-prim (file-creation-time path)
1569   (macro-force-vars (path)
1570     (macro-check-string path 1 (file-creation-time path)
1571       (let ((info (##file-info path)))
1572         (if (##fixnum? info)
1573           (##raise-os-exception #f info file-creation-time path)
1574           (macro-file-info-creation-time info))))))
1575
1576 ;;;----------------------------------------------------------------------------
1577
1578 (define-prim (##file-exists?
1579               path
1580               #!optional
1581               (chase? (macro-absent-obj)))
1582   (let* ((resolved-path
1583           (##path-resolve path))
1584          (result
1585           (##os-file-info resolved-path
1586                           (if (##eq? chase? (macro-absent-obj))
1587                               #t
1588                               chase?))))
1589     (##not (##fixnum? result))))
1590
1591 (define-prim (file-exists?
1592               path
1593               #!optional
1594               (chase? (macro-absent-obj)))
1595   (macro-force-vars (path chase?)
1596     (macro-check-string path 1 (file-exists? path chase?)
1597       (##file-exists? path chase?))))
1598
1599 ;;;----------------------------------------------------------------------------
1600
1601 ;;; Implementation of user-info objects.
1602
1603 (implement-library-type-user-info)
1604
1605 (define-prim (##user-info user)
1606   (let ((result (##os-user-info user)))
1607     (if (##fixnum? result)
1608       (##raise-os-exception #f result user-info user)
1609       (begin
1610         (##structure-type-set! result (macro-type-user-info))
1611         (##subtype-set! result (macro-subtype-structure))
1612         result))))
1613
1614 (define-prim (user-info user)
1615   (macro-force-vars (user)
1616     (macro-check-string-or-nonnegative-fixnum user 1 (user-info user)
1617       (##user-info user))))
1618
1619 (define-prim (##user-name)
1620   (let ((result (##os-user-name)))
1621     (if (##fixnum? result)
1622       (##raise-os-exception #f result user-name)
1623       result)))
1624
1625 (define-prim (user-name)
1626   (##user-name))
1627
1628 ;;;----------------------------------------------------------------------------
1629
1630 ;;; Implementation of group-info objects.
1631
1632 (implement-library-type-group-info)
1633
1634 (define-prim (##group-info group)
1635   (let ((result (##os-group-info group)))
1636     (if (##fixnum? result)
1637       (##raise-os-exception #f result group-info group)
1638       (begin
1639         (##structure-type-set! result (macro-type-group-info))
1640         (##subtype-set! result (macro-subtype-structure))
1641         result))))
1642
1643 (define-prim (group-info group)
1644   (macro-force-vars (group)
1645     (macro-check-string-or-nonnegative-fixnum group 1 (group-info group)
1646       (##group-info group))))
1647
1648 ;;;----------------------------------------------------------------------------
1649
1650 ;;; Pathname operations.
1651
1652 (define-prim (##path-volume-end-using-dir-sep path directory-separator)
1653   (cond ((##char=? #\: directory-separator)
1654          (let loop1 ((i 0))
1655            (if (##fixnum.< i (##string-length path))
1656              (let ((c (##string-ref path i)))
1657                (if (##char=? #\: c)
1658                  i
1659                  (loop1 (##fixnum.+ i 1))))
1660              0)))
1661         ((##char=? #\\ directory-separator)
1662          (if (##fixnum.= 0 (##string-length path))
1663            0
1664            (let ((c (##string-ref path 0)))
1665              (cond ((or (and (##char<=? #\a c)
1666                              (##char<=? c #\z))
1667                         (and (##char<=? #\A c)
1668                              (##char<=? c #\Z)))
1669                     (if (and (##fixnum.< 1 (##string-length path))
1670                              (##char=? #\: (##string-ref path 1)))
1671                       2
1672                       0))
1673                    ((or (##char=? #\\ c)
1674                         (##char=? #\/ c))
1675                     (if (and (##fixnum.< 1 (##string-length path))
1676                              (let ((c (##string-ref path 1)))
1677                                (or (##char=? #\\ c)
1678                                    (##char=? #\/ c))))
1679                       (let loop2 ((i 2)
1680                                   (nb-seps 2)
1681                                   (last 1))
1682                         (if (##fixnum.< i (##string-length path))
1683                           (let ((c (##string-ref path i)))
1684                             (cond ((##not (or (##char=? #\\ c)
1685                                               (##char=? #\/ c)))
1686                                    (loop2 (##fixnum.+ i 1)
1687                                           nb-seps
1688                                           last))
1689                                   ((##fixnum.= i (##fixnum.+ last 1))
1690                                    0)
1691                                   ((##fixnum.= nb-seps 3)
1692                                    i)
1693                                   (else
1694                                    (loop2 (##fixnum.+ i 1)
1695                                           (##fixnum.+ nb-seps 1)
1696                                           i))))
1697                           (if (or (##fixnum.< nb-seps 3)
1698                                   (##fixnum.= i (##fixnum.+ last 1)))
1699                             0
1700                             i)))
1701                       0))
1702                    (else
1703                     0)))))
1704         (else
1705          0)))
1706
1707 (define ##path-resolve-hook #f)
1708 (set! ##path-resolve-hook #f)
1709
1710 (define-prim (##path-resolve path)
1711   (let ((pr-hook ##path-resolve-hook))
1712     (if (##procedure? pr-hook)
1713         (let ((result
1714                (pr-hook path)))
1715           (if (##string? result)
1716               result
1717               (##raise-error-exception
1718                "STRING result expected but got"
1719                (##list result))))
1720         (##default-path-resolve path))))
1721
1722 (define-prim (##default-path-resolve path)
1723   (##path-expand path))
1724
1725 (define ##path-expand-hook #f)
1726 (set! ##path-expand-hook #f)
1727
1728 (define-prim (##path-expand
1729               path
1730               #!optional
1731               (origin (macro-absent-obj)))
1732   (let ((pe-hook ##path-expand-hook))
1733     (if (##procedure? pe-hook)
1734         (let ((result
1735                (if (##eq? origin (macro-absent-obj))
1736                    (pe-hook path)
1737                    (pe-hook path origin))))
1738           (if (##string? result)
1739               result
1740               (##raise-error-exception
1741                "STRING result expected but got"
1742                (##list result))))
1743         (if (##eq? origin (macro-absent-obj))
1744             (##default-path-expand path)
1745             (##default-path-expand path origin)))))
1746
1747 (define-prim (##default-path-expand
1748               path
1749               #!optional
1750               (origin (macro-absent-obj)))
1751   (let* ((cd
1752           (##current-directory))
1753          (directory-separator
1754           (if (##fixnum.< 0 (##string-length cd))
1755               (##string-ref cd (##fixnum.- (##string-length cd) 1))
1756               #\/)))
1757
1758     (define (expand p orig)
1759
1760       (define (relative dir-sep?)
1761         (let* ((dir
1762                 (if (##not orig)
1763                     cd
1764                     (let* ((d orig) ;; (expand orig #f)
1765                            (len (##string-length d)))
1766                       (if (or (##fixnum.= len 0)
1767                               (##char=? (##string-ref d
1768                                                       (##fixnum.- len 1))
1769                                         directory-separator))
1770                           d
1771                           (##string-append
1772                            d
1773                            (##string directory-separator))))))
1774                (len
1775                 (if dir-sep?
1776                     (if (##char=? #\: directory-separator)
1777                         (##fixnum.- (##string-length dir) 1)
1778                         (##path-volume-end-using-dir-sep
1779                          dir
1780                          directory-separator))
1781                     (##string-length dir))))
1782           (if (##fixnum.= len 0)
1783               p
1784               (let ((result
1785                      (##make-string
1786                       (##fixnum.+ len (##string-length p)))))
1787                 (##substring-move! dir 0 len result 0)
1788                 (##substring-move! p 0 (##string-length p) result len)
1789                 result))))
1790
1791       (define (absolute vol-end dir-sep?)
1792         (if dir-sep?
1793             p
1794             (let ((result
1795                    (##make-string (##fixnum.+ 1 (##string-length p)))))
1796               (##substring-move! p 0 vol-end result 0)
1797               (##string-set! result vol-end directory-separator)
1798               (##substring-move! p vol-end (##string-length p) result (##fixnum.+ vol-end 1))
1799               result)))
1800
1801       (define (tilde-end)
1802         (if (##fixnum.= 0 (##string-length p))
1803             0
1804             (if (##char=? #\~ (##string-ref p 0))
1805                 (let loop ((i 1))
1806                   (if (##fixnum.< i (##string-length p))
1807                       (let ((c (##string-ref p i)))
1808                         (cond ((or (##char=? c directory-separator)
1809                                    (and (##char=? #\\ directory-separator)
1810                                         (##char=? #\/ c)))
1811                                i)
1812                               (else
1813                                (loop (##fixnum.+ i 1)))))
1814                       i))
1815                 0)))
1816
1817       (define (prepend-directory dir start)
1818         (if (##fixnum? dir)
1819             (##raise-os-exception #f dir path-expand path origin)
1820             (let* ((dir-len
1821                     (##string-length dir))
1822                    (ends-with-dir-sep?
1823                     (and (##fixnum.< 0 dir-len)
1824                          (##char=? directory-separator
1825                                    (##string-ref dir (##fixnum.- dir-len 1)))))
1826                    (dir-end
1827                     (if ends-with-dir-sep? (##fixnum.- dir-len 1) dir-len))
1828                    (rest-len
1829                     (##fixnum.- (##string-length p)
1830                                 start))
1831                    (len
1832                     (##fixnum.+ dir-end
1833                                 1 ;; for directory separator
1834                                 (if (##fixnum.< 0 rest-len)
1835                                     (##fixnum.- rest-len 1)
1836                                     0)))
1837                    (result
1838                     (##make-string len)))
1839               (##substring-move! dir 0 dir-end result 0)
1840               (##substring-move! p start (##string-length p) result dir-end)
1841               (##string-set! result dir-end directory-separator)
1842               (expand result orig))))
1843
1844       (define (err code)
1845         (##raise-os-exception #f code path-expand path origin))
1846
1847       (define (expand-in-instdir relpath instdir-name)
1848         (let ((dir (##os-path-gambcdir-map-lookup instdir-name)))
1849           (cond ((##fixnum? dir)
1850                  (err dir))
1851                 (dir
1852                  (expand relpath dir))
1853                 (else
1854                  (let ((dir (##os-path-gambcdir)))
1855                    (cond ((##fixnum? dir)
1856                           (err dir))
1857                          ((##fixnum.= 0 (##string-length instdir-name))
1858                           (expand relpath dir))
1859                          (else
1860                           (expand relpath
1861                                   (expand instdir-name dir)))))))))
1862
1863       (let ((t-end (tilde-end)))
1864         (if (##fixnum.< 0 t-end)
1865
1866             (cond ((##fixnum.= 1 t-end)
1867                    (let ((homedir (##os-path-homedir)))
1868                      (cond ((##fixnum? homedir)
1869                             (err homedir))
1870                            (homedir
1871                             (prepend-directory homedir t-end))
1872                            (else
1873                             (expand "~~" #f)))))
1874                   ((##char=? #\~ (##string-ref p 1))
1875                    (let* ((len
1876                            (##string-length p))
1877                           (instdir-name
1878                            (##substring p 2 t-end))
1879                           (relpath
1880                            (##substring p
1881                                         (if (##fixnum.= t-end len)
1882                                             t-end
1883                                             (##fixnum.+ t-end 1))
1884                                         len)))
1885                      (expand-in-instdir
1886                       relpath
1887                       instdir-name)))
1888                   (else
1889                    (let ((info (##os-user-info (##substring p 1 t-end))))
1890                      (prepend-directory
1891                       (if (##fixnum? info)
1892                           info
1893                           (##vector-ref info 4)) ;; home dir
1894                       t-end))))
1895
1896             (let* ((vol-end
1897                     (##path-volume-end-using-dir-sep p directory-separator))
1898                    (dir-sep?
1899                     (and (##fixnum.< vol-end (##string-length p))
1900                          (let ((c (##string-ref p vol-end)))
1901                            (or (##char=? c directory-separator)
1902                                (and (##char=? #\\ directory-separator)
1903                                     (##char=? #\/ c)))))))
1904               (if (##fixnum.= vol-end 0)
1905                   (relative dir-sep?)
1906                   (absolute vol-end dir-sep?))))))
1907
1908     (expand path (if (##eq? origin (macro-absent-obj)) #f origin))))
1909
1910 (define-prim (path-expand
1911               path
1912               #!optional
1913               (origin (macro-absent-obj)))
1914   (macro-force-vars (path origin)
1915     (macro-check-string path 1 (path-expand path origin)
1916       (if (##eq? origin (macro-absent-obj))
1917         (##path-expand path)
1918         (macro-check-string origin 2 (path-expand path origin)
1919           (##path-expand path origin))))))
1920
1921 (define-prim (##path-normalize
1922               path
1923               #!optional
1924               (allow-relative? (macro-absent-obj))
1925               (origin (macro-absent-obj))
1926               (raise-os-exception? (macro-absent-obj)))
1927
1928   (define (normalize path)
1929     (let ((dir
1930            (##os-path-normalize-directory path)))
1931       (if (##fixnum? dir)
1932         (let ((parent-dir
1933                (##os-path-normalize-directory (##path-directory path))))
1934           (if (##fixnum? parent-dir)
1935             parent-dir
1936             (##string-append parent-dir (##path-strip-directory path))))
1937         dir)))
1938
1939   (let* ((cd
1940           (##current-directory))
1941          (directory-separator
1942           (##string-ref cd (##fixnum.- (##string-length cd) 1)))
1943          (dir
1944           (if (or (##not origin) (##eq? origin (macro-absent-obj)))
1945             cd
1946             (normalize (##path-expand origin cd))))
1947          (p
1948           (normalize (##path-expand path dir))))
1949     (if (##fixnum? p)
1950         (if raise-os-exception?
1951             (##raise-os-exception
1952              #f
1953              p
1954              path-normalize
1955              path
1956              allow-relative?
1957              origin
1958              raise-os-exception?)
1959             path)
1960       (if (or (##eq? allow-relative? (macro-absent-obj))
1961               (##not allow-relative?))
1962         p
1963         (let* ((first-diff
1964                 (let loop1 ((i 0))
1965                   (if (and (##fixnum.< i (##string-length dir))
1966                            (##fixnum.< i (##string-length p))
1967                            (##char=? (##string-ref dir i) (##string-ref p i)))
1968                     (loop1 (##fixnum.+ i 1))
1969                     i)))
1970                (vol-end
1971                 (##path-volume-end-using-dir-sep dir directory-separator)))
1972           (if (##fixnum.< first-diff vol-end)
1973             p
1974             (let* ((common-dir-end
1975                     (let loop2 ((i (##fixnum.- first-diff 1)))
1976                       (if (##fixnum.< i vol-end)
1977                         0
1978                         (let ((c (##string-ref dir i)))
1979                           (if (or (##char=? c directory-separator)
1980                                   (and (##char=? #\\ directory-separator)
1981                                        (##char=? #\/ c)))
1982                             (##fixnum.+ i 1)
1983                             (loop2 (##fixnum.- i 1)))))))
1984                    (nb-hops
1985                     (let loop3 ((i first-diff) (nb-hops 0))
1986                       (if (##fixnum.< i (##string-length dir))
1987                         (loop3 (##fixnum.+ i 1)
1988                                (let ((c (##string-ref dir i)))
1989                                  (if (or (##char=? c directory-separator)
1990                                          (and (##char=? #\\ directory-separator)
1991                                               (##char=? #\/ c)))
1992                                    (##fixnum.+ nb-hops 1)
1993                                    nb-hops)))
1994                         (if (and (##char=? #\: directory-separator)
1995                                  (or (##fixnum.< 0 nb-hops)
1996                                      (let loop4 ((i first-diff))
1997                                        (if (##fixnum.< i (##string-length p))
1998                                          (if (##char=? #\:
1999                                                        (##string-ref p i))
2000                                            #t
2001                                            (loop4 (##fixnum.+ i 1)))
2002                                          #f))))
2003                           (##fixnum.+ nb-hops 1)
2004                           nb-hops))))
2005                    (hop
2006                     (cond ((##char=? #\: directory-separator)
2007                            ":")
2008                           ((##char=? #\\ directory-separator)
2009                            "..\\")
2010                           (else
2011                            "../")))
2012                    (hop-len
2013                     (##fixnum.* (##string-length hop) nb-hops))
2014                    (length-reduction
2015                     (##fixnum.- common-dir-end hop-len)))
2016
2017               (if (and (##fixnum.< length-reduction (##string-length p))
2018                        (or (##not (##eq? allow-relative? 'shortest))
2019                            (##fixnum.< 0 length-reduction)))
2020                 (let ((result
2021                        (##make-string
2022                         (##fixnum.- (##string-length p) length-reduction))))
2023                   (##substring-move!
2024                    p
2025                    common-dir-end
2026                    (##string-length p)
2027                    result
2028                    hop-len)
2029                   (let loop5 ((i (##fixnum.- nb-hops 1)))
2030                     (if (##fixnum.< i 0)
2031                       result
2032                       (begin
2033                         (##substring-move!
2034                          hop
2035                          0
2036                          (##string-length hop)
2037                          result
2038                          (##fixnum.* i (##string-length hop)))
2039                         (loop5 (##fixnum.- i 1))))))
2040                 p))))))))
2041
2042 (define-prim (path-normalize
2043               path
2044               #!optional
2045               (allow-relative? (macro-absent-obj))
2046               (origin (macro-absent-obj))
2047               (raise-os-exception? (macro-absent-obj)))
2048   (macro-force-vars (path allow-relative? origin raise-os-exception?)
2049     (macro-check-string path 1 (path-normalize path allow-relative? origin)
2050       (if (##eq? allow-relative? (macro-absent-obj))
2051         (##path-normalize path)
2052         (if (##eq? origin (macro-absent-obj))
2053           (##path-normalize path allow-relative?)
2054           (macro-check-string origin 2 (path-normalize path allow-relative? origin)
2055             (if (##eq? raise-os-exception? (macro-absent-obj))
2056                 (##path-normalize path allow-relative? origin)
2057                 (##path-normalize path allow-relative? origin raise-os-exception?))))))))
2058
2059 (define-prim (##path-extension-start path)
2060   (let* ((cd
2061           (##current-directory))
2062          (directory-separator
2063           (##string-ref cd (##fixnum.- (##string-length cd) 1)))
2064          (vol-end
2065           (##path-volume-end-using-dir-sep path directory-separator)))
2066     (let loop ((i (##fixnum.- (##string-length path) 1)))
2067       (if (##fixnum.< vol-end i)
2068         (let ((c (##string-ref path (##fixnum.- i 1))))
2069           (cond ((or (##char=? c directory-separator)
2070                      (and (##char=? #\\ directory-separator)
2071                           (##char=? #\/ c)))
2072                  (##string-length path))
2073                 ((##char=? (##string-ref path i) #\.)
2074                  i)
2075                 (else
2076                  (loop (##fixnum.- i 1)))))
2077         (##string-length path)))))
2078
2079 (define-prim (##path-extension path)
2080   (##substring path (##path-extension-start path) (##string-length path)))
2081
2082 (define-prim (path-extension path)
2083   (macro-force-vars (path)
2084     (macro-check-string path 1 (path-extension path)
2085       (##path-extension path))))
2086
2087 (define-prim (##path-strip-extension path)
2088   (##substring path 0 (##path-extension-start path)))
2089
2090 (define-prim (path-strip-extension path)
2091   (macro-force-vars (path)
2092     (macro-check-string path 1 (path-strip-extension path)
2093       (##path-strip-extension path))))
2094
2095 (define-prim (##path-directory-end path)
2096   (let* ((cd
2097           (##current-directory))
2098          (directory-separator
2099           (##string-ref cd (##fixnum.- (##string-length cd) 1)))
2100          (vol-end
2101           (##path-volume-end-using-dir-sep path directory-separator)))
2102     (let loop ((i (##fixnum.- (##string-length path) 1)))
2103       (if (##fixnum.< i vol-end)
2104         vol-end
2105         (let ((c (##string-ref path i)))
2106           (cond ((or (##char=? c directory-separator)
2107                      (and (##char=? #\\ directory-separator)
2108                           (##char=? #\/ c)))
2109                  (##fixnum.+ i 1))
2110                 (else
2111                  (loop (##fixnum.- i 1)))))))))
2112
2113 (define-prim (##path-directory path)
2114   (##substring path 0 (##path-directory-end path)))
2115
2116 (define-prim (path-directory path)
2117   (macro-force-vars (path)
2118     (macro-check-string path 1 (path-directory path)
2119       (##path-directory path))))
2120
2121 (define-prim (##path-strip-directory path)
2122   (##substring path (##path-directory-end path) (##string-length path)))
2123
2124 (define-prim (path-strip-directory path)
2125   (macro-force-vars (path)
2126     (macro-check-string path 1 (path-strip-directory path)
2127       (##path-strip-directory path))))
2128
2129 (define-prim (##path-strip-trailing-directory-separator path)
2130   (let* ((cd
2131           (##current-directory))
2132          (directory-separator
2133           (##string-ref cd (##fixnum.- (##string-length cd) 1)))
2134          (len
2135           (##string-length path)))
2136     (if (and (##fixnum.< 0 len)
2137              (let ((c (##string-ref path (##fixnum.- len 1))))
2138                (or (##char=? c directory-separator)
2139                    (and (##char=? #\\ directory-separator)
2140                         (##char=? #\/ c)))))
2141       (##substring path 0 (##fixnum.- len 1))
2142       path)))
2143
2144 (define-prim (path-strip-trailing-directory-separator path)
2145   (macro-force-vars (path)
2146     (macro-check-string path 1 (path-strip-trailing-directory-separator path)
2147       (##path-strip-trailing-directory-separator path))))
2148
2149 (define-prim (##path-volume-end path)
2150   (let* ((cd
2151           (##current-directory))
2152          (directory-separator
2153           (##string-ref cd (##fixnum.- (##string-length cd) 1)))
2154          (vol-end
2155           (##path-volume-end-using-dir-sep path directory-separator)))
2156     vol-end))
2157
2158 (define-prim (##path-volume path)
2159   (##substring path 0 (##path-volume-end path)))
2160
2161 (define-prim (path-volume path)
2162   (macro-force-vars (path)
2163     (macro-check-string path 1 (path-volume path)
2164       (##path-volume path))))
2165
2166 (define-prim (##path-strip-volume path)
2167   (##substring path (##path-volume-end path) (##string-length path)))
2168
2169 (define-prim (path-strip-volume path)
2170   (macro-force-vars (path)
2171     (macro-check-string path 1 (path-strip-volume path)
2172       (##path-strip-volume path))))
2173
2174 ;;;----------------------------------------------------------------------------
2175
2176 ;;; Filesystem operations.
2177
2178 (define-prim (##create-directory-or-fifo prim path-or-settings)
2179
2180   (define (fail)
2181     (##fail-check-string-or-settings 1 prim path-or-settings))
2182
2183   (##make-psettings
2184    (macro-direction-inout)
2185    '(path:
2186      permissions:)
2187    (cond ((##string? path-or-settings)
2188           (##list 'path: path-or-settings))
2189          (else
2190           path-or-settings))
2191    fail
2192    (lambda (psettings)
2193      (let ((path
2194             (macro-psettings-path psettings)))
2195        (if (##not (##string? path))
2196          (fail)
2197          (let* ((resolved-path
2198                  (##path-resolve path))
2199                 (permissions
2200                  (##psettings->permissions
2201                   psettings
2202                   (if (##eq? prim create-directory)
2203                     #o777
2204                     #o666)))
2205                 (code
2206                  (if (##eq? prim create-directory)
2207                    (##os-create-directory resolved-path permissions)
2208                    (##os-create-fifo resolved-path permissions))))
2209            (if (##fixnum.< code 0)
2210              (##raise-os-exception #f code prim path-or-settings)
2211              (##void))))))))
2212
2213 (define-prim (create-directory path-or-settings)
2214   (macro-force-vars (path-or-settings)
2215     (##create-directory-or-fifo create-directory path-or-settings)))
2216
2217 (define-prim (create-fifo path-or-settings)
2218   (macro-force-vars (path-or-settings)
2219     (##create-directory-or-fifo create-fifo path-or-settings)))
2220
2221 (define-prim (##create-link old-path new-path)
2222   (let* ((resolved-old-path
2223           (##path-resolve old-path))
2224          (resolved-new-path
2225           (##path-resolve new-path))
2226          (code
2227           (##os-create-link resolved-old-path resolved-new-path)))
2228     (if (##fixnum.< code 0)
2229       (##raise-os-exception #f code create-link old-path new-path)
2230       (##void))))
2231
2232 (define-prim (create-link old-path new-path)
2233   (macro-force-vars (old-path new-path)
2234     (macro-check-string old-path 1 (create-link old-path new-path)
2235       (macro-check-string new-path 2 (create-link old-path new-path)
2236         (##create-link old-path new-path)))))
2237
2238 (define-prim (##create-symbolic-link old-path new-path)
2239   (let* ((resolved-old-path
2240           (##path-resolve old-path))
2241          (resolved-new-path
2242           (##path-resolve new-path))
2243          (code
2244           (##os-create-symbolic-link resolved-old-path resolved-new-path)))
2245     (if (##fixnum.< code 0)
2246       (##raise-os-exception #f code create-symbolic-link old-path new-path)
2247       (##void))))
2248
2249 (define-prim (create-symbolic-link old-path new-path)
2250   (macro-force-vars (old-path new-path)
2251     (macro-check-string old-path 1 (create-symbolic-link old-path new-path)
2252       (macro-check-string new-path 2 (create-symbolic-link old-path new-path)
2253         (##create-symbolic-link old-path new-path)))))
2254
2255 (define-prim (##delete-directory path)
2256   (let* ((resolved-path
2257           (##path-resolve path))
2258          (code
2259           (##os-delete-directory resolved-path)))
2260     (if (##fixnum.< code 0)
2261       (##raise-os-exception
2262        #f
2263        code
2264        delete-directory
2265        path)
2266       (##void))))
2267
2268 (define-prim (delete-directory path)
2269   (macro-force-vars (path)
2270     (macro-check-string path 1 (delete-directory path)
2271       (##delete-directory path))))
2272
2273 (define-prim (##rename-file old-path new-path)
2274   (let* ((resolved-old-path
2275           (##path-resolve old-path))
2276          (resolved-new-path
2277           (##path-resolve new-path))
2278          (code
2279           (##os-rename-file
2280            resolved-old-path
2281            resolved-new-path)))
2282     (if (##fixnum.< code 0)
2283       (##raise-os-exception
2284        #f
2285        code
2286        rename-file
2287        old-path
2288        new-path)
2289       (##void))))
2290
2291 (define-prim (rename-file old-path new-path)
2292   (macro-force-vars (old-path new-path)
2293     (macro-check-string old-path 1 (rename-file old-path new-path)
2294       (macro-check-string new-path 2 (rename-file old-path new-path)
2295         (##rename-file old-path new-path)))))
2296
2297 (define-prim (##copy-file old-path new-path)
2298   (let* ((resolved-old-path
2299           (##path-resolve old-path))
2300          (resolved-new-path
2301           (##path-resolve new-path))
2302          (code
2303           (##os-copy-file
2304            resolved-old-path
2305            resolved-new-path)))
2306     (if (##fixnum.< code 0)
2307       (##raise-os-exception
2308        #f
2309        code
2310        copy-file
2311        old-path
2312        new-path)
2313       (##void))))
2314
2315 (define-prim (copy-file old-path new-path)
2316   (macro-force-vars (old-path new-path)
2317     (macro-check-string old-path 1 (copy-file old-path new-path)
2318       (macro-check-string new-path 2 (copy-file old-path new-path)
2319         (##copy-file old-path new-path)))))
2320
2321 (define-prim (##delete-file path)
2322   (let* ((resolved-path
2323           (##path-resolve path))
2324          (code
2325           (##os-delete-file resolved-path)))
2326     (if (##fixnum.< code 0)
2327       (##raise-os-exception
2328        #f
2329        code
2330        delete-file
2331        path)
2332       (##void))))
2333
2334 (define-prim (delete-file path)
2335   (macro-force-vars (path)
2336     (macro-check-string path 1 (delete-file path)
2337       (##delete-file path))))
2338
2339 (define-prim (##directory-files
2340               #!optional
2341               (path-or-settings (macro-absent-obj)))
2342   (##open-directory
2343    #t
2344    (lambda (port)
2345      (let ((files (##read-all port ##read)))
2346        (##close-input-port port)
2347        files))
2348    directory-files
2349    path-or-settings))
2350
2351 (define-prim (directory-files
2352               #!optional
2353               (path-or-settings (macro-absent-obj)))
2354   (macro-force-vars (path-or-settings)
2355     (##directory-files path-or-settings)))
2356
2357 ;;;----------------------------------------------------------------------------
2358
2359 (define-runtime-macro (six.!x x)
2360   `(not ,x))
2361
2362 (define-runtime-macro (six.++x x)
2363   (##infix-update-in-place 'six.++x x 'six.x+y 1 #t))
2364
2365 (define-runtime-macro (six.x++ x)
2366   (##infix-update-in-place 'six.x++ x 'six.x+y 1 #f))
2367
2368 (define-runtime-macro (six.--x x)
2369   (##infix-update-in-place 'six.--x x 'six.x-y 1 #t))
2370
2371 (define-runtime-macro (six.x-- x)
2372   (##infix-update-in-place 'six.x-- x 'six.x-y 1 #f))
2373
2374 (define-runtime-macro (six.~x x)
2375   `(bitwise-not ,x))
2376
2377 (define-runtime-macro (six.x%y x y)
2378   `(modulo ,x ,y))
2379
2380 (define-runtime-macro (six.x*y x y)
2381   `(* ,x ,y))
2382
2383 (define-runtime-macro (six.*x x)
2384   (##infix-lvalue-fetch (##list 'six.*x x)))
2385
2386 (define-runtime-macro (six.x/y x y)
2387   `(/ ,x ,y))
2388
2389 (define-runtime-macro (six.x+y x y)
2390   `(+ ,x ,y))
2391
2392 (define-runtime-macro (six.+x x)
2393   `(+ ,x))
2394
2395 (define-runtime-macro (six.x-y x y)
2396   `(- ,x ,y))
2397
2398 (define-runtime-macro (six.-x x)
2399   `(- ,x))
2400
2401 (define-runtime-macro (six.x<<y x y)
2402   `(arithmetic-shift ,x ,y))
2403
2404 (define-runtime-macro (six.x>>y x y)
2405   `(arithmetic-shift ,x (- ,y)))
2406
2407 (define-runtime-macro (six.x<y x y)
2408   `(< ,x ,y))
2409
2410 (define-runtime-macro (six.x<=y x y)
2411   `(<= ,x ,y))
2412
2413 (define-runtime-macro (six.x>y x y)
2414   `(> ,x ,y))
2415
2416 (define-runtime-macro (six.x>=y x y)
2417   `(>= ,x ,y))
2418
2419 (define-runtime-macro (six.x!=y x y)
2420   `(not (equal? ,x ,y)))
2421
2422 (define-runtime-macro (six.x==y x y)
2423   `(equal? ,x ,y))
2424
2425 (define-runtime-macro (six.x&y x y)
2426   `(bitwise-and ,x ,y))
2427
2428 (define-prim (##infix-id x)
2429   (if (##pair? x)
2430     (let* ((first (##car x))
2431            (rest (##cdr x)))
2432       (if (and (or (##eq? first 'six.identifier)
2433                    (##eq? first 'six.prefix))
2434                (##pair? rest))
2435         (let* ((second (##car rest))
2436                (rest (##cdr rest)))
2437           (if (and (##symbol? second)
2438                    (##null? rest))
2439             second
2440             #f))
2441         #f))
2442     #f))
2443
2444 (define-runtime-macro (six.&x x)
2445   (##infix-lvalue-access
2446    'six.&x
2447    (##list x)
2448    x
2449    (lambda (prepare fetch only-fetch store only-store)
2450      (let* ((set (##gensym))
2451             (val (##gensym)))
2452        (prepare
2453         `(lambda ,set
2454            (if (##pair? ,set)
2455              (let ((,val (##car ,set)))
2456                ,(store val)
2457                ,val)
2458              ,(fetch))))))))
2459
2460 (define-prim (##infix-lvalue-access form-name args x cont)
2461
2462   (define (err)
2463     (##ill-formed-special-form form-name args))
2464
2465   (if (##pair? x)
2466     (let* ((first (##car x))
2467            (rest (##cdr x)))
2468       (if (##pair? rest)
2469         (let* ((second (##car rest))
2470                (rest (##cdr rest)))
2471           (cond ((##pair? rest)
2472                  (let* ((third (##car rest))
2473                         (rest (##cdr rest)))
2474                    (cond ((##not (##null? rest))
2475                           (err))
2476                          ((##eq? first 'six.index)
2477                           (let* ((vect (##gensym))
2478                                  (index (##gensym)))
2479                             (cont (lambda (body)
2480                                     `(let ((,vect ,second) (,index ,third))
2481                                        ,body))
2482                                   (lambda ()
2483                                     `(vector-ref ,vect ,index))
2484                                   (lambda ()
2485                                     `(vector-ref ,second ,third))
2486                                   (lambda (val)
2487                                     `(vector-set! ,vect ,index ,val))
2488                                   (lambda (val)
2489                                     `(vector-set! ,second ,third ,val)))))
2490                          ((and (or (##eq? first 'six.arrow)
2491                                    (##eq? first 'six.dot))
2492                                (##infix-id third))
2493                           =>
2494                           (lambda (id)
2495                             (let* ((struct (##gensym))
2496                                    (mutator
2497                                     (##string->symbol
2498                                      (##string-append
2499                                       (##symbol->string id)
2500                                       "-set!"))))
2501                             (cont (lambda (body)
2502                                     `(let ((,struct ,second))
2503                                        ,body))
2504                                   (lambda ()
2505                                     `(,id ,struct))
2506                                   (lambda ()
2507                                     `(,id ,second))
2508                                   (lambda (val)
2509                                     `(,mutator ,struct ,val))
2510                                   (lambda (val)
2511                                     `(,mutator ,second ,val))))))
2512                          (else
2513                           (err)))))
2514                 ((##null? rest)
2515                  (cond ((##eq? first 'six.*x)
2516                         (let ((ptr (##gensym)))
2517                           (cont (lambda (body)
2518                                   `(let ((,ptr ,second))
2519                                      ,body))
2520                                 (lambda ()
2521                                   `(,ptr))
2522                                 (lambda ()
2523                                   `(,second))
2524                                 (lambda (val)
2525                                   `(,ptr ,val))
2526                                 (lambda (val)
2527                                   `(,second ,val)))))
2528                        ((and (or (##eq? first 'six.identifier)
2529                                  (##eq? first 'six.prefix))
2530                              (##symbol? second))
2531                         (let ((var (##gensym)))
2532                           (cont (lambda (body)
2533                                   body)
2534                                 (lambda ()
2535                                   second)
2536                                 (lambda ()
2537                                   second)
2538                                 (lambda (val)
2539                                   `(set! ,second ,val))
2540                                 (lambda (val)
2541                                   `(set! ,second ,val)))))
2542                        (else
2543                         (err))))
2544                 (else
2545                  (err))))
2546         (err)))
2547     (err)))
2548
2549 (define-prim (##infix-lvalue-fetch form)
2550   (##infix-lvalue-access
2551    (##car form)
2552    (##cdr form)
2553    form
2554    (lambda (prepare fetch only-fetch store only-store)
2555      (only-fetch))))
2556
2557 (define-prim (##infix-update-in-place form-name x operator operand2 pre?)
2558   (##infix-lvalue-access
2559    form-name
2560    (if (##eq? operand2 1)
2561      (##list x)
2562      (##list x operand2))
2563    x
2564    (lambda (prepare fetch only-fetch store only-store)
2565      (let ((val (##gensym)))
2566        (prepare
2567         (if pre?
2568           `(let ((,val (,operator ,(fetch) ,operand2)))
2569              ,(store val)
2570              ,val)
2571           `(let ((,val ,(fetch)))
2572              ,(store `(,operator ,val ,operand2))
2573              ,val)))))))
2574
2575 (define-runtime-macro (six.x^y x y)
2576   `(bitwise-xor ,x ,y))
2577
2578 (define-runtime-macro (|six.x\|y| x y)
2579   `(bitwise-ior ,x ,y))
2580
2581 (define-runtime-macro (six.x&&y x y)
2582   `(and ,x ,y))
2583
2584 (define-runtime-macro (|six.x\|\|y| x y)
2585   `(or ,x ,y))
2586
2587 (define-runtime-macro (six.x?y:z x y z)
2588   `(if ,x ,y ,z))
2589
2590 (define-runtime-macro (six.x:y x y)
2591   `(cons ,x ,y))
2592
2593 (define-runtime-macro (six.x%=y x y)
2594   (##infix-update-in-place 'six.x%=y x 'six.x%y y #t))
2595
2596 (define-runtime-macro (six.x&=y x y)
2597   (##infix-update-in-place 'six.x&=y x 'six.x&y y #t))
2598
2599 (define-runtime-macro (six.x*=y x y)
2600   (##infix-update-in-place 'six.x*=y x 'six.x*y y #t))
2601
2602 (define-runtime-macro (six.x+=y x y)
2603   (##infix-update-in-place 'six.x+=y x 'six.x+y y #t))
2604
2605 (define-runtime-macro (six.x-=y x y)
2606   (##infix-update-in-place 'six.x-=y x 'six.x-y y #t))
2607
2608 (define-runtime-macro (six.x/=y x y)
2609   (##infix-update-in-place 'six.x/=y x 'six.x/y y #t))
2610
2611 (define-runtime-macro (six.x<<=y x y)
2612   (##infix-update-in-place 'six.x<<=y x 'six.x<<y y #t))
2613
2614 (define-runtime-macro (six.x=y x y)
2615   (##infix-lvalue-access
2616    'six.x=y
2617    (##list x y)
2618    x
2619    (lambda (prepare fetch only-fetch store only-store)
2620      (let ((val (##gensym)))
2621        (prepare
2622         `(let ((,val ,y))
2623            ,(store val)
2624            ,val))))))
2625
2626 (define-runtime-macro (six.x>>=y x y)
2627   (##infix-update-in-place 'six.x>>=y x 'six.x>>y y #t))
2628
2629 (define-runtime-macro (six.x^=y x y)
2630   (##infix-update-in-place 'six.x^=y x 'six.x^y y #t))
2631
2632 (define-runtime-macro (|six.x\|=y| x y)
2633   (##infix-update-in-place '|six.x\|=y| x '|six.x\|y| y #t))
2634
2635 (define-runtime-macro (six.x:=y x y)
2636   (##infix-lvalue-access
2637    'six.x:=y
2638    (##list x y)
2639    x
2640    (lambda (prepare fetch only-fetch store only-store)
2641      (let ((val (##gensym)))
2642        (prepare
2643         `(let ((,val ,y))
2644            ,(store val)
2645            ,val))))))
2646
2647 (define-runtime-macro (|six.x,y| x y)
2648   `(begin ,x ,y))
2649
2650 (define-runtime-macro (six.cons expr1 expr2)
2651   `(cons ,expr1 ,expr2))
2652
2653 (define-runtime-macro (six.list expr1 expr2)
2654   `(cons ,expr1 ,expr2))
2655
2656 (define-runtime-macro (six.null)
2657   `'())
2658
2659 (define-runtime-macro (six.new identifier . args)
2660   (cond ((##infix-id identifier)
2661          =>
2662          (lambda (id)
2663            `(,(##string->symbol
2664                (##string-append "make-"
2665                                 (##symbol->string id)))
2666              ,@args)))
2667         (else
2668          (##ill-formed-special-form 'six.new (##cons identifier args)))))
2669
2670 (define-runtime-macro (six.call func . args)
2671   `(,func ,@args))
2672
2673 (define-runtime-macro (six.index expr1 expr2)
2674   (##infix-lvalue-fetch (##list 'six.index expr1 expr2)))
2675
2676 (define-runtime-macro (six.arrow expr identifier)
2677   (##infix-lvalue-fetch (##list 'six.arrow expr identifier)))
2678
2679 (define-runtime-macro (six.dot expr identifier)
2680   (##infix-lvalue-fetch (##list 'six.dot expr identifier)))
2681
2682 (define-runtime-macro (six.literal value)
2683   `',value)
2684
2685 (define-runtime-macro (six.identifier identifier)
2686   (##infix-lvalue-fetch (##list 'six.identifier identifier)))
2687
2688 (define-runtime-macro (six.prefix datum)
2689   datum)
2690
2691 (define-runtime-macro (six.if expr stat1 . stat2)
2692   `(if ,expr ,stat1 ,@stat2))
2693
2694 (define-runtime-macro (six.while expr stat)
2695   (let ((loop (gensym)))
2696     `(let ,loop () (if ,expr (begin ,stat (,loop))))))
2697
2698 (define-runtime-macro (six.do-while stat expr)
2699   (let ((loop (gensym)))
2700     `(let ,loop () (begin ,stat (if ,expr (,loop))))))
2701
2702 (define-runtime-macro (six.for stat1 expr2 expr3 stat2)
2703   (if (##equal? stat1 '(six.compound))
2704     (let* ((loop (gensym))
2705            (body `(begin ,stat2 ,@(if expr3 `(,expr3) '()) (,loop))))
2706       `(let ,loop ()
2707          ,(if expr2
2708             `(if ,expr2 ,body)
2709             body)))
2710     `(six.compound
2711       ,stat1
2712       (six.for (six.compound) ,expr2 ,expr3 ,stat2))))
2713
2714 (define-runtime-macro (six.compound . stats)
2715   (##infix-compound-expand 'six.compound stats))
2716
2717 (define-runtime-macro (six.procedure-body . stats)
2718   (##infix-compound-expand 'six.procedure-body stats))
2719
2720 (define-prim (##infix-compound-expand form-name stats)
2721
2722   (define (expand lst1 lst2 first?)
2723     (cond ((##pair? lst1)
2724            (let ((stat (##car lst1)))
2725              (cond ((and (##pair? stat)
2726                          (##eq? (##car stat) 'six.define-procedure))
2727                     (expand (##cdr lst1)
2728                             (##cons stat lst2)
2729                             first?))
2730                    ((##not (##null? lst2))
2731                     `((let () ,@(##reverse lst2) ,@(expand lst1 '() #t))))
2732                    ((##infix-variable-binding stat)
2733                     =>
2734                     (lambda (binding)
2735                       `((let (,binding) ,@(expand (##cdr lst1) '() #t)))))
2736                    ((##null? (##cdr lst1))
2737                     (if (and (##eq? form-name 'six.procedure-body)
2738                              (##pair? stat)
2739                              (##eq? (##car stat) 'six.return))
2740                       (let ((rest (##cdr stat)))
2741                         (cond ((##null? rest)
2742                                `((void)))
2743                               ((and (##pair? rest)
2744                                     (##null? (##cdr rest)))
2745                                `(,(##car rest)))
2746                               (else
2747                                `(,stat))))
2748                       `(,stat)))
2749                    (else
2750                     `(,stat ,@(expand (##cdr lst1) '() #f))))))
2751           (first?
2752            '((void)))
2753           (else
2754            '())))
2755
2756   (if (##null? stats)
2757     `(void)
2758     `(begin ,@(expand stats '() #t))))
2759
2760 (define-runtime-macro (six.define-variable identifier type dims init)
2761   (cond ((##infix-variable-binding
2762           `(six.define-variable ,identifier ,type ,dims ,init))
2763          =>
2764          (lambda (binding)
2765            `(define ,@binding)))
2766         (else
2767          (##ill-formed-special-form 'six.define-variable
2768                                     (##list identifier
2769                                             type
2770                                             dims
2771                                             init)))))
2772
2773 (define-prim (##infix-variable-binding form)
2774   (if (and (##pair? form)
2775            (##eq? (##car form) 'six.define-variable))
2776     (let ((rest (##cdr form)))
2777       (if (##pair? rest)
2778         (let* ((identifier (##car rest))
2779                (rest (##cdr rest)))
2780           (if (##pair? rest)
2781             (let* ((type (##car rest))
2782                    (rest (##cdr rest)))
2783               (if (##pair? rest)
2784                 (let* ((dims (##car rest))
2785                        (rest (##cdr rest)))
2786                   (if (##pair? rest)
2787                     (let* ((init (##car rest))
2788                            (rest (##cdr rest)))
2789                       (cond ((and (##null? rest)
2790                                   (##infix-id identifier))
2791                              =>
2792                              (lambda (id)
2793                                `(,id
2794                                  ,(if (##null? dims)
2795                                     init
2796                                     `(six.make-array ,init ,@dims)))))
2797                             (else
2798                              #f)))
2799                     #f))
2800                 #f))
2801             #f))
2802         #f))
2803     #f))
2804
2805 (define-prim (six.make-array init . dims)
2806   (if (##pair? dims)
2807
2808     (let loop1 ((lst dims) (i 2))
2809       (let ((dim1 (##car lst)))
2810         (macro-check-index dim1 i (six.make-array init . dims)
2811           (let* ((array (##make-vector dim1 init))
2812                  (rest (##cdr lst)))
2813             (if (##pair? rest)
2814               (let loop2 ((j (##fixnum.- dim1 1)))
2815                 (if (##fixnum.< j 0)
2816                   array
2817                   (begin
2818                     (##vector-set! array j (loop1 rest (##fixnum.+ i 1)))
2819                     (loop2 (##fixnum.- j 1)))))
2820               array)))))
2821
2822     init))
2823
2824 (define-runtime-macro (six.define-procedure identifier proc)
2825   `(define ,(##infix-id identifier) ,proc))
2826
2827 (define-runtime-macro (six.procedure type params stat)
2828   `(lambda ,(##map (lambda (x) (##infix-id (##car x))) params)
2829      ,stat))
2830
2831 ;; There is no predefined semantics for the following infix forms:
2832 ;;
2833 ;; (define-runtime-macro (six.label identifier stat)
2834 ;;   `(void))
2835 ;;
2836 ;; (define-runtime-macro (six.goto expr)
2837 ;;   `(void))
2838 ;;
2839 ;; (define-runtime-macro (six.switch expr stat)
2840 ;;   `(void))
2841 ;;
2842 ;; (define-runtime-macro (six.case expr stat)
2843 ;;   `(void))
2844 ;;
2845 ;; (define-runtime-macro (six.break)
2846 ;;   `(void))
2847 ;;
2848 ;; (define-runtime-macro (six.continue)
2849 ;;   `(void))
2850 ;;
2851 ;; (define-runtime-macro (six.return . expr)
2852 ;;   `(void))
2853 ;;
2854 ;; (define-runtime-macro (six.clause expr)
2855 ;;   `(void))
2856 ;;
2857 ;; (define-runtime-macro (six.x:-y x y)
2858 ;;   `(void))
2859 ;;
2860 ;; (define-runtime-macro (six.!)
2861 ;;   `(void))
2862
2863 ;;;----------------------------------------------------------------------------
2864
2865 ;;; Object encoding/decoding.
2866
2867 (define-prim (##object->encoding obj)
2868   (let* ((hi (##type-cast obj (macro-type-fixnum)))
2869          (lo (##type obj)))
2870     (##+ (##* (if (##fixnum.< hi 0) (##- hi ##bignum.2*min-fixnum) hi)
2871               4)
2872          lo)))
2873
2874 (define-prim (##encoding->object encoding)
2875   (let* ((hi (##quotient encoding 4))
2876          (lo (##modulo encoding 4))
2877          (x (if (##fixnum? hi) hi (##+ hi ##bignum.2*min-fixnum))))
2878     (##type-cast x lo)))
2879
2880 ;;;============================================================================