lexer.scm 17 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431
  1. ;;; Guile Emacs Lisp
  2. ;;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc.
  3. ;;;
  4. ;;; This library is free software; you can redistribute it and/or
  5. ;;; modify it under the terms of the GNU Lesser General Public
  6. ;;; License as published by the Free Software Foundation; either
  7. ;;; version 3 of the License, or (at your option) any later version.
  8. ;;;
  9. ;;; This library is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;;; Lesser General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU Lesser General Public
  15. ;;; License along with this library; if not, write to the Free Software
  16. ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17. ;;; Code:
  18. (define-module (language elisp lexer)
  19. #:use-module (ice-9 regex)
  20. #:export (get-lexer get-lexer/1))
  21. ;;; This is the lexical analyzer for the elisp reader. It is
  22. ;;; hand-written instead of using some generator. I think this is the
  23. ;;; best solution because of all that fancy escape sequence handling and
  24. ;;; the like.
  25. ;;;
  26. ;;; Characters are handled internally as integers representing their
  27. ;;; code value. This is necessary because elisp allows a lot of fancy
  28. ;;; modifiers that set certain high-range bits and the resulting values
  29. ;;; would not fit into a real Scheme character range. Additionally,
  30. ;;; elisp wants characters as integers, so we just do the right thing...
  31. ;;;
  32. ;;; TODO: #@count comments
  33. ;;; Report an error from the lexer (that is, invalid input given).
  34. (define (lexer-error port msg . args)
  35. (apply error msg args))
  36. ;;; In a character, set a given bit. This is just some bit-wise or'ing
  37. ;;; on the characters integer code and converting back to character.
  38. (define (set-char-bit chr bit)
  39. (logior chr (ash 1 bit)))
  40. ;;; Check if a character equals some other. This is just like char=?
  41. ;;; except that the tested one could be EOF in which case it simply
  42. ;;; isn't equal.
  43. (define (is-char? tested should-be)
  44. (and (not (eof-object? tested))
  45. (char=? tested should-be)))
  46. ;;; For a character (as integer code), find the real character it
  47. ;;; represents or #\nul if out of range. This is used to work with
  48. ;;; Scheme character functions like char-numeric?.
  49. (define (real-character chr)
  50. (if (< chr 256)
  51. (integer->char chr)
  52. #\nul))
  53. ;;; Return the control modified version of a character. This is not
  54. ;;; just setting a modifier bit, because ASCII conrol characters must be
  55. ;;; handled as such, and in elisp C-? is the delete character for
  56. ;;; historical reasons. Otherwise, we set bit 26.
  57. (define (add-control chr)
  58. (let ((real (real-character chr)))
  59. (if (char-alphabetic? real)
  60. (- (char->integer (char-upcase real)) (char->integer #\@))
  61. (case real
  62. ((#\?) 127)
  63. ((#\@) 0)
  64. (else (set-char-bit chr 26))))))
  65. ;;; Parse a charcode given in some base, basically octal or hexadecimal
  66. ;;; are needed. A requested number of digits can be given (#f means it
  67. ;;; does not matter and arbitrary many are allowed), and additionally
  68. ;;; early return allowed (if fewer valid digits are found). These
  69. ;;; options are all we need to handle the \u, \U, \x and \ddd (octal
  70. ;;; digits) escape sequences.
  71. (define (charcode-escape port base digits early-return)
  72. (let iterate ((result 0)
  73. (procdigs 0))
  74. (if (and digits (>= procdigs digits))
  75. result
  76. (let* ((cur (read-char port))
  77. (value (cond
  78. ((char-numeric? cur)
  79. (- (char->integer cur) (char->integer #\0)))
  80. ((char-alphabetic? cur)
  81. (let ((code (- (char->integer (char-upcase cur))
  82. (char->integer #\A))))
  83. (if (< code 0)
  84. #f
  85. (+ code 10))))
  86. (else #f)))
  87. (valid (and value (< value base))))
  88. (if (not valid)
  89. (if (or (not digits) early-return)
  90. (begin
  91. (unread-char cur port)
  92. result)
  93. (lexer-error port
  94. "invalid digit in escape-code"
  95. base
  96. cur))
  97. (iterate (+ (* result base) value) (1+ procdigs)))))))
  98. ;;; Read a character and process escape-sequences when necessary. The
  99. ;;; special in-string argument defines if this character is part of a
  100. ;;; string literal or a single character literal, the difference being
  101. ;;; that in strings the meta modifier sets bit 7, while it is bit 27 for
  102. ;;; characters.
  103. (define basic-escape-codes
  104. '((#\a . 7)
  105. (#\b . 8)
  106. (#\t . 9)
  107. (#\n . 10)
  108. (#\v . 11)
  109. (#\f . 12)
  110. (#\r . 13)
  111. (#\e . 27)
  112. (#\s . 32)
  113. (#\d . 127)))
  114. (define (get-character port in-string)
  115. (let ((meta-bits `((#\A . 22)
  116. (#\s . 23)
  117. (#\H . 24)
  118. (#\S . 25)
  119. (#\M . ,(if in-string 7 27))))
  120. (cur (read-char port)))
  121. (if (char=? cur #\\)
  122. ;; Handle an escape-sequence.
  123. (let* ((escaped (read-char port))
  124. (esc-code (assq-ref basic-escape-codes escaped))
  125. (meta (assq-ref meta-bits escaped)))
  126. (cond
  127. ;; Meta-check must be before esc-code check because \s- must
  128. ;; be recognized as the super-meta modifier if a - follows.
  129. ;; If not, it will be caught as \s -> space escape code.
  130. ((and meta (is-char? (peek-char port) #\-))
  131. (if (not (char=? (read-char port) #\-))
  132. (error "expected - after control sequence"))
  133. (set-char-bit (get-character port in-string) meta))
  134. ;; One of the basic control character escape names?
  135. (esc-code esc-code)
  136. ;; Handle \ddd octal code if it is one.
  137. ((and (char>=? escaped #\0) (char<? escaped #\8))
  138. (begin
  139. (unread-char escaped port)
  140. (charcode-escape port 8 3 #t)))
  141. ;; Check for some escape-codes directly or otherwise use the
  142. ;; escaped character literally.
  143. (else
  144. (case escaped
  145. ((#\^) (add-control (get-character port in-string)))
  146. ((#\C)
  147. (if (is-char? (peek-char port) #\-)
  148. (begin
  149. (if (not (char=? (read-char port) #\-))
  150. (error "expected - after control sequence"))
  151. (add-control (get-character port in-string)))
  152. escaped))
  153. ((#\x) (charcode-escape port 16 #f #t))
  154. ((#\u) (charcode-escape port 16 4 #f))
  155. ((#\U) (charcode-escape port 16 8 #f))
  156. (else (char->integer escaped))))))
  157. ;; No escape-sequence, just the literal character. But remember
  158. ;; to get the code instead!
  159. (char->integer cur))))
  160. ;;; Read a symbol or number from a port until something follows that
  161. ;;; marks the start of a new token (like whitespace or parentheses).
  162. ;;; The data read is returned as a string for further conversion to the
  163. ;;; correct type, but we also return what this is
  164. ;;; (integer/float/symbol). If any escaped character is found, it must
  165. ;;; be a symbol. Otherwise we at the end check the result-string
  166. ;;; against regular expressions to determine if it is possibly an
  167. ;;; integer or a float.
  168. (define integer-regex (make-regexp "^[+-]?[0-9]+\\.?$"))
  169. (define float-regex
  170. (make-regexp
  171. "^[+-]?([0-9]+\\.?[0-9]*|[0-9]*\\.?[0-9]+)(e[+-]?[0-9]+)?$"))
  172. ;;; A dot is also allowed literally, only a single dort alone is parsed
  173. ;;; as the 'dot' terminal for dotted lists.
  174. (define no-escape-punctuation (string->char-set "-+=*/_~!@$%^&:<>{}?."))
  175. (define (get-symbol-or-number port)
  176. (let iterate ((result-chars '())
  177. (had-escape #f))
  178. (let* ((c (read-char port))
  179. (finish (lambda ()
  180. (let ((result (list->string
  181. (reverse result-chars))))
  182. (values
  183. (cond
  184. ((and (not had-escape)
  185. (regexp-exec integer-regex result))
  186. 'integer)
  187. ((and (not had-escape)
  188. (regexp-exec float-regex result))
  189. 'float)
  190. (else 'symbol))
  191. result))))
  192. (need-no-escape? (lambda (c)
  193. (or (char-numeric? c)
  194. (char-alphabetic? c)
  195. (char-set-contains?
  196. no-escape-punctuation
  197. c)))))
  198. (cond
  199. ((eof-object? c) (finish))
  200. ((need-no-escape? c) (iterate (cons c result-chars) had-escape))
  201. ((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
  202. (else
  203. (unread-char c port)
  204. (finish))))))
  205. ;;; Parse a circular structure marker without the leading # (which was
  206. ;;; already read and recognized), that is, a number as identifier and
  207. ;;; then either = or #.
  208. (define (get-circular-marker port)
  209. (call-with-values
  210. (lambda ()
  211. (let iterate ((result 0))
  212. (let ((cur (read-char port)))
  213. (if (char-numeric? cur)
  214. (let ((val (- (char->integer cur) (char->integer #\0))))
  215. (iterate (+ (* result 10) val)))
  216. (values result cur)))))
  217. (lambda (id type)
  218. (case type
  219. ((#\#) `(circular-ref . ,id))
  220. ((#\=) `(circular-def . ,id))
  221. (else (lexer-error port
  222. "invalid circular marker character"
  223. type))))))
  224. ;;; Main lexer routine, which is given a port and does look for the next
  225. ;;; token.
  226. (define lexical-binding-regexp
  227. (make-regexp
  228. "-\\*-(|.*;)[ \t]*lexical-binding:[ \t]*([^;]*[^ \t;]).*-\\*-"))
  229. (define (lex port)
  230. (define (lexical-binding-value string)
  231. (and=> (regexp-exec lexical-binding-regexp string)
  232. (lambda (match)
  233. (not (member (match:substring match 2) '("nil" "()"))))))
  234. (let* ((return (let ((file (if (file-port? port)
  235. (port-filename port)
  236. #f))
  237. (line (1+ (port-line port)))
  238. (column (1+ (port-column port))))
  239. (lambda (token value)
  240. (let ((obj (cons token value)))
  241. (set-source-property! obj 'filename file)
  242. (set-source-property! obj 'line line)
  243. (set-source-property! obj 'column column)
  244. obj))))
  245. ;; Read afterwards so the source-properties are correct above
  246. ;; and actually point to the very character to be read.
  247. (c (read-char port)))
  248. (cond
  249. ;; End of input must be specially marked to the parser.
  250. ((eof-object? c) (return 'eof c))
  251. ;; Whitespace, just skip it.
  252. ((char-whitespace? c) (lex port))
  253. ;; The dot is only the one for dotted lists if followed by
  254. ;; whitespace. Otherwise it is considered part of a number of
  255. ;; symbol.
  256. ((and (char=? c #\.)
  257. (char-whitespace? (peek-char port)))
  258. (return 'dot #f))
  259. ;; Continue checking for literal character values.
  260. (else
  261. (case c
  262. ;; A line comment, skip until end-of-line is found.
  263. ((#\;)
  264. (if (= (port-line port) 0)
  265. (let iterate ((chars '()))
  266. (let ((cur (read-char port)))
  267. (if (or (eof-object? cur) (char=? cur #\newline))
  268. (let ((string (list->string (reverse chars))))
  269. (return 'set-lexical-binding-mode!
  270. (lexical-binding-value string)))
  271. (iterate (cons cur chars)))))
  272. (let iterate ()
  273. (let ((cur (read-char port)))
  274. (if (or (eof-object? cur) (char=? cur #\newline))
  275. (lex port)
  276. (iterate))))))
  277. ;; A character literal.
  278. ((#\?)
  279. (return 'character (get-character port #f)))
  280. ;; A literal string. This is mainly a sequence of characters
  281. ;; just as in the character literals, the only difference is
  282. ;; that escaped newline and space are to be completely ignored
  283. ;; and that meta-escapes set bit 7 rather than bit 27.
  284. ((#\")
  285. (let iterate ((result-chars '()))
  286. (let ((cur (read-char port)))
  287. (case cur
  288. ((#\")
  289. (return 'string (list->string (reverse result-chars))))
  290. ((#\\)
  291. (let ((escaped (read-char port)))
  292. (case escaped
  293. ((#\newline #\space)
  294. (iterate result-chars))
  295. (else
  296. (unread-char escaped port)
  297. (unread-char cur port)
  298. (iterate
  299. (cons (integer->char (get-character port #t))
  300. result-chars))))))
  301. (else (iterate (cons cur result-chars)))))))
  302. ((#\#)
  303. (let ((c (read-char port)))
  304. (case c
  305. ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  306. (unread-char c port)
  307. (let ((mark (get-circular-marker port)))
  308. (return (car mark) (cdr mark))))
  309. ((#\')
  310. (return 'function #f))
  311. ((#\:)
  312. (call-with-values
  313. (lambda () (get-symbol-or-number port))
  314. (lambda (type str)
  315. (return 'symbol (make-symbol str))))))))
  316. ;; Parentheses and other special-meaning single characters.
  317. ((#\() (return 'paren-open #f))
  318. ((#\)) (return 'paren-close #f))
  319. ((#\[) (return 'square-open #f))
  320. ((#\]) (return 'square-close #f))
  321. ((#\') (return 'quote #f))
  322. ((#\`) (return 'backquote #f))
  323. ;; Unquote and unquote-splicing.
  324. ((#\,)
  325. (if (is-char? (peek-char port) #\@)
  326. (if (not (char=? (read-char port) #\@))
  327. (error "expected @ in unquote-splicing")
  328. (return 'unquote-splicing #f))
  329. (return 'unquote #f)))
  330. ;; Remaining are numbers and symbols. Process input until next
  331. ;; whitespace is found, and see if it looks like a number
  332. ;; (float/integer) or symbol and return accordingly.
  333. (else
  334. (unread-char c port)
  335. (call-with-values
  336. (lambda () (get-symbol-or-number port))
  337. (lambda (type str)
  338. (case type
  339. ((symbol)
  340. ;; str could be empty if the first character is already
  341. ;; something not allowed in a symbol (and not escaped)!
  342. ;; Take care about that, it is an error because that
  343. ;; character should have been handled elsewhere or is
  344. ;; invalid in the input.
  345. (if (zero? (string-length str))
  346. (begin
  347. ;; Take it out so the REPL might not get into an
  348. ;; infinite loop with further reading attempts.
  349. (read-char port)
  350. (error "invalid character in input" c))
  351. (return 'symbol (string->symbol str))))
  352. ((integer)
  353. ;; In elisp, something like "1." is an integer, while
  354. ;; string->number returns an inexact real. Thus we need
  355. ;; a conversion here, but it should always result in an
  356. ;; integer!
  357. (return
  358. 'integer
  359. (let ((num (inexact->exact (string->number str))))
  360. (if (not (integer? num))
  361. (error "expected integer" str num))
  362. num)))
  363. ((float)
  364. (return 'float (let ((num (string->number str)))
  365. (if (exact? num)
  366. (error "expected inexact float"
  367. str
  368. num))
  369. num)))
  370. (else (error "wrong number/symbol type" type)))))))))))
  371. ;;; Build a lexer thunk for a port. This is the exported routine which
  372. ;;; can be used to create a lexer for the parser to use.
  373. (define (get-lexer port)
  374. (lambda () (lex port)))
  375. ;;; Build a special lexer that will only read enough for one expression
  376. ;;; and then always return end-of-input. If we find one of the quotation
  377. ;;; stuff, one more expression is needed in any case.
  378. (define (get-lexer/1 port)
  379. (let ((lex (get-lexer port))
  380. (finished #f)
  381. (paren-level 0))
  382. (lambda ()
  383. (if finished
  384. (cons 'eof ((@ (ice-9 binary-ports) eof-object)))
  385. (let ((next (lex))
  386. (quotation #f))
  387. (case (car next)
  388. ((paren-open square-open)
  389. (set! paren-level (1+ paren-level)))
  390. ((paren-close square-close)
  391. (set! paren-level (1- paren-level)))
  392. ((quote backquote unquote unquote-splicing circular-def)
  393. (set! quotation #t)))
  394. (if (and (not quotation) (<= paren-level 0))
  395. (set! finished #t))
  396. next)))))