root/lang/elisp/escm/trunk/escm-compile.el @ 9197

Revision 9197, 12.3 kB (checked in by lieutar, 5 years ago)

lang/elisp/escm/trunk: I added a Makefile.

Line 
1;;; escm-compile.el --- Compiler of escm
2
3;; Copyright (C) 2008  Free Software Foundation, Inc.
4
5;; Author:  <onishi@THOTH>
6;; Keywords: lisp
7
8;; This file is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation; either version 2, or (at your option)
11;; any later version.
12
13;; This file is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
19;; along with GNU Emacs; see the file COPYING.  If not, write to
20;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21;; Boston, MA 02111-1307, USA.
22
23;;; Commentary:
24
25;;
26
27;;; Code:
28
29(require 'escm-base   )
30(require 'escm-syntax )
31(require 'escm-icode  )
32(require 'escm-env    )
33(require 'escm-context)
34
35(defun escm-compile (context sexp)
36  "Compiles sexp."
37  (cond
38   ((and sexp (consp sexp))
39    (let* ((head  (car sexp))
40           (env   (escm-context::get-env context))
41           (headv (when (symbolp head)
42                    (condition-case *err*
43                        (escm-env::gref env head)
44                      (escm-void-variable)))))
45      (cond
46       ((escm-syntax-p headv)
47        (escm-syntax::apply headv context sexp))
48       (t (escm-compile-apply context sexp)))))
49   ((and sexp
50         (symbolp sexp))
51    (escm-icode `(( ,(if (escm-context::get-func? context) 'fref 'ref)
52                    ,sexp
53                    ,(escm-context::get-env context)))))
54   (t              (escm-icode `((store  ,sexp))))))
55;;(escm-vm::eval (escm-vm::new) '(+ 1 2))
56
57
58;;; test code
59(escm-test::define-test escm escm-compile-atom
60  (let* ((root    (escm-root-env::new))
61         (context (escm-context::new root)))
62
63    (escm-test numeric-constant (equal (escm-compile context 1)
64                                       (escm-icode   '((store 1)))))
65
66    (escm-test nil-constant (equal (escm-compile context ())
67                                       (escm-icode   '((store ())))))
68
69    (escm-test varref (equal (escm-test::p 'icode (escm-compile context 'a))
70                             (escm-icode `((ref a ,root)))))
71
72    (escm-test::p 'built (escm-iproc::build (escm-compile context 'a)))))
73;; (escm-test::run 'escm 'escm-compile-atom)
74
75(defsubst escm-compile-apply (context sexp)
76  ""
77  (let ((head        (car sexp))
78        (tail        (cdr sexp))
79        (arg-context (escm-context::set-tail? context nil))
80        (ret         (escm-icode '((push 1)))))
81    (mapcar (lambda (x)
82              (escm-iproc::merge ret (escm-compile arg-context  x))
83              (escm-iproc::merge ret (escm-icode '((to-arg))))) tail)
84    (escm-iproc::merge ret (escm-compile
85                            (escm-context::set-func? context t)  head))
86    (escm-iproc::merge ret
87                       (escm-icode `((,(if (escm-context::get-tail? context)
88                                           'tcall
89                                         'call)))))))
90;;; test code
91(escm-test::define-test escm escm-compile-apply
92  (let* ((root    (escm-root-env::new))
93         (context (escm-context::new root))
94         (r       (escm-compile-apply context '(a (b 1) c)))
95         (ex       (escm-icode `((push 1)
96
97                                   (push 1)
98                                     (store 1)
99                                     (to-arg)
100                                     (fref b ,root)
101                                   (call)
102                                   (to-arg)
103
104                                   (ref c ,root)
105                                   (to-arg)
106
107                                   (fref a ,root)
108                                 (call)))))
109    (escm-test::p 'icode (escm-iproc::to-string r))
110    (escm-test::p 'icode (escm-iproc::to-string ex))
111    (escm-test compile-0 (escm-cbos::equal r ex))))
112;; (escm-test::run 'escm 'escm-compile-apply)
113
114(defsubst escm-compile-if::ifv0 (context condx positivex negativex)
115  ""
116  (let ((posi0 (escm-iproc::get-first-block positivex))
117        (nega0 (escm-iproc::get-first-block negativex))
118        (nega1 (escm-iproc::get-body-without-first    negativex)))
119    (when nega1 (escm-iblock::add-contents
120                 posi0 (escm-inimonic::new 'jmp (list (length nega1)))))
121    (escm-iproc::merge condx (escm-icode `((ifv ,posi0 ,nega0))))
122    (escm-iproc::merge condx (escm-iproc::new nega1))))
123
124(defsubst escm-compile-if::ifv1 (context condx positivex negativex)
125  ""
126  (let ((posi0 (escm-iproc::get-first-block positivex))
127        (nega0 (escm-iproc::get-first-block negativex))
128        (posi1 (escm-iproc::get-body-without-first    positivex)))
129    (when posi1 (escm-iblock::add-contents
130                 nega0 (escm-inimonic::new 'jmp (list (length posi1)))))
131    (escm-iproc::merge condx (escm-icode `((ifv ,posi0 ,nega0))))
132    (escm-iproc::merge condx (escm-iproc::new posi1))))
133
134(defsubst escm-compile-if::with-jump (context condx positivex negativex)
135  ""
136  (escm-iproc::merge negativex
137                     (escm-icode `((jmp ,(escm-iproc::length positivex)))))
138  (escm-iproc::merge condx
139                     (escm-icode `((jt  ,(escm-iproc::length negativex)))))
140  (escm-iproc::merge condx negativex)
141  (escm-iproc::merge condx positivex))
142
143(defsubst escm-compile-if (context sexp)
144  ""
145 (let ((condx     (escm-compile (escm-context::set-tail? context nil) (cadr   sexp)))
146       (positivex (escm-compile context (caddr  sexp)))
147       (negativex (escm-compile context (cadddr sexp))))
148
149   (cond ((not (escm-iproc::has-jump positivex))
150          (escm-compile-if::ifv0 context condx positivex negativex))
151
152         ((not (escm-iproc::has-jump negativex))
153          (escm-compile-if::ifv1 context condx positivex negativex))
154
155         (t (escm-compile-if::with-jump context condx positivex negativex)))))
156
157;;;
158(escm-test::define-test escm escm-compile-if
159  (let* ((root    (escm-root-env::new))
160         (context (escm-context::new root))
161
162         (r0      nil)
163         (e0      (escm-icode `((push 1)
164                                (fref x ,root)
165                                (call)
166                                (ifv ((ref y ,root))
167                                     ((ref z ,root))))))
168         (r1      nil)
169         (r2      nil)
170         (r3      nil))
171
172    (escm-test compile-0 (setq r0 (escm-compile-if context '(if (x) y z))) t)
173    (escm-test::p 'r0 (escm-iproc::to-string r0))
174    (escm-test::p 'e0 (escm-iproc::to-string e0))
175    (escm-test check-0 (equal r0 e0))
176
177    (escm-test compile-1
178               (setq r1 (escm-compile-if context '(if (x) (y (a)) z))) t)
179    (escm-test::p 'compile-1 (escm-iproc::to-string r1))
180
181
182    (escm-test compile-2
183               (setq r2 (escm-compile-if context '(if (x) y (z (a))))) t)
184    (escm-test::p 'compile-2 (escm-iproc::to-string r2))
185
186    (escm-test compile-3
187               (setq r3 (escm-compile-if context '(if (x) (y (a)) (z (b))))) t)
188    (escm-test::p 'compile-3 (escm-iproc::to-string r3))))
189;;(escm-test::run 'escm 'escm-compile-if)
190
191(defun escm-compile-elamba (context sexp)
192  (let* ((elfun (byte-compile (cons 'lambda (cdr sexp)))))
193    (escm-icode `((store ,(escm-wrapped-proc::new elfun))))))
194
195
196
197(defun escm-compile-let (context sexp)
198  (let* ((bindings (cadr sexp))
199         (body     (cddr sexp))
200         (name     (unless (listp binding)
201                     (let ((name bindings))
202                       (setq bindings (car body))
203                       (setq body     (cdr body))
204                       name)))
205         (syms    ())
206         (vals    ()))
207    (mapcar
208     (lambda (b)
209       (setq syms (cons (car  b) syms))
210       (setq vals (cons (escm-compile
211                         (escm-context::set-tail? context nil)
212                         (cadr b)) vals)) bindings)
213     bindings)
214    (when name (setq syms (cons name syms)))
215    (let ((proc (escm-compile context `(lambda ,syms ,body)))
216          (ret  (escm-iproc::new ())))
217     
218      (mapcar
219       (lambda (v) (escm-iproc::merge ret v))
220       (if name (cons (escm-iproc `((store-to-arg ,proc))) vals)
221         vals))
222      ret)))
223;;
224
225;;
226(defun escm-compile-define-syntax (context sexp)
227  (let ((name (cadr  sexp))
228        (proc (escm-vm::eval
229               (escm-context::get-vm context)
230               (caddr sexp))))
231    (escm-env::define (escm-context::get-env context)
232                      name
233                      (escm-syntax::new proc))
234    (escm-icode `((store ',name)))))
235
236(escm-test::define-test escm define-syntax
237  (let* ((vm  (escm-vm::new))
238         (env (escm-vm::current-env vm))
239         (ctx (escm-context::new env vm)))
240  (escm-test compile0 (escm-compile-define-syntax
241                       ctx
242                       '(define-syntax x (lambda (_ . body)
243                                           1)))
244             t)
245  (escm-test compile1 (escm-syntax-p (escm-env::gref env 'x)))
246  (escm-test expand   (escm-iproc::equal
247                       (escm-icode '((store 1)))
248                       (escm-test::p "result" (escm-compile ctx '(x)))))
249  ))
250;; (escm-test::run 'escm 'define-syntax)
251
252
253
254
255;;
256(defun escm-compile-let-syntax (context sexp)
257  (let* ((bind (cadr sexp))
258         (body (cddr sexp))
259         (ctx  (escm-context::push context))
260         (env  (escm-context::get-env ctx))
261         (ret  (escm-iproc::new ())))
262    (mapcar (lambda (b)
263              (escm-env::define
264               ctx
265               (car b)
266               (escm-syntax::new (escm-compile context (cdr b)))))
267            bind)
268    (mapcar (lambda (x) (escm-iproc::merge ret (escm-compile ctx x))
269              body))
270    ret))
271
272;;
273(defsubst escm-compile-lambda1 (context sexp)
274  (let* ((argspec (cadr sexp))
275         (body    (cddr sexp))
276         (body-reversed (reverse body))
277         (last    (car body-reversed))
278         (body-without-last (reverse (cdr body-reversed)))
279         (arity   (escm-arity::new        argspec))
280         (proc    (escm-iproc::new        nil sexp))
281         (ctx     (escm-context::push
282                   context (escm-arity::get-symbols arity))))
283    (mapcar (lambda (sexp)
284              (escm-iproc::merge proc
285                                 (escm-compile ctx sexp)))
286            body-without-last)
287    (escm-iproc::merge proc
288                       (escm-compile (escm-context::set-tail? ctx t) last))
289    (escm-iproc::merge proc (escm-icode '((ret))))
290    (escm-iproc::to-proc proc arity (escm-context::get-env ctx))))
291
292;;
293(defun escm-compile-lambda (context sexp)
294  (escm-icode `((store-proc ,(escm-compile-lambda1 context sexp)))))
295
296;;
297(escm-test::define-test escm escm-compile-lambda
298  (let* ((vm      (escm-vm::new))
299         (context (escm-context::new (escm-vm::current-env vm) vm))
300         (sexp    '(lambda (a b)))
301         (test
302          (lambda (proc)
303            (let ((env (escm-proc::get-env proc)))
304              (escm-test env
305                         (equal '(a b)
306                                (escm-test::p
307                                 'env-syms
308                                 (escm-env::get-fields env))))))))
309    (escm-test::p
310     "compiled"
311     (escm-iproc::to-string
312      (escm-icode `((store-proc ,(escm-compile-lambda1 context sexp))))))
313    (funcall test (escm-compile-lambda1 context sexp))
314    (funcall test (escm-vm::eval vm sexp))))
315;; (escm-test::run 'escm 'escm-compile-lambda)
316
317;;
318(defun escm-compile-elambda (context sexp)
319  (let ((body (cdr sexp)))
320    (escm-icode
321     `((store-proc
322        ,(escm-wrapped-proc::new
323          (if  (= (length body) 1)
324              body
325            (byte-compile (cons 'lambda body)))))))))
326
327;;
328(defsubst escm-compile-define1 (context sexp)
329  (let* ((spec (cadr sexp)))
330    (if (listp spec)
331        `(,(car spec) (lambda ,(cdr spec) ,@(cddr sexp)))
332      `(, name ,(caddr sexp)))))
333
334;;
335(defun escm-compile-define (context sexp)
336  (let* ((spec (escm-compile-define1  context sexp))
337         (env  (escm-context::get-env context))
338         (name (car  spec))
339         (body (cadr spec)))
340    (escm-env::define  env  name)
341    (escm-iproc::merge (escm-compile context body)
342                       (escm-icode `((set!  ,name ,env)
343                                     (store ',name))))))
344
345;;
346(escm-test::define-test escm escm-compile-define
347  (let* ((vm  (escm-vm::new))
348         (context (escm-context::new (escm-vm::current-env vm) vm)))
349    (escm-test "expand to lambda"
350               (equal '(a (lambda (n) n))
351                      (escm-test::p
352                       "lambda expantion"
353                       (escm-compile-define1 context '(define (a n) n)))))
354
355    (escm-test::p
356     "ex0"
357     (escm-iproc::to-string
358      (escm-compile context '(define (a n) n))))
359
360    (escm-test::p
361     "ex1"
362     (escm-iproc::to-string
363      (escm-compile context '((lambda (n) (define (a n) n) (a n)) 5))))
364
365    (escm-test::p
366     "ex2"
367     (escm-iproc::to-string
368      (escm-compile context '((lambda () (define (a n) n) (a 5))))))
369     ))
370;;; (escm-test::run 'escm 'escm-compile-define)
371
372;;
373(defun escm-compile-quote (context sexp)
374  (escm-icode `((store ',(cadr sexp)))))
375
376;;
377(defsubst escm-compile::init-vm (vm)
378
379  (mapcar
380   (lambda (spec)
381     (escm-define-builtin-syntax
382       vm (car spec) (cadr spec)))
383   `((quote         escm-compile-quote)
384     (if            escm-compile-if)
385     (let           escm-compile-let)
386     (let-syntax    escm-compile-let-syntax)
387     (define-syntax escm-compile-define-syntax)
388     (define        escm-compile-define)
389     (lambda        escm-compile-lambda)
390     (elambda       escm-compile-elambda)))
391
392   (escm-vm::eval
393    vm
394    '(define-syntax quasiquote
395         (lambda (_ . body)
396           (expand-quasiquote (list 'quote body)))))
397  )
398
399(add-hook 'escm-vm::init-hook (function escm-compile::init-vm))
400
401(provide 'escm-compile)
402;;; escm-compile.el ends here
Note: See TracBrowser for help on using the browser.