Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | (cl:in-package #:sod) |
2 | ||
3 | (defun play-fetch-token (string) | |
4 | (with-parser-context (string-parser :string string) | |
5 | (labels ((digit (radix) | |
6 | (parse (filter (lambda (ch) | |
7 | (digit-char-p ch radix))))) | |
8 | (number (radix &optional (initial 0)) | |
9 | (parse (many (a initial (+ (* radix a) it)) | |
10 | (digit radix)))) | |
11 | (numeric (radix sigil) | |
12 | (parse (seq ((first (peek (seq ((nil (funcall sigil)) | |
13 | (d (digit radix))) | |
14 | d))) | |
15 | (result (number radix first))) | |
16 | result)))) | |
17 | (multiple-value-call #'values | |
18 | (loop | |
19 | (parse :whitespace) | |
20 | ||
21 | (cond-parse () | |
22 | ||
23 | ;; Give up at end-of-file. | |
24 | (:eof | |
25 | (return (values :eof nil))) | |
26 | ||
27 | ;; Pick out comments. | |
28 | ((peek (and #\/ #\*)) | |
29 | (parse (skip-many () ; this may fail at eof; don't worry | |
3109662a | 30 | (and (skip-many () (not #\*)) |
dea4d055 MW |
31 | (skip-many (:min 1) #\*)) |
32 | (not #\/))) | |
33 | (if-parse :eof () | |
34 | (cerror* "Unterminated comment") | |
35 | (parse :any))) | |
36 | ((and (peek (seq (#\/ #\/))) | |
37 | (skip-many () (not #\newline)) | |
38 | (or :eof #\newline))) | |
39 | ||
40 | ;; Quoted strings and characters. | |
41 | ((or #\' #\") | |
42 | (let ((quote it) | |
43 | (out (make-string-output-stream))) | |
44 | (parse (skip-many () | |
45 | (or (seq ((ch (satisfies (lambda (ch) | |
46 | (and (char/= ch #\\) | |
47 | (char/= ch quote)))))) | |
48 | (write-char ch out)) | |
49 | (seq (#\\ (ch :any)) | |
50 | (write-char ch out))))) | |
51 | (if-parse :eof () | |
52 | (cerror* "Unterminated ~:[string~;character~] constant" | |
53 | (char= quote #\')) | |
54 | (parse :any)) | |
55 | (let ((string (get-output-stream-string out))) | |
56 | (ecase quote | |
57 | (#\" (return (values :string string))) | |
58 | (#\' (case (length string) | |
59 | (0 (cerror* "Empty character constant") | |
60 | (return (values :char #\?))) | |
61 | (1 (return (values :char (char string 0)))) | |
62 | (t (cerror* "Multiple characters in ~ | |
63 | character constant") | |
64 | (return (values :char (char string 0)))))))))) | |
65 | ||
66 | ;; Identifiers. | |
67 | ((seq ((first (satisfies (lambda (ch) | |
68 | (or (char= ch #\_) | |
69 | (alpha-char-p ch))))) | |
70 | (ident (many (out (let ((s (make-string-output-stream))) | |
71 | (write-char first s) | |
72 | s) | |
73 | (progn (write-char it out) out) | |
74 | :final (get-output-stream-string out)) | |
75 | (satisfies (lambda (ch) | |
76 | (or (char= ch #\_) | |
77 | (alphanumericp ch))))))) | |
78 | (return (values :id ident)))) | |
79 | ||
80 | ;; Numbers -- uses the machinery in the labels above. | |
81 | ((or (seq (#\0 | |
82 | (i (or (numeric 8 (parser () (or #\o #\O))) | |
83 | (numeric 16 (parser () (or #\x #\X))) | |
84 | (number 8)))) | |
85 | i) | |
86 | (seq ((first (digit 10)) | |
87 | (rest (number 10 first))) | |
88 | rest)) | |
89 | (return (values :integer it))) | |
90 | ||
91 | ;; Special separator tokens. | |
92 | ("..." | |
93 | (return (values :ellipsis :ellipsis))) | |
94 | ||
95 | ;; Anything else is a standalone delimiter character. | |
96 | (:any | |
97 | (return (values it it))))) | |
98 | (parse (list () :any)))))) |