source: project/release/5/expand-full/trunk/expand-full.scm @ 35936

Last change on this file since 35936 was 35936, checked in by Kon Lovett, 14 months ago

C5 initial

File size: 2.9 KB
Line 
1;;;; expand-full.scm
2;;;; Kon Lovett, Apr '09
3
4;;;
5
6(module expand-full
7
8(;export
9  expand*
10  pretty-print-expand* ppexpand*)
11
12(import
13  scheme
14  (chicken base)
15  (chicken type)
16  (chicken syntax)
17  (only (chicken platform) feature?)
18  (only (chicken csi) toplevel-command)
19  (only (chicken pretty-print) pretty-print)
20  (only (srfi 1) proper-list? map!)
21  (only vector-lib vector-map))
22
23;;
24
25(: expand (* #!optional * --> *))
26;
27(define (expand* form #!optional se)
28  (let expand-loop ((form form))
29    (let (
30      (expanded
31        (cond
32          ((null? form)
33            '() )
34          ((proper-list? form)
35            (let ((expanded (expand form se)))
36              (if (not (proper-list? expanded))
37                expanded
38                (map! expand-loop expanded) ) ) )
39          ((pair? form)
40            (cons (expand-loop (car form)) (expand-loop (cdr form))) )
41          ((vector? form)
42            (vector-map (lambda (_ x) (expand-loop x)) form) )
43          (else
44            form ) ) ) )
45      (if (equal? form expanded)
46        form
47        (expand-loop expanded) ) ) ) )
48
49#; ;WTF
50(define (expand* form #!optional se going-up?)
51  ;
52  (: protected? (* --> boolean))
53  ;
54  (define (protected? obj)
55    (or (null? obj) (atom? obj) (not (proper-list? obj))) )
56
57  (: protected-expand (* #!optional * --> *))
58  ;
59  (define (protected-expand form #!optional se)
60    (if (protected? form)
61      form
62      (expand form se)) )
63
64  (: protected-equal=? (* * --> boolean))
65  ;
66  (define (protected-equal=? a b)
67    (or
68      (and (not (number? a)) (protected? a))
69      (and (not (number? b)) (protected? b))
70      (equal=? a b)) )
71  ;
72  (let expand*-loop ((form form))
73    ;
74    (define (seq-expand form)
75      (cond
76        ((pair? form)
77          (cons (expand*-loop (car form)) (expand*-loop (cdr form))) )
78        ((list? form)
79          (map expand*-loop form) )
80        ((vector? form)
81          (vector-map (lambda (_ x) (expand*-loop x)) form) )
82        (else
83          form ) ) )
84    ;
85    ;(define local-protected-expand (o strip-syntax (cut protected-expand <> se)))
86    (define local-protected-expand (cut protected-expand <> se))
87    ;
88    (define bottom-up (o local-protected-expand seq-expand))
89    (define top-down (o seq-expand local-protected-expand))
90    (define go-direction (if going-up? bottom-up top-down))
91    ;
92    (let ((expanded (go-direction form)))
93      (if (protected-equal=? form expanded)
94        form
95        (expand*-loop expanded) ) ) ) )
96
97;;
98
99(: pretty-print-expand* (* #!optional * --> *))
100;
101(define (pretty-print-expand* form #!optional se)
102  (pretty-print (strip-syntax (expand* form se)))
103  (void) )
104
105(: ppexpand* (* #!optional * --> *))
106;
107(define ppexpand* pretty-print-expand*)
108
109;;;
110
111(when (feature? 'csi)
112  (toplevel-command 'x*
113    ;FIXME need apropos like csi argument handler
114    (lambda () (ppexpand* (read)))
115    ",x* EXP           Pretty print, almost fully, expanded expression EXP") )
116
117) ;module expand-full
Note: See TracBrowser for help on using the repository browser.