| 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 |
| 30 | (and (skip-many () (not #\*)) |
| 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)))))) |