Commit df7d5b3fcd5c0110b536e001d80f3b71bf142df4 - Robin

Replace exception handler with error objects. Untested. Chris Pressey 5 years ago

5 changed file(s) with 43 addition(s) and 71 deletion(s). Raw diff Collapse all Expand all

+14

-14

src/Language/Robin/Builtins.hs less more

32	32	evalArgs formals actuals origActuals env (\nenv ->
33	33	cc $ insert formal value nenv))
34	34	evalArgs _ _ origActuals env cc =
35		raise env $ errMsg "illegal-arguments" $ List origActuals
	35	errMsg "illegal-arguments" $ List origActuals
36	36
37	37
38	38	evalTwoNumbers :: (Int32 -> Int32 -> (Expr -> Expr) -> Expr) -> Evaluable

42	42	eval env yexpr (\y ->
43	43	assertNumber env y (\(Number yv) ->
44	44	(fn xv yv cc)))))
45		evalTwoNumbers fn env other cc = raise env $ errMsg "illegal-arguments" other
	45	evalTwoNumbers fn env other cc = errMsg "illegal-arguments" other
46	46
47	47	--
48	48	-- `Small`

55	55	literal :: Evaluable
56	56	literal env (List (expr:_)) cc =
57	57	cc expr
58		literal env other cc = raise env $ errMsg "illegal-arguments" other
	58	literal env other cc = errMsg "illegal-arguments" other
59	59
60	60	robinList :: Evaluable
61	61	robinList env (List exprs) cc =

75	75	eval env branch cc
76	76	Boolean False ->
77	77	choose env (List rest) cc)
78		choose env other cc = raise env $ errMsg "illegal-arguments" other
	78	choose env other cc = errMsg "illegal-arguments" other
79	79
80	80	bind :: Evaluable
81	81	bind env (List [(Symbol name), expr, body]) cc =
82	82	eval env expr (\value ->
83	83	eval (insert name value env) body cc)
84		bind env other cc = raise env $ errMsg "illegal-arguments" other
	84	bind env other cc = errMsg "illegal-arguments" other
85	85
86	86	robinLet :: Evaluable
87	87	robinLet env (List ((List bindings):body:_)) cc =

94	94	eval env sexpr (\value ->
95	95	bindAll rest (insert name value env) cc)
96	96	bindAll (other:rest) env cc =
97		raise env $ errMsg "illegal-binding" other
98		robinLet env other cc = raise env $ errMsg "illegal-arguments" other
	97	errMsg "illegal-binding" other
	98	robinLet env other cc = errMsg "illegal-arguments" other
99	99
100	100	robinBindArgs :: Evaluable
101	101	robinBindArgs env (List [(List formals), givenArgs, givenEnvExpr, body]) cc =

103	103	eval env givenEnvExpr (\outerEnvExpr ->
104	104	evalArgs formals actuals actuals outerEnvExpr (\argEnv ->
105	105	eval (mergeEnvs argEnv env) body cc)))
106		robinBindArgs env other cc = raise env $ errMsg "illegal-arguments" other
	106	robinBindArgs env other cc = errMsg "illegal-arguments" other
107	107
108	108	robinFun :: Evaluable
109	109	robinFun closedEnv (List [(List formals), body]) cc =

112	112	fun env (List actuals) cc =
113	113	evalArgs formals actuals actuals env (\argEnv ->
114	114	eval (mergeEnvs argEnv closedEnv) body cc)
115		robinFun env other cc = raise env $ errMsg "illegal-arguments" other
	115	robinFun env other cc = errMsg "illegal-arguments" other
116	116
117	117	--
118	118	-- `Arith`

137	137	robinAbs :: Evaluable
138	138	robinAbs env (List [expr]) cc =
139	139	eval env expr (\x -> assertNumber env x (\(Number xv) -> cc (Number $ abs xv)))
140		robinAbs env other cc = raise env (errMsg "illegal-arguments" other)
	140	robinAbs env other cc = errMsg "illegal-arguments" other
141	141
142	142	robinAdd :: Evaluable
143	143	robinAdd = evalTwoNumbers (\x y cc -> cc $ Number (x + y))

152	152	eval env yexpr (\y ->
153	153	assertNumber env y (\(Number yv) ->
154	154	case yv of
155		0 -> raise env $ errMsg "division-by-zero" $ Number xv
	155	0 -> errMsg "division-by-zero" $ Number xv
156	156	_ -> cc $ Number (xv `div` yv)))))
157		robinDivide env other cc = raise env $ errMsg "illegal-arguments" other
	157	robinDivide env other cc = errMsg "illegal-arguments" other
158	158
159	159	robinRemainder :: Evaluable
160	160	robinRemainder env (List [xexpr, yexpr]) cc =

