add missing require
[emacsstuff.git] / cc-ide / recdesc.el
1 ;;; recdesc.el --- Generator for recursive-descent parsers
2 ;;
3 ;; Copyright (C) 2000,2007 Stefan Bund
4
5 ;; recdesc.el is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU General Public License as
7 ;; published by the Free Software Foundation; either version 2, or (at
8 ;; your option) any later version.
9
10 ;; recdesc.el is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;; General Public License for more details.
14
15 ;;; Commentary:
16
17 ;; Der Syntax einer term deklaration ist:
18
19 ;; <term-declaration> := (term <symbol> <arglist> <command>...)
20 ;;
21 ;; <command> := <directive>
22 ;;            | (collect <directive-or-form>)
23 ;;            | (return <form>)
24 ;; 
25 ;; <directive-or-form> := <directive> | <form>
26 ;; 
27 ;; <diretive> :=  (match <term> [<form>...])
28 ;;             |  (or <command>...)
29 ;;             |  (and <command>...)
30 ;;             |  (maybe <command>...)
31 ;;             |  (repeat <command>...)
32 ;;             |  (commit)
33 ;;             |  (fail)
34 ;;             |  (progn <lisp-code>...)
35 ;;
36 ;; <term> := <symbol> | <form>
37
38 ;; 
39 ;;
40
41 ;;; Change-Log:
42
43 ;; $Log: recdesc.el,v $
44 ;; Revision 1.3  2000/02/13 21:19:56  bund
45 ;; Erste vollständige version von SqIV2
46 ;;
47 ;; Revision 1.2  2000/02/03 10:15:19  bund
48 ;; *** empty log message ***
49 ;;
50 ;; Revision 1.1  2000/02/01 13:26:03  bund
51 ;; *** empty log message ***
52 ;;
53 ;;
54
55 ;;; Variables:
56
57 ;;; Code:
58
59 (require 'cl)
60
61 (declaim (special position))
62 (declaim (special string))
63 (declaim (special commit-flag))
64 (declaim (special saved-position))
65 (declaim (special saved-elements))
66 (declaim (special elements))
67 (declaim (special return-form))
68
69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
70 ;;
71 ;; Zunächst der Parser/Scanner zur deklaration von Termen
72
73 (defmacro recdesc-deferror (name message &rest classes)
74   `(progn
75      (put ',name 'error-conditions '(error sqi-error ,@classes ,name))
76      (put ',name 'error-message ,message)))
77
78 (defmacro recdesc-declare (&rest forms)
79   (cons 'progn
80         (loop for form in forms
81               collect (if (and (consp form)
82                                (eq (car form) 'term)
83                                (consp (cdr form))
84                                (symbolp (cadr form))
85                                (consp (cddr form))
86                                (listp (caddr form)))
87                           (recdesc-declare-term (cadr form)
88                                                     (caddr form)
89                                                     (cdddr form))
90                         (signal 'recdesc-invalid-decl-component
91                                 (list form))))))
92
93 (recdesc-deferror recdesc-invalid-decl-component
94   "Invalid component in recdesc-declare" recdesc-error)
95
96 (defun recdesc-declare-term (name arglist body)
97   (let (return-form)
98     `(defun ,(intern (concat "recdesc@@" (symbol-name name))) ,arglist
99        (let (elements)
100          (or (and ,(recdesc-parse-directive/and body)
101                   ,(if return-form
102                        return-form
103                      '(or elements t))))))))
104
105 (defun recdesc-parse-command (command)
106   (if (not (consp command))
107       (signal 'recdesc-invalid-command
108               (list command)))
109   (cond ((eq (car command) 'return)
110          (if (not (consp (cdr command)))
111              (signal 'recdesc-invalid-command
112                      (list command)))
113          (setq return-form (cadr command))
114          t)
115         ((eq (car command) 'collect)
116          (if (not (consp (cdr command)))
117              (signal 'recdesc-invalid-command (list command)))
118          `(recdesc-collect ,(recdesc-parse-directive-or-form (cadr command))))
119         (t (recdesc-parse-directive command))))
120
121 (recdesc-deferror recdesc-invalid-command
122   "Invalid scanner command" recdesc-error)
123
124 (defun recdesc-parse-directive-or-form (directive-or-form)
125   (or (recdesc-parse-directive directive-or-form t)
126       directive-or-form))
127
128 (defun recdesc-parse-directive (directive &optional nosignal)
129   (if (not (consp directive))
130       (if (not nosignal)
131           (signal 'recdesc-invalid-directive
132                   (list directive)))
133     (cond ((eq (car directive) 'match)   (recdesc-parse-directive/match   (cdr directive)))
134           ((eq (car directive) 'or)      (recdesc-parse-directive/or      (cdr directive)))
135           ((eq (car directive) 'and)     (recdesc-parse-directive/and     (cdr directive)))
136           ((eq (car directive) 'maybe)   (recdesc-parse-directive/maybe   (cdr directive)))
137           ((eq (car directive) 'repeat)  (recdesc-parse-directive/repeat  (cdr directive)))
138           ((eq (car directive) 'commit)  (recdesc-parse-directive/commit  (cdr directive)))
139           ((eq (car directive) 'fail)    (recdesc-parse-directive/fail    (cdr directive)))
140           ((eq (car directive) 'progn)   (recdesc-parse-directive/progn   (cdr directive)))
141           (t (if (not nosignal)
142                  (signal 'recdesc-invalid-directive
143                          (list directive)))))))
144
145 (recdesc-deferror recdesc-invalid-directive
146   "Invalid scanner directive" recdesc-error)
147
148 (defun recdesc-parse-directive/match (args)
149   (if (not (consp args))
150       (signal 'recdesc-invalid-match-arguments
151               (list args)))
152   (if (symbolp (car args))
153       (cons (intern (concat "recdesc@@" (symbol-name (car args))))
154             (cdr args))
155     (if (not (null (cdr args)))
156         (signal 'recdesc-invalid-match-arguments
157                 (list args)))
158     (list 'recdesc-match-regexp (car args))))
159
160 (recdesc-deferror recdesc-invalid-match-arguments
161   "Invalid arguments to match directive" recdesc-error)
162
163 (defun recdesc-parse-directive/or (args)
164   (if (not (consp args))
165       (signal 'recdesc-invalid-or-arguments
166               (list args)))
167   (cons 'or
168         (loop for command in args
169               collect (recdesc-parse-directive/and (list command)))))
170
171 (recdesc-deferror recdesc-invalid-or-arguments
172   "Invalid arguments to or directive" recdesc-error)
173
174 (defun recdesc-parse-directive/and (args)
175   (if (not (consp args))
176       (signal 'recdesc-invalid-and-arguments
177               (list args)))
178   `(let ((saved-position position)
179          (saved-elements elements)
180          commit-flag)
181      (or (and ,@(loop for command in args
182                       collect (recdesc-parse-command command)))
183          (recdesc-backtrack))))
184
185 (recdesc-deferror recdesc-invalid-and-arguments
186   "Invalid arguments to and directive" recdesc-error)
187
188 (defun recdesc-parse-directive/maybe (args)
189   (if (not (consp args))
190       (signal 'recdesc-invalid-maybe-arguments
191               (list args)))
192   `(or ,(recdesc-parse-directive/and args) t))
193
194 (defun recdesc-parse-directive/repeat (args)
195   `(loop for repeat-item = ,(recdesc-parse-directive/and args)
196          while repeat-item
197          collect repeat-item))
198
199 (defun recdesc-parse-directive/commit (args)
200   (if args
201       (signal 'recdesc-invalid-commit-arguments
202               (list args)))
203   `(setq commit-flag t))
204
205 (recdesc-deferror recdesc-invalid-commit-arguments
206   "Invalid arguments to commit directive" recdesc-error)
207
208 (defun recdesc-parse-directive/fail (args)
209   (if args
210       (signal 'recdesc-invalid-fail-arguments
211               (list args)))
212   '(throw 'recdesc-failed nil))
213
214 (recdesc-deferror recdesc-invalid-fail-arguments
215   "Invalid arguments to fail directive" recdesc-error)
216
217 (defun recdesc-parse-directive/progn (args)
218   `(progn ,@args))
219
220 (put 'term 'lisp-indent-function 'defun)
221
222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
223 ;;
224 ;; Die folgenden Funktionen werden von den durch recdesc-declare
225 ;; erzeugten termen benötigt
226
227 (defun recdesc-backtrack ()
228   (progn
229     (if commit-flag
230         (throw 'recdesc-failed nil))
231     (setq position saved-position
232           elements saved-elements)
233     nil))
234
235 (defun recdesc-collect (value)
236   (if value
237       (progn
238         (setq elements (nconc elements 
239                               (list value)))
240         value)))
241
242 (defun recdesc-match-regexp (regexp)
243   (if (string-match (concat "^" regexp) (substring string position))
244       (let ((start position))
245         (setq position (+ position (match-end 0)))
246         (substring string start position))))
247
248 (defun recdesc-match (term &rest args)
249   (apply (intern (concat "recdesc@@" (symbol-name term))) args))
250
251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
252 ;; 
253 ;; Toplevel calls to generated scanners
254
255 (defun recdesc-scan-string (term string &rest args)
256   (let ((scanner (intern (concat "recdesc@@"
257                                  (symbol-name term))))
258         (position 0)
259         rv)
260     (setq rv (catch 'recdesc-failed
261                (apply scanner args)))
262     (if (not (string-match "^[ \t\n\r]*$" (substring string position)))
263         nil
264       rv)))
265
266 (provide 'recdesc)
267
268 \f
269 ;;; Local Variables:
270 ;;; elisp-project-autoload-file-name: "sqi-autoload.el"
271 ;;; End: