Révisions pour joyful.ml

capitalex a révisé ce gist 1 day ago. Aller à la révision

1 file changed, 64 insertions, 39 deletions

joyful.ml

			@@ -53,6 +53,15 @@ and joyful_action =
53	53		exception Unclosed_quotation
54	54
55	55		let parse tokens =
	56	+	let to_action token =
	57	+	match int_of_string_opt token with
	58	+	\| Some n ->
	59	+	Push (`JoyfulInt n)
	60	+	\| None when String.starts_with ~prefix:"`" token ->
	61	+	Push (`JoyfulSymbol (String.sub token 1 (String.length token - 1)))
	62	+	\| None ->
	63	+	Call token in
	64	+
56	65		let rec parse_quotation ?(quotation=[]) tokens =
57	66		match tokens with
58	67		\| [] ->
			@@ -62,14 +71,9 @@ let parse tokens =
62	71		parse_quotation rest ~quotation:(Push inner_quotation :: quotation)
63	72		\| "]" :: rest ->
64	73		rest, `JoyfulQuotation (List.rev quotation)
65		-	\| x :: rest ->
66		-	match int_of_string_opt x with
67		-	\| Some n ->
68		-	let quotation = Push (`JoyfulInt n) :: quotation in
69		-	parse_quotation rest ~quotation
70		-	\| None ->
71		-	let quotation = Call x :: quotation in
72		-	parse_quotation rest ~quotation in
	74	+	\| token :: rest ->
	75	+	let quotation = to_action token :: quotation in
	76	+	parse_quotation rest ~quotation in
73	77
74	78		let rec helper tokens prog =
75	79		match tokens with
			@@ -78,14 +82,9 @@ let parse tokens =
78	82		\| "[" :: rest ->
79	83		let rest, quotation = parse_quotation rest in
80	84		helper rest (Push (quotation) :: prog)
81		-	\| x :: rest ->
82		-	match int_of_string_opt x with
83		-	\| Some n ->
84		-	Push (`JoyfulInt n) :: prog \|> helper rest
85		-	\| None when String.starts_with ~prefix:"`" x ->
86		-	Push (`JoyfulSymbol (String.sub x 1 (String.length x - 1))) :: prog \|> helper rest
87		-	\| None ->
88		-	Call x :: prog \|> helper rest in
	85	+	\| token :: rest ->
	86	+	to_action token :: prog \|> helper rest in
	87	+
89	88		helper tokens []
90	89
91	90		class runtime_class =
			@@ -134,15 +133,21 @@ class runtime_class =
134	133
135	134		method poll =
136	135		Stack.pop_opt call_stack
	136	+
	137	+	method data_stack = data_stack
	138	+	method retain_stack = retain_stack
	139	+	method call_stack = call_stack
137	140		end
138	141
139	142		let dictionary =
140	143		object(self)
141	144		val words : (string, runtime_class -> unit) Hashtbl.t = Hashtbl.create 16
142	145
143		-	method new_primitive name f =
	146	+	method add_word name f =
144	147		Hashtbl.add words name f
145	148
	149	+	method remove_word name =
	150	+	Hashtbl.remove words name
146	151
147	152		method call name runtime =
148	153		(Hashtbl.find words name) runtime
			@@ -151,7 +156,7 @@ let dictionary =
151	156
152	157		let () =
153	158		let new_math_primitives name op =
154		-	dictionary#new_primitive name (fun runtime ->
	159	+	dictionary#add_word name (fun runtime ->
155	160		let y = runtime#pop_int in
156	161		let x = runtime#pop_int in
157	162		let z = `JoyfulInt (op x y) in
			@@ -162,42 +167,55 @@ let () =
162	167		["+" ; "-" ; "/" ; "*" ]
163	168		[ (+) ; (-) ; (/) ; ( * ) ] ;
164	169
165		-	dictionary#new_primitive "print-int" (fun runtime -> runtime#pop_int \|> print_int) ;
	170	+	dictionary#add_word "print-int" (fun runtime -> runtime#pop_int \|> print_int) ;
166	171
167		-	dictionary#new_primitive "dup" (fun runtime -> runtime#dup);
	172	+	dictionary#add_word "dup" (fun runtime -> runtime#dup);
168	173
169		-	dictionary#new_primitive "swap" (fun runtime -> runtime#swap);
	174	+	dictionary#add_word "swap" (fun runtime -> runtime#swap);
170	175
171		-	dictionary#new_primitive "drop" (fun runtime -> runtime#drop);
	176	+	dictionary#add_word "drop" (fun runtime -> runtime#drop);
172	177
173		-	dictionary#new_primitive "call" (fun runtime -> runtime#pop_quote \|> runtime#queue_actions) ;
	178	+	dictionary#add_word "call" (fun runtime -> runtime#pop_quote \|> runtime#queue_actions) ;
174	179
175		-	dictionary#new_primitive "stash" (fun runtime -> runtime#stash) ;
	180	+	dictionary#add_word "compose" (fun runtime ->
	181	+	let p = runtime#pop_quote in
	182	+	let q = runtime#pop_quote in
	183	+	`JoyfulQuotation (q @ p) \|> runtime#push
	184	+	) ;
176	185
177		-	dictionary#new_primitive "unstash" (fun runtime -> runtime#unstash) ;
	186	+	dictionary#add_word "quote" (fun runtime ->
	187	+	`JoyfulQuotation [ Push runtime#pop ] \|> runtime#push
	188	+	) ;
178	189
179		-	dictionary#new_primitive "def" (fun runtime ->
	190	+	dictionary#add_word "stash" (fun runtime -> runtime#stash) ;
	191	+
	192	+	dictionary#add_word "unstash" (fun runtime -> runtime#unstash) ;
	193	+
	194	+	dictionary#add_word "def" (fun runtime ->
180	195		let symbol = runtime#pop_symbol in
181	196		let actions = runtime#pop_quote in
182		-	dictionary#new_primitive symbol (fun runtime ->
	197	+	dictionary#add_word symbol (fun runtime ->
183	198		actions \|> runtime#queue_actions
184	199		)
185	200		) ;
186	201
	202	+	dictionary#add_word "undef" (fun runtime ->
	203	+	let symbol = runtime#pop_symbol in
	204	+	dictionary#remove_word symbol) ;
187	205
188		-	dictionary#new_primitive "dip" (fun runtime ->
	206	+	dictionary#add_word "dip" (fun runtime ->
189	207		[ Call "unstash" ] \|> runtime#queue_actions ;
190	208		runtime#pop_quote \|> runtime#queue_actions ;
191	209		[ Call "stash" ] \|> runtime#queue_actions
192	210		) ;
193	211
194		-	dictionary#new_primitive "sqrti" (fun runtime ->
	212	+	dictionary#add_word "sqrti" (fun runtime ->
