Context Navigation

← Previous Change
Next Change →

Changeset 12358 for lang/c

Timestamp:

05/25/08 22:12:38 (6 months ago)

Author:

mokehehe

Message:

Add 'begin' syntax.
Add 'gensym' for macro.

Location:

lang/c/misc/mlisp

Files:

: 6 modified

core/c_compiler.cpp (modified) (10 diffs)
core/m_basic.cpp (modified) (2 diffs)
core/m_vect.cpp (modified) (4 diffs)
core/m_vect.h (modified) (1 diff)
proto/stackbased.scm (modified) (18 diffs)
readme.txt (modified) (1 diff)

Legend:

: Unmodified
: Added
: Removed

lang/c/misc/mlisp/core/c_compiler.cpp

r12268	r12358
68	68
69	69
	70	static SExp find_sets(SExp x, SExp v);
	71
	72	static SExp find_sets_compound(SExp body, SExp v) {
	73	SExp r = nil;
	74	for (SExp p = body; !nilp(p); p = cdr(p)) {
	75	SExp x = car(p);
	76	r = set_union(find_sets(x, v), r);
	77	}
	78	return r;
	79	}
70	80
71	81	static SExp find_sets(SExp x, SExp v) {
…	…
79	89	SExp vars = cadr(x);
80	90	SExp body = cddr(x);
81		SExp sets = set_minus(v, vars);
82		for (SExp p = body; !nilp(p); p = cdr(p)) {
83		SExp x = car(p);
84		sets = find_sets(x, sets);
85		}
86		return sets;
	91	return find_sets_compound(body, set_minus(v, vars));
87	92	} else if (eq(op, intern("if"))) {
88	93	SExp test = cadr(x);
…	…
106	111	SExp exp = cadr(x);
107	112	return find_sets(exp, v);
	113	} else if (eq(op, intern("begin"))) {
	114	SExp body = cdr(x);
	115	return find_sets_compound(body, v);
108	116	} else {
109	117	SExp r = nil;
…	…
182	190	}
183	191
	192
	193	static SExp find_free(SExp x, SExp b);
	194
	195	static SExp find_free_compound(SExp body, SExp free) {
	196	for (SExp p = body; !nilp(p); p = cdr(p)) {
	197	SExp x = car(p);
	198	free = find_free(x, free);
	199	}
	200	return free;
	201	}
	202
