gsc/_source.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_source.scm"
   4
   5 ;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
   6
   7 (include "fixnum.scm")
   8
   9 (include-adt "_envadt.scm")
  10 (include-adt "_gvmadt.scm")
  11 (include-adt "_ptreeadt.scm")
  12 (include     "_sourceadt.scm")
  13
  14 '(##include "_hostadt.scm");*******************brad
  15
  16 ;;;----------------------------------------------------------------------------
  17 ;;
  18 ;; Source code manipulation module:
  19 ;; -------------------------------
  20
  21 ;; This module contains procedures to manipulate source code
  22 ;; representations read in from Scheme source files.
  23
  24 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  25
  26 ;; A readenv structure maintains the "read environment" throughout the
  27 ;; reading of a Scheme datum.  It includes the port from which to read,
  28 ;; the readtable, the wrap and unwrap procedures, and the position
  29 ;; where the currently being read datum started.
  30
  31 (define (**make-readenv port readtable error-proc wrapper unwrapper)
  32   (vector port readtable error-proc wrapper unwrapper 0 0 0 0))
  33
  34 (define (**readenv-port re)              (vector-ref re 0))
  35 (define (**readenv-readtable re)         (vector-ref re 1))
  36 (define (**readenv-error-proc re)        (vector-ref re 2))
  37 (define (**readenv-wrap re x)            ((vector-ref re 3) re x))
  38 (define (**readenv-unwrap re x)          ((vector-ref re 4) re x))
  39 (define (**readenv-filepos re)           (vector-ref re 5))
  40 (define (**readenv-filepos-set! re pos)  (vector-set! re 5 pos))
  41 (define (**readenv-line-count re)        (vector-ref re 6))
  42 (define (**readenv-line-count-set! re x) (vector-set! re 6 x))
  43 (define (**readenv-char-count re)        (vector-ref re 7))
  44 (define (**readenv-char-count-set! re x) (vector-set! re 7 x))
  45 (define (**readenv-line-start re)        (vector-ref re 8))
  46 (define (**readenv-line-start-set! re x) (vector-set! re 8 x))
  47
  48 (define (**readenv-current-filepos re)
  49   (let* ((line
  50           (**readenv-line-count re))
  51          (char-count
  52           (**readenv-char-count re))
  53          (char
  54           (- char-count
  55              (**readenv-line-start re))))
  56     (**make-filepos line char char-count)))
  57
  58 (define (**readenv-previous-filepos re offset)
  59   (let* ((line
  60           (**readenv-line-count re))
  61          (char-count
  62           (- (**readenv-char-count re) offset))
  63          (char
  64           (- char-count
  65              (**readenv-line-start re))))
  66     (**make-filepos line char char-count)))
  67
  68 (define (**peek-next-char-or-eof re) ; possibly returns end-of-file
  69   (peek-char (**readenv-port re)))
  70
  71 (define (**read-next-char-or-eof re) ; possibly returns end-of-file
  72   (let ((c (read-char (**readenv-port re))))
  73     (if (char? c)
  74       (let ((char-count (+ (**readenv-char-count re) 1)))
  75         (**readenv-char-count-set! re char-count)
  76         (if (char=? c #\newline)
  77           (begin
  78             (**readenv-line-start-set! re char-count)
  79             (**readenv-line-count-set! re
  80               (+ (**readenv-line-count re) 1))))))
  81     c))
  82
  83 (define (**make-filepos line char char-count)
  84   (if (and (< line (max-lines))
  85            (not (< (max-fixnum32-div-max-lines) char)))
  86     (+ line (* char (max-lines)))
  87     (- char-count)))
  88
  89 (define (**filepos-line filepos)
  90   (if (< filepos 0)
  91     0
  92     (modulo filepos (max-lines))))
  93
  94 (define (**filepos-col filepos)
  95   (if (< filepos 0)
  96     (- filepos)
  97     (quotient filepos (max-lines))))
  98
  99 (define (**readenv-open filename)
 100
 101   (define (error-proc re msg . args)
 102     (apply compiler-user-error
 103            (cons (re->locat re filename)
 104                  (cons msg
 105                        args))))
 106
 107   (define (wrapper re x)
 108     (make-source x (re->locat re filename)))
 109
 110   (define (unwrapper re x)
 111     (source-code x))
 112
 113   (let ((port (open-input-file filename)))
 114     (**make-readenv port
 115                     **main-readtable
 116                     error-proc
 117                     wrapper
 118                     unwrapper)))
 119
 120 (define (**readenv-close re)
 121   (close-input-port (**readenv-port re)))
 122
 123 (define (false-obj)
 124   false-object)
 125
 126 (define (**append-strings lst)
 127   (let loop1 ((n 0) (x lst) (y '()))
 128     (if (pair? x)
 129       (let ((s (car x)))
 130         (loop1 (+ n (string-length s)) (cdr x) (cons s y)))
 131       (let ((result (make-string n #\space)))
 132         (let loop2 ((k (- n 1)) (y y))
 133           (if (pair? y)
 134             (let ((s (car y)))
 135               (let loop3 ((i k) (j (- (string-length s) 1)))
 136                 (if (not (< j 0))
 137                   (begin
 138                     (string-set! result i (string-ref s j))
 139                     (loop3 (- i 1) (- j 1)))
 140                   (loop2 i (cdr y)))))
 141             result))))))
 142
 143 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 144 ;;
 145 ;; Symbol "canonicalization".
 146
 147 (define (string->canonical-symbol str)
 148   (let ((new-str (string-append str "")))
 149     (if **main-readtable
 150       (**readtable-string-convert-case! **main-readtable new-str))
 151     (string->symbol new-str)))
 152
 153 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 154 ;;
 155 ;; 'location' manipulation
 156
 157 (define (re->locat re filename)
 158   (vector filename (**readenv-filepos re)))
 159
 160 (define (expr->locat expr source)
 161   (vector source expr))
 162
 163 (define (locat-show prefix loc)
 164   (if loc
 165
 166       (let ((filename (##container->path (##locat-container loc)))
 167             (filepos (##locat-position loc)))
 168         (if (string? filename) ; file?
 169             (let ((str (format-filepos filename filepos #t)))
 170               (if str
 171                   (begin
 172                     (display prefix)
 173                     (display str))
 174                   (let ((line (+ (**filepos-line filepos) 1))
 175                         (col (+ (**filepos-col filepos) 1))
 176                         (filename*
 177                          (if (string? filename)
 178                              (path-expand filename)
 179                              filename)))
 180                     (display prefix)
 181                     (write filename*)
 182                     (display "@")
 183                     (display line)
 184                     (display ".")
 185                     (display col))))
 186             (let ((source (vector-ref loc 0))
 187                   (expr (vector-ref loc 1)))
 188               (display prefix)
 189               (display "EXPRESSION ")
 190               (write expr)
 191               (if source
 192                   (locat-show " " (source-locat source))))))
 193
 194     (display "UNKNOWN LOCATION")))
 195
 196 (define (locat-filename-and-line loc)
 197   (if loc
 198       (let* ((container (##locat-container loc))
 199              (path (##container->path container)))
 200         (if path
 201             (let* ((position (##locat-position loc))
 202                    (filepos (##position->filepos position))
 203                    (line (+ (**filepos-line filepos) 1)))
 204               (cons path line))
 205             (cons "" 1)))
 206       (cons "" 1)))
 207
 208 (define (locat-filename loc)
 209   (car (locat-filename-and-line loc)))
 210
 211 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 212 ;;
 213 ;; 'source' manipulation
 214
 215 ;; (expression->source expr source) returns the source that represent
 216 ;; the Scheme expression 'expr' and is related to the source 'source'
 217 ;; (#f if no relation).
 218
 219 (define (expression->source expr source)
 220
 221   (define (expr->source x)
 222     (make-source (cond ((pair? x)
 223                         (list-convert x))
 224                        ((box-object? x)
 225                         (box-object (expr->source (unbox-object x))))
 226                        ((vector-object? x)
 227                         (vector-convert x))
 228                        (else
 229                         x))
 230                  (expr->locat x source)))
 231
 232   (define (list-convert l)
 233     (cons (expr->source (car l))
 234           (list-tail-convert (cdr l))))
 235
 236   (define (list-tail-convert l)
 237     (cond ((pair? l)
 238            (if (quoting-form? l) ; so that macros which generate quoting-forms
 239              (expr->source l)    ; at the tail of a list work properly
 240              (cons (expr->source (car l))
 241                    (list-tail-convert (cdr l)))))
 242           ((null? l)
 243            '())
 244           (else
 245            (expr->source l))))
 246
 247   (define (quoting-form? x)
 248     (let ((first (car x))
 249           (rest (cdr x)))
 250       (and (pair? rest)
 251            (null? (cdr rest))
 252            (or (eq? first quote-sym)
 253                (eq? first quasiquote-sym)
 254                (eq? first unquote-sym)
 255                (eq? first unquote-splicing-sym)))))
 256
 257   (define (vector-convert v)
 258     (let* ((len (vector-length v))
 259            (x (make-vector len)))
 260       (let loop ((i (- len 1)))
 261         (if (>= i 0)
 262           (begin
 263             (vector-set! x i (expr->source (vector-ref v i)))
 264             (loop (- i 1)))))
 265       x))
 266
 267   (expr->source expr))
 268
 269 ;; (source->expression source) returns the Scheme expression represented by the
 270 ;; source 'source'.  Note that every call with the same argument returns a
 271 ;; different (i.e. non eq?) expression.
 272
 273 (define (source->expression source)
 274
 275   (define (list->expression l)
 276     (cond ((pair? l)
 277            (cons (source->expression (car l)) (list->expression (cdr l))))
 278           ((null? l)
 279            '())
 280           (else
 281            (source->expression l))))
 282
 283   (define (vector->expression v)
 284     (let* ((len (vector-length v))
 285            (x (make-vector len)))
 286       (let loop ((i (- len 1)))
 287         (if (>= i 0)
 288           (begin
 289             (vector-set! x i (source->expression (vector-ref v i)))
 290             (loop (- i 1)))))
 291       x))
 292
 293   (let ((code (source-code source)))
 294     (cond ((pair? code)
 295            (list->expression code))
 296           ((box-object? code)
 297            (box-object (source->expression (unbox-object code))))
 298           ((vector-object? code)
 299            (vector->expression code))
 300           (else
 301            code))))
 302
 303 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 304
 305 ;; (include-expr->source source info-port) returns a list of the
 306 ;; source representation for each of the expressions contained in the
 307 ;; specified file.
 308
 309 (define (include-expr->sourcezzzzz source info-port)
 310
 311   (define (find-source-file filename)
 312
 313     (define (open-error filename)
 314       (pt-syntax-error
 315        source
 316        "Can't find file"
 317        (or (path-expand filename)
 318            filename)))
 319
 320     (let ((expanded-filename (path-expand filename)))
 321       (if expanded-filename
 322         (if (equal? (path-extension expanded-filename) "")
 323
 324           (let loop ((exts (append (map car scheme-file-extensions) '(""))))
 325             (if (pair? exts)
 326               (let* ((ext (car exts))
 327                      (full-name (string-append expanded-filename ext))
 328                      (port (open-input-file* full-name)))
 329                 (if port
 330                   (begin
 331                     (close-input-port port)
 332                     full-name)
 333                   (loop (cdr exts))))
 334               (open-error filename)))
 335
 336           (let ((port (open-input-file* expanded-filename)))
 337             (if port
 338               (begin
 339                 (close-input-port port)
 340                 expanded-filename)
 341               (open-error filename))))
 342
 343         (open-error filename))))
 344
 345   (let* ((filename-src
 346           (cadr (source-code source)))
 347          (filename
 348           (source-code filename-src))
 349          (rerooted-filename
 350           (path-expand
 351            filename
 352            (path-directory (path-expand (locat-filename (source-locat filename-src))))))
 353          (final-filename
 354           (find-source-file rerooted-filename))
 355          (re
 356           (**readenv-open final-filename)))
 357
 358     (define (read-sources) ; return list of all sources in file
 359 ';;;;;;;;;;;;;;;;;;;;;;;;;;;
 360       (let ((source ((or read-datum-or-eof **read-datum-or-eof) re)))
 361         (if (vector-object? source)
 362           (begin
 363             (if info-port (display "." info-port))
 364             (cons source (read-sources)))
 365           '()))
 366       (##vector-ref
 367        (##read-all-as-a-begin-expr-from-port
 368         (**readenv-port re)
 369         (##current-readtable)
 370         (lambda (re x)
 371           (make-source x
 372                        (##make-locat (##port-name (macro-readenv-port re))
 373                                      (macro-readenv-filepos re))))
 374         (lambda (re x)
 375           (source-code x))
 376         #f
 377         #f)
 378        1));;;;;;;;;;;;;;;;;;;;;;;
 379
 380     (if info-port
 381       (begin
 382         (display "(reading " info-port)
 383         (write (path-expand final-filename) info-port)))
 384
 385     (let ((sources (read-sources)))
 386
 387       (if info-port (display ")" info-port))
 388
 389       (**readenv-close re)
 390
 391       sources)))
 392
 393 (define (read-source path relative-to-path try-scheme-file-extensions?)
 394
 395   (define (read-source-from-path path)
 396     (let ((container (##path->container path)))
 397       (##read-all-as-a-begin-expr-from-path
 398        path
 399        (##current-readtable);;;;;;;;;;;;;;;;;;;;
 400        (lambda (re x)
 401          (let ((locat
 402                 (##make-locat container
 403                               (##filepos->position
 404                                (macro-readenv-filepos re)))))
 405            (make-source x locat)))
 406        (lambda (re x)
 407          (source-code x)))))
 408
 409   (define (read-source-no-extension)
 410     (let loop ((lst ##scheme-file-extensions))
 411       (if (pair? lst)
 412         (let ((x (read-source-from-path (string-append path (caar lst)))))
 413           (if (##fixnum? x)
 414             (loop (cdr lst))
 415             x))
 416         #f)))
 417
 418   (or (and try-scheme-file-extensions?
 419            (string=? (path-extension path) "")
 420            (read-source-no-extension))
 421       (let* ((abs-path (##path-reference path relative-to-path))
 422              (x (read-source-from-path abs-path)))
 423         (if (##fixnum? x)
 424           (compiler-error "Can't find file" abs-path)
 425           x))))
 426
 427 (define (include-expr->source source info-port)
 428   (let* ((filename-src
 429           (cadr (source-code source)))
 430          (filename
 431           (source-code filename-src))
 432          (x
 433           (read-source filename
 434                        (locat-filename (source-locat filename-src))
 435                        #f)))
 436     (##vector-ref x 1)));;;;;;;;;;;;;;;;;;;;;;;;
 437
 438 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 439
 440 ;; Tables for reader.
 441
 442 (define **standard-escaped-char-table
 443   (list
 444     (cons #\\ #\\)
 445     (cons #\a (unicode->character 7))
 446     (cons #\b (unicode->character 8))
 447     (cons #\t (unicode->character 9))
 448     (cons #\n #\newline)
 449     (cons #\v (unicode->character 11))
 450     (cons #\f (unicode->character 12))
 451     (cons #\r (unicode->character 13))))
 452
 453 (define **standard-named-char-table
 454   (list
 455     (cons "newline"   #\newline)
 456     (cons "space"     #\ )
 457     (cons "nul"       (unicode->character 0))
 458     (cons "bel"       (unicode->character 7))
 459     (cons "backspace" (unicode->character 8))
 460     (cons "tab"       (unicode->character 9))
 461     (cons "linefeed"  (unicode->character 10))
 462     (cons "vt"        (unicode->character 11))
 463     (cons "page"      (unicode->character 12))
 464     (cons "return"    (unicode->character 13))
 465     (cons "rubout"    (unicode->character 127))))
 466
 467 (define **standard-sharp-bang-table
 468   (list
 469     (cons "optional" optional-object)
 470     (cons "rest"     rest-object)
 471     (cons "key"      key-object)
 472     (cons "eof"      end-of-file-object)))
 473
 474 (set! **standard-sharp-bang-table;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 475       (append (list (cons "void"     (##type-cast -5 2))
 476                     (cons "unbound1" (##type-cast -7 2))
 477                     (cons "unbound2" (##type-cast -8 2)))
 478                 **standard-sharp-bang-table))
 479
 480 ;;;============================================================================
 481
 482 ;; The reader.
 483
 484 ;; For compatibility between the interpreter and compiler, this section
 485 ;; must be the same as the corresponding section in the file
 486 ;; "lib/_io.scm" (except that ## and ** are exchanged).
 487
 488 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 489
 490 ;; A chartable structure is a vector-like data structure which is
 491 ;; indexed using a character.
 492
 493 (define (**make-chartable default)
 494   (vector (make-vector 128 default) default '()))
 495
 496 (define (**chartable-ref ct c)
 497   (let ((i (character->unicode c)))
 498     (if (< i 128)
 499       (vector-ref (vector-ref ct 0) i)
 500       (let ((x (assq i (vector-ref ct 2))))
 501         (if x
 502           (cdr x)
 503           (vector-ref ct 1))))))
 504
 505 (define (**chartable-set! ct c val)
 506   (let ((i (character->unicode c)))
 507     (if (< i 128)
 508       (vector-set! (vector-ref ct 0) i val)
 509       (let ((x (assq i (vector-ref ct 2))))
 510         (if x
 511           (set-cdr! x val)
 512           (vector-set! ct 2 (cons (cons i val) (vector-ref ct 2))))))))
 513
 514 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 515
 516 ;; A readtable structure contains parsing information for the reader.
 517 ;; It indicates what action must be taken when a given character is
 518 ;; encountered.
 519
 520 (define **readtable-tag '#(readtable 0))
 521
 522 (define (**make-readtable
 523          case-conversion?
 524          keywords-allowed?
 525          escaped-char-table
 526          named-char-table
 527          sharp-bang-table
 528          char-delimiter?-table
 529          char-handler-table)
 530 ;;  (**subtype-set!
 531     (vector
 532      **readtable-tag
 533      case-conversion?
 534      keywords-allowed?
 535      escaped-char-table
 536      named-char-table
 537      sharp-bang-table
 538      char-delimiter?-table
 539      char-handler-table)
 540 ;;    (subtype-structure))
 541 )
 542
 543 (define (**readtable-case-conversion? rt)
 544   (vector-ref rt 1))
 545
 546 (define (**readtable-case-conversion?-set! rt x)
 547   (vector-set! rt 1 x))
 548
 549 (define (**readtable-keywords-allowed? rt)
 550   (vector-ref rt 2))
 551
 552 (define (**readtable-keywords-allowed?-set! rt x)
 553   (vector-set! rt 2 x))
 554
 555 (define (**readtable-escaped-char-table rt)
 556   (vector-ref rt 3))
 557
 558 (define (**readtable-escaped-char-table-set! rt x)
 559   (vector-set! rt 3 x))
 560
 561 (define (**readtable-named-char-table rt)
 562   (vector-ref rt 4))
 563
 564 (define (**readtable-named-char-table-set! rt x)
 565   (vector-set! rt 4 x))
 566
 567 (define (**readtable-sharp-bang-table rt)
 568   (vector-ref rt 5))
 569
 570 (define (**readtable-sharp-bang-table-set! rt x)
 571   (vector-set! rt 5 x))
 572
 573 (define (**readtable-char-delimiter?-table rt)
 574   (vector-ref rt 6))
 575
 576 (define (**readtable-char-delimiter?-table-set! rt x)
 577   (vector-set! rt 6 x))
 578
 579 (define (**readtable-char-handler-table rt)
 580   (vector-ref rt 7))
 581
 582 (define (**readtable-char-handler-table-set! rt x)
 583   (vector-set! rt 7 x))
 584
 585 (define (**readtable-char-delimiter? rt c)
 586   (**chartable-ref (**readtable-char-delimiter?-table rt) c))
 587
 588 (define (**readtable-char-delimiter?-set! rt c delimiter?)
 589   (**chartable-set! (**readtable-char-delimiter?-table rt) c delimiter?))
 590
 591 (define (**readtable-char-handler rt c)
 592   (**chartable-ref (**readtable-char-handler-table rt) c))
 593
 594 (define (**readtable-char-handler-set! rt c handler)
 595   (**chartable-set! (**readtable-char-handler-table rt) c handler))
 596
 597 (define (**readtable-char-class-set! rt c delimiter? handler)
 598   (begin
 599     (**readtable-char-delimiter?-set! rt c delimiter?)
 600     (**readtable-char-handler-set! rt c handler)))
 601
 602 (define (**readtable-convert-case rt c)
 603   (let ((case-conversion? (**readtable-case-conversion? rt)))
 604     (if case-conversion?
 605       (if (eq? case-conversion? 'upcase)
 606         (char-upcase c)
 607         (char-downcase c))
 608       c)))
 609
 610 (define (**readtable-string-convert-case! rt s)
 611   (let ((case-conversion? (**readtable-case-conversion? rt)))
 612     (if case-conversion?
 613       (if (eq? case-conversion? 'upcase)
 614         (let loop ((i (- (string-length s) 1)))
 615           (if (not (< i 0))
 616             (begin
 617               (string-set! s i (char-upcase (string-ref s i)))
 618               (loop (- i 1)))))
 619         (let loop ((i (- (string-length s) 1)))
 620           (if (not (< i 0))
 621             (begin
 622               (string-set! s i (char-downcase (string-ref s i)))
 623               (loop (- i 1)))))))))
 624
 625 (define (**readtable-parse-keyword rt s)
 626   (let ((keywords-allowed? (**readtable-keywords-allowed? rt)))
 627     (and keywords-allowed?
 628          (let ((len (string-length s)))
 629            (and (< 1 len)
 630                 (if (eq? keywords-allowed? 'prefix)
 631                     (and (char=? (string-ref s 0) #\:)
 632                          (string->keyword-object
 633                           (substring s 1 len)))
 634                     (and (char=? (string-ref s (- len 1)) #\:)
 635                          (string->keyword-object
 636                           (substring s 0 (- len 1))))))))))
 637
 638 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 639
 640 ;; Error handling.
 641
 642 (define (**read-error-datum-or-eof-expected re)
 643   ((**readenv-error-proc re) re "Datum or EOF expected"))
 644
 645 (define (**read-error-datum-expected re)
 646   ((**readenv-error-proc re) re "Datum expected"))
 647
 648 (define (**read-error-improperly-placed-dot re)
 649   ((**readenv-error-proc re) re "Improperly placed dot"))
 650
 651 (define (**read-error-incomplete-form-eof-reached re)
 652   ((**readenv-error-proc re) re "Incomplete form, EOF reached"))
 653
 654 (define (**read-error-incomplete re)
 655   ((**readenv-error-proc re) re "Incomplete form"))
 656
 657 (define (**read-error-char-name re str)
 658   ((**readenv-error-proc re) re "Invalid '#\\' name:" str))
 659
 660 (define (**read-error-illegal-char re c)
 661   ((**readenv-error-proc re) re "Illegal character:" c))
 662
 663 (define (**read-error-u8 re)
 664   ((**readenv-error-proc re) re "8 bit exact integer expected"))
 665
 666 (define (**read-error-u16 re)
 667   ((**readenv-error-proc re) re "16 bit exact integer expected"))
 668
 669 (define (**read-error-u32 re)
 670   ((**readenv-error-proc re) re "32 bit exact integer expected"))
 671
 672 (define (**read-error-u64 re)
 673   ((**readenv-error-proc re) re "64 bit exact integer expected"))
 674
 675 (define (**read-error-f32/f64 re)
 676   ((**readenv-error-proc re) re "Inexact real expected"))
 677
 678 (define (**read-error-hex re)
 679   ((**readenv-error-proc re) re "Invalid hexadecimal escape"))
 680
 681 (define (**read-error-escaped-char re c)
 682   ((**readenv-error-proc re) re "Invalid escaped character:" c))
 683
 684 (define (**read-error-vector re)
 685   ((**readenv-error-proc re) re "'(' expected"))
 686
 687 (define (**read-error-sharp-token re str)
 688   ((**readenv-error-proc re) re "Invalid token:" str))
 689
 690 (define (**read-error-sharp-bang-name re str)
 691   ((**readenv-error-proc re) re "Invalid '#!' name:" str))
 692
 693 (define (**read-error-char-range re)
 694   ((**readenv-error-proc re) re "Character out of range"))
 695
 696 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 697
 698 ;; Procedures to read single characters.
 699
 700 (define (**peek-next-char re) ; never returns end-of-file
 701   (let ((next (**peek-next-char-or-eof re)))
 702     (if (char? next)
 703       next
 704       (**read-error-incomplete-form-eof-reached re))))
 705
 706 (define (**read-next-char re) ; never returns end-of-file
 707   (let ((c (**read-next-char-or-eof re)))
 708     (if (char? c)
 709       c
 710       (**read-error-incomplete-form-eof-reached re))))
 711
 712 (define (**read-next-char-expecting re c) ; only accepts c as the next char
 713   (let ((x (**read-next-char-or-eof re)))
 714     (if (char? x)
 715       (if (not (char=? x c))
 716         (**read-error-incomplete re))
 717       (**read-error-incomplete-form-eof-reached re))
 718     x))
 719
 720 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 721
 722 ;; Procedures to read datums.
 723
 724 ;; (**read-datum-or-eof re) attempts to read a datum in the read
 725 ;; environment "re", skipping all whitespace and comments in the
 726 ;; process.  The "pos" field of the read environment indicates the
 727 ;; position where the enclosing datum starts (e.g. list or vector).  If
 728 ;; a datum is read it is returned (wrapped if the read environment asks
 729 ;; for it); if the end-of-file is reached the end-of-file object is
 730 ;; returned (never wrapped); otherwise an error is signaled.  The read
 731 ;; environment's "pos" field is only modified if a datum was read, in
 732 ;; which case it is the position where the datum starts.
 733
 734 (define (**read-datum-or-eof re)
 735   (let ((obj (**read-datum-or-none re)))
 736     (if (eq? obj (**none-marker))
 737       (let ((c (**peek-next-char-or-eof re)))
 738         (if (char? c)
 739           (begin
 740             (**readenv-filepos-set! re (**readenv-current-filepos re))
 741             (**read-next-char-or-eof re) ; to make sure reader makes progress
 742             (**read-error-datum-or-eof-expected re))
 743           (begin
 744             (**read-next-char-or-eof re) ; to make sure reader makes progress
 745             c))) ; end-of-file was reached so return end-of-file object
 746       obj)))
 747
 748 ;; (**read-datum re) attempts to read a datum in the read environment
 749 ;; "re", skipping all whitespace and comments in the process.  The
 750 ;; "pos" field of the read environment indicates the position where the
 751 ;; enclosing datum starts (e.g. list or vector).  If a datum is read it
 752 ;; is returned (wrapped if the read environment asks for it); if the
 753 ;; end-of-file is reached or no datum can be read an error is signaled.
 754 ;; The read environment's "pos" field is only modified if a datum was
 755 ;; read, in which case it is the position where the datum starts.
 756
 757 (define (**read-datum re)
 758   (let ((obj (**read-datum-or-none re)))
 759     (if (eq? obj (**none-marker))
 760       (begin
 761         (**readenv-filepos-set! re (**readenv-current-filepos re))
 762         (**read-next-char-or-eof re) ; to make sure reader makes progress
 763         (**read-error-datum-expected re))
 764       obj)))
 765
 766 ;; (**read-datum-or-none re) attempts to read a datum in the read
 767 ;; environment "re", skipping all whitespace and comments in the
 768 ;; process.  The "pos" field of the read environment indicates the
 769 ;; position where the enclosing datum starts (e.g. list or vector).  If
 770 ;; a datum is read it is returned (wrapped if the read environment asks
 771 ;; for it); if the end-of-file is reached or no datum can be read the
 772 ;; "none-marker" is returned.  The read environment's "pos" field is
 773 ;; only modified if a datum was read, in which case it is the position
 774 ;; where the datum starts.
 775
 776 (define (**read-datum-or-none re)
 777   (let ((obj (**read-datum-or-none-or-dot re)))
 778     (if (eq? obj (**dot-marker))
 779       (begin
 780         (**readenv-filepos-set! re (**readenv-previous-filepos re 1))
 781         (**read-error-improperly-placed-dot re))
 782       obj)))
 783
 784 ;; (**read-datum-or-none-or-dot re) attempts to read a datum in the
 785 ;; read environment "re", skipping all whitespace and comments in the
 786 ;; process.  The "pos" field of the read environment indicates the
 787 ;; position where the enclosing datum starts (e.g. list or vector).  If
 788 ;; a datum is read it is returned (wrapped if the read environment asks
 789 ;; for it); if a lone dot is read the "dot-marker" is returned; if the
 790 ;; end-of-file is reached or no datum can be read the "none-marker" is
 791 ;; returned.  The read environment's "pos" field is only modified if a
 792 ;; datum was read, in which case it is the position where the datum
 793 ;; starts.
 794
 795 (define (**read-datum-or-none-or-dot re)
 796   (let ((next (**peek-next-char-or-eof re)))
 797     (if (char? next)
 798       ((**readtable-char-handler (**readenv-readtable re) next) re next)
 799       (**none-marker))))
 800
 801 ;; Special objects returned by **read-datum-or-none-or-dot.
 802
 803 (define (**none-marker) '#(none)) ; indicates no following datum
 804 (define (**dot-marker) '#(dot))   ; indicates an isolated dot
 805
 806 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 807
 808 ;; Procedure to read a list of datums (possibly an improper list).
 809
 810 (define (**build-list re allow-improper? start-pos close)
 811   (let ((obj (**read-datum-or-none re)))
 812     (if (eq? obj (**none-marker))
 813       (begin
 814         (**read-next-char-expecting re close)
 815         '())
 816       (let ((lst (cons obj '())))
 817         (**readenv-filepos-set! re start-pos) ; restore pos
 818         (let loop ((end lst))
 819           (let ((obj
 820                  (if allow-improper?
 821                    (**read-datum-or-none-or-dot re)
 822                    (**read-datum-or-none re))))
 823             (cond ((eq? obj (**none-marker))
 824                    (**read-next-char-expecting re close)
 825                    lst)
 826                   ((eq? obj (**dot-marker))
 827                    (let ((obj (**read-datum re)))
 828                      (set-cdr! end obj)
 829                      (**readenv-filepos-set! re start-pos) ; restore pos
 830                      (let ((x (**read-datum-or-none re))) ; skip whitespace!
 831                        (if (eq? x (**none-marker))
 832                          (begin
 833                            (**read-next-char-expecting re close)
 834                            lst)
 835                          (begin
 836                            (**readenv-filepos-set! re start-pos) ; restore pos
 837                            (**read-error-incomplete re))))))
 838                   (else
 839                    (**readenv-filepos-set! re start-pos) ; restore pos
 840                    (let ((tail (cons obj '())))
 841                      (set-cdr! end tail)
 842                      (loop tail))))))))))
 843
 844 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 845
 846 ;; Procedure to read a vector or byte vector.
 847
 848 (define (**build-vector re kind start-pos close)
 849
 850   (define (exact-integer-check n lo hi)
 851     (and (integer? n)
 852          (exact? n)
 853          (in-integer-range? n lo hi)))
 854
 855   (define (inexact-real-check n)
 856     (and (real? n)
 857          (not (exact? n))))
 858
 859   (let loop ((i 0))
 860     (let* ((x (**read-datum-or-none re))
 861            (x-pos (**readenv-filepos re)))
 862       (**readenv-filepos-set! re start-pos) ; restore pos
 863       (if (eq? x (**none-marker))
 864         (begin
 865           (**read-next-char-expecting re close)
 866           (case kind
 867             ((vector)    (make-vector i #f))
 868             ((u8vector)  (make-u8vect i))
 869             ((u16vector) (make-u16vect i))
 870             ((u32vector) (make-u32vect i))
 871             ((u64vector) (make-u64vect i))
 872             ((f32vector) (make-f32vect i))
 873             ((f64vector) (make-f64vect i))))
 874         (let ((vect (loop (+ i 1))))
 875           (case kind
 876             ((vector)
 877              (vector-set! vect i x))
 878             ((u8vector)
 879              (let ((ux (**readenv-unwrap re x)))
 880                (if (not (exact-integer-check ux 0 255))
 881                  (begin
 882                    (**readenv-filepos-set! re x-pos) ; restore pos of element
 883                    (**read-error-u8 re)))
 884                (u8vect-set! vect i ux)))
 885             ((u16vector)
 886              (let ((ux (**readenv-unwrap re x)))
 887                (if (not (exact-integer-check ux 0 65535))
 888                  (begin
 889                    (**readenv-filepos-set! re x-pos) ; restore pos of element
 890                    (**read-error-u16 re)))
 891                (u16vect-set! vect i ux)))
 892             ((u32vector)
 893              (let ((ux (**readenv-unwrap re x)))
 894                (if (not (exact-integer-check ux 0 4294967295))
 895                  (begin
 896                    (**readenv-filepos-set! re x-pos) ; restore pos of element
 897                    (**read-error-u32 re)))
 898                (u32vect-set! vect i ux)))
 899             ((u64vector)
 900              (let ((ux (**readenv-unwrap re x)))
 901                (if (not (exact-integer-check ux 0 18446744073709551615))
 902                  (begin
 903                    (**readenv-filepos-set! re x-pos) ; restore pos of element
 904                    (**read-error-u64 re)))
 905                (u64vect-set! vect i ux)))
 906             ((f32vector)
 907              (let ((ux (**readenv-unwrap re x)))
 908                (if (not (inexact-real-check ux))
 909                  (begin
 910                    (**readenv-filepos-set! re x-pos) ; restore pos of element
 911                    (**read-error-f32/f64 re)))
 912                (f32vect-set! vect i ux)))
 913             ((f64vector)
 914              (let ((ux (**readenv-unwrap re x)))
 915                (if (not (inexact-real-check ux))
 916                  (begin
 917                    (**readenv-filepos-set! re x-pos) ; restore pos of element
 918                    (**read-error-f32/f64 re)))
 919                (f64vect-set! vect i ux))))
 920           vect)))))
 921
 922 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 923
 924 ;; Procedures to read delimited tokens.
 925
 926 (define (**build-delimited-string re c i)
 927   (let loop ((i i))
 928     (let ((next (**peek-next-char-or-eof re)))
 929       (if (or (not (char? next))
 930               (**readtable-char-delimiter? (**readenv-readtable re) next))
 931         (make-string i c)
 932         (begin
 933           (**read-next-char-or-eof re) ; skip "next"
 934           (let ((s (loop (+ i 1))))
 935             (string-set! s i next)
 936             s))))))
 937
 938 (define (**build-delimited-number/keyword/symbol re c)
 939   (let ((s (**build-delimited-string re c 1)))
 940     (or (string->number s 10)
 941         (begin
 942           (**readtable-string-convert-case! (**readenv-readtable re) s)
 943           (or (**readtable-parse-keyword (**readenv-readtable re) s)
 944               (string->symbol s))))))
 945
 946 (define (**build-delimited-symbol re c i)
 947   (let ((s (**build-delimited-string re c i)))
 948     (**readtable-string-convert-case! (**readenv-readtable re) s)
 949     (string->symbol s)))
 950
 951 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 952
 953 (define (**build-escaped-string-up-to re close)
 954
 955   (define (char-octal? c)
 956     (and (not (char<? c #\0)) (not (char<? #\7 c))))
 957
 958   (define (char-hexadecimal? c)
 959     (or (and (not (char<? c #\0)) (not (char<? #\9 c)))
 960         (and (not (char<? c #\a)) (not (char<? #\f c)))
 961         (and (not (char<? c #\A)) (not (char<? #\F c)))))
 962
 963   (define (unicode n)
 964     (if (in-char-range? n)
 965       (unicode->character n)
 966       (**read-error-char-range re)))
 967
 968   (define (read-escape-octal c)
 969     (let ((str (let loop ((i 1))
 970                  (let ((next (**peek-next-char-or-eof re)))
 971                    (if (and (< i 3)
 972                             (char? next)
 973                             (char-octal? next))
 974                      (begin
 975                        (**read-next-char-or-eof re) ; skip "next"
 976                        (let ((s (loop (+ i 1))))
 977                          (string-set! s i next)
 978                          s))
 979                      (make-string i #\space))))))
 980       (string-set! str 0 c)
 981       (unicode (string->number str 8))))
 982
 983   (define (read-escape-hexadecimal)
 984     (let ((next (**peek-next-char-or-eof re)))
 985       (if (and (char? next)
 986                (char-hexadecimal? next))
 987         (begin
 988           (**read-next-char-or-eof re) ; skip "next"
 989           (let ((str (let loop ((i 1))
 990                        (let ((next2 (**peek-next-char-or-eof re)))
 991                          (if (and (char? next2)
 992                                   (char-hexadecimal? next2))
 993                            (begin
 994                              (**read-next-char-or-eof re) ; skip "next2"
 995                              (let ((s (loop (+ i 1))))
 996                                (string-set! s i next2)
 997                                s))
 998                            (make-string i #\space))))))
 999             (string-set! str 0 next)
1000             (unicode (string->number str 16))))
1001         (**read-error-hex re))))
1002
1003   (define (read-escape)
1004     (let ((next (**read-next-char re)))
1005       (cond ((char-octal? next)
1006              (read-escape-octal next))
1007             ((char=? next #\x)
1008              (read-escape-hexadecimal))
1009             ((char=? next close)
1010              close)
1011             (else
1012              (let ((x (assq next
1013                             (**readtable-escaped-char-table
1014                              (**readenv-readtable re)))))
1015                (if x
1016                  (cdr x)
1017                  (**read-error-escaped-char re next)))))))
1018
1019   (define max-chunk-length 512)
1020
1021   (define (read-chunk)
1022     (let loop ((i 0))
1023       (if (< i max-chunk-length)
1024         (let ((c (**read-next-char re)))
1025           (cond ((char=? c close)
1026                  (make-string i #\space))
1027                 ((char=? c #\\)
1028                  (let* ((c (read-escape))
1029                         (s (loop (+ i 1))))
1030                    (string-set! s i c)
1031                    s))
1032                 (else
1033                  (let ((s (loop (+ i 1))))
1034                    (string-set! s i c)
1035                    s))))
1036         (make-string i #\space))))
1037
1038   (let ((chunk1 (read-chunk)))
1039     (if (< (string-length chunk1) max-chunk-length)
1040       chunk1
1041       (let loop ((chunks (list chunk1)))
1042         (let* ((new-chunk (read-chunk))
1043                (new-chunks (cons new-chunk chunks)))
1044           (if (< (string-length new-chunk) max-chunk-length)
1045             (**append-strings (reverse new-chunks))
1046             (loop new-chunks)))))))
1047
1048 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1049
1050 ;; Procedures to handle comments.
1051
1052 (define (**skip-extended-comment re open1 open2 close1 close2)
1053   (let loop ((level 0) (c (**read-next-char re)))
1054     (cond ((char=? c open1)
1055            (let ((c (**read-next-char re)))
1056              (if (char=? c open2)
1057                (loop (+ level 1) (**read-next-char re))
1058                (loop level c))))
1059           ((char=? c close1)
1060            (let ((c (**read-next-char re)))
1061              (if (char=? c close2)
1062                (if (< 0 level)
1063                  (loop (- level 1) (**read-next-char re))
1064                  #f) ; comment has ended
1065                (loop level c))))
1066           (else
1067            (loop level (**read-next-char re))))))
1068
1069 (define (**skip-single-line-comment re)
1070   (let loop ()
1071     (let ((next (**peek-next-char-or-eof re)))
1072       (if (char? next)
1073         (begin
1074           (**read-next-char-or-eof re) ; skip "next"
1075           (if (not (char=? next #\newline))
1076             (loop)))))))
1077
1078 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1079
1080 ;; Procedure to read datums starting with '#'.
1081
1082 (define (**read-sharp re c)
1083   (let ((start-pos (**readenv-current-filepos re)))
1084     (**read-next-char-or-eof re) ; skip #\#
1085     (let ((next (**peek-next-char re)))
1086       (cond ((char=? next #\()
1087              (**read-next-char-or-eof re) ; skip #\(
1088              (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1089              (let ((vect (**build-vector re 'vector start-pos #\))))
1090                (**readenv-wrap re vect)))
1091             ((char=? next #\\)
1092              (**read-next-char-or-eof re) ; skip #\\
1093              (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1094              (let ((c (**read-next-char re)))
1095                (if (**readtable-char-delimiter?
1096                     (**readenv-readtable re)
1097                     (**peek-next-char-or-eof re))
1098                  (**readenv-wrap re c)
1099                  (let ((name (**build-delimited-string re c 1)))
1100                    (let ((x (**read-assoc-string-ci=?
1101                              name
1102                              (**readtable-named-char-table
1103                               (**readenv-readtable re)))))
1104                      (if x
1105                        (**readenv-wrap re (cdr x))
1106                        (let ((n (string->number name 10)))
1107                          (if (and n
1108                                   (integer? n)
1109                                   (exact? n))
1110                            (if (in-char-range? n)
1111                              (**readenv-wrap re (unicode->character n))
1112                              (**read-error-char-range re))
1113                            (**read-error-char-name re name)))))))))
1114             ((char=? next #\|)
1115              (let ((old-pos (**readenv-filepos re)))
1116                (**readenv-filepos-set! re start-pos) ; in case error in comment
1117                (**read-next-char-or-eof re) ; skip #\|
1118                (**skip-extended-comment re #\# #\| #\| #\#)
1119                (**readenv-filepos-set! re old-pos) ; restore pos
1120                (**read-datum-or-none-or-dot re))) ; read what follows comment
1121             ((char=? next #\!)
1122              (**read-next-char-or-eof re) ; skip #\!
1123              (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1124              (let ((name (**build-delimited-string re #\space 0)))
1125                (let ((x (**read-assoc-string-ci=?
1126                          name
1127                          (**readtable-sharp-bang-table
1128                           (**readenv-readtable re)))))
1129                  (if x
1130                    (**readenv-wrap re (cdr x))
1131                    (**read-error-sharp-bang-name re name)))))
1132             ((char=? next #\#)
1133              (**read-next-char-or-eof re) ; skip #\#
1134              (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1135              (let ((sym (**build-delimited-symbol re #\# 2)))
1136                (**readenv-wrap re sym)))
1137             (else
1138              (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1139              (let* ((s
1140                      (**build-delimited-string re c 1))
1141                     (obj
1142                      (or (string->number s 10)
1143                          (let ()
1144
1145                            (define (build-vect re kind)
1146                              (let ((c (**read-next-char re)))
1147                                (if (char=? c #\()
1148                                  (**build-vector re kind start-pos #\))
1149                                  (**read-error-vector re))))
1150
1151                            (cond ((string-ci=? s "#f")
1152                                   (false-obj))
1153                                  ((string-ci=? s "#t")
1154                                   #t)
1155                                  ((string-ci=? s "#u8")
1156                                   (build-vect re 'u8vector))
1157                                  ((string-ci=? s "#u16")
1158                                   (build-vect re 'u16vector))
1159                                  ((string-ci=? s "#u32")
1160                                   (build-vect re 'u32vector))
1161                                  ((string-ci=? s "#u64")
1162                                   (build-vect re 'u64vector))
1163                                  ((string-ci=? s "#f32")
1164                                   (build-vect re 'f32vector))
1165                                  ((string-ci=? s "#f64")
1166                                   (build-vect re 'f64vector))
1167                                  (else
1168                                   (**read-error-sharp-token re s)))))))
1169                (**readenv-wrap re obj)))))))
1170
1171 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1172
1173 (define (**read-whitespace re c)
1174   (**read-next-char-or-eof re) ; skip whitespace character
1175   (**read-datum-or-none-or-dot re)) ; read what follows whitespace
1176
1177 (define (**read-single-line-comment re c)
1178   (**skip-single-line-comment re) ; skip comment
1179   (**read-datum-or-none-or-dot re)) ; read what follows comment
1180
1181 (define (**read-escaped-string re c)
1182   (let ((start-pos (**readenv-current-filepos re)))
1183     (**read-next-char-or-eof re) ; skip #\"
1184     (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1185     (let ((str (**build-escaped-string-up-to re c)))
1186       (**readenv-wrap re str))))
1187
1188 (define (**read-escaped-symbol re c)
1189   (let ((start-pos (**readenv-current-filepos re)))
1190     (**read-next-char-or-eof re) ; skip #\|
1191     (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1192     (let ((sym (string->symbol (**build-escaped-string-up-to re c))))
1193       (**readenv-wrap re sym))))
1194
1195 (define (**read-quotation re c)
1196   (let ((start-pos (**readenv-current-filepos re)))
1197     (**read-next-char-or-eof re) ; skip #\'
1198     (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1199     (let ((obj (**read-datum re)))
1200       (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1201       (**readenv-wrap
1202        re
1203        (list (**readenv-wrap re 'quote) obj)))))
1204
1205 (define (**read-quasiquotation re c)
1206   (let ((start-pos (**readenv-current-filepos re)))
1207     (**read-next-char-or-eof re) ; skip #\`
1208     (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1209     (let ((obj (**read-datum re)))
1210       (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1211       (**readenv-wrap
1212        re
1213        (list (**readenv-wrap re 'quasiquote) obj)))))
1214
1215 (define (**read-unquotation re c)
1216   (let ((start-pos (**readenv-current-filepos re)))
1217     (**read-next-char-or-eof re) ; skip #\,
1218     (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1219     (let ((next (**peek-next-char re)))
1220       (if (char=? next #\@)
1221         (begin
1222           (**read-next-char-or-eof re) ; skip #\@
1223           (let ((obj (**read-datum re)))
1224             (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1225             (**readenv-wrap
1226              re
1227              (list (**readenv-wrap re 'unquote-splicing) obj))))
1228         (let ((obj (**read-datum re)))
1229           (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1230           (**readenv-wrap
1231            re
1232            (list (**readenv-wrap re 'unquote) obj)))))))
1233
1234 (define (**read-list re c)
1235   (let ((start-pos (**readenv-current-filepos re)))
1236     (**read-next-char-or-eof re) ; skip #\( or #\[ or #\{
1237     (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1238     (let ((close
1239            (cond ((char=? c #\[) #\])
1240                  ((char=? c #\{) #\})
1241                  (else           #\)))))
1242       (let ((lst (**build-list re #t start-pos close)))
1243         (**readenv-wrap re lst)))))
1244
1245 (define (**read-none re c)
1246   (**none-marker))
1247
1248 (define (**read-illegal re c)
1249   (let ((start-pos (**readenv-current-filepos re)))
1250     (**read-next-char-or-eof re) ; skip illegal character
1251     (**readenv-filepos-set! re start-pos) ; set pos to illegal char
1252     (**read-error-illegal-char re c)))
1253
1254 (define (**read-dot re c)
1255   (let ((start-pos (**readenv-current-filepos re)))
1256     (**read-next-char-or-eof re) ; skip #\.
1257     (let ((next (**peek-next-char-or-eof re)))
1258       (if (or (not (char? next))
1259               (**readtable-char-delimiter? (**readenv-readtable re) next))
1260         (**dot-marker)
1261         (begin
1262           (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1263           (let ((obj (**build-delimited-number/keyword/symbol re c)))
1264             (**readenv-wrap re obj)))))))
1265
1266 (define (**read-number/keyword/symbol re c)
1267   (let ((start-pos (**readenv-current-filepos re)))
1268     (**read-next-char-or-eof re) ; skip "c"
1269     (**readenv-filepos-set! re start-pos) ; set pos to start of datum
1270     (let ((obj (**build-delimited-number/keyword/symbol re c)))
1271       (**readenv-wrap re obj))))
1272
1273 (define (**read-assoc-string-ci=? x lst)
1274   (let loop ((lst lst))
1275     (if (pair? lst)
1276       (let ((couple (car lst)))
1277         (let ((y (car couple)))
1278           (if (string-ci=? x y)
1279             couple
1280             (loop (cdr lst)))))
1281       #f)))
1282
1283 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1284
1285 ;; Setup the standard readtable.
1286
1287 (define (**make-standard-readtable)
1288   (let ((rt
1289          (**make-readtable
1290           #f ; preserve case in symbols, character names, etc
1291           #t ; keywords ending with ":" are allowed
1292           **standard-escaped-char-table
1293           **standard-named-char-table
1294           **standard-sharp-bang-table
1295           (**make-chartable #f) ; all chars are non-delimiters
1296           (**make-chartable **read-number/keyword/symbol))))
1297
1298     (if (**comply-to-standard-scheme?) ; force compliance to standard Scheme?
1299       (begin
1300         (**readtable-case-conversion?-set! rt #t)
1301         (**readtable-keywords-allowed?-set! rt #f)))
1302
1303     ; setup control characters
1304
1305     (let loop ((i 31))
1306       (if (not (< i 0))
1307         (begin
1308           (**readtable-char-class-set!
1309            rt
1310            (unicode->character i)
1311            #t
1312            **read-illegal)
1313           (loop (- i 1)))))
1314
1315     ; setup whitespace characters
1316
1317     (**readtable-char-class-set! rt #\space    #t **read-whitespace)
1318     (**readtable-char-class-set! rt #\linefeed #t **read-whitespace)
1319     (**readtable-char-class-set! rt #\return   #t **read-whitespace)
1320     (**readtable-char-class-set! rt #\tab      #t **read-whitespace)
1321     (**readtable-char-class-set! rt #\page     #t **read-whitespace)
1322
1323     ; setup handlers for non-whitespace delimiters
1324
1325     (**readtable-char-class-set! rt #\; #t **read-single-line-comment)
1326
1327     (**readtable-char-class-set! rt #\" #t **read-escaped-string)
1328     (**readtable-char-class-set! rt #\| #t **read-escaped-symbol)
1329
1330     (**readtable-char-class-set! rt #\' #t **read-quotation)
1331     (**readtable-char-class-set! rt #\` #t **read-quasiquotation)
1332     (**readtable-char-class-set! rt #\, #t **read-unquotation)
1333
1334     (**readtable-char-class-set! rt #\( #t **read-list)
1335     (**readtable-char-class-set! rt #\) #t **read-none)
1336
1337     (**readtable-char-class-set! rt #\[ #t **read-list)
1338     (**readtable-char-class-set! rt #\] #t **read-none)
1339
1340     (**readtable-char-class-set! rt #\{ #t **read-illegal)
1341     (**readtable-char-class-set! rt #\} #t **read-illegal)
1342
1343     ; setup handlers for "#" and "." (these are NOT delimiters)
1344
1345     (**readtable-char-class-set! rt #\# #f **read-sharp)
1346     (**readtable-char-class-set! rt #\. #f **read-dot)
1347
1348     rt))
1349
1350 (if (not **main-readtable)
1351   (set! **main-readtable
1352     (**make-standard-readtable)))
1353
1354 ;;;============================================================================
1355
1356 '(;;;;;;;;;;;
1357
1358 (include "fixnum.scm")
1359
1360 (include-adt "_envadt.scm")
1361 (include-adt "_gvmadt.scm")
1362 (include-adt "_ptreeadt.scm")
1363 (include     "_sourceadt.scm")
1364
1365 (define (**filepos-line filepos)
1366   (##filepos-line filepos))
1367
1368 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1369 ;;
1370 ;; Symbol "canonicalization".
1371
1372 (define (string->canonical-symbol str)
1373   (let ((new-str (string-append str "")))
1374     (##readtable-string-convert-case! (current-readtable) new-str)
1375     new-str))
1376
1377 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1378 ;;
1379 ;; 'location' manipulation
1380
1381 (define (expr->locat expr source)
1382   (vector source expr));;;;;;;;;;;;;;;;;;;;;;
1383
1384 (define (locat-show prefix loc)
1385   (if loc
1386
1387     (if (string? (vector-ref loc 0)) ; file?
1388       (let* ((filename (vector-ref loc 0))
1389              (filepos (vector-ref loc 1))
1390              (str (format-filepos filename filepos #t)))
1391         (if str
1392           (begin
1393             (display prefix)
1394             (display str))
1395           (let ((line (+ (**filepos-line filepos) 1))
1396                 (col (+ (**filepos-col filepos) 1))
1397                 (filename*
1398                  (if (string? filename)
1399                    (path-expand filename)
1400                    filename)))
1401             (display prefix)
1402             (write filename*)
1403             (display "@")
1404             (display line)
1405             (display ".")
1406             (display col))))
1407       (let ((source (vector-ref loc 0))
1408             (expr (vector-ref loc 1)))
1409        (display prefix)
1410        (display "EXPRESSION ")
1411        (write expr)
1412        (if source
1413          (locat-show " " (source-locat source)))))
1414
1415     (display "UNKNOWN LOCATION")))
1416
1417 (define (locat-filename-and-line loc)
1418   (if loc
1419     (if (string? (vector-ref loc 0)) ; file?
1420       (let* ((filename (vector-ref loc 0))
1421              (filepos (vector-ref loc 1))
1422              (line (+ (**filepos-line filepos) 1)))
1423         (cons filename line))
1424       (let ((source (vector-ref loc 0))
1425             (expr (vector-ref loc 1)))
1426        (if source
1427          (locat-filename-and-line (source-locat source))
1428          (cons "" 1))))
1429     (cons "" 1)))
1430
1431 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1432 ;;
1433 ;; 'source' manipulation
1434
1435 ;; (expression->source expr source) returns the source that represent
1436 ;; the Scheme expression 'expr' and is related to the source 'source'
1437 ;; (#f if no relation).
1438
1439 (define (expression->source expr source)
1440
1441   (define (expr->source x)
1442     (make-source (cond ((pair? x)
1443                         (list-convert x))
1444                        ((box-object? x)
1445                         (box-object (expr->source (unbox-object x))))
1446                        ((vector-object? x)
1447                         (vector-convert x))
1448                        (else
1449                         x))
1450                  (expr->locat x source)))
1451
1452   (define (list-convert l)
1453     (cons (expr->source (car l))
1454           (list-tail-convert (cdr l))))
1455
1456   (define (list-tail-convert l)
1457     (cond ((pair? l)
1458            (if (quoting-form? l) ; so that macros which generate quoting-forms
1459              (expr->source l)    ; at the tail of a list work properly
1460              (cons (expr->source (car l))
1461                    (list-tail-convert (cdr l)))))
1462           ((null? l)
1463            '())
1464           (else
1465            (expr->source l))))
1466
1467   (define (quoting-form? x)
1468     (let ((first (car x))
1469           (rest (cdr x)))
1470       (and (pair? rest)
1471            (null? (cdr rest))
1472            (or (eq? first quote-sym)
1473                (eq? first quasiquote-sym)
1474                (eq? first unquote-sym)
1475                (eq? first unquote-splicing-sym)))))
1476
1477   (define (vector-convert v)
1478     (let* ((len (vector-length v))
1479            (x (make-vector len)))
1480       (let loop ((i (- len 1)))
1481         (if (>= i 0)
1482           (begin
1483             (vector-set! x i (expr->source (vector-ref v i)))
1484             (loop (- i 1)))))
1485       x))
1486
1487   (expr->source expr))
1488
1489 ;; (source->expression source) returns the Scheme expression
1490 ;; represented by the source 'source'.  Note that every call with the
1491 ;; same argument returns a different (i.e. non eq?) expression.
1492
1493 (define (source->expression source)
1494
1495   (define (list->expression l)
1496     (cond ((pair? l)
1497            (cons (source->expression (car l)) (list->expression (cdr l))))
1498           ((null? l)
1499            '())
1500           (else
1501            (source->expression l))))
1502
1503   (define (vector->expression v)
1504     (let* ((len (vector-length v))
1505            (x (make-vector len)))
1506       (let loop ((i (- len 1)))
1507         (if (>= i 0)
1508           (begin
1509             (vector-set! x i (source->expression (vector-ref v i)))
1510             (loop (- i 1)))))
1511       x))
1512
1513   (let ((code (source-code source)))
1514     (cond ((pair? code)
1515            (list->expression code))
1516           ((box-object? code)
1517            (box-object (source->expression (unbox-object code))))
1518           ((vector-object? code)
1519            (vector->expression code))
1520           (else
1521            code))))
1522
1523 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1524
1525 ;; (include-expr->source source info-port) returns the source
1526 ;; representation of a "begin" form containing the expressions
1527 ;; contained in the specified file.
1528
1529 (define (include-expr->source source info-port)
1530
1531   (define (find-source-file filename)
1532
1533     (define (open-error filename)
1534       (pt-syntax-error
1535        source
1536        "Can't find file"
1537        (or (path-expand filename)
1538            filename)))
1539
1540     (let ((expanded-filename (path-expand filename)))
1541       (if expanded-filename
1542         (if (equal? (path-extension expanded-filename) "")
1543
1544           (let loop ((exts (append (map car scheme-file-extensions) '(""))))
1545             (if (pair? exts)
1546               (let* ((ext (car exts))
1547                      (full-name (string-append expanded-filename ext))
1548                      (port (open-input-file* full-name)))
1549                 (if port
1550                   (begin
1551                     (close-input-port port)
1552                     full-name)
1553                   (loop (cdr exts))))
1554               (open-error filename)))
1555
1556           (let ((port (open-input-file* expanded-filename)))
1557             (if port
1558               (begin
1559                 (close-input-port port)
1560                 expanded-filename)
1561               (open-error filename))))
1562
1563         (open-error filename))))
1564
1565   (let* ((filename-src
1566           (cadr (source-code source)))
1567          (filename
1568           (source-code filename-src))
1569          (rerooted-filename
1570           (path-expand
1571            filename
1572            (path-directory (path-expand (locat-filename (source-locat filename-src))))))
1573          (final-filename
1574           (find-source-file rerooted-filename))
1575          (re
1576           (**readenv-open final-filename)))
1577
1578     (define (read-sources) ; return list of all sources in file
1579 ';;;;;;;;;;;;;;;;;;;;;;;;;;;
1580       (let ((source ((or read-datum-or-eof **read-datum-or-eof) re)))
1581         (if (vector-object? source)
1582           (begin
1583             (if info-port (display "." info-port))
1584             (cons source (read-sources)))
1585           '()))
1586       (##vector-ref
1587        (##read-all-as-a-begin-expr-from-port
1588         (**readenv-port re)
1589         (##current-readtable)
1590         (lambda (re x)
1591           (make-source x (##readenv->locat re)))
1592         (lambda (re x)
1593           (source-code x))
1594         #f
1595         #f)
1596        1));;;;;;;;;;;;;;;;;;;;;;;
1597
1598     (if info-port
1599       (begin
1600         (display "(reading " info-port)
1601         (write (path-expand final-filename) info-port)))
1602
1603     (let ((sources (read-sources)))
1604
1605       (if info-port (display ")" info-port))
1606
1607       (**readenv-close re)
1608
1609       sources)))
1610 )