;;; File: parser/lexer Author: John
;;; token data structure: a list with the token type in the
;;; car and other information in the rest of the list. Symbols
;;; designate the token type.
;;; Reserved tokens use the name as the type and have no args.
;;; Reserved tokens:
;;; case class data default deriving else hiding if import in infix
;;; infixl infixr instance interface let module of renaming then to
;;; type where .. :: => = @ \ | ~ <- -> `
;;; Other tokens:
;;; (file string)
;;; (newline line indent-column)
;;; (conid string)
;;; (varid string)
;;; (consym string)
;;; (varsym string)
;;; (comment string) ;;; not used at the moment
;;; (integer integer)
;;; (float integer fraction exponent)
;;; (string string)
;;; (eof)
;;; *** All of the stuff for lexing character and string literals is
;;; *** broken because it assumes that the host Lisp uses the ASCII
;;; *** encoding for characters and supports at least 255 characters.
;;; *** I have marked the specific places in the code where these
;;; *** assumptions are made, but fixing the problem will probably
;;; *** require more drastic changes anyway -- such as using integers
;;; *** instead of characters and vectors of integers instead of characters
;;; *** throughout the compiler.
(define *max-char* 255) ; highest char-code allowed.
;;; This defines the long names of the control chars. Note that some of
;;; this duplicates the table above & the reader.
(define *control-char-names* '(
("NUL" . 0) ("SOH" . 1) ("STX" . 2) ("ETX" . 3)
("EOT" . 4) ("ENQ" . 5) ("ACK" . 6) ("BEL" . 7)
("BS" . 8) ("HT" . 9) ("LF" . 10) ("VT" . 11)
("FF" . 12) ("CR" . 13) ("SO" . 14) ("SI" . 15)
("DLE" . 16) ("DC1" . 17) ("DC2" . 18) ("DC3" . 19)
("DC4" . 20) ("NAK" . 21) ("SYN" . 22) ("ETB" . 23)
("CAN" . 24) ("EM" . 25) ("SUB" . 26) ("ESC" . 27)
("FS" . 28) ("GS" . 29) ("RS" . 30) ("US" . 31)
("SP" . 32) ("DEL" . 127)))
;;; This defines the short names for a few control chars. This
;;; is keyed off the previous table
(define *short-control-char-names* '(
(#\a . "BEL") (#\b . "BS") (#\f . "FF") (#\n . "LF")
(#\r . "CR") (#\t . "HT") (#\v . "VT")))
;;; This is used in the ^X construct. Assume that ^X = code for ^A + X-A
;;; *** This is an invalid assumption.
(define *control-A* 1)
;;; This function is the interface between the lexer and the rest
;;; of the system. Note that the `file' reported in error messages
;;; must be bound in an outer context.
;;; *** I think this function should be binding these variables and not
;;; *** just assigning them.
(define (lex-port port literate?)
(setf *lex-literate?* literate?)
(setf *current-line* 1)
(setf *current-col* 0)
(setf *on-new-line?* '#t)
(setf *save-col?* '#f)
(setf *port* port)
(setf *tokens* '())
(setf *char* (read-char *port*))
(setf *peek-char* (read-char *port*))
(when (eof-object? *char*)
(setf *char* '#\space))
(when (eof-object? *peek-char*)
(setf *peek-char* '#\space))
(setf *at-eof/p?* '#f)
(setf *at-eof?* '#f)
(when *lex-literate?*
(process-literate-comments '#t))
(parse-till-eof)
(nreverse *tokens*))
(define (parse-till-eof)
(cond (*at-eof?*
(emit-token 'eof)
'())
(else
(lex-one-token)
(parse-till-eof))))
;;; There is an assumption that the scanner never peeks beyond a newline.
;;; In literate mode, this may reveal the wrong thing.
(define (advance-char)
(if (and *lex-literate?* (eqv? *char* #\newline))
(process-literate-comments '#f)
(advance-char-1)))
(define (advance-char-1)
(cond ((eqv? *char* #\newline)
(setf *on-new-line?* '#t)
(incf (the fixnum *current-line*))
(setf *current-col* 0))
((eqv? *char* #\tab)
(incf (the fixnum *current-col*) (- 8 (modulo *current-col* 8))))
(else
(incf (the fixnum *current-col*))))
(setf *char* *peek-char*)
(setf *at-eof?* *at-eof/p?*)
(setf *peek-char* (read-char *port*))
(when (eof-object? *peek-char*)
(setf *at-eof/p?* '#t)
(setf *peek-char* '#\space))
*char*)
(define (peek-char-2)
(let ((ch (peek-char *port*)))
(if (eof-object? ch)
'#\space
ch)))
(define (lex-one-token)
(setf *start-line* *current-line*) ; capture the loc at the start of the token
(setf *start-col* *current-col*)
(unless *at-eof?*
(char-case *char*
(whitechar
(advance-char)
(lex-one-token))
(#\- (char-case *peek-char*
(#\- (lex-comment))
(#\> (advance-char)
(advance-char)
(emit-token '\-\>))
(#\} (signal-missing-begin-comment)
(advance-char)
(advance-char)
(lex-one-token))
(else
(lex-varsym))))
(#\{ (cond ((char=? *peek-char* '#\-)
(advance-char)
(advance-char)
(cond ((char=? *char* '#\#)
(advance-char)
(emit-token 'begin-annotation))
(else
(lex-ncomment)
(lex-one-token))))
(else
(advance-char)
(emit-token '\{ ))))
(small (lex-varid))
(large (lex-conid))
(#\( (advance-char)
(emit-token '\())
(#\: (lex-consym))
(#\` (advance-char)
(emit-token '\`))
((symbol presymbol) (lex-varsym))
(digit (lex-numeric))
(#\' (lex-char))
(#\" (lex-string))
(#\) (advance-char)
(emit-token '\)))
(#\, (advance-char)
(emit-token '\,))
(#\; (advance-char)
(emit-token '\;))
(#\[ (advance-char)
(emit-token '\[))
(#\] (advance-char)
(emit-token '\]))
(#\_ (advance-char)
(emit-token '\_))
(#\} (advance-char)
(emit-token '\}))
(else
(signal-invalid-character *char*)
(advance-char)
(lex-one-token)))))
(define (signal-missing-begin-comment)
(lexer-error 'missing-begin-comment
"`-}' appears outside of a nested comment."))
(define (signal-invalid-character ch)
(lexer-error 'invalid-character
"Invalid character `~a' appears in source program." ch))
(define (advance-past-white)
(unless *at-eof?*
(char-case *char*
(whitechar
(advance-char)
(advance-past-white))
(else
'()))))
(define (process-literate-comments at-start?)
(unless at-start? (advance-char-1))
(let ((l (classify-line)))
(cond ((or *at-eof?* (eq? l 'program))
'())
((eq? l 'blank)
(skip-literate-comment '#t))
(else
(when (not at-start?)
(lexer-error 'blank-line-needed
"Literate comments must be preceeded by a blank line"))
(skip-literate-comment '#f)))))
(define (skip-literate-comment prev-blank)
(skip-past-line)
(let ((l (classify-line)))
(cond (*at-eof?*
'())
((eq? l 'comment)
(skip-literate-comment '#f))
((eq? l 'blank)
(skip-literate-comment '#t))
(else
(when (not prev-blank)
(lexer-error 'blank-line-needed
"Literate comments must be followed by a blank line"))))))
(define (classify-line)
(if *at-eof?*
'blank
(char-case *char*
(#\>
(advance-char-1)
'program)
(#\newline 'blank)
(whitechar
(classify-line-1))
(else 'comment))))
(define (classify-line-1)
(advance-char-1)
(char-case *char*
(#\newline 'blank)
(whitechar (classify-line-1))
(else 'comment)))
(define (skip-past-line)
(when (not *at-eof?*)
(char-case *char*
(#\newline
(advance-char-1))
(else
(advance-char-1)
(skip-past-line)))))
(define (lex-comment) ;; a -- style comment
(advance-char)
(cond (*at-eof?* (lexer-eof-in-comment *current-line*))
((char=? *char* #\newline)
(lex-one-token))
(else
(lex-comment))))
(define (lexer-eof-in-comment start-line)
(signal-eof-in-comment start-line)
(lex-one-token)) ; will return the eof token
(define (signal-eof-in-comment start-line)
(lexer-error 'eof-in-comment
"End of file in comment starting at line ~A." start-line))
;;; Here *char* and *peek-char* are the first two chars on a line.
(define (scan-symbol)
(scan-list-of (symbol #\:)))
(define (scan-var-con)
(scan-list-of (large small digit #\' #\_)))
(define (lex-ncomment)
(lex-ncomment-1 *current-line*))
(define (lex-ncomment-1 start-line)
(if *at-eof?*
(lexer-eof-in-comment start-line)
(char-case *char*
(#\- (cond ((char=? *peek-char* #\})
(advance-char)
(advance-char))
(else
(advance-char)
(lex-ncomment-1 start-line))))
(#\{ (cond ((char=? *peek-char* #\-)
(advance-char)
(advance-char)
(lex-ncomment)
(lex-ncomment-1 start-line))
(else
(advance-char)
(lex-ncomment-1 start-line))))
(else
(advance-char)
(lex-ncomment-1 start-line)))))
(define (lex-varid)
(let ((sym (scan-var-con)))
(parse-reserved sym varid
"case" "class"
"data" "default" "deriving"
"else"
"hiding"
"if" "import" "in" "infix" "infixl" "infixr" "instance" "interface"
"let"
"module"
"of"
"renaming"
"then" "to" "type"
"where")))
(define (lex-conid)
(let ((sym (scan-var-con)))
(emit-token/string 'conid sym)))
(define (lex-consym)
(let ((sym (scan-symbol)))
(cond ((string=/list? (cdr sym) ":")
(emit-token '\:\:))
(else
(emit-token/string 'consym sym)))))
(define (lex-varsym)
(let ((sym (scan-symbol)))
(cond ((and (string=/list? sym "<") (char=? *char* #\-))
(advance-char)
(emit-token '\<\-))
((and (string=/list? sym "#")
(char=? *char* #\-)
(char=? *peek-char* #\}))
(advance-char)
(advance-char)
(emit-token 'end-annotation))
(else
(parse-reserved sym varsym
".."
"=>" "="
"@"
"\\"
"|"
"~")))))
(define (lex-integer radix)
(lex-integer-1 radix 0))
(define (lex-integer-1 radix psum)
(declare (type fixnum radix)
(type integer psum))
(let ((d (char->digit *char* radix)))
(if d
(begin
(advance-char)
(lex-integer-1 radix (+ (* psum radix) (the fixnum d))))
psum)))
(define (lex-fraction int-part denominator)
(declare (type integer int-part denominator))
(let ((d (char->digit *char* 10)))
(if d
(begin
(advance-char)
(lex-fraction
(+ (* int-part 10) (the fixnum d)) (* denominator 10)))
(values int-part denominator))))
(define (lex-numeric)
(let ((int-part (lex-integer 10)))
(if (and (char=? *char* #\.)
(char->digit *peek-char* 10))
(lex-float int-part)
(emit-token 'integer int-part))))
(define (lex-float int-part)
(advance-char)
(multiple-value-bind (numerator denominator) (lex-fraction int-part 1)
(let ((no-exponent
(lambda () (emit-token 'float numerator denominator 0))))
(char-case *char*
(exponent
(char-case *peek-char*
(digit
(advance-char)
(lex-float/exp numerator denominator 1))
((#\+ #\-)
(cond ((char->digit (peek-char-2) 10)
(let ((sign (if (char=? *peek-char* '#\+) 1 -1)))
(advance-char)
(advance-char)
(lex-float/exp numerator denominator sign)))
(else
(funcall no-exponent))))
(else
(funcall no-exponent))))
(else
(emit-token 'float numerator denominator 0))))))
(define (lex-float/exp numerator denominator sign)
(let ((exponent (lex-integer 10)))
(emit-token 'float numerator denominator (* sign exponent))))
(define (lex-char)
(advance-char)
(let ((c
(char-case *char*
(#\' (signal-null-character)
'#\?)
(#\\ (lex-escaped-char '#f))
((#\space graphic)
(let ((ch *char*))
(advance-char)
ch))
(else
(signal-bad-character-constant *char*)
(advance-char)
`#\?))))
(cond ((char=? *char* '#\')
(advance-char)
(emit-token 'char c))
(else
(signal-missing-char-quote)
(skip-to-quote-or-eol)))))
(define (signal-null-character)
(lexer-error 'null-character
"Null character '' is illegal - use '\\'' for a quote."))
(define (signal-bad-character-constant ch)
(lexer-error 'bad-character-constant
"The character `~a' may not appear in a character literal." ch))
(define (signal-missing-char-quote)
(lexer-error 'missing-char-quote
"Character constant has more than one character."))
(define (skip-to-quote-or-eol)
(if *at-eof?*
(lex-one-token)
(char-case *char*
(#\' (advance-char)
(lex-one-token))
(#\newline (advance-char)
(lex-one-token))
(else
(advance-char)
(skip-to-quote-or-eol)))))
(define (lex-string)
(advance-char)
(emit-token 'string (list->string (gather-string-chars))))
(define (gather-string-chars)
(char-case *char*
(#\\
(let ((ch (lex-escaped-char '#t)))
(if (eq? ch 'null)
(gather-string-chars)
(cons ch (gather-string-chars)))))
(#\"
(advance-char)
'())
((graphic #\space)
(let ((ch *char*))
(advance-char)
(cons ch (gather-string-chars))))
(#\newline
(signal-missing-string-quote)
'())
(else
(signal-bad-string-constant *char*)
(advance-char)
(gather-string-chars))))
(define (signal-missing-string-quote)
(lexer-error 'missing-string-quote
"String continued over end of line."))
(define (signal-bad-string-constant ch)
(lexer-error 'bad-string-constant
"The character `~a' may not appear in a string literal." ch))
(define (convert-stupid-control-character-names)
(let ((c1 *char*)
(c2 *peek-char*))
(advance-char)
(advance-char)
(let ((s2 (string c1 c2))
(s3 (string c1 c2 *char*)))
(let ((srch3 (assoc s3 *control-char-names*)))
(cond (srch3
(advance-char)
(integer->char (cdr srch3)))
(else
(let ((srch2 (assoc s2 *control-char-names*)))
(cond (srch2
(integer->char (cdr srch2)))
(else
(signal-bad-control-char s3)
`#\?)))))))))
(define (signal-bad-control-char name)
(lexer-error 'invalid-control-char
"`~a' is not a recognized control character name." name))
(define (lex-escaped-char in-string?)
(advance-char)
(char-case *char*
((#\a #\b #\f #\n #\r #\t #\v)
(let* ((ccode (cdr (assoc *char* *short-control-char-names*)))
(ccode1 (cdr (assoc ccode *control-char-names*))))
(advance-char)
(integer->char ccode1)))
((#\\ #\' #\")
(let ((ch *char*))
(advance-char)
ch))
(#\&
(advance-char)
(cond (in-string? 'null)
(else
(signal-bad-&-escape)
'#\?)))
(#\^
;; *** This code is problematic because it assumes
;; *** (1) that you can do the arithmetic on the character codes
;; *** (2) that the resulting integer can actually be coerced to
;; *** the right character object in the host Lisp.
(advance-char)
(char-case *char*
((large #\@ #\[ #\\ #\] #\^ #\_)
(let ((code (+ (- (char->integer *char*)
(char->integer '#\A))
*control-A*)))
(advance-char)
(integer->char code)))
(else
(signal-bad-^-escape *char*)
'#\?)))
(large
(convert-stupid-control-character-names))
(digit
(convert-num-to-char (lex-integer 10)))
(#\o
(advance-char)
(cond ((char->digit *char* 8)
(convert-num-to-char (lex-integer 8)))
(else
(signal-missing-octal-digits)
'#\?)))
(#\x
(advance-char)
(cond ((char->digit *char* 16)
(convert-num-to-char (lex-integer 16)))
(else
(signal-missing-hex-digits)
`#\?)))
(whitechar
(cond (in-string?
(lex-gap))
(else
(signal-bad-gap)
`#\?)))
(else
(signal-bad-escape *char*)
`#\?)))
(define (signal-bad-&-escape)
(lexer-error 'bad-&-escape
"The escape `\\&' is not allowed inside a character literal."))
(define (signal-bad-^-escape ch)
(lexer-error 'bad-^-escape
"The escape `\\^~a' is not recognized." ch))
(define (signal-missing-octal-digits)
(lexer-error 'missing-octal-digits
"No digits provided for `\\o' escape."))
(define (signal-missing-hex-digits)
(lexer-error 'missing-hex-digits
"No digits provided for `\\x' escape."))
(define (signal-bad-gap)
(lexer-error 'invalid-gap
"Gaps are not allowed inside character literals."))
(define (signal-bad-escape ch)
(lexer-error 'bad-escape
"The escape `\\~a' is not recognized." ch))
;;; *** This code is problematic because it assumes that integers
;;; *** between 0 and 255 map on to characters with the corresponding
;;; *** ASCII encoding in the host Lisp, and that the host Lisp actually
;;; *** supports 255 characters.
(define (convert-num-to-char num)
(cond ((and (>= num 0) (>= *max-char* num))
(integer->char num))
(else
(signal-char-out-of-range num)
'#\?)))
(define (signal-char-out-of-range num)
(lexer-error 'char-out-of-range
"There is no character corresponding to code ~s." num))
(define (lex-gap)
(cond (*at-eof?*
(signal-eof-in-gap)
'null)
(else
(char-case *char*
(whitechar
(advance-char)
(lex-gap))
(#\\
(advance-char)
'null)
(else
(signal-missing-gap)
'null)))))
(define (signal-eof-in-gap)
(lexer-error 'eof-in-gap
"End of file encountered inside gap."))
(define (signal-missing-gap)
(lexer-error 'missing-gap
"Missing gap delimiter, or junk inside gap."))