Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Parser protocol implementation. | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
dea4d055 MW |
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 | ;;; Hairy functions used by parser syntax expanders. | |
30 | ||
31 | (declaim (inline %many)) | |
32 | (defun %many (update final parser &key (min 0) max) | |
33 | "Helper function for the `many' parser syntax. | |
34 | ||
35 | This deals with simple repetition, without separators. See the parser | |
36 | syntax documentation for details." | |
37 | ||
38 | (let ((consumed-any-p nil)) | |
39 | (do ((i 0 (1+ i))) | |
40 | ((and max (>= i max))) | |
41 | (multiple-value-bind (value winp consumep) (funcall parser) | |
42 | (when consumep (setf consumed-any-p t)) | |
43 | (cond (winp (funcall update value)) | |
44 | ((or consumep (< i min)) | |
45 | (return-from %many (values value nil consumed-any-p))) | |
46 | (t (return))))) | |
47 | (values (funcall final) t consumed-any-p))) | |
48 | ||
49 | (defun %many-sep (update final parser sep &key (min 1) max (commitp t)) | |
50 | "Helper function for the `many' parser syntax. | |
51 | ||
52 | This deals with the hairy separator and commit stuff. See the parser | |
53 | syntax documentation for details." | |
54 | ||
55 | (let ((consumed-any-p nil) | |
56 | (i 0)) | |
57 | (block nil | |
58 | (flet ((sep () | |
59 | (multiple-value-bind (value winp consumep) (funcall sep) | |
60 | (when consumep (setf consumed-any-p t)) | |
61 | (unless winp | |
62 | (if (and (>= i min) (not consumep)) (return) | |
63 | (return-from %many-sep | |
64 | (values value nil consumed-any-p)))))) | |
65 | ||
66 | (main (mustp) | |
67 | (multiple-value-bind (value winp consumep) (funcall parser) | |
68 | (when consumep (setf consumed-any-p t)) | |
69 | (cond (winp (funcall update value)) | |
70 | ((or mustp consumep (< i min)) | |
71 | (return-from %many-sep | |
72 | (values value nil consumed-any-p))) | |
73 | (t (return)))) | |
74 | (incf i))) | |
75 | ||
76 | (when (eql max 0) (return)) | |
77 | ||
78 | (main nil) | |
79 | ||
80 | (if commitp | |
81 | (loop (when (and max (>= i max)) (return)) (sep) (main t)) | |
82 | (loop (sep) (when (and max (>= i max)) (return)) (main nil))))) | |
83 | ||
84 | (values (funcall final) t consumed-any-p))) | |
85 | ||
86 | ;;;-------------------------------------------------------------------------- | |
87 | ;;; Token parser implementation. | |
88 | ||
89 | (defmethod parser-at-eof-p ((context token-parser-context)) | |
90 | `(eq ,(parser-token-type context) :eof)) | |
91 | ||
92 | ;;;-------------------------------------------------------------------------- | |
93 | ;;; Simple list-based parser; useful for testing. | |
94 | ||
95 | (export 'list-parser) | |
96 | (defclass list-parser () | |
97 | ((var :initarg :var :type symbol :reader parser-var))) | |
98 | ||
99 | (defmethod parser-at-eof-p ((context list-parser)) | |
100 | `(not ,(parser-var context))) | |
101 | ||
102 | (defmethod parser-capture-place ((context list-parser)) | |
103 | `,(parser-var context)) | |
104 | ||
105 | (defmethod parser-restore-place ((context list-parser) place) | |
106 | `(setf ,(parser-var context) ,place)) | |
107 | ||
108 | (defmethod expand-parser-spec ((context list-parser) parser) | |
109 | (if (atom parser) | |
110 | (expand-parser-form context 'quote (list parser)) | |
111 | (call-next-method))) | |
112 | ||
113 | (defparse quote (:context (context list-parser) object) | |
114 | `(if (and ,(parser-var context) | |
115 | (eql (car ,(parser-var context)) ',object)) | |
116 | (progn (pop ,(parser-var context)) (values ',object t t)) | |
117 | (values (list ',object) nil nil))) | |
118 | ||
119 | (defparse type (:context (context list-parser) type) | |
120 | `(if (and ,(parser-var context) | |
121 | (typep (car ,(parser-var context)) ',type)) | |
122 | (values (pop ,(parser-var context)) t t) | |
123 | (values (list ',type) nil nil))) | |
124 | ||
125 | (defmethod parser-places-must-be-released-p ((context list-parser)) nil) | |
126 | ||
127 | ;;;-------------------------------------------------------------------------- | |
128 | ;;; Simple string-based parser; useful for testing. | |
129 | ||
130 | (export 'string-parser) | |
131 | (defclass string-parser (character-parser-context) | |
4b8e5c03 | 132 | ((%string :initarg :string :reader parser-string) |
dea4d055 | 133 | (index :initarg :index :initform 0 :reader parser-index) |
4b8e5c03 | 134 | (%length :initform (gensym "LEN-") :reader parser-length))) |
dea4d055 MW |
135 | |
136 | (defmethod wrap-parser ((context string-parser) form) | |
4b8e5c03 | 137 | (with-slots ((string %string) index (length %length)) context |
dea4d055 MW |
138 | `(let* (,@(unless (symbolp string) |
139 | (let ((s string)) | |
140 | (setf string (gensym "STRING-")) | |
141 | `((,string ,s)))) | |
142 | ,@(unless (symbolp index) | |
143 | (let ((i index)) | |
144 | (setf index (gensym "INDEX-")) | |
145 | `((,index ,i)))) | |
146 | (,length (length ,string))) | |
147 | ,form))) | |
148 | ||
149 | (defmethod parser-at-eof-p ((context string-parser)) | |
150 | `(>= ,(parser-index context) ,(parser-length context))) | |
151 | ||
152 | (defmethod parser-current-char ((context string-parser)) | |
153 | `(char ,(parser-string context) ,(parser-index context))) | |
154 | ||
155 | (defmethod parser-step ((context string-parser)) | |
156 | `(incf ,(parser-index context))) | |
157 | ||
158 | (defmethod parser-capture-place ((context string-parser)) | |
159 | `,(parser-index context)) | |
160 | ||
161 | (defmethod parser-restore-place ((context string-parser) place) | |
162 | `(setf ,(parser-index context) ,place)) | |
163 | ||
164 | (defmethod parser-places-must-be-released-p ((context string-parser)) nil) | |
165 | ||
166 | ;;;----- That's all, folks -------------------------------------------------- |