184	203	static SExp find_free(SExp x, SExp b) {
185	204	if (symbolp(x)) {
…	…
196	215	SExp vars = cadr(x);
197	216	SExp body = cddr(x);
198		SExp free = set_union(vars, b);
199		for (SExp p = body; !nilp(p); p = cdr(p)) {
200		SExp x = car(p);
201		free = find_free(x, free);
202		}
203		return free;
	217	return find_free_compound(body, set_union(vars, b));
204	218	} else if (eq(op, intern("if"))) {
205	219	SExp test = cadr(x);
…	…
223	237	SExp exp = cadr(x);
224	238	return find_free(exp, b);
	239	} else if (eq(op, intern("begin"))) {
	240	SExp body = cdr(x);
	241	return find_free_compound(body, b);
225	242	} else {
226	243	SExp r = nil;
…	…
268	285	/// �h�b�g�΂𐳋K�`�ɒ��
269	286	static SExp dotted2proper(SExp ls) {
270		if (consp(ls)) {
	287	if (nilp(ls)) {
	288	return nil;
	289	} else if (consp(ls)) {
271	290	SExp last = last_pair(ls);
272	291	if (nilp(cdr(last))) {
…	…
357	376	} else if (eq(op, intern("defmacro"))) {
358	377	return x;
	378	} else if (eq(op, intern("begin"))) {
	379	return compile_macroexpand_all_compound(1, x, e);
359	380	} else {
360	381	SExp fn = car(x);
…	…
475	496	SExp els, elsec;
476	497	SExp ddd = cdddr(x);
477		if (!nilp(ddd)) ~~els = cadddr(x);~~
478		else ~~els = nil;~~
	498	if (!nilp(ddd)) { els = car(ddd); }
	499	else { els = nil; }
479	500	elsec = compile(els, e, s, next);
480	501	return compile(test, e, s, list(3, TEST, thenc, elsec));
…	…
510	531	compile_defmacro(name, vars, body);
511	532	return next;
	533	} else if (eq(op, intern("begin"))) {
	534	SExp body = cdr(x);
	535	return compile_block(body, e, s, next);
512	536	} else {
513	537	return compile_apply(x, e, s, next);

lang/c/misc/mlisp/core/m_basic.cpp

r12283	r12358
245	245	}
246	246
	247	static SExp builtin_gensym() {
	248	static int cnt;
	249	char buf[16];
	250	sprintf(buf, "G:%d", ++cnt);
	251	return intern(buf);
	252	}
	253
247	254
248	255
…	…
331	338	{ "compile", builtin_compile, 1, 1, },
332	339	{ "exit", builtin_exit, 0, 1, },
	340
	341	{ "gensym", builtin_gensym, 0, 0, },
333	342	};
334	343	for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {

lang/c/misc/mlisp/core/m_vect.cpp

r12283	r12358
23	23	p->type = (SType)tVect;
24	24	p->size = size;
25		for (int i=0; i<size; ++i) {
26		p->buf[i] = nil;
27		}
	25	SExp v = gen_sexpext(p);
28	26
29		return gen_sexpext(p);
	27	vector_fill(v, nil);
	28	return v;
30	29	}
31	30
…	…
69	68	}
70	69
	70	void vector_fill(SExp v, SExp val) {
	71	type_check(v, tVect);
	72	SVector* p = (SVector*)v.ptr;
	73
	74	unsigned int n = p->size;
	75	for (unsigned int i=0; i<n; ++i) {
	76	p->buf[i] = val;
	77	}
	78	}
	79
71	80
72	81
…	…
92	101	}
93	102
	103	static SExp fn_vector_fill() {
	104	SExp v = get_arg(0);
	105	SExp val = get_arg(1);
	106	vector_fill(v, val);
	107	return v;
	108	}
	109
94	110
95	111	void add_vector_module(void) {
…	…
105	121	{ "vector-set!", fn_vector_set, 3, 3, },
106	122	{ "vector-ref", fn_vector_ref, 2, 2, },
	123	{ "vector-fill!", fn_vector_fill, 2, 2, },
107	124	};
108	125	for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {

lang/c/misc/mlisp/core/m_vect.h

r12263	r12358
21	21	SExp vector_ref(SExp v, int i);
22	22	int vector_length(SExp v);
	23	void vector_fill(SExp v, SExp val);
23	24
24	25

lang/c/misc/mlisp/proto/stackbased.scm

r12283	r12358
50	50	;; ドット対を正規形に直す
51	51	(define (dotted->proper ls)
52		(~~if (pair?~~ ls)
53		(let ((last (last-pair ls)))
54		(if (null? (cdr last))
55		ls
56		(append (subseq ls 0 (dotted-pos ls))
57		~~(list (cdr (last-pair ls~~))))))
58		~~(list ls~~)))
	52	(cond ((null? ls) ls)
	53	((pair? ls) (let ((last (last-pair ls)))
	54	(if (null? (cdr last))
	55	ls
	56	(append (subseq ls 0 (dotted-pos ls))
	57	(list (cdr (last-pair ls)))))))
	58	(else (list ls))))
59	59
60	60
…	…
119	119	(expand-compound 2 `(define ,@var-body) e)))))
120	120	((defmacro) x)
	121	((begin) (expand-compound 1 x e))
121	122	(else
122	123	(let* ((fn (car x))
…	…
216	217	boxes
217	218	next))))
218		(if (test then else)
219		(let ((thenc (compile then e s next))
220		(elsec (compile else e s next)))
	219	(if (test then)
	220	(let* ((ddd (cdddr x))
	221	(thenc (compile then e s next))
	222	(elsec (compile (if (null? ddd)
	223	'()
	224	(car ddd))
	225	e s next)))
221	226	(compile test e s (list 'TEST thenc elsec))))
222	227	(set! (var xx)
…	…
249	254	(compile-defmacro name vars body)
250	255	next))
	256	(begin ()
	257	(let ((body (cdr x)))
	258	(compile-block body e s next)))
251	259	(else
252	260	(compile-apply x e s next))))
…	…
286	294	(define find-free
287	295	(lambda (x b)
	296	(define (find-free-compound xs b)
	297	(fold (lambda (x r) (find-free x r))
	298	b
	299	xs))
288	300	(cond
289	301	((symbol? x) (if (set-member? x b) '() (list x)))
…	…
293	305	(lambda (vars)
294	306	(let ((body (cddr x)))
295		(fold (lambda (x r) (find-free x r))
296		(set-union vars b)
297		body)))
298		(if (test then else)
299		(set-union (find-free test b)
300		(set-union (find-free then b)
301		(find-free else b))))
	307	(find-free-compound body (set-union vars b))))
	308	(if (test then)
	309	(let ((else (cdddr x)))
	310	(set-union (find-free test b)
	311	(set-union (find-free then b)
	312	(find-free-compound else b)))))
302	313	(set! (var exp)
303	314	(set-union (if (set-member? var b) '() (list var))
304	315	(find-free exp b)))
305	316	(call/cc (exp) (find-free exp b))
	317	(begin ()
	318	(let ((body (cdr x)))
	319	(find-free-compound body b)))
306	320	(else
307	321	(recur next ((x x))
…	…
314	328	(define find-sets
315	329	(lambda (x v)
	330	(define (find-sets-compound xs v)
	331	(fold (lambda (x r) (set-union (find-sets x v)
	332	r))
	333	'()
	334	xs))
316	335	(cond
317	336	((symbol? x) '())
…	…
321	340	(lambda (vars)
322	341	(let ((body (cddr x)))
323		(fold (lambda (x r) (find-sets x r))
324		(set-minus v vars)
325		body)))
326		(if (test then else)
327		(set-union (find-sets test v)
328		(set-union (find-sets then v)
329		(find-sets else v))))
	342	(find-sets-compound body (set-minus v vars))))
	343	(if (test then)
	344	(let ((else (cdddr x)))
	345	(set-union (find-sets test v)
	346	(set-union (find-sets then v)
	347	(find-sets-compound else v)))))
330	348	(set! (var x)
331	349	(set-union (if (set-member? var v) (list var) '())
332	350	(find-sets x v)))
333	351	(call/cc (exp) (find-sets exp v))
	352	(begin ()
	353	(let ((body (cdr x)))
	354	(find-sets-compound body v)))
334	355	(else
335	356	(recur next ((x x))
…	…
400	421	(define VM
401	422	(lambda (a x f c)
402		; (write/ss (list (car x) (dump-stack sp)))
403		; (newline)
	423	(when (refer-global 'trace)
	424	(write/ss (list (car x) (dump-stack sp)))
	425	(newline))
404	426	(record-case x
405		~~(HALT () a)~~
406	427	(REFER-LOCAL (n x)
407	428	(VM (index f (+ n 1)) x f c))
408	429	(REFER-FREE (n x)
409	430	(VM (index-closure c n) x f c))
410		~~(INDIRECT (x)~~
411		~~(VM (unbox a) x f c))~~
412	431	(CONSTANT (obj x)
413	432	(VM obj x f c))
…	…
416	435	(unlink n)
417	436	(VM aa x f c)))
418		~~(BOX (n x)~~
419		~~(index-set! sp (+ n 1) (box (index sp (+ n 1))))~~
420		~~(VM a x f c))~~
421	437	(TEST (then else)
422	438	(VM a (if a then else) f c))
423		~~(ASSIGN-LOCAL (n x)~~
424		~~(set-box! (index f (+ n 1)) a)~~
425		~~(VM a x f c))~~
426		~~(ASSIGN-FREE (n x)~~
427		~~(set-box! (index-closure c n) a)~~
428		~~(VM a x f c))~~
429		~~(CONTI (t? x)~~
430		~~(VM (continuation sp t?) x f c))~~
431		~~(NUATE (stack t? x)~~
432		~~(begin~~
433		~~(restore-stack stack)~~
434		~~(if (not t?) (push 0))~~
435		~~(VM a x f c)))~~
436	439	(FRAME (x ret)
437	440	(begin
…	…
444	447	(push a)
445	448	(VM a x f c)))
446		~~(SHIFT (n x)~~
447		~~(let ((m (index sp n))) ; ひとつ上の引数の個数~~
448		~~(shift-args n m sp)~~
449		~~(unlink (+ m 1))~~
450		~~(VM a x f c)))~~
451	449	(APPLY (n)
452	450	(if (is-a? a <functional>)
…	…
470	468	(cc (pop)))
471	469	(VM a xx ff cc))))
	470	(SHIFT (n x)
	471	(let ((m (index sp n))) ; ひとつ上の引数の個数
	472	(shift-args n m sp)
	473	(unlink (+ m 1))
	474	(VM a x f c)))
	475	(ASSIGN-LOCAL (n x)
	476	(set-box! (index f (+ n 1)) a)
	477	(VM a x f c))
	478	(ASSIGN-FREE (n x)
	479	(set-box! (index-closure c n) a)
	480	(VM a x f c))
	481	(INDIRECT (x)
	482	(VM (unbox a) x f c))
	483	(BOX (n x)
	484	(index-set! sp (+ n 1) (box (index sp (+ n 1))))
	485	(VM a x f c))
	486	(CONTI (t? x)
	487	(VM (continuation sp t?) x f c))
	488	(NUATE (stack t? x)
	489	(begin
	490	(restore-stack stack)
	491	(if (not t?) (push 0))
	492	(VM a x f c)))
472	493	(REFER-GLOBAL (var x)
473	494	(VM (refer-global var) x f c))
…	…
481	502	(VM a x f c))
482	503	(error "assign to undefined symbol:" var)))
	504	(HALT () a)
483	505	(else
484	506	(error "illegal opecode:" (car x))))))
…	…
494	516
495	517
	518	(define run
	519	(lambda (code)
	520	(VM '() code 0 '())))
	521
496	522	(define evaluate
497	523	(lambda (x)
498		(~~VM '() (compile-top x) 0 '(~~))))
	524	(run (compile-top x))))
499	525
500	526
…	…
787	813	'proc 2 2
788	814	(lambda () (= (get-arg 0) (get-arg 1)))))
	815	(cons 'gensym
	816	(gen-builtin
	817	'proc 0 0
	818	(let ((cnt 0))
	819	(lambda () (string->symbol
	820	(string-append "G:"
	821	(number->string (inc! cnt))))))))
789	822	(cons 'read
790	823	(gen-builtin
…	…
803	836	'proc 1 1
804	837	(lambda () (compile-top (get-arg 0)))))
	838	(cons 'run
	839	(gen-builtin
	840	'proc 1 1
	841	(lambda () (run (get-arg 0)))))
805	842	(cons 'load
806	843	(gen-builtin
…	…
827	864	transform-quasiquote))
828	865
	866	(cons 'trace
	867	#f)
829	868
830	869	))
…	…
881	920
882	921
883
884		(load "test_macro.scm")
885
886
887		(macroexpand-1
888		'(letrec ((loop (lambda (n acc)
889		(if (> n 0)
890		(loop (- n 1) (+ acc n))
891		acc))))
892		(loop 10 0)))
893
894
895		letrec
896
897
898
899
900
901		(letrec ((loop (lambda (n acc)
902		(if (> n 0)
903		(loop (- n 1) (+ acc n))
904		acc))))
905		(loop 10 0))
	922	(compile
	923	'(if 1
	924	(begin (print 1) (print 2))
	925	(begin (print 'a) (print 'b)))
	926	)
	927
	928	(compile '(begin 1 2))
	929
	930
906	931
907	932

lang/c/misc/mlisp/readme.txt

r12283	r12358
47	47
48	48	* ToDo
	49	- �g��݂̕��@ (if, quote, ...) ��Q�Ƃł��Ȃ�
49	50	-[v] �G��[��b�Z�[�W��Ƃ킩��
50	51	-begin

Download in other formats: