Changeset 7953 for lang/elisp

Timestamp:

03/14/08 18:10:30 (9 months ago)

Author:

lieutar

Message:

lang/elisp/escm/trunk: I fixed a problem in my test framework that aborts testing when the test contains errors.

Location:

lang/elisp/escm/trunk

Files:

• DEVELOPPERSTOOLS.el (moved) (moved from lang/elisp/escm/trunk/DEV.el) (1 diff)
• escm-arity.el (modified) (1 diff)
• escm-cbos.el (modified) (8 diffs)
• escm-compile.el (modified) (1 diff)
• escm-env.el (modified) (10 diffs)
• escm-errors.el (added)
• escm-icode.el (modified) (2 diffs)
• escm-pp.el (deleted)
• escm-test.el (modified) (7 diffs)
• escm-util.el (modified) (2 diffs)
• escm-util.file.el (modified) (1 diff)
• escm-util.minimal.el (modified) (1 diff)
• escm-vm.el (modified) (3 diffs)

lang/elisp/escm/trunk/DEVELOPPERSTOOLS.el

@@ -2 +2 @@
   (unless (member  dir load-path )
     (setq load-path (cons dir load-path))))
-
-
-
-

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

@@ -48 +48 @@
                 (progn (setq fields  (cons head fields))
                        (setq argspec tail))
-              (throw 'error "wrong type argument" 'synbolp head)))
+              (signal 'error `("wrong type argument" 'synbolp ,head))))
         (progn (setq fields (cons argspec fields))
                (setq at-least t)

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

@@ -30 +30 @@
 ;;;
 (require 'escm-util)
+
+(escm-util::define-signals
+ '(escm-cbos::error
+   ""
+   (escm-cbos::error::no-such-method "No such method")))
 
 (defconst escm-cbos::class-vmt    nil)
@@ -72 +77 @@
 
 (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))
