home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Interp⁄Comp (.scm) / source.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  12.8 KB  |  425 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "source.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Source code manipulation package:
  8. ; --------------------------------
  9.  
  10. ; This package contains procedures to manipulate source code representations
  11. ; read in from Scheme source files.
  12.  
  13. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  14. ;
  15. ; 'source file' manipulation
  16.  
  17. (define (open-sf filename)
  18.  
  19.   (define (open-err)
  20.     (compiler-error "Can't find file" filename))
  21.  
  22.   (if (string=? (file-ext filename) "")
  23.  
  24.     (let loop ((exts source-exts))
  25.       (if (pair? exts)
  26.         (let* ((full-name (string-append filename (car exts)))
  27.                (port (open-input-file* full-name)))
  28.           (if port
  29.             (vector port full-name 0 1 0)
  30.             (loop (cdr exts))))
  31.         (open-err)))
  32.  
  33.     (let ((port (open-input-file* filename)))
  34.       (if port
  35.         (vector port filename 0 1 0)
  36.         (open-err)))))
  37.  
  38. (define (close-sf sf)
  39.   (close-input-port (vector-ref sf 0)))
  40.  
  41. (define (sf-read-char sf)
  42.   (let ((c (read-char (vector-ref sf 0))))
  43.     (cond ((eof-object? c))
  44.           ((char=? c char-newline)
  45.            (vector-set! sf 3 (+ (vector-ref sf 3) 1))
  46.            (vector-set! sf 4 0))
  47.           (else
  48.            (vector-set! sf 4 (+ (vector-ref sf 4) 1))))
  49.     c))
  50.  
  51. (define (sf-peek-char sf)
  52.   (peek-char (vector-ref sf 0)))
  53.  
  54. (define (sf-read-error sf msg . args)
  55.   (apply compiler-user-error
  56.          (cons (sf->locat sf)
  57.                (cons (string-append "Read error -- " msg) args))))
  58.  
  59. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  60. ;
  61. ; 'location' manipulation
  62.  
  63. (define (sf->locat sf)
  64.   (vector 'FILE
  65.           (vector-ref sf 1)
  66.           (vector-ref sf 2)
  67.           (vector-ref sf 3)
  68.           (vector-ref sf 4)))
  69.  
  70. (define (expr->locat expr source)
  71.   (vector 'EXPR
  72.           expr
  73.           source))
  74.  
  75. (define (locat-show loc)
  76.   (if loc
  77.  
  78.     (case (vector-ref loc 0)
  79.       ((FILE)
  80.        (if (pinpoint-error
  81.              (vector-ref loc 1)
  82.              (vector-ref loc 3)
  83.              (vector-ref loc 4))
  84.          (begin
  85.            (display " (file \"")
  86.            (display (vector-ref loc 1))
  87.            (display "\", line ")
  88.            (display (vector-ref loc 3))
  89.            (display ", character ")
  90.            (display (vector-ref loc 4))
  91.            (display ")"))))
  92.       ((EXPR)
  93.        (display " (expression ")
  94.        (write (vector-ref loc 1))
  95.        (if (vector-ref loc 2)
  96.          (locat-show (source-locat (vector-ref loc 2))))
  97.        (display ")"))
  98.       (else
  99.        (compiler-internal-error "locat-show, unknown location tag")))
  100.  
  101.     (display " (unknown location)")))
  102.  
  103. (define (locat-filename loc)
  104.   (if loc
  105.     (case (vector-ref loc 0)
  106.       ((FILE)
  107.        (vector-ref loc 1))
  108.       ((EXPR)
  109.        (let ((source (vector-ref loc 2)))
  110.          (if source
  111.            (locat-filename (source-locat source))
  112.            "")))
  113.       (else
  114.        (compiler-internal-error "locat-filename, unknown location tag")))
  115.     ""))
  116.  
  117. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  118. ;
  119. ; 'source' manipulation
  120.  
  121. (define (make-source code locat)
  122.   (vector code locat))
  123.  
  124. (define (source-code x)        (vector-ref x 0))
  125. (define (source-code-set! x y) (vector-set! x 0 y) x)
  126. (define (source-locat x)       (vector-ref x 1))
  127.  
  128. ; (expression->source expr source) returns the source that represent the Scheme
  129. ; expression 'expr' and is related to the source 'source' (#f if no relation).
  130.  
  131. (define (expression->source expr source)
  132.  
  133.   (define (expr->source x)
  134.     (make-source (cond ((pair? x)
  135.                         (list->source x))
  136.                        ((vector? x)
  137.                         (vector->source x))
  138.                        ((symbol-object? x)
  139.                         (string->canonical-symbol (symbol->string x)))
  140.                        (else
  141.                         x))
  142.                  (expr->locat x source)))
  143.  
  144.   (define (list->source l)
  145.     (cond ((pair? l)
  146.            (cons (expr->source (car l)) (list->source (cdr l))))
  147.           ((null? l)
  148.            '())
  149.           (else
  150.            (expr->source l))))
  151.  
  152.   (define (vector->source v)
  153.     (let* ((len (vector-length v))
  154.            (x (make-vector len)))
  155.       (let loop ((i (- len 1)))
  156.         (if (>= i 0)
  157.           (begin
  158.             (vector-set! x i (expr->source (vector-ref v i)))
  159.             (loop (- i 1)))))
  160.       x))
  161.  
  162.   (expr->source expr))
  163.  
  164. ; (source->expression source) returns the Scheme expression represented by the
  165. ; source 'source'.  Note that every call with the same argument returns a
  166. ; different (i.e. non eq?) expression.
  167.  
  168. (define (source->expression source)
  169.  
  170.   (define (list->expression l)
  171.     (cond ((pair? l)
  172.            (cons (source->expression (car l)) (list->expression (cdr l))))
  173.           ((null? l)
  174.            '())
  175.           (else
  176.            (source->expression l))))
  177.  
  178.   (define (vector->expression v)
  179.     (let* ((len (vector-length v))
  180.            (x (make-vector len)))
  181.       (let loop ((i (- len 1)))
  182.         (if (>= i 0)
  183.           (begin
  184.             (vector-set! x i (source->expression (vector-ref v i)))
  185.             (loop (- i 1)))))
  186.       x))
  187.  
  188.   (let ((code (source-code source)))
  189.     (cond ((pair? code)   (list->expression code))
  190.           ((vector? code) (vector->expression code))
  191.           (else           code))))
  192.  
  193. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  194.  
  195. ; (file->sources filename info-port) returns a list of the source
  196. ; representation for each of the expressions contained in the file 'filename'.
  197.  
  198. (define (file->sources filename info-port)
  199.  
  200.   (if info-port
  201.     (begin
  202.       (display "(reading \"" info-port) (display filename info-port)
  203.       (display "\"" info-port)))
  204.  
  205.   (let ((sf (open-sf filename)))
  206.  
  207.     (define (read-sources) ; return list of all sources in file
  208.       (let ((source (read-source sf)))
  209.         (if (not (eof-object? source))
  210.           (begin
  211.             (if info-port (display "." info-port))
  212.             (cons source (read-sources)))
  213.           '())))
  214.  
  215.     (let ((sources (read-sources)))
  216.  
  217.       (if info-port (display ")" info-port))
  218.  
  219.       (close-sf sf)
  220.  
  221.       sources)))
  222.  
  223. (define (file->sources* filename info-port loc)
  224.  (file->sources (if (path-absolute? filename)
  225.                   filename
  226.                   (string-append
  227.                     (file-path (locat-filename loc))
  228.                     filename))
  229.                 info-port))
  230.  
  231. ; (read-source sf) returns the source for the next expression in the source
  232. ; file 'sf'.
  233.  
  234. (define (read-source sf)
  235.  
  236.   (define (read-char*)
  237.     (let ((c (sf-read-char sf)))
  238.       (if (eof-object? c)
  239.         (sf-read-error sf "Premature end of file encountered")
  240.         c)))
  241.  
  242.   (define (read-non-whitespace-char)
  243.     (let ((c (read-char*)))
  244.       (cond ((< 0 (vector-ref read-table (char->integer c)))
  245.              (read-non-whitespace-char))
  246.             ((char=? c #\;)
  247.              (let loop ()
  248.                (if (not (char=? (read-char*) char-newline))
  249.                  (loop)
  250.                  (read-non-whitespace-char))))
  251.             (else
  252.              c))))
  253.  
  254.   (define (delimiter? c)
  255.     (or (eof-object? c)
  256.         (not (= (vector-ref read-table (char->integer c)) 0))))
  257.  
  258.   (define (read-list first)
  259.     (let ((result (cons first '())))
  260.       (let loop ((end result))
  261.         (let ((c (read-non-whitespace-char)))
  262.           (cond ((char=? c #\)))
  263.                 ((and (char=? c #\.) (delimiter? (sf-peek-char sf)))
  264.                  (let ((x (read-source sf)))
  265.                    (if (char=? (read-non-whitespace-char) #\))
  266.                      (set-cdr! end x)
  267.                      (sf-read-error sf "')' expected"))))
  268.                 (else
  269.                  (let ((tail (cons (rd* c) '())))
  270.                    (set-cdr! end tail)
  271.                    (loop tail))))))
  272.       result))
  273.  
  274.   (define (read-vector)
  275.     (define (loop i)
  276.       (let ((c (read-non-whitespace-char)))
  277.         (if (char=? c #\))
  278.           (make-vector i '())
  279.           (let* ((x (rd* c))
  280.                  (v (loop (+ i 1))))
  281.             (vector-set! v i x)
  282.             v))))
  283.     (loop 0))
  284.  
  285.   (define (read-string)
  286.     (define (loop i)
  287.       (let ((c (read-char*)))
  288.         (cond ((char=? c #\")
  289.                (make-string i #\space))
  290.               ((char=? c #\\)
  291.                (let* ((c (read-char*))
  292.                       (s (loop (+ i 1))))
  293.                  (string-set! s i c)
  294.                  s))
  295.               (else
  296.                (let ((s (loop (+ i 1))))
  297.                  (string-set! s i c)
  298.                  s)))))
  299.     (loop 0))
  300.  
  301.   (define (read-symbol/number-string i)
  302.     (if (delimiter? (sf-peek-char sf))
  303.       (make-string i #\space)
  304.       (let* ((c (sf-read-char sf))
  305.              (s (read-symbol/number-string (+ i 1))))
  306.         (string-set! s i (char-downcase c))
  307.         s)))
  308.  
  309.   (define (read-symbol/number c)
  310.     (let ((s (read-symbol/number-string 1)))
  311.       (string-set! s 0 (char-downcase c))
  312.       (or (string->number s 10)
  313.           (string->canonical-symbol s))))
  314.  
  315.   (define (read-prefixed-number c)
  316.     (let ((s (read-symbol/number-string 2)))
  317.       (string-set! s 0 #\#)
  318.       (string-set! s 1 c)
  319.       (string->number s 10)))
  320.  
  321.   (define (read-special-symbol)
  322.     (let ((s (read-symbol/number-string 2)))
  323.       (string-set! s 0 #\#)
  324.       (string-set! s 1 #\#)
  325.       (string->canonical-symbol s)))
  326.  
  327.   (define (rd c)
  328.     (cond ((eof-object? c)
  329.            c)
  330.           ((< 0 (vector-ref read-table (char->integer c)))
  331.            (rd (sf-read-char sf)))
  332.           ((char=? c #\;)
  333.            (let loop ()
  334.              (let ((c (sf-read-char sf)))
  335.                (cond ((eof-object? c)
  336.                       c)
  337.                      ((char=? c char-newline)
  338.                       (rd (sf-read-char sf)))
  339.                      (else
  340.                       (loop))))))
  341.           (else
  342.            (rd* c))))
  343.  
  344.   (define (rd* c)
  345.     (let ((source (make-source #f (sf->locat sf))))
  346.       (source-code-set!
  347.         source
  348.         (cond ((char=? c #\()
  349.                (let ((x (read-non-whitespace-char)))
  350.                  (if (char=? x #\))
  351.                    '()
  352.                    (read-list (rd* x)))))
  353.               ((char=? c #\#)
  354.                (let ((c (char-downcase (sf-read-char sf))))
  355.                  (cond ((char=? c #\() (read-vector))
  356.                        ((char=? c #\f) false-object)
  357.                        ((char=? c #\t) #t)
  358.                        ((char=? c #\\)
  359.                         (let ((c (read-char*)))
  360.                           (if (or (not (char-alphabetic? c))
  361.                                   (delimiter? (sf-peek-char sf)))
  362.                             c
  363.                             (let ((name (read-symbol/number c)))
  364.                               (let ((x (assq name named-char-table)))
  365.                                 (if x
  366.                                   (cdr x)
  367.                                   (sf-read-error sf "Unknown character name" name)))))))
  368.  
  369.                        ((char=? c #\#)
  370.                         (read-special-symbol))
  371.                        (else
  372.                         (let ((num (read-prefixed-number c)))
  373.                           (or num
  374.                               (sf-read-error sf "Unknown '#' read macro" c)))))))
  375.               ((char=? c #\")
  376.                (read-string))
  377.               ((char=? c #\')
  378.                (list (make-source QUOTE-sym (sf->locat sf))
  379.                      (read-source sf)))
  380.               ((char=? c #\`)
  381.                (list (make-source QUASIQUOTE-sym (sf->locat sf))
  382.                      (read-source sf)))
  383.               ((char=? c #\,)
  384.                (if (char=? (sf-peek-char sf) #\@)
  385.                  (let ((x (make-source UNQUOTE-SPLICING-sym (sf->locat sf))))
  386.                    (sf-read-char sf)
  387.                    (list x (read-source sf)))
  388.                  (list (make-source UNQUOTE-sym (sf->locat sf))
  389.                        (read-source sf))))
  390.               ((char=? c #\))
  391.                (sf-read-error sf "Misplaced ')'"))
  392.               (else
  393.                (if (char=? c #\.)
  394.                  (if (delimiter? (sf-peek-char sf))
  395.                    (sf-read-error sf "Misplaced '.'")))
  396.                (read-symbol/number c))))))
  397.  
  398.   (rd (sf-read-char sf)))
  399.  
  400. (define named-char-table
  401.   (list (cons (string->canonical-symbol "SPACE")   #\ )
  402.         (cons (string->canonical-symbol "NEWLINE") char-newline)))
  403.  
  404. (define read-table
  405.   (let ((rt (make-vector (+ max-character-encoding 1) 0)))
  406.  
  407.     ; setup whitespace chars
  408.  
  409.     (vector-set! rt (char->integer #\ ) 1)
  410.     (vector-set! rt (char->integer char-tab) 1)
  411.     (vector-set! rt (char->integer char-newline) 1)
  412.  
  413.     ; setup other delimiters
  414.  
  415.     (vector-set! rt (char->integer #\;) -1)
  416.     (vector-set! rt (char->integer #\() -1)
  417.     (vector-set! rt (char->integer #\)) -1)
  418.     (vector-set! rt (char->integer #\") -1)
  419.     (vector-set! rt (char->integer #\') -1)
  420.     (vector-set! rt (char->integer #\`) -1)
  421.  
  422.     rt))
  423.  
  424. ;==============================================================================
  425.