1;;;;										;
2;;;; (c) 2001 by Jochen Schmidt.
3;;;;
4;;;; File:            meta.lisp
5;;;; Revision:        1.0.0
6;;;; Description:     A simple parsing technique
7;;;; Date:            01.07.2001
8;;;; Authors:         Jochen Schmidt
9;;;; Tel:             (+49 9 11) 47 20 603
10;;;; Email:           jsc@dataheaven.de
11;;;;
12;;;; Redistribution and use in source and binary forms, with or without
13;;;; modification, are permitted provided that the following conditions
14;;;; are met:
15;;;; 1. Redistributions of source code must retain the above copyright
16;;;;    notice, this list of conditions and the following disclaimer.
17;;;; 2. Redistributions in binary form must reproduce the above copyright
18;;;;    notice, this list of conditions and the following disclaimer in the
19;;;;    documentation and/or other materials provided with the distribution.
20;;;;
21;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER
22;;;; EXPRESSED NOR IMPLIED WARRANTIES -  THIS INCLUDES, BUT
23;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
24;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE
25;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
27;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ;
28;;;; LOSS OF USE, DATA, OR PROFITS			; OR BUSINESS INTERRUPTION)
29;;;;
30;;;; For further details contact the authors of this software.
31;;;;
32;;;;  Jochen Schmidt
33;;;;  Zuckmantelstr. 11
34;;;;  91616 Neusitz
35;;;;  GERMANY
36;;;;
37;;;;
38;;;; NOTE:
39;;;; This code is based on the well known paper "Pragmatic Parsing in Common Lisp"
40;;;; of Henry G. Baker. You can find it at:
41;;;;
42;;;;    http://linux.rice.edu/~rahul/hbaker/Prag-Parse.html
43;;;;
44;;;; The parsing technique Baker describes in his paper goes back to:
45;;;;
46;;;;     Schorre, D.V.  "META II: A Syntax-Oriented Compiler Writing Language".
47;;;;       Proc. 19'th Nat'l. Conf. of the ACM (Aug. 1964),D1.3-1-D1.3-11.
48;;;;
49;;;;
50;;;; Nuremberg, 01.Jul.2001 Jochen Schmidt
51
52
53(in-package :meta)
54
55
56;;; String matching
57(defmacro string-match (x &key source-symbol)
58  (etypecase x
59    (character
60     `(when (and (< index end) (eql (char ,source-symbol index)  ,x))
61        (incf index)))
62    (string
63     (let ((old-index-symbol (gensym "OLD-INDEX-")))
64       `(let ((,old-index-symbol index))
65          (or (and ,@(map 'list #'(lambda (c) `(string-match ,c
66                                                             :source-symbol ',source-symbol)) x))
67              (progn (setq index ,old-index-symbol) nil)))))))
68
69(defmacro string-match-type (x v &key source-symbol)
70  (let ((char-sym (gensym)))
71    `(when (< index end)
72       (let ((,char-sym (char ,source-symbol index)))
73         (declare (base-char ,char-sym))
74         (when (typep ,char-sym ',x)
75           (setq ,v ,char-sym) (incf index))))))
76
77
78;;; List matching
79(defmacro list-match (x &key source-symbol); sublist uses new lexical index
80 `(when (and (consp ,source-symbol)
81             ,(if (atom x) `(eql (car ,source-symbol) ',x)
82                `(let ((,source-symbol (car ,source-symbol))) ,(compile-list x :source-symbol source-symbol))))
83    (pop ,source-symbol) t))
84
85(defmacro list-match-type (x v &key source-symbol)
86  `(when (and (consp ,source-symbol) (typep (car ,source-symbol) ',x))
87     (setq ,v (car ,source-symbol)) (pop ,source-symbol) t))
88
89(defun compile-list (l &key source-symbol)
90  (if (atom l) `(eql ,source-symbol ',l)
91      `(and ,(compileit (car l) :meta-parser-type :list :source-symbol source-symbol)
92            ,(compile-list (cdr l) :source-symbol source-symbol))))
93
94
95;;; Stream matching
96(defmacro stream-match (x &key source-symbol)
97  `(when (eql (peek-char ,source-symbol) ',x) (read-char ,source-symbol)))
98
99(defmacro stream-match-type (x v &key source-symbol)
100  `(when (typep (peek-char ,source-symbol) ',x) (setq ,v (read-char ,source-symbol))))
101
102(defstruct (meta
103            (:print-function
104             (lambda (m s d &aux (char (meta-char m)) (form (meta-form m)))
105               (declare (ignore d))
106               (ecase char
107                 ((#\@ #\! #\$) (format s "~A~A" char form))
108                 (#\[ (format s "[~{~A~^ ~}]" form))
109                 (#\{ (format s "{~{~A~^ ~}}" form))))))
110    char
111    form)
112
113
114(defun compileit (x &key meta-parser-type source-symbol)
115	(typecase x
116		(meta
117			(ecase (meta-char x)
118				(#\! (meta-form x))
119				(#\[ `(and ,@(mapcar #'(lambda (f) (compileit f
120                                                              :meta-parser-type meta-parser-type
121                                                              :source-symbol source-symbol))
122                                                     (meta-form x))))
123				(#\{ `(or ,@(mapcar #'(lambda (f) (compileit f
124                                                             :meta-parser-type meta-parser-type
125                                                             :source-symbol source-symbol))
126                                                    (meta-form x))))
127				(#\$ `(not (do () ((not ,(compileit (meta-form x)
128                                                    :meta-parser-type meta-parser-type
129                                                    :source-symbol source-symbol))))))
130				(#\@ (let ((f (meta-form x))) (list (ecase meta-parser-type
131                                                                      (:list 'list-match-type)
132                                                                      (:string 'string-match-type)
133                                                                      (:stream 'stream-match-type))
134                                                                    (car f) (cadr f)
135                                                                    :source-symbol source-symbol
136                                                                    )))))
137		(t (list (ecase meta-parser-type
138                           (:list 'list-match)
139                           (:string 'string-match)
140                           (:stream 'stream-match))
141                         x
142                         :source-symbol source-symbol
143                         ))))
144
145
146(eval-when (compile load eval)
147(defparameter *saved-readtable* (copy-readtable))
148(defparameter *meta-readtable* (copy-readtable))
149
150(defun meta-reader (s c) (make-meta :char c :form (read s)))
151
152
153(mapc #'(lambda (c) (set-macro-character c #'meta-reader nil *meta-readtable*)) '(#\@ #\$ #\!))
154
155(set-macro-character #\{
156	#'(lambda (s c) (make-meta :char c :form (read-delimited-list #\} s t))) nil *meta-readtable*)
157
158(set-macro-character #\[
159	#'(lambda (s c) (make-meta :char c :form (read-delimited-list #\] s t))) nil *meta-readtable*)
160
161(mapc #'(lambda (c) (set-macro-character c (get-macro-character #\))  nil *meta-readtable*))
162	'(#\] #\}))
163)
164
165(defmacro with-stream-meta ((source-symbol stream) &body body)
166  `(let ((,source-symbol ,stream))
167     (macrolet ((match (x)
168                       (compileit x
169                                  :meta-parser-type :stream
170                                  :source-symbol ',source-symbol)))
171       ,@body)))
172
173(defmacro with-string-meta ((source-symbol string-buffer &key (start 0) end) &body body)
174  `(let* ((,source-symbol ,string-buffer)
175          (index ,start)
176          (end ,(or end `(length ,source-symbol))))
177     (declare (fixnum index end)
178              (type simple-base-string ,source-symbol))
179     (macrolet ((match (x)
180                       (compileit x
181                                  :meta-parser-type :string
182                                  :source-symbol ',source-symbol)))
183             ,@body)))
184
185
186(defmacro with-list-meta ((source-symbol list) &body body)
187  `(let ((,source-symbol ,list))
188     (macrolet ((match (x)
189                       (compileit x
190                                  :meta-parser-type :list
191                                  :source-symbol ',source-symbol)))
192       ,@body)))
193
194(defun enable-meta-syntax ()
195	(copy-readtable *meta-readtable* *readtable*))
196
197(defun disable-meta-syntax()
198	(copy-readtable *saved-readtable* *readtable*))
199
200
201(provide 'meta)
202
203#|
204
205(eval-when (compile load eval)
206  (deftype digit () '(member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
207
208  (deftype non-digit () '(not (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))
209
210  (defun ctoi (d) (- (char-code d) #.(char-code #\0)))
211)
212
213(eval-when (compile load eval)
214  (enable-meta-syntax)
215)
216
217
218(defun parse-int (string &aux (s +1) d (n 0))
219  (with-string-meta (buffer string)
220                    (and
221                     (match
222                      [{#\+ [#\- !(setq s -1)] []}
223                            @(digit d) !(setq n (ctoi d))
224                            $[@(digit d) !(setq n (+ (* n 10) (ctoi d)))]])
225                     (* s n))))
226
227(eval-when (compile load eval)
228(disable-meta-syntax)
229)
230
231|#
232