home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / TOKENIZE.SCM < prev    next >
Text File  |  1992-06-17  |  4KB  |  155 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; A tokenizer.
  6.  
  7. ; Nonstandard things needed:
  8. ;  record package
  9. ;  char->ascii
  10. ;  peek-char
  11. ;  reverse-list->string
  12. ;  error
  13.  
  14. (define reverse-list->string (package-ref primitives reverse-list->string))
  15. (define peek-char (package-ref primitives peek-char))
  16. (define char->ascii (package-ref primitives char->ascii))
  17.  
  18. ; Tokenizer tables
  19.  
  20. (define tokenizer-table-type
  21.   (make-record-type 'tokenizer-table
  22.             '(translation dispatch-vector terminating?-vector)))
  23.  
  24. (define make-tokenizer-table
  25.   (let ()
  26.     (define make
  27.       (record-constructor tokenizer-table-type
  28.               '(translation dispatch-vector terminating?-vector)))
  29.     (define (make-tokenizer-table)
  30.       (make (if (char=? (string-ref (symbol->string 't) 0) #\T)
  31.         char-upcase
  32.         char-downcase)
  33.         (make-vector 256 (lambda (c port)
  34.                    (error "illegal character read" c)))
  35.         (make-vector 256 #t)))
  36.     make-tokenizer-table))
  37.  
  38. (define ttab-translation
  39.   (record-accessor tokenizer-table-type 'translation))
  40. (define ttab-dispatch-vector
  41.   (record-accessor tokenizer-table-type 'dispatch-vector))
  42. (define ttab-terminating?-vector
  43.   (record-accessor tokenizer-table-type 'terminating?-vector))
  44.  
  45. (define set-tokenizer-table-translator!
  46.   (record-modifier tokenizer-table-type 'translation))
  47.  
  48. (define (set-char-tokenization! ttab char reader term?)
  49.   (vector-set! (ttab-dispatch-vector ttab) (char->ascii char) reader)
  50.   (vector-set! (ttab-terminating?-vector ttab) (char->ascii char) term?))
  51.  
  52. ; Main dispatch
  53.  
  54. (define (tokenize ttab port)
  55.   (let ((c (read-char port)))
  56.     (if (eof-object? c)
  57.         c
  58.         ((vector-ref (ttab-dispatch-vector ttab) (char->ascii c))
  59.          c port))))
  60.  
  61. ; Atoms (symbols and numbers)
  62.  
  63. (define (scan-atom c ttab port)
  64.   (let ((translate (ttab-translation ttab)))
  65.     (let loop ((l (list (translate c))) (n 1))
  66.       (let ((c (peek-char port)))
  67.     (cond ((or (eof-object? c)
  68.            (vector-ref (ttab-terminating?-vector ttab)
  69.                    (char->ascii c)))
  70.            (reverse-list->string l n))
  71.           (else
  72.            (loop (cons (translate (read-char port)) l)
  73.              (+ n 1))))))))
  74.  
  75. ; Allow ->foo, -v-, etc.
  76.  
  77. (define (parse-atom string)
  78.   (let ((c (string-ref string 0)))
  79.     (cond ((char=? c #\+)
  80.        (parse-possible-number string))
  81.           ((char=? c #\-)
  82.        (parse-possible-number string))
  83.           ((char=? c #\.)
  84.        (parse-possible-number string))
  85.           (else
  86.            (if (char-numeric? c)
  87.                (parse-number string)
  88.                (string->symbol string))))))
  89.  
  90. ; First char is + - .
  91.  
  92. (define (parse-possible-number string)
  93.   (if (and (> (string-length string) 1)
  94.        (char-numeric? (string-ref string 1)))
  95.       (parse-number string)
  96.       (string->symbol string)))
  97.  
  98. (define (parse-number string)
  99.   (or (string->number string 'e 'd)
  100.       (error "unsupported number syntax" string)))
  101.  
  102.  
  103. ; Usual stuff (what you'd expect to be common to Scheme and ML syntax)
  104.  
  105. (define (set-up-usual-tokenization! ttab)
  106.  
  107.   (define (tokenize-whitespace c port)     c ;ignored
  108.     (tokenize ttab port))
  109.  
  110.   (define (tokenize-constituent c port)
  111.     (parse-atom (scan-atom c ttab port)))
  112.  
  113.   (for-each (lambda (c)
  114.           (set-char-tokenization! ttab c tokenize-whitespace #t))
  115.         '(#\space #\newline #\page #\tab))
  116.  
  117.   (for-each (lambda (c)
  118.           (set-char-tokenization! ttab c tokenize-constituent #f))
  119.         (string->list
  120.          (string-append ".0123456789"
  121.                 "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  122.                 "abcdefghijklmnopqrstuvwxyz")))
  123.   
  124.   (set-char-tokenization! ttab #\" tokenize-string #t)
  125.  
  126.   )
  127.  
  128. (define (make-constituent! c ttab)
  129.   (set-char-tokenization! ttab c
  130.               (lambda (c port)
  131.                 (parse-atom (scan-atom c ttab port)))
  132.               #f))
  133.  
  134. (define (tokenize-string c port)      c ;ignored
  135.   (let loop ((l '()) (i 0))
  136.     (let ((c (read-char port)))
  137.       (cond ((eof-object? c)
  138.          (error "end of file within a string"))
  139.         ((char=? c #\\)
  140.          (let ((c (read-char port)))
  141.            (if (or (char=? c #\\) (char=? c #\"))
  142.            (loop (cons c l) (+ i 1))
  143.            (error "invalid escaped character in string" c))))
  144.         ((char=? c #\") (reverse-list->string l i))
  145.         (else (loop (cons c l) (+ i 1)))))))
  146.  
  147. ; Auxiliary for parse-atom and tokenize-string
  148.  
  149. ;(define (reverse-list->string l n)   ;In microcode?
  150. ;  (let ((s (make-string n)))
  151. ;    (do ((l l (cdr l))
  152. ;        (i (- n 1) (- i 1)))
  153. ;       ((< i 0) s)
  154. ;      (string-set! s i (car l)))))
  155.