source: project/release/4/genturfahi/trunk/nunjavni.scm @ 21975

Last change on this file since 21975 was 21975, checked in by Alan Post, 10 years ago

when optional (?) is also tagged with (), honor when no match is found.

I was accidentally passing the empty-string on the non-match case,
which was not being recognized by the parser as a command to not
alter the parse tree.

File size: 18.0 KB
Line 
1;;;;
2;;;; genturfahi - lo la .ckim. ke pe'a jajgau ratcu ke'e genturfa'i
3;;;;            `-> A Scheme packrat parser.
4;;;;
5;;;; Copyright (c) 2010 ".alyn.post." <alyn.post@lodockikumazvati.org>
6;;;;
7;;;; Permission to use, copy, modify, and/or distribute this software for any
8;;;; purpose with or without fee is hereby granted, provided that the above
9;;;; copyright notice and this permission notice appear in all copies.
10;;;;
11;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
12;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
13;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
14;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
15;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
16;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
17;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
18;;;;
19
20;;;
21;;; nunjavni - javni generators
22;;;
23
24;; selci: parse a single specified character.
25;;
26(define (nunjavni-lerfu lerfu #!key cmene (nastura #t))
27  (let ((nunvalsi-lerfu (make-nunvalsi cmene nastura)))
28    (define (javni-lerfu porsi mapti namapti)
29      (if (char=? lerfu (lerfu-porsi-lerfu porsi))
30          (mapti (make-lerfu-porsi-pabalvi-lerfu porsi)
31                 (nunvalsi-lerfu lerfu))
32          (namapti porsi)))
33    javni-lerfu))
34
35
36;; selci: parse any single character.
37;;
38(define (nunjavni-. #!key cmene nastura)
39  (let ((nunvalsi-. (make-nunvalsi cmene nastura)))
40    (define (javni-. porsi mapti namapti)
41      (if (lerfu-porsi-fanmo? porsi)
42          (namapti porsi)
43          (mapti (make-lerfu-porsi-pabalvi-lerfu porsi)
44                 (nunvalsi-. (lerfu-porsi-lerfu porsi)))))
45    javni-.))
46
47
48;; empty-string: parse the empty string, which always succeeds without
49;;               advancing input.
50;;
51(define (nunjavni-e #!key cmene (nastura #t) (empty-string ""))
52  (let ((nunvalsi-e (make-nunvalsi cmene nastura)))
53    (define (javni-e porsi mapti ignore-namapti)
54      (mapti porsi (nunvalsi-e empty-string)))
55    javni-e))
56
57
58;; empty-list: parse the empty list, which always succeeds without
59;;             advancing input.
60;;
61(define (nunjavni-nil #!key cmene nastura (empty-list '()))
62  (let ((nunvalsi-nil (make-nunvalsi cmene nastura)))
63    (define (javni-nil porsi mapti ignore-namapti)
64      (mapti porsi (nunvalsi-nil empty-list)))
65    javni-nil))
66
67
68;; selci: parse the end of input.
69;;
70;; Should this rule return the sentinel character, or should there
71;; be a separate option for the value to return at the end of the file?
72;;
73(define (nunjavni-fanmo #!key cmene nastura (sentinel #\nul))
74  (let ((nunvalsi-fanmo (make-nunvalsi cmene nastura)))
75    (define (javni-fanmo porsi mapti namapti)
76      (if (lerfu-porsi-fanmo? porsi)
77          (mapti porsi (nunvalsi-fanmo sentinel))
78          (namapti porsi)))
79  javni-fanmo))
80
81
82;; selci: parse the specified string
83;;
84(define (nunjavni-valsi valsi #!key cmene (nastura #t))
85  (let ((nilcla (string-length valsi))
86        (nunvalsi-valsi (make-nunvalsi cmene nastura)))
87    (define (javni-valsi porsi mapti namapti)
88      (let ((poi (lerfu-porsi-poi porsi))
89            (zva (lerfu-porsi-zva porsi)))
90        (if (string-prefix? valsi
91                            poi
92                            0
93                            nilcla
94                            zva
95                            (- (string-length poi) 1))
96            (mapti (make-lerfu-porsi-pabalvi-valsi porsi nilcla)
97                   (nunvalsi-valsi valsi))
98            (namapti porsi))))
99    javni-valsi))
100
101
102(define (nunjavni-char-set-* char-set #!key cmene nastura)
103  (let ((nunvalsi-char-set-* (make-nunvalsi cmene nastura)))
104    (define (javni-char-set-* porsi
105                              mapti
106                              ignore-namapti
107                              #!optional (poi (lerfu-porsi-poi porsi))
108                                         (zva (lerfu-porsi-zva porsi)))
109      (define (mapti-char-set-* zva)
110        (let ((puzva (lerfu-porsi-zva porsi)))
111          (mapti (make-lerfu-porsi-pabalvi-valsi porsi (- zva puzva))
112                 (nunvalsi-char-set-* (string-copy poi puzva zva)))))
113
114      (define (char-set-* poi zva)
115        (if (char-set-contains? char-set (string-ref poi zva))
116            (char-set-* poi (+ 1 zva))
117            zva))
118
119      (mapti-char-set-* (char-set-* poi zva)))
120    javni-char-set-*))
121
122
123(define (nunjavni-char-set-+ char-set #!key cmene nastura)
124  (let ((javni-char-set-* (nunjavni-char-set-* char-set
125                                               cmene: cmene
126                                               nastura: nastura)))
127    (define (javni-char-set-+ porsi mapti namapti)
128      (let ((poi        (lerfu-porsi-poi porsi))
129            (zva        (lerfu-porsi-zva porsi)))
130        (if (char-set-contains? char-set (string-ref poi zva))
131            (javni-char-set-* porsi
132                             mapti
133                             namapti
134                             poi
135                             (+ 1 zva))
136            (namapti porsi))))
137    javni-char-set-+))
138
139;; XXX: inline optimize
140(define (nunjavni-char-set char-set #!key cmene nastura)
141  (let ((nunvalsi-char-set (make-nunvalsi cmene nastura)))
142    (define (javni-char-set porsi mapti namapti)
143
144      (let* ((poi        (lerfu-porsi-poi porsi))
145             (zva        (lerfu-porsi-zva porsi)))
146        (if (char-set-contains? char-set (string-ref poi zva))
147            (mapti (make-lerfu-porsi-pabalvi-lerfu porsi)
148                   (nunvalsi-char-set (lerfu-porsi-lerfu porsi)))
149            (namapti porsi))))
150    javni-char-set))
151
152;; zero-or-more: parse zero or more javni out of the |lerfu-porsi|.
153;;
154(define (nunjavni-* javni #!key cmene nastura)
155        ; we merge the results differently when we have a cmene.
156        ; generate the merge routine based on this.
157  (let ((vejmina (venunjmina-rodanunvalsi cmene nastura)))
158    (define (javni-* porsi
159                     mapti
160                     namapti
161                            ; a "dummy head" is a linked-list
162                            ; optimization we'll return the cdr
163                            ; of this list, but by using this
164                            ; extra cons we avoid checking for
165                            ; the beginning of the list below.
166                            ;
167                     #!key (cfari (list '()))
168                           (fanmo cfari))
169      (define (mapti-* porsi nunvalsi)
170        ; append this result to the result list
171        (set-cdr! fanmo (list nunvalsi))
172        (javni-* porsi
173                 mapti
174                 namapti
175                 cfari: cfari
176                 fanmo: (cdr fanmo)))
177
178      (define (namapti-* porsi)
179        ; ignore the failure in |ignore-nunjavni|, as
180        ; this javni cannot fail.  |porsi| is not advanced
181        ; on failure, so we can use it, capturing any
182        ; cases that did succeed.
183        ;
184        (mapti porsi (vejmina (cdr cfari))))
185
186      (javni porsi mapti-* namapti-*))
187    javni-*))
188
189
190;; one-or-more: parse one or more javni out of the |lerfu-porsi|.
191;;
192(define (nunjavni-+ javni #!key cmene nastura)
193  (let ((javni-* (nunjavni-* javni cmene: cmene nastura: nastura)))
194    (define (javni-+ porsi mapti namapti)
195      (define (mapti-+ porsi nunvalsi)
196        (let ((fanmo (list nunvalsi)))
197          (javni-* porsi
198                   mapti
199                   namapti
200                   cfari: (cons (list '()) fanmo)
201                   fanmo: fanmo)))
202      (javni porsi mapti-+ namapti))
203    javni-+))
204
205
206;; optional: parse an optional javni out of the |lerfu-porsi|.
207;;
208(define (nunjavni-? javni #!key cmene nastura (empty-string ""))
209  (let ((vejmina (venunjmina-nunvalsi cmene nastura))
210        (novejmina (if nastura
211                       (lambda () (make-javni-valsi cmene secuxna-nastura))
212                       (lambda () (make-javni-valsi cmene empty-string)))))
213    (define (javni-? porsi mapti ignore-namapti)
214
215      (define (mapti-? porsi nunvalsi)
216        (mapti porsi (vejmina nunvalsi)))
217
218      (define (namapti-? porsi)
219        ; ignore the failure in |ignore-nunvalsi|, as
220        ; this javni cannot fail.  |porsi| is not advanced
221        ; on failure, so we can use it.
222        ;
223        (mapti porsi novejmina))
224
225      (javni porsi mapti-? namapti-?))
226    javni-?))
227
228
229;; and-predicate: succeed or fail without consuming input.
230;;
231(define (nunjavni-& javni)
232  (define (javni-& porsi mapti namapti)
233    (define (mapti-& ignore-porsi ignore-nunvalsi)
234      (mapti porsi (lambda () (make-javni-valsi #f secuxna-nastura))))
235
236    (define (namapti-& ignore-porsi)
237      (namapti porsi))
238
239    (javni porsi mapti-& namapti-&))
240  javni-&)
241
242
243;; not-predicate: require that |javni| is not able to be parsed from
244;;                the |lerfu-porsi|.
245;;
246(define (nunjavni-! javni)
247  (define (javni-! porsi mapti namapti)
248    (define (mapti-! ignore-porsi nunvalsi)
249      (namapti porsi))
250
251    (define (namapti-! ignore-porsi)
252      (mapti porsi (lambda () (make-javni-valsi #f secuxna-nastura))))
253
254    (javni porsi mapti-! namapti-!))
255  javni-!)
256
257
258;; sequence: parse |ro da javni| out of the |lerfu-porsi|.
259;;           if any of the do not match, none of them match.
260;;
261(define (nunjavni-je #!rest rodajavni #!key cmene nastura)
262        ; we merge the results differently when we have a cmene.
263        ; generate the merge routine based on this.
264  (let ((vejmina   (venunjmina-rodanunvalsi cmene nastura))
265        ; remove #!key name/value pairs from argument list.
266        (rodajavni (filter procedure? rodajavni)))
267    (define (javni-je porsi
268                      mapti
269                      namapti
270                                 ; capture the initial position, and
271                                 ; then continue to pass it as we
272                                 ; call ourselves recursively.
273                      #!key     (cfari-porsi porsi)
274                                 ; the current rule we're trying.
275                                (rodajavni rodajavni)
276                                 ; a "dummy head" is a linked-list
277                                 ; optimization we'll return the cdr
278                                 ; of this list, but by using this
279                                 ; extra cons we avoid checking for
280                                 ; the beginning of the list below.
281                                 ;
282                                (cfari (list '()))
283                                (fanmo cfari))
284      ; the (nun)valsi passed to us might
285      ; include previously matched javni.  If
286      ; we fail to match a javni, ignore the
287      ; porsi passed to us and use the one from
288      ; the start of this parse rule.
289      ;
290      (define (namapti-je ignore-porsi)
291        (namapti cfari-porsi))
292
293      (let ((javni (car rodajavni))
294            (rest (cdr rodajavni)))
295        (if (null? rest)
296
297            ; called at the end of the list
298            (let ((mapti-je (lambda (porsi nunvalsi)
299                               (set-cdr! fanmo (list nunvalsi))
300                               (mapti porsi (vejmina (cdr cfari))))))
301              (javni porsi mapti-je namapti-je))
302
303            ; called when there are still elements in the list
304            (let ((mapti-je (lambda (porsi nunvalsi)
305                               (set-cdr! fanmo (list nunvalsi))
306                               (javni-je porsi
307                                         mapti
308                                         namapti
309                                         cfari-porsi: cfari-porsi
310                                         rodajavni: rest
311                                         cfari: cfari
312                                         fanmo: (cdr fanmo)))))
313              (javni porsi mapti-je namapti-je)))))
314  javni-je))
315
316
317;; ordered-choice: parse the first matching javni out of the
318;;                 |lerfu-porsi|.
319;;
320(define (nunjavni-jonai #!rest rodajavni #!key cmene nastura)
321        ; we merge the results differently when we have a cmene.
322        ; generate the merge routine based on this.
323  (let ((vejmina   (venunjmina-nunvalsi cmene nastura))
324        ; remove #!key name/value pairs from argument list.
325        (rodajavni (filter procedure? rodajavni)))
326    (define (javni-jonai porsi
327                         mapti
328                         namapti
329                         #!optional (rodajavni rodajavni))
330      (define (mapti-jonai porsi nunvalsi)
331        (mapti porsi (vejmina nunvalsi)))
332
333      (let ((javni (car rodajavni))
334            (rest (cdr rodajavni)))
335        (if (null? rest)
336            ; called at the end of the list
337            (javni porsi mapti-jonai namapti)
338
339            ; called when there are still elements in the list
340            (let ((namapti-jonai (lambda (porsi)
341                                  (javni-jonai porsi mapti namapti rest))))
342              (javni porsi mapti-jonai namapti-jonai)))))
343    javni-jonai))
344
345
346;; morji: memoization is done to ensure we run in linear time.
347;;        Any javni can be memoized, but in practice we memoize
348;;        na selci javni.
349;;
350(define-values (genturfahi-tolmohi nunjavni-morji)
351  (let ((clear-mapti-caches '())
352        (clear-namapti-caches '())
353        (clear-recurse-caches '()))
354    (values
355      (lambda ()
356        (for-each (lambda (x) (x)) clear-mapti-caches)
357        (for-each (lambda (x) (x)) clear-namapti-caches)
358        (for-each (lambda (x) (x)) clear-recurse-caches)
359        '())
360
361      (lambda (javni)
362        (let ((mapti-cache '())
363              (namapti-cache '())
364              (recurse-cache '()))
365          (define (javni-morji cache-porsi mapti namapti)
366            (define (set-mapti-cache! cache-porsi porsi nunvalsi)
367              (set! mapti-cache
368                (cons (cons cache-porsi (list porsi nunvalsi))
369                      mapti-cache)))
370
371            (define (set-namapti-cache! cache-porsi porsi)
372              (set! namapti-cache
373                (cons (cons cache-porsi (list porsi))
374                      namapti-cache)))
375
376            (define (set-recurse-cache!)
377              (set! recurse-cache
378                (cons (cons cache-porsi (list cache-porsi))
379                      namapti-cache)))
380
381            ;; call the cached |mapti|
382            (define (mapti-morji assv-valsi)
383              (apply mapti (cdr assv-valsi)))
384
385            ;; call the cached |namapti|
386            (define (namapti-morji assv-valsi)
387              (apply namapti (cdr assv-valsi)))
388
389            ;; left recursion support.
390            (define (recurse-morji assv-valsi)
391              (apply namapti (cdr assv-valsi)))
392
393            (define (javni-nomorji)
394              (define (mapti-morji porsi nunvalsi)
395                (set-mapti-cache! cache-porsi
396                                  porsi
397                                  nunvalsi)
398                (mapti porsi nunvalsi))
399
400              (define (namapti-morji porsi)
401                (set-namapti-cache! cache-porsi porsi)
402                (namapti porsi))
403
404              ; register this parse position to detect left
405              ; recursion.
406              (set-recurse-cache!)
407
408              (javni cache-porsi mapti-morji namapti-morji))
409
410                   ; search the match results
411            (cond ((assv cache-porsi mapti-cache) => mapti-morji)
412                   ; search the non-match results
413                  ((assv cache-porsi namapti-cache) => namapti-morji)
414                   ; search for left recursion
415                  ((assv cache-porsi recurse-cache) => recurse-morji)
416                   ; run the rule.
417                  (else (javni-nomorji))))
418
419          ; register this cache so we can clear if we want to use this
420          ; parser on a new |lerfu-porsi|.
421          ;
422          (set! clear-mapti-caches
423            (cons (lambda () (set! mapti-cache '()))
424                  clear-mapti-caches))
425          (set! clear-namapti-caches
426            (cons (lambda () (set! namapti-cache '()))
427                  clear-namapti-caches))
428          (set! clear-recurse-caches
429            (cons (lambda () (set! recurse-cache '()))
430                  clear-recurse-caches))
431
432          javni-morji)))))
433
434(define (nunjavni-samselpla samselpla javni #!key cmene)
435  (define (javni-samselpla porsi mapti namapti)
436    (define (mapti-samselpla porsi nunvalsi)
437
438      (define (samselpla-sumti rodavalsi)
439        (call-with-values
440          (lambda ()
441            (partition (lambda (javni) (and (javni-valsi? javni)
442                                            (javni-valsi-cme javni)))
443                       (if (list? rodavalsi)
444                           rodavalsi
445                           `(,rodavalsi))))
446         
447          (lambda (cmesumti sumti)
448            (let ((key (append-map!
449                         (lambda (javni)
450                           `(,(string->keyword (javni-valsi-cme javni))
451                             ,(javni-valsi-val javni)))
452                         cmesumti))
453                  (rest (javni-rodavalsi-val-filter sumti)))
454              (append! rest key)))))
455
456      (define (nunvalsi-samselpla)
457        (let* ((rodavalsi (nunvalsi))
458               (rodaval   (samselpla-sumti rodavalsi))
459               (valsi     (apply samselpla rodaval)))
460          (make-javni-valsi cmene valsi)))
461
462      (mapti porsi nunvalsi-samselpla))
463
464    (javni porsi mapti-samselpla namapti))
465
466  javni-samselpla)
467
468(define (nunjavni-samselpla-cabna samselpla javni #!key cmene)
469  (define javni-samselpla (nunjavni-samselpla samselpla javni))
470
471  (define (javni-samselpla-cabna porsi mapti namapti)
472    (define (mapti-samselpla-cabna porsi nunvalsi)
473      (nunvalsi)
474      (mapti porsi (make-javni-valsi cmene secuxna-nastura)))
475
476    (javni-samselpla porsi mapti-samselpla-cabna namapti))
477  javni-samselpla-cabna)
478
479(define (nunjavni-cmene javni #!key cmene nastura)
480  (let ((nunvalsi-cmene (make-nunvalsi cmene nastura)))
481    (define (javni-cmene porsi mapti namapti)
482      (define (mapti-cmene porsi nunvalsi)
483        (mapti porsi (nunvalsi-cmene (javni-nunvalsi-val nunvalsi))))
484      (javni porsi mapti-cmene namapti))
485    javni-cmene))
486
487(define (nunjavni-nastura javni)
488  (define (javni-nastura porsi mapti namapti)
489    (define (mapti-nastura porsi ignore-nunvalsi)
490      (define (nunvalsi-nastura)
491        (make-javni-valsi #f secuxna-nastura))
492      (mapti porsi nunvalsi-nastura))
493    (javni porsi mapti-nastura namapti))
494  javni-nastura)
Note: See TracBrowser for help on using the repository browser.