source: project/release/4/genturfahi/trunk/samselpla.scm @ 27313

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

genturfahi: false-failured in {}-expressions.

{} expressions can appear at the top of a .peg file, and are
executed before the main grammar to set global parsing options.

For the set of tokens not to memoize, the return value was not
properly set resulting in parse failure.

File size: 27.4 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;;; code for PEG parser.
22;;;
23
24;; We gensym all non-terminal names in order to avoid name
25;; collisions.  This is particularly important if
26;; |define-toplevel| is #t.
27;;
28(define samselpla-hash-table  (make-hash-table string=?))
29(define samselpla-hash-table* (make-hash-table string=?))
30
31(define (samselpla-cmene->symbol cmene)
32  (hash-table-ref samselpla-hash-table
33                  cmene
34                  (lambda ()
35                    (let ((symbol
36                            (gensym
37                              (string->symbol
38                                (string-append cmene "-")))))
39                      (hash-table-set! samselpla-hash-table
40                                       cmene
41                                       symbol)
42                      symbol))))
43
44(define (samselpla-cmene->symbol* cmene)
45  (hash-table-ref samselpla-hash-table*
46                  cmene
47                  (lambda ()
48                    (let ((symbol
49                             (gensym
50                               (string->symbol
51                                 (string-append cmene "-")))))
52                      (hash-table-set! samselpla-hash-table*
53                                       cmene
54                                       symbol)
55                      symbol))))
56
57; a hash table containing rules that we won't be memoizing
58;
59(define samselpla-namorji (make-hash-table string=?))
60
61(define (samselpla-namorji? naselci-cmene)
62  (hash-table-exists? samselpla-namorji naselci-cmene))
63
64
65;; ignore the FAhO tag in the file, and
66;; just return the header code and grammar.
67;;
68(define (samselpla-cfari #!key gerna)
69  (call-with-values
70    (lambda () (unzip2 gerna))
71    (lambda (smuni-nunselci smuni)
72      (let ((selci-cmene (secuxna-start-production))
73            (rodatamgau  (secuxna-define-name))
74            (toplevel    (secuxna-define-toplevel)))
75
76        ; toplevel definition with mulitple start productions
77        ;
78        (define (suhorecmene-e-toplevel tamgau selci-cmene nunselci-cmene)
79          (map (lambda (tamgau cmene javni)
80                  `(define
81                     ,tamgau
82                     ,javni))
83               tamgau selci-cmene nunselci-cmene))
84
85        ; (let ...) definition with multiple start productions
86        ;
87        (define (suhorecmene-enai-toplevel selci-cmene nunselci-cmene)
88          `((values ,@(map (lambda (javni) javni) nunselci-cmene))))
89
90        ; toplevel definition with a single start production.
91        ;
92        (define (pacmene-e-toplevel tamgau selci-cmene nunselci-cmene)
93          `((define ,tamgau ,nunselci-cmene)))
94
95        ; (let ...) definition with a single start production.
96        ;
97        (define (pacmene-enai-toplevel selci-cmene nunselci-cmene)
98          `(,nunselci-cmene))
99
100        ; reset the start production.
101        (secuxna-start-production #f)
102
103        (let ((jalge
104          (if (not (null? smuni))
105              `(,@(if toplevel '() '(let ()))
106                ,@smuni-nunselci
107                ,@smuni
108                (tolmohi-nunjavni)
109                ,@(if (list? rodatamgau)
110
111                      (let ((rodatamgau
112                              (map string->symbol rodatamgau))
113                            (nunselci-cmene
114                              (map samselpla-cmene->symbol selci-cmene)))
115                        (if toplevel
116                            (suhorecmene-e-toplevel rodatamgau
117                                                    selci-cmene
118                                                    nunselci-cmene)
119                            (suhorecmene-enai-toplevel selci-cmene
120                                                       nunselci-cmene)))
121
122                      (let ((rodatamgau
123                              (string->symbol  rodatamgau))
124                            (nunselci-cmene
125                              (samselpla-cmene->symbol selci-cmene)))
126                        (if toplevel
127                            (pacmene-e-toplevel rodatamgau
128                                                selci-cmene
129                                                nunselci-cmene)
130                            (pacmene-enai-toplevel selci-cmene
131                                                   nunselci-cmene)))))
132            '())))
133
134          (hash-table-clear! samselpla-hash-table)
135          (hash-table-clear! samselpla-hash-table*)
136          (hash-table-clear! samselpla-namorji)
137
138          jalge)))))
139
140(define (samselpla-cfari-samselpla #!key rodalerfu)
141  (let* ((valsi     (apply string rodalerfu))
142         (samselpla (call-with-input-string valsi read)))
143    ; evaluate parameters before compiling the code.
144    (safe-eval samselpla environment: genturfahi-env)
145
146    ; update the list of non-terminals that we don't memoize
147    ;
148    (let ((no-memoize (secuxna-no-memoize)))
149      ; since we've registered all of the rules not to
150      ; memoize, make sure we do memoize the rest of them.
151      ;
152      (secuxna-no-memoize #f)
153
154      (type-case no-memoize
155        (string (hash-table-set! samselpla-namorji no-memoize #t)
156                ; success
157                #t)
158        (list   (for-each (lambda (naselci)
159                            (hash-table-set! samselpla-namorji naselci #t))
160                          no-memoize)
161                ; success
162                #t)
163        ;;
164        ;; this should be an error case, but I haven't built an
165        ;; error handling framework for this system yet.
166        ;;
167        (else   #f)))))
168
169;; emit the non-terminal with it's rule.
170;;
171;; we assume we're in a letrec.
172;;
173(define (samselpla-smuni #!key naselci javni)
174  ; if this is the first non-terminal we've seen, it is the
175  ; initial rule of the grammar.
176  (if (not (secuxna-start-production))
177      (secuxna-start-production naselci))
178
179  ; we create two symbols for each terminal rule.  One is the
180  ; definition and the other is the reference.
181  ;
182  (let ((symbol-nunselci (samselpla-cmene->symbol  naselci))
183        (symbol          (samselpla-cmene->symbol* naselci)))
184
185    (if (pair? javni)
186        ; there are a set of productions that we should never
187        ; memoize.  memoization in this case is more expensive
188        ; than running the rule.
189        ;
190        (case (car javni)
191          ((morji-nunjavni-lerfu
192            morji-nunjavni-.*
193            morji-nunjavni-.+
194            morji-nunjavni-.kuspe
195            morji-nunjavni-.
196            morji-nunjavni-e
197            morji-nunjavni-nil
198            morji-nunjavni-fanmo
199            morji-nunjavni-valsi)
200           (hash-table-set! samselpla-namorji naselci #t)))
201
202        ; don't memoize a non-terminal production which consists
203        ; only of another non-terminal production.
204        ;
205        (hash-table-set! samselpla-namorji naselci #t))
206
207          ; outer letrec (which stores references)
208          ;
209    (list `(define ,symbol-nunselci
210             (nunjavni-secuxna
211               (lambda () ',(string->symbol naselci))
212                 (lambda (porsi mapti namapti)
213                   (,symbol porsi mapti namapti))))
214
215          ; inner let (which stores grammar rules)
216          ;
217          `(define ,symbol
218                   ; If a non-terminal production is a sequence, wrap that
219                   ; call in a javni-valsi so that the non-terminal only
220                   ; returns a single value when it is used in other
221                   ; productions.
222                   ;
223            ,(if (or (samselpla-namorji? naselci) (secuxna-no-memoize))
224                 javni
225                 `(nunjavni-morji ,javni))))))
226
227
228(define (samselpla-naselci #!key cfari fanmo)
229  (string-append (make-string 1 cfari) fanmo))
230
231;; sequence: wrap the current rule in a sequence operator, unless
232;;           it is only a single rule, in which case we pass it
233;;           untouched.
234;;
235;;           this is where we attach code to a production as well,
236;;
237(define (samselpla-je #!key samselpla javni)
238         ; if any of the rules are in a group (denoted by the
239         ; porsumti flag being true), distributed a porja'e flag
240         ; to all of the rules so we can splice the group.
241         ;
242  (let ((porsumti?  (fold (lambda (x y) (or x y)) #f
243                      (map
244                        (match-lambda
245                          ((_ ... 'porsumti: #t) #t)
246                          (_ #f))
247                        javni)))
248
249         ; a single rule?
250         ;
251        (pavjavni?  (null? (cdr javni)))
252
253         ; is there code to attach?
254         ;
255        (samselpla? (not (and (string? samselpla) (string=? "" samselpla)))))
256
257      ; if any of the javni are a group, have all javni return their
258      ; result as a list so we can splice the group.
259      ;
260      (define (nunporjahe javni)
261        (define (porjahe javni)
262          (if (symbol? javni)
263              `(morji-nunjavni-porjahe ,javni)
264              `(,@javni porjahe: #t)))
265
266            ; a single javni doesn't need to distributed porjahe
267            ; flags, exclude them.
268            ;
269        (if (and porsumti? (not pavjavni?))
270            (map porjahe javni)
271            javni))
272
273      ; if there is more than one javni, wrap it in a sequence operator.
274      ; After this point there is only a single javni, though we
275      ; still might treat it differently.
276      ;
277      (define (nunpavjavni javni)
278        (let ((javni (if pavjavni?
279                         (car javni)
280                         `(morji-nunjavni-je (list ,@javni)))))
281
282          ; if our rules are returning lists, join them together.
283          ;
284          (if (and porsumti? (not pavjavni?))
285              `(,@javni porsumti: #t)
286              javni)))
287
288      ; if we have code to attach, do that.  The routine returning
289      ; to the code must have porjahe set to true, but that might
290      ; have been done before we got here.
291      ;
292      (define (nunsamselpla samselpla javni)
293        (if samselpla?
294            `(,@samselpla
295               ,(match javni
296                  ; if we have a symbol, wrap it
297                  ;
298                  ((? symbol? _) `(morji-nunjavni-porjahe ,javni))
299
300                  ; if porjahe is already set, either
301                  ; as a wrap or a #!key argument, don't
302                  ; set it twice.
303                  ;
304                  (`(morji-nunjavni-porjahe ,_) javni)
305                  ((_ ... 'porjahe: #t) javni)
306
307                  ; if we have a rule, set the porjahe
308                  ; flag.
309                  ;
310                  (_ `(,@javni porjahe: #t))))
311            javni))
312
313    (nunsamselpla samselpla (nunpavjavni (nunporjahe javni)))))
314
315;; backquote: the following operator should not modify the parse tree.
316;;
317(define (samselpla-nastura-javni #!key javni)
318  (if (symbol? javni)
319      ; if we have a non-terminal, we must use |morji-nunjavni-nastura|.
320      ;
321      `(morji-nunjavni-nastura ,javni)
322      `(,@javni nastura: #t)))
323
324;; tag: attach a name to the rule.  If the rule is a non-terminal,
325;; we must wrap the rule in a tagging call, but other rules directly
326;; accept a name argument.
327;;
328(define (samselpla-pajavni-cmene #!key cmene javni)
329  (if (string=? "" cmene)
330      javni
331      (if (symbol? javni)
332          ; if we have a non-terminal, we must use |morji-nunjavni-cmene|.
333          ;
334          `(morji-nunjavni-cmene ,javni cmene: ,cmene)
335          `(,@javni cmene: ,cmene))))
336
337;; ordered choice: the passed in rules are an ordered choice.
338;;
339(define (samselpla-jonai #!key cfari fanmo)
340  `(morji-nunjavni-jonai (list ,cfari ,@fanmo)))
341
342(define (samselpla-girzu-javni javni)
343  ; with nested parenthesis, we may try to
344  ; decorate a rule more than once.  Detect
345  ; that case and skip adding the porjahe
346  ; flag.
347  ;
348  (define (porjahe javni)
349    (match javni
350      ((? symbol? _)                `(morji-nunjavni-porjahe ,javni))
351      (`(morji-nunjavni-porjahe ,_) javni)
352      ((_ ... 'porjahe: #t)         javni)
353      (_                            `(,@javni porjahe: #t))))
354
355  ; check for an existing porsumti #!key before writing one.
356  ;
357  (define (porsumti? sumti jalge)
358    (or jalge (match sumti (`(porsumti: #t . ,_) #t) (_ #f))))
359
360  (match javni
361    (((or 'morji-nunjavni-je
362          'morji-nunjavni-jonai) . _)
363
364       ; morji-nunjavni-je or morji-nunjavni-jonai sequence
365       ;
366     `(,(car javni)
367
368       ; set flags for each rule in the sequence
369       ;
370       (list ,@(map (lambda (javni) (porjahe javni)) (cdadr javni)))
371
372       ; preserve rules that exist for the sequence rule
373       ;
374       ,@(cddr javni)
375
376       ; set the porsumti flag, unless it has been set already.
377       ;
378       ,@(if (pair-fold porsumti? #f (cddr javni)) '() '(porsumti: #t))))
379
380    ; anything else means the () was optional, and can be skipped.
381    ;
382    (_ javni)))
383
384
385(define (samselpla-.* #!key cmene)
386  `(morji-nunjavni-.* ,@(if (string=? "" cmene) '() `(cmene: ,cmene))))
387
388(define (samselpla-.+ #!key cmene)
389  `(morji-nunjavni-.+ ,@(if (string=? "" cmene) '() `(cmene: ,cmene))))
390
391(define (samselpla-.kuspe #!key cmene my slakabu ny)
392  ; if I have a single range with no comma, match exactly that many
393  ; times.
394  ;
395  (if (not (or slakabu (string=? "" my)))
396      (set! ny my))
397
398  `(morji-nunjavni-.kuspe ,@(if (string=? "" cmene)
399                                '()
400                                `(cmene: ,cmene))
401                          ,@(if (string=? "" my)
402                                '()
403                                `(my: ,(string->number my)))
404                          ,@(if (string=? "" ny)
405                                '()
406                               `(ny: ,(string->number ny)))))
407
408(define (samselpla-? #!key cmene javni)
409  (define porsumti? (match javni
410                      ((_ ... 'porsumti: #t) #t)
411                      (_ #f)))
412
413  (define (nilnarstura javni)
414    ; some rules don't modify the parse tree by default.
415    ;
416    (define (stura? sumti jalge)
417      (or jalge (match sumti (`(nastura: #f . ,_) #t) (_ #f))))
418
419    ; other rules do modify the parse tree by default.
420    ;
421    (define (narstura? sumti jalge)
422      (or jalge (match sumti (`(nastura: #t . ,_) #t) (_ #f))))
423
424    ; if an embedded rule has a ni #!key, return that count so
425    ; we can sum it with our own.
426    (define (nilstura sumti jalge)
427      (match sumti (`(ni: ,klani . ,_) klani) (_ jalge)))
428
429    (match javni
430       ; look for backquoted non-terminal rules.
431       ;
432      (`(morji-nunjavni-nastura . ,_)
433        0)
434
435       ; these rules don't return a result, unless nastura is #f.
436       ;
437      (((or 'morji-nunjavni-lerfu
438            'morji-nunjavni-e
439            'morji-nunjavni-fanmo
440            'morji-nunjavni-valsi
441            'morji-nunjavni-&
442            'morji-nunjavni-!) _ . sumti)
443         (if (pair-fold stura? #f sumti) 1 0))
444
445     (`(morji-nunjavni-? . ,sumti)
446         (pair-fold nilstura 1 sumti))
447
448       ; check if nastura is true.
449       ;
450      ((_ . sumti)
451         (if (pair-fold narstura? #f sumti) 0 1))))
452
453
454  ; |1| if we don't need to pass a count.  Otherwise, the count
455  ; of elements to return when this rule doesn't match.
456  ;
457  ; XXX: we miss one case here, which is where we have a
458  ;      non-terminal rule that isn't backquoted, but the rule
459  ;      itself doesn't modify the tree.  We could determine
460  ;      whether we have one of these by loking at the definition
461  ;      of the rule, but we can't do that here--it needs to wait
462  ;      until the full grammar is parsed.  As there is a workaround
463  ;      (backquote a non-terminal) I don't yet solve this problem.
464  ;
465  (define niljavni (match javni
466                     (('morji-nunjavni-je `(list . ,javni) . _)
467                      (fold fx+ 0 (map nilnarstura javni)))
468                     (('morji-nunjavni-jonai `(list . ,javni) . _)
469                      (apply fxmax (map nilnarstura javni)))
470                     (_ 1)))
471
472  (let ((default (secuxna-?-default)))
473    `(morji-nunjavni-? ,(if porsumti?
474                            `(,@javni porjahe: #t)
475                            javni)
476                       ,@(if (string=? "" cmene)
477                             '()
478                             `(cmene: ,cmene))
479                       ,@(if (fx> niljavni 1)
480                             `(ni: ,niljavni)
481                             '())
482                       ,@(if (equal? "" default)
483                             '()
484                             `(default: ,default))
485                       ,@(if porsumti?
486                             '(porsumti: #t)
487                             '()))))
488
489;; zero-or-more
490;;
491(define (samselpla-* #!key cmene javni)
492  (define porsumti? (match javni
493                      ((_ ... 'porsumti: #t) #t)
494                      (_ #f)))
495
496  (let ((default (secuxna-*-default)))
497    `(morji-nunjavni-* ,(if porsumti?
498                            `(,@javni porjahe: #t)
499                            javni)
500                       ,@(if (string=? "" cmene)
501                             '()
502                             `(cmene: ,cmene))
503                       ,@(if (null? default)
504                             '()
505                             `(default: ,default))
506                       ,@(if porsumti?
507                             '(porsumti: #t)
508                             '()))))
509
510;; one-or-more
511;;
512(define (samselpla-+ #!key cmene javni)
513  (define porsumti? (match javni
514                      ((_ ... 'porsumti: #t) #t)
515                      (_ #f)))
516
517  `(morji-nunjavni-+ ,(if porsumti?
518                          `(,@javni porjahe: #t)
519                          javni)
520                     ,@(if (string=? "" cmene)
521                           '()
522                           `(cmene: ,cmene))
523                     ,@(if porsumti?
524                           '(porsumti: #t)
525                           '())))
526
527;; range
528;;
529(define (samselpla-kuspe #!key cmene javni my slakabu ny)
530  ; if I have a single range with no comma, match exactly that many
531  ; times.
532  ;
533  (if (not (or slakabu (string=? "" my)))
534      (set! ny my))
535
536  (define porsumti? (match javni
537                      ((_ ... 'porsumti: #t) #t)
538                      (_ #f)))
539
540  (let ((default (secuxna-*-default)))
541    `(morji-nunjavni-kuspe ,(if porsumti?
542                                `(,@javni porjahe: #t)
543                                javni)
544                           ,@(if (string=? "" cmene)
545                                 '()
546                                 `(cmene: ,cmene))
547                           ,@(if (null? default)
548                                 '()
549                                 `(default: ,default))
550                           ,@(if porsumti?
551                                 '(porsumti: #t)
552                                 '())
553                           ,@(if (string=? "" my)
554                                 '()
555                                 `(my: ,(string->number my)))
556                           ,@(if (string=? "" ny)
557                                 '()
558                                 `(ny: ,(string->number ny))))))
559
560;; and-predicate
561;;
562(define (samselpla-& #!key javni)
563  `(morji-nunjavni-& ,javni))
564
565;; not-predicate
566;;
567(define (samselpla-! #!key javni)
568  `(morji-nunjavni-! ,javni))
569
570(define (samselpla-fanmo)
571  (let ((sentinel (secuxna-sentinel)))
572    `(morji-nunjavni-fanmo ,@(if (eq? #\nul sentinel)
573                                 '()
574                                 `(sentinel: ,sentinel)))))
575
576(define (samselpla-cmene-sumti #!key cfari fanmo)
577  `,(string-append (make-string 1 cfari) fanmo))
578
579;; A naselci that appears on the right side of a definition.
580;;
581(define (samselpla-selci-naselci #!key naselci)
582  (samselpla-cmene->symbol naselci))
583
584(define (samselpla-stura-lerfu-selci #!key lerfu)
585  `(morji-nunjavni-lerfu ,lerfu nastura: #f))
586
587(define (samselpla-lerfu-selci #!key lerfu)
588  `(morji-nunjavni-lerfu ,lerfu))
589
590(define (samselpla-lerfu-space)
591  #\space)
592
593(define (samselpla-lerfu-linefeed)
594  #\linefeed)
595
596(define (samselpla-lerfu-newline)
597  #\newline)
598
599(define (samselpla-lerfu-return)
600  #\return)
601
602(define (samselpla-lerfu-tab)
603  #\tab)
604
605(define (samselpla-lerfu-page)
606  #\page)
607
608(define (samselpla-stura-valsi-selci #!key valsi-lerfu)
609  `(morji-nunjavni-valsi ,(apply string-append valsi-lerfu) nastura: #f))
610
611(define (samselpla-valsi-selci #!key valsi-lerfu)
612  `(morji-nunjavni-valsi ,(apply string-append valsi-lerfu)))
613
614(define (samselpla-valsi-newline)
615  "\n")
616
617(define (samselpla-valsi-return)
618  (make-string 1 #\return))
619
620(define (samselpla-valsi-tab)
621  (make-string 1 #\tab))
622
623(define (samselpla-valsi-page)
624  (make-string 1 #\page))
625
626(define (samselpla-valsi-backslash)
627  (make-string 1 #\\))
628
629(define (samselpla-valsi-single-quote)
630  (make-string 1 #\'))
631
632(define (samselpla-valsi-left-single-quote)
633  (make-string 1 #\‘))
634
635(define (samselpla-valsi-right-single-quote)
636  (make-string 1 #\’))
637
638(define (samselpla-valsi-double-quote)
639  (make-string 1 #\"))
640
641(define (samselpla-valsi-left-double-quote)
642  (make-string 1 #\“))
643
644(define (samselpla-valsi-right-double-quote)
645  (make-string 1 #\”))
646
647(define (samselpla-valsi-lerfu #!key lerfu)
648  (make-string 1 lerfu))
649
650(define (samselpla-alnum)
651  'char-set:letter+digit)
652
653(define (samselpla-alpha)
654  'char-set:letter)
655
656(define (samselpla-ascii)
657  'char-set:ascii)
658
659(define (samselpla-blank)
660  'char-set:blank)
661
662(define (samselpla-cntrl)
663  'char-set:iso-control)
664
665(define (samselpla-digit)
666  'char-set:digit)
667
668(define (samselpla-graph)
669  'char-set:graphic)
670
671(define (samselpla-jbolehu)
672  `(char-set-xor
673     (char-set-union char-set:letter+digit (char-set #\' #\’))
674     (char-set #\q #\w)))
675
676(define (samselpla-jbocahu)
677  `(char-set-xor
678     (char-set-union char-set:whitespace
679                     char-set:punctuation
680                     (char-set #\.))
681     (char-set #\' #\,)))
682
683(define (samselpla-lower)
684  'char-set:lower-case)
685
686(define (samselpla-odigit)
687  (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))
688
689(define (samselpla-print)
690  'char-set:printing)
691
692(define (samselpla-punct)
693  'char-set:punctuation)
694
695(define (samselpla-space)
696  'char-set:whitespace)
697
698(define (samselpla-upper)
699  'char-set:upper-case)
700
701(define (samselpla-xdigit)
702  'char-set:hex-digit)
703
704(define (samselpla-^alnum)
705  `(char-set-xor (char-set-complement char-set:letter+digit)
706                 (char-set ,(secuxna-sentinel))))
707
708(define (samselpla-^alpha)
709  `(char-set-xor (char-set-complement char-set:letter)
710                 (char-set ,(secuxna-sentinel))))
711
712(define (samselpla-^ascii)
713  `(char-set-xor (char-set-complement char-set:ascii)
714                 (char-set ,(secuxna-sentinel))))
715
716(define (samselpla-^blank)
717  `(char-set-xor (char-set-complement char-set:blank)
718                 (char-set ,(secuxna-sentinel))))
719
720(define (samselpla-^cntrl)
721  `(char-set-xor (char-set-complement char-set:iso-control)
722                 (char-set ,(secuxna-sentinel))))
723
724(define (samselpla-^digit)
725  `(char-set-xor (char-set-complement char-set:digit)
726                 (char-set ,(secuxna-sentinel))))
727
728(define (samselpla-^graph)
729  `(char-set-xor (char-set-complement char-set:graphic)
730                 (char-set ,(secuxna-sentinel))))
731
732(define (samselpla-^lower)
733  `(char-set-xor (char-set-complement char-set:lower-case)
734                 (char-set ,(secuxna-sentinel))))
735
736(define (samselpla-^odigit)
737  `(char-set-xor (char-set-complement
738                 (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7))
739                 (char-set ,(secuxna-sentinel))))
740
741(define (samselpla-^print)
742  `(char-set-xor (char-set-complement char-set:printing)
743                 (char-set ,(secuxna-sentinel))))
744
745(define (samselpla-^punct)
746  `(char-set-xor (char-set-complement char-set:punctuation)
747                 (char-set ,(secuxna-sentinel))))
748
749(define (samselpla-^space)
750  `(char-set-xor (char-set-complement char-set:whitespace)
751                 (char-set ,(secuxna-sentinel))))
752
753(define (samselpla-^upper)
754  `(char-set-xor (char-set-complement char-set:upper-case)
755                 (char-set ,(secuxna-sentinel))))
756
757(define (samselpla-^xdigit)
758  `(char-set-xor (char-set-complement char-set:hex-digit)
759                 (char-set ,(secuxna-sentinel))))
760
761(define (samselpla-klesi-newline)
762  #\newline)
763
764(define (samselpla-klesi-return)
765  #\return)
766
767(define (samselpla-klesi-tab)
768  #\tab)
769
770(define (samselpla-klesi-page)
771  #\page)
772
773(define (samselpla-klesi-lbracket)
774  #\[)
775
776(define (samselpla-klesi-rbracket)
777  #\])
778
779(define (samselpla-klesi-backslash)
780  #\\)
781
782(define (samselpla-klesi-lerfu #!key klesi-lerfu)
783  klesi-lerfu)
784
785
786(define (samselpla-klesi-selci-* #!key klesi-lerfu)
787  (samselpla-klesi-selci klesi-lerfu: klesi-lerfu
788                         javni: 'morji-nunjavni-char-set-*))
789
790(define (samselpla-klesi-selci-+ #!key klesi-lerfu)
791  (samselpla-klesi-selci klesi-lerfu: klesi-lerfu
792                         javni: 'morji-nunjavni-char-set-+))
793
794(define (samselpla-klesi-selci #!key klesi-lerfu
795                                     (javni 'morji-nunjavni-char-set)
796                                     (key '()))
797  (define (union char-sets)
798    (call-with-values
799      (lambda ()
800        (partition char? char-sets))
801
802      (lambda (char char-set)
803        (let ((cs `(,@char-set
804                    ,@(if (null? char) '() `((char-set ,@char))))))
805          (if (null? (cdr cs))
806              (car cs)
807              `(char-set-union ,@cs))))))
808
809  `(,javni ,(union klesi-lerfu) ,@key))
810
811(define (samselpla-klesi-selci-kuspe #!key klesi-lerfu my slakabu ny)
812  ; if I have a single range with no comma, match exactly that many
813  ; times.
814  ;
815  (if (not (or slakabu (string=? "" my)))
816      (set! ny my))
817
818  (let ((key `(,@(if (string=? "" my)
819                     '()
820                     `(my: ,(string->number my)))
821               ,@(if (string=? "" ny)
822                     '()
823                     `(ny: ,(string->number ny))))))
824    (samselpla-klesi-selci klesi-lerfu: klesi-lerfu
825                           javni:       'morji-nunjavni-char-set-kuspe
826                           key:         key)))
827
828
829(define (samselpla-denpabu)
830  `(morji-nunjavni-.))
831
832(define (samselpla-samselpla-xadni #!key rodalerfu)
833  (read (open-input-string (apply string rodalerfu))))
834
835(define (samselpla-samselpla-cmene #!key cfari fanmo)
836  (string->symbol (string-append (make-string 1 cfari) fanmo)))
837
838(define (samselpla-samselpla-balvi samselpla)
839  `(morji-nunjavni-samselpla ,samselpla))
840
841(define (samselpla-samselpla-cabna samselpla)
842  `(morji-nunjavni-samselpla-cabna ,samselpla))
843
844(define (samselpla-stura-empty-string)
845  (let ((empty-string (secuxna-empty-string)))
846    `(morji-nunjavni-e nastura: #f
847                       ,@(if (string=? "" empty-string)
848                             '()
849                             `(empty-string: ,empty-string)))))
850
851(define (samselpla-empty-string)
852  (let ((empty-string (secuxna-empty-string)))
853    `(morji-nunjavni-e ,@(if (string=? "" empty-string)
854                             '()
855                             `(empty-string: ,empty-string)))))
856
857(define (samselpla-empty-list)
858  (let ((empty-list (secuxna-empty-list)))
859    `(morji-nunjavni-nil ,@(if (eq? '() empty-list)
860                               '()
861                               `(empty-list: ,empty-list)))))
Note: See TracBrowser for help on using the repository browser.