;==============================================================================
;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

; file: "source.scm"

;------------------------------------------------------------------------------
;
; Source code manipulation package:
; --------------------------------

; This package contains procedures to manipulate source code representations
; read in from Scheme source files.

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; 'source file' manipulation

(define (open-sf filename)

  (define (open-err)
    (compiler-error "Can't find file" filename))

  (if (string=? (file-ext filename) "")

    (let loop ((exts source-exts))
      (if (pair? exts)
        (let* ((full-name (string-append filename (car exts)))
               (port (open-input-file* full-name)))
          (if port
            (vector port full-name 0 1 0)
            (loop (cdr exts))))
        (open-err)))

    (let ((port (open-input-file* filename)))
      (if port
        (vector port filename 0 1 0)
        (open-err)))))

(define (close-sf sf)
  (close-input-port (vector-ref sf 0)))

(define (sf-read-char sf)
  (let ((c (read-char (vector-ref sf 0))))
    (cond ((eof-object? c))
          ((char=? c char-newline)
           (vector-set! sf 3 (+ (vector-ref sf 3) 1))
           (vector-set! sf 4 0))
          (else
           (vector-set! sf 4 (+ (vector-ref sf 4) 1))))
    c))

(define (sf-peek-char sf)
  (peek-char (vector-ref sf 0)))

