blob: 25d86d492cb8f6b75eedae1ea5deedc599384797 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
(defpackage #:clex
(:use #:common-lisp #:cutil)
(:export
#:<lint>
#:<lsymbol>
#:<lstring>
#:<lend>
#:<lident>
#:ident
#:lexer))
(in-package #:clex)
(defclass <lexeme> () () (:metaclass <abstract-class>))
(defclass <lint> (<lexeme>) ((int :reader int)))
(defclass <lident> (<lexeme>) ((ident :reader ident)))
(defclass <lsymbol> (<lexeme>) ((lsymbol :reader lsymbol)))
(defclass <lstring> (<lexeme>) ((lstring :reader lstring)))
(defclass <lend> (<lexeme>) ())
(defclass <string-lexer> () ((lstring :initarg :s :accessor lstring)
(current :initform 0 :accessor current)
(size :accessor size)))
(defmethod initialize-object :after ((self <string-lexer>) initargs)
(setf (size self) (length (lstring self))))
(defgeneric forward (cl &rest args))
(defmethod forward ((cl <string-lexer>) &rest args)
(let ((incr (if (null args)
1
(car args))))
(setf (current cl) (+ (current cl) incr))))
(defgeneric extract (pred cl))
(defmethod extract (pred (cl <string-lexer>))
(let* ((st (lstring cl))
(pos (current cl))
(res nil))
(labels ((ext (n)
(if (and (< n (size cl)) (funcall pred (elt st n)))
(ext (+ n 1))
n)))
(setq res (ext pos))
(setf (current cl) res)
(subseq (lstring cl) pos (- res pos)))))
(defgeneric extract-int (cl))
(defmethod extract-int ((cl <string-lexer>))
(flet ((is-int (x)
(and (char>= x #\0) (char<= x #\9))))
(parse-integer (extract #'is-int cl))))
(defgeneric extract-ident (cl))
(defmethod extract-ident ((cl <string-lexer>))
(flet ((is-alpha-num (x)
(or (and (char>= x #\a) (char<= x #\z))
(and (char>= x #\A) (char<= x #\Z))
(and (char>= x #\0) (char<= x #\9))
(char= x #\_))))
(extract #'is-alpha-num cl)))
(defgeneric lexer (cl))
(defmethod lexer ((cl <string-lexer>))
(flet ((lexer-char (c)
(cond ((member c '(#\space #\tab))
(forward cl)
(lexer cl)) ; NB: tail recursion. ok?
((or (and (char>= c #\a) (char<= c #\z))
(and (char>= c #\A) (char<= c #\Z)))
(make-instance (find-class '<lident>) 'i (extract-ident cl)))
((char= c #\")
(forward cl)
(let ((res (make-instance (find-class '<lstring>) 's (extract (lambda (c) (char/= c #\")) cl))))
(forward cl)
res))
((member c '(#\+ #\- #\* #\/ #\% #\& #\| #\! #\= #\( #\)))
(forward cl)
(make-instance (find-class '<lsymbol>) 's (string c)))
((member c '(#\< #\>))
(forward cl)
))))))
(provide "clex")
|