Changeset 7842 for lang/elisp

Timestamp:

03/12/08 17:08:23 (9 months ago)

Author:

lieutar

Message:

 

Location:

lang/elisp/escm/trunk

Files:

• README.rd (added)
• escm-arity.el (modified) (4 diffs)
• escm-cbos.el (modified) (2 diffs)
• escm-env.el (modified) (6 diffs)
• escm-test.el (modified) (3 diffs)
• escm-util.el (modified) (2 diffs)

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

@@ -1 +1 @@
 (require 'escm-util)
 (require 'escm-cbos)
+(require 'escm-test)
+(require 'escm-env)
 
-(escm-cbos::define-class escm-arity
+(escm-cbos::define-class (escm-arity)
                          length
                          symbols
@@ -19 +21 @@
                 (progn (setq fields  (cons head fields))
                        (setq argspec tail))
-              (throw 'error (format "wrong type argument: synbolp : %s" head))))
+              (throw 'error "wrong type argument" 'synbolp head)))
         (progn (setq fields (cons argspec fields))
                (setq at-least t)
@@ -25 +27 @@
     (escm-arity::set-symbols  new (reverse fields))
     (escm-arity::set-length   new (length  fields))
-    (escm-arity::set-at-least new at-least)))
+    (escm-arity::set-at-least new at-least)
+    new))
+
+;;; test code
+(escm-test::define-test escm arity
+  (let ((z (escm-arity::new  ()))
+        (o (escm-arity::new  '(a b c)))
+        (a1 (escm-arity::new 'a))
+        (a2 (escm-arity::new '(a . b))))
+    (escm-test one1         (= 1 (escm-arity::get-length a1)))
+    (escm-test zero         (= 0 (escm-arity::get-length z)))
+    (escm-test three        (= 3 (escm-arity::get-length o)))
+    (escm-test not-at-least (not (escm-arity::get-at-least z)))
+    (escm-test at-least-2   (escm-arity::get-at-least a2))
+    (escm-test at-least-1   (escm-arity::get-at-least a1))))
+;; (escm-test::run 'escm 'arity)
+
 
 (defsubst escm-arity::inject-args! (self env args)
@@ -38 +56 @@
 
 (provide 'escm-arity)
+
+

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

@@ -78 +78 @@
          (meth  (escm-cbos::find-method 'ilist name)))
     (if meth (apply meth (cons ilist (cons name (cons obj args))))
-      (throw 'escm-cbos::error::no-such-method
-             (format "method \"%s.%s\" is not exist." class name)))))
+      (throw 'escm-cbos::error::no-such-method 
+             (list "no such method" class name)))))
 
 (defun escm-cbos::expand-method (args body)
@@ -155 +155 @@
               fields)))))
 
+(defun escm-cbos::report-class (class)
+  )
+
 
 (escm-cbos::register-class 'escm-cbos::Object nil nil)

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

@@ -1 +1 @@
 (require 'escm-util)
 (require 'escm-cbos)
+(require 'escm-test)
 
 (defconst escm-env::class-diagram "
@@ -54 +55 @@
                              val))))
 
-(escm-test::define-test escm env
-  ""
-  (let* ((e (create-escm-env nil '(a b c)))
-         (f (create-escm-env e   '(d e f)))
-         (g (create-escm-env f   '(a))))
-    (escm-test "gset! 0" (escm-env::gset! e 'a 1) t)
-    (escm-test "gref  0" (eq 1 (escm-env::gref e 'a)))
-    (escm-test "gset! 1" (escm-env::gset! f 'b 2) t)
-    (escm-test "gref  1" (eq 2 (escm-env::gref  e 'b)))
-    (escm-test "gset! 2" (escm-env::gset! g 'a 3) t)
-    (escm-test "gref  2" (and (eq 1 (escm-env::gref e 'a))
-                              (eq 3 (escm-env::gref g 'a))))
-    (escm-util::a (escm-env::make-referer f 'env 'a))
-    (escm-util::a (escm-env::make-setter f 'env 'a '((aaa))))))
-
-;;(escm-test::run 'escm 'env )
-
 ;;;-----------;;;
 ;;;           ;;;
@@ -80 +64 @@
 
 ;; override
-(defsubst create-escm-env (parent syms)
+(defsubst create-escm-fixed-env (parent syms)
   (let ((new (escm-cbos::create-object 'escm-env (length syms)))
         (dic (make-symbol "*dic*"))
@@ -86 +70 @@
     (escm-env::set-parent new parent)
     (escm-env::set-dic    new dic)
-    (escm-env::set-ptr    new 3)
+    (escm-fixed-env::set-ptr    new 3)
     (mapcar (lambda (s) (put dic s (setq p (1+ p)))) syms)
     new))
@@ -100 +84 @@
       (let ((parent (escm-env::get-parent self)))
         (if parent (escm-env::gref parent)
-          (throw 'escm-env::unbound (format "unbound symbol : %s" sym)))))))
+          (throw 'escm-env::unbound "unbound symbol" sym))))))
 
 (escm-cbos::define-method escm-fixed-env escm-env::gset! (self sym val)
@@ -107 +91 @@
       (let ((parent (escm-env::get-parent self)))
         (if parent (escm-env::gset! parent sym val)
-          (throw 'escm-env::unbound (format "unbound symbol : %s" sym)))))))
+          (throw 'escm-env::unbound  "unbound symbol" sym))))))
+
+;; test code for escm-test
+(escm-test::define-test escm env
+  ""
+  (let* ((e (create-escm-fixed-env nil '(a b c)))
+         (f (create-escm-fixed-env e   '(d e f)))
+         (g (create-escm-fixed-env f   '(a))))
+    (escm-test "gset! 0" (escm-env::gset! e 'a 1))
+    (escm-test "gref  0" (eq 1 (escm-env::gref e 'a)))
+    (escm-test "gset! 1" (escm-env::gset! f 'b 2))
+    (escm-test "gref  1" (eq 2 (escm-env::gref  e 'b)))
+    (escm-test "gset! 2" (escm-env::gset! g 'a 3) t)
+    (escm-test "gref  2" (and (eq 1 (escm-env::gref e 'a))
+                              (eq 3 (escm-env::gref g 'a))))
+    (escm-util::a (escm-env::make-referer f 'env 'a))
+    (escm-util::a (escm-env::make-setter f 'env 'a '((aaa))))))
+;; (escm-test::run 'escm 'env )
 
 ;;;-------------;;;

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

@@ -1 +1 @@
 (defconst escm-test::tests () "symbol for plist of tests.")
 
+(defface  escm-test::ok-face
+  '((((class color) (background light))
+     (:foreground "black" :background "green"))
+    (((class color) (background dark))
+     (:foreground "black" :background "green"))
+    (t ()))
+  "")
+
+(defface  escm-test::faild-face 
+  '((((class color) (background light))
+     (:foreground "white" :background "red"))
+    (((class color) (background dark))
+     (:foreground "white" :background "red"))
+    (t ()))
+  "")
+
 (defmacro escm-test (name &rest x)
+  ""
   `(let ((err (condition-case *error*
-                  (let ((err (eval (progn ,@x)))) (if (eq err t) nil err))
-                (error *error*))))
-     (when err (setq failed (cons (cons ,name err) failed)))))
+                  (let ((err (eval (progn ,@x))))
+                    (if (eq err t) nil (or err "failed")))
+                (error
+                 (format "%S\n%s"
+                         *error*
+                         (with-output-to-string
+                           (backtrace)))))))
+     (setq report (cons (if err (progn (setq failed (1+ failed))
+                                       (list ',name err))  ',name)
+                        report))))
 
 (defun escm-test::run-test (reporter project name all)
   "Runs provided test."
-  (let* ((errors  ())
-         (failed  ()))
+  (let* ((report  ())
+         (errors  ())
+         (failed  0))
     (eval (cons 'progn all))
-    (apply reporter (list project name  (length all) failed))))
+    (apply reporter (list project name failed (reverse report)))))
 
 (defmacro escm-test::define-test (project name &rest body)
@@ -18 +43 @@
   `(put 'escm-test::tests
         ',project
-        (cons (cons ',name ',body) (get 'escm-test::tests ',project))))
+        (cons (cons ',name ',body)
+              (get 'escm-test::tests ',project))))
 (put 'escm-test::define-test 'lisp-indent-function 'defun)
 
-(defun escm-test::report-single (project name all failed)
+(defun escm-test::report-single (project name failed report)
   ""
-  (if failed
-      (with-output-to-temp-buffer "*escm-test*"
-        (mapcar
-         'print
-         failed))
-    (message "all tests successful.")))
+  (save-excursion
+    (let ((buf (get-buffer-create "*escm-test*")))
+      (set-buffer buf)
+      (toggle-read-only -1)
+      (delete-region (point-min) (point-max))
+      (insert
+       (mapconcat
+        (lambda (r)
+          (if (listp r)
+              (let ((head (format "%s :"    (car r))))
+                (set-text-properties
+                 0 (length head) '(face escm-test::faild-face) head)
+                (concat head (format " %s" (cadr r))))
+            (let ((ok (format "%s ... ok!" r)))
+              (set-text-properties
+               0 (length ok) '(face escm-test::ok-face) ok)
+              ok)))
+        report
+        "\n"))
+      (toggle-read-only 1)
+      (goto-char (point-min))
+      (pop-to-buffer buf t t)))
+  (when (= failed 0) (message "all tests successful.")))
 
 (defun escm-test::project-alist ()
@@ -54 +97 @@
   (let ((alist (get 'escm-test::tests project)))
     (if name
-        (escm-test::run-test 'escm-test::report-single project name (cdr (assoc name alist)))
+        (escm-test::run-test 'escm-test::report-single project name
+                             (cdr (assoc name alist)))
       (let ((failed ()))
         (mapcar (lambda (x)
                   (escm-test::run-test
-                   (lambda (project name all fail)
-                     (if fail nil
+                   (lambda (project name fail report)
+                     (if fail
+                         nil
                        (setq failed (cons fail failed))))
                    project

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

@@ -1 +1 @@
 (require 'cl)
+
+(apply (let ((s (make-symbol "*aa*")))
+         (set s 123)
+         (eval `(lambda () (symbol-value ,s)))) ())
 
 (defmacro escm-util::expand (&rest body)
   "Expands anonymous macro as standard macro."
   (cons 'progn (eval body)))
+
+(defmacro escm-util::text-with-properties (str &rest props)
+  ""
+  (let ((str ,str))
+    (set-text-properties 0 (length str) props str)
+    str))
+
+(defmacro escm-util::popup (name &rest body)
+  ""
+  `(save-excursion
+     (set-buffer    (get-buffer-create ,name))
+     (toggle-read-only -1)
+     (delete-region (point-min) (point-max))
+     ,@body
+     (toggle-read-only 1)
+     (goto-char (point-min))
+     (pop-to-buffer (current-buffer) t t)))
+
+(defun escm-util::a (&rest args)
+  "Prints args to minibuffer."
+  (read-char (format "%S" args))
+  nil)
+
+(defsubst escm-util::get-arity (fun)
+  "Returns arguments list of function."
+  (if (functionp fun)
+      (cond ((subrp fun) (subr-arity fun))
+            ((listp fun) (cadr       fun))
+            (t           (aref       fun 0)))
+    (throw 'error (format "wrong type argument: functionp %S" fun))))
+
 
 ;;;
@@ -51 +86 @@
           (nthcdr (+ n (or len 1))  list)))
 
-(defun escm-util::a (&rest args)
-  "Prints args to minibuffer."
-  (read-char (format "%S" args))
-  nil)
-
-(defsubst escm-util::get-arity (fun)
-  "Returns arguments list of function."
-  (if (functionp fun)
-      (cond ((subrp fun) (subr-arity fun))
-            ((listp fun) (cadr       fun))
-            (t           (aref       fun 0)))
-    (throw 'error (format "wrong type argument: functionp %S" fun))))
 
 (provide 'escm-util)