Commit add85075 authored by Chris Müller's avatar Chris Müller
Browse files

add symboltables for quotes and environment modelling

parent 0ffe0cee
......@@ -13,7 +13,6 @@ include_directories(crystal/include)
include_directories(include)
add_subdirectory(crystal)
add_subdirectory(runtime)
add_subdirectory(source)
add_subdirectory(test)
......@@ -38,12 +38,14 @@ typedef uint32_t cy_unicode_t;
enum org_cherry_value_type {
CY_EMPTYLIST,
CY_BOOLEAN,
CY_FIXNUM,
CY_FLOAT,
CY_STRING,
CY_CHAR,
CY_PAIR
CY_PAIR,
CY_SYMBOL
};
......@@ -64,9 +66,28 @@ struct org_cherry_value {
cy_byte_t* string_value;
cy_unicode_t char_value;
cy_byte_t* symbol_value;
};
};
#define IS_NULL(value) (value->meta.type == CY_EMPTYLIST);
#define IS_BOOLEAN(value) (value->meta.type == CY_BOOLEAN)
#define IS_FIXNUM(value) (value->meta.type == CY_FIXNUM)
#define IS_STRING(value) (value->meta.type == CY_STRING)
#define IS_SYMBOL(value) (value->meta.type == CY_SYMBOL)
#define IS_FLOAT(value) (value->meta.type == CY_FLOAT)
#define IS_CHAR(value) (value->meta.type == CY_CHAR)
#define IS_PAIR(value) (value->meta.type == CY_PAIR)
struct org_cherry_value* org_cherry_value_alloc(void);
struct org_cherry_value* org_cherry_symbol(cy_byte_t* symbol_value);
struct org_cherry_value* org_cherry_fixnum(cy_fixnum_t value);
struct org_cherry_value* org_cherry_float(cy_float_t float_value);
struct org_cherry_value* org_cherry_string(cy_byte_t* string_value);
struct org_cherry_value* org_cherry_char(cy_unicode_t char_value);
struct org_cherry_pair {
struct org_cherry_meta meta;
......@@ -75,20 +96,50 @@ struct org_cherry_pair {
struct org_cherry_value* tail;
};
struct org_cherry_value* __org_cherry_make_fixnum(cy_fixnum_t value);
struct org_cherry_value* __org_cherry_make_float(cy_float_t float_value);
struct org_cherry_value* __org_cherry_make_string(cy_byte_t* string_value);
struct org_cherry_value* __org_cherry_make_char(cy_unicode_t char_value);
#define HEAD(pair) pair->head
#define TAIL(pair) pair->tail
struct org_cherry_pair* org_cherry_list_cons(struct org_cherry_value* head, struct org_cherry_value* tail);
struct org_cherry_value* org_cherry_list_head(struct org_cherry_pair* pair);
struct org_cherry_value* org_cherry_list_tail(struct org_cherry_pair* pair);
struct org_cherry_value* org_cherry_list_length(struct org_cherry_pair* pair);
struct org_cherry_value* org_cherry_primitive_add(struct org_cherry_pair* pair);
// ----------------------------------------------------------------------------
// Symboltables
// ----------------------------------------------------------------------------
struct org_cherry_symboltable;
struct org_cherry_symboltable* org_cherry_symboltable(void);
struct org_cherry_value* org_cherry_symbollist_get(struct org_cherry_symboltable* table, cy_byte_t* name);
struct org_cherry_pair* __org_cherry_list_cons(struct org_cherry_value* head, struct org_cherry_value* tail);
extern struct org_cherry_symboltable* org_cherry_global_symboltable;
extern struct org_cherry_value* org_cherry_symbol_emptylist;
extern struct org_cherry_value* org_cherry_symbol_true;
extern struct org_cherry_value* org_cherry_symbol_false;
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_cond;
extern struct org_cherry_value* org_cherry_symbol_else;
struct org_cherry_value* __org_cherry_list_head(struct org_cherry_pair* pair);
struct org_cherry_value* __org_cherry_list_tail(struct org_cherry_pair* pair);
struct org_cherry_value* __org_cherry_list_length(struct org_cherry_pair* pair);
struct org_cherry_value* __org_cherry_primitive_add(struct org_cherry_pair* pair);
// ----------------------------------------------------------------------------
// Evaluation
// ----------------------------------------------------------------------------
#define IS_SELF_EVALUATING(value) \
(IS_BOOLEAN(value) || IS_FIXNUM(value) || IS_CHAR(value) || IS_STRING(value))
#define IS_VARIABLE(value) \
IS_SYMBOL(value)
// ----------------------------------------------------------------------------
// Default
// ----------------------------------------------------------------------------
void org_cherry_initialize(struct org_cherry_pair* arguments);
set(SOURCES
value.c)
add_library(cherry-runtime SHARED ${SOURCES})
target_link_libraries(cherry-runtime gc)
set(CORE_SOURCES
parser.c)
lexer.c
value.c
tables.c)
set(INTERPRETER_SOURCES
cherry.c)
......@@ -7,5 +9,5 @@ set(INTERPRETER_SOURCES
add_library(cherry-core ${CORE_SOURCES})
add_executable(cherry ${INTERPRETER_SOURCES})
target_link_libraries(cherry readline crystal cherry-core cherry-runtime)
target_link_libraries(cherry readline crystal cherry-core)
......@@ -15,7 +15,7 @@
* 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/parser.h"
#include "cherry/lexer.h"
#include <crystal/unicode.h>
#include <crystal/array.h>
......@@ -628,7 +628,7 @@ cy_token_string(struct CyContext* context)
{
assert(context->buffer != 0);
(byte_t*) cry_array_get(context->buffer, 0);
return (byte_t*) cry_array_get(context->buffer, 0);
}
......@@ -637,6 +637,6 @@ cy_token_length(struct CyContext* context)
{
assert(context->buffer != 0);
cry_array_size(context->buffer);
return cry_array_size(context->buffer);
}
/*
* 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 <gc.h>
#include <string.h>
enum RbNodeColor { RED, BLACK };
#define RB_PARENT(node) node->parent
#define RB_GRAND_PARENT(node) node->parent->parent
struct RbNode {
struct org_cherry_value* symbol;
struct org_cherry_value* value;
enum RbNodeColor color;
struct RbNode* parent;
struct RbNode* left;
struct RbNode* right;
};
struct org_cherry_symboltable {
struct RbNode* root;
struct org_cherry_symboltable* parent;
};
static struct RbNode*
rbnode(enum RbNodeColor color, struct RbNode* parent, struct org_cherry_value* symbol, struct org_cherry_value* value)
{
struct RbNode* node = GC_MALLOC(sizeof(struct RbNode));
node->color = color;
node->parent = parent;
node->symbol = symbol;
node->value = value;
node->left = 0;
node->right = 0;
return node;
}
static struct RbNode*
rbnode_rotate_left(struct RbNode* node)
{
assert(node != 0);
struct RbNode* parent = node->parent;
struct RbNode* right = node->right;
// switch right-node and its parent in a left-in-order rotation
node->right = right->left;
right->left = node;
// correct parent hierarchy
node->parent = right;
right->parent = parent;
if(node->right != 0)
node->right->parent = node;
if(parent != 0 && parent->left == node)
parent->left = right;
else if(parent != 0 && parent->right == node)
parent->right = right;
// return new sub_root
return right;
}
static struct RbNode*
rbnode_rotate_right(struct RbNode* node)
{
assert(node != 0);
struct RbNode* parent = node->parent;
struct RbNode* left = node->left;
// switch left-node and its parent in a right-in-order rotation
node->left = left->right;
left->right = node;
// correct parent hierarchy
node->parent = left;
left->parent = parent;
if(node->left != 0)
node->left->parent = node;
if(parent != 0 && parent->left == node)
parent->left = left;
else if(parent != 0 && parent->right == node)
parent->right = left;
// return new sub_root
return left;
}
static struct RbNode*
rbnode_trinode_restructering(struct RbNode* node)
{
assert(node != 0);
struct RbNode* root = RB_GRAND_PARENT(node);
if(root->left == RB_PARENT(node)) {
if(RB_PARENT(node)->left == node)
root = rbnode_rotate_right(root);
else {
lq_rbnode_rotate_left(RB_PARENT(node));
root = rbnode_rotate_right(root);
}
} else {
if(RB_PARENT(node)->right == node)
root = rbnode_rotate_left(root);
else {
lq_rbnode_rotate_right(RB_PARENT(node));
root = rbnode_rotate_left(root);
}
}
return root;
}
static void
rbnode_remedy_double_red(struct org_cherry_symboltable* tree, struct RbNode* node_z)
{
assert(tree != 0 && node_z != 0);
if(tree->root == RB_PARENT(node_z))
return;
else if(RB_PARENT(node_z)->color == BLACK)
return;
if(RB_GRAND_PARENT(node_z)->left == 0 || RB_GRAND_PARENT(node_z)->right == 0 || RB_GRAND_PARENT(node_z)->left->color == BLACK || RB_GRAND_PARENT(node_z)->right->color == BLACK) {
// trinode restructering with single/multiple left- and right rotations
struct RbNode* node_v = rbnode_trinode_restructering(node_z);
node_v->color = BLACK;
node_v->left->color = RED;
node_v->right->color = RED;
while(node_v->parent != 0)
node_v = node_v->parent;
tree->root = node_v;
} else {
// recoloring of nodes
RB_GRAND_PARENT(node_z)->left->color = BLACK;
RB_GRAND_PARENT(node_z)->right->color = BLACK;
if(RB_GRAND_PARENT(node_z)->parent == 0)
return;
RB_GRAND_PARENT(node_z)->color = RED;
rbnode_remedy_double_red(tree, RB_GRAND_PARENT(node_z));
}
}
static void
rbnode_remedey_double_black(struct org_cherry_symboltable* tree, struct RbNode* node_x, struct RbNode* node_r)
{
assert(node_x != 0);
struct RbNode* sibling = (node_x->left == node_r) ? node_x->right : node_x->left;
struct RbNode* child = 0;
if(sibling == 0)
return;
enum RbNodeColor parent_color = node_x->color;
if(sibling->color == BLACK) {
// get red child of siblings if available
if(sibling->left != 0 && sibling->left->color == RED)
child = sibling->left;
else if(sibling->right != 0 && sibling->right->color == RED)
child = sibling->right;
if(child != 0) {
// Case 1: Restructering of siblings red child
child = rbnode_trinode_restructering(child);
child->color = parent_color;
if(node_r != 0)
node_r->color = BLACK;
child->left->color = BLACK;
child->right->color = BLACK;
while(child->parent != 0)
child = child->parent;
tree->root = child;
} else {
// Case 2: Both siblings childs are black => Recoloring
if(node_r != 0)
node_r->color = BLACK;
sibling->color = RED;
if(node_x->color == RED)
node_x->color = BLACK;
else if(node_x->parent != 0) {
rbnode_remedy_double_black(tree, RB_PARENT(node_x), node_x);
}
}
} else {
// Case 3: Sibling is red => Adjustment needed
if(node_x->right == sibling)
child = sibling->right;
else
child = sibling->left;
if(child != 0) {
child = rbnode_trinode_restructering(child);
sibling->color = BLACK;
node_x->color = RED;
while(child->parent != 0)
child = child->parent;
tree->root = child;
rbnode_remedy_double_black(tree, node_x, node_r);
}
}
}
struct org_cherry_symboltable*
org_cherry_symboltable(void)
{
struct org_cherry_symboltable* s = GC_MALLOC(sizeof(struct org_cherry_symboltable));
s->root = 0;
s->parent = 0;
return s;
}
static struct org_cherry_value*
alloc_symbol(cy_byte_t* name)
{
struct org_cherry_value* symbol = org_cherry_value_alloc();
size_t name_size = strlen(name) + 1;
cy_byte_t* str = GC_MALLOC(name_size);
memcpy(str, name, name_size);
symbol->meta.type = CY_SYMBOL;
symbol->symbol_value = str;
return symbol;
}
static int
string_compare(cy_byte_t* A, cy_byte_t* B)
{
register const cy_byte_t* s1 = A;
register const cy_byte_t* s2 = B;
register cy_byte_t c1, c2;
do {
c1 = *s1++;
c2 = *s2++;
if(c1 == '\0')
return c1 - c2;
} while(c1 == c2);
return c1 - c2;
}
struct org_cherry_value*
org_cherry_symbollist_get(struct org_cherry_symboltable* tree, cy_byte_t* name)
{
assert(tree != 0 && name != 0);
struct RbNode* node = tree->root;
struct RbNode* current_node = 0;
if(node == 0) {
struct org_cherry_value* symbol = alloc_symbol(name);
tree->root = rbnode(BLACK, 0, symbol, 0);
return symbol;
}
while(current_node == 0) {
int result = string_compare(name, node->symbol->symbol_value);
if(result < 0) {
if(node->left == 0)
current_node = node->left = rbnode(RED, node, alloc_symbol(name), 0);
else
node = node->left;
} else if(result > 0) {
if(node->right == 0)
current_node = node->right = rbnode(RED, node, alloc_symbol(name), 0);
else
node = node->right;
} else {
return node->symbol;
}
rbnode_remedy_double_red(tree, current_node);
return current_node->symbol;
}
}
......@@ -17,16 +17,42 @@
*/
#include "cherry/runtime.h"
#include <stdio.h>
#include <stdlib.h>
#include <gc.h>
// ----------------------------------------------------------------------------
// globals
// ----------------------------------------------------------------------------
struct org_cherry_symboltable* org_cherry_global_symboltable;
struct org_cherry_value* org_cherry_symbol_emptylist;
struct org_cherry_value* org_cherry_symbol_true;
struct org_cherry_value* org_cherry_symbol_false;
// ----------------------------------------------------------------------------
// cherry object constructors
// ----------------------------------------------------------------------------
struct org_cherry_value*
org_cherry_value_alloc(void)
{
struct org_cherry_value* value = GC_MALLOC(sizeof(struct org_cherry_value));
if(value == 0) {
fprintf(stderr, "GC: out of memory");
exit(1);
}
return value;
}
struct org_cherry_value*
__org_cherry_make_fixnum(cy_fixnum_t value)
org_cherry_fixnum(cy_fixnum_t value)
{
struct org_cherry_value* cy_value = GC_MALLOC(sizeof(struct org_cherry_value));
struct org_cherry_value* cy_value = org_cherry_value_alloc();
cy_value->meta.type = CY_FIXNUM;
cy_value->fixnum_value = value;
return cy_value;
......@@ -34,9 +60,9 @@ __org_cherry_make_fixnum(cy_fixnum_t value)
struct org_cherry_value*
__org_cherry_make_float(cy_float_t value)
org_cherry_float(cy_float_t value)
{
struct org_cherry_value* cy_value = GC_MALLOC(sizeof(struct org_cherry_value));
struct org_cherry_value* cy_value = org_cherry_value_alloc();
cy_value->meta.type = CY_FLOAT;
cy_value->float_value = value;
return cy_value;
......@@ -44,9 +70,9 @@ __org_cherry_make_float(cy_float_t value)
struct org_cherry_value*
__org_cherry_make_string(cy_byte_t* value)
org_cherry_string(cy_byte_t* value)
{
struct org_cherry_value* cy_value = GC_MALLOC(sizeof(struct org_cherry_value));
struct org_cherry_value* cy_value = org_cherry_value_alloc();
cy_value->meta.type = CY_STRING;
cy_value->string_value = value;
return cy_value;
......@@ -54,20 +80,26 @@ __org_cherry_make_string(cy_byte_t* value)
struct org_cherry_value*
__org_cherry_make_char(cy_unicode_t value)
org_cherry_char(cy_unicode_t value)
{
struct org_cherry_value* cy_value = GC_MALLOC(sizeof(struct org_cherry_value));
struct org_cherry_value* cy_value = org_cherry_value_alloc();
cy_value->meta.type = CY_CHAR;
cy_value->char_value = value;
return cy_value;
}
struct org_cherry_value*
org_cherry_symbol(cy_byte_t* value)
{
return org_cherry_symbollist_get(org_cherry_global_symboltable, value);
}
// ----------------------------------------------------------------------------
// cherry list operations
// ----------------------------------------------------------------------------
struct org_cherry_pair*
__org_cherry_list_cons(struct org_cherry_value* head, struct org_cherry_value* tail)
org_cherry_list_cons(struct org_cherry_value* head, struct org_cherry_value* tail)
{
struct org_cherry_pair* pair = GC_MALLOC(sizeof(struct org_cherry_pair));
pair->meta.type = CY_PAIR;
......@@ -77,19 +109,19 @@ __org_cherry_list_cons(struct org_cherry_value* head, struct org_cherry_value* t
}
struct org_cherry_value*
__org_cherry_list_head(struct org_cherry_pair* pair)
org_cherry_list_head(struct org_cherry_pair* pair)
{
return pair->head;
}
struct org_cherry_value*
__org_cherry_list_tail(struct org_cherry_pair* pair)
org_cherry_list_tail(struct org_cherry_pair* pair)
{
return pair->tail;
}
struct org_cherry_value*
__org_cherry_list_length(struct org_cherry_pair* pair)
org_cherry_list_length(struct org_cherry_pair* pair)
{
cy_fixnum_t length = 0;
......@@ -98,11 +130,11 @@ __org_cherry_list_length(struct org_cherry_pair* pair)
pair = (struct org_cherry_pair*) pair->tail;
}
return __org_cherry_make_fixnum(length);
return org_cherry_fixnum(length);
}
struct org_cherry_value*
__org_cherry_primitive_add(struct org_cherry_pair* pair)
org_cherry_primitive_add(struct org_cherry_pair* pair)
{
cy_fixnum_t result = 0;
......@@ -111,7 +143,29 @@ __org_cherry_primitive_add(struct org_cherry_pair* pair)
pair = (struct org_cherry_pair*) pair->tail;
}
return __org_cherry_make_fixnum(result);
return org_cherry_fixnum(result);
}