(define (sf-read-error sf msg . args)
  (apply compiler-user-error
         (cons (sf->locat sf)
               (cons (string-append "Read error -- " msg) args))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; 'location' manipulation

(define (sf->locat sf)
  (vector 'FILE
          (vector-ref sf 1)
          (vector-ref sf 2)
          (vector-ref sf 3)
          (vector-ref sf 4)))

(define (expr->locat expr source)
  (vector 'EXPR
          expr
          source))

(define (locat-show loc)
  (if loc

    (case (vector-ref loc 0)
      ((FILE)
       (if (pinpoint-error
             (vector-ref loc 1)
             (vector-ref loc 3)
             (vector-ref loc 4))
         (begin
           (display " (file \"")
           (display (vector-ref loc 1))
           (display "\", line ")
           (display (vector-ref loc 3))
           (display ", character ")
           (display (vector-ref loc 4))
           (display ")"))))
      ((EXPR)
       (display " (expression ")
       (write (vector-ref loc 1))
       (if (vector-ref loc 2)
         (locat-show (source-locat (vector-ref loc 2))))
       (display ")"))
      (else
       (compiler-internal-error "locat-show, unknown location tag")))

    (display " (unknown location)")))

(define (locat-filename loc)
  (if loc
    (case (vector-ref loc 0)
      ((FILE)
       (vector-ref loc 1))
      ((EXPR)
       (let ((source (vector-ref loc 2)))
         (if source
           (locat-filename (source-locat source))
           "")))
      (else
       (compiler-internal-error "locat-filename, unknown location tag")))
    ""))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;
; 'source' manipulation

(define (make-source code locat)
  (vector code locat))

(define (source-code x)        (vector-ref x 0))
(define (source-code-set! x y) (vector-set! x 0 y) x)
(define (source-locat x)       (vector-ref x 1))

; (expression->source expr source) returns the source that represent the Scheme
; expression 'expr' and is related to the source 'source' (#f if no relation).

(define (expression->source expr source)

  (define (expr->source x)
    (make-source (cond ((pair? x)
                        (list->source x))
                       ((vector? x)
                        (vector->source x))
                       ((symbol-object? x)
                        (string->canonical-symbol (symbol->string x)))
                       (else
                        x))
                 (expr->locat x source)))

  (define (list->source l)
    (cond ((pair? l)
           (cons (expr->source (car l)) (list->source (cdr l))))
          ((null? l)
           '())
          (else
           (expr->source l))))

  (define (vector->source v)
    (let* ((len (vector-length v))
           (x (make-vector len)))
      (let loop ((i (- len 1)))
        (if (>= i 0)
          (begin
            (vector-set! x i (expr->source (vector-ref v i)))
            (loop (- i 1)))))
      x))

  (expr->source expr))

; (source->expression source) returns the Scheme expression represented by the
; source 'source'.  Note that every call with the same argument returns a
; different (i.e. non eq?) expression.

(define (source->expression source)

  (define (list->expression l)
    (cond ((pair? l)
           (cons (source->expression (car l)) (list->expression (cdr l))))
          ((null? l)
           '())
          (else
           (source->expression l))))

  (define (vector->expression v)
    (let* ((len (vector-length v))
           (x (make-vector len)))
      (let loop ((i (- len 1)))
        (if (>= i 0)
          (begin
            (vector-set! x i (source->expression (vector-ref v i)))
            (loop (- i 1)))))
      x))

  (let ((code (source-code source)))
    (cond ((pair? code)   (list->expression code))
          ((vector? code) (vector->expression code))
          (else           code))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; (file->sources filename info-port) returns a list of the source
; representation for each of the expressions contained in the file 'filename'.

(define (file->sources filename info-port)

  (if info-port
    (begin
      (display "(reading \"" info-port) (display filename info-port)
      (display "\"" info-port)))

  (let ((sf (open-sf filename)))

    (define (read-sources) ; return list of all sources in file
      (let ((source (read-source sf)))
        (if (not (eof-object? source))
          (begin
            (if info-port (display "." info-port))
            (cons source (read-sources)))
          '())))

    (let ((sources (read-sources)))

      (if info-port (display ")" info-port))

      (close-sf sf)

      sources)))

(define (file->sources* filename info-port loc)
 (file->sources (if (path-absolute? filename)
                  filename
                  (string-append
                    (file-path (locat-filename loc))
                    filename))
                info-port))

; (read-source sf) returns the source for the next expression in the source
; file 'sf'.

(define (read-source sf)

  (define (read-char*)
    (let ((c (sf-read-char sf)))
      (if (eof-object? c)
        (sf-read-error sf "Premature end of file encountered")
        c)))

  (define (read-non-whitespace-char)
    (let ((c (read-char*)))
      (cond ((< 0 (vector-ref read-table (char->integer c)))
             (read-non-whitespace-char))
            ((char=? c #\;)
             (let loop ()
               (if (not (char=? (read-char*) char-newline))
                 (loop)
                 (read-non-whitespace-char))))
            (else
             c))))

  (define (delimiter? c)
    (or (eof-object? c)
        (not (= (vector-ref read-table (char->integer c)) 0))))

  (define (read-list first)
    (let ((result (cons first '())))
      (let loop ((end result))
        (let ((c (read-non-whitespace-char)))
          (cond ((char=? c #\)))
                ((and (char=? c #\.) (delimiter? (sf-peek-char sf)))
                 (let ((x (read-source sf)))
                   (if (char=? (read-non-whitespace-char) #\))
                     (set-cdr! end x)
                     (sf-read-error sf "')' expected"))))
                (else
                 (let ((tail (cons (rd* c) '())))
                   (set-cdr! end tail)
                   (loop tail))))))
      result))

  (define (read-vector)
    (define (loop i)
      (let ((c (read-non-whitespace-char)))
        (if (char=? c #\))
          (make-vector i '())
          (let* ((x (rd* c))
                 (v (loop (+ i 1))))
            (vector-set! v i x)
            v))))
    (loop 0))

  (define (read-string)
    (define (loop i)
      (let ((c (read-char*)))
        (cond ((char=? c #\")
               (make-string i #\space))
              ((char=? c #\\)
               (let* ((c (read-char*))
                      (s (loop (+ i 1))))
                 (string-set! s i c)
                 s))
              (else
               (let ((s (loop (+ i 1))))
                 (string-set! s i c)
                 s)))))
    (loop 0))

  (define (read-symbol/number-string i)
    (if (delimiter? (sf-peek-char sf))
      (make-string i #\space)
      (let* ((c (sf-read-char sf))
             (s (read-symbol/number-string (+ i 1))))
        (string-set! s i (char-downcase c))
        s)))

  (define (read-symbol/number c)
    (let ((s (read-symbol/number-string 1)))
      (string-set! s 0 (char-downcase c))
      (or (string->number s 10)
          (string->canonical-symbol s))))

  (define (read-prefixed-number c)
    (let ((s (read-symbol/number-string 2)))
      (string-set! s 0 #\#)
      (string-set! s 1 c)
      (string->number s 10)))

  (define (read-special-symbol)
    (let ((s (read-symbol/number-string 2)))
      (string-set! s 0 #\#)
      (string-set! s 1 #\#)
      (string->canonical-symbol s)))

  (define (rd c)
    (cond ((eof-object? c)
           c)
          ((< 0 (vector-ref read-table (char->integer c)))
           (rd (sf-read-char sf)))
          ((char=? c #\;)
           (let loop ()
             (let ((c (sf-read-char sf)))
               (cond ((eof-object? c)
                      c)
                     ((char=? c char-newline)
                      (rd (sf-read-char sf)))
                     (else
                      (loop))))))
          (else
           (rd* c))))

  (define (rd* c)
    (let ((source (make-source #f (sf->locat sf))))
      (source-code-set!
        source
        (cond ((char=? c #\()
               (let ((x (read-non-whitespace-char)))
                 (if (char=? x #\))
                   '()
                   (read-list (rd* x)))))
              ((char=? c #\#)
               (let ((c (char-downcase (sf-read-char sf))))
                 (cond ((char=? c #\() (read-vector))
                       ((char=? c #\f) false-object)
                       ((char=? c #\t) #t)
                       ((char=? c #\\)
                        (let ((c (read-char*)))
                          (if (or (not (char-alphabetic? c))
                                  (delimiter? (sf-peek-char sf)))
                            c
                            (let ((name (read-symbol/number c)))
                              (let ((x (assq name named-char-table)))
                                (if x
                                  (cdr x)
                                  (sf-read-error sf "Unknown character name" name)))))))

                       ((char=? c #\#)
                        (read-special-symbol))
                       (else
                        (let ((num (read-prefixed-number c)))
                          (or num
                              (sf-read-error sf "Unknown '#' read macro" c)))))))
              ((char=? c #\")
               (read-string))
              ((char=? c #\')
               (list (make-source QUOTE-sym (sf->locat sf))
                     (read-source sf)))
              ((char=? c #\`)
               (list (make-source QUASIQUOTE-sym (sf->locat sf))
                     (read-source sf)))
              ((char=? c #\,)
               (if (char=? (sf-peek-char sf) #\@)
                 (let ((x (make-source UNQUOTE-SPLICING-sym (sf->locat sf))))
                   (sf-read-char sf)
                   (list x (read-source sf)))
                 (list (make-source UNQUOTE-sym (sf->locat sf))
                       (read-source sf))))
              ((char=? c #\))
               (sf-read-error sf "Misplaced ')'"))
              (else
               (if (char=? c #\.)
                 (if (delimiter? (sf-peek-char sf))
                   (sf-read-error sf "Misplaced '.'")))
               (read-symbol/number c))))))

  (rd (sf-read-char sf)))

(define named-char-table
  (list (cons (string->canonical-symbol "SPACE")   #\ )
        (cons (string->canonical-symbol "NEWLINE") char-newline)))

(define read-table
  (let ((rt (make-vector (+ max-character-encoding 1) 0)))

    ; setup whitespace chars

    (vector-set! rt (char->integer #\ ) 1)
    (vector-set! rt (char->integer char-tab) 1)
    (vector-set! rt (char->integer char-newline) 1)

    ; setup other delimiters

    (vector-set! rt (char->integer #\;) -1)
    (vector-set! rt (char->integer #\() -1)
    (vector-set! rt (char->integer #\)) -1)
    (vector-set! rt (char->integer #\") -1)
    (vector-set! rt (char->integer #\') -1)
    (vector-set! rt (char->integer #\`) -1)

    rt))

;==============================================================================