← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/star-parser/matcher.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/star-parser/matcher.scm
 
1
;;; -*-Scheme-*-
 
2
;;;
 
3
;;; $Id: matcher.scm,v 1.29 2002/02/03 03:38:58 cph Exp $
 
4
;;;
 
5
;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
 
6
;;;
 
7
;;; This program is free software; you can redistribute it and/or
 
8
;;; modify it under the terms of the GNU General Public License as
 
9
;;; published by the Free Software Foundation; either version 2 of the
 
10
;;; License, or (at your option) any later version.
 
11
;;;
 
12
;;; This program is distributed in the hope that it will be useful,
 
13
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 
14
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 
15
;;; General Public License for more details.
 
16
;;;
 
17
;;; You should have received a copy of the GNU General Public License
 
18
;;; along with this program; if not, write to the Free Software
 
19
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
20
;;; 02111-1307, USA.
 
21
 
 
22
;;;; Pattern-matcher language
 
23
 
 
24
;;; A matcher is a procedure of one argument, a parser buffer.
 
25
;;; It performs a match against the contents of the buffer, starting
 
26
;;; at the location of the buffer pointer.  If the match is
 
27
;;; successful, the buffer pointer is advanced to the end of the
 
28
;;; matched segment, and #T is returned.  If the match fails, the
 
29
;;; buffer pointer is unchanged, and #F is returned.
 
30
 
 
31
(declare (usual-integrations))
 
32
 
 
33
;;;; Preprocessor
 
34
 
 
35
(define (preprocess-matcher-expression expression
 
36
                                       external-bindings
 
37
                                       internal-bindings)
 
38
  (cond ((and (pair? expression)
 
39
              (symbol? (car expression))
 
40
              (list? (cdr expression)))
 
41
         (let ((preprocessor (matcher-preprocessor (car expression))))
 
42
           (if preprocessor
 
43
               (preprocessor expression external-bindings internal-bindings)
 
44
               (error "Unknown matcher expression:" expression))))
 
45
        ((symbol? expression)
 
46
         (let ((preprocessor (matcher-preprocessor expression)))
 
47
           (if preprocessor
 
48
               (preprocessor expression external-bindings internal-bindings)
 
49
               expression)))
 
50
        ((identifier? expression)
 
51
         expression)
 
52
        ((string? expression)
 
53
         (preprocess-matcher-expression `(STRING ,expression)
 
54
                                        external-bindings
 
55
                                        internal-bindings))
 
56
        ((char? expression)
 
57
         (preprocess-matcher-expression `(CHAR ,expression)
 
58
                                        external-bindings
 
59
                                        internal-bindings))
 
60
        (else
 
61
         (error "Unknown matcher expression:" expression))))
 
62
 
 
63
(define (preprocess-matcher-expressions expressions
 
64
                                        external-bindings
 
65
                                        internal-bindings)
 
66
  (map (lambda (expression)
 
67
         (preprocess-matcher-expression expression
 
68
                                        external-bindings
 
69
                                        internal-bindings))
 
70
       expressions))
 
71
 
 
72
(define (define-matcher-preprocessor name procedure)
 
73
  (if (pair? name)
 
74
      (for-each (lambda (name) (define-matcher-preprocessor name procedure))
 
75
                name)
 
76
      (hash-table/put! matcher-preprocessors name procedure))
 
77
  name)
 
