schleifen

 1(require-extension srfi-1)
 2
 3(define (set-variable env variable)
 4  (let ((pair (assoc (car variable) env)))
 5    (if pair
 6        (begin
 7          (set-cdr! pair (cdr variable))
 8          env)
 9        (cons variable env))))
10
11(define (ntimes n fn arg)
12  (if (> n 0)
13      (ntimes (- n 1) fn (fn arg))
14      arg))
15
16(define (variable-name lvalue)
17  (assert (eq? (car lvalue) 'var))
18  (cdr lvalue))
19
20(define (variable-value env variable)
21  (assert (eq? (car variable) 'var))
22  (let ((value (assoc (cdr variable) env)))
23    (if value (cdr value) 0)))
24
25(define (eval-literal literal)
26  (assert (eq? (car literal) 'lit))
27  (cdr literal))
28
29(define (eval-operation op)
30  (assert (eq? (car op) 'op))
31  (let ((o (cdr op)))
32    (cond ((eq? o 'plus) +)
33          ((eq? o 'minus) -)
34          (else (error "invalid operation")))))
35
36(define (eval-expression env expr)
37  (assert (eq? (car expr) 'expr))
38  (let ((v1 (eval-rvalue env (second expr)))
39        (op (eval-operation (third expr)))
40        (v2 (eval-rvalue env (fourth expr))))
41    (op v1 v2)))
42
43(define (eval-rvalue env rvalue)
44  (let ((kind (car rvalue)))
45    (cond ((eq? kind 'lit)
46           (eval-literal rvalue))
47          ((eq? kind 'var)
48           (variable-value env rvalue))
49          ((eq? kind 'expr)
50           (eval-expression env rvalue))
51          (else (display kind) (newline) (error "invalid rvalue")))))
52
53(define (eval-assign env lvalue rvalue)
54  (set-variable env (cons (variable-name lvalue)
55                          (eval-rvalue env rvalue))))
56
57(define (eval-loop env cond body)
58  (let ((amount (eval-rvalue env cond)))
59    (ntimes amount (lambda (env)
60                     (eval-loop-prog env body)) env)))
61
62(define (eval-command comp env)
63  (let ((kind (car comp)) (args (cdr comp)))
64    (cond ((eq? kind 'loop)
65           (eval-loop env (first args) (second args)))
66          ((eq? kind 'assign)
67           (eval-assign env (first args) (second args)))
68          (else (error "invalid command")))))
69
70(define (eval-loop-prog env prog)
71  (fold eval-command env prog))