felix/slime
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Work transfer

Browse Source
This commit is contained in:
Felix Brendel
2020-02-18 10:52:05 +01:00
parent 7aa492df67
commit 7c220ed9d6
72 changed files with 19257 additions and 19094 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/assert.hpp
+57 -54
View File
@@ -1,54 +1,57 @@
/**
Usage of the create_error_macros:
*/
#define __create_error(keyword, ...) \
create_error( \
__FUNCTION__, __FILE__, __LINE__, \
Memory::get_keyword(keyword), \
__VA_ARGS__)
#define create_out_of_memory_error(...) \
__create_error("out-of-memory", __VA_ARGS__)
#define create_generic_error(...) \
__create_error("generic", __VA_ARGS__)
#define create_not_yet_implemented_error() \
__create_error("not-yet-implemented", "This feature has not yet been implemented.")
#define create_parsing_error(...) \
__create_error("parsing-error", __VA_ARGS__)
#define create_symbol_undefined_error(...) \
__create_error("symbol-undefined", __VA_ARGS__)
#define create_type_missmatch_error(expected, actual) \
__create_error("type-missmatch", \
"Type missmatch: expected %s, got %s", \
expected, actual)
#ifdef _DEBUG
#define assert_type(_node, _type) \
do { \
if (Memory::get_type(_node) != _type) { \
create_type_missmatch_error( \
Lisp_Object_Type_to_string(_type), \
Lisp_Object_Type_to_string(Memory::get_type(_node))); \
} \
} while(0)
#define assert(condition) \
do { \
if (!(condition)) { \
create_generic_error("Assertion-error."); \
} \
} while(0)
#else
# define assert_arguments_length(expected, actual) do {} while (0)
# define assert_arguments_length_less_equal(expected, actual) do {} while (0)
# define assert_arguments_length_greater_equal(expected, actual) do {} while (0)
# define assert_type(_node, _type) do {} while (0)
# define assert(condition) do {} while (0)
#endif
/**
Usage of the create_error_macros:
*/
#define __create_error(keyword, ...) \
create_error( \
__FUNCTION__, __FILE__, __LINE__, \
Memory::get_keyword(keyword), \
__VA_ARGS__)
#define create_out_of_memory_error(...) \
__create_error("out-of-memory", __VA_ARGS__)
#define create_generic_error(...) \
__create_error("generic", __VA_ARGS__)
#define create_not_yet_implemented_error() \
__create_error("not-yet-implemented", "This feature has not yet been implemented.")
#define create_parsing_error(...) \
__create_error("parsing-error", __VA_ARGS__)
#define create_symbol_undefined_error(...) \
__create_error("symbol-undefined", __VA_ARGS__)
#define create_type_missmatch_error(expected, actual, exp) \
__create_error("type-missmatch", \
"Type missmatch: expected %s, got %s in %s", \
expected, actual, exp)
#ifdef _DEBUG
#define assert_type(_node, _type) \
do { \
if (Memory::get_type(_node) != _type) { \
char* t = lisp_object_to_string(_node); \
defer { free(t); }; \
create_type_missmatch_error( \
Lisp_Object_Type_to_string(_type), \
Lisp_Object_Type_to_string(Memory::get_type(_node)), \
t); \
} \
} while(0)
#define assert(condition) \
do { \
if (!(condition)) { \
create_generic_error("Assertion-error."); \
} \
} while(0)
#else
# define assert_arguments_length(expected, actual) do {} while (0)
# define assert_arguments_length_less_equal(expected, actual) do {} while (0)
# define assert_arguments_length_greater_equal(expected, actual) do {} while (0)
# define assert_type(_node, _type) do {} while (0)
# define assert(condition) do {} while (0)
#endif
src/built_ins.cpp
+1203 -1144
View File
File diff suppressed because it is too large Load Diff
src/define_macros.hpp
+156 -156
View File
@@ -1,156 +1,156 @@
#define concat_( a, b) a##b
#define label(prefix, lnum) concat_(prefix,lnum)
#define log_location() \
do { \
if (Globals::log_level == Log_Level::Debug) { \
printf("in"); \
int spacing = 30-((int)strlen(__FILE__) + (int)log10(__LINE__));\
if (spacing < 1) spacing = 1; \
for (int i = 0; i < spacing;++i) \
printf(" "); \
printf("%s (%d) ", __FILE__, __LINE__); \
printf("-> %s\n",__FUNCTION__); \
} \
} while(0)
#define if_error_log_location_and_return(val) \
do { \
if (Globals::error) { \
log_location(); \
return val; \
} \
} while(0)
#ifdef _DEBUG
#define try_or_else_return(val) \
if (1) \
goto label(body,__LINE__); \
else \
while (1) \
if (1) { \
if (Globals::error) { \
log_location(); \
return val; \
} \
break; \
} \
else label(body,__LINE__):
;
#else
#define try_or_else_return(val)
#endif
#define try_struct try_or_else_return({})
#define try_void try_or_else_return()
#define try try_or_else_return(0)
#define dont_break_on_errors fluid_let(Globals::breaking_on_errors, false)
#define ignore_logging fluid_let(Globals::log_level, Log_Level::None)
#define fetch1(var) \
Lisp_Object* var##_symbol = Memory::get_symbol(#var); \
Lisp_Object* var = lookup_symbol(var##_symbol, get_current_environment()); \
if_error_log_location_and_return(nullptr)
#define fetch2(var1, var2) fetch1(var1); fetch1(var2)
#define fetch3(var1, var2, var3) fetch2(var1, var2); fetch1(var3)
#define fetch4(var1, var2, var3, var4) fetch3(var1, var2, var3); fetch1(var4)
#define fetch5(var1, var2, var3, var4, var5) fetch4(var1, var2, var3, var4); fetch1(var5)
#define fetch6(var1, var2, var3, var4, var5, var6) fetch5(var1, var2, var3, var4, var5); fetch1(var6)
#define fetch7(var1, var2, var3, var4, var5, var6, var7) fetch6(var1, var2, var3, var4, var5, var6); fetch1(var7)
#define fetch8(var1, var2, var3, var4, var5, var6, var7, var8) fetch7(var1, var2, var3, var4, var5, var6, var7); fetch1(var8)
#define fetch9(var1, var2, var3, var4, var5, var6, var7, var8, var9) fetch8(var1, var2, var3, var4, var5, var6, var7, var8); fetch1(var9)
#define fetch10(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10) fetch9(var1, var2, var3, var4, var5, var6, var7, var8, var9); fetch1(var10)
#define fetch11(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11) fetch10(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10); fetch1(var11)
#define fetch12(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12) fetch11(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11); fetch1(var12)
#define fetch13(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13) fetch12(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12); fetch1(var13)
#define fetch14(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14) fetch13(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13); fetch1(var14)
#define fetch15(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15) fetch14(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14); fetch1(var15)
#define fetch16(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16) fetch15(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15); fetch1(var16)
#define fetch17(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17) fetch16(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16); fetch1(var17)
#define fetch18(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18) fetch17(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17); fetch1(var18)
#define fetch19(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19) fetch18(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18); fetch1(var19)
#define fetch20(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20) fetch19(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19); fetch1(var20)
#define fetch21(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21) fetch20(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20); fetch1(var21)
#define fetch22(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22) fetch21(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21); fetch1(var22)
#define fetch23(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23) fetch22(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22); fetch1(var23)
#define fetch24(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23, var24) fetch23(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23); fetch1(var24)
#define GET_MACRO( \
_1, _2, _3, _4, _5, _6, \
_7, _8, _9, _10, _11, _12, \
_13, _14, _15, _16, _17, _18, \
_19, _20, _21, _22, _23, _24, \
NAME, ...) NAME
#ifdef _MSC_VER
#define EXPAND( x ) x
#define fetch(...) EXPAND( \
GET_MACRO( \
__VA_ARGS__, \
fetch24, fetch23, fetch22, fetch21, fetch20, fetch19, \
fetch18, fetch17, fetch16, fetch15, fetch14, fetch13, \
fetch12, fetch11, fetch10, fetch9, fetch8, fetch7, \
fetch6, fetch5, fetch4, fetch3, fetch2, fetch1 \
)(__VA_ARGS__))
#else
#define fetch(...) \
GET_MACRO( \
__VA_ARGS__, \
fetch24, fetch23, fetch22, fetch21, fetch20, fetch19, \
fetch18, fetch17, fetch16, fetch15, fetch14, fetch13, \
fetch12, fetch11, fetch10, fetch9, fetch8, fetch7, \
fetch6, fetch5, fetch4, fetch3, fetch2, fetch1 \
)(__VA_ARGS__)
#endif
// NOTE(Felix): we have to copy the string because we need it to be
// mutable for the parser to work, because the parser relys on being
// able to temporaily put in markers in the code and also it will fill
// out the source code location
#define _define_helper(def, docs, type, ending) \
Parser::parser_file = file_name_built_ins; \
Parser::parser_line = __LINE__; \
Parser::parser_col = 0; \
auto label(params,__LINE__) = Parser::parse_single_expression( \
Memory::get_c_str(Memory::create_string(#def))); \
if_error_log_location_and_return(nullptr); \
assert_type(label(params,__LINE__), Lisp_Object_Type::Pair); \
assert_type(label(params,__LINE__)->value.pair.first, Lisp_Object_Type::Symbol); \
auto label(sym,__LINE__) = label(params,__LINE__)->value.pair.first; \
auto label(sfun,__LINE__) = Memory::create_lisp_object_cfunction(type); \
create_arguments_from_lambda_list_and_inject(label(params,__LINE__)->value.pair.rest, label(sfun,__LINE__)); \
if_error_log_location_and_return(nullptr); \
label(sfun,__LINE__)->docstring = Memory::create_string(docs); \
label(sfun,__LINE__)->value.function->parent_environment = get_current_environment(); \
define_symbol(label(sym,__LINE__), label(sfun,__LINE__)); \
label(sfun,__LINE__)->value.function->body. ending
#define define(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cFunction, c_body = []() -> Lisp_Object*)
#define define_special(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cSpecial, c_body = []() -> Lisp_Object*)
#define define_macro(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cMacro, c_macro_body = []() -> void)
#define in_caller_env fluid_let( \
Globals::Current_Execution::envi_stack.next_index, \
Globals::Current_Execution::envi_stack.next_index-1)
/*
* iterate over lisp vectors
*/
#define for_lisp_vector(v) \
if (!v); else \
if (int it_index = 0); else \
for (auto it = v->value.vector.data; \
it_index < v->value.vector.length; \
it=v->value.vector.data+(++it_index))
/*
* iterate over lisp lists
*/
#define for_lisp_list(l) \
if (!l); else \
if (int it_index = 0); else \
for (Lisp_Object* head = l, *it; \
Memory::get_type(head) == Lisp_Object_Type::Pair && (it = head->value.pair.first); \
head = head->value.pair.rest, ++it_index)
#define concat_( a, b) a##b
#define label(prefix, lnum) concat_(prefix,lnum)
#define log_location() \
do { \
if (Globals::log_level == Log_Level::Debug) { \
printf("in"); \
int spacing = 30-((int)strlen(__FILE__) + (int)log10(__LINE__));\
if (spacing < 1) spacing = 1; \
for (int i = 0; i < spacing;++i) \
printf(" "); \
printf("%s (%d) ", __FILE__, __LINE__); \
printf("-> %s\n",__FUNCTION__); \
} \
} while(0)
#define if_error_log_location_and_return(val) \
do { \
if (Globals::error) { \
log_location(); \
return val; \
} \
} while(0)
#ifdef _DEBUG
#define try_or_else_return(val) \
if (1) \
goto label(body,__LINE__); \
else \
while (1) \
if (1) { \
if (Globals::error) { \
log_location(); \
return val; \
} \
break; \
} \
else label(body,__LINE__):
;
#else
#define try_or_else_return(val)
#endif
#define try_struct try_or_else_return({})
#define try_void try_or_else_return()
#define try try_or_else_return(0)
#define dont_break_on_errors fluid_let(Globals::breaking_on_errors, false)
#define ignore_logging fluid_let(Globals::log_level, Log_Level::None)
#define fetch1(var) \
Lisp_Object* var##_symbol = Memory::get_symbol(#var); \
Lisp_Object* var = lookup_symbol(var##_symbol, get_current_environment()); \
if_error_log_location_and_return(nullptr)
#define fetch2(var1, var2) fetch1(var1); fetch1(var2)
#define fetch3(var1, var2, var3) fetch2(var1, var2); fetch1(var3)
#define fetch4(var1, var2, var3, var4) fetch3(var1, var2, var3); fetch1(var4)
#define fetch5(var1, var2, var3, var4, var5) fetch4(var1, var2, var3, var4); fetch1(var5)
#define fetch6(var1, var2, var3, var4, var5, var6) fetch5(var1, var2, var3, var4, var5); fetch1(var6)
#define fetch7(var1, var2, var3, var4, var5, var6, var7) fetch6(var1, var2, var3, var4, var5, var6); fetch1(var7)
#define fetch8(var1, var2, var3, var4, var5, var6, var7, var8) fetch7(var1, var2, var3, var4, var5, var6, var7); fetch1(var8)
#define fetch9(var1, var2, var3, var4, var5, var6, var7, var8, var9) fetch8(var1, var2, var3, var4, var5, var6, var7, var8); fetch1(var9)
#define fetch10(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10) fetch9(var1, var2, var3, var4, var5, var6, var7, var8, var9); fetch1(var10)
#define fetch11(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11) fetch10(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10); fetch1(var11)
#define fetch12(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12) fetch11(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11); fetch1(var12)
#define fetch13(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13) fetch12(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12); fetch1(var13)
#define fetch14(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14) fetch13(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13); fetch1(var14)
#define fetch15(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15) fetch14(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14); fetch1(var15)
#define fetch16(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16) fetch15(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15); fetch1(var16)
#define fetch17(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17) fetch16(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16); fetch1(var17)
#define fetch18(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18) fetch17(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17); fetch1(var18)
#define fetch19(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19) fetch18(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18); fetch1(var19)
#define fetch20(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20) fetch19(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19); fetch1(var20)
#define fetch21(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21) fetch20(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20); fetch1(var21)
#define fetch22(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22) fetch21(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21); fetch1(var22)
#define fetch23(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23) fetch22(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22); fetch1(var23)
#define fetch24(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23, var24) fetch23(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23); fetch1(var24)
#define GET_MACRO( \
_1, _2, _3, _4, _5, _6, \
_7, _8, _9, _10, _11, _12, \
_13, _14, _15, _16, _17, _18, \
_19, _20, _21, _22, _23, _24, \
NAME, ...) NAME
#ifdef _MSC_VER
#define EXPAND( x ) x
#define fetch(...) EXPAND( \
GET_MACRO( \
__VA_ARGS__, \
fetch24, fetch23, fetch22, fetch21, fetch20, fetch19, \
fetch18, fetch17, fetch16, fetch15, fetch14, fetch13, \
fetch12, fetch11, fetch10, fetch9, fetch8, fetch7, \
fetch6, fetch5, fetch4, fetch3, fetch2, fetch1 \
)(__VA_ARGS__))
#else
#define fetch(...) \
GET_MACRO( \
__VA_ARGS__, \
fetch24, fetch23, fetch22, fetch21, fetch20, fetch19, \
fetch18, fetch17, fetch16, fetch15, fetch14, fetch13, \
fetch12, fetch11, fetch10, fetch9, fetch8, fetch7, \
fetch6, fetch5, fetch4, fetch3, fetch2, fetch1 \
)(__VA_ARGS__)
#endif
// NOTE(Felix): we have to copy the string because we need it to be
// mutable for the parser to work, because the parser relys on being
// able to temporaily put in markers in the code and also it will fill
// out the source code location
#define _define_helper(def, docs, type, ending) \
Parser::parser_file = file_name_built_ins; \
Parser::parser_line = __LINE__; \
Parser::parser_col = 0; \
auto label(params,__LINE__) = Parser::parse_single_expression( \
Memory::get_c_str(Memory::create_string(#def))); \
if_error_log_location_and_return(nullptr); \
assert_type(label(params,__LINE__), Lisp_Object_Type::Pair); \
assert_type(label(params,__LINE__)->value.pair.first, Lisp_Object_Type::Symbol); \
auto label(sym,__LINE__) = label(params,__LINE__)->value.pair.first; \
auto label(sfun,__LINE__) = Memory::create_lisp_object_cfunction(type); \
create_arguments_from_lambda_list_and_inject(label(params,__LINE__)->value.pair.rest, label(sfun,__LINE__)); \
if_error_log_location_and_return(nullptr); \
label(sfun,__LINE__)->docstring = Memory::create_string(docs); \
label(sfun,__LINE__)->value.function->parent_environment = get_current_environment(); \
define_symbol(label(sym,__LINE__), label(sfun,__LINE__)); \
label(sfun,__LINE__)->value.function->body. ending
#define define(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cFunction, c_body = []() -> Lisp_Object*)
#define define_special(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cSpecial, c_body = []() -> Lisp_Object*)
#define define_macro(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cMacro, c_macro_body = []() -> void)
#define in_caller_env fluid_let( \
Globals::Current_Execution::envi_stack.next_index, \
Globals::Current_Execution::envi_stack.next_index-1)
/*
* iterate over lisp vectors
*/
#define for_lisp_vector(v) \
if (!v); else \
if (int it_index = 0); else \
for (auto it = v->value.vector.data; \
it_index < v->value.vector.length; \
it=v->value.vector.data+(++it_index))
/*
* iterate over lisp lists
*/
#define for_lisp_list(l) \
if (!l); else \
if (int it_index = 0); else \
for (Lisp_Object* head = l, *it; \
Memory::get_type(head) == Lisp_Object_Type::Pair && (it = head->value.pair.first); \
head = head->value.pair.rest, ++it_index)
src/defines.cpp
+23 -23
View File
@@ -1,23 +1,23 @@
#define proc auto
#ifdef _DEBUG
# define if_debug if constexpr (true)
#else
# define if_debug if constexpr (false)
#endif
#ifdef _MSC_VER
# define debug_break() if_debug __debugbreak()
# define if_windows if constexpr (true)
# define if_linux if constexpr (false)
#else
# define debug_break() if_debug raise(SIGTRAP)
# define if_windows if constexpr (false)
# define if_linux if constexpr (true)
#endif
#define console_normal "\x1B[0m"
#define console_red "\x1B[31m"
#define console_green "\x1B[32m"
#define console_cyan "\x1B[36m"
#define proc auto
#ifdef _DEBUG
# define if_debug if constexpr (true)
#else
# define if_debug if constexpr (false)
#endif
#ifdef _MSC_VER
# define debug_break() if_debug __debugbreak()
# define if_windows if constexpr (true)
# define if_linux if constexpr (false)
#else
# define debug_break() if_debug raise(SIGTRAP)
# define if_windows if constexpr (false)
# define if_linux if constexpr (true)
#endif
#define console_normal "\x1B[0m"
#define console_red "\x1B[31m"
#define console_green "\x1B[32m"
#define console_cyan "\x1B[36m"
src/docgeneration.cpp
+142 -142
View File
@@ -1,142 +1,142 @@
namespace Slime {
proc generate_docs(String* path) -> void {
FILE *f = fopen(Memory::get_c_str(path), "w");
if (!f) {
create_generic_error("The file for writing the documentation (%s) "
"could not be opened for writing.", Memory::get_c_str(path));
return;
}
defer {
fclose(f);
};
Array_List<Environment*> visited;
const auto print_this_env = [&](const auto& rec, Environment* env, char* prefix) -> void {
bool we_already_printed = false;
// TODO(Felix): Make a generic array_list_contains function
for(auto it : visited) {
if (it == env) {
we_already_printed = true;
break;
}
}
if (!we_already_printed) {
// printf("Working on env::::");
// print_environment(env);
// printf("\n--------------------------------\n");
visited.append(env);
push_environment(env);
defer {
pop_environment();
};
for_hash_map(env->hm) {
try_void fprintf(f,
"#+latex: \\hrule\n"
"#+html: <hr/>\n"
"* =%s%s= \n"
" :PROPERTIES:\n"
" :UNNUMBERED: t\n"
" :END:"
,prefix, Memory::get_c_str(((Lisp_Object*)key)->value.symbol));
/*
* sourcecodeLocation
*/
if (value->sourceCodeLocation) {
try_void fprintf(f, "\n - defined in :: =%s:%d:%d=",
Memory::get_c_str(value->sourceCodeLocation->file),
value->sourceCodeLocation->line,
value->sourceCodeLocation->column);
}
/*
* type
*/
Lisp_Object_Type type = Memory::get_type(value);
Lisp_Object* LOtype;
Lisp_Object* type_expr = Memory::create_list(Memory::get_symbol("type"), value);
try_void LOtype = eval_expr(type_expr);
fprintf(f, "\n - type :: =");
print(LOtype, true, f);
fprintf(f, "=");
/*
* if printable value -> print it
*/
switch (type) {
case(Lisp_Object_Type::Nil):
case(Lisp_Object_Type::T):
case(Lisp_Object_Type::Number):
case(Lisp_Object_Type::String):
case(Lisp_Object_Type::Pair):
case(Lisp_Object_Type::Symbol):
case(Lisp_Object_Type::Keyword): {
fprintf(f, "\n - value :: =");
print(value, true, f);
fprintf(f, "=");
} break;
default: break;
}
/*
* if function then print arguments
*/
if (type == Lisp_Object_Type::Function)
{
Arguments* args = &value->value.function->args;
fprintf(f, "\n - arguments :: ");
// if no args at all
if (args->positional.symbols.next_index == 0 &&
args->keyword.values.next_index == 0 &&
!args->rest)
{
fprintf(f, "none.");
} else {
if (args->positional.symbols.next_index != 0) {
fprintf(f, "\n - postitional :: ");
fprintf(f, "=%s=", Memory::get_c_str(args->positional.symbols.data[0]->value.symbol));
for (int i = 1; i < args->positional.symbols.next_index; ++i) {
fprintf(f, ", =%s=", Memory::get_c_str(args->positional.symbols.data[i]->value.symbol));
}
}
if (args->keyword.values.next_index != 0) {
fprintf(f, "\n - keyword :: ");
fprintf(f, "=%s=", Memory::get_c_str(args->keyword.keywords.data[0]->value.symbol));
if (args->keyword.values.data[0]) {
fprintf(f, " =(");
print(args->keyword.values.data[0], true, f);
fprintf(f, ")=");
}
for (int i = 1; i < args->keyword.values.next_index; ++i) {
fprintf(f, ", =%s=", Memory::get_c_str(args->keyword.keywords.data[i]->value.symbol));
if (args->keyword.values.data[i]) {
fprintf(f, " =(");
print(args->keyword.values.data[i], true, f);
fprintf(f, ")=");
}
}
}
if (args->rest) {
fprintf(f, "\n - rest :: =%s=", Memory::get_c_str(args->rest->value.symbol));
}
}
}
fprintf(f, "\n - docu :: ");
if (value->docstring)
fprintf(f, "\n #+BEGIN:\n%s\n #+END:\n",
Memory::get_c_str(value->docstring));
else
fprintf(f, "none\n");
}
}
for (int i = 0; i < env->parents.next_index; ++i) {
try_void rec(rec, env->parents.data[i], prefix);
}
};
print_this_env(print_this_env, get_current_environment(), (char*)"");
}
}
namespace Slime {
proc generate_docs(String* path) -> void {
FILE *f = fopen(Memory::get_c_str(path), "w");
if (!f) {
create_generic_error("The file for writing the documentation (%s) "
"could not be opened for writing.", Memory::get_c_str(path));
return;
}
defer {
fclose(f);
};
Array_List<Environment*> visited;
const auto print_this_env = [&](const auto& rec, Environment* env, char* prefix) -> void {
bool we_already_printed = false;
// TODO(Felix): Make a generic array_list_contains function
for(auto it : visited) {
if (it == env) {
we_already_printed = true;
break;
}
}
if (!we_already_printed) {
// printf("Working on env::::");
// print_environment(env);
// printf("\n--------------------------------\n");
visited.append(env);
push_environment(env);
defer {
pop_environment();
};
for_hash_map(env->hm) {
try_void fprintf(f,
"#+latex: \\hrule\n"
"#+html: <hr/>\n"
"* =%s%s= \n"
" :PROPERTIES:\n"
" :UNNUMBERED: t\n"
" :END:"
,prefix, Memory::get_c_str(((Lisp_Object*)key)->value.symbol));
/*
* sourcecodeLocation
*/
if (value->sourceCodeLocation) {
try_void fprintf(f, "\n - defined in :: =%s:%d:%d=",
Memory::get_c_str(value->sourceCodeLocation->file),
value->sourceCodeLocation->line,
value->sourceCodeLocation->column);
}
/*
* type
*/
Lisp_Object_Type type = Memory::get_type(value);
Lisp_Object* LOtype;
Lisp_Object* type_expr = Memory::create_list(Memory::get_symbol("type"), value);
try_void LOtype = eval_expr(type_expr);
fprintf(f, "\n - type :: =");
print(LOtype, true, f);
fprintf(f, "=");
/*
* if printable value -> print it
*/
switch (type) {
case(Lisp_Object_Type::Nil):
case(Lisp_Object_Type::T):
case(Lisp_Object_Type::Number):
case(Lisp_Object_Type::String):
case(Lisp_Object_Type::Pair):
case(Lisp_Object_Type::Symbol):
case(Lisp_Object_Type::Keyword): {
fprintf(f, "\n - value :: =");
print(value, true, f);
fprintf(f, "=");
} break;
default: break;
}
/*
* if function then print arguments
*/
if (type == Lisp_Object_Type::Function)
{
Arguments* args = &value->value.function->args;
fprintf(f, "\n - arguments :: ");
// if no args at all
if (args->positional.symbols.next_index == 0 &&
args->keyword.values.next_index == 0 &&
!args->rest)
{
fprintf(f, "none.");
} else {
if (args->positional.symbols.next_index != 0) {
fprintf(f, "\n - postitional :: ");
fprintf(f, "=%s=", Memory::get_c_str(args->positional.symbols.data[0]->value.symbol));
for (int i = 1; i < args->positional.symbols.next_index; ++i) {
fprintf(f, ", =%s=", Memory::get_c_str(args->positional.symbols.data[i]->value.symbol));
}
}
if (args->keyword.values.next_index != 0) {
fprintf(f, "\n - keyword :: ");
fprintf(f, "=%s=", Memory::get_c_str(args->keyword.keywords.data[0]->value.symbol));
if (args->keyword.values.data[0]) {
fprintf(f, " =(");
print(args->keyword.values.data[0], true, f);
fprintf(f, ")=");
}
for (int i = 1; i < args->keyword.values.next_index; ++i) {
fprintf(f, ", =%s=", Memory::get_c_str(args->keyword.keywords.data[i]->value.symbol));
if (args->keyword.values.data[i]) {
fprintf(f, " =(");
print(args->keyword.values.data[i], true, f);
fprintf(f, ")=");
}
}
}
if (args->rest) {
fprintf(f, "\n - rest :: =%s=", Memory::get_c_str(args->rest->value.symbol));
}
}
}
fprintf(f, "\n - docu :: ");
if (value->docstring)
fprintf(f, "\n #+BEGIN:\n%s\n #+END:\n",
Memory::get_c_str(value->docstring));
else
fprintf(f, "none\n");
}
}
for (int i = 0; i < env->parents.next_index; ++i) {
try_void rec(rec, env->parents.data[i], prefix);
}
};
print_this_env(print_this_env, get_current_environment(), (char*)"");
}
}
src/env.cpp
+125 -125
View File
@@ -1,125 +1,125 @@
namespace Slime {
proc define_symbol(Lisp_Object* symbol, Lisp_Object* value) -> void {
profile_with_comment(&symbol->value.symbol->data);
Environment* env = get_current_environment();
env->hm.set_object((void*)symbol, value);
}
inline proc lookup_symbol_in_this_envt(Lisp_Object* sym, Environment* env) -> Lisp_Object* {
return (Lisp_Object*)env->hm.get_object((void*)sym);
}
proc environment_binds_symbol(Lisp_Object* sym, Environment* env) -> bool {
return lookup_symbol_in_this_envt(sym, env) != nullptr;
}
proc find_binding_environment(Lisp_Object* sym, Environment* env) -> Environment* {
if (environment_binds_symbol(sym, env))
return env;
for (auto it : env->parents) {
if (Environment* ret = find_binding_environment(sym, it))
return ret;
}
return nullptr;
}
proc try_lookup_symbol(Lisp_Object* node, Environment* env) -> Lisp_Object* {
// first check current environment
Lisp_Object* result;
result = lookup_symbol_in_this_envt(node, env);
if (result)
return result;
for (int i = 0; i < env->parents.next_index; ++i) {
result = try_lookup_symbol(node, env->parents.data[i]);
if (result)
return result;
}
auto nil_sym = Memory::get_symbol("nil");
auto t_sym = Memory::get_symbol("t");
if (node == nil_sym) {
return Memory::nil;
}
if (node == t_sym) {
return Memory::t;
}
return nullptr;
}
inline proc push_environment(Environment* env) -> void {
using namespace Globals::Current_Execution;
envi_stack.append(env);
}
inline proc pop_environment() -> void {
using namespace Globals::Current_Execution;
--envi_stack.next_index;
}
inline proc get_root_environment() -> Environment* {
using namespace Globals::Current_Execution;
return envi_stack.data[0];
}
inline proc get_current_environment() -> Environment* {
using namespace Globals::Current_Execution;
return envi_stack.data[envi_stack.next_index-1];
}
proc lookup_symbol(Lisp_Object* node, Environment* env) -> Lisp_Object* {
profile_with_comment(&node->value.symbol->data);
// print(node);
assert_type(node, Lisp_Object_Type::Symbol);
Lisp_Object* result = try_lookup_symbol(node, env);
if (result)
return result;
String* identifier = node->value.symbol;
print_environment(env);
printf("\n");
create_symbol_undefined_error("The symbol '%s' is not defined.", &identifier->data);
return nullptr;
}
proc print_environment_indent(Environment* env, int indent) -> void {
proc print_indent = [](int indent) {
for (int i = 0; i < indent; ++i) {
printf(" ");
}
};
if(env == get_root_environment()) {
print_indent(indent);
printf("[built-ins]-Environment (%lld)\n", (long long)env);
return;
}
for_hash_map (env->hm) {
print_indent(indent);
printf("-> %s :: ", &(((Lisp_Object*)key)->value.symbol->data));
print((Lisp_Object*)value);
printf(" (0x%016llx)", (unsigned long long)value);
puts("");
}
for (int i = 0; i < env->parents.next_index; ++i) {
print_indent(indent);
printf("parent (0x%016llx)", (long long)env->parents.data[i]);
puts(":");
print_environment_indent(env->parents.data[i], indent+4);
}
}
proc print_environment(Environment* env) -> void {
printf("\n=== Environment === (0x%016llx)\n", (long long)env);
print_environment_indent(env, 0);
}
}
namespace Slime {
proc define_symbol(Lisp_Object* symbol, Lisp_Object* value) -> void {
profile_with_comment(&symbol->value.symbol->data);
Environment* env = get_current_environment();
env->hm.set_object((void*)symbol, value);
}
inline proc lookup_symbol_in_this_envt(Lisp_Object* sym, Environment* env) -> Lisp_Object* {
return (Lisp_Object*)env->hm.get_object((void*)sym);
}
proc environment_binds_symbol(Lisp_Object* sym, Environment* env) -> bool {
return lookup_symbol_in_this_envt(sym, env) != nullptr;
}
proc find_binding_environment(Lisp_Object* sym, Environment* env) -> Environment* {
if (environment_binds_symbol(sym, env))
return env;
for (auto it : env->parents) {
if (Environment* ret = find_binding_environment(sym, it))
return ret;
}
return nullptr;
}
proc try_lookup_symbol(Lisp_Object* node, Environment* env) -> Lisp_Object* {
// first check current environment
Lisp_Object* result;
result = lookup_symbol_in_this_envt(node, env);
if (result)
return result;
for (int i = 0; i < env->parents.next_index; ++i) {
result = try_lookup_symbol(node, env->parents.data[i]);
if (result)
return result;
}
auto nil_sym = Memory::get_symbol("nil");
auto t_sym = Memory::get_symbol("t");
if (node == nil_sym) {
return Memory::nil;
}
if (node == t_sym) {
return Memory::t;
}
return nullptr;
}
inline proc push_environment(Environment* env) -> void {
using namespace Globals::Current_Execution;
envi_stack.append(env);
}
inline proc pop_environment() -> void {
using namespace Globals::Current_Execution;
--envi_stack.next_index;
}
inline proc get_root_environment() -> Environment* {
using namespace Globals::Current_Execution;
return envi_stack.data[0];
}
inline proc get_current_environment() -> Environment* {
using namespace Globals::Current_Execution;
return envi_stack.data[envi_stack.next_index-1];
}
proc lookup_symbol(Lisp_Object* node, Environment* env) -> Lisp_Object* {
profile_with_comment(&node->value.symbol->data);
// print(node);
assert_type(node, Lisp_Object_Type::Symbol);
Lisp_Object* result = try_lookup_symbol(node, env);
if (result)
return result;
String* identifier = node->value.symbol;
print_environment(env);
printf("\n");
create_symbol_undefined_error("The symbol '%s' is not defined.", &identifier->data);
return nullptr;
}
proc print_environment_indent(Environment* env, int indent) -> void {
proc print_indent = [](int indent) {
for (int i = 0; i < indent; ++i) {
printf(" ");
}
};
if(env == get_root_environment()) {
print_indent(indent);
printf("[built-ins]-Environment (%lld)\n", (long long)env);
return;
}
for_hash_map (env->hm) {
print_indent(indent);
printf("-> %s :: ", &(((Lisp_Object*)key)->value.symbol->data));
print((Lisp_Object*)value);
printf(" (0x%016llx)", (unsigned long long)value);
puts("");
}
for (int i = 0; i < env->parents.next_index; ++i) {
print_indent(indent);
printf("parent (0x%016llx)", (long long)env->parents.data[i]);
puts(":");
print_environment_indent(env->parents.data[i], indent+4);
}
}
proc print_environment(Environment* env) -> void {
printf("\n=== Environment === (0x%016llx)\n", (long long)env);
print_environment_indent(env, 0);
}
}
src/error.cpp
+57 -57
View File
@@ -1,57 +1,57 @@
namespace Slime {
proc delete_error() -> void {
using Globals::error;
free(error);
error = nullptr;
}
proc create_error(const char* c_func_name,const char* c_file_name, int c_file_line, Lisp_Object* type, String* message) -> void {
delete_error();
if (Globals::breaking_on_errors) {
debug_break();
}
using Globals::error;
error = (Error*)malloc(sizeof(Error)) ;
error->type = type;
error->message = message;
log_error();
if (Globals::log_level > Log_Level::None) {
// c error location
printf("in");
int spacing = 30-((int)strlen(c_file_name) + (int)log10(c_file_line));
if (spacing < 1) spacing = 1;
for (int i = 0; i < spacing; ++i)
printf(" ");
printf("%s (%d) ", c_file_name, c_file_line);
printf("-> %s\n", c_func_name);
}
// visualize_lisp_machine();
}
proc create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, const char* format, ...) -> void {
using Globals::error;
int length = 200;
String* formatted_string = Memory::create_string("", length);
if (error) {
error = new(Error);
error->type = type;
}
int written_length;
va_list args;
char* out_msg;
va_start(args, format);
written_length = vasprintf(&out_msg, format, args);
va_end(args);
formatted_string->length = written_length;
strcpy(&formatted_string->data, out_msg);
free(out_msg);
create_error(c_func_name, c_file_name, c_file_line, type, formatted_string);
}
}
namespace Slime {
proc delete_error() -> void {
using Globals::error;
free(error);
error = nullptr;
}
proc create_error(const char* c_func_name,const char* c_file_name, int c_file_line, Lisp_Object* type, String* message) -> void {
delete_error();
if (Globals::breaking_on_errors) {
debug_break();
}
using Globals::error;
error = (Error*)malloc(sizeof(Error)) ;
error->type = type;
error->message = message;
log_error();
if (Globals::log_level > Log_Level::None) {
// c error location
printf("in");
int spacing = 30-((int)strlen(c_file_name) + (int)log10(c_file_line));
if (spacing < 1) spacing = 1;
for (int i = 0; i < spacing; ++i)
printf(" ");
printf("%s (%d) ", c_file_name, c_file_line);
printf("-> %s\n", c_func_name);
}
// visualize_lisp_machine();
}
proc create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, const char* format, ...) -> void {
using Globals::error;
int length = 200;
String* formatted_string = Memory::create_string("", length);
if (error) {
error = new(Error);
error->type = type;
}
int written_length;
va_list args;
char* out_msg;
va_start(args, format);
written_length = vasprintf(&out_msg, format, args);
va_end(args);
formatted_string->length = written_length;
strcpy(&formatted_string->data, out_msg);
free(out_msg);
create_error(c_func_name, c_file_name, c_file_line, type, formatted_string);
}
}
src/eval.cpp
+615 -614
View File
File diff suppressed because it is too large Load Diff
src/forward_decls.cpp
+87 -86
View File
@@ -1,86 +1,87 @@
namespace Slime {
void add_to_load_path(const char*);
bool lisp_object_equal(Lisp_Object*,Lisp_Object*);
Lisp_Object* built_in_load(String*);
Lisp_Object* built_in_import(String*);
void delete_error();
void create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, const char* format, ...);
void create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, String* message);
void create_error(Lisp_Object* type, const char* message, const char* c_file_name, int c_file_line);
Lisp_Object* eval_arguments(Lisp_Object*);
Lisp_Object* eval_expr(Lisp_Object*);
bool is_truthy (Lisp_Object*);
int list_length(Lisp_Object*);
void* load_built_ins_into_environment();
void create_arguments_from_lambda_list_and_inject(Lisp_Object* formal_arguments, Lisp_Object* function);
Lisp_Object* lookup_symbol(Lisp_Object* symbol, Environment*);
void define_symbol(Lisp_Object* symbol, Lisp_Object* value);
char* lisp_object_to_string(Lisp_Object* node, bool print_repr);
void print(Lisp_Object* node, bool print_repr = false, FILE* file = stdout);
void print_environment(Environment*);
bool run_all_tests();
inline Environment* get_root_environment();
inline Environment* get_current_environment();
inline void push_environment(Environment*);
inline void pop_environment();
const char* Lisp_Object_Type_to_string(Lisp_Object_Type type);
void visualize_lisp_machine();
void generate_docs(String* path);
void log_error();
namespace Memory {
Environment* create_built_ins_environment();
Lisp_Object* create_lisp_object_cfunction(bool is_special);
inline Lisp_Object_Type get_type(Lisp_Object* node);
void init(int);
char* get_c_str(String*);
void free_everything();
String* create_string(const char*);
Lisp_Object* get_symbol(String* identifier);
Lisp_Object* get_symbol(const char*);
Lisp_Object* get_keyword(String* identifier);
Lisp_Object* get_keyword(const char*);
Lisp_Object* create_lisp_object(double);
Lisp_Object* create_lisp_object(const char*);
Lisp_Object* create_lisp_object_vector(Lisp_Object*);
Lisp_Object* create_lisp_object_vector(Lisp_Object*, Lisp_Object*);
Lisp_Object* create_lisp_object_vector(Lisp_Object*, Lisp_Object*, Lisp_Object*);
Lisp_Object* create_lisp_object_vector(int, Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*);
}
namespace Parser {
// extern Environment* environment_for_macros;
extern String* standard_in;
extern String* parser_file;
extern int parser_line;
extern int parser_col;
Lisp_Object* parse_expression(char* text, int* index_in_text);
Lisp_Object* parse_single_expression(char* text);
Lisp_Object* parse_single_expression(wchar_t* text);
}
namespace Globals {
extern char* bin_path;
extern Log_Level log_level;
extern Array_List<void*> load_path;
namespace Current_Execution {
extern Array_List<Lisp_Object*> call_stack;
extern Array_List<Environment*> envi_stack;
}
extern Error* error;
extern bool breaking_on_errors;
}
}
namespace Slime {
void add_to_load_path(const char*);
bool lisp_object_equal(Lisp_Object*,Lisp_Object*);
Lisp_Object* built_in_load(String*);
Lisp_Object* built_in_import(String*);
void delete_error();
void create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, const char* format, ...);
void create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, String* message);
void create_error(Lisp_Object* type, const char* message, const char* c_file_name, int c_file_line);
Lisp_Object* eval_arguments(Lisp_Object*);
Lisp_Object* eval_expr(Lisp_Object*);
bool is_truthy (Lisp_Object*);
int list_length(Lisp_Object*);
void* load_built_ins_into_environment();
void create_arguments_from_lambda_list_and_inject(Lisp_Object* formal_arguments, Lisp_Object* function);
Lisp_Object* lookup_symbol(Lisp_Object* symbol, Environment*);
void define_symbol(Lisp_Object* symbol, Lisp_Object* value);
char* lisp_object_to_string(Lisp_Object* node, bool print_repr = true);
void print(Lisp_Object* node, bool print_repr = false, FILE* file = stdout);
void print_environment(Environment*);
bool run_all_tests();
inline Environment* get_root_environment();
inline Environment* get_current_environment();
inline void push_environment(Environment*);
inline void pop_environment();
const char* Lisp_Object_Type_to_string(Lisp_Object_Type type);
void visualize_lisp_machine();
void generate_docs(String* path);
void log_error();
namespace Memory {
Environment* create_built_ins_environment();
Lisp_Object* create_lisp_object_cfunction(bool is_special);
inline Lisp_Object_Type get_type(Lisp_Object* node);
void init(int);
char* get_c_str(String*);
void free_everything();
String* create_string(const char*);
Lisp_Object* get_symbol(String* identifier);
Lisp_Object* get_symbol(const char*);
Lisp_Object* get_keyword(String* identifier);
Lisp_Object* get_keyword(const char*);
Lisp_Object* create_lisp_object(double);
Lisp_Object* create_lisp_object(const char*);
Lisp_Object* create_lisp_object_vector(Lisp_Object*);
Lisp_Object* create_lisp_object_vector(Lisp_Object*, Lisp_Object*);
Lisp_Object* create_lisp_object_vector(Lisp_Object*, Lisp_Object*, Lisp_Object*);
Lisp_Object* create_lisp_object_vector(int, Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*);
inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*);
}
namespace Parser {
// extern Environment* environment_for_macros;
extern String* standard_in;
extern String* parser_file;
extern int parser_line;
extern int parser_col;
Lisp_Object* parse_expression(char* text, int* index_in_text);
Lisp_Object* parse_single_expression(char* text);
Lisp_Object* parse_single_expression(wchar_t* text);
}
namespace Globals {
extern bool debug_log;
extern char* bin_path;
extern Log_Level log_level;
extern Array_List<void*> load_path;
namespace Current_Execution {
extern Array_List<Lisp_Object*> call_stack;
extern Array_List<Environment*> envi_stack;
}
extern Error* error;
extern bool breaking_on_errors;
}
}
src/globals.cpp
+21 -21
View File
@@ -1,21 +1,21 @@
namespace Slime::Globals {
char* bin_path = nullptr;
Log_Level log_level = Log_Level::Debug;
Array_List<void*> load_path;
namespace Current_Execution {
Array_List<Lisp_Object*> cs;
Array_List<Lisp_Object*> pcs;
Array_List<int> ams;
Array_List<Array_List<NasAction>> nass;
// Array_List<Lisp_Object*> call_stack;
Array_List<Environment*> envi_stack;
}
Error* error = nullptr;
#ifdef _DONT_BREAK_ON_ERRORS
bool breaking_on_errors = false;
#else
bool breaking_on_errors = true;
#endif
}
namespace Slime::Globals {
char* bin_path = nullptr;
Log_Level log_level = Log_Level::Debug;
bool debug_log = false;
Array_List<void*> load_path;
namespace Current_Execution {
Array_List<Lisp_Object*> cs;
Array_List<Lisp_Object*> pcs;
Array_List<int> ams;
Array_List<Array_List<NasAction>> nass;
// Array_List<Lisp_Object*> call_stack;
Array_List<Environment*> envi_stack;
}
Error* error = nullptr;
#ifdef _DONT_BREAK_ON_ERRORS
bool breaking_on_errors = false;
#else
bool breaking_on_errors = true;
#endif
}
src/io.cpp
+425 -424
View File
@@ -1,307 +1,307 @@
namespace Slime {
proc string_equal(const char input[], const char check[]) -> bool {
if (input == check) return true;
for(int i = 0; input[i] == check[i]; i++) {
if (input[i] == '\0')
return true;
}
return false;
}
proc string_equal(String* str, const char check[]) -> bool {
return string_equal(Memory::get_c_str(str), check);
}
proc string_equal(const char check[], String* str) -> bool {
return string_equal(Memory::get_c_str(str), check);
}
proc string_equal(String* str1, String* str2) -> bool {
if (str1 == str2)
return true;
return string_equal(Memory::get_c_str(str1), Memory::get_c_str(str2));
}
proc get_nibble(char c) -> char {
if (c >= 'A' && c <= 'F')
return (c - 'A') + 10;
else if (c >= 'a' && c <= 'f')
return (c - 'a') + 10;
return (c - '0');
}
proc escape_string(char* in) -> char* {
// TODO(Felix): add more escape sequences
int i = 0, count = 0;
while (in[i] != '\0') {
switch (in[i]) {
case '\\':
case '\n':
case '\t':
++count;
default: break;
}
++i;
}
char* ret = (char*)malloc((i+count+1)*sizeof(char));
// copy in
i = 0;
int j = 0;
while (in[i] != '\0') {
switch (in[i]) {
case '\\': ret[j++] = '\\'; ret[j++] = '\\'; break;
case '\n': ret[j++] = '\\'; ret[j++] = 'n'; break;
case '\t': ret[j++] = '\\'; ret[j++] = 't'; break;
default: ret[j++] = in[i];
}
++i;
}
ret[j++] = '\0';
return ret;
}
proc unescape_string(char* in) -> int {
if (!in) return 0;
char *out = in, *p = in;
const char *int_err = nullptr;
while (*p && !int_err) {
if (*p != '\\') {
/* normal case */
*out++ = *p++;
} else {
/* escape sequence */
switch (*++p) {
case '0': *out++ = '\a'; ++p; break;
case 'a': *out++ = '\a'; ++p; break;
case 'b': *out++ = '\b'; ++p; break;
case 'f': *out++ = '\f'; ++p; break;
case 'n': *out++ = '\n'; ++p; break;
case 'r': *out++ = '\r'; ++p; break;
case 't': *out++ = '\t'; ++p; break;
case 'v': *out++ = '\v'; ++p; break;
case '"':
case '\'':
case '\\':
*out++ = *p++;
case '?':
break;
case 'x':
case 'X':
if (!isxdigit(p[1]) || !isxdigit(p[2])) {
create_parsing_error(
"The string '%s' at %s:%d:%d could not be unescaped. "
"(Invalid character on hexadecimal escape at char %d)",
in, Parser::parser_file, Parser::parser_line, Parser::parser_col,
(p+1)-in);
} else {
*out++ = (char)(get_nibble(p[1]) * 0x10 + get_nibble(p[2]));
p += 3;
}
break;
default:
create_parsing_error(
"The string '%s' at %s:%d:%d could not be unescaped. "
"(Unexpected '\\' with no escape sequence at char %d)",
in, Parser::parser_file, Parser::parser_line, Parser::parser_col,
(p+1)-in);
}
}
}
/* Set the end of string. */
*out = '\0';
return (int)(out - in);
}
proc read_entire_file(char* filename) -> char* {
profile_with_comment(filename);
char *fileContent = nullptr;
FILE *fp = fopen(filename, "r");
if (fp) {
/* Go to the end of the file. */
if (fseek(fp, 0L, SEEK_END) == 0) {
/* Get the size of the file. */
long bufsize = ftell(fp) + 1;
if (bufsize == 0) {
fputs("Empty file", stderr);
goto closeFile;
}
/* Go back to the start of the file. */
if (fseek(fp, 0L, SEEK_SET) != 0) {
fputs("Error reading file", stderr);
goto closeFile;
}
/* Allocate our buffer to that size. */
fileContent = (char*)calloc(bufsize, sizeof(char));
/* Read the entire file into memory. */
size_t newLen = fread(fileContent, sizeof(char), bufsize, fp);
fileContent[newLen] = '\0';
if (ferror(fp) != 0) {
fputs("Error reading file", stderr);
}
}
closeFile:
fclose(fp);
}
return fileContent;
/* Don't forget to call free() later! */
}
proc read_expression() -> char* {
char* line = (char*)malloc(100);
if(line == nullptr)
return nullptr;
char* linep = line;
size_t lenmax = 100, len = lenmax;
int c;
int nesting = 0;
while (true) {
c = fgetc(stdin);
if(c == EOF)
break;
if(--len == 0) {
len = lenmax;
char * linen = (char*)realloc(linep, lenmax *= 2);
if(linen == nullptr) {
free(linep);
return nullptr;
}
line = linen + (line - linep);
linep = linen;
}
*line = (char)c;
if(*line == '(')
++nesting;
else if(*line == ')')
--nesting;
else if(*line == '\n')
if (nesting == 0)
break;
line++;
}
(*line)--; // we dont want the \n actually
*line = '\0';
return linep;
}
proc read_line() -> char* {
char* line = (char*)malloc(100), * linep = line;
size_t lenmax = 100, len = lenmax;
int c;
int nesting = 0;
if(line == nullptr)
return nullptr;
for(;;) {
c = fgetc(stdin);
if(c == EOF)
break;
if(--len == 0) {
len = lenmax;
char* linen = (char*)realloc(linep, lenmax *= 2);
if(linen == nullptr) {
free(linep);
return nullptr;
}
line = linen + (line - linep);
linep = linen;
}
*line = (char)c;
if(*line == '(')
++nesting;
else if(*line == ')')
--nesting;
else if(*line == '\n')
if (nesting == 0)
break;
line++;
}
(*line)--; // we dont want the \n actually
*line = '\0';
return linep;
}
proc log_message(Log_Level type, const char* message) -> void {
if (type > Globals::log_level)
return;
const char* prefix;
switch (type) {
case Log_Level::Critical: prefix = "CRITICAL"; break;
case Log_Level::Warning: prefix = "WARNING"; break;
case Log_Level::Info: prefix = "INFO"; break;
case Log_Level::Debug: prefix = "DEBUG"; break;
default: return;
}
printf("%s: %s\n",prefix, message);
}
char* wchar_to_char(const wchar_t* pwchar) {
// get the number of characters in the string.
int currentCharIndex = 0;
char currentChar = (char)pwchar[currentCharIndex];
while (currentChar != '\0')
{
currentCharIndex++;
currentChar = (char)pwchar[currentCharIndex];
}
const int charCount = currentCharIndex + 1;
// allocate a new block of memory size char (1 byte) instead of wide char (2 bytes)
char* filePathC = (char*)malloc(sizeof(char) * charCount);
for (int i = 0; i < charCount; i++)
{
// convert to char (1 byte)
char character = (char)pwchar[i];
*filePathC = character;
filePathC += sizeof(char);
}
filePathC += '\0';
filePathC -= (sizeof(char) * charCount);
return filePathC;
}
const wchar_t* char_to_wchar(const char* c) {
const size_t cSize = strlen(c)+1;
wchar_t* wc = new wchar_t[cSize];
mbstowcs (wc, c, cSize);
return wc;
}
namespace Slime {
proc string_equal(const char input[], const char check[]) -> bool {
if (input == check) return true;
for(int i = 0; input[i] == check[i]; i++) {
if (input[i] == '\0')
return true;
}
return false;
}
proc string_equal(String* str, const char check[]) -> bool {
return string_equal(Memory::get_c_str(str), check);
}
proc string_equal(const char check[], String* str) -> bool {
return string_equal(Memory::get_c_str(str), check);
}
proc string_equal(String* str1, String* str2) -> bool {
if (str1 == str2)
return true;
return string_equal(Memory::get_c_str(str1), Memory::get_c_str(str2));
}
proc get_nibble(char c) -> char {
if (c >= 'A' && c <= 'F')
return (c - 'A') + 10;
else if (c >= 'a' && c <= 'f')
return (c - 'a') + 10;
return (c - '0');
}
proc escape_string(char* in) -> char* {
// TODO(Felix): add more escape sequences
int i = 0, count = 0;
while (in[i] != '\0') {
switch (in[i]) {
case '\\':
case '\n':
case '\t':
++count;
default: break;
}
++i;
}
char* ret = (char*)malloc((i+count+1)*sizeof(char));
// copy in
i = 0;
int j = 0;
while (in[i] != '\0') {
switch (in[i]) {
case '\\': ret[j++] = '\\'; ret[j++] = '\\'; break;
case '\n': ret[j++] = '\\'; ret[j++] = 'n'; break;
case '\t': ret[j++] = '\\'; ret[j++] = 't'; break;
default: ret[j++] = in[i];
}
++i;
}
ret[j++] = '\0';
return ret;
}
proc unescape_string(char* in) -> int {
if (!in) return 0;
char *out = in, *p = in;
const char *int_err = nullptr;
while (*p && !int_err) {
if (*p != '\\') {
/* normal case */
*out++ = *p++;
} else {
/* escape sequence */
switch (*++p) {
case '0': *out++ = '\a'; ++p; break;
case 'a': *out++ = '\a'; ++p; break;
case 'b': *out++ = '\b'; ++p; break;
case 'f': *out++ = '\f'; ++p; break;
case 'n': *out++ = '\n'; ++p; break;
case 'r': *out++ = '\r'; ++p; break;
case 't': *out++ = '\t'; ++p; break;
case 'v': *out++ = '\v'; ++p; break;
case '"':
case '\'':
case '\\':
*out++ = *p++;
case '?':
break;
case 'x':
case 'X':
if (!isxdigit(p[1]) || !isxdigit(p[2])) {
create_parsing_error(
"The string '%s' at %s:%d:%d could not be unescaped. "
"(Invalid character on hexadecimal escape at char %d)",
in, Parser::parser_file, Parser::parser_line, Parser::parser_col,
(p+1)-in);
} else {
*out++ = (char)(get_nibble(p[1]) * 0x10 + get_nibble(p[2]));
p += 3;
}
break;
default:
create_parsing_error(
"The string '%s' at %s:%d:%d could not be unescaped. "
"(Unexpected '\\' with no escape sequence at char %d)",
in, Parser::parser_file, Parser::parser_line, Parser::parser_col,
(p+1)-in);
}
}
}
/* Set the end of string. */
*out = '\0';
return (int)(out - in);
}
proc read_entire_file(char* filename) -> char* {
profile_with_comment(filename);
char *fileContent = nullptr;
FILE *fp = fopen(filename, "r");
if (fp) {
/* Go to the end of the file. */
if (fseek(fp, 0L, SEEK_END) == 0) {
/* Get the size of the file. */
long bufsize = ftell(fp) + 1;
if (bufsize == 0) {
fputs("Empty file", stderr);
goto closeFile;
}
/* Go back to the start of the file. */
if (fseek(fp, 0L, SEEK_SET) != 0) {
fputs("Error reading file", stderr);
goto closeFile;
}
/* Allocate our buffer to that size. */
fileContent = (char*)calloc(bufsize, sizeof(char));
/* Read the entire file into memory. */
size_t newLen = fread(fileContent, sizeof(char), bufsize, fp);
fileContent[newLen] = '\0';
if (ferror(fp) != 0) {
fputs("Error reading file", stderr);
}
}
closeFile:
fclose(fp);
}
return fileContent;
/* Don't forget to call free() later! */
}
proc read_expression() -> char* {
char* line = (char*)malloc(100);
if(line == nullptr)
return nullptr;
char* linep = line;
size_t lenmax = 100, len = lenmax;
int c;
int nesting = 0;
while (true) {
c = fgetc(stdin);
if(c == EOF)
break;
if(--len == 0) {
len = lenmax;
char * linen = (char*)realloc(linep, lenmax *= 2);
if(linen == nullptr) {
free(linep);
return nullptr;
}
line = linen + (line - linep);
linep = linen;
}
*line = (char)c;
if(*line == '(')
++nesting;
else if(*line == ')')
--nesting;
else if(*line == '\n')
if (nesting == 0)
break;
line++;
}
(*line)--; // we dont want the \n actually
*line = '\0';
return linep;
}
proc read_line() -> char* {
char* line = (char*)malloc(100), * linep = line;
size_t lenmax = 100, len = lenmax;
int c;
int nesting = 0;
if(line == nullptr)
return nullptr;
for(;;) {
c = fgetc(stdin);
if(c == EOF)
break;
if(--len == 0) {
len = lenmax;
char* linen = (char*)realloc(linep, lenmax *= 2);
if(linen == nullptr) {
free(linep);
return nullptr;
}
line = linen + (line - linep);
linep = linen;
}
*line = (char)c;
if(*line == '(')
++nesting;
else if(*line == ')')
--nesting;
else if(*line == '\n')
if (nesting == 0)
break;
line++;
}
(*line)--; // we dont want the \n actually
*line = '\0';
return linep;
}
proc log_message(Log_Level type, const char* message) -> void {
if (type > Globals::log_level)
return;
const char* prefix;
switch (type) {
case Log_Level::Critical: prefix = "CRITICAL"; break;
case Log_Level::Warning: prefix = "WARNING"; break;
case Log_Level::Info: prefix = "INFO"; break;
case Log_Level::Debug: prefix = "DEBUG"; break;
default: return;
}
printf("%s: %s\n",prefix, message);
}
char* wchar_to_char(const wchar_t* pwchar) {
// get the number of characters in the string.
int currentCharIndex = 0;
char currentChar = (char)pwchar[currentCharIndex];
while (currentChar != '\0')
{
currentCharIndex++;
currentChar = (char)pwchar[currentCharIndex];
}
const int charCount = currentCharIndex + 1;
// allocate a new block of memory size char (1 byte) instead of wide char (2 bytes)
char* filePathC = (char*)malloc(sizeof(char) * charCount);
for (int i = 0; i < charCount; i++)
{
// convert to char (1 byte)
char character = (char)pwchar[i];
*filePathC = character;
filePathC += sizeof(char);
}
filePathC += '\0';
filePathC -= (sizeof(char) * charCount);
return filePathC;
}
const wchar_t* char_to_wchar(const char* c) {
const size_t cSize = strlen(c)+1;
wchar_t* wc = new wchar_t[cSize];
mbstowcs (wc, c, cSize);
return wc;
}
proc string_buider_to_string(Array_List<char*> string_builder) -> char* {
int len = 1;
@@ -328,15 +328,15 @@ namespace Slime {
string_builder.dealloc();
};
switch (Memory::get_type(node)) {
switch (Memory::get_type(node)) {
case (Lisp_Object_Type::Nil): return strdup("()");
case (Lisp_Object_Type::T): return strdup("t");
case (Lisp_Object_Type::Continuation): return strdup("[continuation]");
case (Lisp_Object_Type::Pointer): return strdup("[pointer]");
case (Lisp_Object_Type::Number): {
if (abs(node->value.number - (int)node->value.number) < 0.000001f)
case (Lisp_Object_Type::Number): {
if (abs(node->value.number - (int)node->value.number) < 0.000001f)
asprintf(&temp, "%d", (int)node->value.number);
else
else
asprintf(&temp, "%f", node->value.number);
return temp;
}
@@ -348,8 +348,8 @@ namespace Slime {
asprintf(&temp, "%s", Memory::get_c_str(node->value.symbol));
return temp;
}
case (Lisp_Object_Type::HashMap): {
for_hash_map (*(node->value.hashMap)) {
case (Lisp_Object_Type::HashMap): {
for_hash_map (*(node->value.hashMap)) {
char* k = lisp_object_to_string(key, true);
char* v = lisp_object_to_string((Lisp_Object*)value, true);
asprintf(&temp, " %s -> %s\n", k, v);
@@ -364,27 +364,22 @@ namespace Slime {
free(str);
}
return temp;
}
case (Lisp_Object_Type::String): {
asprintf(&temp, "%s", Memory::get_c_str(node->value.symbol));
if (print_repr) {
char* escaped = escape_string(Memory::get_c_str(node->value.string));
string_builder.append(strdup("\""));
string_builder.append(escaped);
string_builder.append(strdup("\""));
free(escaped);
temp = string_buider_to_string(string_builder);
// TODO free
}
case (Lisp_Object_Type::String): {
if (print_repr) {
char* escaped = escape_string(Memory::get_c_str(node->value.string));
asprintf(&temp, "\"%s\"", escaped);
free(escaped);
return temp;
} else
return strdup(Memory::get_c_str(node->value.string));
} break;
case (Lisp_Object_Type::Vector): {
} break;
case (Lisp_Object_Type::Vector): {
string_builder.append(strdup("["));
if (node->value.vector.length > 0)
if (node->value.vector.length > 0)
string_builder.append(lisp_object_to_string(node->value.vector.data, print_repr));
for (int i = 1; i < node->value.vector.length; ++i) {
for (int i = 1; i < node->value.vector.length; ++i) {
string_builder.append(strdup(" "));
string_builder.append(lisp_object_to_string(node->value.vector.data+i, print_repr));
}
@@ -392,140 +387,146 @@ namespace Slime {
temp = string_buider_to_string(string_builder);
for (auto str : string_builder) {
free(str);
}
}
return temp;
} break;
case (Lisp_Object_Type::Function): {
if (node->userType) {
} break;
case (Lisp_Object_Type::Function): {
if (node->userType) {
asprintf(&temp, "[%s]", Memory::get_c_str(node->userType->value.symbol));
return temp;
}
if (node->value.function->is_c) {
switch (node->value.function->type.c_function_type) {
case C_Function_Type::cFunction: return strdup("[c-function]");
case C_Function_Type::cSpecial: return strdup("[c-special]");
case C_Function_Type::cMacro: return strdup("[c-macro]");
}
if (node->value.function->is_c) {
// NOTE(Felix): try to find the symbol it is bound to
// in global env
Lisp_Object* name = (Lisp_Object*)(get_root_environment()->hm.search_key_to_object(node));
switch (node->value.function->type.c_function_type) {
case C_Function_Type::cFunction: asprintf(&temp, "[c-function %s]",&((Lisp_Object*)name)->value.symbol->data); break;
case C_Function_Type::cSpecial: asprintf(&temp, "[c-special %s]", &((Lisp_Object*)name)->value.symbol->data); break;
case C_Function_Type::cMacro: asprintf(&temp, "[c-macro %s]", &((Lisp_Object*)name)->value.symbol->data); break;
default: return strdup("[c-??]");
}
} else {
switch (node->value.function->type.lisp_function_type) {
}
return temp;
} else {
switch (node->value.function->type.lisp_function_type) {
case Lisp_Function_Type::Lambda: return strdup("[lambda]");
case Lisp_Function_Type::Macro: return strdup("[macro]");
default: return strdup("[??]");
}
}
} break;
case (Lisp_Object_Type::Pair): {
}
}
} break;
case (Lisp_Object_Type::Pair): {
// TODO
Lisp_Object* head = node;
Lisp_Object* head = node;
defer {
for (auto str : string_builder) {
free(str);
}
};
// first check if it is a quotation form, in that case we want
// to print it prettier
if (Memory::get_type(head->value.pair.first) == Lisp_Object_Type::Symbol) {
String* identifier = head->value.pair.first->value.symbol;
auto symbol = head->value.pair.first;
auto quote_sym = Memory::get_symbol("quote");
auto unquote_sym = Memory::get_symbol("unquote");
auto quasiquote_sym = Memory::get_symbol("quasiquote");
auto unquote_splicing_sym = Memory::get_symbol("unquote-splicing");
if (symbol == quote_sym || symbol == unquote_sym || symbol == unquote_splicing_sym)
{
if (symbol == quote_sym)
// first check if it is a quotation form, in that case we want
// to print it prettier
if (Memory::get_type(head->value.pair.first) == Lisp_Object_Type::Symbol) {
String* identifier = head->value.pair.first->value.symbol;
auto symbol = head->value.pair.first;
auto quote_sym = Memory::get_symbol("quote");
auto unquote_sym = Memory::get_symbol("unquote");
auto quasiquote_sym = Memory::get_symbol("quasiquote");
auto unquote_splicing_sym = Memory::get_symbol("unquote-splicing");
if (symbol == quote_sym || symbol == unquote_sym || symbol == unquote_splicing_sym)
{
if (symbol == quote_sym)
string_builder.append(strdup("\'"));
else if (symbol == unquote_sym)
else if (symbol == unquote_sym)
string_builder.append(strdup(","));
else if (symbol == unquote_splicing_sym)
else if (symbol == unquote_splicing_sym)
string_builder.append(strdup(",@"));
assert_type(head->value.pair.rest, Lisp_Object_Type::Pair);
assert(head->value.pair.rest->value.pair.rest == Memory::nil);
assert_type(head->value.pair.rest, Lisp_Object_Type::Pair);
assert(head->value.pair.rest->value.pair.rest == Memory::nil);
string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr));
temp = string_buider_to_string(string_builder);
return string_buider_to_string(string_builder);
} else if (symbol == quasiquote_sym) {
string_builder.append(strdup("`"));
assert_type(head->value.pair.rest, Lisp_Object_Type::Pair);
assert_type(head->value.pair.rest, Lisp_Object_Type::Pair);
string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr));
return string_buider_to_string(string_builder);
}
}
}
}
string_builder.append(strdup("("));
// NOTE(Felix): We could do a while true here, however in case
// we want to print a broken list (for logging the error) we
// should do more checks.
while (head) {
// NOTE(Felix): We could do a while true here, however in case
// we want to print a broken list (for logging the error) we
// should do more checks.
while (head) {
string_builder.append(lisp_object_to_string(head->value.pair.first, print_repr));
head = head->value.pair.rest;
head = head->value.pair.rest;
if (!head) break;
if (Memory::get_type(head) != Lisp_Object_Type::Pair) break;
string_builder.append(strdup(" "));
}
}
if (head && Memory::get_type(head) != Lisp_Object_Type::Nil) {
string_builder.append(strdup(" . "));
string_builder.append(lisp_object_to_string(head, print_repr));
}
}
string_builder.append(strdup(")"));
return string_buider_to_string(string_builder);
}
}
}
proc print(Lisp_Object* node, bool print_repr, FILE* file) -> void {
char* string = lisp_object_to_string(node, print_repr);
fputs(string, file);
free(string);
}
}
proc print_single_call(Lisp_Object* obj) -> void {
printf(console_cyan);
print(obj, true);
printf(console_normal);
printf("\n at ");
if (obj->sourceCodeLocation) {
printf("%s (line %d, position %d)",
Memory::get_c_str(
obj->sourceCodeLocation->file),
obj->sourceCodeLocation->line,
obj->sourceCodeLocation->column);
} else {
fputs("no source code location avaliable", stdout);
}
}
proc print_call_stack() -> void {
printf("call stack cannot be printed.");
// using Globals::Current_Execution::call_stack;
// printf("callstack [%d] (most recent call last):\n", call_stack.next_index);
// for (int i = 0; i < call_stack.next_index; ++i) {
// printf("%2d -> ", i);
// print_single_call(call_stack.data[i]);
// printf("\n");
// }
}
proc log_error() -> void {
proc print(Lisp_Object* node, bool print_repr, FILE* file) -> void {
char* string = nullptr;
defer {
free(string);
};
string = lisp_object_to_string(node, print_repr);
fputs(string, file);
}
proc print_single_call(Lisp_Object* obj) -> void {
printf(console_cyan);
print(obj, true);
printf(console_normal);
printf("\n at ");
if (obj->sourceCodeLocation) {
printf("%s (line %d, position %d)",
Memory::get_c_str(
obj->sourceCodeLocation->file),
obj->sourceCodeLocation->line,
obj->sourceCodeLocation->column);
} else {
fputs("no source code location avaliable", stdout);
}
}
proc print_call_stack() -> void {
printf("call stack cannot be printed.");
// using Globals::Current_Execution::call_stack;
// printf("callstack [%d] (most recent call last):\n", call_stack.next_index);
// for (int i = 0; i < call_stack.next_index; ++i) {
// printf("%2d -> ", i);
// print_single_call(call_stack.data[i]);
// printf("\n");
// }
}
proc log_error() -> void {
fputs("\n", stdout);
fputs(console_red, stdout);
fputs(Memory::get_c_str(Globals::error->message), stdout);
puts(console_normal);
fputs(" in: ", stdout);
print_call_stack();
puts(console_normal);
}
}
fputs(console_red, stdout);
fputs(Memory::get_c_str(Globals::error->message), stdout);
puts(console_normal);
fputs(" in: ", stdout);
print_call_stack();
puts(console_normal);
}
}
src/libslime.cpp
+120 -120
View File
@@ -1,120 +1,120 @@
#define _CRT_SECURE_NO_WARNINGS
#define _CRT_SECURE_NO_DEPRECATE
#include <stdlib.h>
#include <stdio.h>
#include <time.h>
#include <string.h>
#include <cmath>
#include <ctype.h>
#include <stdarg.h>
#include <errno.h>
#include <new>
#ifdef _MSC_VER
# include <direct.h>
# include <windows.h>
#else
# include <unistd.h>
# include <signal.h>
#endif
/*
Forward declare the hash functions for the hashmap (needed at least
for clang++)
*/
namespace Slime {struct Lisp_Object;}
bool hm_objects_match(char* a, char* b);
bool hm_objects_match(void* a, void* b);
bool hm_objects_match(Slime::Lisp_Object* a, Slime::Lisp_Object* b);
unsigned int hm_hash(char* str);
unsigned int hm_hash(void* ptr);
unsigned int hm_hash(Slime::Lisp_Object* obj);
#include "ftb/hashmap.hpp"
#include "ftb/types.hpp"
#include "ftb/arraylist.hpp"
#include "ftb/bucket_allocator.hpp"
#include "ftb/macros.hpp"
#include "ftb/profiler.hpp"
# include "defines.cpp"
# include "assert.hpp"
# include "define_macros.hpp"
# include "platform.cpp"
# include "structs.cpp"
# include "forward_decls.cpp"
bool hm_objects_match(char* a, char* b) {
return strcmp(a, b) == 0;
}
bool hm_objects_match(void* a, void* b) {
return a == b;
}
bool hm_objects_match(Slime::Lisp_Object* a, Slime::Lisp_Object* b) {
return Slime::lisp_object_equal(a, b);
}
unsigned int hm_hash(char* str) {
unsigned int value = str[0] << 7;
int i = 0;
while (str[i]) {
value = (10000003 * value) ^ str[i++];
}
return value ^ i;
}
unsigned int hm_hash(void* ptr) {
return ((unsigned long long)ptr * 2654435761) % 4294967296;
}
unsigned int hm_hash(Slime::Lisp_Object* obj) {
using namespace Slime;
switch (Memory::get_type(obj)) {
// hash from adress: if two objects of these types have
// different addresses, they are different
case Lisp_Object_Type::Function:
case Lisp_Object_Type::Symbol:
case Lisp_Object_Type::Keyword:
case Lisp_Object_Type::Continuation:
case Lisp_Object_Type::Nil:
case Lisp_Object_Type::T:
return hm_hash((void*) obj);
// hash from contents: even if objects are themselved
// different, they cauld be equivalent:
case Lisp_Object_Type::Pointer: return hm_hash((void*) obj->value.pointer);
case Lisp_Object_Type::Number: return hm_hash((void*) (unsigned long long)obj->value.number); // HACK(Felix): yes
case Lisp_Object_Type::String: return hm_hash((char*) &obj->value.string->data);
case Lisp_Object_Type::Pair: {
u32 hash = 1;
for_lisp_list (obj) {
hash <<= 1;
hash += hm_hash(it);
}
return hash;
} break;
case Lisp_Object_Type::Vector:
case Lisp_Object_Type::HashMap:
default:
create_not_yet_implemented_error();
return 0;
}
}
# include "globals.cpp"
# include "memory.cpp"
# include "gc.cpp"
# include "lisp_object.cpp"
# include "error.cpp"
# include "io.cpp"
# include "env.cpp"
# include "parse.cpp"
# include "eval.cpp"
# include "visualization.cpp"
# include "docgeneration.cpp"
# include "built_ins.cpp"
# include "testing.cpp"
// # include "undefines.cpp"
#define _CRT_SECURE_NO_WARNINGS
#define _CRT_SECURE_NO_DEPRECATE
#include <stdlib.h>
#include <stdio.h>
#include <time.h>
#include <string.h>
#include <cmath>
#include <ctype.h>
#include <stdarg.h>
#include <errno.h>
#include <new>
#ifdef _MSC_VER
# include <direct.h>
# include <windows.h>
#else
# include <unistd.h>
# include <signal.h>
#endif
/*
Forward declare the hash functions for the hashmap (needed at least
for clang++)
*/
namespace Slime {struct Lisp_Object;}
bool hm_objects_match(char* a, char* b);
bool hm_objects_match(void* a, void* b);
bool hm_objects_match(Slime::Lisp_Object* a, Slime::Lisp_Object* b);
unsigned int hm_hash(char* str);
unsigned int hm_hash(void* ptr);
unsigned int hm_hash(Slime::Lisp_Object* obj);
#include "ftb/hashmap.hpp"
#include "ftb/types.hpp"
#include "ftb/arraylist.hpp"
#include "ftb/bucket_allocator.hpp"
#include "ftb/macros.hpp"
#include "ftb/profiler.hpp"
# include "defines.cpp"
# include "assert.hpp"
# include "define_macros.hpp"
# include "platform.cpp"
# include "structs.cpp"
# include "forward_decls.cpp"
bool hm_objects_match(char* a, char* b) {
return strcmp(a, b) == 0;
}
bool hm_objects_match(void* a, void* b) {
return a == b;
}
bool hm_objects_match(Slime::Lisp_Object* a, Slime::Lisp_Object* b) {
return Slime::lisp_object_equal(a, b);
}
unsigned int hm_hash(char* str) {
unsigned int value = str[0] << 7;
int i = 0;
while (str[i]) {
value = (10000003 * value) ^ str[i++];
}
return value ^ i;
}
unsigned int hm_hash(void* ptr) {
return ((unsigned long long)ptr * 2654435761) % 4294967296;
}
unsigned int hm_hash(Slime::Lisp_Object* obj) {
using namespace Slime;
switch (Memory::get_type(obj)) {
// hash from adress: if two objects of these types have
// different addresses, they are different
case Lisp_Object_Type::Function:
case Lisp_Object_Type::Symbol:
case Lisp_Object_Type::Keyword:
case Lisp_Object_Type::Continuation:
case Lisp_Object_Type::Nil:
case Lisp_Object_Type::T:
return hm_hash((void*) obj);
// hash from contents: even if objects are themselved
// different, they cauld be equivalent:
case Lisp_Object_Type::Pointer: return hm_hash((void*) obj->value.pointer);
case Lisp_Object_Type::Number: return hm_hash((void*) (unsigned long long)obj->value.number); // HACK(Felix): yes
case Lisp_Object_Type::String: return hm_hash((char*) &obj->value.string->data);
case Lisp_Object_Type::Pair: {
u32 hash = 1;
for_lisp_list (obj) {
hash <<= 1;
hash += hm_hash(it);
}
return hash;
} break;
case Lisp_Object_Type::Vector:
case Lisp_Object_Type::HashMap:
default:
create_not_yet_implemented_error();
return 0;
}
}
# include "globals.cpp"
# include "memory.cpp"
# include "gc.cpp"
# include "lisp_object.cpp"
# include "error.cpp"
# include "io.cpp"
# include "env.cpp"
# include "parse.cpp"
# include "eval.cpp"
# include "visualization.cpp"
# include "docgeneration.cpp"
# include "built_ins.cpp"
# include "testing.cpp"
// # include "undefines.cpp"
src/lisp_object.cpp
+45 -48
View File
@@ -1,48 +1,45 @@
namespace Slime {
proc create_source_code_location(String* file, int line, int col) -> Source_Code_Location* {
if (!file)
return nullptr;
Source_Code_Location* ret = (Source_Code_Location*)malloc(sizeof(Source_Code_Location));
ret->file = file;
ret->line = line;
ret->column = col;
return ret;
}
proc Lisp_Object_Type_to_string(Lisp_Object_Type type) -> const char* {
switch (type) {
case(Lisp_Object_Type::Nil): return "nil";
case(Lisp_Object_Type::T): return "t";
case(Lisp_Object_Type::Number): return "number";
case(Lisp_Object_Type::String): return "string";
case(Lisp_Object_Type::Symbol): return "symbol";
case(Lisp_Object_Type::Keyword): return "keyword";
case(Lisp_Object_Type::Function): return "function";
case(Lisp_Object_Type::Continuation): return "continuation";
case(Lisp_Object_Type::Pair): return "pair";
case(Lisp_Object_Type::Vector): return "vector";
case(Lisp_Object_Type::Pointer): return "pointer";
case(Lisp_Object_Type::HashMap): return "hashmap";
}
return "unknown";
}
Lisp_Object::~Lisp_Object() {
free(sourceCodeLocation);
sourceCodeLocation = 0;
switch (Memory::get_type(this)) {
case Lisp_Object_Type::HashMap: {
delete this->value.hashMap;
} break;
case Lisp_Object_Type::Function:{
this->value.function->args.positional.symbols.dealloc();
this->value.function->args.keyword.keywords.dealloc();
this->value.function->args.keyword.values.dealloc();
free(this->value.function);
} break;
default: break;
}
}
}
namespace Slime {
proc create_source_code_location(String* file, int line, int col) -> Source_Code_Location* {
if (!file)
return nullptr;
Source_Code_Location* ret = (Source_Code_Location*)malloc(sizeof(Source_Code_Location));
ret->file = file;
ret->line = line;
ret->column = col;
return ret;
}
proc Lisp_Object_Type_to_string(Lisp_Object_Type type) -> const char* {
switch (type) {
case(Lisp_Object_Type::Nil): return "nil";
case(Lisp_Object_Type::T): return "t";
case(Lisp_Object_Type::Number): return "number";
case(Lisp_Object_Type::String): return "string";
case(Lisp_Object_Type::Symbol): return "symbol";
case(Lisp_Object_Type::Keyword): return "keyword";
case(Lisp_Object_Type::Function): return "function";
case(Lisp_Object_Type::Continuation): return "continuation";
case(Lisp_Object_Type::Pair): return "pair";
case(Lisp_Object_Type::Vector): return "vector";
case(Lisp_Object_Type::Pointer): return "pointer";
case(Lisp_Object_Type::HashMap): return "hashmap";
}
return "unknown";
}
Lisp_Object::~Lisp_Object() {
free(sourceCodeLocation);
sourceCodeLocation = 0;
switch (Memory::get_type(this)) {
case Lisp_Object_Type::Function:{
this->value.function->args.positional.symbols.dealloc();
this->value.function->args.keyword.keywords.dealloc();
this->value.function->args.keyword.values.dealloc();
free(this->value.function);
} break;
default: break;
}
}
}
src/main.cpp
+33 -33
View File
@@ -1,33 +1,33 @@
#include "libslime.cpp"
int main(int argc, char* argv[]) {
#ifdef _MSC_VER
// enable colored terminal output for windows
HANDLE hOut = GetStdHandle(STD_OUTPUT_HANDLE);
DWORD dwMode = 0;
GetConsoleMode(hOut, &dwMode);
dwMode |= ENABLE_VIRTUAL_TERMINAL_PROCESSING;
SetConsoleMode(hOut, dwMode);
#endif
if (argc > 1) {
if (Slime::string_equal(argv[1], "--run-tests")) {
int res = Slime::run_all_tests();
return res ? 0 : 1;
} else if (Slime::string_equal(argv[1], "--generate-docs")) {
Slime::Memory::init(4096 * 256* 100);
if (Slime::Globals::error) return 1;
Slime::built_in_load(Slime::Memory::create_string("generate-docs.slime"));
Slime::Memory::free_everything();
} else {
Slime::interprete_file(argv[1]);
}
} else {
Slime::interprete_stdin();
return 0;
}
if (Slime::Globals::error) return 1;
}
#include "libslime.cpp"
int main(int argc, char* argv[]) {
#ifdef _MSC_VER
// enable colored terminal output for windows
HANDLE hOut = GetStdHandle(STD_OUTPUT_HANDLE);
DWORD dwMode = 0;
GetConsoleMode(hOut, &dwMode);
dwMode |= ENABLE_VIRTUAL_TERMINAL_PROCESSING;
SetConsoleMode(hOut, dwMode);
#endif
if (argc > 1) {
if (Slime::string_equal(argv[1], "--run-tests")) {
int res = Slime::run_all_tests();
return res ? 0 : 1;
} else if (Slime::string_equal(argv[1], "--generate-docs")) {
Slime::Memory::init(4096 * 256* 100);
if (Slime::Globals::error) return 1;
Slime::built_in_load(Slime::Memory::create_string("generate-docs.slime"));
Slime::Memory::free_everything();
} else {
Slime::interprete_file(argv[1]);
}
} else {
Slime::interprete_stdin();
return 0;
}
if (Slime::Globals::error) return 1;
}
src/memory.cpp
+565 -543
View File
File diff suppressed because it is too large Load Diff
src/parse.cpp
+399 -399
View File
@@ -1,399 +1,399 @@
namespace Slime::Parser {
String* standard_in;
String* parser_file;
int parser_line;
int parser_col;
proc eat_comment_line(char* text, int* index_in_text) -> void {
// safety check if we are actually starting a comment here
if (text[*index_in_text] != ';')
return;
// eat the comment line
do {
++(*index_in_text);
++parser_col;
} while (text[(*index_in_text)] != '\n' &&
text[(*index_in_text)] != '\r' &&
text[(*index_in_text)] != '\0');
}
proc step_char(char* text, int* index_in_text, int steps = 1) {
for (int i = 0; i < steps; ++i) {
if (text[(*index_in_text)] == '\n') {
++parser_line;
parser_col = 0;
}
++parser_col;
++(*index_in_text);
}
}
proc eat_whitespace(char* text, int* index_in_text) -> void {
// skip whitespaces
while (text[(*index_in_text)] == ' ' ||
text[(*index_in_text)] == '\t' ||
text[(*index_in_text)] == '\n' ||
text[(*index_in_text)] == '\r')
{
step_char(text, index_in_text);
}
}
proc eat_until_code(char* text, int* index_in_text) -> void {
profile_this();
int position_before;
do {
position_before = *index_in_text;
eat_comment_line(text, index_in_text);
eat_whitespace(text, index_in_text);
} while (position_before != *index_in_text);
}
proc step_char_and_eat_until_code(char* text, int* index_in_text) {
step_char(text, index_in_text);
eat_until_code(text, index_in_text);
}
proc parse_fancy_delimiter(char* text, int* index_in_text, char l_delimiter, char r_delimiter, Lisp_Object* first_elem) -> Lisp_Object* {
profile_this();
if (text[*index_in_text] != l_delimiter) {
create_parsing_error("a fancy cannot be parsed here");
return nullptr;
}
Lisp_Object* ret;
Lisp_Object* head;
try ret = Memory::create_lisp_object_pair(first_elem, Memory::nil);
head = ret;
step_char(text, index_in_text);
eat_until_code(text, index_in_text);
while (text[*index_in_text] != r_delimiter) {
Lisp_Object* element;
try element = parse_expression(text, index_in_text);
try head->value.pair.rest = Memory::create_lisp_object_pair(element, Memory::nil);
head = head->value.pair.rest;
eat_until_code(text, index_in_text);
}
step_char(text, index_in_text);
return ret;
}
proc get_atom_text_length(char* text, int* index_in_text) -> int {
int atom_length = 0;
while (text[*index_in_text+atom_length] != ' ' &&
text[*index_in_text+atom_length] != ')' &&
text[*index_in_text+atom_length] != '(' &&
text[*index_in_text+atom_length] != '[' &&
text[*index_in_text+atom_length] != ']' &&
text[*index_in_text+atom_length] != '{' &&
text[*index_in_text+atom_length] != '}' &&
text[*index_in_text+atom_length] != '\0' &&
text[*index_in_text+atom_length] != '\n' &&
text[*index_in_text+atom_length] != '\r' &&
text[*index_in_text+atom_length] != '\t')
{
++atom_length;
}
return atom_length;
}
proc parse_number(char* text, int* index_in_text) -> Lisp_Object* {
Lisp_Object* ret;
try ret = Memory::create_lisp_object(0.0);
sscanf(text+*index_in_text, "%lf", &ret->value.number);
int atom_length = get_atom_text_length(text, index_in_text);
step_char(text, index_in_text, atom_length);
return ret;
}
proc parse_symbol_or_keyword(char* text, int* index_in_text) -> Lisp_Object* {
bool keyword = false;
if (text[*index_in_text] == ':') {
keyword = true;
step_char(text, index_in_text);
}
int atom_length = get_atom_text_length(text, index_in_text);
char orig = text[*index_in_text+atom_length];
text[*index_in_text+atom_length] = '\0';
String* str_keyword;
Lisp_Object* ret;
try str_keyword = Memory::create_string("", atom_length);
strcpy(&str_keyword->data, text+*index_in_text);
if (keyword) {
try ret = Memory::get_keyword(str_keyword);
} else {
try ret = Memory::get_symbol(str_keyword);
}
text[*index_in_text+atom_length] = orig;
step_char(text, index_in_text, atom_length);
return ret;
}
proc parse_string(char* text, int* index_in_text) -> Lisp_Object* {
// the first character is the '"'
step_char(text, index_in_text);
// now we are at the first letter, if this is the closing '"' then
// it's easy
if (text[*index_in_text] == '"') {
Lisp_Object* ret;
try ret = Memory::create_lisp_object(Memory::create_string("", 0));
// inject_scl(ret);
// plus one because we want to go after the quotes
step_char(text, index_in_text);
return ret;
}
// okay so the first letter was not actually closing the string...
int string_length = 0;
bool escaping = false;
while (escaping || text[*index_in_text+string_length] != '"') {
if (escaping) {
escaping = false;
}
else
if (text[*index_in_text+string_length] == '\\')
escaping = true;
++string_length;
}
// we found the end of the string
text[*index_in_text+string_length] = '\0';
// NOTE(Felix): Tactic: Through unescaping the string will
// only get shorter, so we replace it inplace and later jump
// to the original end of the string.
int new_len;
try new_len = unescape_string(text+(*index_in_text));
String* string = Memory::create_string("", new_len);
strcpy(&string->data, text+(*index_in_text));
// printf("------ %s\n", &string->data);
text[*index_in_text+string_length] = '"';
// plus one because we want to go after the quotes
step_char(text, index_in_text, string_length+1);
Lisp_Object* ret;
try ret = Memory::create_lisp_object(string);
// inject_scl(ret);
return ret;
}
proc parse_atom(char* text, int* index_in_text) -> Lisp_Object* {
profile_this();
Lisp_Object* ret;
// numbers
if ((text[*index_in_text] <= 57 && // if number
text[*index_in_text] >= 48)
||
((text[*index_in_text] == '+' || // or if sign and then number
text[*index_in_text] == '-')
&&
(text[*index_in_text +1] <= 57 &&
text[*index_in_text +1] >= 48))
||
((text[*index_in_text] == '.') // or if . and then number
&&
(text[*index_in_text +1] <= 57 &&
text[*index_in_text +1] >= 48)))
{
try ret = parse_number(text, index_in_text);
}
else if (text[*index_in_text] == '"')
try ret = parse_string(text, index_in_text);
else
try ret = parse_symbol_or_keyword(text, index_in_text);
return ret;
}
proc parse_list(char* text, int* index_in_text) -> Lisp_Object* {
profile_this();
if (text[*index_in_text] != '(') {
create_parsing_error("a list cannot be parsed here");
return nullptr;
}
step_char_and_eat_until_code(text, index_in_text);
if (text[*index_in_text] == ')') {
step_char(text, index_in_text);
return Memory::nil;
}
Lisp_Object* first_elem;
Lisp_Object* ret;
Lisp_Object* head;
try first_elem = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(first_elem, Memory::nil);
head = ret;
eat_until_code(text, index_in_text);
while (text[*index_in_text] != ')') {
Lisp_Object* element;
if (text[*index_in_text+0] == '.' &&
text[*index_in_text+1] == ' ')
{
step_char(text, index_in_text, 2);
try element = parse_expression(text, index_in_text);
head->value.pair.rest = element;
eat_until_code(text, index_in_text);
if (text[*index_in_text] != ')') {
create_parsing_error("expected the list to end after the dotted end.");
return nullptr;
}
step_char(text, index_in_text);
return ret;
}
try element = parse_expression(text, index_in_text);
try head->value.pair.rest = Memory::create_lisp_object_pair(element, Memory::nil);
head = head->value.pair.rest;
eat_until_code(text, index_in_text);
}
step_char(text, index_in_text);
return ret;
}
proc maybe_expand_short_form(char* text, int* index_in_text) -> Lisp_Object* {
profile_this();
Lisp_Object* vector_sym = Memory::get_symbol("vector");
Lisp_Object* hash_map_sym = Memory::get_symbol("hash-map");
Lisp_Object* quote_sym = Memory::get_symbol("quote");
Lisp_Object* quasiquote_sym = Memory::get_symbol("quasiquote");
Lisp_Object* unquote_sym = Memory::get_symbol("unquote");
Lisp_Object* unquote_splicing_sym = Memory::get_symbol("unquote-splicing");
Lisp_Object* ret = nullptr;
Lisp_Object* expr;
switch (text[*index_in_text]) {
case '\'': {
// quote
step_char_and_eat_until_code(text, index_in_text);
try expr = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(expr, Memory::nil);
try ret = Memory::create_lisp_object_pair(quote_sym, ret);
} break;
case '`': {
// quasiquote
step_char_and_eat_until_code(text, index_in_text);
try expr = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(expr, Memory::nil);
try ret = Memory::create_lisp_object_pair(quasiquote_sym, ret);
} break;
case ',': {
step_char_and_eat_until_code(text, index_in_text);
if (text[*index_in_text] == '@') {
// unquote-splicing
step_char_and_eat_until_code(text, index_in_text);
try expr = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(expr, Memory::nil);
try ret = Memory::create_lisp_object_pair(unquote_splicing_sym, ret);
} else {
// unquote
try expr = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(expr, Memory::nil);
try ret = Memory::create_lisp_object_pair(unquote_sym, ret);
}
} break;
case '[': {
// vector
try ret = parse_fancy_delimiter(text, index_in_text, '[', ']', vector_sym);
} break;
case '{': {
// hashmap
try ret = parse_fancy_delimiter(text, index_in_text, '{', '}', hash_map_sym);
} break;
default: break;
}
return ret;
}
proc parse_expression(char* text, int* index_in_text) -> Lisp_Object* {
profile_this();
Lisp_Object* ret;
eat_until_code(text, index_in_text);
try ret = maybe_expand_short_form(text, index_in_text);
if (ret)
return ret;
if (text[*index_in_text] == '(') {
try ret = parse_list(text, index_in_text);
} else {
try ret = parse_atom(text, index_in_text);
}
return ret;
}
proc parse_single_expression(wchar_t* text) -> Lisp_Object* {
char* res = wchar_to_char(text);
defer {free(res);};
return parse_single_expression(res);
}
proc parse_single_expression(char* text) -> Lisp_Object* {
parser_file = standard_in;
parser_line = 1;
parser_col = 1;
int index_in_text = 0;
Lisp_Object* ret;
try ret = parse_expression(text, &index_in_text);
return ret;
}
proc parse_program(String* file_name, char* text) -> Array_List<Lisp_Object*>* {
profile_this();
parser_file = file_name;
parser_line = 1;
parser_col = 0;
Array_List<Lisp_Object*>* program = (Array_List<Lisp_Object*>*)malloc(sizeof(Array_List<Lisp_Object*>));
program->alloc();
int index_in_text = 0;
Lisp_Object* parsed;
eat_until_code(text, &index_in_text);
while (text[index_in_text] != '\0') {
try parsed = parse_expression(text, &index_in_text);
program->append(parsed);
eat_until_code(text, &index_in_text);
}
return program;
}
}
namespace Slime::Parser {
String* standard_in;
String* parser_file;
int parser_line;
int parser_col;
proc eat_comment_line(char* text, int* index_in_text) -> void {
// safety check if we are actually starting a comment here
if (text[*index_in_text] != ';')
return;
// eat the comment line
do {
++(*index_in_text);
++parser_col;
} while (text[(*index_in_text)] != '\n' &&
text[(*index_in_text)] != '\r' &&
text[(*index_in_text)] != '\0');
}
proc step_char(char* text, int* index_in_text, int steps = 1) {
for (int i = 0; i < steps; ++i) {
if (text[(*index_in_text)] == '\n') {
++parser_line;
parser_col = 0;
}
++parser_col;
++(*index_in_text);
}
}
proc eat_whitespace(char* text, int* index_in_text) -> void {
// skip whitespaces
while (text[(*index_in_text)] == ' ' ||
text[(*index_in_text)] == '\t' ||
text[(*index_in_text)] == '\n' ||
text[(*index_in_text)] == '\r')
{
step_char(text, index_in_text);
}
}
proc eat_until_code(char* text, int* index_in_text) -> void {
profile_this();
int position_before;
do {
position_before = *index_in_text;
eat_comment_line(text, index_in_text);
eat_whitespace(text, index_in_text);
} while (position_before != *index_in_text);
}
proc step_char_and_eat_until_code(char* text, int* index_in_text) {
step_char(text, index_in_text);
eat_until_code(text, index_in_text);
}
proc parse_fancy_delimiter(char* text, int* index_in_text, char l_delimiter, char r_delimiter, Lisp_Object* first_elem) -> Lisp_Object* {
profile_this();
if (text[*index_in_text] != l_delimiter) {
create_parsing_error("a fancy cannot be parsed here");
return nullptr;
}
Lisp_Object* ret;
Lisp_Object* head;
try ret = Memory::create_lisp_object_pair(first_elem, Memory::nil);
head = ret;
step_char(text, index_in_text);
eat_until_code(text, index_in_text);
while (text[*index_in_text] != r_delimiter) {
Lisp_Object* element;
try element = parse_expression(text, index_in_text);
try head->value.pair.rest = Memory::create_lisp_object_pair(element, Memory::nil);
head = head->value.pair.rest;
eat_until_code(text, index_in_text);
}
step_char(text, index_in_text);
return ret;
}
proc get_atom_text_length(char* text, int* index_in_text) -> int {
int atom_length = 0;
while (text[*index_in_text+atom_length] != ' ' &&
text[*index_in_text+atom_length] != ')' &&
text[*index_in_text+atom_length] != '(' &&
text[*index_in_text+atom_length] != '[' &&
text[*index_in_text+atom_length] != ']' &&
text[*index_in_text+atom_length] != '{' &&
text[*index_in_text+atom_length] != '}' &&
text[*index_in_text+atom_length] != '\0' &&
text[*index_in_text+atom_length] != '\n' &&
text[*index_in_text+atom_length] != '\r' &&
text[*index_in_text+atom_length] != '\t')
{
++atom_length;
}
return atom_length;
}
proc parse_number(char* text, int* index_in_text) -> Lisp_Object* {
Lisp_Object* ret;
try ret = Memory::create_lisp_object(0.0);
sscanf(text+*index_in_text, "%lf", &ret->value.number);
int atom_length = get_atom_text_length(text, index_in_text);
step_char(text, index_in_text, atom_length);
return ret;
}
proc parse_symbol_or_keyword(char* text, int* index_in_text) -> Lisp_Object* {
bool keyword = false;
if (text[*index_in_text] == ':') {
keyword = true;
step_char(text, index_in_text);
}
int atom_length = get_atom_text_length(text, index_in_text);
char orig = text[*index_in_text+atom_length];
text[*index_in_text+atom_length] = '\0';
String* str_keyword;
Lisp_Object* ret;
try str_keyword = Memory::create_string("", atom_length);
strcpy(&str_keyword->data, text+*index_in_text);
if (keyword) {
try ret = Memory::get_keyword(str_keyword);
} else {
try ret = Memory::get_symbol(str_keyword);
}
text[*index_in_text+atom_length] = orig;
step_char(text, index_in_text, atom_length);
return ret;
}
proc parse_string(char* text, int* index_in_text) -> Lisp_Object* {
// the first character is the '"'
step_char(text, index_in_text);
// now we are at the first letter, if this is the closing '"' then
// it's easy
if (text[*index_in_text] == '"') {
Lisp_Object* ret;
try ret = Memory::create_lisp_object(Memory::create_string("", 0));
// inject_scl(ret);
// plus one because we want to go after the quotes
step_char(text, index_in_text);
return ret;
}
// okay so the first letter was not actually closing the string...
int string_length = 0;
bool escaping = false;
while (escaping || text[*index_in_text+string_length] != '"') {
if (escaping) {
escaping = false;
}
else
if (text[*index_in_text+string_length] == '\\')
escaping = true;
++string_length;
}
// we found the end of the string
text[*index_in_text+string_length] = '\0';
// NOTE(Felix): Tactic: Through unescaping the string will
// only get shorter, so we replace it inplace and later jump
// to the original end of the string.
int new_len;
try new_len = unescape_string(text+(*index_in_text));
String* string = Memory::create_string("", new_len);
strcpy(&string->data, text+(*index_in_text));
// printf("------ %s\n", &string->data);
text[*index_in_text+string_length] = '"';
// plus one because we want to go after the quotes
step_char(text, index_in_text, string_length+1);
Lisp_Object* ret;
try ret = Memory::create_lisp_object(string);
// inject_scl(ret);
return ret;
}
proc parse_atom(char* text, int* index_in_text) -> Lisp_Object* {
profile_this();
Lisp_Object* ret;
// numbers
if ((text[*index_in_text] <= 57 && // if number
text[*index_in_text] >= 48)
||
((text[*index_in_text] == '+' || // or if sign and then number
text[*index_in_text] == '-')
&&
(text[*index_in_text +1] <= 57 &&
text[*index_in_text +1] >= 48))
||
((text[*index_in_text] == '.') // or if . and then number
&&
(text[*index_in_text +1] <= 57 &&
text[*index_in_text +1] >= 48)))
{
try ret = parse_number(text, index_in_text);
}
else if (text[*index_in_text] == '"')
try ret = parse_string(text, index_in_text);
else
try ret = parse_symbol_or_keyword(text, index_in_text);
return ret;
}
proc parse_list(char* text, int* index_in_text) -> Lisp_Object* {
profile_this();
if (text[*index_in_text] != '(') {
create_parsing_error("a list cannot be parsed here");
return nullptr;
}
step_char_and_eat_until_code(text, index_in_text);
if (text[*index_in_text] == ')') {
step_char(text, index_in_text);
return Memory::nil;
}
Lisp_Object* first_elem;
Lisp_Object* ret;
Lisp_Object* head;
try first_elem = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(first_elem, Memory::nil);
head = ret;
eat_until_code(text, index_in_text);
while (text[*index_in_text] != ')') {
Lisp_Object* element;
if (text[*index_in_text+0] == '.' &&
text[*index_in_text+1] == ' ')
{
step_char(text, index_in_text, 2);
try element = parse_expression(text, index_in_text);
head->value.pair.rest = element;
eat_until_code(text, index_in_text);
if (text[*index_in_text] != ')') {
create_parsing_error("expected the list to end after the dotted end.");
return nullptr;
}
step_char(text, index_in_text);
return ret;
}
try element = parse_expression(text, index_in_text);
try head->value.pair.rest = Memory::create_lisp_object_pair(element, Memory::nil);
head = head->value.pair.rest;
eat_until_code(text, index_in_text);
}
step_char(text, index_in_text);
return ret;
}
proc maybe_expand_short_form(char* text, int* index_in_text) -> Lisp_Object* {
profile_this();
Lisp_Object* vector_sym = Memory::get_symbol("vector");
Lisp_Object* hash_map_sym = Memory::get_symbol("hash-map");
Lisp_Object* quote_sym = Memory::get_symbol("quote");
Lisp_Object* quasiquote_sym = Memory::get_symbol("quasiquote");
Lisp_Object* unquote_sym = Memory::get_symbol("unquote");
Lisp_Object* unquote_splicing_sym = Memory::get_symbol("unquote-splicing");
Lisp_Object* ret = nullptr;
Lisp_Object* expr;
switch (text[*index_in_text]) {
case '\'': {
// quote
step_char_and_eat_until_code(text, index_in_text);
try expr = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(expr, Memory::nil);
try ret = Memory::create_lisp_object_pair(quote_sym, ret);
} break;
case '`': {
// quasiquote
step_char_and_eat_until_code(text, index_in_text);
try expr = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(expr, Memory::nil);
try ret = Memory::create_lisp_object_pair(quasiquote_sym, ret);
} break;
case ',': {
step_char_and_eat_until_code(text, index_in_text);
if (text[*index_in_text] == '@') {
// unquote-splicing
step_char_and_eat_until_code(text, index_in_text);
try expr = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(expr, Memory::nil);
try ret = Memory::create_lisp_object_pair(unquote_splicing_sym, ret);
} else {
// unquote
try expr = parse_expression(text, index_in_text);
try ret = Memory::create_lisp_object_pair(expr, Memory::nil);
try ret = Memory::create_lisp_object_pair(unquote_sym, ret);
}
} break;
case '[': {
// vector
try ret = parse_fancy_delimiter(text, index_in_text, '[', ']', vector_sym);
} break;
case '{': {
// hashmap
try ret = parse_fancy_delimiter(text, index_in_text, '{', '}', hash_map_sym);
} break;
default: break;
}
return ret;
}
proc parse_expression(char* text, int* index_in_text) -> Lisp_Object* {
profile_this();
Lisp_Object* ret;
eat_until_code(text, index_in_text);
try ret = maybe_expand_short_form(text, index_in_text);
if (ret)
return ret;
if (text[*index_in_text] == '(') {
try ret = parse_list(text, index_in_text);
} else {
try ret = parse_atom(text, index_in_text);
}
return ret;
}
proc parse_single_expression(wchar_t* text) -> Lisp_Object* {
char* res = wchar_to_char(text);
defer {free(res);};
return parse_single_expression(res);
}
proc parse_single_expression(char* text) -> Lisp_Object* {
parser_file = standard_in;
parser_line = 1;
parser_col = 1;
int index_in_text = 0;
Lisp_Object* ret;
try ret = parse_expression(text, &index_in_text);
return ret;
}
proc parse_program(String* file_name, char* text) -> Array_List<Lisp_Object*>* {
profile_this();
parser_file = file_name;
parser_line = 1;
parser_col = 0;
Array_List<Lisp_Object*>* program = (Array_List<Lisp_Object*>*)malloc(sizeof(Array_List<Lisp_Object*>));
program->alloc();
int index_in_text = 0;
Lisp_Object* parsed;
eat_until_code(text, &index_in_text);
while (text[index_in_text] != '\0') {
try parsed = parse_expression(text, &index_in_text);
program->append(parsed);
eat_until_code(text, &index_in_text);
}
return program;
}
}
src/platform.cpp
+170 -170
View File
@@ -1,170 +1,170 @@
namespace Slime {
inline proc get_cwd() -> char* {
const int buf_size = 2048;
char* res = (char*)malloc(buf_size * sizeof(char));
#ifdef _MSC_VER
_getcwd(res, buf_size);
#else
getcwd(res, buf_size);
#endif
return res;
}
inline proc change_cwd(char* dir) -> void {
#ifdef _MSC_VER
_chdir(dir);
#else
chdir(dir);
#endif
}
#ifdef _MSC_VER
int vasprintf(char **strp, const char *fmt, va_list ap) {
// _vscprintf tells you how big the buffer needs to be
int len = _vscprintf(fmt, ap);
if (len == -1) {
return -1;
}
size_t size = (size_t)len + 1;
char *str = (char*)malloc(size);
if (!str) {
return -1;
}
// _vsprintf_s is the "secure" version of vsprintf
int r = vsprintf_s(str, len + 1, fmt, ap);
if (r == -1) {
free(str);
return -1;
}
*strp = str;
return r;
}
int asprintf(char **strp, const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
int r = vasprintf(strp, fmt, ap);
va_end(ap);
return r;
}
#endif
proc get_exe_dir() -> char* {
#ifdef _MSC_VER
DWORD last_error;
DWORD result;
DWORD path_size = 1024;
char* path = (char*)malloc(1024);
while (true) {
memset(path, 0, path_size);
result = GetModuleFileName(0, path, path_size - 1);
last_error = GetLastError();
if (0 == result) {
free(path);
path = 0;
break;
}
else if (result == path_size - 1) {
free(path);
/* May need to also check for ERROR_SUCCESS here if XP/2K */
if (ERROR_INSUFFICIENT_BUFFER != last_error) {
path = 0;
break;
}
path_size = path_size * 2;
path = (char*)malloc(path_size);
}
else
break;
}
if (!path) {
fprintf(stderr, "Failure: %ld\n", last_error);
return nullptr;
}
else {
// remove the exe name, so we are only left with the path
int index_in_path = -1;
int last_backslash = -1;
char c;
while ((c = path[++index_in_path]) != '\0') {
if (c == '\\')
last_backslash = index_in_path;
}
// we are assuming there are some backslashes
path[last_backslash+1] = '\0';
return path;
}
#else
ssize_t size = 512, i, n;
char *path, *temp;
while (1) {
size_t used;
path = (char*)malloc(size);
if (!path) {
errno = ENOMEM;
return NULL;
}
used = readlink("/proc/self/exe", path, size);
if (used == -1) {
const int saved_errno = errno;
free(path);
errno = saved_errno;
return NULL;
} else
if (used < 1) {
free(path);
errno = EIO;
return NULL;
}
if ((size_t)used >= size) {
free(path);
size = (size | 2047) + 2049;
continue;
}
size = (size_t)used;
break;
}
/* Find final slash. */
n = 0;
for (i = 0; i < size; i++)
if (path[i] == '/')
n = i;
/* Optimize allocated size,
ensuring there is room for
a final slash and a
string-terminating '\0', */
temp = path;
path = (char*)realloc(temp, n + 2);
if (!path) {
free(temp);
errno = ENOMEM;
return NULL;
}
/* and properly trim and terminate the path string. */
path[n+0] = '/';
path[n+1] = '\0';
return path;
#endif
}
}
namespace Slime {
inline proc get_cwd() -> char* {
const int buf_size = 2048;
char* res = (char*)malloc(buf_size * sizeof(char));
#ifdef _MSC_VER
_getcwd(res, buf_size);
#else
getcwd(res, buf_size);
#endif
return res;
}
inline proc change_cwd(char* dir) -> void {
#ifdef _MSC_VER
_chdir(dir);
#else
chdir(dir);
#endif
}
#ifdef _MSC_VER
int vasprintf(char **strp, const char *fmt, va_list ap) {
// _vscprintf tells you how big the buffer needs to be
int len = _vscprintf(fmt, ap);
if (len == -1) {
return -1;
}
size_t size = (size_t)len + 1;
char *str = (char*)malloc(size);
if (!str) {
return -1;
}
// _vsprintf_s is the "secure" version of vsprintf
int r = vsprintf_s(str, len + 1, fmt, ap);
if (r == -1) {
free(str);
return -1;
}
*strp = str;
return r;
}
int asprintf(char **strp, const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
int r = vasprintf(strp, fmt, ap);
va_end(ap);
return r;
}
#endif
proc get_exe_dir() -> char* {
#ifdef _MSC_VER
DWORD last_error;
DWORD result;
DWORD path_size = 1024;
char* path = (char*)malloc(1024);
while (true) {
memset(path, 0, path_size);
result = GetModuleFileName(0, path, path_size - 1);
last_error = GetLastError();
if (0 == result) {
free(path);
path = 0;
break;
}
else if (result == path_size - 1) {
free(path);
/* May need to also check for ERROR_SUCCESS here if XP/2K */
if (ERROR_INSUFFICIENT_BUFFER != last_error) {
path = 0;
break;
}
path_size = path_size * 2;
path = (char*)malloc(path_size);
}
else
break;
}
if (!path) {
fprintf(stderr, "Failure: %ld\n", last_error);
return nullptr;
}
else {
// remove the exe name, so we are only left with the path
int index_in_path = -1;
int last_backslash = -1;
char c;
while ((c = path[++index_in_path]) != '\0') {
if (c == '\\')
last_backslash = index_in_path;
}
// we are assuming there are some backslashes
path[last_backslash+1] = '\0';
return path;
}
#else
ssize_t size = 512, i, n;
char *path, *temp;
while (1) {
size_t used;
path = (char*)malloc(size);
if (!path) {
errno = ENOMEM;
return NULL;
}
used = readlink("/proc/self/exe", path, size);
if (used == -1) {
const int saved_errno = errno;
free(path);
errno = saved_errno;
return NULL;
} else
if (used < 1) {
free(path);
errno = EIO;
return NULL;
}
if ((size_t)used >= size) {
free(path);
size = (size | 2047) + 2049;
continue;
}
size = (size_t)used;
break;
}
/* Find final slash. */
n = 0;
for (i = 0; i < size; i++)
if (path[i] == '/')
n = i;
/* Optimize allocated size,
ensuring there is room for
a final slash and a
string-terminating '\0', */
temp = path;
path = (char*)realloc(temp, n + 2);
if (!path) {
free(temp);
errno = ENOMEM;
return NULL;
}
/* and properly trim and terminate the path string. */
path[n+0] = '/';
path[n+1] = '\0';
return path;
#endif
}
}
src/structs.cpp
-4
View File
@@ -112,10 +112,6 @@ namespace Slime {
struct Environment {
Array_List<Environment*> parents;
Hash_Map<void*, Lisp_Object*> hm;
~Environment() {
hm.~Hash_Map();
}
};
struct Function {
src/testing.cpp
+621 -622
View File
File diff suppressed because it is too large Load Diff
src/visualization.cpp
+556 -556
View File
File diff suppressed because it is too large Load Diff