Context Navigation

← Previous Changeset
Next Changeset →

Changeset 7383

Timestamp:

03/03/08 03:20:00 (5 years ago)

Author:

lieutar

Message:

lang/elisp/escm/trunk: add some changes.

Location:

lang/elisp/escm/trunk

Files:

: 2 added
: 3 removed
: 11 modified

escm-arity.el (modified) (4 diffs)
escm-assemble.el (deleted)
escm-cbos.el (modified) (2 diffs)
escm-compile.el (modified) (1 diff)
escm-env.el (modified) (2 diffs)
escm-icode.el (added)
escm-pp.el (added)
escm-proc.el (modified) (2 diffs)
escm-root-env.el (deleted)
escm-syntax.el (modified) (1 diff)
escm-test.el (modified) (5 diffs)
escm-util.el (modified) (4 diffs)
escm-util.file.el (modified) (2 diffs)
escm-vm.el (modified) (4 diffs)
escm-wrapped-proc.el (deleted)
escm.el (modified) (2 diffs)

Legend:

: Unmodified
: Added
: Removed

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

r6576	r7383
	1	(require 'escm-util)
	2	(require 'escm-cbos)
	3
1	4	(escm-cbos::define-class escm-arity
2	5	length
…	…
4	7	at-least)
5	8
6		(defsubst ~~new-escm-arity~~ (argspec)
	9	(defsubst escm-arity::new (argspec)
7	10	""
8	11	(let ((new (create-escm-arity))
…	…
10	13	(at-least nil))
11	14	(while argspec
12		(if (consp argspec) ;; I must add check by symbolp.
13		(progn (setq fields (cons (car argspec) fields))
14		(setq argspec (cdr argspec)))
	15	(if (consp argspec)
	16	(let ((head (car argspec))
	17	(tail (cdr argspec)))
	18	(if (symbolp head)
	19	(progn (setq fields (cons head fields))
	20	(setq argspec tail))
	21	(throw 'error (format "wrong type argument: synbolp : %s" head))))
15	22	(progn (setq fields (cons argspec fields))
16	23	(setq at-least t)
…	…
19	26	(escm-arity::set-length new (length fields))
20	27	(escm-arity::set-at-least new at-least)))
21
22		~~(defsubst escm-arity::make-env (self)~~
23		~~(let* ((fields (escm-util::canonicalize-list self))~~
24		~~(new (create-escm-env (length (escm-arity::get-fields self))))~~
25		~~(ptr -1)~~
26		~~(dic (escm-env::get-dic new)))~~
27		~~(mapcar (lambda (f) (put dic f (setq ptr (1+ ptr)))) fields)~~
28		~~new))~~
29	28
30	29	(defsubst escm-arity::inject-args! (self env args)

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

r6576	r7383
104	104
105	105	(defmacro escm-cbos::define-class (inhspec &rest fields)
106		"Creates object constructor and predicate and field-accessors"
107		(let* ((name (car inhspec))
108		(super (or (cadr inhspec) 'escm-cbos::Object))
109		(fields (escm-cbos::register-class name super fields))
110		(len (length fields))
111		(new (intern (format "create-%s" name)))
112		(pred (intern (format "%s-p" name))))
	106	"Creates object constructor and predicate and field-accessors.
	107	The syntax of `escm-cbos::define-class' is as follows:
	108
	109	(escm-cbos::define-class (CLASS [SUPER] [CLONE-MODE]) ATTR...)
	110
	111	CLASS ::= Name of the class to be defined.
	112	SUPER ::= Name of super class.
	113	CLONE-MODE ::= t \| nil. if true, .
	114	ATTR ::= Name of the attribute of the objects.
	115	"
	116	(let* ((name (car inhspec))
	117	(super (or (cadr inhspec) 'escm-cbos::Object))
	118	(copy-mode (caddr inhspec))
	119	(fields (escm-cbos::register-class name super fields))
	120	(len (length fields))
	121	(new (intern (format "create-%s" name)))
	122	(pred (intern (format "%s-p" name))))
113	123	`(progn
114	124	(defsubst ,new ()
…	…
123	133
124	134	,@(let ((p 0))
125		(mapcar (lambda (f)
126		(setq p (1+ p))
127		`(progn
128		(defsubst ,(intern (format "%s::set-%s" name f)) (obj val)
129		(aset obj ,p val))
130		(defsubst ,(intern (format "%s::get-%s" name f)) (obj)
131		(aref obj ,p))))
132		fields)))))
	135	(mapcar
	136	(if copy-mode
	137	(lambda (f)
	138	(setq p (1+ p))
	139	`(progn
	140	(defsubst ,(intern (format "%s::set-%s" name f)) (obj val)
	141	(let ((new (escm-cbos::clone obj)))
	142	(aset new ,p val)
	143	new))
	144	(defsubst ,(intern (format "%s::get-%s" name f)) (obj)
	145	(aref obj ,p))))
	146
	147	(lambda (f)
	148	(setq p (1+ p))
	149	`(progn
	150	(defsubst ,(intern (format "%s::set-%s" name f)) (obj val)
	151	(aset obj ,p val))
	152	(defsubst ,(intern (format "%s::get-%s" name f)) (obj)
	153	(aref obj ,p)))))
	154
	155	fields)))))
133	156
134	157

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

r6617	r7383
1		(escm-cbos::define-class escm-context
2		argspec
3		envs
4		parent
5		tailp)
	1	(require 'escm-util )
	2	(require 'escm-cbos )
	3	(require 'escm-syntax)
	4	(require 'escm-icode )
	5	(require 'escm-env )
	6
	7	(escm-cbos::define-class (escm-context nil t) env tail? func?)
	8
	9	(defun escm-compile (context sexp)
	10	"Compiles sexp."
	11	(cond
	12	((and sexp (consp sexp))
	13	(let* ((head (car sexp))
	14	(headv (when (symbolp head) (escm-context::gref head))))
	15	(if (escm-syntax-p headv) (escm-syntax::apply headv context sexp)
	16	(escm-compile-apply context sexp))))
	17
	18	((symbolp sexp)
	19	(escm-icode (,(if (escm-context::get-callp) 'fref 'ref)
	20	(escm-context::get-env context))))
	21
	22	(t (escm-icode `((store ,sexp))))))
	23
	24	(defsubst escm-compile-apply (context sexp)
	25	""
	26	(let ((head (car sexp))
	27	(tail (cdr sexp))
	28	(arg-context (escm-context::set-tailp context nil))
	29	(ret (escm-iproc::new ())))
	30	(mapcar (lambda (x)
	31	(escm-iproc::merge ret (escm-compile arg-context x))
	32	(escm-iproc::merge ret (escm-icode '((pusha))))) tail)
	33	(escm-iproc::merge ret (escm-compile (escm-context::set-func? context t) head))
	34	(escm-iproc::merge ret (escm-icode `((,(if (escm-context::get-tailp context)
	35	'tcall
	36	'call)))))))
	37
	38	(defsubst escm-compile-if (sexp)
	39	""
	40	(let ((condx (escm-compile (cadr sexp)))
	41	(positivex (escm-compile (caddr sexp)))
	42	(negativex (escm-compile (cadddr sexp))))
	43
	44	(cond ((not (escm-iproc::has-jump positivex))
	45	(escm-iproc::merge
	46	condx
	47	(escm-icode `(unlessv
	48	,(car (escm-iproc::get-body positivex))
	49	,(escm-iproc::get-first negativex))))
	50	(escm-iproc::merge
	51	condx
	52	(escm-iproc::new
	53	(escm-iproc::get-body-without-first negativex))))
	54
	55	((not (escm-iproc::has-jump positivex))
	56	(escm-iproc::merge
	57	condx
	58	(escm-icode `(unlessv
	59	,(car (escm-iproc::get-body negativex))
	60	,(escm-iproc::get-first positivex))))
	61	(escm-iproc::merge
	62	condx
	63	(escm-iproc::new
	64	(escm-iproc::get-body-without-first positivex))))
	65
	66	(t
	67	(escm-iproc::merge negativex
	68	(escm-icode `((jmp ,(escm-iproc::length positivex)))))
	69	(escm-iproc::merge condx
	70	(escm-icode `((jt ,(escm-iproc::length negativex)))))
	71	(escm-iproc::merge condx negativex)
	72	(escm-iproc::merge condx positivex)))))
	73
	74
	75	(defun escm-compile-define-syntax ()
	76	""
	77	)
	78
	79	(defun escm-compile-let-syntax ()
	80	""
	81	)
	82
	83	(defun escm-compile-define (context sexp)
	84	""
	85	)
	86
	87	(defun escm-compile-lambda (context sexp)
	88	""
	89	`(store
	90	,(let* ((ctx (escm-context::push context))
	91	(arglist (cadr sexp))
	92	(body (cddr sexp))
	93	(mid (let ((asm ()))
	94	(while body
	95	(let ((head (car body))
	96	(tail (cdr body)))
	97	(escm-context::set-tail ctx (not tail))
	98	(setq asm (append asm (escm-compile ctx head)))
	99	(setq body tail)))))
	100	(asm (escm-optimize mid)))
	101	(escm-proc::new (escm-context::build-fixed-env env)
	102	(escm-assemble asm)))))
	103
	104	(defun escm-compile-quote (context sexp)
	105	)
	106
	107	(defun escm-compile-quasiquote (context sexp)
	108	)
	109
	110	(defun escm-compile-unquote (context sexp)
	111	)
6	112
7	113
8	114
	115	(add-hook
	116	'escm-vm::init-hook
	117	(lambda (vm)
	118	(escm-define-builtin-syntax vm quote (function escm-compile-quote))
	119	(escm-define-builtin-syntax vm quasiquote (function escm-compile-quasiquote))
	120	(escm-define-builtin-syntax vm unquote (function escm-compile-unquote))
	121	(escm-define-builtin-syntax vm if (function escm-compile-if))
	122	(escm-define-builtin-syntax vm let-syntax (function escm-compile-let-syntax))
	123	(escm-define-builtin-syntax vm define-syntax (function escm-compile-define-syntax))
	124	(escm-define-builtin-syntax vm define (function escm-compile-define))
	125	(escm-define-builtin-syntax vm lambda (function escm-compile-lambda))
	126	));; END OF INITIALIZER
9	127
10		(defun escm-compile (vm context sexp)
11		""
12		(cond
13		((and sexp (consp sexp))
14		(let* ((head (car sexp))
15		(headv (when (symbolp head)
16		(condition-case err
17		(escm-env::gref
18		(escm-vm::get-current-env vm)
19		head)
20		(error nil)))))
21		(if (escm-syntax-p headv)
22		(escm-syntax::apply headv vm context sexp)
23		(escm-compile-apply vm context sexp))))
24		((symbolp sexp) `(ref ,sexp ,(escm-vm::get-current-env vm)))
25		(t `((store . ,sexp)))))
26
27		(defun escm-compile-apply (vm context sexp)
28		""
29		(let ((head (car sexp))
30		(tail (cdr sexp)))
31
32		`(,@(append (mapcar (lambda (x) (append (escm-compile vm x)
33		'((store)))) tail))
34		,@(escm-compile vm head)
35		,('(call)))))
36
37		(escm-define-syntax if (vm context sexp)
38		(let (())))
39
40		(escm-define-syntax define (vm context sexp)
41		(let ((syms ))))
42
43		(escm-define-syntax lambda (vm context sexp)
44		(let ((syms ))))
	128	(provide 'escm-compile)

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

r6617	r7383
1		(escm-cbos::define-class (escm-env) parent dic ptr)
	1	(require 'escm-util)
	2	(require 'escm-cbos)
	3
	4	(defconst escm-env::class-diagram "
	5
	6	,--------------.
	7	\| escm-env \|
	8	\| <<abstract>> \|
	9	`--------------'
	10	A
	11	\|
	12	.-------------------+---------------------.
	13	\| \| \|
	14	,----------------. ,--------+---------. ,--------+----------.
	15	\| escm-fixed-env \|<-+ escm-dynamic-env \| \| escm-boundary-env \|
	16	`----------------' `------------------' `-------------------'
	17
	18	escm-env ... abstract root class of escm environment.
	19	escm-fixed-env ... fixed fields enviroment for compiled function.
	20	escm-dynamic-env ... it derives escm-fixed-env.
	21	escm-boundary-env ... this is able to access to native elisp environment.
	22
	23	")
	24
	25	(escm-cbos::define-class (escm-env) parent dic)
	26
	27	(escm-cbos::define-method escm-env escm-env::fref (self sym)
	28	""
	29	(escm-cbos::gref self sym))
	30
	31	(escm-cbos::define-method escm-env escm-env::member? (self sym)
	32	""
	33	(plist-member (symbol-plist (escm-env::get-dic)) sym))
	34
	35	(escm-cbos::define-method escm-env escm-env::pos (self sym)
	36	""
	37	(get (escm-env::get-dic self) sym))
	38
	39	(escm-cbos::define-method escm-env escm-env::make-referer (self env sym)
	40	""
	41	(let ((pos (escm-env::pos self sym)))
	42	(if pos `(aref ,env ,pos)
	43	(escm-env::make-referer (escm-env::get-parent self)
	44	`(escm-env::get-parent ,env)
	45	sym))))
	46
	47	(escm-cbos::define-method escm-env escm-env::make-setter (self env sym val)
	48	""
	49	(let ((pos (escm-env::pos self sym)))
	50	(if pos `(aset ,env ,pos ,val)
	51	(escm-env::make-setter (escm-env::get-parent self)
	52	`(escm-env::get-parent ,env)
	53	sym
	54	val))))
	55
	56	(escm-test::define-test escm env
	57	""
	58	(let* ((e (create-escm-env nil '(a b c)))
	59	(f (create-escm-env e '(d e f)))
	60	(g (create-escm-env f '(a))))
	61	(escm-test "gset! 0" (escm-env::gset! e 'a 1) t)
	62	(escm-test "gref 0" (eq 1 (escm-env::gref e 'a)))
	63	(escm-test "gset! 1" (escm-env::gset! f 'b 2) t)
	64	(escm-test "gref 1" (eq 2 (escm-env::gref e 'b)))
	65	(escm-test "gset! 2" (escm-env::gset! g 'a 3) t)
	66	(escm-test "gref 2" (and (eq 1 (escm-env::gref e 'a))
	67	(eq 3 (escm-env::gref g 'a))))
	68	(escm-util::a (escm-env::make-referer f 'env 'a))
	69	(escm-util::a (escm-env::make-setter f 'env 'a '((aaa))))))
	70
	71	;;(escm-test::run 'escm 'env )
	72
	73	;;;-----------;;;
	74	;;; ;;;
	75	;;; fixed-env ;;;
	76	;;; ;;;
	77	;;;-----------;;;
	78
	79	(escm-cbos::define-class (escm-fixed-env escm-env) ptr)
2	80
3	81	;; override
…	…
12	90	new))
13	91
14		(escm-cbos::define-method escm-env escm-cbos::clone (self)
15		(let ((new (super self)))
16		(escm-env::set-ptr new 3) new))
17
18		(escm-cbos::define-method escm-env escm-env::push (self val)
	92	(escm-cbos::define-method escm-fixed-env escm-fixed-env::push (self val)
19	93	(let ((ptr(escm-env::get-ptr self)))
20	94	(aset self ptr val)
21	95	(escm-env::set-ptr (1+ ptr)) val))
22	96
23		(escm-cbos::define-method escm-env escm-env::gref (self sym)
	97	(escm-cbos::define-method escm-fixed-env escm-env::gref (self sym)
24	98	(let ((pos (get (escm-env::get-dic self) sym)))
25	99	(if pos (aref self pos)
26	100	(let ((parent (escm-env::get-parent self)))
27		(if parent
28		(escm-env::gref parent)
	101	(if parent (escm-env::gref parent)
29	102	(throw 'escm-env::unbound (format "unbound symbol : %s" sym)))))))
30	103
31		(escm-cbos::define-method escm-env escm-env::gset! (self sym val)
	104	(escm-cbos::define-method escm-fixed-env escm-env::gset! (self sym val)
32	105	(let ((pos (get (escm-env::get-dic self) sym)))
33	106	(if pos (aset self pos val)
34	107	(let ((parent (escm-env::get-parent self)))
35		(if parent
36		(escm-env::gset! parent sym val)
	108	(if parent (escm-env::gset! parent sym val)
37	109	(throw 'escm-env::unbound (format "unbound symbol : %s" sym)))))))
38	110
39		(escm-cbos::define-method escm-env escm-env::pos (self sym)
40		(get (escm-env::get-dic self) sym))
	111	;;;-------------;;;
	112	;;; ;;;
	113	;;; dynamic-env ;;;
	114	;;; ;;;
	115	;;;-------------;;;
41	116
42		(escm-cbos::define-method escm-env escm-env::make-referer (self env sym)
43		(let ((pos (escm-env::pos self sym)))
44		(if pos `(aref ,env ,pos)
45		(escm-env::make-referer (escm-env::get-parent self)
46		`(escm-env::get-parent ,env)
47		sym))))
	117	(escm-cbos::define-class (escm-dynamic-env escm-env) valdic arity fields)
48	118
49		(escm-cbos::define-method escm-env escm-env::make-setter (self env sym val)
50		(let ((pos (escm-env::pos self sym)))
51		(if pos `(aset ,env ,pos ,val)
52		(escm-env::make-setter (escm-env::get-parent self)
53		`(escm-env::get-parent ,env)
54		sym
55		val))))
	119	(defsubst escm-dynamic-env::new (list)
	120	""
	121	(let ((new create-escm-env))
	122	(let ((arity (escm-arity::new list)))
	123	(mapcar (lambda (sym) (escm-dynamic-env::add-field new sym))
	124	(escm-dynamic-env::get-symbols arity))
	125	(escm-dynamic-env::set-valdic new (make-symbol "valdic"))
	126	(escm-dynamic-env::set-arity new arity))
	127	new))
56	128
57		(escm-test::deftest escm env
58		(let* ((e (create-escm-env nil '(a b c)))
59		(f (create-escm-env e '(d e f)))
60		(g (create-escm-env f '(a))))
61		(escm-test "gset! 0" (escm-env::gset! e 'a 1) t)
62		(escm-test "gref 0" (eq 1 (escm-env::gref e 'a)))
63		(escm-test "gset! 1" (escm-env::gset! f 'b 2) t)
64		(escm-test "gref 1" (eq 2 (escm-env::gref e 'b)))
65		(escm-test "gset! 2" (escm-env::gset! g 'a 3) t)
66		(escm-test "gref 2" (and (eq 1 (escm-env::gref e 'a))
67		(eq 3 (escm-env::gref g 'a))))
68		(escm-util::a (escm-env::make-referer f 'env 'a))
69		(escm-util::a (escm-env::make-setter f 'env 'a '((aaa))))))
	129	(defsubst escm-dynamic-env::add-field (self sym)
	130	""
	131	(put (escm-env::get-dic self) sym (length fields))
	132	(put (escm-dynamic-env::get-valdic self) sym nil)
	133	(escm-dynamic-env::set-fields self (cons sym (escm-dynamic-env::get-fields))))
70	134
71		;;(escm-test::run 'escm 'env )
	135	(defsubst escm-dynamic-env::build-fixed-env (self))
	136
	137	(escm-cbos::define-method escm-dynamic-env escm-env::gset! (self sym val)
	138	(if (escm-env::member? self sym)
	139	(put (escm-dynamic-env::get-valdic self) sym val)
	140	(let ((parent (escm-env::get-parent self)))
	141	(if parent
	142	(escm-env::gset! parent sym val)
	143	(throw 'escm-env::unbound (format "unbound symbol : %s"))))))
	144
	145	(escm-cbos::define-method escm-dynamic-env escm-env::gref (self sym)
	146	(if (escm-env::member? self sym)
	147	(get (escm-dynamic-env::get-valdic self) sym)
	148	(let ((parent (escm-env::get-parent self)))
	149	(if parent
	150	(escm-env::gref parent sym)
	151	(throw 'escm-env::unbound (format "unbound symbol : %s"))))))
	152
	153	;;;
	154	;;; elisp-env
	155	;;;
	156
	157	(escm-cbos::define-class (escm-elisp-env escm-env))
	158
	159	(escm-cbos::define-method escm-elisp-env escm-env::gref (self sym)
	160	(let ((dic (escm-env::dic self)))
	161	(if (plist-member dic sym)
	162	(get dic sym)
	163	(let ((retval (condition-case err (symbol-value 'sym)
	164	(error (condition-case err (symbol-function 'sym)
	165	(error (throw 'escm::unbound "")))))))
	166	(let ((retval (if (functionp retval)
	167	(escm-proc::wrap-elisp retval)
	168	retval)))
	169	(put dic sym retval)
	170	retval)))))
	171
	172	(escm-cbos::define-method escm-elisp-env escm-env::fref (self sym)
	173	(let ((dic (escm-env::dic self)))
	174	(if (plist-member dic sym)
	175	(get dic sym)
	176	(let ((retval (condition-case err (symbol-function 'sym)
	177	(error (condition-case err (symbol-value 'sym)
	178	(error (throw 'escm::unbound "")))))))
	179	(let ((retval (if (functionp retval)
	180	(escm-proc::wrap-elisp retval)
	181	retval)))
	182	(put dic sym retval)
	183	retval)))))
	184
	185	(escm-cbos::define-method escm-elisp-env escm-env::gset! (self sym val)
	186	(put (escm-env::dic self) sym val))
	187
	188	(escm-cbos::define-method escm-elisp-env escm-env::make-referer (self env sym)
	189	`(escm-env::gref ,env ,sym))
	190
	191	(escm-cbos::define-method escm-elisp-env escm-env::make-setter (self env sym val)
	192	`(escm-env::gset! ,env ,sym ,val))
	193
72	194	(provide 'escm-env)

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

r6617	r7383
	1	(require 'escm-bos)
	2	(require 'escm-env)
	3
1	4	(escm-cbos::defclass escm-proc
2	5	env
…	…
11	14	new))
12	15
13		(defmacro escm-defun ()
14		(let (())
15		))
	16	(defsubst escm-wrapped-proc::new (fun)
	17	(let ((new (create-escm-wrapped-proc)))
	18	(escm-proc::set-body
	19	(vector
	20	(byte-compile (lambda (vm)
	21	(escm-vm::set-current-value
	22	vm
	23	(apply fun (escm-vm::get-current-args vm)))))
	24	(function escm-vm::ret)))))

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

r6617	r7383
	1	(require 'escm-cbos)
	2	(require 'escm-proc)
1	3
2		(~~defmacro escm-define-syntax (name argspec &rest body~~)
3		)
	4	(escm-cbos::define-class (escm-syntax) proc)
	5	(escm-cbos::define-class (escm-builtin-syntax escm-syntax))
4	6
5		(put 'escm-define-syntax 'lisp-indent-function 'defun)
	7	(escm-cbos::define-method escm-syntax escm-syntax::apply (self context sexp)
	8	(escm-vm::apply (escm-context::get-vm context)
	9	(escm-syntax::get-proc self)
	10	(list sexp)))
6	11
	12	(escm-cbos::define-method escm-builtin-syntax escm-syntax-apply (self context sexp)
	13	(apply (escm-syntax::get-proc self)
	14	(list context sexp)))
7	15
	16	(defsubst escm-syntax::new (proc)
	17	(let ((self (create-escm-syntax))) (escm-syntax::set-proc proc) self))
	18
	19	(defsubst escm-builtin-syntax::new (proc)
	20	(let ((self (create-escm-builtin-syntax)))
	21	(escm-syntax::set-proc proc)
	22	self))
	23
	24	(defmacro escm-define-builtin-syntax (name argspec &rest body)
	25	`(escm-builtin-syntax::new `(lambda ,argspec ,@body)))
	26
	27	(put 'escm-define-builtin-syntax 'lisp-indent-function 'defun)
	28
	29	(provide 'escm-syntax)

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

r6617	r7383
8	8
9	9	(defun escm-test::run-test (reporter project name all)
10		"runs provided test."
	10	"Runs provided test."
11	11	(let* ((errors ())
12	12	(failed ()))
…	…
14	14	(apply reporter (list project name (length all) failed))))
15	15
16		(defmacro escm-test::deftest (project name &rest body)
17		"~~defines new test as belongs the `project'~~."
	16	(defmacro escm-test::define-test (project name &rest body)
	17	"Defines new test as belongs the PROJECT."
18	18	`(put 'escm-test::tests
19	19	',project
20	20	(cons (cons ',name ',body) (get 'escm-test::tests ',project))))
21		(put 'escm-test::deftest 'lisp-indent-function 'defun)
	21	(put 'escm-test::define-test 'lisp-indent-function 'defun)
22	22
23	23	(defun escm-test::report-single (project name all failed)
	24	""
24	25	(if failed
25	26	(with-output-to-temp-buffer "escm-test"
…	…
30	31
31	32	(defun escm-test::project-alist ()
32		"returns all project names as alist."
	33	"Returns all project names as alist."
33	34	(let((src (symbol-plist 'escm-test::tests))
34	35	(ret ()))
…	…
39	40
40	41	(defun escm-test::run (project &optional name)
41		"~~runs all tests what belongs given project~~."
	42	"Runs all tests what belongs the PROJECT."
42	43	(interactive
43	44	(let* ((prj (intern (completing-read "project: "
…	…
68	69
69	70	(provide 'escm-test)
70

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

r6617	r7383
	1	(require 'cl)
1	2
2	3	(defmacro escm-util::expand (&rest body)
3		"expands anonymous macro as standard macro."
	4	"Expands anonymous macro as standard macro."
4	5	(cons 'progn (eval body)))
5	6
…	…
7	8	;;; list utilities.
8	9	;;;
9		(defsubst escm-util::walk-node (fun src &optional pred)
10		""
	10	(defsubst escm-util::walk-node (fun tree &optional pred)
	11	"Apply FUN to each leaves of TREE, and make a tree of the results.
	12	Nodes in the TREE are lists, and leaves in there are atoms."
11	13	(let ((retstack nil)
12		(srcstack (list ~~src~~))
	14	(srcstack (list tree))
13	15	(ret nil)
14	16	(src nil)
…	…
44	46
45	47	(defun escm-util::list-splice (list n &optional len replacement)
46		"~~like a splice in perl~~."
	48	"Removes items of List , like a \"splice\" in perlfunc."
47	49	(append (escm-util::take n list)
48	50	replacement
…	…
50	52
51	53	(defun escm-util::a (&rest args)
52		""
	54	"Prints args to minibuffer."
53	55	(read-char (format "%S" args))
54	56	nil)
55	57
56	58	(defsubst escm-util::get-arity (fun)
57		"~~returns argument list~~."
	59	"Returns arguments list of function."
58	60	(if (functionp fun)
59	61	(cond ((subrp fun) (subr-arity fun))

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

r6576	r7383
	1	(require 'escm-util)
	2
1	3	;;;
2	4	;;; file utilities
…	…
80	82	(escm-util::close fh)
81	83	(reverse ret)))
	84
	85	(provide 'escm-util.file)

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

r6617	r7383
2	2	(require 'escm-cbos)
3	3	(require 'escm-proc)
4		~~(require 'escm-wrapped-proc)~~
5	4
6		(defconst 'escm-vm::init-hook ())
	5	(defconst 'escm-vm::init-hook ())
	6	(defconst 'escm-vm::serial-number 0)
7	7	(defun escm-vm-init (vm) (run-hook-with-args 'escm-vm::init-hook vm))
8	8
…	…
58	58	(escm-vm::push-args vm ())))
59	59
	60
60	61	(defsubst escm-vm::t-call (vm)
61	62	(let ((proc (escm-vm::get-current-val))
…	…
69	70	(escm-vm::set-current-pc vm 0)
70	71	(escm-vm::set-current-args vm ())))
	72
71	73
72	74	(defsubst escm-vm::ret (vm)
…	…
86	88	(escm-vm::pop-args vm))
87	89
	90
88	91	(defsubst escm-vm::step (vm)
89	92	(let ((pc (escm-vm::get-current-pc vm)))
90	93	(apply (aref (escm-vm::get-current-proc vm) pc) (list vm))
91	94	(escm-vm::set-current-pc vm (1+ pc))))
	95
	96
	97	(defsubst escm-vm::apply (vm proc args)
	98	(let ((procs (escm-vm::get-proc-stack vm))
	99	(retval (progn (escm-vm::set-proc-stack ())
	100	(escm-vm::set-current-args vn args)
	101	(escm-vm::set-current-value vm proc)
	102	(escm-vm::call vm)
	103	(while (escm-vm::get-proc-stack vm)
	104	(escm-vm::step vm)))))
	105	(escm-vm::set-proc-stack vm proc)
	106	retval))

lang/elisp/escm/trunk/escm.el

r6617	r7383
	1	(require 'escm-util)
1	2	(require 'escm-vm)
2	3
3	4	(defvar escm-default-vm nil)
4		(defsubst escm-default-vm () (or escm-default-vm
5		(progn (setq escm-default-vm (escm-vm::new))
6		escm-default-vm)))
	5	(defsubst escm-default-vm ()
	6	(or escm-default-vm
	7	(progn (setq escm-default-vm (escm-vm::new))
	8	escm-default-vm)))
7	9
8	10	(defsubst escm-eval (exp)
…	…
11	13	(defsubst escm-apply (proc args)
12	14	(escm-vm::apply (escm-default-vm) proc args))
	15
	16	(defmacro escm-define (&rest body) (escm-eval `(define ,@body)))
	17	(unless (fboundp 'define) (defalias 'define 'escm-define))
	18
	19	(defun escm-locate-library (name)
	20	(or (locate-library name)
	21	(locate-library (concat (escm-util::basename name) ".escm"))))
	22
	23	(defun escm-load (file)
	24	(when (symbolp file) (setq file (symbol-name file)))
	25	())
	26
	27	(defadvice require (around escm-load first (sym) activate)
	28	""
	29	(condition-case err ad-do-it
	30	(file-error (escm-load sym))))
	31
	32	(defadvice load (around escm-load first (file) activate)
	33	""
	34	(condition-case err ad-do-it
	35	(file-error (escm-load file))))
	36
	37	(provide 'escm)

Download in other formats: