compile: Remove unused macros.
[software/python-on-guile.git] / modules / language / python / parser.scm
1 (define-module (language python parser)
2 #:use-module (logic guile-log)
3 #:use-module ((logic guile-log parser) #:select (*whitespace*))
4 #:use-module (ice-9 match)
5 #:use-module (ice-9 pretty-print)
6 #:use-module (language python parser-tool)
7 #:export (p python-parser))
8
9 (define do-print #f)
10 (define pp
11 (case-lambda
12 ((s x)
13 (when do-print
14 (pretty-print `(,s ,(syntax->datum x))))
15 x)
16 ((x)
17 (when do-print
18 (pretty-print (syntax->datum x)))
19 x)))
20 (define ppp
21 (case-lambda
22 ((s x)
23 (pretty-print `(,s ,(syntax->datum x)))
24 x)
25 ((x)
26 (pretty-print (syntax->datum x))
27 x)))
28
29 (define-syntax-rule (Ds f) (lambda x (apply f x)))
30 (define-syntax-rule (DDs op f ...) (op (lambda x (apply f x)) ...))
31
32 (define divide truncate/)
33 ;; +++++++++++++++++++++++++++++++++++++ SCANNER SUBSECTION
34 (define nl (f-or f-nl f-eof))
35 (define com (f-seq "#" (f* (f-not f-nl)) nl))
36 (define w (f-reg "[\t\r| ]"))
37 (define ws+ (f+ (f-or (f-reg "[\t\r| ]") com)))
38 (define ws* (f+ (f-or (f-reg "[\t\r| ]") com)))
39 (define ws ws*)
40
41
42 (define (wn_ n i)
43 (<p-lambda> (c)
44 (cond
45 ((> i n) <fail>)
46 ((= i n)
47 (.. ((f-and (f-not w) f-true) c)))
48 ((< i n)
49 (<or>
50 (<and!>
51 (.. (c) ((f-tag " ") c))
52 (.. ((wn_ n (+ i 1)) c)))
53 (<and!>
54 (.. (c) ((f-tag "\t") c))
55 (.. ((wn_ n (divide (+ i 8) 8)) c)))
56 (<and!>
57 (.. (c) ((f-tag "\r") c))
58 (.. ((wn_ n i) c))))))))
59
60 (define (wn+_ n i)
61 (<p-lambda> (c)
62 (<pp> `(,n ,i))
63 (<or>
64 (<and!>
65 (.. (c) ((f-tag " ") c))
66 (.. ((wn+_ n (+ i 1)) c)))
67 (<and!>
68 (.. (c) ((f-tag "\t") c))
69 (.. ((wn+_ n (divide (+ i 8) 8)) c)))
70 (<and!>
71 (.. (c) ((f-tag "\r") c))
72 (.. ((wn+_ n i) c)))
73 (<and!>
74 (when (> i n))
75 (<with-bind> ((INDENT (cons i INDENT)))
76 (<p-cc> c))))))
77
78 (define wn+
79 (<p-lambda> (c)
80 (<let> ((n (car INDENT)))
81 (.. ((wn+_ n 0) c)))))
82
83 (define wn
84 (<p-lambda> (c)
85 (<let> ((n (car INDENT)))
86 (.. ((wn_ n 0) c)))))
87
88 (define indent= wn)
89 (define indent+ wn+)
90 (define indent-
91 (<p-lambda> (c)
92 (<with-bind> ((INDENT (cdr INDENT)))
93 (<p-cc> c))))
94
95 (define identifier__
96 (let ()
97 (define ih (f-reg! "[a-zA-Z_]"))
98 (define i.. (f-or! 'or ih (f-reg! "[0-9]")))
99 (mk-token
100 (f-seq ih (f* i..)))))
101
102 (define keyw (make-hash-table))
103 (for-each
104 (lambda (x) (hash-set! keyw (symbol->string x) #t))
105 '(False None True and as assert break class continue def
106 del elif else except finally for from global if import
107 in is lambda nonlocal not or pass raise return try
108 while with yield))
109
110 (define decimal (mk-token (f-seq (f-reg! "[1-9]") (f* (f-reg! "[0-9]")))))
111 (define oct (mk-token
112 (f-seq "0" (f-reg "[oO]") (f+ (f-reg! "[0-7]")))))
113 (define hex (mk-token
114 (f-seq "0" (f-reg "[xX]") (f+ (f-reg! "[0-7a-fA-F]")))))
115 (define bin (mk-token
116 (f-seq "0" (f-reg "[bB]") (f+ (f-reg! "[01]")))))
117
118 (define integer
119 (<p-lambda> (c)
120 (<and!>
121 (<or>
122 (<and>
123 (.. (c) (decimal c))
124 (<p-cc> (string->number c 10)))
125 (<and>
126 (.. (c) (oct c))
127 (<p-cc> (string->number c 8)))
128 (<and>
129 (.. (c) (hex c))
130 (<p-cc> (string->number c 16)))
131 (<and>
132 (.. (c) (bin c))
133 (<p-cc> (string->number c 2)))))))
134
135 (define intpart (f+ (f-reg! "[0-9]")))
136 (define fraction (f-seq (f-tag! ".") intpart))
137 (define exponent (f-seq (f-reg! "[eE]") (f? (f-reg! "[+-]")) intpart))
138 (define pointfloat (f-or! (f-seq (f? intpart) fraction)
139 (f-seq intpart (f-tag! "."))))
140 (define exponentfloat (f-seq (f-or intpart pointfloat) exponent))
141
142 (define floatnumber (mk-token (f-or! exponentfloat pointfloat)))
143 (define float
144 (<p-lambda> (c)
145 (.. (c) (floatnumber c))
146 (<p-cc> (string->number c))))
147
148 (define imagnumber (mk-token (f-seq (f-or floatnumber integer) (f-reg "[jJ]"))))
149 (define imag
150 (<p-lambda> (c)
151 (.. (c) (imagnumber c))
152 (<p-cc> (string->number (string-append "0+" c "i")))))
153
154 (define (mk-id S c cc) cc)
155
156 (define number
157 (p-freeze 'number
158 (f-or! imag float integer)
159 mk-id))
160
161 (define identifier_
162 (let ()
163 (define (__*__ i)
164 (match (string->list i)
165 ((#\_ #\_ . l)
166 (match (reverse l)
167 ((#\_ #\_ . l) #t)
168 (_ #f)))
169 (_ #f)))
170
171 (define (__* i)
172 (match (string->list i)
173 ((#\_ #\_ . l)
174 #t)
175 (_ #f)))
176
177 (define (_* i)
178 (match (string->list i)
179 ((#\_ . l)
180 #t)
181 (_ #f)))
182
183 (<p-lambda> (c)
184 (.. (i) (identifier__ c))
185 (cond
186 ((__*__ i)
187 (<p-cc> `(#:identifier ,i #:system)))
188 ((__* i)
189 (<p-cc> `(#:identifier ,i #:private)))
190 ((_* i)
191 (<p-cc> `(#:identifier ,i #:local)))
192 ((eq? i '_)
193 (<p-cc> #:_))
194 ((hash-ref keyw i)
195 (<p-cc> `(#:keyword ,i)))
196 (else
197 (<p-cc> `(#:identifier ,i)))))))
198
199 (define identifier
200 (<p-lambda> (c)
201 (.. (i) (identifier_ c))
202 (if (not (eq? (car i) #:keyword))
203 (<p-cc> i)
204 <fail>)))
205
206 ;;;; +++++++++++++++++++++++++++++++++++++++++++++++ STRING +++++++++++++++
207 (define string-prefix (mk-token (f-reg! "[ruRU]")))
208 (define short-string-char (f-not! (f-reg "[\n\"']")))
209 (define long-string-char (f-not! "\n"))
210 (define string-esc (f-seq (f-tag "\\") (f-reg! ".")))
211 (define short-string-item (f-or short-string-char string-esc))
212 (define long-string-item (f-or long-string-char string-esc))
213
214 (define long-string
215 (mk-token
216 (f-or
217 (f-seq! "'''" (f* long-string-item) "'''")
218 (f-seq! "\"\"\"" (f* long-string-item) "\"\"\""))))
219
220 (define short-string
221 (mk-token
222 (f-or
223 (f-seq! "'" (f* short-string-item) "'")
224 (f-seq! "\"" (f* short-string-item) "\""))))
225
226 (define string
227 (p-freeze 'string-literal
228 (f-list #:string
229 (ff? string-prefix)
230 (f-or! long-string short-string))
231 mk-id))
232
233 ;; ++++++++++++++++++++++++++++++++++++++++++ BYTE ++++++++++++++++++++++++++
234
235 (define bytes-prefix
236 (mk-token
237 (f-or!
238 (f-seq! (f-tag! "b") (f-or f-true (f-reg! "[rR]")))
239 (f-seq! (f-tag! "B") (f-or f-true (f-reg! "[rR]")))
240 (f-seq! (f-tag! "r") (f-or f-true (f-reg! "[bB]")))
241 (f-seq! (f-tag! "R") (f-or f-true (f-reg! "[bB]"))))))
242
243 (define bytes-esc (f-seq "\\" (f-reg ".")))
244
245 (define short-bytes-char (f-not! (f-reg "[\\\n'\"]")))
246 (define long-bytes-char (f-not! (f-reg "[\\]")))
247
248 (define short-bytes-item
249 (f-or short-bytes-char bytes-esc))
250
251 (define long-bytes-item
252 (f-or long-bytes-char bytes-esc))
253
254 (define short-bytes
255 (mk-token
256 (f-or! (f-seq! "'" (f* short-bytes-item) "'")
257 (f-seq! "\"" (f* short-bytes-item) " \""))))
258
259 (define long-bytes
260 (mk-token
261 (f-or! (f-seq! "'''" (f* long-bytes-item) "'''")
262 (f-seq! "\"\"\"" (f* long-bytes-item) "\"\"\""))))
263
264 (define bytes-literal
265 (p-freeze 'string-literal
266 (<p-lambda> (c)
267 (.. (pre) (bytes-prefix c))
268 (.. (str) ((f-or! long-bytes short-bytes) pre))
269 (<p-cc> (#:bytes pre str)))
270 mk-id))
271
272
273 ; +++++++++++++++++++++++++++++++++++ PARSER SUBSECTION +++++++++++++++++
274 (define stmt #f)
275 (define testlist #f)
276 (define dottaed_name #f)
277 (define arglist #f)
278 (define classdef #f)
279 (define funcdef #f)
280 (define test #f)
281 (define small_stmt #f)
282
283
284 (define expr_stmt #f)
285 (define del_stmt #f)
286 (define pass_stmt #f)
287 (define flow_stmt #f)
288 (define import_stmt #f)
289 (define global_stmt #f)
290 (define nonlocal_stmt #f)
291 (define assert_stmt #f)
292 (define testlist_star_expr #f)
293 (define augassign #f)
294 (define yield_expr #f)
295 (define star_expr #f)
296 (define exprlist #f)
297 (define import_name #f)
298 (define import_from #f)
299 (define dotted_as_names #f)
300 (define import_as_names #f)
301 (define if_stmt #f)
302 (define while_stmt #f)
303 (define for_stmt #f)
304 (define try_stmt #f)
305 (define with_stmt #f)
306 (define suite #f)
307 (define except_clause #f)
308 (define with_item #f)
309 (define expr #f)
310 (define or_test #f)
311 (define lambdef #f)
312 (define lambdef_nocond #f)
313 (define and_test #f)
314 (define not_test #f)
315 (define comparison #f)
316 (define comp_op #f)
317 (define xor_expr #f)
318 (define and_expr #f)
319 (define or_expr #f)
320 (define arith_expr #f)
321 (define shift_expr #f)
322 (define term #f)
323 (define factor #f)
324 (define power #f)
325 (define atom #f)
326 (define trailer #f)
327 (define subscriptlist #f)
328 (define testlist_comp #f)
329 (define dictorsetmaker #f)
330 (define comp_for #f)
331 (define subscript #f)
332 (define sliceop #f)
333 (define argument #f)
334 (define comp_if #f)
335 (define yield_arg #f)
336 (define dotted_name #f)
337
338 (define file-input (f-seq (f* (f-or nl (f-seq indent= stmt))) f-eof))
339
340 (define eval-input (f-seq testlist (f* nl) f-eof))
341
342 (define decorator (f-cons (f-seq ws "@" ws (Ds dotted_name) ws)
343 (f-seq (ff? (f-seq "(" ws (ff? (Ds arglist))
344 ws ")" ws))
345 f-nl)))
346
347 (define decorators (ff+ decorator))
348
349
350 (define decorated (f-list #:decorated
351 decorators
352 (f-or classdef funcdef)))
353
354 (define FALSE (f-out #f))
355 (define tfpdef
356 (f-cons identifier (f-or
357 (f-seq ":" ws test ws)
358 FALSE)))
359
360 (define vfpdef identifier)
361 (define mk-py-list
362 (lambda (targlist tfpdef)
363 (let* ((t (f-or (f-seq "=" (Ds test)) FALSE))
364 (arg (f-list tfpdef t))
365 (arg.. (ff* (f-seq "," arg)))
366 (args (f-cons arg arg..))
367 (arg* (f-seq "*" (f-list tfpdef arg..)))
368 (arg** (f-seq "**" tfpdef)))
369 (f-cons
370 targlist
371 (f-or!
372 (f-cons args
373 (f-or (f-list arg* (f-or arg** FALSE))
374 (f-list FALSE FALSE)))
375 (f-list FALSE arg* (f-or arg** FALSE))
376 (f-list FALSE FALSE arg**)
377 (f-list 'a1 '() FALSE FALSE))))))
378
379 (define typedargslist (mk-py-list #:types-args-list tfpdef))
380 (define varargslist (mk-py-list #:var-args-list vfpdef))
381
382 (define parameters (f-seq! 'parameters
383 "(" (f-or typedargslist
384 (f-out (list #f #f #f)))
385 ")"))
386
387 (set! funcdef
388 (p-freeze 'funcdef
389 (f-list 'fundef
390 #:def
391 (f-seq "def" identifier)
392 parameters
393 (ff? (f-seq! "->" (Ds test)))
394 (f-seq ":" (Ds suite)))
395 mk-id))
396
397 (define simple_stmt (f-list 'simple_stmt #:stmt
398 (f-seq
399 (f-cons (Ds small_stmt)
400 (ff* (f-seq ";" (Ds small_stmt))))
401 (f? ";") (f? ws) (f-or nl f-eof))))
402 (set! small_stmt
403 (Ds
404 (f-or 'small expr_stmt del_stmt pass_stmt flow_stmt import_stmt global_stmt
405 nonlocal_stmt assert_stmt)))
406
407 (set! expr_stmt
408 (f-list 'expr_stmt
409 #:expr-stmt
410 (Ds testlist_star_expr)
411 (f-or!
412 (f-list 'augassign #:augassign
413 (Ds augassign)
414 (f-or (Ds yield_expr) (Ds testlist)))
415 (f-cons 'assign #:assign
416 (ff* (f-seq "="
417 (f-or (Ds yield_expr)
418 (Ds testlist_star_expr))))))))
419
420 (set! testlist_star_expr
421 (f-cons 'testlist_star_expr
422 (f-or (Ds test) (Ds star_expr))
423 (f-seq
424 (ff* (f-seq "," (f-or (Ds test) (Ds star_expr))))
425 (f? ","))))
426
427
428 (set! augassign
429 (mk-token
430 (f-seq 'augassign
431 ws
432 (apply f-or!
433 (map f-tag
434 '("+=" "-=" "*=" "/=" "%=" "&=" "|=" "^="
435 "<<=" ">>=" "**=" "//=")))
436 ws)))
437
438 (set! del_stmt (f-cons 'del_stmt #:del (f-seq "del" (Ds exprlist))))
439
440 (set! pass_stmt (f-seq 'pass_stmt "pass" #:pass))
441
442 (set! flow_stmt
443 (f-or 'flow_stmt
444 (f-seq "break" #:break)
445 (f-seq "continue" #:continue)
446 (f-cons #:return (f-seq "return" (ff? (Ds testlist))))
447 (Ds yield_expr)
448 (f-cons #:raise (f-seq "raise"
449 (f-or (f-cons (Ds test)
450 (ff?
451 (f-seq "from" (Ds test))))
452 (f-cons FALSE FALSE))))))
453
454 (set! import_name (f-seq "import" dotted_as_names))
455 (set! import_stmt (f-list #:import
456 (f-or 'import_stmt import_name (Ds import_from))))
457
458
459
460 (define dottir (mk-token (f-or! (f-tag! "...") (f-tag! "."))))
461 (define dots* (ff* dottir))
462 (define dots+ (ff+ dottir))
463
464 (set! import_from
465 (f-seq 'import_from "from"
466 (f-cons
467 (f-or (f-cons dots* (Ds dotted_name)) dots+)
468 (f-seq "import" (f-or "*"
469 (f-seq "(" (Ds import_as_names) ")")
470 (Ds import_as_names))))))
471
472 (define import_as_name
473 (f-cons identifier (ff? (f-seq "as" identifier))))
474
475 (define dotted_as_name
476 (f-cons (Ds dotted_name) (ff? (f-seq "as" identifier))))
477
478 (set! import_as_names
479 (f-seq
480 (f-cons import_as_name (ff* (f-seq "," import_as_name)))
481 (f? ",")))
482
483 (set! dotted_as_names
484 (f-cons dotted_as_name (ff* (f-seq "," dotted_as_name))))
485
486 (set! dotted_name
487 (f-cons identifier (ff* (f-seq "." identifier))))
488
489 (define comma_name
490 (f-cons identifier (ff* (f-seq "," identifier))))
491
492 (set! global_stmt
493 (f-cons 'global #:global (f-seq "global" comma_name)))
494
495 (set! nonlocal_stmt
496 (f-cons 'nonlocal #:nonlocal (f-seq "nonlocal" comma_name)))
497
498 (set! assert_stmt
499 (f-cons 'assert #:assert
500 (f-seq "assert" (f-cons (Ds test) (ff* (f-seq "," (Ds test)))))))
501
502
503 (define compound_stmt
504 (Ds
505 (f-or! 'compound
506 if_stmt while_stmt for_stmt try_stmt with_stmt funcdef classdef
507 decorated)))
508
509 (define single_input (f-or! (f-seq indent= simple_stmt)
510 (f-seq indent= compound_stmt nl)
511 (f-seq (f-or nl f-eof))))
512
513
514 (set! stmt (f-or 'stmt simple_stmt compound_stmt))
515
516 (set! if_stmt
517 (f-cons 'if_stmt
518 #:if
519 (f-seq
520 "if"
521 (f-cons (Ds test)
522 (f-seq ":"
523 (f-cons (Ds suite)
524 (f-cons
525 (ff* (f-seq "elif"
526 (f-cons (Ds test)
527 (f-seq ":" (Ds suite)))))
528 (ff? (f-seq "else" ":" (Ds suite))))))))))
529
530 (set! while_stmt
531 (f-cons 'while
532 #:while
533 (f-seq "while"
534 (f-cons (Ds test)
535 (f-seq ":"
536 (f-cons (Ds suite)
537 (ff? (f-seq "else" ":" (Ds suite)))))))))
538
539 (set! for_stmt
540 (f-cons 'for
541 #:for
542 (f-seq "for"
543 (f-cons (Ds exprlist)
544 (f-seq "in"
545 (f-cons (Ds testlist)
546 (f-cons (f-seq ":" (Ds suite))
547 (ff? (f-seq "else" ":" (Ds suite))))))))))
548
549 (set! try_stmt
550 (f-cons 'try
551 #:try
552 (f-seq ws "try" ":"
553 (f-cons (Ds suite)
554 (f-or
555 (f-cons
556 (ff+ (f-list (Ds except_clause) ":" (Ds suite)))
557 (f-cons
558 (ff? (f-seq "else" ":" (Ds suite)))
559 (ff? (f-seq "finally" ":" ws (Ds suite)))))
560 (f-cons
561 FALSE
562 (f-cons
563 FALSE
564 (f-seq "finally" ":" (Ds suite)))))))))
565
566 (set! with_item
567 (f-cons (Ds test) (f-seq "as" (Ds expr))))
568
569 (set! with_stmt
570 (f-cons 'with
571 #:with
572 (f-seq "with"
573 (f-cons
574 (f-cons with_item
575 (ff* (f-seq "," with_item)))
576 (f-seq ":" (Ds suite))))))
577
578
579 (set! except_clause
580 (f-seq 'except "except"
581 (ff? (f-cons (Ds test) (ff? (f-seq "as" identifier))))))
582
583 (set! suite
584 (f-cons #:suite
585 (f-or! (f-list simple_stmt)
586 (f-seq nl indent+
587 (f-cons stmt
588 (ff* (f-seq indent= stmt)))
589 indent-))))
590
591 (set! test
592 (f-or! 'test
593 (f-list #:test
594 (Ds or_test)
595 (ff? (f-list
596 (f-seq "if" (Ds or_test))
597 (f-seq "else" test))))
598 (Ds lambdef)))
599
600 (define test_nocond
601 (f-or 'nocond (Ds or_test) (Ds lambdef_nocond)))
602
603 (set! lambdef
604 (f-list 'lambdef
605 #:lambdef
606 (f-seq "lambda" (ff? (Ds varargslist) '()))
607 (f-seq ":" (Ds test))))
608
609 (set! lambdef_nocond
610 (f-list 'lambdef_nocond
611 'lambdef #:lambdef
612 (f-seq "lambda" (ff? (Ds varargslist) '()))
613 (f-seq ":" test_nocond)))
614
615 (set! or_test
616 (p-freeze 'or_test
617 (f-or! 'or_test
618 (f-cons #:or (f-cons (Ds and_test) (ff+ (f-seq "or" (Ds and_test)))))
619 (Ds and_test))
620 mk-id))
621
622 (set! and_test
623 (p-freeze 'and_test
624 (f-or! 'and_test
625 (f-cons #:and (f-cons (Ds not_test) (ff+ (f-seq "and" (Ds not_test)))))
626 (Ds not_test))
627 mk-id))
628
629 (set! not_test
630 (f-or! 'not_test
631 (f-cons #:not (f-seq "not" not_test))
632 (Ds comparison)))
633
634 (set! comparison
635 (p-freeze 'comparison
636 (f-or! 'comparison
637 (f-cons #:comp
638 (f-cons (Ds expr)
639 (ff+ (f-cons (Ds comp_op) (Ds expr)))))
640 (Ds expr))
641 mk-id))
642
643 (set! comp_op
644 (f-or! 'comp_op
645 (f-seq (f-seq "not" "in" ) (f-out "notin"))
646 (f-seq (f-seq "is" "not") (f-out "isnot"))
647 (apply f-or!
648 (map (lambda (x) (f-seq x (f-out x)))
649 '("==" ">=" "<=" "<>" "!=" "in" "is" "<" ">" )))))
650
651
652 (set! star_expr (f-cons 'star_expr #:starexpr (f-seq "*" (Ds expr))))
653 (set! expr
654 (p-freeze 'expr
655 (f-or! 'expr
656 (f-cons #:bor (f-cons (Ds xor_expr) (ff+ (f-seq "|" (Ds xor_expr)))))
657 (Ds xor_expr))
658 mk-id))
659
660 (set! xor_expr
661 (p-freeze 'xor
662 (f-or! 'xor
663 (f-cons #:bxor (f-cons (Ds and_expr) (ff+ (f-seq "^" (Ds and_expr)))))
664 (Ds and_expr))
665 mk-id))
666
667 (set! and_expr
668 (p-freeze 'and
669 (f-or! 'and
670 (f-cons #:band (f-cons (Ds shift_expr)
671 (ff+ (f-seq "&" (Ds shift_expr)))))
672 (Ds shift_expr))
673 mk-id))
674
675 (set! shift_expr
676 (p-freeze 'shift
677 (f-or! 'shift
678 (f-cons #:<< (f-cons (Ds arith_expr) (ff+ (f-seq "<<" (Ds arith_expr) ))))
679 (f-cons #:>> (f-cons (Ds arith_expr) (ff+ (f-seq ">>" (Ds arith_expr) ))))
680 (Ds arith_expr))
681 mk-id))
682
683 (set! arith_expr
684 (p-freeze 'arith
685 (f-or! 'arith
686 (f-cons #:+ (f-cons (Ds term) (ff+ (f-seq 'rest "+" (Ds term) ))))
687 (f-cons #:- (f-cons (Ds term) (ff+ (f-seq "-" (Ds term) ))))
688 (f-seq 'single_term (Ds term)))
689 mk-id))
690
691 (set! term
692 (p-freeze 'term
693 (f-or! 'term
694 (f-cons #:* (f-cons (Ds factor) (ff+ (f-seq "*" (Ds factor) ))))
695 (f-cons #:// (f-cons (Ds factor) (ff+ (f-seq "//" (Ds factor) ))))
696 (f-cons #:/ (f-cons (Ds factor) (ff+ (f-seq "/" (Ds factor) ))))
697 (f-cons #:% (f-cons (Ds factor) (ff+ (f-seq "%" (Ds factor) ))))
698 (f-seq 'single-factor (Ds factor)))
699 mk-id))
700
701
702 (set! factor
703 (p-freeze 'factor
704 (f-or! 'factor
705 (f-cons #:u+ (f-seq "+" factor))
706 (f-cons #:u- (f-seq "-" factor))
707 (f-cons #:u~ (f-seq "~" factor))
708 (Ds power))
709 mk-id))
710
711 (set! power
712 (p-freeze 'power
713 (f-cons 'power #:power
714 (f-cons (f-or (f-list #:f (Ds identifier) ":" (Ds atom)) (Ds atom))
715 (f-cons (ff* (Ds trailer))
716 (f-or! (f-seq "**" factor)
717 FALSE))))
718 mk-id))
719
720 (set! trailer
721 (f-or! 'trailer
722 (f-seq "(" (ff? (Ds arglist)) ")")
723 (f-seq "[" (Ds subscriptlist) "]")
724 (f-seq (f-list #:dot (ff+ "." identifier))))
725
726 (set! atom
727 (p-freeze 'atom
728 (f-or! 'atom
729 (f-cons
730 #:subexpr
731 (f-seq "(" (ff? (f-or! (Ds yield_expr) (Ds testlist_comp))) ")"))
732 (f-cons
733 #:list
734 (f-seq "[" (ff? (Ds testlist_comp)) ")"))
735 (f-cons
736 #:dict
737 (f-seq "{" (ff? (Ds dictorsetmaker)) "}"))
738 (f-seq 'identifier identifier)
739 (f-seq 'number number)
740 (ff+ string)
741 (f-seq #:... "...")
742 (f-seq #:None "None")
743 (f-seq #:True "True")
744 (f-seq #:false "False"))
745 mk-id))
746
747 (set! testlist_comp
748 (f-cons
749 (f-or! star_expr test)
750 (f-or!
751 comp_for
752 (f-seq (ff* (f-seq "," (f-or! star_expr test)))
753 (f? ",")))))
754
755 (set! subscriptlist
756 (f-cons* 'subscriptlist
757 #:subscripts
758 (Ds subscript)
759 (f-seq (ff* (f-seq "," (Ds subscript))) (f? ","))))
760
761 (set! subscript
762 (f-or! 'subscript
763 (f-list (ff? test '()) (f-seq ":" (ff? test '())) (ff? (Ds sliceop)))
764 (f-list test FALSE FALSE)))
765
766 (set! sliceop
767 (f-seq ":" (ff? test '())))
768
769 (define exprlist
770 (let ((f (f-or expr star_expr)))
771 (f-cons f (f-seq (ff* (f-seq "," f)) (f? ",")))))
772
773 (set! testlist
774 (f-cons
775 test
776 (f-seq (ff* (f-seq "," test)) (f? ","))))
777
778 (set! dictorsetmaker
779 (let ((f (f-cons test (f-seq ":" test))))
780 (f-or!
781 (f-cons* f (f-seq (ff* (f-seq "," f)) (f? ",")))
782 (f-cons f (Ds comp_for))
783 (f-cons test (Ds comp_for))
784 (f-cons test (f-seq (ff* (f-seq "," test)) (f? ","))))))
785
786 (set! classdef
787 (f-list
788 #:classdef
789 (f-seq "class" identifier)
790 (ff? (f-seq "(" (ff? (Ds arglist) '()) ")"))
791 (f-seq ":" suite)))
792
793 (set! arglist
794 (f-or! 'arglist
795 (f-list 'arg0
796 #:arglist
797 (f-seq (ff* (f-seq (Ds argument) ",")))
798 (f-seq "*" (f-cons test (ff* (f-seq "," (Ds argument)))))
799 (ff? (f-seq "," "**" test)))
800
801 (f-list 'arg1
802 #:arglist
803 (f-seq (ff* (f-seq (Ds argument) ",")))
804 FALSE
805 (f-seq "**" test))
806
807 (f-list 'arg2
808 #:arglist
809 (f-seq (f-append (ff* (f-seq (Ds argument) ","))
810 (f-seq (Ds argument) (f? ","))))
811 FALSE FALSE)))
812
813 (set! argument
814 (f-or!
815 (f-list #:= test (f-seq "=" test))
816 (f-list #:comp test (ff? (Ds comp_for)))))
817
818 (define comp_iter (f-or! (Ds comp_for) (Ds comp_if)))
819 (define comp_for (f-list (f-seq "for" exprlist)
820 (f-seq "in" or_test)
821 (ff? comp_iter)))
822 (set! comp_if (f-list (f-seq "if" test_nocond)
823 (ff? comp_iter)))
824
825 (set! yield_expr
826 (f-list #:yield (f-seq "yield" (ff? (Ds yield_arg)))))
827
828 (set! yield_arg
829 (f-or!
830 (f-list #:from (f-seq "from" test))
831 (f-list #:list testlist)))
832
833
834 (define input (f-seq
835 (ff+ (f-seq (f? ws)
836 (f-or! (f-seq indent= simple_stmt)
837 (f-seq indent= compound_stmt nl))))
838
839 (f-seq (f? ws) (f-or nl f-eof))))
840
841 (define (p str)
842 (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
843 (parse str input)))
844
845 (define (python-parser . l)
846 (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
847 (ppp (apply parse (append l (list (f-seq nl ws single_input ws)))))))
848
849