@@ -89 +94 @@
   (put (get 'escm-cbos::class-vmt ',class) ',name nil))
 
-(defsubst escm-cbos::find-method (sym name)
+(defsubst escm-cbos::find-method1 (sym name)
   ""
   (let ((meth  nil)
@@ -101 +106 @@
     meth))
 
+(defun escm-cbos::find-method (class method-name)
+  (let ((ilist (escm-cbos::inheritance-list class)))
+    (escm-cbos::find-method1 'ilist method-name)))
+
 (defsubst escm-cbos::run-method (name obj args)
   ""
   (let* ((class (escm-cbos::get-class obj))
          (ilist (symbol-value (get 'escm-cbos::class-vmt class)))
-         (meth  (escm-cbos::find-method 'ilist name)))
+         (meth  (escm-cbos::find-method1 'ilist name)))
     (if meth (apply meth (cons ilist (cons name (cons obj args))))
-      (throw 'escm-cbos::error::no-such-method 
-             (list "no such method" class name)))))
+      (signal 'escm-cbos::error::no-such-method 
+              (list class name)))))
+
+
 
 (defun escm-cbos::expand-method (args body)
@@ -118 +129 @@
               (cond ((eq 'super (car x))
                      `(apply
-                       (or (escm-cbos::find-method '*ilist* *method-name*)
-                           (throw 'escm-cbos::error::no-such-method
-                                  (format "")))
-                       (list *ilist* *method-name* ,@(cdr x))))
-                    (t (throw 'error "panic!!"))) x))
+                       (or (escm-cbos::find-method '*ilist* *method-name*)
+                           (signal 'escm-cbos::error::no-such-method
+                                   ()))
+                       (list *ilist* *method-name* ,@(cdr x))))
+                    (t (signal 'error '("panic!!")))) x))
         body
         (lambda (n) (not (or (eq 'super (car n))))))))
@@ -129 +140 @@
   "Creates object with buffer."
   (let ((new (make-vector
-              (+ 1 (length (escm-cbos::get-fields-of name)) (or buflen 0)) nil)))
+              (+ 1 (length (escm-cbos::get-fields-of name))
+                 (or buflen 0)) nil)))
     (aset new 0 name)
     new))
@@ -189 +201 @@
 
 
+
+
+
 (escm-cbos::register-class 'escm-cbos::Object nil nil)
 
@@ -205 +220 @@
   (format "* object : %s *" (escm-cbos::get-class self)))
 
+
+
+
+
+
+
+
 (provide 'escm-cbos)
 ;;; escm-cbos.el ends here.

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

@@ -31 +31 @@
               (escm-iproc::merge ret (escm-compile arg-context  x))
               (escm-iproc::merge ret (escm-icode '((pusha)))))  tail)
-    (escm-iproc::merge ret (escm-compile (escm-context::set-func? context t)  head))
-    (escm-iproc::merge ret (escm-icode `((,(if (escm-context::get-tailp context)
-                                               'tcall
-                                             'call)))))))
+    (escm-iproc::merge ret (escm-compile
+                            (escm-context::set-func? context t)  head))
+    (escm-iproc::merge ret
+                       (escm-icode `((,(if (escm-context::get-tailp context)
+                                           'tcall
+                                         'call)))))))
 
 (defsubst escm-compile-if (sexp)

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

@@ -2 +2 @@
 (require 'escm-cbos)
 (require 'escm-test)
+(require 'escm-errors)
 
 (defconst escm-env::class-diagram nil "
@@ -84 +85 @@
       (let ((parent (escm-env::get-parent self)))
         (if parent (escm-env::gref parent)
-          (throw 'escm-env::unbound "unbound symbol" sym))))))
+          (signal 'escm-void-variable  (list "unbound symbol" sym)))))))
 
 (escm-cbos::define-method escm-fixed-env escm-env::gset! (self sym val)
@@ -91 +92 @@
       (let ((parent (escm-env::get-parent self)))
         (if parent (escm-env::gset! parent sym val)
-          (throw 'escm-env::unbound  "unbound symbol" sym))))))
+          (signal 'escm-void-variable  (list "unbound symbol" sym)))))))
 
 ;; test code for escm-test
@@ -112 +113 @@
                                    (escm-env::make-setter  f 'f 'a 123))) t)
     (escm-test "make referer"
-               (eq (eval
-                    (escm-test::p "referer" (escm-env::make-referer f 'f 'a)))
+               (eq (eval (escm-test::p "referer"
+                                       (escm-env::make-referer f 'f 'a)))
                    123))))
 ;; (escm-test::run 'escm 'fixed-env)
+
 
 ;;;-------------;;;
@@ -138 +140 @@
 (defsubst escm-dynamic-env::add-field (self sym)
   ""
-  
   (put (escm-env::get-dic self)
        sym
@@ -157 +158 @@
       (if parent
           (escm-env::gset! parent sym val)
-        (throw 'escm-env::unbound (format "unbound symbol : %s"))))))
-
-(escm-cbos::define-method escm-dynamic-env escm-env::gref  (self sym)
+        (signal 'escm-void-variable (list ))))))
+
+
+(defsubst escm-dynamic-env::gref (self sym)
   (if (escm-env::member? self sym)
       (get (escm-dynamic-env::get-valdic self) sym)
@@ -165 +167 @@
       (if parent
           (escm-env::gref parent sym)
-        (throw 'escm-env::unbound (format "unbound symbol : %s"))))))
+        (signal 'escm-void-variable (list))))))
+
+(escm-cbos::define-method escm-dynamic-env escm-env::gref (self sym)
+  (escm-dynamic-env::gref self sym))
 
 ;; test code for escm-dynamic-env
@@ -178 +183 @@
     (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 "gref  1"     (eq 2 (escm-test::p
+                                    "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-test::p "f" f)
     (escm-test "make setter"
                (eval (escm-test::p "setter"
-                                   (escm-env::make-setter  f 'f 'a 123))) t)
-
+                                   (escm-env::make-setter f 'f 'a 123))) t)
     (escm-test "make referer"
-               (eq (eval
-                    (escm-test::p "referer" (escm-env::make-referer f 'f 'a)))
+               (eq (eval (escm-test::p "referer"
+                                       (escm-env::make-referer f 'f 'a)))
                    123))
 ))
+
 ;; (escm-test::run 'escm 'dynamic-env)
-
 
 ;;;
@@ -206 +212 @@
       (let ((retval (condition-case *err* (symbol-value 'sym)
                       (error (condition-case *err* (symbol-function 'sym)
-                               (error (throw 'escm::unbound "")))))))
+                               (error (signal 'escm-void-variable
+                                              (list ""))))))))
         (let ((retval (if (functionp retval)
                           (escm-proc::wrap-elisp retval)
@@ -219 +226 @@
       (let ((retval (condition-case *err* (symbol-function 'sym)
                       (error (condition-case *err* (symbol-value 'sym)
-                               (error (throw 'escm::unbound "")))))))
+                               (error (signal 'escm-void-variable
+                                              (list ""))))))))
         (let ((retval (if (functionp retval)
                           (escm-proc::wrap-elisp retval)

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

@@ -86 +86 @@
   (cond ((escm-iblock-p          node) node)
         ((escm-iblock-contents-p node) (escm-iblock::new (list node)))
-        (t (throw 'error "wrong type argument: escm-iblock-p or escm-iblock-contents-p"))))
+        (t (signal 'wrong-type-argument
+                   (list
+                    "wrong type argument"
+                    'escm-iblock-p
+                    'escm-iblock-contents-p)))))
 
 (defsubst escm-iblock::add-contents (self content)
   ""
-  (when (escm-iblock::get-has-jump self) (throw 'error ""))
+  (when (escm-iblock::get-has-jump self) (signal 'error ()))
   (escm-iblock::set-has-jump self (escm-iblock-contents::has-jump content))
   (escm-iblock::set-body  self (append (escm-iblock::get-body self)
@@ -105 +109 @@
            (escm-iblock::add-contents self node))
           (t
-           (throw 'error "")))
+           (signal 'error ())))
     self))
 

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

@@ -28 +28 @@
 (require 'escm-util.minimal)
 
-
-(defconst escm-test::tests ()
-  "symbol for plist of tests.")
+(defconst escm-test::tests () "symbol for plist of tests.")
 
 (defface  escm-test::ok-face
@@ -67 +65 @@
   (format "%S" (cdr trace)))
 
-
-
-
-(defun escm-test::record-errors (cont debugger-args)
-  (throw cont
-         (format "%S\nbacktrace:%s"
-                 debugger-args
-                 (let ((drop  t)
-                       (depth 0)
-                       (trace t)
-                       (all  ""))
-                   (while trace
-                     (unless (eq trace t)
-                       (if drop
-                           (if (eq (cadr trace) 'escm-test::record-errors)
-                               (setq drop nil))
-                         (setq all
-                               (concat
-                                all
-                                "\n"
-                                (escm-test::build-traced-line trace)))))
-                     (setq trace (backtrace-frame depth))
-                     (setq depth (1+ depth))
-                     (when (and (eq    (cadr trace) 'catch)
-                                (equal (caddr trace) ''escm-test->eval))
-                       (setq trace nil)))
-                   all))))
+(defun escm-test::backtrace1 (cont debugger-args skip)
+  (format "%S\nbacktrace:%s"
+          debugger-args
+          (let ((drop  t)
+                (depth 0)
+                (trace t)
+                (skip (or skip 0))
+                (all  ""))
+            (while trace
+              (unless (eq trace t)
+                (if drop
+                    (if (eq (cadr trace) 'escm-test::backtrace)
+                        (setq drop nil))
+                  (if (> 1 skip)
+                      (setq all
+                            (concat
+                             all
+                             "\n"
+                             (escm-test::build-traced-line
+                              trace)))
+                    (setq skip (1- skip)))))
+              (setq trace (backtrace-frame depth))
+              (setq depth (1+ depth))
+              (when (and (eq    (cadr  trace) 'catch)
+                         (equal (caddr trace) (list 'quote cont)))
+                (setq trace nil)))
+            all)))
+
+(defun escm-test::backtrace (cont debugger-args &optional skip)
+  ""
+  (let* ((old-local-map (current-local-map))
+         (tmp-map (make-keymap))
+         (len     (length (cadr tmp-map)))
+         (tbl     (make-vector len (lambda ()
+                                     (interactive)
+                                     (message "Continue ...")
+                                     (run-with-timer 0.125 nil
+                                                     'exit-recursive-edit))))
+         (pos     1))
+    (aset tbl 0 t)
+    (setcar (cdr tmp-map) tbl)
+    (use-local-map tmp-map)
+    (message "\"escm-test\" caught an error. Push any key...")
+    (recursive-edit)
+    (use-local-map old-local-map)
+    (throw cont (escm-test::backtrace1 cont debugger-args skip))))
+
+(when nil ;;;;
+
+  (progn
+    (escm-test::define-test escm-test fail2
+      (escm-test ok-0 t)
+      (escm-test arith-0 (/ 0 0))
+      (escm-test ok 1 t)
+      (escm-test arith-1 (/ 1 0))
+      )
+    (escm-test::run 'escm-test 'fail2 ))
+
+);;;;
+
+(defsubst escm-test::assert1 (name x)
+  ""
+  (let ((result (let ((debugger (lambda (&rest args)
+                                  (escm-test::backtrace 'escm-test->eval
+                                                        args
+                                                        1))))
+                  (catch 'escm-test->eval (eval (cons 'progn x))))))
+    (setq report
+          (cons (if (eq result t)
+                    `(:ok ,name)
+                  (progn (setq failed (1+ failed))
+                         `(:failed ,name ,(or result "failed"))))
+                report))))
 
 (defmacro escm-test (name &rest x)
   ""
-  `(let ((err (let ((debugger (lambda (&rest args)
-                                (escm-test::record-errors 'escm-test->eval
-                                                          args))))
-                (let ((result (catch 'escm-test->eval (eval (progn ,@x)))))
-                  (if (eq result t) nil (or result "failed"))))))
-     (setq report
-           (cons (if err (progn (setq failed (1+ failed))
-                                (list ',name err))  ',name)
-                        report))))
+  `(escm-test::assert1 ',name ',x))
 
 (defun escm-test::run-test::debugger (&rest debugger-args)
   (setq failed (1+ failed))
-  (escm-test::record-errors 'escm-test::run-test->eval
-                            debugger-args))
+  (escm-test::backtrace 'escm-test::run-test->eval
+                            debugger-args
+                            1))
 
 (defun escm-test::run-test (reporter project name all)
@@ -122 +159 @@
                               all
                               '(nil))))))
-    (if err (setq report (cons (list "*** FATAL ERROR ***" err) report)))
+    (if err (setq report
+                  (cons (list :failed "*** FATAL ERROR ***" err) report)))
     (apply reporter (list project name failed (reverse report)))))
 
 
-(when nil ;;;;
-
-  (progn
-    (escm-test::define-test escm-test fail2
-      (/ 2 0))
-    (escm-test::run 'escm-test 'fail2))
-
-  (progn
-    (escm-test::define-test escm-test fail
-      (escm-test zero    (progn (/ 1 0)))
-      (escm-test success  t)
-      (escm-test unreach  t))
-    (escm-test::run 'escm-test 'fail))
-
-);;;;
+
+(defconst escm-test::report-mode-map
+  (let ((m (make-keymap)))
+    (define-key m "q" 'top-level)
+    m))
+
+
+(defun escm-test::report-mode ()
+  (use-local-map escm-test::report-mode-map))
+
 
 (defmacro escm-test::define-test (project name &rest body)
@@ -154 +187 @@
 (defun escm-test::report-single (project name failed report)
   "Reports result of a test."
-  (escm-util::popup  "*escm-test*"
-    (insert
-     (mapconcat
-      (lambda (r)
-        (if (listp r)
-            (if (eq :print (car r))
-                (concat (escm-util::text-with-properties
-                         (format "%s :" (cadr r)) 'face 'escm-test::print-face)
-                        (format "%S" (cddr r)))
-              (concat (escm-util::text-with-properties
-                       (format "%s :"    (car r)) 'face 'escm-test::faild-face)
-                      (format " %s" (cadr r))))
-           (escm-util::text-with-properties
-                (format "%s ... ok!" r) 'face 'escm-test::ok-face)))
-      report
-      "\n")))
-  (when (= failed 0) (message "all tests successful.")))
+  (save-window-excursion
+    (escm-util::popup  "*escm-test*"
+      (escm-test::report-mode)
+      (insert
+       (mapconcat
+        (lambda (r)
+          (case (car r)
+            ((:ok)
+             (escm-util::stext
+              `(face escm-test::ok-face ,(format "%s ... ok!" (cadr r)))))
+            ((:print)
+           (escm-util::stext
+            `(face escm-test::print-face ,(format "%s :" (cadr r)))
+            (format "%S" (cddr r))))
+            ((:failed)
+             (escm-util::stext
+              `(face escm-test::faild-face ,(format "%s :" (cadr r)))
+              (format " %s" (caddr r))))))
+        report
+        "\n")))
+    (if (= failed 0)
+        (message "all tests successful.")
+      (message (format "The test has %d or more errors." failed)))
+    (save-excursion (recursive-edit))))
 
 (defun escm-test::project-alist ()
@@ -188 +228 @@
 
 
-(defun escm-test::run (project &optional name)
+(defun escm-test::run (project &optional name reporter)
   "Runs all tests what belongs the PROJECT."
   (interactive
@@ -201 +241 @@
     (if name
         (progn
-          (escm-test::run-test 'escm-test::report-single project name
+          (escm-test::run-test (or reporter
+                                   (function escm-test::report-single))
+                               project
+                               name
                                (cdr (assoc name alist))))
       (let ((result ())
@@ -239 +282 @@
                          "all tests successful.")))
           (cons failed result))))))
-;;;(call-interactively 'escm-test::run 'escm) 
-
 
 (provide 'escm-test)

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

@@ -39 +39 @@
             ((listp fun) (cadr       fun))
             (t           (aref       fun 0)))
-    (throw 'error (format "wrong type argument: functionp %S" fun))))
+    (signal 'wrong-type-argument
+            (list "wrong type argument" 'functionp fun))))
 
 
@@ -88 +89 @@
           (nthcdr (+ n (or len 1))  list)))
 
+(defun escm-util::define-signals (spec &optional parents)
+  ""
+  (let ((sym      (car  spec))
+        (mess     (cadr spec))
+        (children (cddr spec)))
+    (put sym 'error-conditions (cons 'error (cons sym parents)))
+    (put sym 'error-message    mess)
+    (mapcar (lambda (child)
+              (escm-util::define-signals child (cons sym parents)))
+            children)))
+
 
 (provide 'escm-util)

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

@@ -17 +17 @@
   "extracts basename from file-path.
 If you give number as second argument, it removes suffixes."
-  (when (string-match "/$" path) (setq path (substring path 0 (1- (length path)))))
+  (when (string-match "/$" path)
+    (setq path (substring path 0 (1- (length path)))))
   (string-match "\\([^/]*/\\)*\\(.*\\)" path)
   (let* ((basename (match-string 2 path))

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

@@ -76 +76 @@
     retval))
 
+
 (provide 'escm-util.minimal)

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

@@ -15 +15 @@
         (regs   ())
         (vminit ()))
+
    `(,@(mapcar (lambda (p)
                  (let* ((n           (car p))
                         (v           (cdr p))
-                        (set         (intern (format "escm-vm::set-%s-stack"   n)))
-                        (get         (intern (format "escm-vm::get-%s-stack"   n)))
-                        (push        (intern (format "escm-vm::push-%s"        n)))
-                        (pop         (intern (format "escm-vm::pop-%s"         n)))