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

Revision 9197, 7.0 kB (checked in by lieutar, 6 years ago)

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

Line 
1;;; escm-vm.el --- Virtual machine of escm.
2
3;; Copyright (C) 2008  Free Software Foundation, Inc.
4
5;; Author: lieutar <lieutar@1dk.jp>
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-proc       )
31(require 'escm-preprocess )
32(require 'escm-compile    )
33(require 'escm-debug      )
34
35
36(defvar   escm-vm::init-hook    ())
37(defconst escm-vm::serial-number 0)
38(defun escm-vm-init (vm)
39  (run-hook-with-args 'escm-vm::init-hook vm))
40
41(escm-util::expand
42 (let* ((vmdef  '((env  . (escm-root-env::new))
43                  (proc . nil)
44                  (src  . nil)
45                  (pc   . 0)
46                  (arg  . nil)
47                  (val  . nil)))
48        (regs   ())
49        (vminit ()))
50
51   `(,@(mapcar (lambda (p)
52                 (let* ((n           (car p))
53                        (v           (cdr p))
54                        (set         (intern (format "escm-vm::set-%s-stack"
55                                                     n)))
56                        (get         (intern (format "escm-vm::get-%s-stack"
57                                                     n)))
58                        (push        (intern (format "escm-vm::push-%s"
59                                                     n)))
60                        (pop         (intern (format "escm-vm::pop-%s"
61                                                     n)))
62                        (current     (intern (format "escm-vm::current-%s"
63                                                     n)))
64                        (set-current (intern (format "escm-vm::set-current-%s"
65                                                     n))))
66                   (setq regs   (cons n regs))
67                   (setq vminit (cons `(,push vm nil)
68                                      (cons `(,set-current vm ,v) vminit)))
69                   `(progn
70                      (defsubst ,push
71                        (vm val) (,set vm (cons val (,get vm))))
72                      (defsubst ,pop
73                        (vm) (,set vm (cdr (,get vm))))
74                      (defsubst ,current
75                        (vm) (car (,get vm)))
76                      (defsubst ,set-current
77                        (vm v) (setcar (,get vm) v)))))
78               vmdef)
79
80       ,(macroexpand
81         `(escm-cbos::define-class (escm-vm)
82                                   nil
83                                   ,@(mapcar (lambda (v)
84                                               (intern (format "%s-stack" v)))
85                                             regs)))
86
87       (defun escm-vm::new ()
88         (let ((vm (create-escm-vm)))
89           ,@vminit
90           (escm-vm-init vm)
91           vm)))))
92
93(defsubst escm-vm::call (vm &optional proc)
94  (escm-debug::enter)
95  (let* ((proc   (or proc (escm-vm::current-val  vm))))
96    (escm-vm::push-src  vm (escm-proc::get-src     proc))
97    (escm-vm::push-proc vm (escm-proc::get-body    proc))
98    (escm-vm::push-env  vm (escm-proc::runtime-env proc vm))
99    (escm-vm::pop-arg   vm )
100    (escm-vm::push-pc   vm -1)))
101
102(defsubst escm-vm::tail-call (vm &optional proc)
103  (let* ((proc   (or proc (escm-vm::current-val  vm))))
104    (escm-vm::set-current-src   vm  (escm-proc::get-src     proc))
105    (escm-vm::set-current-proc  vm  (escm-proc::get-body   proc))
106    (escm-vm::set-current-env   vm  (escm-proc::runtime-env proc vm))
107    (escm-vm::pop-arg           vm  )
108    (escm-vm::set-current-pc    vm  -1)))
109
110(defsubst escm-vm::push (vm n)
111  (let ((stack (escm-vm::get-arg-stack vm)))
112    (while (> n 0)
113      (setq stack (cons nil stack))
114      (setq n (1- n)))
115    (escm-vm::set-arg-stack vm stack)))
116
117(defsubst escm-vm::ret (vm)
118  (escm-vm::pop-src  vm)
119  (escm-vm::pop-proc vm)
120  (escm-vm::pop-env  vm)
121  (escm-vm::pop-pc   vm)
122  (escm-debug::leave   ))
123
124(defsubst escm-vm::to-arg (vm arg)
125  (escm-vm::set-current-arg
126   vm (cons arg (escm-vm::current-arg vm))))
127
128(defsubst escm-vm::jmp (vm n)
129  (escm-vm::set-current-pc
130   vm (+ n (escm-vm::current-pc vm))))
131
132(defsubst escm-vm::step (vm)
133  (apply (aref (escm-vm::current-proc vm)
134               (escm-vm::current-pc   vm))
135         (list vm (escm-vm::current-env vm)))
136  (escm-vm::set-current-pc vm (1+ (escm-vm::current-pc vm))))
137;;   (escm-vm::eval (escm-vm::new) '(call/cc (lambda (cc) 123)))
138
139(defsubst escm-vm::apply (vm proc args)
140  (let ((procs  (escm-vm::get-proc-stack vm))
141        (retval (progn (escm-vm::set-proc-stack vm ())
142                       (escm-vm::push-arg       vm (reverse args))
143                       (escm-vm::call           vm proc)
144                       (escm-vm::set-current-pc vm 0)
145                       (while (escm-vm::get-proc-stack vm)
146                         (escm-vm::step vm))
147                       (escm-vm::current-val vm))))
148    (escm-vm::set-proc-stack vm procs)
149    (escm-vm::set-current-pc vm 0)
150    retval))
151
152(escm-test::define-test escm escm-vm-eval
153  (let ((test (lambda (sexp)
154                (let ((vm (escm-vm::new)))
155                  (escm-vm::eval vm sexp)
156                  (eval (macroexpand
157                         `(escm-test
158                           ,(format "eval %S" sexp)
159                           (equal
160                            (escm-test::p "pc(result):"
161                                          (escm-vm::get-pc-stack vm))
162                            (escm-test::p "pc(new):"
163                                          (escm-vm::get-pc-stack
164                                           (escm-vm::new)))))))))))
165    (funcall test '())
166    (funcall test '(+ 1 1))
167    (funcall test '((lambda () )))
168    (funcall test '(define (a x) x))
169    (funcall test '(define-syntax a (lambda (sexp) )))))
170;;(escm-test::run 'escm 'escm-vm-eval)
171
172(defsubst escm-vm::compile (vm sexp)
173  (escm-iproc::merge
174   (escm-compile (escm-context::set-tail?
175                  (escm-context::new (escm-vm::current-env vm) vm) t)
176                 (escm-preprocess::process-elisp-quotes sexp))
177   (escm-icode '((ret)))))
178
179(defsubst escm-vm::compile-top-level (vm sexp)
180  (let ((iproc (escm-vm::compile vm sexp)))
181    (escm-iproc::set-src iproc sexp)
182    (escm-iproc::to-proc iproc
183                         (escm-arity::new ())
184                         (escm-vm::current-env vm))))
185
186(defun escm-vm::eval (vm sexp)
187  (escm-vm::apply vm (escm-vm::compile-top-level vm sexp)  nil))
188
189(defsubst escm-vm::define (vm sym val)
190  (escm-env::define (escm-vm::current-env vm)
191                    sym val))
192
193(defun escm-vm::locate-library (vm name)
194  (let ((load-pathes ((escm-vm::eval vm '*load-path*)
195                      load-path))
196        (ret nil))
197    (while (not (null ret)
198                load-pathes)
199      (let ((load-path (car load-pathes)))
200        (or (locate-library name)
201            (let ((suffixes '(".escmc"
202                              ".escm"
203                              ".scm")))
204              (while (and (null ret)
205                          suffixes)
206                (setq (locate-library
207                       (concat  (escm-util::basename name)
208                                (car suffixes))))
209                (setq suffixes (cdr suffixes))))))
210      (setq load-pathes (cdr load-pathes)))
211    ret))
212
213(defsubst escm-vm::load1 (vm path)
214 
215  )
216
217(defun escm-vm::load (vm name)
218  (let ((path (escm-vm::locate-library vm name)))
219    (when path (escm-vm::load1 path))))
220
221(provide 'escm-vm)
222;;; escm-vm.el ends here
Note: See TracBrowser for help on using the browser.