163	163	eval env yexpr (\y ->
164	164	assertNumber env y (\(Number yv) ->
165	165	case yv of
166		0 -> raise env $ errMsg "division-by-zero" $ Number xv
	166	0 -> errMsg "division-by-zero" $ Number xv
167	167	_ -> cc $ Number (abs (xv `mod` yv))))))
168		robinRemainder env other cc = raise env $ errMsg "illegal-arguments" other
	168	robinRemainder env other cc = errMsg "illegal-arguments" other
169	169
170	170	--
171	171	-- Mapping of names to our functions, providing an evaluation environment.

-16

src/Language/Robin/Eval.hs less more

28	28	Just value ->
29	29	cc value
30	30	Nothing ->
31		raise env (errMsg "unbound-identifier" sym)
	31	errMsg "unbound-identifier" sym
32	32
33	33	--
34	34	-- Evaluating a list means we must make several evaluations. We

45	45	b@(Intrinsic _ fun) ->
46	46	fun env (List actuals) cc
47	47	other ->
48		raise env (errMsg "inapplicable-object" other))
	48	errMsg "inapplicable-object" other)
49	49
50	50	--
51	51	-- Everything else just evaluates to itself. Continue the current

60	60	--
61	61
62	62	errMsg msg term =
63		List [(Symbol msg), term]
	63	Error (List [(Symbol msg), term])
64	64
65	65	makeMacroEnv :: Env -> Expr -> Expr -> Env
66	66	makeMacroEnv env actuals m@(Macro closedEnv argList _) =

74	74	newEnv''
75	75
76	76	--
77		-- Exception Handler
78		--
79
80		raise :: Env -> Expr -> Expr
81		raise env expr =
82		case getExceptionHandler env of
83		Just (Intrinsic _ evaluable) ->
84		evaluable (empty) expr (\e -> e)
85		Nothing ->
86		error ("uncaught exception: " ++ show expr)
87
88		--
89	77	-- Assertions
90	78	--
91	79
92	80	assert env pred msg expr cc =
93	81	case pred expr of
94	82	True -> cc expr
95		False -> raise env (errMsg msg expr)
	83	False -> errMsg msg expr
96	84
97	85	assertSymbol env = assert env (isSymbol) "expected-symbol"
98	86	assertBoolean env = assert env (isBoolean) "expected-boolean"

-6

src/Language/Robin/Expr.hs less more

22	22	\| Macro Env Expr Expr
23	23	\| Intrinsic String Evaluable
24	24	\| List [Expr]
	25	\| Error Expr
25	26
26	27	instance Eq Expr where
27	28	(Symbol x) == (Symbol y) = x == y

30	31	(Macro _ _ _) == (Macro _ _ _) = False
31	32	(Intrinsic x _) == (Intrinsic y _) = x == y
32	33	(List x) == (List y) = x == y
	34	(Error x) == (Error y) = x == y
33	35	_ == _ = False
34	36
35	37	instance Show Expr where

40	42	show (Macro env args body) = ("(macro " ++ (show args) ++
41	43	" " ++ (show body) ++ ")")
42	44	show (Intrinsic name _) = name
	45	show (Error e) = "*ERR:" ++ (show e) ++ "*"
43	46	show (List exprs) = "(" ++ (showl exprs) ++ ")" where
44	47	showl [] = ""
45	48	showl [expr] = show expr

104	107	isMacro (Intrinsic _ _) = True
105	108	isMacro _ = False
106	109
107		--
108		-- Exceptions
109		--
110
111		getExceptionHandler env = find "(exception-handler)" env
112		setExceptionHandler handler env = insert "(exception-handler)" handler env
	110	isError (Error _) = True
	111	isError _ = False

+16

-27

src/Language/Robin/Intrinsics.hs less more

9	9	assertList env x (\val ->
10	10	case val of
11	11	List (a:_) -> cc a
12		other -> raise env $ errMsg "expected-list" other))
13		robinHead env other cc = raise env $ errMsg "illegal-arguments" other
	12	other -> errMsg "expected-list" other))
	13	robinHead env other cc = errMsg "illegal-arguments" other
14	14
15	15	robinTail :: Evaluable
16	16	robinTail env (List [expr]) cc =

18	18	assertList env x (\val ->
19	19	case val of
20	20	List (_:b) -> cc (List b)
21		other -> raise env $ errMsg "expected-list" other))
22		robinTail env other cc = raise env $ errMsg "illegal-arguments" other
	21	other -> errMsg "expected-list" other))
	22	robinTail env other cc = errMsg "illegal-arguments" other
23	23
24	24	robinPrepend :: Evaluable
25	25	robinPrepend env (List [e1, e2]) cc =
26	26	eval env e1 (\x1 -> eval env e2 (\val ->
27	27	case val of
28	28	List x2 -> cc $ List (x1:x2)
29		other -> raise env (errMsg "expected-list" other)))
30		robinPrepend env other cc = raise env $ errMsg "illegal-arguments" other
	29	other -> errMsg "expected-list" other))
	30	robinPrepend env other cc = errMsg "illegal-arguments" other
