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

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

genturfa'i: add debug and profile support to parser.

This is a fairly substantial patch, adding all of the framework to
produce debug output and profiling information from the parser.
When these options are not enabled, there is a small initialization
penalty and no runtime penalty to the parser.

When debug in enabled, a file is written containing a symbolic
expression describing the path taken by the parser while it matches
the input.

When profile is enabled, timing for non-terminal rules and operators
is written as an association list. This information isn't perfect
yet, as it doesn't subtract containing rules from the timing of
outer rules. For purposes of debugging performance, however, it is
good enough. It allowed me to find some performance issues in the
memoization code, a patch for which is coming up.

File size: 19.1 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    (nunjavni-secuxna
34      (lambda ()
35        (string-append "#\\" (make-string 1 lerfu)))
36        javni-lerfu)))
37
38
39;; selci: parse any single character.
40;;
41(define (nunjavni-. #!key cmene nastura)
42  (let ((nunvalsi-. (make-nunvalsi cmene nastura)))
43    (define (javni-. porsi mapti namapti)
44      (if (lerfu-porsi-fanmo? porsi)
45          (namapti porsi)
46          (mapti (make-lerfu-porsi-pabalvi-lerfu porsi)
47                 (nunvalsi-. (lerfu-porsi-lerfu porsi)))))
48    (nunjavni-secuxna (lambda () "#\.") javni-.)))
49
50
51;; empty-string: parse the empty string, which always succeeds without
52;;               advancing input.
53;;
54(define (nunjavni-e #!key cmene (nastura #t) (empty-string ""))
55  (let ((nunvalsi-e (make-nunvalsi cmene nastura)))
56    (define (javni-e porsi mapti ignore-namapti)
57      (mapti porsi (nunvalsi-e empty-string)))
58    (nunjavni-secuxna (lambda () (make-string 2 #\")) javni-e)))
59
60
61;; empty-list: parse the empty list, which always succeeds without
62;;             advancing input.
63;;
64(define (nunjavni-nil #!key cmene nastura (empty-list '()))
65  (let ((nunvalsi-nil (make-nunvalsi cmene nastura)))
66    (define (javni-nil porsi mapti ignore-namapti)
67      (mapti porsi (nunvalsi-nil empty-list)))
68    (nunjavni-secuxna (lambda () "()") javni-nil)))
69
70
71;; selci: parse the end of input.
72;;
73;; Should this rule return the sentinel character, or should there
74;; be a separate option for the value to return at the end of the file?
75;;
76(define (nunjavni-fanmo #!key cmene nastura (sentinel #\nul))
77  (let ((nunvalsi-fanmo (make-nunvalsi cmene nastura)))
78    (define (javni-fanmo porsi mapti namapti)
79      (if (lerfu-porsi-fanmo? porsi)
80          (mapti porsi (nunvalsi-fanmo sentinel))
81          (namapti porsi)))
82  (nunjavni-secuxna (lambda () "!.") javni-fanmo)))
83
84
85;; selci: parse the specified string
86;;
87(define (nunjavni-valsi valsi #!key cmene (nastura #t))
88  (let ((nilcla (string-length valsi))
89        (nunvalsi-valsi (make-nunvalsi cmene nastura)))
90    (define (javni-valsi porsi mapti namapti)
91      (let ((poi (lerfu-porsi-poi porsi))
92            (zva (lerfu-porsi-zva porsi)))
93        (if (string-prefix? valsi
94                            poi
95                            0
96                            nilcla
97                            zva
98                            (- (string-length poi) 1))
99            (mapti (make-lerfu-porsi-pabalvi-valsi porsi nilcla)
100                   (nunvalsi-valsi valsi))
101            (namapti porsi))))
102    (nunjavni-secuxna
103      (lambda ()
104        (string-append (make-string 1 #\") valsi (make-string 1 #\")))
105        javni-valsi)))
106
107
108(define (nunjavni-char-set-* char-set #!key cmene nastura)
109  (let ((nunvalsi-char-set-* (make-nunvalsi cmene nastura)))
110    (define (javni-char-set-* porsi
111                              mapti
112                              ignore-namapti
113                              #!optional (poi (lerfu-porsi-poi porsi))
114                                         (zva (lerfu-porsi-zva porsi)))
115      (define (mapti-char-set-* zva)
116        (let ((puzva (lerfu-porsi-zva porsi)))
117          (mapti (make-lerfu-porsi-pabalvi-valsi porsi (- zva puzva))
118                 (nunvalsi-char-set-* (string-copy poi puzva zva)))))
119
120      (define (char-set-* poi zva)
121        (if (char-set-contains? char-set (string-ref poi zva))
122            (char-set-* poi (+ 1 zva))
123            zva))
124
125      (mapti-char-set-* (char-set-* poi zva)))
126    (nunjavni-secuxna
127      (lambda () (string-append "[" (char-set->string char-set) "]*"))
128      javni-char-set-*)))
129
130
131(define (nunjavni-char-set-+ char-set #!key cmene nastura)
132  (let ((javni-char-set-* (nunjavni-char-set-* char-set
133                                               cmene: cmene
134                                               nastura: nastura)))
135    (define (javni-char-set-+ porsi mapti namapti)
136      (let ((poi        (lerfu-porsi-poi porsi))
137            (zva        (lerfu-porsi-zva porsi)))
138        (if (char-set-contains? char-set (string-ref poi zva))
139            (javni-char-set-* porsi
140                              mapti
141                              namapti
142                              poi
143                              (+ 1 zva))
144            (namapti porsi))))
145    (nunjavni-secuxna
146      (lambda () (string-append "[" (char-set->string char-set) "]+"))
147      javni-char-set-+)))
148
149;; XXX: inline optimize
150(define (nunjavni-char-set char-set #!key cmene nastura)
151  (let ((nunvalsi-char-set (make-nunvalsi cmene nastura)))
152    (define (javni-char-set porsi mapti namapti)
153
154      (let* ((poi        (lerfu-porsi-poi porsi))
155             (zva        (lerfu-porsi-zva porsi)))
156        (if (char-set-contains? char-set (string-ref poi zva))
157            (mapti (make-lerfu-porsi-pabalvi-lerfu porsi)
158                   (nunvalsi-char-set (lerfu-porsi-lerfu porsi)))
159            (namapti porsi))))
160    (nunjavni-secuxna
161      (lambda () (string-append "[" (char-set->string char-set) "]"))
162      javni-char-set)))
163
164;; zero-or-more: parse zero or more javni out of the |lerfu-porsi|.
165;;
166(define (nunjavni-* javni #!key cmene nastura)
167        ; we merge the results differently when we have a cmene.
168        ; generate the merge routine based on this.
169  (let ((vejmina (venunjmina-rodanunvalsi cmene nastura)))
170    (define (javni-* porsi
171                     mapti
172                     namapti
173                            ; a "dummy head" is a linked-list
174                            ; optimization we'll return the cdr
175                            ; of this list, but by using this
176                            ; extra cons we avoid checking for
177                            ; the beginning of the list below.
178                            ;
179                     #!key (cfari (list '()))
180                           (fanmo cfari))
181      (define (mapti-* porsi nunvalsi)
182        ; append this result to the result list
183        (set-cdr! fanmo (list nunvalsi))
184        (javni-* porsi
185                 mapti
186                 namapti
187                 cfari: cfari
188                 fanmo: (cdr fanmo)))
189
190      (define (namapti-* porsi)
191        ; ignore the failure in |ignore-nunjavni|, as
192        ; this javni cannot fail.  |porsi| is not advanced
193        ; on failure, so we can use it, capturing any
194        ; cases that did succeed.
195        ;
196        (mapti porsi (vejmina (cdr cfari))))
197
198      (javni porsi mapti-* namapti-*))
199    (nunjavni-secuxna (lambda () "*") javni-*)))
200
201
202;; one-or-more: parse one or more javni out of the |lerfu-porsi|.
203;;
204(define (nunjavni-+ javni #!key cmene nastura)
205  (let ((javni-* (nunjavni-* javni cmene: cmene nastura: nastura)))
206    (define (javni-+ porsi mapti namapti)
207      (define (mapti-+ porsi nunvalsi)
208        (let ((fanmo (list nunvalsi)))
209          (javni-* porsi
210                   mapti
211                   namapti
212                   cfari: (cons (list '()) fanmo)
213                   fanmo: fanmo)))
214      (javni porsi mapti-+ namapti))
215    (nunjavni-secuxna (lambda () "+") javni-+)))
216
217
218;; optional: parse an optional javni out of the |lerfu-porsi|.
219;;
220(define (nunjavni-? javni #!key cmene nastura (empty-string ""))
221  (let ((vejmina (venunjmina-nunvalsi cmene nastura))
222        (novejmina (if nastura
223                       (lambda () (make-javni-valsi cmene secuxna-nastura))
224                       (lambda () (make-javni-valsi cmene empty-string)))))
225    (define (javni-? porsi mapti ignore-namapti)
226
227      (define (mapti-? porsi nunvalsi)
228        (mapti porsi (vejmina nunvalsi)))
229
230      (define (namapti-? porsi)
231        ; ignore the failure in |ignore-nunvalsi|, as
232        ; this javni cannot fail.  |porsi| is not advanced
233        ; on failure, so we can use it.
234        ;
235        (mapti porsi novejmina))
236
237      (javni porsi mapti-? namapti-?))
238    (nunjavni-secuxna (lambda () "?") javni-?)))
239
240
241;; and-predicate: succeed or fail without consuming input.
242;;
243(define (nunjavni-& javni)
244  (define (javni-& porsi mapti namapti)
245    (define (mapti-& ignore-porsi ignore-nunvalsi)
246      (mapti porsi (lambda () (make-javni-valsi #f secuxna-nastura))))
247
248    (define (namapti-& ignore-porsi)
249      (namapti porsi))
250
251    (javni porsi mapti-& namapti-&))
252  (nunjavni-secuxna (lambda () "&") javni-&))
253
254
255;; not-predicate: require that |javni| is not able to be parsed from
256;;                the |lerfu-porsi|.
257;;
258(define (nunjavni-! javni)
259  (define (javni-! porsi mapti namapti)
260    (define (mapti-! ignore-porsi nunvalsi)
261      (namapti porsi))
262
263    (define (namapti-! ignore-porsi)
264      (mapti porsi (lambda () (make-javni-valsi #f secuxna-nastura))))
265
266    (javni porsi mapti-! namapti-!))
267  (nunjavni-secuxna (lambda () "!") javni-!))
268
269
270;; sequence: parse |ro da javni| out of the |lerfu-porsi|.
271;;           if any of the do not match, none of them match.
272;;
273(define (nunjavni-je #!rest rodajavni #!key cmene nastura)
274        ; we merge the results differently when we have a cmene.
275        ; generate the merge routine based on this.
276  (let ((vejmina   (venunjmina-rodanunvalsi cmene nastura))
277        ; remove #!key name/value pairs from argument list.
278        (rodajavni (filter procedure? rodajavni)))
279    (define (javni-je porsi
280                      mapti
281                      namapti
282                                 ; capture the initial position, and
283                                 ; then continue to pass it as we
284                                 ; call ourselves recursively.
285                      #!key     (cfari-porsi porsi)
286                                 ; the current rule we're trying.
287                                (rodajavni rodajavni)
288                                 ; a "dummy head" is a linked-list
289                                 ; optimization we'll return the cdr
290                                 ; of this list, but by using this
291                                 ; extra cons we avoid checking for
292                                 ; the beginning of the list below.
293                                 ;
294                                (cfari (list '()))
295                                (fanmo cfari))
296      ; the (nun)valsi passed to us might
297      ; include previously matched javni.  If
298      ; we fail to match a javni, ignore the
299      ; porsi passed to us and use the one from
300      ; the start of this parse rule.
301      ;
302      (define (namapti-je ignore-porsi)
303        (namapti cfari-porsi))
304
305      (let ((javni (car rodajavni))
306            (rest (cdr rodajavni)))
307        (if (null? rest)
308
309            ; called at the end of the list
310            (let ((mapti-je (lambda (porsi nunvalsi)
311                               (set-cdr! fanmo (list nunvalsi))
312                               (mapti porsi (vejmina (cdr cfari))))))
313              (javni porsi mapti-je namapti-je))
314
315            ; called when there are still elements in the list
316            (let ((mapti-je (lambda (porsi nunvalsi)
317                               (set-cdr! fanmo (list nunvalsi))
318                               (javni-je porsi
319                                         mapti
320                                         namapti
321                                         cfari-porsi: cfari-porsi
322                                         rodajavni: rest
323                                         cfari: cfari
324                                         fanmo: (cdr fanmo)))))
325              (javni porsi mapti-je namapti-je)))))
326  (nunjavni-secuxna (lambda () "je") javni-je)))
327
328
329;; ordered-choice: parse the first matching javni out of the
330;;                 |lerfu-porsi|.
331;;
332(define (nunjavni-jonai #!rest rodajavni #!key cmene nastura)
333        ; we merge the results differently when we have a cmene.
334        ; generate the merge routine based on this.
335  (let ((vejmina   (venunjmina-nunvalsi cmene nastura))
336        ; remove #!key name/value pairs from argument list.
337        (rodajavni (filter procedure? rodajavni)))
338    (define (javni-jonai porsi
339                         mapti
340                         namapti
341                         #!optional (rodajavni rodajavni))
342      (define (mapti-jonai porsi nunvalsi)
343        (mapti porsi (vejmina nunvalsi)))
344
345      (let ((javni (car rodajavni))
346            (rest (cdr rodajavni)))
347        (if (null? rest)
348            ; called at the end of the list
349            (javni porsi mapti-jonai namapti)
350
351            ; called when there are still elements in the list
352            (let ((namapti-jonai (lambda (porsi)
353                                  (javni-jonai porsi mapti namapti rest))))
354              (javni porsi mapti-jonai namapti-jonai)))))
355    (nunjavni-secuxna (lambda () "jonai") javni-jonai)))
356
357
358;; morji: memoization is done to ensure we run in linear time.
359;;        Any javni can be memoized, but in practice we memoize
360;;        na selci javni.
361;;
362(define-values (genturfahi-semorji genturfahi-tolmohi nunjavni-morji)
363  (let ((rodasemorji '())
364        (rodatolmohi '()))
365    (values
366      (lambda (nilcla)
367        (map (lambda (semorji) (semorji nilcla)) rodasemorji))
368
369      (lambda ()
370        (map (lambda (tolmohi) (tolmohi)) rodatolmohi))
371
372      (lambda (javni)
373        (let ((morji '()))
374          (define (semorji nilcla)
375            (let ((klani (quotient nilcla 2)))
376              (set! morji (make-hash-table = size: (if (= 0 klani) 1 klani)))))
377
378          (define (tolmohi)
379            (set! morji '()))
380
381          (define (javni-morji morji-porsi mapti namapti)
382            ;; mapti
383            (define (set-mapti-morji! porsi nunvalsi)
384              (define (mapti-morji mapti ignore-namapti)
385                (mapti porsi nunvalsi))
386
387              (hash-table-set! morji
388                               (lerfu-porsi-zva morji-porsi)
389                               mapti-morji))
390
391            ;; namapti
392            (define (set-namapti-morji! porsi)
393              (define (namapti-morji ignore-mapti namapti)
394                (namapti porsi))
395
396              (hash-table-set! morji
397                               (lerfu-porsi-zva morji-porsi)
398                               namapti-morji))
399
400            ;; recurse
401            (define (set-recurse-morji!)
402              (define (recurse-morji ignore-mapti namapti)
403                (namapti morji-porsi))
404
405              (hash-table-set! morji
406                               (lerfu-porsi-zva morji-porsi)
407                               recurse-morji))
408
409            (define (javni-nomorji)
410              (define (mapti-morji porsi nunvalsi)
411                (set-mapti-morji! porsi nunvalsi)
412                (mapti porsi nunvalsi))
413
414              (define (namapti-morji porsi)
415                (set-namapti-morji! porsi)
416                (namapti porsi))
417
418              ; register this parse position to detect left
419              ; recursion.
420              (set-recurse-morji!)
421
422              (javni morji-porsi mapti-morji namapti-morji))
423
424            (let ((nunjalge
425                    (hash-table-ref/default morji
426                                            (lerfu-porsi-zva morji-porsi)
427                                            #f)))
428              (if nunjalge (nunjalge mapti namapti) (javni-nomorji))))
429
430          ; register this cache so we can initialize and clear.
431          ; This routine customizes itself based on the input size,
432          ; and we can free up a substantial amount of memory if
433          ; we clear the caches after we're done parsing.
434          ;
435          (set! rodasemorji (cons semorji rodasemorji))
436          (set! rodatolmohi (cons tolmohi rodatolmohi))
437
438          javni-morji)))))
439
440(define (nunjavni-samselpla samselpla javni #!key cmene)
441  (define (javni-samselpla porsi mapti namapti)
442    (define (mapti-samselpla porsi nunvalsi)
443
444      (define (samselpla-sumti rodavalsi)
445        (call-with-values
446          (lambda ()
447            (partition (lambda (javni) (and (javni-valsi? javni)
448                                            (javni-valsi-cme javni)))
449                       (if (list? rodavalsi)
450                           rodavalsi
451                           `(,rodavalsi))))
452         
453          (lambda (cmesumti sumti)
454            (let ((key (append-map!
455                         (lambda (javni)
456                           `(,(string->keyword (javni-valsi-cme javni))
457                             ,(javni-valsi-val javni)))
458                         cmesumti))
459                  (rest (javni-rodavalsi-val-filter sumti)))
460              (append! (if (list? rest) rest `(,rest)) key)))))
461
462      (define (nunvalsi-samselpla)
463        (let* ((rodavalsi (nunvalsi))
464               (rodaval   (samselpla-sumti rodavalsi))
465               (valsi     (apply samselpla rodaval)))
466          (make-javni-valsi cmene valsi)))
467
468      (mapti porsi nunvalsi-samselpla))
469
470    (javni porsi mapti-samselpla namapti))
471
472  javni-samselpla)
473
474(define (nunjavni-samselpla-cabna samselpla javni #!key cmene)
475  (define javni-samselpla (nunjavni-samselpla samselpla javni))
476
477  (define (javni-samselpla-cabna porsi mapti namapti)
478    (define (mapti-samselpla-cabna porsi nunvalsi)
479      (nunvalsi)
480      (mapti porsi (make-javni-valsi cmene secuxna-nastura)))
481
482    (javni-samselpla porsi mapti-samselpla-cabna namapti))
483  javni-samselpla-cabna)
484
485(define (nunjavni-cmene javni #!key cmene nastura)
486  (let ((nunvalsi-cmene (make-nunvalsi cmene nastura)))
487    (define (javni-cmene porsi mapti namapti)
488      (define (mapti-cmene porsi nunvalsi)
489        (mapti porsi (nunvalsi-cmene (javni-nunvalsi-val nunvalsi))))
490      (javni porsi mapti-cmene namapti))
491    javni-cmene))
492
493(define (nunjavni-nastura javni)
494  (define (javni-nastura porsi mapti namapti)
495    (define (mapti-nastura porsi ignore-nunvalsi)
496      (define (nunvalsi-nastura)
497        (make-javni-valsi #f secuxna-nastura))
498      (mapti porsi nunvalsi-nastura))
499    (javni porsi mapti-nastura namapti))
500  javni-nastura)
501
502;; decorate each rule according to the options specified.
503;;
504(define (nunjavni-secuxna nuncmene javni #!rest cmene-sumti)
505  (define (cfisisku cmene javni)
506    (if (secuxna-debug)
507        (apply nunjavni-cfisisku cmene javni cmene-sumti)
508        javni))
509
510  (define (junla cmene javni)
511    (if (secuxna-profile)
512        (apply nunjavni-junla cmene javni cmene-sumti)
513        javni))
514
515  (if (or (secuxna-debug) (secuxna-profile))
516      (let ((cmene (nuncmene)))
517            (cfisisku cmene (junla cmene javni)))
518      javni))
Note: See TracBrowser for help on using the repository browser.