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))
11 (numeric (radix sigil)
12 (parse (seq ((first (peek (seq ((nil (funcall sigil))
15 (result (number radix first)))
17 (multiple-value-call #'values
23 ;; Give up at end-of-file.
25 (return (values :eof nil)))
29 (parse (skip-many () ; this may fail at eof; don't worry
30 (and (skip-many () (not #\*))
31 (skip-many (:min 1) #\*))
34 (cerror* "Unterminated comment")
36 ((and (peek (seq (#\/ #\/)))
37 (skip-many () (not #\newline))
40 ;; Quoted strings and characters.
43 (out (make-string-output-stream)))
45 (or (seq ((ch (satisfies (lambda (ch)
47 (char/= ch quote))))))
50 (write-char ch out)))))
52 (cerror* "Unterminated ~:[string~;character~] constant"
55 (let ((string (get-output-stream-string out)))
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 ~
64 (return (values :char (char string 0))))))))))
67 ((seq ((first (satisfies (lambda (ch)
70 (ident (many (out (let ((s (make-string-output-stream)))
73 (progn (write-char it out) out)
74 :final (get-output-stream-string out))
75 (satisfies (lambda (ch)
77 (alphanumericp ch)))))))
78 (return (values :id ident))))
80 ;; Numbers -- uses the machinery in the labels above.
82 (i (or (numeric 8 (parser () (or #\o #\O)))
83 (numeric 16 (parser () (or #\x #\X)))
86 (seq ((first (digit 10))
87 (rest (number 10 first)))
89 (return (values :integer it)))
91 ;; Special separator tokens.
93 (return (values :ellipsis :ellipsis)))
95 ;; Anything else is a standalone delimiter character.
97 (return (values it it)))))
98 (parse (list () :any))))))