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

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

genturfa'i: replace assoc list in memoization routine with hash.

This is a dramatic speedup to the parser. I found this problem
looking at performance issues after writing some parsers for
jbogenturfa'i.

File size: 17.7 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-semorji genturfahi-tolmohi nunjavni-morji)
351  (let ((rodasemorji '())
352        (rodatolmohi '()))
353    (values
354      (lambda (nilcla)
355        (map (lambda (semorji) (semorji nilcla)) rodasemorji))
356
357      (lambda ()
358        (map (lambda (tolmohi) (tolmohi)) rodatolmohi))
359
360      (lambda (javni)
361        (let ((morji '()))
362          (define (semorji nilcla)
363            (let ((klani (quotient nilcla 2)))
364              (set! morji (make-hash-table = size: (if (= 0 klani) 1 klani)))))
365
366          (define (tolmohi)
367            (set! morji '()))
368
369          (define (javni-morji morji-porsi mapti namapti)
370            ;; mapti
371            (define (set-mapti-morji! porsi nunvalsi)
372              (define (mapti-morji mapti ignore-namapti)
373                (mapti porsi nunvalsi))
374
375              (hash-table-set! morji
376                               (lerfu-porsi-zva morji-porsi)
377                               mapti-morji))
378
379            ;; namapti
380            (define (set-namapti-morji! porsi)
381              (define (namapti-morji ignore-mapti namapti)
382                (namapti porsi))
383
384              (hash-table-set! morji
385                               (lerfu-porsi-zva morji-porsi)
386                               namapti-morji))
387
388            ;; recurse
389            (define (set-recurse-morji!)
390              (define (recurse-morji ignore-mapti namapti)
391                (namapti morji-porsi))
392
393              (hash-table-set! morji
394                               (lerfu-porsi-zva morji-porsi)
395                               recurse-morji))
396
397            (define (javni-nomorji)
398              (define (mapti-morji porsi nunvalsi)
399                (set-mapti-morji! porsi nunvalsi)
400                (mapti porsi nunvalsi))
401
402              (define (namapti-morji porsi)
403                (set-namapti-morji! porsi)
404                (namapti porsi))
405
406              ; register this parse position to detect left
407              ; recursion.
408              (set-recurse-morji!)
409
410              (javni morji-porsi mapti-morji namapti-morji))
411
412            (let ((nunjalge
413                    (hash-table-ref/default morji
414                                            (lerfu-porsi-zva morji-porsi)
415                                            #f)))
416              (if nunjalge (nunjalge mapti namapti) (javni-nomorji))))
417
418          ; register this cache so we can initialize and clear.
419          ; This routine customizes itself based on the input size,
420          ; and we can free up a substantial amount of memory if
421          ; we clear the caches after we're done parsing.
422          ;
423          (set! rodasemorji (cons semorji rodasemorji))
424          (set! rodatolmohi (cons tolmohi rodatolmohi))
425
426          javni-morji)))))
427
428(define (nunjavni-samselpla samselpla javni #!key cmene)
429  (define (javni-samselpla porsi mapti namapti)
430    (define (mapti-samselpla porsi nunvalsi)
431
432      (define (samselpla-sumti rodavalsi)
433        (call-with-values
434          (lambda ()
435            (partition (lambda (javni) (and (javni-valsi? javni)
436                                            (javni-valsi-cme javni)))
437                       (if (list? rodavalsi)
438                           rodavalsi
439                           `(,rodavalsi))))
440         
441          (lambda (cmesumti sumti)
442            (let ((key (append-map!
443                         (lambda (javni)
444                           `(,(string->keyword (javni-valsi-cme javni))
445                             ,(javni-valsi-val javni)))
446                         cmesumti))
447                  (rest (javni-rodavalsi-val-filter sumti)))
448              (append! (if (list? rest) rest `(,rest)) key)))))
449
450      (define (nunvalsi-samselpla)
451        (let* ((rodavalsi (nunvalsi))
452               (rodaval   (samselpla-sumti rodavalsi))
453               (valsi     (apply samselpla rodaval)))
454          (make-javni-valsi cmene valsi)))
455
456      (mapti porsi nunvalsi-samselpla))
457
458    (javni porsi mapti-samselpla namapti))
459
460  javni-samselpla)
461
462(define (nunjavni-samselpla-cabna samselpla javni #!key cmene)
463  (define javni-samselpla (nunjavni-samselpla samselpla javni))
464
465  (define (javni-samselpla-cabna porsi mapti namapti)
466    (define (mapti-samselpla-cabna porsi nunvalsi)
467      (nunvalsi)
468      (mapti porsi (make-javni-valsi cmene secuxna-nastura)))
469
470    (javni-samselpla porsi mapti-samselpla-cabna namapti))
471  javni-samselpla-cabna)
472
473(define (nunjavni-cmene javni #!key cmene nastura)
474  (let ((nunvalsi-cmene (make-nunvalsi cmene nastura)))
475    (define (javni-cmene porsi mapti namapti)
476      (define (mapti-cmene porsi nunvalsi)
477        (mapti porsi (nunvalsi-cmene (javni-nunvalsi-val nunvalsi))))
478      (javni porsi mapti-cmene namapti))
479    javni-cmene))
480
481(define (nunjavni-nastura javni)
482  (define (javni-nastura porsi mapti namapti)
483    (define (mapti-nastura porsi ignore-nunvalsi)
484      (define (nunvalsi-nastura)
485        (make-javni-valsi #f secuxna-nastura))
486      (mapti porsi nunvalsi-nastura))
487    (javni porsi mapti-nastura namapti))
488  javni-nastura)
Note: See TracBrowser for help on using the repository browser.