schleifen

 1(require-extension comparse)
 2
 3(define parse-spaces
 4  (zero-or-more (in #\newline #\tab #\ )))
 5
 6(define (parse-string str)
 7  (sequence* ((_ parse-spaces)
 8              (v (char-seq str))
 9              (_ parse-spaces))
10    (result v)))
11
12(define parse-variable
13  (bind (as-string (char-seq-match "^[a-zA-Z_][a-zA-Z0-9_]*"))
14        (lambda (s)
15          (result (cons 'var s)))))
16
17(define parse-operator
18  (any-of
19    (parse-string "+")
20    (parse-string "-")))
21
22(define parse-operation
23  (bind (as-string parse-operator)
24        (lambda (s)
25          (result (cons 'op (cond ((equal? s "+") 'plus)
26                                  ((equal? s "-") 'minus)))))))
27
28(define parse-literal
29  (bind (as-string (char-seq-match "^[0-9]*"))
30        (lambda (s) (result (cons 'lit (string->number s))))))
31
32(define parse-primitive
33  (any-of parse-variable parse-literal))
34
35(define parse-expression
36  (bind (sequence parse-primitive parse-operation parse-primitive)
37        (lambda (s) (result (cons 'expr s)))))
38
39(define parse-value
40  (any-of parse-expression parse-primitive))
41
42(define parse-assign
43  (sequence* ((var parse-variable)
44              (_   (parse-string ":="))
45              (val parse-value))
46    (result (list 'assign var val))))
47
48(define parse-loop
49  (sequence* ((_    (parse-string "LOOP"))
50              (cond parse-value)
51              (body parse-loop-body))
52    (result (list 'loop cond body))))
53
54(define (parse-command)
55  (bind (sequence (any-of parse-loop parse-assign) (parse-string ";"))
56        (lambda (s) (result (car s)))))
57
58(define parse-commands
59  (sequence* ((_    parse-spaces)
60              (cmds (zero-or-more (parse-command)))
61              (_    parse-spaces))
62    (result cmds)))
63
64(define parse-loop-body
65  (enclosed-by (parse-string "DO") parse-commands (parse-string "DONE")))
66
67(define parse-program
68  (sequence* ((prog parse-commands)
69              (_    end-of-input))
70    (result prog)))
71
72(define (parse-loop-prog input)
73  (let ((prog (parse parse-program input)))
74    (if prog prog #f)))