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

Last change on this file since 21975 was 21975, checked in by Alan Post, 9 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.