Context Navigation

← Previous Change
Next Change →

Changeset 7843 for lang/elisp

Timestamp:

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

Author:

lieutar

Message:

lang/elisp/escm/trunk: I modified my test framework a little.

Location:

lang/elisp/escm/trunk

Files:

: 3 added
: 7 modified

DEV.el (added)
escm-arity.el (modified) (3 diffs)
escm-cbos.el (modified) (4 diffs)
escm-compile.el (modified) (1 diff)
escm-env.el (modified) (8 diffs)
escm-icode.el (modified) (1 diff)
escm-preprocess.el (added)
escm-test.el (modified) (5 diffs)
escm-util.el (modified) (3 diffs)
escm-util.minimal.el (added)

Legend:

: Unmodified
: Added
: Removed

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

r7842	r7843
	1	;;; escm-arity.el ---
	2
	3	;; Copyright (C) 2008 Free Software Foundation, Inc.
	4
	5	;; Author: <lieutar@1dk.jp>
	6	;; Keywords:
	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:
1	28	(require 'escm-util)
2	29	(require 'escm-cbos)
3	30	(require 'escm-test)
4		(require 'escm-env)
	31	;;(require 'escm-env)
5	32
6	33	(escm-cbos::define-class (escm-arity)
…	…
30	57	new))
31	58
32		~~;;; test code~~
33		~~(escm-test::define-test escm arity~~
34		~~(let ((z (escm-arity::new ()))~~
35		~~(o (escm-arity::new '(a b c)))~~
36		~~(a1 (escm-arity::new 'a))~~
37		~~(a2 (escm-arity::new '(a . b))))~~
38		~~(escm-test one1 (= 1 (escm-arity::get-length a1)))~~
39		~~(escm-test zero (= 0 (escm-arity::get-length z)))~~
40		~~(escm-test three (= 3 (escm-arity::get-length o)))~~
41		~~(escm-test not-at-least (not (escm-arity::get-at-least z)))~~
42		~~(escm-test at-least-2 (escm-arity::get-at-least a2))~~
43		~~(escm-test at-least-1 (escm-arity::get-at-least a1))))~~
44		~~;; (escm-test::run 'escm 'arity)~~
45	59
46	60
…	…
58	72
59	73
	74	;;; test codes
	75	(escm-test::define-test escm arity
	76	(let ((z (escm-arity::new ()))
	77	(o (escm-arity::new '(a b c)))
	78	(a1 (escm-arity::new 'a))
	79	(a2 (escm-arity::new '(a . b))))
	80	(escm-test one1 (= 1 (escm-arity::get-length a1)))
	81	(escm-test zero (= 0 (escm-arity::get-length z)))
	82	(escm-test three (= 3 (escm-arity::get-length o)))
	83	(escm-test not-at-least (not (escm-arity::get-at-least z)))
	84	(escm-test at-least-2 (escm-arity::get-at-least a2))
	85	(escm-test at-least-1 (escm-arity::get-at-least a1)))
	86	)
	87	;; (escm-test::run 'escm 'arity)
	88
	89	;;; escm-arity.el ends here.

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

r7842	r7843
1		;;; escm-cbos - tiny class base object system for escm-vm.
	1	;;; escm-cbos.el --- tiny class base object system for escm-vm.
	2
	3	;; Copyright (C) 2008 Free Software Foundation, Inc.
	4
	5	;; Author: <lieutar@1dk.jp>
	6	;; Keywords:
	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
2	29	;;;
3	30	;;;
…	…
32	59	(defsubst escm-cbos::register-class (name super fields)
33	60	""
34		(put 'escm-cbos::class-vmt name (let ((tbl (make-symbol (format "spec:%s" name))))
35		(set tbl
36		(cons name
37		(symbol-value (get 'escm-cbos::class-vmt
38		super))))
39		tbl))
40		(let ((retval (if super (append (escm-cbos::get-fields-of super) fields) fields)))
	61	(put 'escm-cbos::class-vmt
	62	name (let ((tbl (make-symbol (format "spec:%s" name))))
	63	(set tbl
	64	(cons name
	65	(symbol-value (get 'escm-cbos::class-vmt
	66	super))))
	67	tbl))
	68	(let ((retval
	69	(if super (append (escm-cbos::get-fields-of super) fields) fields)))
41	70	(put 'escm-cbos::class-fields name retval)
42	71	retval))
…	…
88	117	(if (listp x)
89	118	(cond ((eq 'super (car x))
90		`(apply (or (escm-cbos::find-method 'ilist method-name)
91		(throw 'escm-cbos::error::no-such-method
92		(format "")))
93		(list ilist method-name ,@(cdr x))))
	119	`(apply
	120	(or (escm-cbos::find-method 'ilist method-name)
	121	(throw 'escm-cbos::error::no-such-method
	122	(format "")))
	123	(list ilist method-name ,@(cdr x))))
94	124	(t (throw 'error "panic!!"))) x))
95	125	body
…	…
176	206
177	207	(provide 'escm-cbos)
	208	;;; escm-cbos.el ends here.

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

r7840	r7843
87	87	(defun escm-compile-lambda (context sexp)
88	88	""
89		`(store
	89	`(store-proc
90	90	,(let* ((ctx (escm-context::push context))
91	91	(arglist (cadr sexp))

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

r7842	r7843
3	3	(require 'escm-test)
4	4
5		(defconst escm-env::class-diagram "
6
7		~~,--------------.~~
	5	(defconst escm-env::class-diagram nil "
	6
	7	+--------------+
8	8	\| escm-env \|
9	9	\| <<abstract>> \|
10		~~`--------------'~~
	10	+--------------+
11	11	A
12	12	\|
13		~~.-------------------+---------------------.~~
	13	+-------------------+---------------------+
14	14	\| \| \|
15		~~,----------------. ,--------+---------. ,--------+----------.~~
	15	+----------------+ +--------+---------+ +--------+----------+
16	16	\| escm-fixed-env \|<-+ escm-dynamic-env \| \| escm-boundary-env \|
17		~~`----------------' `------------------' `-------------------'~~
	17	+----------------+ -------------------+ +-------------------+
18	18
19	19	escm-env ... abstract root class of escm environment.
…	…
32	32	(escm-cbos::define-method escm-env escm-env::member? (self sym)
33	33	""
34		(plist-member (symbol-plist (escm-env::get-dic)) sym))
	34	(plist-member (symbol-plist (escm-env::get-dic self)) sym))
35	35
36	36	(escm-cbos::define-method escm-env escm-env::pos (self sym)
…	…
65	65	;; override
66	66	(defsubst create-escm-fixed-env (parent syms)
67		(let ((new (escm-cbos::create-object 'escm-env (length syms)))
	67	(let ((new (escm-cbos::create-object 'escm-fixed-env (length syms)))
68	68	(dic (make-symbol "dic"))
69	69	(p 2))
…	…
94	94
95	95	;; test code for escm-test
96		(escm-test::define-test escm env
	96	(escm-test::define-test escm fixed-env
97	97	""
98	98	(let* ((e (create-escm-fixed-env nil '(a b c)))
99	99	(f (create-escm-fixed-env e '(d e f)))
100	100	(g (create-escm-fixed-env f '(a))))
101		(escm-test "gset! 0" (escm-env::gset! e 'a 1))
	101	(escm-test "inheritance" (eq (escm-env::get-parent f) e))
	102	(escm-test "inheritance" (eq (escm-env::get-parent g) f))
	103	(escm-test "gset! 0" (escm-env::gset! e 'a 1) t)
102	104	(escm-test "gref 0" (eq 1 (escm-env::gref e 'a)))
103		(escm-test "gset! 1" (escm-env::gset! f 'b 2))
	105	(escm-test "gset! 1" (escm-env::gset! f 'b 2) t)
104	106	(escm-test "gref 1" (eq 2 (escm-env::gref e 'b)))
105	107	(escm-test "gset! 2" (escm-env::gset! g 'a 3) t)
106	108	(escm-test "gref 2" (and (eq 1 (escm-env::gref e 'a))
107	109	(eq 3 (escm-env::gref g 'a))))
108		(escm-util::a (escm-env::make-referer f 'env 'a))
109		(escm-util::a (escm-env::make-setter f 'env 'a '((aaa))))))
110		;; (escm-test::run 'escm 'env )
	110	(escm-test "make setter"
	111	(eval (escm-test::p "setter"
	112	(escm-env::make-setter f 'f 'a 123))) t)
	113	(escm-test "make referer"
	114	(eq (eval
	115	(escm-test::p "referer" (escm-env::make-referer f 'f 'a)))
	116	123))))
	117	;; (escm-test::run 'escm 'fixed-env)
111	118
112	119	;;;-------------;;;
…	…
115	122	;;; ;;;
116	123	;;;-------------;;;
117
	124	(require 'escm-arity)
118	125	(escm-cbos::define-class (escm-dynamic-env escm-env) valdic arity fields)
119	126
120		(defsubst escm-dynamic-env::new (list)
121		""
122		(let ((new create-escm-env))
	127	(defsubst escm-dynamic-env::new (parent list)
	128	""
	129	(let ((new (create-escm-dynamic-env)))
	130	(escm-env::set-parent new parent)
123	131	(let ((arity (escm-arity::new list)))
124	132	(mapcar (lambda (sym) (escm-dynamic-env::add-field new sym))
125		(escm-~~dynamic-env~~::get-symbols arity))
	133	(escm-arity::get-symbols arity))
126	134	(escm-dynamic-env::set-valdic new (make-symbol "valdic"))
127	135	(escm-dynamic-env::set-arity new arity))
…	…
130	138	(defsubst escm-dynamic-env::add-field (self sym)
131	139	""
132		(put (escm-env::get-dic self) sym (length fields))
133		(put (escm-dynamic-env::get-valdic self) sym nil)
134		(escm-dynamic-env::set-fields self (cons sym (escm-dynamic-env::get-fields))))
	140
	141	(put (escm-env::get-dic self)
	142	sym
	143	(length (escm-dynamic-env::get-fields self)))
	144	(put (escm-dynamic-env::get-valdic self)
	145	sym
	146	nil)
	147	(escm-dynamic-env::set-fields
	148	self
	149	(cons sym (escm-dynamic-env::get-fields self))))
135	150
136	151	(defsubst escm-dynamic-env::build-fixed-env (self))
…	…
151	166	(escm-env::gref parent sym)
152	167	(throw 'escm-env::unbound (format "unbound symbol : %s"))))))
	168
	169	;; test code for escm-dynamic-env
	170	(escm-test::define-test escm dynamic-env
	171	""
	172	(let* ((e (escm-dynamic-env::new nil '(a b c)))
	173	(f (escm-dynamic-env::new e '(d e f)))
	174	(g (escm-dynamic-env::new f '(a))))
	175	(escm-test "inheritance" (eq (escm-env::get-parent f) e))
	176	(escm-test "inheritance" (eq (escm-env::get-parent g) f))
	177	(escm-test "gset! 0" (escm-env::gset! e 'a 1) t)
	178	(escm-test "gref 0" (eq 1 (escm-env::gref e 'a)))
	179	(escm-test "gset! 1" (escm-env::gset! f 'b 2) t)
	180	(escm-test "gref 1" (eq 2 (escm-env::gref e 'b)))
	181	(escm-test "gset! 2" (escm-env::gset! g 'a 3) t)
	182	(escm-test "gref 2" (and (eq 1 (escm-env::gref e 'a))
	183	(eq 3 (escm-env::gref g 'a))))
	184	(escm-test "make setter"
	185	(eval (escm-test::p "setter"
	186	(escm-env::make-setter f 'f 'a 123))) t)
	187
	188	(escm-test "make referer"
	189	(eq (eval
	190	(escm-test::p "referer" (escm-env::make-referer f 'f 'a)))
	191	123))
	192	))
	193	;; (escm-test::run 'escm 'dynamic-env)
	194
153	195
154	196	;;;
…	…
190	232	`(escm-env::gref ,env ,sym))
191	233
192		(escm-cbos::define-method escm-elisp-env escm-env::make-setter (self env sym val)
	234	(escm-cbos::define-method escm-elisp-env escm-env::make-setter
	235	(self env sym val)
193	236	`(escm-env::gset! ,env ,sym ,val))
194	237

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

r7383	r7843
173	173
174	174	;;
	175	store-proc ((lambda (val) `(progn (escm-vm::set-current-value
	176	vm
	177	))))
	178
	179	;;
175	180	call ((lambda () `(escm-vm::call vm)) . t)
176	181

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

r7842	r7843
1		(defconst escm-test::tests () "symbol for plist of tests.")
	1	;;; escm-test.el --- simple test framework
	2
	3	;; Copyright (C) 2008 Free Software Foundation, Inc.
	4
	5	;; Author: <lieutar@1dk.jp>
	6	;; Keywords: test
	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	(require 'escm-util.minimal)
	29
	30
	31	(defconst escm-test::tests ()
	32	"symbol for plist of tests.")
2	33
3	34	(defface escm-test::ok-face
…	…
17	48	"")
18	49
	50
	51	(defface escm-test::print-face
	52	'((((class color) (background light))
	53	(:foreground "white" :background "blue"))
	54	(((class color) (background dark))
	55	(:foreground "white" :background "blue"))
	56	(t ()))
	57	"")
	58
	59	(defmacro escm-test::p (name &rest x)
	60	""
	61	`(let ((ret (progn ,@x)))
	62	(setq report (cons (cons :print (cons ,name ret)) report))
	63	ret))
	64
	65	(defun escm-test::build-traced-line (trace)
	66	""
	67	(format "%S" (cdr trace)))
	68
	69
	70
	71
	72	(defun escm-test::record-errors (cont debugger-args)
	73	(throw cont
	74	(format "%S\nbacktrace:%s"
	75	debugger-args
	76	(let ((drop t)
	77	(depth 0)
	78	(trace t)
	79	(all ""))
	80	(while trace
	81	(unless (eq trace t)
	82	(if drop
	83	(if (eq (cadr trace) 'escm-test::record-errors)
	84	(setq drop nil))
	85	(setq all
	86	(concat
	87	all
	88	"\n"
	89	(escm-test::build-traced-line trace)))))
	90	(setq trace (backtrace-frame depth))
	91	(setq depth (1+ depth))
	92	(when (and (eq (cadr trace) 'catch)
	93	(equal (caddr trace) ''escm-test->eval))
	94	(setq trace nil)))
	95	all))))
	96
19	97	(defmacro escm-test (name &rest x)
20	98	""
21		`(let ((err (condition-case error
22		(let ((err (eval (progn ,@x))))
23		(if (eq err t) nil (or err "failed")))
24		(error
25		(format "%S\n%s"
26		error
27		(with-output-to-string
28		(backtrace)))))))
29		(setq report (cons (if err (progn (setq failed (1+ failed))
30		(list ',name err)) ',name)
	99	`(let ((err (let ((debugger (lambda (&rest args)
	100	(escm-test::record-errors 'escm-test->eval
	101	args))))
	102	(let ((result (catch 'escm-test->eval (eval (progn ,@x)))))
	103	(if (eq result t) nil (or result "failed"))))))
	104	(setq report
	105	(cons (if err (progn (setq failed (1+ failed))
	106	(list ',name err)) ',name)
31	107	report))))
	108
	109	(defun escm-test::run-test::debugger (&rest debugger-args)
	110	(setq failed (1+ failed))
	111	(escm-test::record-errors 'escm-test::run-test->eval
	112	debugger-args))
32	113
33	114	(defun escm-test::run-test (reporter project name all)
…	…
35	116	(let* ((report ())
36	117	(errors ())
37		(failed 0))
38		(eval (cons 'progn all))
	118	(failed 0)
	119	(debugger 'escm-test::run-test::debugger)
	120	(err (catch 'escm-test::run-test->eval
	121	(eval (cons 'progn all)))))
	122	(if err (setq report (cons (list "* FATAL ERROR *" err) report)))
39	123	(apply reporter (list project name failed (reverse report)))))
	124
	125
	126	(when nil ;;;;
	127
	128	(progn
	129	(escm-test::define-test escm-test fail2
	130	(/ 2 0))
	131	(escm-test::run 'escm-test 'fail2))
	132
	133	(progn
	134	(escm-test::define-test escm-test fail
	135	(escm-test zero (progn (/ 1 0)))
	136	(escm-test success t)
	137	(escm-test unreach t))
	138	(escm-test::run 'escm-test 'fail))
	139
	140	);;;;
40	141
41	142	(defmacro escm-test::define-test (project name &rest body)
42	143	"Defines new test as belongs the PROJECT."
43		`(put 'escm-test::tests
44		',project
45		(cons (cons ',name ',body)
46		(get 'escm-test::tests ',project))))
	144	`(progn
	145	(let ((dic (or (get 'escm-test::tests ',project)
	146	(let ((sym (make-symbol (symbol-name ',project))))
	147	(put 'escm-test::tests ',project sym)
	148	sym))))
	149	(put dic ',name ',body))))
47	150	(put 'escm-test::define-test 'lisp-indent-function 'defun)
48	151
49	152	(defun escm-test::report-single (project name failed report)
50		""
51		(save-excursion
52		(let ((buf (get-buffer-create "escm-test")))
53		(set-buffer buf)
54		(toggle-read-only -1)
55		(delete-region (point-min) (point-max))
56		(insert
57		(mapconcat
58		(lambda (r)
59		(if (listp r)
60		(let ((head (format "%s :" (car r))))
61		(set-text-properties
62		0 (length head) '(face escm-test::faild-face) head)
63		(concat head (format " %s" (cadr r))))
64		(let ((ok (format "%s ... ok!" r)))
65		(set-text-properties
66		0 (length ok) '(face escm-test::ok-face) ok)
67		ok)))
68		report
69		"\n"))
70		(toggle-read-only 1)
71		(goto-char (point-min))
72		(pop-to-buffer buf t t)))
	153	"Reports result of a test."
	154	(escm-util::popup "escm-test"
	155	(insert
	156	(mapconcat
	157	(lambda (r)
	158	(if (listp r)
	159	(if (eq :print (car r))
	160	(concat (escm-util::text-with-properties
	161	(format "%s :" (cadr r)) 'face 'escm-test::print-face)
	162	(format "%S" (cddr r)))
	163	(concat (escm-util::text-with-properties
	164	(format "%s :" (car r)) 'face 'escm-test::faild-face)
	165	(format " %s" (cadr r))))
	166	(escm-util::text-with-properties
	167	(format "%s ... ok!" r) 'face 'escm-test::ok-face)))
	168	report
	169	"\n")))
73	170	(when (= failed 0) (message "all tests successful.")))
74	171
…	…
82	179	ret))
83	180
	181	(defun escm-test::test-alist (project)
	182	"Returns alist of test that bound PROJECT."
	183	(escm-util::plist-to-alist
	184	(symbol-plist (get 'escm-test::tests project))))
	185
	186
	187
84	188	(defun escm-test::run (project &optional name)
85	189	"Runs all tests what belongs the PROJECT."
…	…
87	191	(let* ((prj (intern (completing-read "project: "
88	192	(escm-test::project-alist) nil t)))
	193	(cands (mapcar (lambda (x) (list (symbol-name (car x))))
	194	(escm-test::test-alist prj)))
89	195	(name (completing-read
90		"test: "
91		(mapcar (lambda (x) (list (symbol-name
92		(car x))))
93		(get 'escm-test::tests prj))
94		nil
95		t)))
96		(list prj (if name (intern name)))))
97		(let ((alist (get 'escm-test::tests project)))
	196	"test: " cands nil t)))
	197	(list prj (if (equal name "") nil (intern name)))))
	198	(let ((alist (escm-test::test-alist project)))
98	199	(if name
99		(escm-test::run-test 'escm-test::report-single project name
100		(cdr (assoc name alist)))
101		(let ((failed ()))
	200	(progn
	201	(escm-test::run-test 'escm-test::report-single project name
	202	(cdr (assoc name alist))))
	203	(let ((result ())
	204	(failed 0))
	205
102	206	(mapcar (lambda (x)
103	207	(escm-test::run-test
104	208	(lambda (project name fail report)
105		(if fail
106		nil
107		(setq failed (cons fail failed))))
	209	(setq result
	210	(cons (cons (if (> fail 0)
	211	:failed
	212	(progn (setq failed (1+ failed))
	213	:success)) name)
	214	result)))
108	215	project
109	216	(car x)
110	217	(cdr x)))
111	218	alist)
112		(if failed (with-output-to-temp-buffer "escm-test" (mapcar 'print failed))
113		(message "all tests successful."))))))
	219
	220	(if (interactive-p)
	221	(escm-util::popup "escm-test"
	222	(insert (mapconcat
	223	(lambda (r)
	224	(case (car r)
	225	((:failed)
	226	(escm-util::text-with-properties
	227	(format "%s ... failure" (cdr r))
	228	'face 'escm-test::faild-face))
	229	((:success)
	230	(escm-util::text-with-properties
	231	(concat (cdr r) " ... ok")
	232	'face 'escm-test::ok-face))))
	233	result "\n"))
	234	(message (if (> failed 0)
	235	(format "%s/%s tests failed..."
	236	failed (length alist))
	237	"all tests successful.")))
	238	(cons failed result))))))
	239	;;;(call-interactively 'escm-test::run 'escm)
	240
114	241
115	242	(provide 'escm-test)
	243	;;; escm-test.el ends here.

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

r7842	r7843
1		(require 'cl)
	1	;;; hoge.el ---
2	2
3		(apply (let ((s (make-symbol "aa")))