source: project/release/3/fp/trunk/fp2scheme.scm @ 9927

Last change on this file since 9927 was 9927, checked in by Kon Lovett, 12 years ago

Re. 2.2.1 w/ Explict use of SRFI 69.

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