195	213		`JoyfulInt (runtime#pop_int \|> Float.of_int \|> sqrt \|> Int.of_float) \|> runtime#push) ;
196	214
197		-	dictionary#new_primitive "nl" (fun _ -> print_newline ())
	215	+	dictionary#add_word "nl" (fun _ -> print_newline ())
198	216
199		-	let eval quote =
200		-	let runtime = new runtime_class in
	217	+
	218	+	let eval ?(runtime = new runtime_class) quote =
201	219		runtime#queue_quotation quote ;
202	220		let rec helper () =
203	221		let action = runtime#poll in
			@@ -214,12 +232,19 @@ let eval quote =
214	232		helper () in
215	233		helper ()
216	234
217		-	let mag_program = "
218		-	[ dup [ dip ] dip call ] `bi@ def
219		-	[ dup * ] `sq def
220		-	3 4 [ sq ] bi@ + sqrti print-int nl
	235	+	let program = "
	236	+	[ quote [ call ] compose swap quote compose call ] `dip def
	237	+	[ dup [ dip ] dip call ] `bi@ def
	238	+	[ dup * ] `sq def
	239	+	[ [ sq ] bi@ + sqrti ] `mag def
	240	+	3 4 mag print-int nl
	241	+
221	242		"
222	243
223		-	let run_mag () =
224		-	print_endline mag_program ;
225		-	mag_program \|> tokenize \|> parse \|> eval
	244	+	let spy_eval program =
	245	+	let r = new runtime_class in
	246	+	program \|> tokenize \|> parse \|> eval ~runtime:r ;
	247	+	( r#data_stack \|> Stack.to_seq \|> List.of_seq
	248	+	, r#retain_stack \|> Stack.to_seq \|> List.of_seq
	249	+	, r#call_stack \|> Stack.to_seq \|> List.of_seq
	250	+	)

capitalex a révisé ce gist 1 day ago. Aller à la révision

1 file changed, 225 insertions

joyful.ml(fichier créé)

		@@ -0,0 +1,225 @@
1	+	(*
2	+	1 2 + print-int
3	+	*)
4	+
5	+	let rec skip_whitespace chars =
6	+	let open Seq in
7	+	match chars () with
8	+	\| Cons (' ', rest) \| Cons ('\t', rest) \| Cons ('\n', rest) ->
9	+	skip_whitespace rest
10	+	\| _ ->
11	+	chars
12	+
13	+	let collect_symbol chars =
14	+	let rec helper chars acc =
15	+	let open Seq in
16	+	match chars () with
17	+	\| Cons (' ', rest) \| Cons ('\t', rest) \| Cons ('\n', rest) ->
18	+	acc \|> Buffer.contents, rest
19	+	\| Cons (ch, rest) ->
20	+	Buffer.add_char acc ch ;
21	+	helper rest acc
22	+	\| Nil ->
23	+	(acc \|> Buffer.contents, Seq.empty) in
24	+	helper chars @@ Buffer.create 16
25	+
26	+	let scan_symbol chars =
27	+	let chars = skip_whitespace chars in
28	+	collect_symbol chars
29	+
30	+	let tokenize str =
31	+	let stream = String.to_seq str in
32	+	let rec helper stream acc =
33	+	let open Seq in
34	+	match scan_symbol stream with
35	+	\| "", seq ->
36	+	acc \|> List.rev
37	+	\| str, more ->
38	+	helper more (str :: acc) in
39	+	helper stream []
40	+
41	+	type joyful_quote = [ `JoyfulQuotation of joyful_action list ]
42	+	and joyful_data =
43	+	[
44	+	\| `JoyfulSymbol of string
45	+	\| `JoyfulInt of int
46	+	\| `JoyfulQuotation of joyful_action list
47	+	]
48	+	and joyful_action =
49	+	\| Push of joyful_data
50	+	\| Call of string
51	+
52	+	(* todo, implmenent stackless qoutation eval *)
53	+	exception Unclosed_quotation
54	+
55	+	let parse tokens =
56	+	let rec parse_quotation ?(quotation=[]) tokens =
57	+	match tokens with
58	+	\| [] ->
59	+	raise Unclosed_quotation
60	+	\| "[" :: rest ->
61	+	let rest, inner_quotation = parse_quotation rest in
62	+	parse_quotation rest ~quotation:(Push inner_quotation :: quotation)
63	+	\| "]" :: rest ->
64	+	rest, `JoyfulQuotation (List.rev quotation)
65	+	\| x :: rest ->
66	+	match int_of_string_opt x with
67	+	\| Some n ->
68	+	let quotation = Push (`JoyfulInt n) :: quotation in
69	+	parse_quotation rest ~quotation
70	+	\| None ->
71	+	let quotation = Call x :: quotation in
72	+	parse_quotation rest ~quotation in
73	+
74	+	let rec helper tokens prog =
75	+	match tokens with
76	+	\| [] ->
77	+	`JoyfulQuotation (List.rev prog)
78	+	\| "[" :: rest ->
79	+	let rest, quotation = parse_quotation rest in
80	+	helper rest (Push (quotation) :: prog)
81	+	\| x :: rest ->
82	+	match int_of_string_opt x with
83	+	\| Some n ->
84	+	Push (`JoyfulInt n) :: prog \|> helper rest
85	+	\| None when String.starts_with ~prefix:"`" x ->
86	+	Push (`JoyfulSymbol (String.sub x 1 (String.length x - 1))) :: prog \|> helper rest
87	+	\| None ->
88	+	Call x :: prog \|> helper rest in
89	+	helper tokens []
90	+
91	+	class runtime_class =
92	+	let transfer sa sb = Stack.push (Stack.pop sa) sb in
93	+	object(self)
94	+	val data_stack : joyful_data Stack.t = Stack.create ()
95	+	val retain_stack : joyful_data Stack.t = Stack.create ()
96	+	val call_stack : joyful_action Stack.t = Stack.create ()
97	+
98	+	method stash = transfer data_stack retain_stack
99	+	method unstash = transfer retain_stack data_stack
100	+	method push = Fun.flip Stack.push data_stack
101	+	method pop = Stack.pop data_stack
102	+
103	+	method pop_int =
104	+	match self#pop with
105	+	\| `JoyfulInt i -> i
106	+	\| _ -> raise @@ Invalid_argument "Expected int"
107	+
108	+	method pop_quote =
109	+	match self#pop with
110	+	\| `JoyfulQuotation q -> q
111	+	\| _ -> raise @@ Invalid_argument "Expected quote"
112	+
113	+	method pop_symbol =
114	+	match self#pop with
115	+	\| `JoyfulSymbol s -> s
116	+	\| _ -> raise @@ Invalid_argument "Expected symbol"
117	+
118	+	method dup = Stack.push (Stack.top data_stack) data_stack
119	+
120	+	method swap =
121	+	let tos = self#pop in
122	+	let nos = self#pop in
123	+	self#push tos ;
124	+	self#push nos
125	+
126	+	method drop = Stack.drop data_stack
127	+
128	+	method queue_quotation (quote : joyful_quote) =
129	+	match quote with
130	+	\| `JoyfulQuotation actions -> self#queue_actions actions
131	+
132	+	method queue_actions actions =
133	+	actions \|> List.rev \|> List.to_seq \|> Stack.add_seq call_stack
134	+
135	+	method poll =
136	+	Stack.pop_opt call_stack
137	+	end
138	+
139	+	let dictionary =
140	+	object(self)
141	+	val words : (string, runtime_class -> unit) Hashtbl.t = Hashtbl.create 16
142	+
143	+	method new_primitive name f =
144	+	Hashtbl.add words name f
145	+
146	+
147	+	method call name runtime =
148	+	(Hashtbl.find words name) runtime
149	+	end
150	+
151	+
152	+	let () =
153	+	let new_math_primitives name op =
154	+	dictionary#new_primitive name (fun runtime ->
155	+	let y = runtime#pop_int in
156	+	let x = runtime#pop_int in
157	+	let z = `JoyfulInt (op x y) in
158	+	runtime#push z
159	+	) in
160	+
161	+	List.iter2 new_math_primitives
162	+	["+" ; "-" ; "/" ; "*" ]
163	+	[ (+) ; (-) ; (/) ; ( * ) ] ;
164	+
165	+	dictionary#new_primitive "print-int" (fun runtime -> runtime#pop_int \|> print_int) ;
166	+
167	+	dictionary#new_primitive "dup" (fun runtime -> runtime#dup);
168	+
169	+	dictionary#new_primitive "swap" (fun runtime -> runtime#swap);
170	+
171	+	dictionary#new_primitive "drop" (fun runtime -> runtime#drop);
172	+
173	+	dictionary#new_primitive "call" (fun runtime -> runtime#pop_quote \|> runtime#queue_actions) ;
174	+
175	+	dictionary#new_primitive "stash" (fun runtime -> runtime#stash) ;
176	+
177	+	dictionary#new_primitive "unstash" (fun runtime -> runtime#unstash) ;
178	+
179	+	dictionary#new_primitive "def" (fun runtime ->
180	+	let symbol = runtime#pop_symbol in
181	+	let actions = runtime#pop_quote in
182	+	dictionary#new_primitive symbol (fun runtime ->
183	+	actions \|> runtime#queue_actions
184	+	)
185	+	) ;
186	+
187	+
188	+	dictionary#new_primitive "dip" (fun runtime ->
189	+	[ Call "unstash" ] \|> runtime#queue_actions ;
190	+	runtime#pop_quote \|> runtime#queue_actions ;
191	+	[ Call "stash" ] \|> runtime#queue_actions
192	+	) ;
193	+
194	+	dictionary#new_primitive "sqrti" (fun runtime ->
195	+	`JoyfulInt (runtime#pop_int \|> Float.of_int \|> sqrt \|> Int.of_float) \|> runtime#push) ;
196	+
197	+	dictionary#new_primitive "nl" (fun _ -> print_newline ())
198	+
199	+	let eval quote =
200	+	let runtime = new runtime_class in
201	+	runtime#queue_quotation quote ;
202	+	let rec helper () =
203	+	let action = runtime#poll in
204	+	match action with
205	+	\| None ->
206	+	()
207	+
208	+	\| Some (Push value) ->
209	+	runtime#push value ;
210	+	helper ()
211	+
212	+	\| Some (Call name) ->
213	+	dictionary#call name runtime;
214	+	helper () in
215	+	helper ()
216	+
217	+	let mag_program = "
218	+	[ dup [ dip ] dip call ] `bi@ def
219	+	[ dup * ] `sq def
220	+	3 4 [ sq ] bi@ + sqrti print-int nl
221	+	"
222	+
223	+	let run_mag () =
224	+	print_endline mag_program ;
225	+	mag_program \|> tokenize \|> parse \|> eval

Plus récent Plus ancien