Changeset 8322 for lang/elisp

Timestamp:

03/24/08 01:18:44 (8 months ago)

Author:

lieutar

Message:

lang/elisp/escm/trunk: I added some changes.

Location:

lang/elisp/escm

Files:

• . (modified) (1 prop)
• trunk/escm-cbos.el (modified) (11 diffs)
• trunk/escm-compile.el (modified) (4 diffs)
• trunk/escm-env.el (modified) (13 diffs)
• trunk/escm-errors.el (modified) (1 diff)
• trunk/escm-icode.el (modified) (9 diffs)
• trunk/escm-proc.el (modified) (1 diff)
• trunk/escm-syntax.el (modified) (3 diffs)
• trunk/escm-test.el (modified) (6 diffs)
• trunk/escm-util.el (modified) (3 diffs)
• trunk/escm-util.minimal.el (modified) (3 diffs)
• trunk/escm-vm.el (modified) (3 diffs)

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

@@ -1 @@
-;;; escm-cbos.el --- tiny class base object system for escm-vm.
+;;; escm-cbos.el --- tiny class base object sytem for escm-vm
 
 ;; Copyright (C) 2008  Free Software Foundation, Inc.
 
-;; Author:  <lieutar@1dk.jp>
-;; Keywords: 
+;; Author: ;;; <onishi@THOTH>
+;; Keywords: oop
 
 ;; This file is free software; you can redistribute it and/or modify
@@ -27 +27 @@
 ;;; Code:
 
