source: project/simplify/simplify.scm @ 2754

Last change on this file since 2754 was 2754, checked in by felix winkelmann, 14 years ago

added simplify

File size: 2.0 KB
Line 
1;;;; simplify.scm
2
3(use codewalk)
4
5(define (simplify exp)
6  (expand 
7   exp
8   (lambda (x c w e m)
9     (case c
10       ((quoted-literal)
11        (let ((val (cadr x)))
12          (if (or (number? val) (string? val) (boolean? val) (char? val))
13              val
14              (w x))))
15       ((undefined) '(void))
16       ((if)
17        (let loop ((x2 (map w (cdr x))))
18          (match x2
19            ((#f _) '(void))
20            ((#f _ b) b)
21            (((or #t (? number?) (? char?) (? string?)) a . _) a)
22            ((('quote (? boolean? f)) . more) (loop (cons f more)))
23            (('(quote _) a . _) a)
24            ((a b (void)) `(if ,a ,b))
25            (_ `(if ,@x2)) ) ) )
26       ((begin)
27        (let ((xs (let loop ((xs (map w (cdr x))))
28                    (match xs
29                      (() '())
30                      ((((or 'void '##sys#void)) . more) (loop more))
31                      ((('begin . body) . more) (loop (append body more)))
32                      ((x . more) (cons x (loop more))) ) ) ) )
33          (cond ((null? xs) '(void))
34                ((null? (cdr xs)) (car xs))
35                (else `(begin ,@xs)) ) ) )
36       ((let)
37        (match x
38          ((_ () . body) (w `(begin ,@body)))
39          (_ (w x)) ) )
40       ((app)
41        (match x
42          (((or 'call-with-values '##sys#call-with-values)
43            ('lambda () . body1)
44            ('lambda (var) . body2) )
45           (w `(let ((,var (begin ,@body1)))
46                 ,@body2)))
47          (((or 'call-with-values '##sys#call-with-values)
48            ('lambda () . body1)
49            ('lambda vars . body2) )
50           (if (list? vars)
51               `(let-values ((,vars ,(w `(begin ,@body1)))) ,(w `(begin ,@body2)))
52               `(receive ,vars ,(w `(begin ,@body1)) ,(w `(begin ,@body2)))))
53          ((fn xs ...)
54           (match fn
55             (('lambda llist . body)
56              (w `(let ,(let loop ((llist llist) (args (map w (cdr x))))
57                          (cond ((null? llist) '())
58                                ((symbol? llist) `((,llist (list ,@args))))
59                                (else (cons `(,(car llist) ,(car args))
60                                            (loop (cdr llist) (cdr args))))))
61                    ,@(cddr fn)) ) )
62             ('##sys#void '(void))
63             (_ (cons (w fn) (map w xs))) ) )
64          (_ (error "invalid syntax" x))))
65       (else (w x)) ) ) ) )
66
67(when (feature? 'csi)
68  (toplevel-command
69   'sx
70   (lambda () (pretty-print (simplify (read))))
71   ",sx FORM          pretty print expanded and simplifed code") )
Note: See TracBrowser for help on using the repository browser.