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

Last change on this file since 21950 was 21950, checked in by Alan Post, 9 years ago

genturfa'i: add -| operator for immediate code execution.

This is used to execute the header code in genturfahi.peg before
parsing the rest of the grammar.

Because of the rules of scheme and the implementation of of
genturfa'i, I can't guarantee that the parse tree is executed in any
particular order, save that the leaves will be executed before their
branches.

Even if I change genturfa'i to guarantee a certain kind of order, I
can't change the Scheme standard, which does not requires parameters
to a function to be evaluated in any particular order.

This change executes the code during the parse. It may execute
multiple times, though with memoization turned on this should not be
true. Regardless, I don't really specify the number of times this
code is executed, and have limited my operations to those that can
be executed multiple times with no side-effects.

File size: 17.9 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    (define (javni-? porsi mapti ignore-namapti)
211
212      (define (mapti-? porsi nunvalsi)
213        (mapti porsi (vejmina nunvalsi)))
214
215      (define (namapti-? porsi)
216        ; ignore the failure in |ignore-nunvalsi|, as
217        ; this javni cannot fail.  |porsi| is not advanced
218        ; on failure, so we can use it.
219        ;
220        (mapti porsi
221               (lambda () (make-javni-valsi cmene empty-string))))
222
223      (javni porsi mapti-? namapti-?))
224    javni-?))
225
226
227;; and-predicate: succeed or fail without consuming input.
228;;
229(define (nunjavni-& javni)
230  (define (javni-& porsi mapti namapti)
231    (define (mapti-& ignore-porsi ignore-nunvalsi)
232      (mapti porsi (lambda () (make-javni-valsi #f secuxna-nastura))))
233
234    (define (namapti-& ignore-porsi)
235      (namapti porsi))
236
237    (javni porsi mapti-& namapti-&))
238  javni-&)
239
240
241;; not-predicate: require that |javni| is not able to be parsed from
242;;                the |lerfu-porsi|.
243;;
244(define (nunjavni-! javni)
245  (define (javni-! porsi mapti namapti)
246    (define (mapti-! ignore-porsi nunvalsi)
247      (namapti porsi))
248
249    (define (namapti-! ignore-porsi)
250      (mapti porsi (lambda () (make-javni-valsi #f secuxna-nastura))))
251
252    (javni porsi mapti-! namapti-!))
253  javni-!)
254
255
256;; sequence: parse |ro da javni| out of the |lerfu-porsi|.
257;;           if any of the do not match, none of them match.
258;;
259(define (nunjavni-je #!rest rodajavni #!key cmene nastura)
260        ; we merge the results differently when we have a cmene.
261        ; generate the merge routine based on this.
262  (let ((vejmina   (venunjmina-rodanunvalsi cmene nastura))
263        ; remove #!key name/value pairs from argument list.
264        (rodajavni (filter procedure? rodajavni)))
265    (define (javni-je porsi
266                      mapti
267                      namapti
268                                 ; capture the initial position, and
269                                 ; then continue to pass it as we
270                                 ; call ourselves recursively.
271                      #!key     (cfari-porsi porsi)
272                                 ; the current rule we're trying.
273                                (rodajavni rodajavni)
274                                 ; a "dummy head" is a linked-list
275                                 ; optimization we'll return the cdr
276                                 ; of this list, but by using this
277                                 ; extra cons we avoid checking for
278                                 ; the beginning of the list below.
279                                 ;
280                                (cfari (list '()))
281                                (fanmo cfari))
282      ; the (nun)valsi passed to us might
283      ; include previously matched javni.  If
284      ; we fail to match a javni, ignore the
285      ; porsi passed to us and use the one from
286      ; the start of this parse rule.
287      ;
288      (define (namapti-je ignore-porsi)
289        (namapti cfari-porsi))
290
291      (let ((javni (car rodajavni))
292            (rest (cdr rodajavni)))
293        (if (null? rest)
294
295            ; called at the end of the list
296            (let ((mapti-je (lambda (porsi nunvalsi)
297                               (set-cdr! fanmo (list nunvalsi))
298                               (mapti porsi (vejmina (cdr cfari))))))
299              (javni porsi mapti-je namapti-je))
300
301            ; called when there are still elements in the list
302            (let ((mapti-je (lambda (porsi nunvalsi)
303                               (set-cdr! fanmo (list nunvalsi))
304                               (javni-je porsi
305                                         mapti
306                                         namapti
307                                         cfari-porsi: cfari-porsi
308                                         rodajavni: rest
309                                         cfari: cfari
310                                         fanmo: (cdr fanmo)))))
311              (javni porsi mapti-je namapti-je)))))
312  javni-je))
313
314
315;; ordered-choice: parse the first matching javni out of the
316;;                 |lerfu-porsi|.
317;;
318(define (nunjavni-jonai #!rest rodajavni #!key cmene nastura)
319        ; we merge the results differently when we have a cmene.
320        ; generate the merge routine based on this.
321  (let ((vejmina   (venunjmina-nunvalsi cmene nastura))
322        ; remove #!key name/value pairs from argument list.
323        (rodajavni (filter procedure? rodajavni)))
324    (define (javni-jonai porsi
325                         mapti
326                         namapti
327                         #!optional (rodajavni rodajavni))
328      (define (mapti-jonai porsi nunvalsi)
329        (mapti porsi (vejmina nunvalsi)))
330
331      (let ((javni (car rodajavni))
332            (rest (cdr rodajavni)))
333        (if (null? rest)
334            ; called at the end of the list
335            (javni porsi mapti-jonai namapti)
336
337            ; called when there are still elements in the list
338            (let ((namapti-jonai (lambda (porsi)
339                                  (javni-jonai porsi mapti namapti rest))))
340              (javni porsi mapti-jonai namapti-jonai)))))
341    javni-jonai))
342
343
344;; morji: memoization is done to ensure we run in linear time.
345;;        Any javni can be memoized, but in practice we memoize
346;;        na selci javni.
347;;
348(define-values (genturfahi-tolmohi nunjavni-morji)
349  (let ((clear-mapti-caches '())
350        (clear-namapti-caches '())
351        (clear-recurse-caches '()))
352    (values
353      (lambda ()
354        (for-each (lambda (x) (x)) clear-mapti-caches)
355        (for-each (lambda (x) (x)) clear-namapti-caches)
356        (for-each (lambda (x) (x)) clear-recurse-caches)
357        '())
358
359      (lambda (javni)
360        (let ((mapti-cache '())
361              (namapti-cache '())
362              (recurse-cache '()))
363          (define (javni-morji cache-porsi mapti namapti)
364            (define (set-mapti-cache! cache-porsi porsi nunvalsi)
365              (set! mapti-cache
366                (cons (cons cache-porsi (list porsi nunvalsi))
367                      mapti-cache)))
368
369            (define (set-namapti-cache! cache-porsi porsi)
370              (set! namapti-cache
371                (cons (cons cache-porsi (list porsi))
372                      namapti-cache)))
373
374            (define (set-recurse-cache!)
375              (set! recurse-cache
376                (cons (cons cache-porsi (list cache-porsi))
377                      namapti-cache)))
378
379            ;; call the cached |mapti|
380            (define (mapti-morji assv-valsi)
381              (apply mapti (cdr assv-valsi)))
382
383            ;; call the cached |namapti|
384            (define (namapti-morji assv-valsi)
385              (apply namapti (cdr assv-valsi)))
386
387            ;; left recursion support.
388            (define (recurse-morji assv-valsi)
389              (apply namapti (cdr assv-valsi)))
390
391            (define (javni-nomorji)
392              (define (mapti-morji porsi nunvalsi)
393                (set-mapti-cache! cache-porsi
394                                  porsi
395                                  nunvalsi)
396                (mapti porsi nunvalsi))
397
398              (define (namapti-morji porsi)
399                (set-namapti-cache! cache-porsi porsi)
400                (namapti porsi))
401
402              ; register this parse position to detect left
403              ; recursion.
404              (set-recurse-cache!)
405
406              (javni cache-porsi mapti-morji namapti-morji))
407
408                   ; search the match results
409            (cond ((assv cache-porsi mapti-cache) => mapti-morji)
410                   ; search the non-match results
411                  ((assv cache-porsi namapti-cache) => namapti-morji)
412                   ; search for left recursion
413                  ((assv cache-porsi recurse-cache) => recurse-morji)
414                   ; run the rule.
415                  (else (javni-nomorji))))
416
417          ; register this cache so we can clear if we want to use this
418          ; parser on a new |lerfu-porsi|.
419          ;
420          (set! clear-mapti-caches
421            (cons (lambda () (set! mapti-cache '()))
422                  clear-mapti-caches))
423          (set! clear-namapti-caches
424            (cons (lambda () (set! namapti-cache '()))
425                  clear-namapti-caches))
426          (set! clear-recurse-caches
427            (cons (lambda () (set! recurse-cache '()))
428                  clear-recurse-caches))
429
430          javni-morji)))))
431
432(define (nunjavni-samselpla samselpla javni #!key cmene)
433  (define (javni-samselpla porsi mapti namapti)
434    (define (mapti-samselpla porsi nunvalsi)
435
436      (define (samselpla-sumti rodavalsi)
437        (call-with-values
438          (lambda ()
439            (partition (lambda (javni) (and (javni-valsi? javni)
440                                            (javni-valsi-cme javni)))
441                       (if (list? rodavalsi)
442                           rodavalsi
443                           `(,rodavalsi))))
444         
445          (lambda (cmesumti sumti)
446            (let ((key (append-map!
447                         (lambda (javni)
448                           `(,(string->keyword (javni-valsi-cme javni))
449                             ,(javni-valsi-val javni)))
450                         cmesumti))
451                  (rest (javni-rodavalsi-val-filter sumti)))
452              (append! rest key)))))
453
454      (define (nunvalsi-samselpla)
455        (let* ((rodavalsi (nunvalsi))
456               (rodaval   (samselpla-sumti rodavalsi))
457               (valsi     (apply samselpla rodaval)))
458          (make-javni-valsi cmene valsi)))
459
460      (mapti porsi nunvalsi-samselpla))
461
462    (javni porsi mapti-samselpla namapti))
463
464  javni-samselpla)
465
466(define (nunjavni-samselpla-cabna samselpla javni #!key cmene)
467  (define javni-samselpla (nunjavni-samselpla samselpla javni))
468
469  (define (javni-samselpla-cabna porsi mapti namapti)
470    (define (mapti-samselpla-cabna porsi nunvalsi)
471      (nunvalsi)
472      (mapti porsi (make-javni-valsi cmene secuxna-nastura)))
473
474    (javni-samselpla porsi mapti-samselpla-cabna namapti))
475  javni-samselpla-cabna)
476
477(define (nunjavni-cmene javni #!key cmene nastura)
478  (let ((nunvalsi-cmene (make-nunvalsi cmene nastura)))
479    (define (javni-cmene porsi mapti namapti)
480      (define (mapti-cmene porsi nunvalsi)
481        (mapti porsi (nunvalsi-cmene (javni-nunvalsi-val nunvalsi))))
482      (javni porsi mapti-cmene namapti))
483    javni-cmene))
484
485(define (nunjavni-nastura javni)
486  (define (javni-nastura porsi mapti namapti)
487    (define (mapti-nastura porsi ignore-nunvalsi)
488      (define (nunvalsi-nastura)
489        (make-javni-valsi #f secuxna-nastura))
490      (mapti porsi nunvalsi-nastura))
491    (javni porsi mapti-nastura namapti))
492  javni-nastura)
Note: See TracBrowser for help on using the repository browser.