git @ Cat's Eye Technologies Pixley / master dialect / p-normal.pix
master

Tree @master (Download .tar.gz)

p-normal.pix @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
(let*
  ((cadr (lambda (alist)
    (car (cdr alist))))
   (null? (lambda (alist)
    (equal? alist (quote ()))))
   (listify
    (lambda (x) (cons x (quote ()))))
   (map (lambda (self fun list)
    (cond
      ((null? list)
        (quote ()))
      (else
        (cons (fun fun (car list)) (self self fun (cdr list)))))))
   (p-normalize (lambda (self sexp)
    (cond
      ((list? sexp)
        (let* ((tag  (car sexp))
               (args (cdr sexp)))
          (cond
            ((equal? tag (quote car))
              (cons (quote car) (listify (self self (cadr sexp)))))
            ((equal? tag (quote cdr))
              (cons (quote cdr) (listify (self self (cadr sexp)))))
            ((equal? tag (quote cond))
              (cond
                ((null? args)
                  (listify args))
                (else
                  (let* ((branch     (car args))
                         (rest       (cdr args))
                         (test       (self self (car branch)))
                         (expr       (self self (cadr branch)))
                         (new-branch (cons test (listify expr)))
                         (sub-cond   (cons (quote cond) rest)))
                    (cond
                      ((equal? test (quote else))
                        expr)
                      (else
                        (cons (quote cond) (cons new-branch
                                                 (listify (cons (quote else) (listify (self self sub-cond))))))))))))
            ((equal? tag (quote cons))
              (cons (quote cons) (cons (self self (cadr sexp))
                                       (listify (self self (car (cdr (cdr sexp))))))))
            ((equal? tag (quote equal?))
              (cons (quote equal?) (cons (self self (cadr sexp))
                                         (listify (self self (car (cdr (cdr sexp))))))))
            ((equal? tag (quote lambda))
              (let* ((formals (car args))
                     (body    (cadr args)))
                (cons (quote lambda) (cons formals (listify (self self body))))))
            ((equal? tag (quote let*))
              (let* ((bindings (car args))
                     (body     (cadr args)))
                (cond
                  ((null? bindings)
                    (self self body))
                  (else
                    (let* ((binding      (car bindings))
                           (rest         (cdr bindings))
                           (ident        (car binding))
                           (expr         (self self (cadr binding)))
                           (new-bindings (listify (cons ident (listify expr))))
                           (sub-let      (cons (quote let*) (cons rest (listify body)))))
                      (cons (quote let*) (cons new-bindings (listify (self self sub-let)))))))))
            ((equal? tag (quote list?))
              (cons (quote list?) (listify (self self (cadr sexp)))))
            ((equal? tag (quote quote))
              sexp)
            (else
              (cons tag (map map self args))))))
      (else
        sexp)))))
  (lambda (sexp) (p-normalize p-normalize sexp)))