src/parser/scanner-impl.lisp: Location protocol for `string-scanner'.
[sod] / src / parser / scanner-impl.lisp
1 ;;; -*-lisp-*-
2 ;;;
3 ;;; Basic scanner interface
4 ;;;
5 ;;; (c) 2009 Straylight/Edgeware
6 ;;;
7
8 ;;;----- Licensing notice ---------------------------------------------------
9 ;;;
10 ;;; This file is part of the Sensible Object Design, an object system for C.
11 ;;;
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
16 ;;;
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
25
26 (cl:in-package #:sod-parser)
27
28 ;;;--------------------------------------------------------------------------
29 ;;; Common scanner implementation..
30
31 (defmethod file-location ((scanner character-scanner))
32 (scanner-file-location scanner))
33
34 (defmethod file-location ((scanner token-scanner))
35 (scanner-file-location scanner))
36
37 ;;;--------------------------------------------------------------------------
38 ;;; Streams on character scanners.
39
40 (defmethod stream-read-char ((stream character-scanner-stream))
41 (with-slots (scanner) stream
42 (if (scanner-at-eof-p scanner)
43 :eof
44 (prog1 (scanner-current-char scanner)
45 (scanner-step scanner)))))
46
47 (defmethod stream-unread-char ((stream character-scanner-stream) char)
48 (with-slots (scanner) stream
49 (scanner-unread scanner char)))
50
51 (defmethod stream-peek-char ((stream character-scanner-stream))
52 (with-slots (scanner) stream
53 (scanner-current-char scanner)))
54
55 ;;;--------------------------------------------------------------------------
56 ;;; String scanner.
57
58 ;; This is much more convenient for testing lexers than the full character
59 ;; buffer scanner.
60
61 (export '(string-scanner make-string-scanner string-scanner-p))
62 (defstruct (string-scanner
63 (:constructor make-string-scanner
64 (string &key (start 0) end filename
65 &aux (%string string)
66 (index start)
67 (limit (or end (length string))))))
68 "Scanner structure for a simple string scanner."
69 (%string "" :type string :read-only t)
70 (filename "<string>" :type string :read-only t)
71 (index 0 :type (and fixnum unsigned-byte))
72 (limit nil :type (and fixnum unsigned-byte) :read-only t)
73 (line 1 :type fixnum)
74 (column 0 :type fixnum))
75 (define-access-wrapper string-scanner-string string-scanner-%string
76 :read-only t)
77
78 (defmethod scanner-at-eof-p ((scanner string-scanner))
79 (>= (string-scanner-index scanner) (string-scanner-limit scanner)))
80
81 (defmethod scanner-current-char ((scanner string-scanner))
82 (char (string-scanner-string scanner) (string-scanner-index scanner)))
83
84 (defmethod scanner-step ((scanner string-scanner))
85 (let ((index (string-scanner-index scanner)))
86 (setf (values (string-scanner-line scanner)
87 (string-scanner-column scanner))
88 (update-position (char (string-scanner-string scanner) index)
89 (string-scanner-line scanner)
90 (string-scanner-column scanner))
91 (string-scanner-index scanner) (1+ index))))
92
93 (defmethod scanner-unread ((scanner string-scanner) char)
94 (let ((index (1- (string-scanner-index scanner))))
95 (setf (values (string-scanner-line scanner)
96 (string-scanner-column scanner))
97 (backtrack-position (char (string-scanner-string scanner) index)
98 (string-scanner-line scanner)
99 (string-scanner-column scanner))
100 (string-scanner-index scanner) index)))
101
102 (defmethod scanner-filename ((scanner string-scanner))
103 (string-scanner-filename scanner))
104 (defmethod scanner-line ((scanner string-scanner))
105 (string-scanner-line scanner))
106 (defmethod scanner-column ((scanner string-scanner))
107 (string-scanner-column scanner))
108 (defmethod file-location ((scanner string-scanner))
109 (make-file-location (string-scanner-filename scanner)
110 (string-scanner-line scanner)
111 (string-scanner-column scanner)))
112
113 (defmethod scanner-capture-place ((scanner string-scanner))
114 (string-scanner-index scanner))
115
116 (defmethod scanner-restore-place ((scanner string-scanner) place)
117 (setf (string-scanner-index scanner) place))
118
119 (defmethod scanner-interval
120 ((scanner string-scanner) place-a &optional place-b)
121 (with-slots ((string %string) index) scanner
122 (subseq string place-a (or place-b index))))
123
124 (defmethod make-scanner-stream ((scanner string-scanner))
125 (make-instance 'character-scanner-stream :scanner scanner))
126
127 ;;;--------------------------------------------------------------------------
128 ;;; List scanner.
129
130 (export '(list-scanner list-scanner-p make-list-scanner))
131 (defstruct (list-scanner
132 (:constructor make-list-scanner (list &aux (%list list))))
133 "Simple token scanner for lists.
134
135 The list elements are the token semantic values; the token types are the
136 names of the elements' classes. This is just about adequate for testing
137 purposes, but is far from ideal for real use."
138 (%list nil :type list))
139 (define-access-wrapper list-scanner-list list-scanner-%list)
140
141 (defmethod scanner-step ((scanner list-scanner))
142 (pop (list-scanner-list scanner)))
143
144 (defmethod scanner-at-eof-p ((scanner list-scanner))
145 (null (list-scanner-list scanner)))
146
147 (defmethod token-type ((scanner list-scanner))
148 (class-name (class-of (car (list-scanner-list scanner)))))
149
150 (defmethod token-value ((scanner list-scanner))
151 (car (list-scanner-list scanner)))
152
153 (defmethod scanner-capture-place ((scanner list-scanner))
154 (list-scanner-list scanner))
155
156 (defmethod scanner-restore-place ((scanner list-scanner) place)
157 (setf (list-scanner-list scanner) place))
158
159 ;;;----- That's all, folks --------------------------------------------------