
; C lexical analyzer. Refer to the wikipedia article: "lexical analysis".

(define EOF-CHAR (integer->char 0))

(define TAB-CHAR (integer->char 9))

(define CARRIAGE-RETURN (integer->char 13))

(define white-space (list #\space #\newline TAB-CHAR CARRIAGE-RETURN))

(define comments '())

(define (display-comments level)
  (if (not (null? comments))
    (let
      ((comment (list->string (reverse comments))))
      (indent level)
      (display ";")
      (display comment)
      (newline)
      (set! comments '()))))

(define get-c-token
  (let
    ((lookahead-ch (read-char)) ; prime the pump
     (ch #\space)
     (line-count 1))

    (letrec (

      (separators '(
        #\( #\) #\[
        #\] #\, #\<
        #\> #\; #\:
        #\= #\+ #\-
        #\* #\/ #\%
        #\& #\^ #\| #\~
        #\{ #\} #\!
        #\# #\.
      ))

      (two-character-separators
        '((#\= #\=)
	  (#\! #\=)
	  (#\< #\=)
	  (#\> #\=)
	  (#\> #\>)
	  (#\< #\<)
	  (#\+ #\+)
	  (#\- #\-)
	  (#\& #\&)
	  (#\| #\|)
        ))

      (token '())

      (lookahead-c-ch
        (lambda ()
          lookahead-ch))

      (char-alpha-numeric?
        (lambda (ch)
          (or (char-alphabetic? ch) (char-numeric? ch))))

      (char-hex?
        (lambda (ch)
          (or
            (char-numeric? ch)
            (and (char>=? ch #\a) (char<=? ch #\f))
            (and (char>=? ch #\A) (char<=? ch #\F)))))

      (c-error
        (lambda (message info)
          (display  "*** ERROR on line ")
          (display line-count)
          (display " ")
          (display message)
          (if (not (null? info))
            (begin
              (display " ")
              (display info)))
          (newline)))

      (read-c-ch
        (lambda ()
          (set! ch lookahead-ch)
          (set! lookahead-ch (read-char))
          (if (eof-object? ch)
            (set! ch EOF-CHAR))
          (if (memq ch white-space)
            (begin
              (if (char=? ch #\newline)
                (set! line-count (+ line-count 1)))
              (set! ch #\space)))))
    
      (skip-blanks
        (lambda ()
          (cond
            ((char=? ch EOF-CHAR)) ; TODO remove?
            ((char=? ch #\space)
              (read-c-ch)
              (skip-blanks)))))

      (log-comment-char
	(lambda (ch)
	  (set! comments (cons ch comments))))

      (skip-comment
        (lambda ()
          (cond
	    ((char=? (lookahead-c-ch) EOF-CHAR))
	    ((char=? (lookahead-c-ch) #\newline)
              (read-c-ch)
              (skip-blanks))
            (else
              (read-c-ch)
	      (log-comment-char ch)
              (skip-comment)))))

      (skip-comments
        (lambda ()
          (if (and (char=? ch #\/) (char=? (lookahead-c-ch) #\/))
            (begin
              (read-c-ch)
              (skip-comment)
              (skip-comments)))))
 
      (add-ch-to-token
        (lambda ()
	  (set! token (cons ch token))
          (read-c-ch)))
            
      (build-symbol-token
        (lambda ()
          (if (or (char-alpha-numeric? ch) (char=? ch #\_))
            (begin
              (add-ch-to-token)
              (build-symbol-token)))))

      (build-string-token
        (lambda ()
          (cond
            ((char=? ch EOF-CHAR))
            ((char=? ch #\\)
              (read-c-ch)
	      (if (char=? ch #\n)
	        (set! ch (integer->char 10))) ; newline
              (add-ch-to-token)
              (build-string-token))
            ((char=? ch #\") ; close string
              (read-c-ch))
            (else
              (add-ch-to-token)
              (build-string-token)))))

      (hex-dig->value
        (lambda (ch)
	  (if (and (char>=? ch #\a) (char<=? ch #\f))
	    (+ 10 (- (char->integer ch) (char->integer #\a)))
            (if (and (char>=? ch #\A) (char<=? ch #\F))
	      (+ 10 (- (char->integer ch) (char->integer #\A)))
	      (- (char->integer ch) (char->integer #\0))))))

      (value->hex-dig
	(lambda (dig)
	  (vector-ref
            '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7
               #\8 #\9 #\a #\b #\c #\d #\e #\f)
	    dig)))

      (hex->dec
        (lambda (l pow)
	  (if (null? l)
	    0
	    (let
	      ((dig (car l)))
	      (+ (* (hex-dig->value dig) pow)
	         (hex->dec (cdr l) (* pow 16)))))))

      (hex-negative?
	(lambda (token)
	  (>= (hex-dig->value (list-ref token 7)) 8)))

      (hex-compliment
	(lambda (token)
	  (if (null? token)
	    '()
	    (let
	      ((hex-dig (car token)))
	      (cons
		(value->hex-dig (- 15 (hex-dig->value hex-dig)))
		(hex-compliment (cdr token)))))))

      (do-hex
        (lambda ()
	  ; to make scheme compilers with 64 bit integers force 32 bit
	  ; behavior we will only use the least significant 8 digits
	  (if (> (length token) 8)
	    (set! token
	      (reverse (list-tail (reverse token) (- (length token) 8)))))
	  (let
	    ((negative #f))
	    (if (= (length token) 8)
	      (if (hex-negative? token)
		(begin
		  (set! negative #t)
		  (set! token (hex-compliment token)))))
            (set! token (hex->dec token 1))
	    (if negative
	      (set! token (- (+ token 1)))))))

      (build-hex-number-token
        (lambda ()
          (if (char-hex? ch)
	    (begin
              (add-ch-to-token)
              (build-hex-number-token)))))

      (build-decimal-number-token
        (lambda ()
          (if (char-numeric? ch)
	    (begin
              (add-ch-to-token)
              (build-decimal-number-token)))))

      (build-number-token
        (lambda ()
          (if (char=? (lookahead-c-ch) #\x) ; hex number
	    (begin
	      (read-c-ch)
	      (read-c-ch)
	      (build-hex-number-token)
	      (do-hex))
	    (begin
	      (build-decimal-number-token)
	      (set! token (string->number (list->string (reverse token))))))))

      (separator?
        (lambda ()
          (memq ch separators)))

      (build-separator-token
        (lambda ()
          (let
            ((old-ch ch))
            (add-ch-to-token)
            (if (member (list old-ch ch) two-character-separators)
              (add-ch-to-token)))))

      )
 
      (lambda () ; get-c-token
        (set! token '())
        (skip-blanks)
        (if (and (char=? ch #\/) (char=? (lookahead-c-ch) #\/))
        (skip-comments))

        (cond
          ((char=? ch EOF-CHAR)
            (set! token '())) ; null token
          ((separator?)
            (build-separator-token)
            (set! token (string->symbol (list->string (reverse token)))))
          ((char-numeric? ch) ; integer number
            (build-number-token))
          ((or (char-alphabetic? ch) (char=? ch #\_))
            (add-ch-to-token)
            (build-symbol-token)
            (set! token (string->symbol (list->string (reverse token)))))
          ((char=? ch #\") ; string
            (read-c-ch)
            (build-string-token)
            (set! token (list->string (reverse token))))
          ((char=? ch #\') ; character
            (read-c-ch)
	    (if (char=? ch #\\)
	      (begin ; escape character
                (read-c-ch)
	        (if (char=? ch #\n)
	          (set! ch (integer->char 10))))) ; newline
	    (set! token (char->integer ch))
            (read-c-ch) ; close quote
            (read-c-ch))
          (else
            (c-error "bad character" ch)
            (add-ch-to-token)
            (set! token (string->symbol (list->string (reverse token))))))
        token))))

(define token-ring (list (list) (list) (list) (list)))
(set-cdr! (cdr (cddr token-ring)) token-ring)

(define (triple-lookahead)
  (cadr (cddr token-ring)))

(define (double-lookahead)
  (cadr (cdr token-ring)))

(define (lookahead)
  (cadr token-ring))

(define (get-token)
  (set-car! token-ring (get-c-token))
  (set! token-ring (cdr token-ring))
  (car token-ring))
