development
[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 (set! stmt (f-or 'stmt simple_stmt compound_stmt))
514
515 (set! if_stmt
516 (f-cons 'if_stmt
517 #:if
518 (f-seq
519 "if"
520 (f-cons (Ds test)
521 (f-seq ":"
522 (f-cons (Ds suite)
523 (f-cons
524 (ff* (f-seq "elif"
525 (f-cons (Ds test)
526 (f-seq ":" (Ds suite)))))
527 (ff? (f-seq "else" ":" (Ds suite))))))))))
528
529 (set! while_stmt
530 (f-cons 'while
531 #:while
532 (f-seq "while"
533 (f-cons (Ds test)
534 (f-seq ":"
535 (f-cons (Ds suite)
536 (ff? (f-seq "else" ":" (Ds suite)))))))))
537
538 (set! for_stmt
539 (f-cons 'for
540 #:for
541 (f-seq "for"
542 (f-cons (Ds exprlist)
543 (f-seq "in"
544 (f-cons (Ds testlist)
545 (f-cons (f-seq ":" (Ds suite))
546 (ff? (f-seq "else" ":" (Ds suite))))))))))
547
548 (set! try_stmt
549 (f-cons 'try
550 #:try
551 (f-seq ws "try" ":"
552 (f-cons (Ds suite)
553 (f-or
554 (f-cons
555 (ff+ (f-seq (Ds except_clause) ":" (Ds suite)))
556 (f-cons
557 (ff? (f-seq "else" ":" (Ds suite)))
558 (ff? (f-seq "finally" ":" ws (Ds suite)))))
559 (f-cons
560 FALSE
561 (f-cons
562 FALSE
563 (f-seq "finally" ":" (Ds suite)))))))))
564
565 (set! with_item
566 (f-cons (Ds test) (f-seq "as" (Ds expr))))
567
568 (set! with_stmt
569 (f-cons 'with
570 #:with
571 (f-seq "with"
572 (f-cons
573 (f-cons with_item
574 (ff* (f-seq "," with_item)))
575 (f-seq ":" (Ds suite))))))
576
577
578 (set! except_clause
579 (f-seq 'except "except"
580 (ff? (f-cons (Ds test) (ff? (f-seq "as" identifier))))))
581
582 (set! suite
583 (f-cons #:suite
584 (f-or! (f-list simple_stmt)
585 (f-seq nl indent+
586 (f-cons stmt
587 (ff* (f-seq indent= stmt)))
588 indent-))))
589
590 (set! test
591 (f-or! 'test
592 (f-list #:test
593 (Ds or_test)
594 (ff? (f-list
595 (f-seq "if" (Ds or_test))
596 (f-seq "else" test))))
597 (Ds lambdef)))
598
599 (define test_nocond
600 (f-or 'nocond (Ds or_test) (Ds lambdef_nocond)))
601
602 (set! lambdef
603 (f-list 'lambdef
604 #:lambdef
605 (f-seq "lambda" (ff? (Ds varargslist) '()))
606 (f-seq ":" (Ds test))))
607
608 (set! lambdef_nocond
609 (f-list 'lambdef_nocond
610 'lambdef #:lambdef
611 (f-seq "lambda" (ff? (Ds varargslist) '()))
612 (f-seq ":" test_nocond)))
613
614 (set! or_test
615 (p-freeze 'or_test
616 (f-or! 'or_test
617 (f-cons #:or (f-cons (Ds and_test) (ff+ (f-seq "or" (Ds and_test)))))
618 (Ds and_test))
619 mk-id))
620
621 (set! and_test
622 (p-freeze 'and_test
623 (f-or! 'and_test
624 (f-cons #:and (f-cons (Ds not_test) (ff+ (f-seq "and" (Ds not_test)))))
625 (Ds not_test))
626 mk-id))
627
628 (set! not_test
629 (f-or! 'not_test
630 (f-cons #:not (f-seq "not" not_test))
631 (Ds comparison)))
632
633 (set! comparison
634 (p-freeze 'comparison
635 (f-or! 'comparison
636 (f-cons #:comp
637 (f-cons (Ds expr)
638 (ff+ (f-cons (Ds comp_op) (Ds expr)))))
639 (Ds expr))
640 mk-id))
641
642 (set! comp_op
643 (f-or! 'comp_op
644 (f-seq (f-seq "not" "in" ) (f-out "notin"))
645 (f-seq (f-seq "is" "not") (f-out "isnot"))
646 (apply f-or!
647 (map (lambda (x) (f-seq x (f-out x)))
648 '("==" ">=" "<=" "<>" "!=" "in" "is" "<" ">" )))))
649
650
651 (set! star_expr (f-cons 'star_expr #:starexpr (f-seq "*" (Ds expr))))
652 (set! expr
653 (p-freeze 'expr
654 (f-or! 'expr
655 (f-cons #:bor (f-cons (Ds xor_expr) (ff+ (f-seq "|" (Ds xor_expr)))))
656 (Ds xor_expr))
657 mk-id))
658
659 (set! xor_expr
660 (p-freeze 'xor
661 (f-or! 'xor
662 (f-cons #:bxor (f-cons (Ds and_expr) (ff+ (f-seq "^" (Ds and_expr)))))
663 (Ds and_expr))
664 mk-id))
665
666 (set! and_expr
667 (p-freeze 'and
668 (f-or! 'and
669 (f-cons #:band (f-cons (Ds shift_expr)
670 (ff+ (f-seq "&" (Ds shift_expr)))))
671 (Ds shift_expr))
672 mk-id))
673
674 (set! shift_expr
675 (p-freeze 'shift
676 (f-or! 'shift
677 (f-cons #:<< (f-cons (Ds arith_expr) (ff+ (f-seq "<<" (Ds arith_expr) ))))
678 (f-cons #:>> (f-cons (Ds arith_expr) (ff+ (f-seq ">>" (Ds arith_expr) ))))
679 (Ds arith_expr))
680 mk-id))
681
682 (set! arith_expr
683 (p-freeze 'arith
684 (f-or! 'arith
685 (f-cons #:+ (f-cons (Ds term) (ff+ (f-seq 'rest "+" (Ds term) ))))
686 (f-cons #:- (f-cons (Ds term) (ff+ (f-seq "-" (Ds term) ))))
687 (f-seq 'single_term (Ds term)))
688 mk-id))
689
690 (set! term
691 (p-freeze 'term
692 (f-or! 'term
693 (f-cons #:* (f-cons (Ds factor) (ff+ (f-seq "*" (Ds factor) ))))
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-seq 'single-factor (Ds factor)))
698 mk-id))
699
700
701 (set! factor
702 (p-freeze 'factor
703 (f-or! 'factor
704 (f-cons #:u+ (f-seq "+" factor))
705 (f-cons #:u- (f-seq "-" factor))
706 (f-cons #:u~ (f-seq "~" factor))
707 (Ds power))
708 mk-id))
709
710 (set! power
711 (p-freeze 'power
712 (f-cons 'power #:power
713 (f-cons (Ds atom)
714 (f-cons (ff* (Ds trailer))
715 (f-or! (f-seq "**" factor)
716 FALSE))))
717 mk-id))
718
719 (set! trailer
720 (f-or! 'trailer
721 (f-seq "(" (ff? (Ds arglist)) ")")
722 (f-seq "[" (Ds subscriptlist) "]")
723 (f-seq "." identifier)))
724
725 (set! atom
726 (p-freeze 'atom
727 (f-or! 'atom
728 (f-cons
729 #:subexpr
730 (f-seq "(" (ff? (f-or! (Ds yield_expr) (Ds testlist_comp))) ")"))
731 (f-cons
732 #:list
733 (f-seq "[" (ff? (Ds testlist_comp)) ")"))
734 (f-cons
735 #:dict
736 (f-seq "{" (ff? (Ds dictorsetmaker)) "}"))
737 (f-seq 'identifier identifier)
738 (f-seq 'number number)
739 (ff+ string)
740 (f-seq #:... "...")
741 (f-seq #:None "None")
742 (f-seq #:True "True")
743 (f-seq #:false "False"))
744 mk-id))
745
746 (set! testlist_comp
747 (f-cons
748 (f-or! star_expr test)
749 (f-or!
750 comp_for
751 (f-seq (ff* (f-seq "," (f-or! star_expr test)))
752 (f? ",")))))
753
754 (set! subscriptlist
755 (f-cons* 'subscriptlist
756 #:subscripts
757 (Ds subscript)
758 (f-seq (ff* (f-seq "," (Ds subscript))) (f? ","))))
759
760 (set! subscript
761 (f-or! 'subscript
762 (f-list (ff? test '()) (f-seq ":" (ff? test '())) (ff? (Ds sliceop)))
763 (f-list test FALSE FALSE)))
764
765 (set! sliceop
766 (f-seq ":" (ff? test '())))
767
768 (define exprlist
769 (let ((f (f-or expr star_expr)))
770 (f-cons f (f-seq (ff* (f-seq "," f)) (f? ",")))))
771
772 (set! testlist
773 (f-cons
774 test
775 (f-seq (ff* (f-seq "," test)) (f? ","))))
776
777 (set! dictorsetmaker
778 (let ((f (f-cons test (f-seq ":" test))))
779 (f-or!
780 (f-cons* f (f-seq (ff* (f-seq "," f)) (f? ",")))
781 (f-cons f (Ds comp_for))
782 (f-cons test (Ds comp_for))
783 (f-cons test (f-seq (ff* (f-seq "," test)) (f? ","))))))
784
785 (set! classdef
786 (f-list
787 #:classdef
788 (f-seq "class" identifier)
789 (ff? (f-seq "(" (ff? (Ds arglist) '()) ")"))
790 (f-seq ":" suite)))
791
792 (set! arglist
793 (f-or! 'arglist
794 (f-list 'arg0
795 #:arglist
796 (f-seq (ff* (f-seq (Ds argument) ",")))
797 (f-seq "*" (f-cons test (ff* (f-seq "," (Ds argument)))))
798 (ff? (f-seq "," "**" test)))
799
800 (f-list 'arg1
801 #:arglist
802 (f-seq (ff* (f-seq (Ds argument) ",")))
803 FALSE
804 (f-seq "**" test))
805
806 (f-list 'arg2
807 #:arglist
808 (f-seq (f-append (ff* (f-seq (Ds argument) ","))
809 (f-seq (Ds argument) (f? ","))))
810 FALSE FALSE)))
811
812 (set! argument
813 (f-or!
814 (f-list #:= test (f-seq "=" test))
815 (f-list #:comp test (ff? (Ds comp_for)))))
816
817 (define comp_iter (f-or! (Ds comp_for) (Ds comp_if)))
818 (define comp_for (f-list (f-seq "for" exprlist)
819 (f-seq "in" or_test)
820 (ff? comp_iter)))
821 (set! comp_if (f-list (f-seq "if" test_nocond)
822 (ff? comp_iter)))
823
824 (set! yield_expr
825 (f-list #:yield (f-seq "yield" (ff? (Ds yield_arg)))))
826
827 (set! yield_arg
828 (f-or!
829 (f-list #:from (f-seq "from" test))
830 (f-list #:list testlist)))
831
832
833 (define (p str)
834 (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
835 (ppp (parse str (f-seq nl single_input)))
836 (if #f #f)))
837
838 (define (python-parser . l)
839 (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]"))))
840 (ppp (apply parse (append l (list (f-seq nl single_input)))))))
841
842