-;;;
-;;;
 (require 'escm-util)
+(require 'escm-test)
 
 (escm-util::define-signals
@@ -42 +41 @@
   "returns true if sym is escm::cbos class."
   (and (symbolp sym)
-       (plist-member 'escm-cbos::class-fields sym)
+       (plist-member (symbol-plist 'escm-cbos::class-fields) sym)
        t))
 
@@ -52 +51 @@
          (when (escm-cbos::classp cls)
            cls))))
+
+
 
 (defsubst escm-cbos::inheritance-list (class)
@@ -95 +96 @@
 
 (defsubst escm-cbos::find-method1 (sym name)
-  ""
   (let ((meth  nil)
         (ilist (symbol-value sym)))
-
-
     (while (and (not meth) ilist)
       (setq meth  (get (get 'escm-cbos::class-vmt (car ilist)) name))
@@ -111 +109 @@
 
 (defsubst escm-cbos::run-method (name obj args)
-  ""
   (let* ((class (escm-cbos::get-class obj))
          (ilist (symbol-value (get 'escm-cbos::class-vmt class)))
@@ -122 +119 @@
 
 (defun escm-cbos::expand-method (args body)
-  ""
   `(lambda ,(cons '*ilist* (cons '*method-name*  args))
      ,@(escm-util::walk-node
@@ -169 +165 @@
            new))
 
-       (defsubst ,pred (o)
-         (and (vectorp o)
-              (> (length o) 0)
-              (eq (aref new 0) ',name)))
+       (defsubst ,pred (o) (escm-cbos::isa o ',name))
 
        ,@(let ((p 0))
@@ -197 +190 @@
               fields)))))
 
-(defun escm-cbos::report-class (class)
-  )
-
-
-
+(defface  escm-cbos::report-section-face
+  '((((class color) (background light))
+     (:foreground "white" :background "black"))
+    (((class color) (background dark))
+     (:foreground "black" :background "white"))
+    (t ()))
+  "")
+
+(defface  escm-cbos::report-document-face
+  '((((class color) (background light))
+     (:foreground "red" ))
+    (((class color) (background dark))
+     (:foreground "green" ))
+    (t ()))
+  "")
+
+(defsubst escm-cbos::isa (o class)
+  (and (vectorp o)
+       (> (length o) 0)
+       (let ((klass (aref o 0)))
+         (member class (escm-cbos::inheritance-list klass)))
+       t))
+
+
+(defun escm-cbos::describe-class (class)
+  (interactive
+   (list (intern (completing-read
+                  "class: "
+                  (mapcar (lambda (c) (list (symbol-name (car c))))
+                          (escm-util::plist-to-alist
+                           (symbol-plist 'escm-cbos::class-fields)))))))
+  (if (escm-cbos::classp class)
+      (escm-util::popup "*escm-cbos::report-class*" nil
+        (insert
+         (escm-util::stext
+          `(face escm-cbos::report-section-face
+            "name:" (" " ,(format "%s" class)  "\n" )
+            "fields:" (" ",(mapconcat 'symbol-name
+                                      (escm-cbos::get-fields-of class) ", ")
+                       "\n")
+            "methods:"
+            ("\n"
+             ,(mapcar
+               (lambda (klass)
+                 (list
+                  "  " (symbol-name klass) "\n"
+                  (mapcar
+                   (lambda (meth)
+                     (list "    "
+                           (symbol-name (car meth))
+                           " "
+                           (format
+                            "%S" (cddr (escm-util::get-arity (cdr meth))))
+                           (let ((doc (documentation (cdr meth))))
+                             (if doc (list "\n"
+                                           (list
+                                            'face
+                                            'escm-cbos::report-document-face
+                                            "    "
+                                            doc))
+                               "\n\n"))
+                           "\n"))
+                   (escm-util::plist-to-alist
+                    (symbol-plist (get 'escm-cbos::class-vmt klass))))
+                  "\n"))
+               (escm-cbos::inheritance-list class)))))))
+    (message (format "%s is not defined as class in escm-cbos"))))
+
+
+
+(defsubst escm-cbos::Object-p (o)
+  (escm-cbos::isa o 'escm-cbos::Object))
 
 
 (escm-cbos::register-class 'escm-cbos::Object nil nil)
-
 (escm-cbos::define-method
  escm-cbos::Object escm-cbos::clone (self &optional copy-method)
@@ -213 +272 @@
         (c  (make-vector l nil)))
    (while (> (setq l (1- l))-1)
-    (aset c l (apply cp (list (aref self l))))
-   c)))
+    (aset c l (apply cp (list (aref self l)))))
+   c))
+
+(escm-cbos::define-method escm-cbos::Object escm-cbos::equal (a b)
+  (equal a b))
+
+
 
 (escm-cbos::define-method
@@ -220 +284 @@
   (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))
+  (escm-test classp-1 (not (escm-cbos::classp 'escm-cbos::OOOOO)))
+
+  (escm-cbos::define-class (escm-cbos::test0) a b c)
+  (escm-cbos::define-class (escm-cbos::test1 escm-cbos::test0) d e f)
+
+  (escm-test inheritance-list-0
+             (equal '(escm-cbos::test0
+                      escm-cbos::Object)
+                    (escm-test::p 'inheritance-list-0
+                                  (escm-cbos::inheritance-list
+                                   'escm-cbos::test0))))
+  (escm-test inheritance-list-1
+             (equal '(escm-cbos::test1
+                      escm-cbos::test0
+                      escm-cbos::Object)
+                    (escm-test::p 'inheritance-list-1
+                                  (escm-cbos::inheritance-list
+                                   'escm-cbos::test1))))) 
+;;(escm-test::run 'escm-cbos 'escm-cbos)
 
 (provide 'escm-cbos)

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

@@ -1 @@
-(require 'escm-util  )
+;;; escm-compile.el --- Compiler of escm
+
+;; Copyright (C) 2008  Free Software Foundation, Inc.
+
+;; Author: (require 'escm-util  ) <onishi@THOTH>
+;; 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:
+
+
 (require 'escm-cbos  )
 (require 'escm-syntax)
 (require 'escm-icode )
 (require 'escm-env   )
-
-(escm-cbos::define-class (escm-context nil t) env tail? func?)
+(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)))
 
 (defun escm-compile (context sexp)
@@ -12 +54 @@
    ((and sexp (consp sexp))
     (let* ((head  (car sexp))
-           (headv (when (symbolp head) (escm-context::gref head))))
-      (if (escm-syntax-p headv) (escm-syntax::apply headv context sexp)
-        (escm-compile-apply context sexp))))
-
-   ((symbolp sexp)
-    (escm-icode (,(if (escm-context::get-callp) 'fref 'ref)
-                 (escm-context::get-env context))))
-
+           (env   (escm-context::get-env context))
+           (headv (when (symbolp head)
+                    (condition-case *err*
+                        (escm-env::gref env head)
+                      (escm-void-variable)))))
+      (cond
+       ((escm-syntax-p headv)
+        (escm-syntax::apply headv context sexp))
+       (t (escm-compile-apply context sexp)))))
+   ((and sexp
+         (symbolp sexp))
+    (escm-icode `(( ,(if (escm-context::get-func? context) 'fref 'ref)
+                    ,sexp
+                    ,(escm-context::get-env context)))))
    (t              (escm-icode `((store  ,sexp))))))
+
+;;(escm-vm::eval (escm-vm::new) '(+ 1 2))
+
+;;; test code
+(escm-test::define-test escm escm-compile-atom
+  (let* ((root    (escm-root-env::new))
+         (context (escm-context::new root)))
+
+    (escm-test numeric-constant (equal (escm-compile context 1)
+                                       (escm-icode   '((store 1)))))
+
+    (escm-test nil-constant (equal (escm-compile context ())
+                                       (escm-icode   '((store ())))))
+
+    (escm-test varref (equal (escm-test::p 'icode (escm-compile context 'a))
+                             (escm-icode `((ref a ,root)))))
+
+    (escm-test::p 'built (escm-iproc::build (escm-compile context 'a)))))
+;; (escm-test::run 'escm 'escm-compile-atom)
+
+
+
+
+
 
 (defsubst escm-compile-apply (context sexp)
@@ -26 +98 @@
   (let ((head        (car sexp))
         (tail        (cdr sexp))
-        (arg-context (escm-context::set-tailp context nil))
+        (arg-context (escm-context::set-tail? context nil))
         (ret         (escm-iproc::new ())))
     (mapcar (lambda (x)
@@ -34 +106 @@
                             (escm-context::set-func? context t)  head))
     (escm-iproc::merge ret
-                       (escm-icode `((,(if (escm-context::get-tailp context)
+                       (escm-icode `((,(if (escm-context::get-tail? context)
                                            'tcall
                                          'call)))))))
-
-(defsubst escm-compile-if (sexp)
-  ""
- (let ((condx     (escm-compile (cadr   sexp)))
-       (positivex (escm-compile (caddr  sexp)))
-       (negativex (escm-compile (cadddr sexp))))
+;;; test code
+(escm-test::define-test escm escm-compile-apply
+  (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)))))
+    (escm-test::p 'icode (escm-iproc::to-string r))
+    (escm-test::p 'icode (escm-iproc::to-string ex))
+    (escm-test compile-0 (escm-cbos::equal r ex))))
+;; (escm-test::run 'escm 'escm-compile-apply)
+
+
+
+
+(defsubst escm-compile-if::ifv0 (context condx positivex negativex)
+  (let ((posi0 (escm-iproc::get-first-block positivex))
+        (nega0 (escm-iproc::get-first-block negativex))
+        (nega1 (escm-iproc::get-body-without-first    negativex)))
+    (when nega1 (escm-iblock::add-contents
+                 posi0 (escm-inimonic::new 'jmp (list (length nega1)))))
+    (escm-iproc::merge condx (escm-icode `((ifv ,posi0 ,nega0))))
+    (escm-iproc::merge condx (escm-iproc::new nega1))))
+
+(defsubst escm-compile-if::ifv1 (context condx positivex negativex)
+  (let ((posi0 (escm-iproc::get-first-block positivex))
+        (nega0 (escm-iproc::get-first-block negativex))
+        (posi1 (escm-iproc::get-body-without-first    positivex)))
+    (when posi1 (escm-iblock::add-contents
+                 nega0 (escm-inimonic::new 'jmp (list (length posi1)))))
+    (escm-iproc::merge condx (escm-icode `((ifv ,posi0 ,nega0))))
+    (escm-iproc::merge condx (escm-iproc::new posi1))))
+
+(defsubst escm-compile-if::with-jump (context condx positivex negativex)
+  (escm-iproc::merge negativex
+                     (escm-icode `((jmp ,(escm-iproc::length positivex)))))
+  (escm-iproc::merge condx
+                     (escm-icode `((jt  ,(escm-iproc::length negativex)))))
+  (escm-iproc::merge condx negativex)
+  (escm-iproc::merge condx positivex))
+
+(defsubst escm-compile-if (context sexp)
+  ""
+ (let ((condx     (escm-compile context (cadr   sexp)))
+       (positivex (escm-compile context (caddr  sexp)))
+       (negativex (escm-compile context (cadddr sexp))))
 
    (cond ((not (escm-iproc::has-jump positivex))
-          (escm-iproc::merge
-           condx
-           (escm-icode `(unlessv
-                         ,(car (escm-iproc::get-body positivex))
-                         ,(escm-iproc::get-first negativex))))
-          (escm-iproc::merge
-           condx
-           (escm-iproc::new
-            (escm-iproc::get-body-without-first negativex))))
-
-         ((not (escm-iproc::has-jump positivex))
-          (escm-iproc::merge
-           condx
-           (escm-icode `(unlessv
-                         ,(car (escm-iproc::get-body negativex))
-                         ,(escm-iproc::get-first positivex))))
-          (escm-iproc::merge
-           condx
-           (escm-iproc::new
-            (escm-iproc::get-body-without-first positivex))))
-
-         (t
-          (escm-iproc::merge negativex
-                             (escm-icode `((jmp ,(escm-iproc::length positivex)))))
-          (escm-iproc::merge condx
-                             (escm-icode `((jt  ,(escm-iproc::length negativex)))))
-          (escm-iproc::merge condx negativex)
-          (escm-iproc::merge condx positivex)))))
-
-
-(defun escm-compile-define-syntax ()
-  ""
+          (escm-compile-if::ifv0 context condx positivex negativex))
+
+         ((not (escm-iproc::has-jump negativex))
+          (escm-compile-if::ifv1 context condx positivex negativex))
+
+         (t (escm-compile-if::with-jump context condx positivex negativex)))))
+
+;;;
+(escm-test::define-test escm escm-compile-if
+  (let* ((root    (escm-root-env::new))
+         (context (escm-context::new root))
+
+         (r0      nil)
+         (e0      (escm-icode `((fref x ,root)
+                                (call)
+                                (ifv ((ref y ,root))
+                                     ((ref z ,root))))))
+         (r1      nil)
+         (r2      nil)
+         (r3      nil))
+
+    (escm-test compile-0 (setq r0 (escm-compile-if context '(if (x) y z))) t)
+    (escm-test::p 'compile-0 (escm-iproc::to-string r0))
+    (escm-test::p 'compile-0 (escm-iproc::to-string e0))
+    (escm-test check-0 (equal r0 e0))
+
+    (escm-test compile-1
+               (setq r1 (escm-compile-if context '(if (x) (y (a)) z))) t)
+    (escm-test::p 'compile-1 (escm-iproc::to-string r1))
+
+
+    (escm-test compile-2
+               (setq r2 (escm-compile-if context '(if (x) y (z (a))))) t)
+    (escm-test::p 'compile-2 (escm-iproc::to-string r2))
+
+    (escm-test compile-3
+               (setq r3 (escm-compile-if context '(if (x) (y (a)) (z (b))))) t)
+    (escm-test::p 'compile-3 (escm-iproc::to-string r3))))
+;;(escm-test::run 'escm 'escm-compile-if)
+
+
+
+
+
+
+(defun escm-compile-define-syntax (context sexp)
+  ""
+  (let ((name (cadr  sexp))
+        (proc (caddr sexp)))
+    (escm-env::define (escm-context::get-env context)
+                      name
+                      (escm-syntax::new proc))))
+;;
+(defun escm-compile-let-syntax (context sexp)
+  (let* ((bind (cadr sexp))
+         (body (cddr sexp))
+         (ctx  (escm-context::push context))
+         (env  (escm-context::get-env ctx))
+         (ret  (escm-iproc::new ())))
+    (mapcar (lambda (b)
+              (escm-env::define
+               ctx
+               (car b)
+               (escm-syntax::new (escm-compile context (cdr b)))))
+            bind)
+    (mapcar (lambda (x) (escm-iproc::merge ret (escm-compile ctx x))
+              body))
+    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))))))
+;;
+
+
+(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-test::define-test escm escm-compile-lambda
   )
-
-(defun escm-compile-let-syntax ()
-  ""
-  )
-
-(defun escm-compile-define (context sexp)
-  ""
-  )
-
-(defun escm-compile-lambda (context sexp)
-  ""
-  `(store-proc
-    ,(let* ((ctx     (escm-context::push context))
-            (arglist (cadr sexp))
-            (body    (cddr sexp))
-            (mid     (let ((asm ()))
-                       (while body
-                         (let ((head (car body))
-                               (tail (cdr body)))
-                           (escm-context::set-tail ctx (not tail))
-                           (setq asm (append asm (escm-compile ctx head)))
-                           (setq body tail)))))
-            (asm     (escm-optimize mid)))
-       (escm-proc::new (escm-context::build-fixed-env env)
-                       (escm-assemble asm)))))
-
+;;
+;;(escm-vm::eval (escm-vm::new) '((lambda () 1)))
+
+
+;;
 (defun escm-compile-quote (context sexp)
-  )
-
-(defun escm-compile-quasiquote   (context sexp)
-  )
-
-(defun escm-compile-unquote (context sexp)
-  )
-
-
-
+  (escm-icode `((store ',(cadr sexp)))))
+
+
+
+
+;;(setq escm-vm::init-hook nil)
 (add-hook
  'escm-vm::init-hook
  (lambda (vm)
-   (escm-define-builtin-syntax vm quote         (function escm-compile-quote))
-   (escm-define-builtin-syntax vm quasiquote    (function escm-compile-quasiquote))
-   (escm-define-builtin-syntax vm unquote       (function escm-compile-unquote))
-   (escm-define-builtin-syntax vm if            (function escm-compile-if))
-   (escm-define-builtin-syntax vm let-syntax    (function escm-compile-let-syntax))
-   (escm-define-builtin-syntax vm define-syntax (function escm-compile-define-syntax))
-   (escm-define-builtin-syntax vm define        (function escm-compile-define))
-   (escm-define-builtin-syntax vm lambda        (function escm-compile-lambda))
+
+   (escm-define-builtin-syntax vm quote
+     (function escm-compile-quote))
+
+   (escm-define-builtin-syntax vm if
+     (function escm-compile-if))
+
+   (escm-define-builtin-syntax vm let-syntax
+     (function escm-compile-let-syntax))
+
+   (escm-define-builtin-syntax vm define-syntax
+     (function escm-compile-define-syntax))
+
+   (escm-define-builtin-syntax vm define
+     (function escm-compile-define))
+
+   (escm-define-builtin-syntax vm lambda
+     (function escm-compile-lambda))
   ));; END OF INITIALIZER
 
+
 (provide 'escm-compile)
+;;; escm-compile.el ends here

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

@@ -14 +14 @@
           +-------------------+---------------------+
           |                   |                     |
- +----------------+  +--------+---------+  +--------+----------+
- | escm-fixed-env |<-+ escm-dynamic-env |  | escm-boundary-env |
- +----------------+  -------------------+  +-------------------+
+ +----------------+  +--------+---------+  +--------+-------+
+ | escm-fixed-env |<-+ escm-dynamic-env |  | escm-elisp-env |
+ +----------------+  -------------------+  +--------+-------+
+                              A                     |
+                              |                     |
+                       +------+--------+            |
+                       | escm-root-env |<>----------+
+                       +---------------+
 
   escm-env          ... abstract root class of escm environment.
-  escm-fixed-env    ... fixed fields enviroment for compiled function.
+  escm-fixed-env    ... runtime environment for any procedures.
   escm-dynamic-env  ... it derives escm-fixed-env.
-  escm-boundary-env ... this is able to access to native elisp environment.
+  escm-root-env     ... 
+  escm-elisp-env    ... this is able to access to native elisp environment.
 
 ")
@@ -27 +33 @@
 (escm-cbos::define-class (escm-env) parent dic)
 
+(escm-cbos::define-method escm-env escm-env::to-string (self)
+  (format "<%s %S>"
+          (escm-cbos::get-class self)
+          (escm-env::get-fields self)))
+
+(escm-cbos::define-method escm-env escm-cbos::equal (a b)
+  (and (escm-env-p b)
+       (escm-env::has-same-fields a b)
+       (if (escm-env::get-parent a)
+           (escm-cbos::equal
+            (escm-env::get-parent a)
+            (escm-env::get-parent b))
+         (null (escm-env::get-parent b)))))
+
+(escm-cbos::define-method escm-env escm-env::has-same-fields (a b)
+  (escm-util::equal-as-aggregate
+   (escm-env::get-fields a)
+   (escm-env::get-fields b)))
+
+
 (escm-cbos::define-method escm-env escm-env::fref (self sym)
   ""
@@ -38 +64 @@
   ""
   (get (escm-env::get-dic self) sym))
+
+(escm-cbos