Start extending runtime system for exceptions

include/cherry/primitives.h

+/*
+ * Cherry programming language
+ * Copyright (C) 2013 Christoph Mueller
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program.  If not, see <http://www.gnu.org/licenses/>.
+*/
+#pragma once
+
+#include "cherry/runtime.h"
+
+struct org_cherry_value*    org_cherry_primitive_println(struct org_cherry_environment* env, struct org_cherry_value* args);
+
+struct org_cherry_value*    org_cherry_primitive_exit(struct org_cherry_environment* env, struct org_cherry_value* args);
+

include/cherry/runtime.h

@@ -56,7 +56,7 @@ struct org_cherry_value {
 
 		const cy_byte_t* symbol_value;
 
-		struct org_cherry_value* (*fun_value)(struct org_cherry_value*); 
+		cy_primitive_t fun_value;
 	};
 };
 
@@ -101,18 +101,20 @@ struct org_cherry_pair {
 #define TAIL(pair) ((struct org_cherry_pair*) pair)->tail
 
 struct org_cherry_value*     org_cherry_list_cons(struct org_cherry_value* head, struct org_cherry_value* tail);
+struct org_cherry_value*	 org_cherry_list(struct org_cherry_value* val, ...);
+struct org_cherry_value*     org_cherry_list_reverse(struct org_cherry_value* value);
 
 struct org_cherry_procedure {
 	struct org_cherry_meta meta;
 
 	struct org_cherry_value* param;
 	struct org_cherry_value* body;
-	struct org_cherry_symbollist* env;
+	struct org_cherry_environment* env;
 };
 
 #define TO_PROC(obj) ((struct org_cherry_procedure*) obj)
 
-struct org_cherry_value*	org_cherry_procedure(struct org_cherry_symbollist* env,
+struct org_cherry_value*	org_cherry_procedure(struct org_cherry_environment* env,
 												 struct org_cherry_value* param,
 												 struct org_cherry_value* body);
 
@@ -125,10 +127,18 @@ struct org_cherry_symbollist;
 struct org_cherry_symbollist*	org_cherry_symbollist(void);
 struct org_cherry_value*		org_cherry_symbollist_get(struct org_cherry_symbollist* table, const cy_byte_t* name);
 
-struct org_cherry_symbollist*   org_cherry_env_push(struct org_cherry_symbollist* env);
-struct org_cherry_symbollist*   org_cherry_env_pop(struct org_cherry_symbollist* env);
-struct org_cherry_value*        org_cherry_env_lookup(struct org_cherry_symbollist* env, struct org_cherry_value* symbol);
-int                             org_cherry_env_add(struct org_cherry_symbollist* env, struct org_cherry_value* symbol, struct org_cherry_value* value);
+struct org_cherry_environment {
+  struct org_cherry_value* exception_stack;
+  struct org_cherry_symbollist* mapping;
+};
+
+struct org_cherry_environment*  org_cherry_env_push(struct org_cherry_environment* env);
+struct org_cherry_environment*  org_cherry_env_pop(struct org_cherry_environment* env);
+struct org_cherry_value*        org_cherry_env_lookup(struct org_cherry_environment* env, struct org_cherry_value* symbol);
+int                             org_cherry_env_add(struct org_cherry_environment* env, struct org_cherry_value* symbol, struct org_cherry_value* value);
+
+
+struct org_cherry_environment*  org_cherry_environment(void);
 
 extern struct org_cherry_symbollist*    org_cherry_global_symbollist;
 
@@ -140,6 +150,9 @@ extern struct org_cherry_value*         org_cherry_symbol_define;
 extern struct org_cherry_value*         org_cherry_symbol_lambda;
 extern struct org_cherry_value*         org_cherry_symbol_if;
 
+extern struct org_cherry_value*         org_cherry_symbol_begin;
+extern struct org_cherry_value*         org_cherry_symbol_catch;
+extern struct org_cherry_value*         org_cherry_symbol_finally;
 
 
 // ----------------------------------------------------------------------------
@@ -171,13 +184,22 @@ extern struct org_cherry_value*         org_cherry_symbol_if;
 #define IS_LAMBDA(value) \
   IS_TAGGED(value, org_cherry_symbol_lambda)
 
+#define IS_BEGIN(value) \
+  IS_TAGGED(value, org_cherry_symbol_begin)
+
+#define IS_CATCH(value) \
+  IS_TAGGED(value, org_cherry_symbol_catch)
+
+#define IS_FINALLY(value) \
+  IS_TAGGED(value, org_cherry_symbol_finally)
+
 #define IS_APPLICATION(value) \
   IS_PAIR(value)
 
 #define TEXT_OF_QUOTATION(value) \
 	HEAD(TAIL(value))
 
-struct org_cherry_value*    org_cherry_eval(struct org_cherry_symbollist* env, struct org_cherry_value* exp);
+struct org_cherry_value*    org_cherry_eval(struct org_cherry_environment* env, struct org_cherry_value* exp);
 
 
 

include/cherry/standard.h

@@ -19,6 +19,9 @@
 
 #include <stdint.h>
 
+struct org_cherry_environment;
+struct org_cherry_value;
+
 #define TRUE 1
 #define FALSE 0
 
@@ -37,3 +40,4 @@ typedef uint32_t    cy_unicode_t;
 
 typedef uint32_t    cy_flags_t;
 
+typedef struct org_cherry_value* (*cy_primitive_t)(struct org_cherry_environment* env, struct org_cherry_value* args);

source/CMakeLists.txt

@@ -4,7 +4,8 @@ set(CORE_SOURCES
   eval.c
   value.c
   unicode.c
-  tables.c)
+  tables.c
+  primitives/print.c)
 
 set(INTERPRETER_SOURCES
   cherry.c)

source/cherry.c

@@ -46,7 +46,7 @@ org_cherry_process_file(const char* filename, const cy_byte_t* method, struct or
 		exit(EXIT_FAILURE);
 	}
 
-	struct org_cherry_symbollist* env = org_cherry_symbollist();
+	struct org_cherry_environment* env = org_cherry_environment();
 	struct org_cherry_context* context = org_cherry_context(src, src, CY_SUPRESS_COMMENTS);
 	struct org_cherry_value* exp = org_cherry_read(context);
 
@@ -71,7 +71,7 @@ org_cherry_start_repl(void)
 {
 	printf("Cherry Interpreter 0.1\n\n");
 
-	struct org_cherry_symbollist* env = org_cherry_symbollist();
+	struct org_cherry_environment* env = org_cherry_environment();
 
 	while(1) {
 		cy_byte_t* line = (cy_byte_t*) readline("> ");
@@ -114,7 +114,6 @@ main(int argc, char** argv)
 				break;
 			case 'M':
 				method = optarg;
-				printf("%s\n", optarg);
 				break;
 			case '?':
 				print_usage(stderr, argv[0]);

source/eval.c

@@ -20,7 +20,7 @@
 #include <stdlib.h>
 
 static struct org_cherry_value*
-org_cherry_eval_define(struct org_cherry_symbollist* env, struct org_cherry_value* exp)
+org_cherry_eval_define(struct org_cherry_environment* env, struct org_cherry_value* exp)
 {
 	struct org_cherry_value* symbol;
 	struct org_cherry_value* value;
@@ -43,7 +43,7 @@ org_cherry_eval_define(struct org_cherry_symbollist* env, struct org_cherry_valu
 
 
 static struct org_cherry_value*
-org_cherry_eval_values(struct org_cherry_symbollist* env, struct org_cherry_value* values)
+org_cherry_eval_values(struct org_cherry_environment* env, struct org_cherry_value* values)
 {
 	struct org_cherry_value* list = org_cherry_emptylist;
 	struct org_cherry_value* val;
@@ -60,7 +60,7 @@ org_cherry_eval_values(struct org_cherry_symbollist* env, struct org_cherry_valu
 
 
 static struct org_cherry_value*
-org_cherry_eval_sequence(struct org_cherry_symbollist* env, struct org_cherry_value* body)
+org_cherry_eval_sequence(struct org_cherry_environment* env, struct org_cherry_value* body)
 {
 	struct org_cherry_value* val = org_cherry_false;
 
@@ -73,12 +73,12 @@ org_cherry_eval_sequence(struct org_cherry_symbollist* env, struct org_cherry_va
 }
 
 static struct org_cherry_value*
-org_cherry_apply(struct org_cherry_value* operator, struct org_cherry_value* operands)
+org_cherry_apply(struct org_cherry_environment* env, struct org_cherry_value* operator, struct org_cherry_value* operands)
 {
 	if(IS_PRIMITIVE(operator)) 
-		return operator->fun_value(operands);
+		return (operator->fun_value)(env, operands);
 	else if(IS_PROCEDURE(operator)) {
-		struct org_cherry_symbollist* env = TO_PROC(operator)->env;
+		struct org_cherry_environment* env = TO_PROC(operator)->env;
 
 		org_cherry_env_push(env);
 
@@ -103,7 +103,7 @@ org_cherry_apply(struct org_cherry_value* operator, struct org_cherry_value* ope
 
 
 static struct org_cherry_value*
-org_cherry_eval_if(struct org_cherry_symbollist* env, struct org_cherry_value* value)
+org_cherry_eval_if(struct org_cherry_environment* env, struct org_cherry_value* value)
 {
 	if(IS_NULL(value))
 		return org_cherry_false;
@@ -116,26 +116,39 @@ org_cherry_eval_if(struct org_cherry_symbollist* env, struct org_cherry_value* v
 		return org_cherry_false;
 }
 
+
+struct org_cherry_value*
+org_cherry_eval_begin(struct org_cherry_environment* env, struct org_cherry_value* value)
+{
+	return org_cherry_false;
+}
+
 struct org_cherry_value*
-org_cherry_eval(struct org_cherry_symbollist* env, struct org_cherry_value* value)
+org_cherry_eval(struct org_cherry_environment* env, struct org_cherry_value* value)
 {
 	if(IS_SELF_EVALUATING(value))
 		return value;
 	else if(IS_VARIABLE(value)) {
-		if(org_cherry_env_lookup(env, value))
-			return org_cherry_true;
-		else
-			return org_cherry_false;
+		struct org_cherry_value* v = org_cherry_env_lookup(env, value);
+
+		if(!v) {
+			fprintf(stderr, "ERROR value %s is not defined\n", value->symbol_value);
+			exit(EXIT_FAILURE);
+		}
+
+		return v;
 	} else if(IS_QUOTE(value)) 
 		return TEXT_OF_QUOTATION(value);
     else if(IS_DEFINE(value))
         return org_cherry_eval_define(env, value);
+	else if(IS_BEGIN(value))
+		return org_cherry_eval_begin(env, value);
 	else if(IS_LAMBDA(value))
 		return org_cherry_procedure(env, HEAD(TAIL(value)), TAIL(TAIL(value)));
 	else if(IS_IF(value))
 		return org_cherry_eval_if(env, TAIL(value));
 	else if(IS_APPLICATION(value))
-		return org_cherry_apply(org_cherry_eval(env, HEAD(value)), org_cherry_eval_values(env, TAIL(value)));
+		return org_cherry_apply(env, org_cherry_eval(env, HEAD(value)), org_cherry_eval_values(env, TAIL(value)));
 		
 	fprintf(stderr, "can not eval unknown expression\n");
 	exit(1);

source/exceptions.c

+/*
+ * Cherry programming language
+ * Copyright (C) 2013 Christoph Mueller
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program.  If not, see <http://www.gnu.org/licenses/>.
+*/
+
+#include <setjmp.h>
+
+struct org_cherry_exception {
+	jmp_buf jump;
+	cy_const_pointer_t data;
+};
+
+
+

source/primitives/print.c

+/*
+ * Cherry programming language
+ * Copyright (C) 2013 Christoph Mueller
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program.  If not, see <http://www.gnu.org/licenses/>.
+*/
+
+#include "cherry/runtime.h"
+#include <stdio.h>
+
+struct org_cherry_value*
+org_cherry_primitive_println(struct org_cherry_environment* env, struct org_cherry_value* args)
+{
+	while(!IS_NULL(args)) {
+		struct org_cherry_value* v = HEAD(args);
+		switch(v->meta.type) {
+			case CY_BOOLEAN:
+				if(IS_TRUE(v))
+					printf("true");
+				else
+					printf("false");
+				break;
+			case CY_STRING:
+				printf("%s", v->string_value);
+				break;
+			case CY_SYMBOL:
+				printf("%s", v->symbol_value);
+				break;
+			case CY_FIXNUM:
+				printf("%ld", v->fixnum_value);
+				break;
+			case CY_FLOAT:
+				printf("%lf", v->float_value);
+				break;
+			default:
+				break;
+		}
+
+		args = TAIL(args);
+	}
+	printf("\n");
+
+	return org_cherry_true;
+}

source/primitives/system.c

+/*
+ * Cherry programming language
+ * Copyright (C) 2013 Christoph Mueller
+ *
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program.  If not, see <http://www.gnu.org/licenses/>.
+*/
+
+#include "cherry/runtime.h"
+#include <stdlib.h>
+
+struct org_cherry_value*
+org_cherry_exit(struct org_cherry_environment* env, struct org_cherry_value* args)
+{
+	return org_cherry_false;
+}
+
+

source/read.c

@@ -688,47 +688,153 @@ org_cherry_read_pair(struct org_cherry_context* context)
 	return (struct org_cherry_value*) org_cherry_list_cons(head, tail);
 }
 
+enum BeginState {
+	CODE, EXCEPTION_VAR, EXCEPTION, FINALLY
+};
+
+static struct org_cherry_value*
+org_cherry_transform_begin(struct org_cherry_value* value)
+{
+	struct org_cherry_value* code = 
+		org_cherry_list_cons(org_cherry_emptylist,
+				org_cherry_list_cons(org_cherry_symbol_lambda, org_cherry_emptylist));
+	
+	struct org_cherry_value* handler = org_cherry_emptylist; 
+	struct org_cherry_value* finally = org_cherry_emptylist;
+
+	struct org_cherry_value* tmp = org_cherry_emptylist;
+
+	enum BeginState state = CODE;
+
+	while(!IS_NULL(value)) {
+		switch(state) {
+			case CODE:
+				if(IS_CATCH(HEAD(value))) {
+					state = EXCEPTION_VAR;
+					handler = org_cherry_list_cons(org_cherry_symbol_lambda, org_cherry_emptylist);
+					tmp = TAIL(HEAD(value));
+					continue;
+				} else
+					code = org_cherry_list_cons(HEAD(value), code);
+				break;
+
+			case EXCEPTION_VAR:
+				printf("::: ");
+				org_cherry_print(stdout, tmp);
+				printf("\n");
+
+				if(IS_PAIR(HEAD(tmp))) {
+					handler = org_cherry_list_cons(HEAD(tmp), handler);
+					state = EXCEPTION;
+					tmp = TAIL(tmp);
+					continue;
+				} else {
+					handler = org_cherry_list_cons(org_cherry_list(org_cherry_symbol("e"), org_cherry_emptylist), handler);
+					state = EXCEPTION;
+					continue;
+				}
+
+			case EXCEPTION:
+				while(!IS_NULL(tmp)) {
+					handler = org_cherry_list_cons(HEAD(tmp), handler);
+					tmp = TAIL(tmp);
+				}
+
+				if(IS_FINALLY(HEAD(value))) {
+					state = FINALLY;
+					tmp = TAIL(HEAD(value));
+					finally =  
+						org_cherry_list_cons(org_cherry_emptylist, 
+							org_cherry_list_cons(org_cherry_symbol_lambda, org_cherry_emptylist));
+					continue;
+				}
+				break;
+
+			case FINALLY:
+				while(!IS_NULL(tmp)) {
+					finally = org_cherry_list_cons(HEAD(tmp), finally);
+					tmp = TAIL(tmp);
+				}
+				break;
+		}
+
+		value = TAIL(value);
+	}
+
+	return 	org_cherry_list(
+			org_cherry_symbol_begin, 
+			org_cherry_list_reverse(code), 
+			org_cherry_list_reverse(handler),
+			org_cherry_list_reverse(finally));
+}
+
+
+static struct org_cherry_value* 
+org_cherry_transform(struct org_cherry_value* value)
+{
+	if(IS_BEGIN(value))
+		return org_cherry_transform_begin(TAIL(value));
+	else
+		return value;
+}
+
+
+
 struct org_cherry_value*
 org_cherry_read(struct org_cherry_context* context)
 {
 	assert(context != 0);
 
+	struct org_cherry_value* value = org_cherry_false;
+
 	enum org_cherry_tok tok = org_cherry_lex(context);
 
 	while(tok != TOK_EOF) {
 		switch(tok) {
-			case TOK_TRUE:
-				return org_cherry_true;
 			case TOK_FALSE:
 				return org_cherry_false;
+
+			case TOK_TRUE:
+				return org_cherry_true;
+
 			case TOK_HEX:
 				return org_cherry_fixnum_from_string(org_cherry_token_string(context), 16);
+
 			case TOK_DEC:
 				return org_cherry_fixnum_from_string(org_cherry_token_string(context), 10);
+
 			case TOK_OCT:
 				return org_cherry_fixnum_from_string(org_cherry_token_string(context), 8);
+
 			case TOK_BIN:
 				return org_cherry_fixnum_from_string(org_cherry_token_string(context), 2);
+
 			case TOK_FLOAT:
 				return org_cherry_float_from_string(org_cherry_token_string(context));
+
 			case TOK_STRING:
 				return org_cherry_string_from_string(org_cherry_token_string(context));
+
             case TOK_CHAR:
                 return org_cherry_char_from_string(org_cherry_token_string(context));
+
             case TOK_SYMBOL:
                 return org_cherry_symbol_from_string(org_cherry_token_string(context));
+
             case TOK_ROUNDLEFTBRACE:
-				return org_cherry_read_pair(context);
+				value = org_cherry_read_pair(context);
+				goto RETURN_VALUE;
+
 			case TOK_QUOTE:
-				return TO_VALUE(org_cherry_list_cons(org_cherry_symbol_quote, 
-                        TO_VALUE(org_cherry_list_cons(org_cherry_read(context), org_cherry_emptylist))));
+				return org_cherry_list_cons(org_cherry_symbol_quote, org_cherry_list_cons(org_cherry_read(context), org_cherry_emptylist));
 
 			default:
 				org_cherry_error(context, "bad input with token %s", 
 						org_cherry_tok_to_string(tok));
-				return org_cherry_false;
+				goto RETURN_VALUE;
 		}
 	}
 
-	return 0;
+RETURN_VALUE:
+	return org_cherry_transform(value);
 }

source/tables.c

@@ -306,29 +306,35 @@ org_cherry_symbollist_get(struct org_cherry_symbollist* tree, const cy_byte_t* n
 }
 
 
-struct org_cherry_symbollist*   
-org_cherry_env_push(struct org_cherry_symbollist* env)
+struct org_cherry_environment*   
+org_cherry_env_push(struct org_cherry_environment* env)
 {
     assert(env != 0);
 	struct org_cherry_symbollist* frame = org_cherry_symbollist();
-	frame->parent = env;
-    return frame;
+	frame->parent = env->mapping;
+	env->mapping = frame;
+
+    return env;
 }
 
-struct org_cherry_symbollist*   
-org_cherry_env_pop(struct org_cherry_symbollist* env)
+struct org_cherry_environment*   
+org_cherry_env_pop(struct org_cherry_environment* env)
 {
     assert(env != 0);
-	struct org_cherry_symbollist* frame = env->parent;
-	env->parent = 0;
-    return frame;
+	struct org_cherry_symbollist* frame = env->mapping->parent;
+	env->mapping->parent = 0;
+	env->mapping = frame;
+
+    return env;
 }
 
 struct org_cherry_value*        
-org_cherry_env_lookup(struct org_cherry_symbollist* env, struct org_cherry_value* symbol)
+org_cherry_env_lookup(struct org_cherry_environment* env, struct org_cherry_value* symbol)
 {
+	struct org_cherry_symbollist* mapping = env->mapping;
+
 	while(env != 0) {
-	    struct RbNode* node = env->root;
+	    struct RbNode* node = mapping->root;
 
 		while(node != 0) {
 			if(symbol < node->symbol)
@@ -339,7 +345,7 @@ org_cherry_env_lookup(struct org_cherry_symbollist* env, struct org_cherry_value
 				return node->value;
 		}
 
-		env = env->parent;
+		mapping = mapping->parent;
 	}
 
     return 0;
@@ -347,17 +353,19 @@ org_cherry_env_lookup(struct org_cherry_symbollist* env, struct org_cherry_value
 
 
 int                             
-org_cherry_env_add(struct org_cherry_symbollist* env, struct org_cherry_value* symbol, struct org_cherry_value* value)
+org_cherry_env_add(struct org_cherry_environment* env, struct org_cherry_value* symbol, struct org_cherry_value* value)
 {
 	assert(env != 0);
 	assert(symbol != 0);
 
-	if(env->root == 0) {
-		env->root = rbnode(BLACK, 0, symbol, value);
+	struct org_cherry_symbollist* mapping = env->mapping;
+
+	if(mapping->root == 0) {
+		mapping->root = rbnode(BLACK, 0, symbol, value);
 		return TRUE;
 	}
 
-	struct RbNode* node = env->root;
+	struct RbNode* node = mapping->root;
 	struct RbNode* current_node = 0;
 	
 	while(current_node == 0) {
@@ -375,7 +383,7 @@ org_cherry_env_add(struct org_cherry_symbollist* env, struct org_cherry_value* s
 			return FALSE;
 	}
 
-	rbnode_remedy_double_red(env, current_node);
+	rbnode_remedy_double_red(mapping, current_node);
 
     return TRUE;
 }

source/value.c

@@ -16,7 +16,8 @@
  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 */
 #include "cherry/runtime.h"
-