scheme-fudge/fudge.ss

(import (scheme base)
        (scheme file)
        (scheme write)
        (scheme char))

(define-syntax import-scheme
  (syntax-rules ()
    ((_ module ...)
      (import (scheme module) ...))))

(define keywords
  '("true" "false" "struct" "enum" "if" "then" "else" "type" "let"))

(define keyword?
  (lambda (word)
    (member word keywords)))

(define get-word-string
  (lambda (file)
    (let ((c (peek-char file)))
      (cond
        ((eof-object? c) "")
        ((char-alphabetic? c)
         (read-char file)
         (string-append (string c) (get-word file)))
        (else "")))))

(define get-word
  (lambda (file)
    (let ((word (get-word-string file)))
      (if (keyword? word)
        (string->symbol word)
        word))))

(define char->digit
  (lambda (c)
    (- (char->integer c) (char->integer #\0))))

; get-number supports only nonnegative integers.
(define get-number
  (lambda (file)
    (let f ((total 0))
      (let ((c (peek-char file)))
        (cond
         ((eof-object? c) total)
         ((char-numeric? c)
          (read-char file)
          (f (+ (* total 10) (char->digit c))))
         (else total))))))

(define get-token
  (lambda (file)
    (let ((c (peek-char file)))
      (cond
        ((eof-object? c) 'end-of-file)
        ((char-whitespace? c)
         (read-char file)
         (get-token file))
        ((char-alphabetic? c)
         (get-word file))
        ((char-numeric? c)
         (get-number file))
        ((eq? c #\+) (read-char file) '+)
        ((eq? c #\-) (read-char file) '-)
        ((eq? c #\*) (read-char file) '*)
        ((eq? c #\/) (read-char file) '/)
        ((eq? c #\=) (read-char file) '=)
        ((eq? c #\() (read-char file) 'left-parenthesis)
        ((eq? c #\)) (read-char file) 'right-parenthesis)
        ((eq? c #\{) (read-char file) 'left-brace)
        ((eq? c #\}) (read-char file) 'right-brace)
        ((eq? c #\;) (read-char file) 'semicolon)
        ((eq? c #\:) (read-char file) 'colon)
        (else (error 'get-token "Bad character" c))))))

(define get-tokens
  (lambda (file)
    (let ((token (get-token file)))
      (if (eq? token 'end-of-file)
          '()
          (cons token (get-tokens file))))))
    
(define tokenize
  (lambda (filename)
    (let ((file (open-input-file filename)))
      (get-tokens file))))

(define test-lexer-fail
  (lambda (input want got)
    (display "text-lexer-fail: input=")
    (write input)
    (display "; want: ")
    (write want)
    (display "; got: ")
    (write got)
    (display ".")
    (newline)))


(define test-lexer-success
  (lambda (input got)
    (display "text-lexer-success: input=")
    (write input)
    (display "; got: ")
    (write got)
    (display ".")
    (newline)))

(define test-lexer-fail-exception
  (lambda (input x)
    (display "test-lexer-fail: input ")
    (write input)
    (display " throws ")
    (write (error-object-message x))
    (display ".")
    (newline)))
  
(define test-lexer
  (lambda (input want)
    (let ((port (open-input-string input)))
      (call/cc
        (lambda (i-got-exception)
          (with-exception-handler
            (lambda (x)
              (test-lexer-fail-exception input x)
              (i-got-exception x))
            (lambda ()
              (let ((got (get-tokens port)))
                (if (equal? got want)
                (test-lexer-success input got)
                (test-lexer-fail input want got))))))))))

(test-lexer "hello world" '("hello" "world"))
(test-lexer "+ * / - = " '(+ * / - =))
(test-lexer "( ) { }" '(left-parenthesis right-parenthesis left-brace right-brace))
(test-lexer "true false" '(true false))
(test-lexer "if then else" '(if then else))
(test-lexer ": ;" '(colon semicolon))
(test-lexer "identifier = 14" '("identifier" = 14))
(test-lexer "" '())