git @ Cat's Eye Technologies Pixley / master dialect / pifxley.pifx
master

Tree @master (Download .tar.gz)

pifxley.pifx @master — raw · history · blame 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
(lambda (program)
  (let* ((interpreter (lambda (interpret program env)
    (let*  ((cadr (lambda (alist)
              (car (cdr alist))))
            (null? (lambda (expr)
              (equal? expr (quote ()))))
            (find (lambda (self elem alist)
              (if (null? alist)
                (quote nothing)
                (let* ((entry (car alist))
                       (key   (car entry))
                       (rest  (cdr alist)))
                  (if (equal? elem key)
                    entry
                    (self self elem rest))))))
            (interpret-args (lambda (interpret-args args env)
              (if (null? args)
                args
                (let* ((arg  (car args))
                       (rest (cdr args)))
                  (cons (interpret interpret arg env) (interpret-args interpret-args rest env))))))
            (expand-args (lambda (expand-args formals argvals)
              (if (null? formals)
                formals
                (let* ((formal       (car formals))
                       (rest-formals (cdr formals))
                       (argval       (car argvals))
                       (rest-argvals (cdr argvals)))
                  (cons (cons formal (cons argval (quote ()))) (expand-args expand-args rest-formals rest-argvals))))))
            (concat-envs (lambda (concat-envs new-env old-env)
              (if (null? new-env)
                old-env
                (let* ((entry (car new-env))
                       (rest  (cdr new-env)))
                  (cons entry (concat-envs concat-envs rest old-env))))))
             (call-lambda (lambda (func args env)
               (let* ((arg-vals (interpret-args interpret-args args env)))
                  (func arg-vals)))))
      (if (null? program)
        program
        (if (list? program)
          (let* ((tag   (car program))
                 (args  (cdr program))
                 (entry (find find tag env)))
            (if (list? entry)
              (call-lambda (cadr entry) args env)
              (if (equal? tag (quote lambda))
                (let* ((formals (car args))
                       (body    (cadr args)))
                  (lambda (arg-vals)
                    (let* ((arg-env   (expand-args expand-args formals arg-vals))
                           (new-env   (concat-envs concat-envs arg-env env)))
                      (interpret interpret body new-env))))
                (if (equal? tag (quote if))
                  (let* ((test      (car args))
                         (then-expr (cadr args))
                         (else-expr (cadr (cdr args))))
                    (if (interpret interpret test env)
                      (interpret interpret then-expr env)
                      (interpret interpret else-expr env)))
                  (if (equal? tag (quote let*))
                    (let* ((bindings (car args))
                           (body     (cadr args)))
                      (if (null? bindings)
                        (interpret interpret body env)
                        (let* ((binding  (car bindings))
                               (rest     (cdr bindings))
                               (ident    (car binding))
                               (expr     (cadr binding))
                               (value    (interpret interpret expr env))
                               (new-bi   (cons ident (cons value (quote ()))))
                               (new-env  (cons new-bi env))
                               (newprog  (cons (quote let*) (cons rest (cons body (quote ()))))))
                          (interpret interpret newprog new-env))))
                    (if (equal? tag (quote list?))
                      (list? (interpret interpret (car args) env))
                      (if (equal? tag (quote quote))
                        (car args)
                        (if (equal? tag (quote car))
                          (car (interpret interpret (car args) env))
                          (if (equal? tag (quote cdr))
                            (cdr (interpret interpret (car args) env))
                            (if (equal? tag (quote cons))
                              (cons (interpret interpret (car args) env) (interpret interpret (cadr args) env))
                              (if (equal? tag (quote equal?))
                                (equal? (interpret interpret (car args) env) (interpret interpret (cadr args) env))
                                (if (null? tag)
                                  tag
                                  (if (list? tag)
                                    (call-lambda (interpret interpret tag env) args env)
                                    (call-lambda tag args env))))))))))))))
          (let* ((entry (find find program env)))
            (if (list? entry)
              (cadr entry)
              (quote illegal-program-error)))))))))
      (interpreter interpreter program (quote ()))))