(define (symbol->list symbol)
(string->list (symbol->string symbol)))
(define (list->symbol symbol-list)
(if (null? symbol-list)
symbol-list
(string->symbol (list->string symbol-list))))
(define (pascal-char-alpha-numeric? ch)
(or (char-alphabetic? ch) (char-numeric? ch)))
(define lookahead-pascal-ch #\space)
(define pascal-ch #\space)
(define PASCAL-EOF-CHAR (integer->char 0))
(define PASCAL-TAB-CHAR (integer->char 9))
(define PASCAL-CARRIAGE-RETURN (integer->char 13))
(define PASCAL-LINE-FEED (integer->char 10))
(define pascal-white-space
(list #\space #\newline
PASCAL-TAB-CHAR PASCAL-CARRIAGE-RETURN PASCAL-LINE-FEED))
(define pascal-line-count 1)
(define (pascal-line-number)
pascal-line-count)
(define (get-lookahead-pascal-ch)
lookahead-pascal-ch)
(define (initialize-pascal-lex)
(set! lookahead-pascal-ch (read-char))
(set! pascal-ch #\space)
(set! pascal-line-count 1))
(define MAX-TOKEN 100)
(define pascal-buffer '())
(define (get-pascal-token)
(letrec (
(buffer->symbol
(lambda ()
(string->symbol (list->string (reverse pascal-buffer)))))
(buffer->number
(lambda ()
(string->number (list->string (reverse pascal-buffer)))))
(buffer->string
(lambda ()
(list->string (reverse pascal-buffer))))
(token '())
(buffer-idx 0)
(tail '())
(separators
'(#\( #\) #\[ #\] #\, #\. #\* #\< #\> #\; #\: #\= #\+ #\/ #\# #\^))
(two-character-separators
'((#\* #\)) (#\( #\*) (#\: #\=) (#\( #\.) (#\. #\))
(#\. #\.) (#\< #\>) (#\< #\=) (#\> #\=) ))
(pascal-error
(lambda (message info)
(my-display-pascal "*** ERROR on line ")
(my-display-pascal pascal-line-count)
(my-display-pascal " ")
(my-display-pascal message)
(if (not (null? info))
(begin
(my-display-pascal " ")
(my-display-pascal info)))
(my-newline-pascal)))
(read-pascal-ch
(lambda ()
(set! pascal-ch lookahead-pascal-ch)
(set! lookahead-pascal-ch (read-char))
(if (eof-object? pascal-ch)
(set! pascal-ch PASCAL-EOF-CHAR))
(if (char=? pascal-ch #\newline)
(begin
(set! pascal-ch #\space)
(set! pascal-line-count (+ pascal-line-count 1))))))
(skip-pascal-blanks
(lambda ()
(cond
((char=? pascal-ch PASCAL-EOF-CHAR))
((memq pascal-ch pascal-white-space)
(read-pascal-ch)
(skip-pascal-blanks)))))
(skip-pascal-comment
(lambda ()
(cond
((char=? pascal-ch PASCAL-EOF-CHAR))
((char=? pascal-ch #\})
(read-pascal-ch)
(skip-pascal-blanks))
(else
(read-pascal-ch)
(skip-pascal-comment)))))
(skip-pascal-comments
(lambda ()
(if (char=? pascal-ch #\{)
(begin
(read-pascal-ch)
(skip-pascal-comment)
(skip-pascal-comments)))))
(add-ch-to-buffer-proper
(lambda ()
(if (< buffer-idx MAX-TOKEN)
(begin
(set! pascal-buffer (cons pascal-ch pascal-buffer))
(set! buffer-idx (+ buffer-idx 1))))
(read-pascal-ch)
))
(add-ch-to-buffer
(lambda ()
(set! pascal-ch (char-upcase pascal-ch))
(add-ch-to-buffer-proper)))
(build-symbol-buffer
(lambda ()
(if (or (pascal-char-alpha-numeric? pascal-ch) (char=? pascal-ch #\_))
(begin
(add-ch-to-buffer)
(build-symbol-buffer)))))
(build-string-buffer
(lambda ()
(cond
((char=? pascal-ch PASCAL-EOF-CHAR))
((char=? pascal-ch #\')
(read-pascal-ch)
(if (char=? pascal-ch #\')
(begin
(add-ch-to-buffer)
(build-string-buffer))))
(else
(add-ch-to-buffer-proper)
(build-string-buffer)))))
(add-negative-sign
(lambda ()
(if (char=? pascal-ch #\-)
(add-ch-to-buffer))))
(build-number-buffer
(lambda ()
(letrec (
(state-2
(lambda ()
(add-ch-to-buffer)
(cond
((char=? pascal-ch #\.)
(if (char=? (get-lookahead-pascal-ch) #\.)
(state-7)
(state-3)))
((char-numeric? pascal-ch) (state-2))
((or (char=? pascal-ch #\e) (char=? pascal-ch #\E)) (state-4))
(else (state-7)))))
(state-3
(lambda ()
(add-ch-to-buffer)
(cond
((or (char=? pascal-ch #\e) (char=? pascal-ch #\E)) (state-4))
((char-numeric? pascal-ch) (state-3))
(else (state-7)))))
(state-4
(lambda ()
(add-ch-to-buffer)
(cond
((or (char=? pascal-ch #\+) (char=? pascal-ch #\-)) (state-5))
((char-numeric? pascal-ch) (state-6))
(else (state-7)))))
(state-5
(lambda ()
(add-ch-to-buffer)
(if (char-numeric? pascal-ch)
(state-6)
(state-7))))
(state-6
(lambda ()
(add-ch-to-buffer)
(cond
((char-numeric? pascal-ch) (state-6))
(else (state-7)))))
(state-7
(lambda () '()))
)
(if (char-numeric? pascal-ch)
(state-2)))))
(separator?
(lambda ()
(or (memq pascal-ch separators) (char=? pascal-ch #\-))))
(build-separator-buffer
(lambda ()
(let
((old-ch pascal-ch))
(add-ch-to-buffer)
(if (member (list old-ch pascal-ch) two-character-separators)
(add-ch-to-buffer)))))
(create-number
(lambda ()
(set! token (buffer->number))))
(create-symbol
(lambda ()
(set! token (buffer->symbol))))
(create-string
(lambda ()
(set! token (buffer->string))
(if (= (string-length token) 1)
(set! token (string-ref token 0)))))
)
(set! pascal-buffer '())
(skip-pascal-blanks)
(if (char=? pascal-ch #\{)
(skip-pascal-comments))
(cond
((char=? pascal-ch PASCAL-EOF-CHAR))
((separator?)
(build-separator-buffer)
(create-symbol))
((or (char-numeric? pascal-ch) (char=? pascal-ch #\-))
(add-negative-sign)
(build-number-buffer)
(create-number))
((or (char-alphabetic? pascal-ch) (memq pascal-ch '(#\_ #\$)))
(add-ch-to-buffer)
(build-symbol-buffer)
(create-symbol))
((char=? pascal-ch #\')
(read-pascal-ch)
(build-string-buffer)
(create-string))
(else
(pascal-error "bad character" pascal-ch)
(add-ch-to-buffer)
(create-symbol)))
token))