31	31
32	32	equalP :: Evaluable
33	33	equalP env (List [e1, e2]) cc =
34	34	eval env e1 (\x1 -> eval env e2 (\x2 -> cc $ Boolean (x1 == x2)))
35		equalP env other cc = raise env $ errMsg "illegal-arguments" other
	35	equalP env other cc = errMsg "illegal-arguments" other
36	36
37	37	predP pred env (List [expr]) cc =
38	38	eval env expr (\x -> cc $ Boolean $ pred x)
39		predP pred env other cc = raise env $ errMsg "illegal-arguments" other
	39	predP pred env other cc = errMsg "illegal-arguments" other
40	40
41	41	symbolP = predP isSymbol
42	42	listP = predP isList

50	50	eval env yexpr (\y ->
51	51	assertNumber env y (\(Number yv) ->
52	52	cc (Number (xv - yv))))))
53		robinSubtract env other cc = raise env $ errMsg "illegal-arguments" other
	53	robinSubtract env other cc = errMsg "illegal-arguments" other
54	54
55	55	robinSign :: Evaluable
56	56	robinSign env (List [expr]) cc =

59	59	cc $ Number $ sign xv))
60	60	where
61	61	sign x = if x == 0 then 0 else if x < 0 then -1 else 1
62		robinSign env other cc = raise env $ errMsg "illegal-arguments" other
	62	robinSign env other cc = errMsg "illegal-arguments" other
63	63
64	64	robinIf :: Evaluable
65	65	robinIf env (List [test, texpr, fexpr]) cc =

68	68	case b of
69	69	True -> eval env texpr cc
70	70	False -> eval env fexpr cc))
71		robinIf env other cc = raise env $ errMsg "illegal-arguments" other
	71	robinIf env other cc = errMsg "illegal-arguments" other
72	72
73	73	robinEval :: Evaluable
74	74	robinEval env (List [envlist, form]) cc =
75	75	eval env envlist (\newEnvVal ->
76	76	eval env form (\body ->
77	77	eval newEnvVal body cc))
78		robinEval env other cc = raise env $ errMsg "illegal-arguments" other
	78	robinEval env other cc = errMsg "illegal-arguments" other
79	79
80	80	robinMacro :: Evaluable
81	81	robinMacro env (List [args@(List [(Symbol selfS), (Symbol argsS), (Symbol envS)]), body]) k =
82	82	k $ Macro env args body
83		robinMacro env other cc = raise env $ errMsg "illegal-arguments" other
	83	robinMacro env other cc = errMsg "illegal-arguments" other
84	84
85	85	robinRaise :: Evaluable
86	86	robinRaise env (List [expr]) cc =
87		eval env expr (\v -> raise env v)
88		robinRaise env other cc = raise env $ errMsg "illegal-arguments" other
89
90		robinCatch :: Evaluable
91		robinCatch env (List [(Symbol s), handler, body]) cc =
92		let
93		exceptionHandler _ errvalue k =
94		eval (insert s errvalue env) handler cc
95		env' = setExceptionHandler (Intrinsic "(exception-handler)" exceptionHandler) env
96		in
97		eval env' body cc
98		robinCatch env other cc = raise env $ errMsg "illegal-arguments" other
	87	eval env expr (\v -> cc $ Error v)
	88	robinRaise env other cc = errMsg "illegal-arguments" other
99	89
100	90	robinIntrinsics :: Env
101	91	robinIntrinsics = fromList $ map (\(name,bif) -> (name, Intrinsic name bif))

113	103	("macro", robinMacro),
114	104	("eval", robinEval),
115	105	("if", robinIf),
116		("raise", robinRaise),
117		("catch", robinCatch)
	106	("raise", robinRaise)
118	107	]

-8

src/Language/Robin/TopLevel.hs less more

10	10
11	11	collect ((List [Symbol "display", expr]):rest) env reactors results =
12	12	let
13		catchException env expr k = List [(Symbol "uncaught-exception"), expr]
14		env' = setExceptionHandler (Intrinsic "(exception-handler)" catchException) env
15		result = case eval env' expr id of
	13	result = case eval env expr id of
16	14	(List [(Symbol "uncaught-exception"), expr]) -> Left expr
17	15	other -> Right other
18	16	in

54	52
55	53	collect ((List [Symbol "reactor", facExpr, stateExpr, bodyExpr]):rest) env reactors results =
56	54	let
57		catchException env expr k = List [(Symbol "uncaught-exception"), expr]
58		env' = setExceptionHandler (Intrinsic "(exception-handler)" catchException) env
59		state = eval env' stateExpr id
60		body = eval env' bodyExpr id
61		newReactor = Reactor{ rid=(fromIntegral $ length reactors), env=env', state=state, body=body }
	55	state = eval env stateExpr id
	56	body = eval env bodyExpr id
	57	newReactor = Reactor{ rid=(fromIntegral $ length reactors), env=env, state=state, body=body }
62	58	in
63	59	collect rest env (newReactor:reactors) results
64	60