Coverage report: /home/ellis/comp/core/lib/parse/lex.lisp

KindCoveredAll%
expression78220 35.5
branch428 14.3
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; lib/parse/lex.lisp --- Lexer Tools
2
 
3
 ;; https://github.com/Shinmera/plump/blob/master/lexer.lisp
4
 
5
 ;;; Commentary:
6
 
7
 ;; TODO: make less dynamic, compile lexer functions for compatibility
8
 ;; with PARSE/YACC.
9
 
10
 ;;; Code:
11
 (in-package :parse/lex)
12
 (declaim (optimize (speed 3) (safety 1)))
13
 (defvar *string*)
14
 (defvar *length*)
15
 (defvar *index*)
16
 (defvar *matchers* (make-hash-table))
17
 (declaim (fixnum *length* *index*)
18
          (simple-string *string*)
19
          (hash-table *matchers*))
20
 
21
 (defmacro with-lexer-environment ((string) &body body)
22
   `(let* ((*string* ,string)
23
           (*string* (etypecase *string*
24
                       (simple-string *string*)
25
                       (string (copy-seq *string*))))
26
           (*length* (length *string*))
27
           (*index* 0))
28
      (handler-bind ((error #'(lambda (err)
29
                                (declare (ignore err))
30
                                (format T "Error during lexing at index ~a~%" *index*))))
31
        ,@body)))
32
 
33
 (declaim (ftype (function () (or character null)) consume)
34
          (inline consume))
35
 (defun consume ()
36
   (declare (optimize (speed 3) (safety 0)))
37
   (when (< *index* *length*)
38
     (prog1 (aref *string* *index*)
39
       #+debug (format T "~a +~%" *index*)
40
       (incf *index*))))
41
 
42
 (declaim (ftype (function () (or fixnum null)) advance)
43
          (inline advance))
44
 (defun advance ()
45
   (declare (optimize (speed 3) (safety 0)))
46
   (when (< *index* *length*)
47
     #+debug (format T "~a +~%" *index*)
48
     (incf *index*)))
49
 
50
 (declaim (ftype (function () fixnum) unread)
51
          (inline unread))
52
 (defun unread ()
53
   (declare (optimize (speed 3) (safety 0)))
54
   (when (< 0 *index*)
55
     #+debug (format T "~a -~%" *index*)
56
     (decf *index*))
57
   *index*)
58
 
59
 (declaim (ftype (function () (or character null)) peek)
60
          (inline peek))
61
 (defun peek ()
62
   (declare (optimize (speed 3) (safety 0)))
63
   (when (< *index* *length*)
64
     #+debug (format T "~a ?~%" *index*)
65
     (aref *string* *index*)))
66
 
67
 (declaim (ftype (function (fixnum) fixnum) advance-n)
68
          (inline advance-n))
69
 (defun advance-n (n)
70
   (declare (optimize (speed 3) (safety 0)))
71
   (declare (fixnum n))
72
   #+debug (format T "~a +~d~%" *index* n)
73
   (incf *index* n)
74
   (when (<= *length* *index*)
75
     (setf *index* *length*))
76
   *index*)
77
 
78
 (declaim (ftype (function (fixnum) fixnum) unread-n)
79
          (inline unread-n))
80
 (defun unread-n (n)
81
   (declare (optimize (speed 3) (safety 0)))
82
   (declare (fixnum n))
83
   #+debug (format T "~a -~d~%" *index* n)
84
   (decf *index* n)
85
   (when (< *index* 0)
86
     (setf *index* 0))
87
   *index*)
88
 
89
 (declaim (ftype (function (function) string) consume-until))
90
 (defun consume-until (matcher)
91
   (declare (function matcher))
92
   (loop with start = *index*
93
         until (funcall matcher)
94
         while (advance)
95
         finally (return (subseq *string* start *index*))))
96
 
97
 (declaim (ftype (function (character) function) matcher-character))
98
 (defun matcher-character (character)
99
   #'(lambda ()
100
       (let ((char (peek)))
101
         (when char
102
           (char= char character)))))
103
 
104
 (declaim (ftype (function (simple-string) function) matcher-string))
105
 (defun matcher-string (string)
106
   (declare (simple-string string))
107
   (let ((len (length string)))
108
     #'(lambda ()
109
         (let ((len (+ *index* len)))
110
           (and (<= len *length*)
111
                (string= string *string* :start2 *index* :end2 len))))))
112
 
113
 (declaim (ftype (function ((or fixnum character string) (or fixnum character string)) function) matcher-range))
114
 (defun matcher-range (from to)
115
   (flet ((normalize (in) (etypecase in
116
                            (fixnum in)
117
                            (character (char-code in))
118
                            (simple-string (char-code (char in 0))))))
119
     (let ((from (normalize from))
120
           (to (normalize to)))
121
       #'(lambda ()
122
           (let ((char (peek)))
123
             (when char
124
               (<= from (char-code char) to)))))))
125
 
126
 (declaim (ftype (function (list) function) matcher-find))
127
 (defun matcher-find (list)
128
   #'(lambda ()
129
       (let ((char (peek)))
130
         (and char (member char list :test #'char=)))))
131
 
132
 (declaim (ftype (function (&rest function) function) matcher-or))
133
 (defun matcher-or (&rest matchers)
134
   #'(lambda ()
135
       (loop for matcher of-type function in matchers
136
             thereis (funcall matcher))))
137
 
138
 (declaim (ftype (function (&rest function) function) matcher-and))
139
 (defun matcher-and (&rest matchers)
140
   #'(lambda ()
141
       (loop for matcher of-type function in matchers
142
             always (funcall matcher))))
143
 
144
 (declaim (ftype (function (function) function) matcher-not))
145
 (defun matcher-not (matcher)
146
   (declare (function matcher))
147
   #'(lambda ()
148
       (not (funcall matcher))))
149
 
150
 (declaim (ftype (function (function) function) matcher-next))
151
 (defun matcher-next (matcher)
152
   #'(lambda ()
153
       (let ((*index* (1+ *index*)))
154
         (when (< *index* *length*)
155
           (funcall matcher)))))
156
 
157
 (declaim (ftype (function (function) function) matcher-prev))
158
 (defun matcher-prev (matcher)
159
   #'(lambda ()
160
       (let ((*index* (1- *index*)))
161
         (when (<= 0 *index*)
162
           (funcall matcher)))))
163
 
164
 (defmacro matcher-any (&rest is)
165
   `(matcher-or ,@(loop for i in is
166
                        collect `(,(typecase i
167
                                     (string 'matcher-string)
168
                                     (character 'matcher-character)
169
                                     (T 'matcher-string)) ,i))))
170
 
171
 (defmacro make-matcher (form)
172
   (labels ((transform (form)
173
              (etypecase form
174
                (keyword
175
                 `(gethash ',form *matchers*))
176
                (atom form)
177
                (T
178
                 (cons
179
                  (case (find-symbol (string (car form)) "PARSE/LEX")
180
                    (not 'matcher-not)
181
                    (and 'matcher-and)
182
                    (or 'matcher-or)
183
                    (is (typecase (second form)
184
                          (string 'matcher-string)
185
                          (character 'matcher-character)
186
                          (T 'matcher-string)))
187
                    (in 'matcher-range)
188
                    (next 'matcher-next)
189
                    (prev 'matcher-prev)
190
                    (any 'matcher-any)
191
                    (find 'matcher-find)
192
                    (T (car form)))
193
                  (mapcar #'transform (cdr form)))))))
194
     (transform form)))
195
 
196
 (defmacro define-matcher (name form)
197
   `(setf (gethash ,(intern (string name) "KEYWORD") *matchers*) (make-matcher ,form)))