78
 
 
79
(define-syntax define-*matcher-macro
 
80
  (rsc-macro-transformer
 
81
   (lambda (form environment)
 
82
     (let ((r-dme (close-syntax 'DEFINE-*MATCHER-EXPANDER environment))
 
83
           (r-lambda (close-syntax 'LAMBDA environment)))
 
84
       (cond ((syntax-match? '(SYMBOL EXPRESSION) (cdr form))
 
85
              `(,r-dme ',(cadr form)
 
86
                       (,r-lambda ()
 
87
                                  ,(caddr form))))
 
88
             ((syntax-match? '((SYMBOL . MIT-BVL) + EXPRESSION) (cdr form))
 
89
              `(,r-dme ',(car (cadr form))
 
90
                       (,r-lambda ,(cdr (cadr form))
 
91
                                  ,@(cddr form))))
 
92
             (else
 
93
              (ill-formed-syntax form)))))))
 
94
 
 
95
(define (define-*matcher-expander name procedure)
 
96
  (define-matcher-macro name
 
97
    (lambda (expression external-bindings internal-bindings)
 
98
      (preprocess-matcher-expression (if (pair? expression)
 
99
                                         (apply procedure (cdr expression))
 
100
                                         (procedure))
 
101
                                     external-bindings
 
102
                                     internal-bindings))))
 
103
 
 
104
(define (matcher-preprocessor name)
 
105
  (or (lookup-matcher-macro name)
 
106
      (hash-table/get matcher-preprocessors name #f)))
 
107
 
 
108
(define matcher-preprocessors
 
109
  (make-eq-hash-table))
 
110
 
 
111
(define-*matcher-expander '+
 
112
  (lambda (expression)
 
113
    `(SEQ ,expression (* ,expression))))
 
114
 
 
115
(define-*matcher-expander '?
 
116
  (lambda (expression)
 
117
    `(ALT ,expression (SEQ))))
 
118
 
 
119
(define-*matcher-expander 'COMPLETE
 
120
  (lambda (expression)
 
121
    `(SEQ ,expression (END-OF-INPUT))))
 
122
 
 
123
(define-*matcher-expander 'TOP-LEVEL
 
124
  (lambda (expression)
 
125
    `(SEQ ,expression (DISCARD-MATCHED))))
 
126
 
 
127
(define-matcher-preprocessor '(ALT SEQ)
 
128
  (lambda (expression external-bindings internal-bindings)
 
129
    `(,(car expression)
 
130
      ,@(flatten-expressions (preprocess-matcher-expressions (cdr expression)
 
131
                                                             external-bindings
 
132
                                                             internal-bindings)
 
133
                             (car expression)))))
 
134
 
 
135
(define-matcher-preprocessor '*
 
136
  (lambda (expression external-bindings internal-bindings)
 
137
    `(,(car expression)
 
138
      ,(preprocess-matcher-expression (check-1-arg expression)
 
139
                                      external-bindings
 
140
                                      internal-bindings))))
 
141
 
 
142
(define-matcher-preprocessor '(CHAR CHAR-CI NOT-CHAR NOT-CHAR-CI ALPHABET)
 
143
  (lambda (expression external-bindings internal-bindings)
 
144
    external-bindings internal-bindings
 
145
    (check-1-arg expression)
 
146
    expression))
 
147
 
 
148
(define-matcher-preprocessor '(STRING STRING-CI)
 
149
  (lambda (expression external-bindings internal-bindings)
 
150
    external-bindings internal-bindings
 
151
    (let ((string (check-1-arg expression)))
 
152
      (if (and (string? string) (fix:= (string-length string) 1))
 
153
          `(,(if (eq? (car expression) 'STRING) 'CHAR 'CHAR-CI)
 
154
            ,(string-ref string 0))
 
155
          expression))))
 
156
 
 
157
(define-matcher-preprocessor 'CHAR-SET
 
158
  (lambda (expression external-bindings internal-bindings)
 
159
    internal-bindings
 
160
    (let ((arg (check-1-arg expression)))
 
161
      (if (string? arg)
 
162
          `(,(car expression)
 
163
            ,(handle-complex-expression
 
164
              (if (string-prefix? "^" arg)
 
165
                  `(,(close 'RE-COMPILE-CHAR-SET) ,(string-tail arg 1) #T)
 
166
                  `(,(close 'RE-COMPILE-CHAR-SET) ,arg #F))
 
167
              external-bindings))
 
168
          expression))))
 
169
 
 
170
(define-matcher-preprocessor '(END-OF-INPUT DISCARD-MATCHED)
 
171
  (lambda (expression external-bindings internal-bindings)
 
172
    external-bindings internal-bindings
 
173
    (check-0-args expression)
 
174
    expression))
 
175
 
 
176
(define-matcher-preprocessor 'WITH-POINTER
 
177
  (lambda (expression external-bindings internal-bindings)
 
178
    (check-2-args expression
 
179
                  (lambda (expression) (identifier? (cadr expression))))
 
180
    `(,(car expression) ,(cadr expression)
 
181
                        ,(preprocess-matcher-expression (caddr expression)
 
182
                                                        external-bindings
 
183
                                                        internal-bindings))))
 
184
 
 
185
(define-matcher-preprocessor 'SEXP
 
186
  (lambda (expression external-bindings internal-bindings)
 
187
    external-bindings internal-bindings
 
188
    (check-1-arg expression)
 
189
    expression))
 
190
 
 
191
;;;; Compiler
 
192
 
 
193
(define-syntax *matcher
 
194
  (sc-macro-transformer
 
195
   (lambda (form environment)
 
196
     (if (syntax-match? '(EXPRESSION) (cdr form))
 
197
         (generate-matcher-code (cadr form) environment)
 
198
         (ill-formed-syntax form)))))
 
199
 
 
200
(define (generate-matcher-code expression environment)
 
201
  (generate-external-procedure expression environment
 
202
                               preprocess-matcher-expression
 
203
    (lambda (expression free-names)
 
204
      (call-with-pointer #f
 
205
        (lambda (p)
 
206
          (bind-delayed-lambdas
 
207
           (lambda (ks kf)
 
208
             (compile-matcher-expression expression #f ks kf free-names))
 
209
           (make-matcher-ks-lambda (lambda (kf) kf `#T))
 
210
           (backtracking-kf p (lambda () `#F))))))))
 
211
 
 
212
(define (compile-matcher-expression expression pointer ks kf free-names)
 
213
  (cond ((and (pair? expression)
 
214
              (symbol? (car expression))
 
215
              (list? (cdr expression))
 
216
              (hash-table/get matcher-compilers (car expression) #f))
 
217
         => (lambda (entry)
 
218
              (let ((arity (car entry))
 
219
                    (compiler (cdr entry)))
 
220
                (if (and arity (not (= (length (cdr expression)) arity)))
 
221
                    (error "Incorrect arity for matcher:" expression))
 
222
                (apply compiler pointer ks kf free-names (cdr expression)))))
 
223
        ((or (identifier? expression)
 
224
             (and (pair? expression) (eq? (car expression) 'SEXP)))
 
225
         (wrap-external-matcher `(,(protect (if (pair? expression)
 
226
                                                (cadr expression)
 
227
                                                expression)
 
228
                                            free-names)
 
229
                                  ,*buffer-name*)
 
230
                                ks
 
231
                                kf))
 
232
        (else
 
233
         (error "Malformed matcher:" expression))))
 
234
 
 
235
(define (wrap-external-matcher matcher ks kf)
 
236
  `(IF ,matcher
 
237
       ,(delay-call ks kf)
 
238
       ,(delay-call kf)))
 
239
 
 
240
(define-syntax define-matcher
 
241
  (rsc-macro-transformer
 
242
   (lambda (form environment)
 
243
     (if (syntax-match? '((SYMBOL . MIT-BVL) + EXPRESSION) (cdr form))
 
244
         (let ((name (car (cadr form)))
 
245
               (parameters (cdr (cadr form)))
 
246
               (compiler-body (cddr form))
 
247
               (r-dmc (close-syntax 'DEFINE-MATCHER-COMPILER environment))
 
248
               (r-lambda (close-syntax 'LAMBDA environment)))
 
249
           `(,r-dmc ',name
 
250
                    ,(if (identifier? parameters) `#F (length parameters))
 
251
                    (,r-lambda (POINTER KS KF FREE-NAMES . ,parameters)
 
252
                               ,@compiler-body)))
 
253
         (ill-formed-syntax form)))))
 
254
 
 
255
(define (define-matcher-compiler keyword arity compiler)
 
256
  (hash-table/put! matcher-compilers keyword (cons arity compiler))
 
257
  keyword)
 
258
 
 
259
(define matcher-compilers
 
260
  (make-eq-hash-table))
 
261
 
 
262
(define-syntax define-atomic-matcher
 
263
  (rsc-macro-transformer
 
264
   (lambda (form environment)
 
265
     (if (syntax-match? '(DATUM + EXPRESSION) (cdr form))
 
266
         (let ((r-dm (close-syntax 'DEFINE-MATCHER environment))
 
267
               (r-wem (close-syntax 'WRAP-EXTERNAL-MATCHER environment)))
 
268
           `(,r-dm ,(cadr form)
 
269
                   POINTER ,@(except-last-pair (cddr form))
 
270
                   (,r-wem ,(car (last-pair (cddr form))) KS KF)))
 
271
         (ill-formed-syntax form)))))
 
272
 
 
273
(define-atomic-matcher (char char)
 
274
  `(MATCH-PARSER-BUFFER-CHAR ,*buffer-name* ,(protect char free-names)))
 
275
 
 
276
(define-atomic-matcher (char-ci char)
 
277
  `(MATCH-PARSER-BUFFER-CHAR-CI ,*buffer-name* ,(protect char free-names)))
 
278
 
 
279
(define-atomic-matcher (not-char char)
 
280
  `(MATCH-PARSER-BUFFER-NOT-CHAR ,*buffer-name* ,(protect char free-names)))
 
281
 
 
282
(define-atomic-matcher (not-char-ci char)
 
283
  `(MATCH-PARSER-BUFFER-NOT-CHAR-CI ,*buffer-name* ,(protect char free-names)))
 
284
 
 
285
(define-atomic-matcher (char-set char-set)
 
286
  `(MATCH-PARSER-BUFFER-CHAR-IN-SET ,*buffer-name*
 
287
                                    ,(protect char-set free-names)))
 
288
 
 
289
(define-atomic-matcher (alphabet alphabet)
 
290
  `(MATCH-UTF8-CHAR-IN-ALPHABET ,*buffer-name* ,(protect alphabet free-names)))
 
291
 
 
292
(define-atomic-matcher (string string)
 
293
  `(MATCH-PARSER-BUFFER-STRING ,*buffer-name* ,(protect string free-names)))
 
294
 
 
295
(define-atomic-matcher (string-ci string)
 
296
  `(MATCH-PARSER-BUFFER-STRING-CI ,*buffer-name* ,(protect string free-names)))
 
297
 
 
298
(define-atomic-matcher (end-of-input)
 
299
  free-names
 
300
  `(NOT (PEEK-PARSER-BUFFER-CHAR ,*buffer-name*)))
 
301
 
 
302
(define-matcher (discard-matched)
 
303
  pointer free-names
 
304
  `(BEGIN
 
305
     (DISCARD-PARSER-BUFFER-HEAD! ,*buffer-name*)
 
306
     ,(delay-call ks kf)))
 
307
 
 
308
(define-matcher (with-pointer identifier expression)
 
309
  `((LAMBDA (,identifier)
 
310
      ,(compile-matcher-expression expression (or pointer identifier) ks kf
 
311
                                   (cons identifier free-names)))
 
312
    ,(or pointer (fetch-pointer))))
 
313
 
 
314
(define-matcher (seq . expressions)
 
315
  (if (pair? expressions)
 
316
      (let loop ((expressions expressions) (pointer pointer) (kf kf))
 
317
        (if (pair? (cdr expressions))
 
318
            (bind-delayed-lambdas
 
319
             (lambda (ks)
 
320
               (compile-matcher-expression (car expressions) pointer ks kf
 
321
                                           free-names))
 
322
             (make-matcher-ks-lambda
 
323
              (lambda (kf)
 
324
                (loop (cdr expressions) #f kf))))
 
325
            (compile-matcher-expression (car expressions) pointer ks kf
 
326
                                        free-names)))
 
327
      (delay-call ks kf)))
 
328
 
 
329
(define-matcher (alt . expressions)
 
330
  (if (pair? expressions)
 
331
      (let loop ((expressions expressions) (pointer pointer))
 
332
        (if (pair? (cdr expressions))
 
333
            (call-with-pointer pointer
 
334
              (lambda (pointer)
 
335
                (bind-delayed-lambdas
 
336
                 (lambda (kf)
 
337
                   (compile-matcher-expression (car expressions) pointer ks kf
 
338
                                               free-names))
 
339
                 (backtracking-kf pointer
 
340
                   (lambda ()
 
341
                     (loop (cdr expressions) pointer))))))
 
342
            (compile-matcher-expression (car expressions) pointer ks kf
 
343
                                        free-names)))
 
344
      (delay-call kf)))
 
345
 
 
346
(define-matcher (* expression)
 
347
  pointer
 
348
  (let ((ks2 (make-ks-identifier))
 
349
        (kf2 (make-kf-identifier)))
 
350
    `(LET ,ks2 ((,kf2 ,(delay-reference kf)))
 
351
       ,(call-with-pointer #f
 
352
          (lambda (pointer)
 
353
            (bind-delayed-lambdas
 
354
             (lambda (kf)
 
355
               (compile-matcher-expression expression #f ks2 kf free-names))
 
356
             (backtracking-kf pointer
 
357
               (lambda ()
 
358
                 (delay-call ks kf2)))))))))
 
 
b'\\ No newline at end of file'