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

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

genturfa'i: use list, rather than vector, for parser input.

This converts several of the now o(n) routines back to o(1). I
noticed the performance hit, just testing as I converted this
code.

Rather than storing a vector and an index, we store the current
position in the list and advance it as we parse. The grouping
code is now immeasurably slower. You won't notice.

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