source: project/fp/trunk/fp2scheme.scm @ 4398

Last change on this file since 4398 was 4398, checked in by felix winkelmann, 13 years ago

peep update, wiki

File size: 5.2 KB
Line 
1;;;; fp2scheme.scm
2
3
4#+compiling
5(declare
6  (compress-literals 20)
7  (export fp->scheme fp-parse fp-code))
8
9
10(define-macro (tok t)
11  `(make-token ,(list 'quasiquote t) yyline) )
12
13(define-record-type token 
14  (%make-token symbol value line)
15  token?
16  (symbol token-symbol)
17  (value token-value)
18  (line token-line) )
19
20(define-record-printer (token x p)
21  (fprintf p "#<token ~s:~a>" (token-value x) (token-line x)) )
22
23(define (make-token t line)
24  (cons
25   (car t)
26   (match t
27     ((sym val) (%make-token sym val line))
28     ((sym) (%make-token sym #f line)) ) ) )
29
30(define lexer-error error)
31
32(define (escaped-char c)
33  (case c
34    ((#\n) #\newline)
35    ((#\r) #\return)
36    ((#\t) #\tab)
37    ((#\e) #\esc)
38    (else c) ) )
39
40(include "fp.l.scm")
41
42(define (parse-error msg #!optional arg)
43  (match arg
44    (#f (error msg))
45    ((or (_ . ($ token symbol value line))
46         ($ token symbol value line) )
47     (error (conc "(line " line ") " msg) symbol value) )
48    (x (error msg x)) ) )
49
50(include "grammar.lalr.scm")
51
52(define (fp-parse s)
53  (cond ((port? s) (lexer-init 'port s))
54        ((string? s) (lexer-init 'string s))
55        (else (error 'fp-parse "bad argument type - not a string or port" s)) )
56  (parser lexer parse-error) )
57
58(define (fp->scheme top #!optional trace)
59  (compile-toplevel top trace) )
60
61(define *code-table* (make-hash-table eq?))
62(define *pattern-bindings* '())
63
64(define (fp-code sym)
65  (hash-table-ref/default *code-table* sym #f))
66
67(define (compile-toplevel x #!optional trace local)
68  (define (defwrap x)
69    (if trace
70        `(fp:_trace _loc _arg (lambda () (,x _arg)))
71        `(,x _arg)))
72  (fluid-let ((*pattern-bindings* '()))
73    (match x
74      (('def ('once id) exp)
75       (unless local (hash-table-set! *code-table* id exp))
76       `(define ,(mangle id)
77          (let ((_f #f)
78                (_loc ',id)
79                (_val #f) )
80            (lambda (_arg)
81              (if _f
82                  _val
83                  (begin
84                    (set! _val ,(defwrap (compile exp)))
85                    (set! _f #t)
86                    _val) ) ) ) ) )
87      (('def id exp)
88       (unless local (hash-table-set! *code-table* id exp))
89       `(define ,(mangle id)
90          (let ((_loc ',id))
91            (lambda (_arg)
92              ,(defwrap (compile exp))))) )
93      (('where ('def ('once id) exp) . body)
94       (unless local (hash-table-set! *code-table* id exp))
95       `(define ,(mangle id)
96          (let ((_f #f)
97                (_loc ',id)
98                (_val #f) )
99            (lambda (_arg)
100              ,@(map (cut compile-toplevel <> trace #t) body)
101              (if _f
102                  _val
103                  (begin
104                    (set! _val ,(defwrap (compile exp)))
105                    (set! _f #t)
106                    _val) ) ) ) ) )
107      (('where ('def id exp) . body)
108       (unless local (hash-table-set! *code-table* id exp))
109       `(define ,(mangle id)
110          (let ((_loc ',id))
111            (lambda (_arg)
112              ,@(map (cut compile-toplevel <> trace #t) body)
113              ,(defwrap (compile exp)) ) ) ) )
114      (('app exp obj)
115       `(let ((_loc '<TOPLEVEL>)
116              (_arg ,(compile-object obj)))
117          (,(compile exp) _arg) ) )
118      (('seq ('atom files) ...)
119       `(fp:_load ',files))
120      (_ (error "invalid toplevel expression" x)) ) ) )
121
122(define (mangle s)
123  (string->symbol (conc "fp:" s)) )
124
125(define (compile exp)
126  (match exp
127    (('cond x y z)
128     (let* ((cx (compile x))
129            (cy (compile y))
130            (cz (compile z)))
131       `(lambda (_x)
132          (if (eq? 'F (,cx _x)) 
133              (,cz _x) 
134              (,cy _x))) ) )
135    (('comp f g)
136     `(lambda (_x) (,(compile f) (,(compile g) _x))) )
137    (('const o)
138     `(lambda _ ,(compile-object o)) )
139    (('cons fs ...)
140     `(lambda (_x) (list ,@(map (lambda (f) `(,(compile f) _x)) fs))) )
141    (('alpha f)
142     `(lambda (_x) (map ,(compile f) _x)) )
143    (('debug s)
144     `(lambda (_x) (fp:_debug ',s _x) _x) )
145    (('bottom msg)
146     `(lambda (_x) (fp:_error _loc ',msg _arg)) )
147    (('bu f o)
148     `(lambda (_x) (,(compile f) (list _x ,(compile-object o)))))
149    (('catch h f)
150     `(lambda (_x) (fp:_catch ,(compile h) ,(compile f) _x)) )
151    (('while p f)
152     `(letrec ((loop 
153                (lambda (_x)
154                  (if (eq? 'F (,(compile p) _x))
155                      _x
156                      (loop (,(compile f) _x))))))
157        loop) )
158    (('select n)
159     `(lambda (_x) (fp:_select ,n _x)))
160    (('insert f)
161     `(lambda (_x) (fp:_insert ,(compile f) _x)) )
162    (('insert-right f)
163     `(lambda (_x) (fp:_insert-right ,(compile f) _x)) )
164    (('pcons fs ...)
165     `(lambda (_x)
166        (fp:_pcons
167         _x
168         ,@(let loop ((fs fs) (i 1))
169             (cond ((null? fs) '())
170                   ((equal? '(...) fs) '('...))
171                   ((match (car fs) (('let _ _) #t) (_ #f)) 
172                    (set! *pattern-bindings* 
173                      (alist-cons 
174                       (cadar fs)
175                       (if (eq? '... (caddar fs)) (- (sub1 i)) i)
176                       *pattern-bindings*))
177                    (loop (cons (caddar fs) (cdr fs)) i))
178                   ((eq? '... (car fs)) 
179                    (error "dots not at end of pattern" fs) )
180                   (else (cons (compile (car fs)) (loop (cdr fs) (add1 i)))))))))
181    (('verbatim a) (parse-scheme a))
182    ((? symbol?)
183     (cond ((assq exp *pattern-bindings*) =>
184            (lambda (a)
185              (if (zero? (cdr a))
186                  (compile 'id)
187                  (compile `(select ,(cdr a))))))
188           (else (mangle exp))))
189    (_ (error "invalid expression" exp)) ) )
190
191(define (compile-object o)
192  (match o
193    (('atom s) `',s)
194    ('... '...)
195    ((? number?) o)
196    (('verbatim a) (parse-scheme a))
197    (('seq xs ...) `(list ,@(map compile-object xs))) 
198    (_ (error "invalid object" o)) ) )
199
200(define (parse-scheme sym)
201  (with-input-from-string (symbol->string sym) read) )
202
203(include "fplib.scm")
Note: See TracBrowser for help on using the repository browser.