Changeset 8609 for lang/elisp

Timestamp:

04/01/08 21:44:19 (8 months ago)

Author:

lieutar

Message:

/lang/elisp/escm/trunk: I created debugging mode on my scheme VM.

Location:

lang/elisp/escm/trunk

Files:

• DEVELOPERSTOOLS.el (modified) (1 diff)
• escm-arity.el (modified) (3 diffs)
• escm-base.el (added)
• escm-cbos.el (modified) (9 diffs)
• escm-compile.el (modified) (10 diffs)
• escm-context.el (added)
• escm-debug.el (added)
• escm-env.el (modified) (13 diffs)
• escm-icode.el (modified) (5 diffs)
• escm-preprocess.el (modified) (1 diff)
• escm-proc.el (modified) (4 diffs)
• escm-syntax.el (modified) (1 diff)
• escm-util.el (modified) (1 diff)
• escm-util.minimal.el (modified) (1 diff)
• escm-vm.el (modified) (8 diffs)
• escm.el (modified) (2 diffs)

lang/elisp/escm/trunk/DEVELOPERSTOOLS.el

@@ -1 +1 @@
 (let ((dir (file-name-directory (buffer-file-name))))
   (unless (member  dir load-path )
-    (setq load-path (cons dir load-path))))
+    (setq load-path (cons dir load-path)))
+  (require 'escm)
+  (global-set-key [?\C-c ?e ?a] 'escm-debug::activate)
+  (global-set-key [?\C-c ?e ?d] 'escm-debug::deactivate)
+  (dired (file-name-directory (buffer-file-name))))
+
+(when nil
+
+  (escm-vm::eval (escm-vm::new)  '(+ 0 1 (* 2 3) 4))
+  (escm-vm::eval (escm-vm::new)  '(if nil 1 2))
+
+  (escm-vm::eval
+   (escm-vm::new)
+   '((lambda ()
+       (define (fact n) (if (= n 1) n (* n (fact (- n 1)))))
+       (fact 3))))
+
+  (escm-vm::eval
+   (escm-vm::new)
+   '((lambda ()
+       (define (fib n)
+         (if (< n 2)
+             1
+           (+ (fib (- n 2))
+              (fib (- n 1)))))
+       (fib 7))))
+
+  (escm-vm::eval
+   (escm-vm::new)
+   '((lambda ()
+
+       (define (fib-iter a b n)
+         (if (= 0 n)
+             (+ a b)
+           (fib-iter
+            b
+            (+ a b)
+            (- n 1))))
+
+       (define (fib n)
+         (fib-iter 0 1 n))
+
+       (fib 32)
+       )))
+
+  (progn
+    (define (fact n) (if (= n 1)        n (* n (- n 1))))
+    (escm-eval '(fact 5))
+    )
+
+
+  )

lang/elisp/escm/trunk/escm-arity.el

@@ -26 +26 @@
 
 ;;; Code:
-(require 'escm-util)
-(require 'escm-cbos)
-(require 'escm-test)
+(require 'escm-base)
 ;;(require 'escm-env)
 
-(escm-cbos::define-class (escm-arity)
+(escm-cbos::define-class (escm-arity escm-object)
                          length
                          symbols
@@ -64 +62 @@
     (while (> p 0)
       (if (and at-least (= p 1))
-          (escm-env::push env (cdr args))
+          (escm-env::push env args)
         (escm-env::push env (car args)))
       (setq p    (1- p))
@@ -70 +68 @@
 
 (provide 'escm-arity)
+
+
 
 

lang/elisp/escm/trunk/escm-cbos.el

@@ -35 +35 @@
    (escm-cbos::error::no-such-method "No such method")))
 
-(defconst escm-cbos::class-vmt    nil)
-(defconst escm-cbos::class-fields nil)
+(defconst escm-cbos::default-method nil)
+(defconst escm-cbos::class-vmt      nil)
+(defconst escm-cbos::class-fields   nil)
 
 (defsubst escm-cbos::classp (sym)
@@ -78 +79 @@
 
 (defmacro escm-cbos::define-method (class name args &rest body)
-  "defines method of escm-cbos objects."  
+  "defines method of escm-cbos objects."   
   `(progn
      ,(when t;;(not (fboundp 'name))
         `(defsubst ,name (*object* &rest args)
            (escm-cbos::run-method ',name *object* args)))
-     (put (get 'escm-cbos::class-vmt ',class) ',name
-;;        (byte-compile (escm-cbos::expand-method ',args ',body)))
+     ,(if (null class)
+          `(put 'escm-cbos::default-method ',name
+                (lambda ,args ,@body)
+                )
+        `(put
+          (get 'escm-cbos::class-vmt ',class)
+          ',name
+          ;;      (byte-compile (escm-cbos::expand-method ',args ',body)))
           (escm-cbos::expand-method ',args ',body))
+        )
      ',name))
 (put 'escm-cbos::define-method 'lisp-indent-function 'defun)
@@ -111 +119 @@
   (let* ((class (escm-cbos::get-class obj))
          (ilist (symbol-value (get 'escm-cbos::class-vmt class)))
-         (meth  (escm-cbos::find-method1 'ilist name)))
-    (if meth (apply meth (cons ilist (cons name (cons obj args))))
-      (signal 'escm-cbos::error::no-such-method 
-              (list class name)))))
+         (meth  (escm-cbos::find-method1 'ilist name))
+         dflt )
+    (cond (meth (apply meth (cons ilist (cons name (cons obj args)))))
+          ((setq dflt (get 'escm-cbos::default-method name))
+           (apply dflt (cons obj args)))
+          (t
+           (signal 'escm-cbos::error::no-such-method 
+                   (list class name))))))
 
 
@@ -141 +153 @@
     new))
 
+
+(defun escm-cbos::make-accessor (spec p)
+  (let* ((spec      (if (listp spec) spec (list spec)))
+         (f         (car spec))
+         (copy-mode (and (member :copy (cdr spec)) t)))
+    (if copy-mode
+        `(progn
+           (defsubst ,(intern (format "%s::set-%s" name f)) (obj val)
+             (let ((new (escm-cbos::clone obj)))
+               (aset new ,p val) new))
+           (defsubst ,(intern (format "%s::get-%s" name f)) (obj)
+             (aref obj ,p)))
+      `(progn
+         (defsubst ,(intern (format "%s::set-%s" name f)) (obj val)
+           (aset obj ,p val))
+         (defsubst ,(intern (format "%s::get-%s" name f)) (obj)
+           (aref obj ,p))))))
+
 (defmacro escm-cbos::define-class (inhspec &rest fields)
   "Creates object constructor and predicate and field-accessors.
@@ -154 +184 @@
   (let* ((name      (car inhspec))
          (super     (or (cadr inhspec) 'escm-cbos::Object))
-         (copy-mode (caddr inhspec))
          (fields    (escm-cbos::register-class name super fields))
          (len       (length fields))
@@ -168 +197 @@
 
        ,@(let ((p 0))
-           (mapcar
-            (if copy-mode
-                (lambda (f)
-                  (setq p (1+ p))
-                  `(progn
-                     (defsubst ,(intern (format "%s::set-%s" name f)) (obj val)
-                       (let ((new (escm-cbos::clone obj)))
-                         (aset new ,p val)
-                         new))
-                     (defsubst ,(intern (format "%s::get-%s" name f)) (obj)
-                       (aref obj ,p))))
-
-              (lambda (f)
-                (setq p (1+ p))
-                `(progn
-                   (defsubst ,(intern (format "%s::set-%s" name f)) (obj val)
-                     (aset obj ,p val))
-                   (defsubst ,(intern (format "%s::get-%s" name f)) (obj)
-                     (aref obj ,p)))))
-
-              fields)))))
+           (mapcar (lambda (f)
+                     (escm-cbos::make-accessor
+                      f
+                      (setq p (1+ p)))) fields)))))
 
 (defface  escm-cbos::report-section-face
@@ -227 +239 @@
           `(face escm-cbos::report-section-face
             "name:" (" " ,(format "%s" class)  "\n" )
-            "fields:" (" ",(mapconcat 'symbol-name
-                                      (escm-cbos::get-fields-of class) ", ")
+            "fields:" (" ",(mapconcat (lambda (f)
+                                        (format "%S" f))
+                                      (escm-cbos::get-fields-of class)
+                                      "\n        ")
                        "\n")
             "methods:"
@@ -278 +292 @@
   (equal a b))
 
-
+(escm-cbos::define-method nil escm-cbos::stringify (self)
+  (format "#<normal : %S>" self))
 
 (escm-cbos::define-method
   escm-cbos::Object escm-cbos::stringify (self)
-  (format "* object : %s *" (escm-cbos::get-class self)))
-
+  (format "#<object : %s>" (escm-cbos::get-class self)))
+
+
+;;;;;;;;;;;;;;;;;;;;
 (escm-test::define-test escm-cbos escm-cbos
   (escm-test classp-0 (escm-cbos::classp 'escm-cbos::Object))
@@ -303 +320 @@
                     (escm-test::p 'inheritance-list-1
                                   (escm-cbos::inheritance-list
-                                   'escm-cbos::test1))))) 
+                                   'escm-cbos::test1))))
+
+  (escm-cbos::define-class (escm-cbos::test2 nil)
+                           (a :copy)
+                           b)
+  (let* ((o (create-escm-cbos::test2))
+         (p (escm-cbos::test2::set-a o 1)))
+    (escm-cbos::test2::set-b o 2)
+    (escm-test "copy0" (escm-cbos::test2-p p))
+    (escm-test "copy1" (not (eq o p)))
+    (escm-test "copy2" (eq (escm-cbos::test2::get-a o) nil))
+    (escm-test "copy3" (eq (escm-cbos::test2::get-a p) 1))
+    (escm-test "copy4" (eq (escm-cbos::test2::get-b o) 2))
+    (escm-test "copy5" (eq (escm-cbos::test2::get-b p) nil))
+  ))
 ;;(escm-test::run 'escm-cbos 'escm-cbos)
 

lang/elisp/escm/trunk/escm-compile.el

@@ -27 +27 @@
 ;;; Code:
 
-
-(require 'escm-cbos  )
+(require 'escm-base  )
 (require 'escm-syntax)
 (require 'escm-icode )
 (require 'escm-env   )
-(require 'escm-errors)
-
-
-(escm-cbos::define-class (escm-context nil t) env vm tail? func? in-qq?)
-
-(defsubst escm-context::new (env &optional vm)
-  (let ((new (create-escm-context)))
-    (escm-context::set-vm
-     (escm-context::set-env new env)
-     vm)))
-
-(defsubst escm-context::push (self &optional syms)
-  (escm-context::new
-   (escm-dynamic-env::new
-    (escm-context::get-env self) syms)
-   (escm-context::get-vm self)))
+(require 'escm-context)
+
 
 (defun escm-compile (context sexp)
@@ -69 +54 @@
                     ,(escm-context::get-env context)))))
    (t              (escm-icode `((store  ,sexp))))))
-
 ;;(escm-vm::eval (escm-vm::new) '(+ 1 2))
+
 
 ;;; test code
@@ -88 +73 @@
     (escm-test::p 'built (escm-iproc::build (escm-compile context 'a)))))
 ;; (escm-test::run 'escm 'escm-compile-atom)
-
-
-
-
-
 
 (defsubst escm-compile-apply (context sexp)
@@ -99 +79 @@
         (tail        (cdr sexp))
         (arg-context (escm-context::set-tail? context nil))
-        (ret         (escm-iproc::new ())))
+        (ret         (escm-icode '((push 1)))))
     (mapcar (lambda (x)
               (escm-iproc::merge ret (escm-compile arg-context  x))
-              (escm-iproc::merge ret (escm-icode '((pusha)))))  tail)
+              (escm-iproc::merge ret (escm-icode '((to-arg))))) tail)
     (escm-iproc::merge ret (escm-compile
                             (escm-context::set-func? context t)  head))
@@ -113 +93 @@
   (let* ((root    (escm-root-env::new))
          (context (escm-context::new root))
-         (r       (escm-compile-apply context '(a b c)))
-         (ex       (escm-icode `((ref b ,root)
-                                (pusha)
-                                (ref c ,root)
-                                (pusha)
-                                (fref a ,root)
-                                (call)))))
+         (r       (escm-compile-apply context '(a (b 1) c)))
+         (ex       (escm-icode `((push)
+
+                                   (push)
+                                     (store 1)
+                                     (to-arg)
+                                     (fref b ,root)
+                                   (call)
+                                   (to-arg)
+
+                                   (ref c ,root)
+                                   (to-arg)
+
+                                   (fref a ,root)
+                                 (call)))))
     (escm-test::p 'icode (escm-iproc::to-string r))
     (escm-test::p 'icode (escm-iproc::to-string ex))
@@ -156 +144 @@
 (defsubst escm-compile-if (context sexp)
   ""
- (let ((condx     (escm-compile context (cadr   sexp)))
+ (let ((condx     (escm-compile (escm-context::set-tail? context nil) (cadr   sexp)))
        (positivex (escm-compile context (caddr  sexp)))
        (negativex (escm-compile context (cadddr sexp))))
@@ -167 +155 @@
 
          (t (escm-compile-if::with-jump context condx positivex negativex)))))
+
 
 ;;;
@@ -207 +196 @@
 
 (defun escm-compile-define-syntax (context sexp)
-  ""
   (let ((name (cadr  sexp))
         (proc (caddr sexp)))
@@ -230 +218 @@
     ret))
 
-;;
-
-(defun escm-compile-define (context sexp)
-  ""
-  (let* ((spec (cadr sexp))
-         (env (escm-context::get-env context))
-         name
-         body
-         ret)
-    (if (listp spec)
-        (progn (setq name (car spec))
-               (setq body (list 'lambda (cadr spec) (cddr sexp))))
-      (setq name spec)
-      (setq body (caddr sexp)))
-    (setq ret (escm-compile body))
-    (escm-env::define env  name)
-    (escm-iproc::merge ret (escm-icode `((set!  ,name ,env))))))
-;;
-
+;;;;
+
+(defsubst escm-compile-lambda1 (context sexp)
+  (let* ((argspec (cadr sexp))
+         (body    (cddr sexp))
+         (body-reversed (reverse body))
+         (last    (car body-reversed))
+         (body-without-last (reverse (cdr body-reversed)))
+         (arity   (escm-arity::new        argspec))
+         (proc    (escm-iproc::new        nil sexp))
+         (ctx     (escm-context::push
+                   context (escm-arity::get-symbols arity))))
+    (mapcar (lambda (sexp)
+              (escm-iproc::merge proc
+                                 (escm-compile ctx sexp)))
+            body-without-last)
+    (escm-iproc::merge proc
+                       (escm-compile (escm-context::set-tail? ctx t) last))
+    (escm-iproc::merge proc (escm-icode '((ret))))
+    (escm-iproc::to-proc proc arity (escm-context::get-env ctx))))
 
 (defun escm-compile-lambda (context sexp)
   ""
-  (let* ((argspec (cadr sexp))
-         (body    (cddr sexp))
-         (arity   (escm-arity::new        argspec))
-         (proc    (escm-iproc::new        nil))
-         (ctx     (escm-context::push
-                   context
-                   (escm-arity::get-symbols arity))))
-    (mapcar (lambda (sexp) (escm-iproc::merge proc (escm-compile ctx sexp))) body)
-    (escm-iproc::merge proc (escm-icode '((ret))))
-    (escm-icode `((store-proc ,(escm-iproc::to-proc proc arity env))))))
+  (escm-icode `((store-proc ,(escm-compile-lambda1 context sexp)))))
 ;;;
 (escm-test::define-test escm escm-compile-lambda
-  )
+  (let* ((vm      (escm-vm::new))
+         (context (escm-context::new (escm-vm::current-env vm) vm))
+         (sexp    '(lambda (a b)))
+         (test
+          (lambda (proc)
+            (let ((env (escm-proc::get-env proc)))
+              (escm-test env
+                         (equal '(a b)
+                                (escm-test::p 
+                                 'env-syms
+                                 (escm-env::get-fields env))))))))
+    (escm-test::p
+     "compiled"
+     (escm-iproc::to-string
+      (escm-icode `((store-proc ,(escm-compile-lambda1 context sexp))))))
+    (funcall test (escm-compile-lambda1 context sexp))
+    (funcall test (escm-vm::eval vm sexp))))
+;; (escm-test::run 'escm 'escm-compile-lambda)
+
+
 ;;
-;;(escm-vm::eval (escm-vm::new) '((lambda () 1)))
+(defsubst escm-compile-define1 (context sexp)
+  (let* ((spec (cadr sexp)))
+    (if (listp spec)
+        `(,(car spec) (lambda ,(cdr spec) ,@(cddr sexp)))
+      `(, name ,(caddr sexp)))))
+
+(defun escm-compile-define (context sexp)
+  (let* ((spec (escm-compile-define1  context sexp))
+         (env  (escm-context::get-env context))
+         (name (car  spec))
+         (body (cadr spec)))
+    (escm-env::define  env  name)
+    (escm-iproc::merge (escm-compile context body)
+                       (escm-icode `((set!  ,name ,env)
+                                     (store ',name))))))
+
+(escm-test::define-test escm escm-compile-define
+  (let* ((vm  (escm-vm::new))
+         (context (escm-context::new (escm-vm::current-env vm) vm)))
+    (escm-test "expand to lambda"
+               (equal '(a (lambda (n) n))
+                      (escm-test::p
+                       "lambda expantion"
+                       (escm-compile-define1 context '(define (a n) n)))))
+
+    (escm-test::p
+     "ex0"
+     (escm-iproc::to-string (escm-compile context '(define (a n) n))))
+
+    (escm-test::p
+     "ex1"
+     (escm-iproc::to-string (escm-compile context '((lambda (n) (define (a n) n) (a n)) 5))))
+
+    (escm-test::p
+     "ex2"
+     (escm-iproc::to-string (escm-compile context '((lambda () (define (a n) n) (a 5))))))
+     ))
+;;; (escm-test::run 'escm 'escm-compile-define)
 
 
@@ -301 +337 @@
 
 
+
+
 (provide 'escm-compile)
 ;;; escm-compile.el ends here

lang/elisp/escm/trunk/escm-env.el

@@ -1 @@
-(require 'escm-util)
-(require 'escm-cbos)
-(require 'escm-test)
-(require 'escm-errors)
+;;; escm-env.el --- enviroment for escm runtime.
+
+;; Copyright (C) 2008  Free Software Foundation, Inc.
+
+;; Author: Zaurus User(require 'escm-base) <zaurus@localhost.localdomain>
+;; Keywords: lisp
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; 
+
+;;; Code:
 
 (defconst escm-env::class-diagram nil "
 
-                       +--------------+
-                       |   escm-env   |
-                       | <<abstract>> |
-                       +--------------+
-                              A
-                              |
-          +-------------------+---------------------+
-          |                   |                     |
- +----------------+  +--------+---------+  +--------+-------+
- | escm-fixed-env |<-+ escm-dynamic-env |  | escm-elisp-env |
- +----------------+  -------------------+  +--------+-------+
-                              A                     |
-                              |                     |
-                       +------+--------+            |
-                       | escm-root-env |<>----------+
-                       +---------------+
-
-  escm-env          ... abstract root class of escm environment.
-  escm-fixed-env    ... runtime environment for any procedures.
-  escm-dynamic-env  ... it derives escm-fixed-env.
-  escm-root-env     ... 
-  escm-elisp-env    ... this is able to access to native elisp environment.
+                             +--------------+
+                             |   escm-env   |
+                             | <<abstract>> |
+                             +--------------+
+                                    A
+                                    |
+          +-------------------+-----+---------------+---------+
+          |                   |                     |         |
+ +----------------+  +--------+---------+  +--------+-------+ |
+ | escm-fixed-env |<-+ escm-dynamic-env |  | escm-elisp-env | |
+ +----------------+  -------------------+  +--------+-------+ |
+                              A                     |         |
+                              |                     |         |
+                       +------+--------+            |         |
+                       | escm-root-env |<>----------+         |
+                       +---------------+          +-----------+-----------+
+                                                  | escm-wrapped-proc-env |
+                                                  +-----------------------+
+
+  escm-env              ... abstract root class of escm environment.
+  escm-fixed-env        ... runtime environment for any procedures.
+  escm-dynamic-env      ... it derives escm-fixed-env.
+  escm-root-env         ... environment that exists when vm initialized.
+  escm-elisp-env        ... this is able to access to native elisp environment.
+  escm-wrapped-proc-env ... pseudo env for procedure that wrapped elisp function.
 
 ")
 
-(escm-cbos::define-class (escm-env) parent dic)
+(escm-cbos::define-class (escm-env escm-object) parent dic)
+
+(escm-cbos::define-method escm-env escm-object::to-string (self)
+  (escm-env::to-string self))
 
 (escm-cbos::define-method escm-env escm-env::to-string (self)
-  (format "<%s %S>"
+  (format "#<%s|%S>"
           (escm-cbos::get-class self)
           (escm-env::get-fields self)))
@@ -52 +81 @@
    (escm-env::get-fields b)))
 
-
 (escm-cbos::define-method escm-env escm-env::fref (self sym)
-  ""
-  (escm-cbos::gref self sym))
+  (escm-env::gref self sym))
 
 (escm-cbos::define-method escm-env escm-env::member? (self sym)
-  ""
   (plist-member (symbol-plist (escm-env::get-dic self)) sym))
 
 (escm-cbos::define-method escm-env escm-env::pos (self sym)
-  ""
   (get (escm-env::get-dic self) sym))
 
@@ -69 +94 @@
                                   'escm-env::define)))
 
-
-
-(escm-cbos::define-method escm-env escm-env::make-function-referer (self env sym)
+(escm-cbos::define-method
+  escm-env escm-env::make-referer (self env sym)
   ""