#include "builtins.h" #include "lexer.h" #include "object.h" #include "parser.h" #include "tokens.h" #include #include #include #include #include // Assertions static struct Object *func_assert_equal(size_t args_count, struct Object **args_array); static struct Object *func_assert_false(size_t args_count, struct Object **args_array); static struct Object *func_assert_true(size_t args_count, struct Object **args_array); // Arcana Lisp internals static struct Object *func_arcana_SLASH_builtin(size_t args_count, struct Object **args_array); static struct Object *func_arcana_SLASH_parse(size_t args_count, struct Object **args_array); static struct Object *func_arcana_SLASH_tokenize(size_t args_count, struct Object **args_array); static struct Object *func_arcana_SLASH_typeof(size_t args_count, struct Object **args_array); // Freezing static struct Object *func_freeze(size_t args_count, struct Object **args_array); static struct Object *func_frozen_QN(size_t args_count, struct Object **args_array); // Basic data structures static struct Object *func_car(size_t args_count, struct Object **args_array); static struct Object *func_cdr(size_t args_count, struct Object **args_array); static struct Object *func_cons(size_t args_count, struct Object **args_array); static struct Object *func_list(size_t args_count, struct Object **args_array); // Equivalence predicates static struct Object *func_equal_QN(size_t args_count, struct Object **args_array); // Type equivalence predicates static struct Object *func_boolean_EQ_QN(size_t args_count, struct Object **args_array); static struct Object *func_symbol_EQ_QN(size_t args_count, struct Object **args_array); // Type conversion static struct Object *func_number_TO_string(size_t args_count, struct Object **args_array); static struct Object *func_string_TO_symbol(size_t args_count, struct Object **args_array); static struct Object *func_symbol_TO_string(size_t args_count, struct Object **args_array); // Arithmetic operators static struct Object *func_EQ(size_t args_count, struct Object **args_array); static struct Object *func_PLUS(size_t args_count, struct Object **args_array); static struct Object *func_MINUS(size_t args_count, struct Object **args_array); // IO static struct Object *func_display(size_t args_count, struct Object **args_array); static struct Object *func_newline(size_t args_count, struct Object **args_array); #define BUILTIN(name_str, func_name) { \ .type = TYPE_PROCEDURE, \ .is_frozen = true, \ .procedure = { \ .name = name_str, \ .func = func_##func_name, \ }, \ } static struct Object builtins[] = { // Assertions BUILTIN("assert-equal", assert_equal), BUILTIN("assert-false", assert_false), BUILTIN("assert-true", assert_true), // Arcana Lisp internals BUILTIN("arcana/builtin", arcana_SLASH_builtin), BUILTIN("arcana/parse", arcana_SLASH_parse), BUILTIN("arcana/tokenize", arcana_SLASH_tokenize), BUILTIN("arcana/typeof", arcana_SLASH_typeof), // Freezing BUILTIN("freeze", freeze), BUILTIN("frozen?", frozen_QN), // Basic data structures BUILTIN("car", car), BUILTIN("cdr", cdr), BUILTIN("cons", cons), BUILTIN("list", list), // Equivalence predicates BUILTIN("equal?", equal_QN), // Type equivalence predicates BUILTIN("boolean=?", boolean_EQ_QN), BUILTIN("symbol=?", symbol_EQ_QN), // Type conversion BUILTIN("number->string", number_TO_string), BUILTIN("string->symbol", string_TO_symbol), BUILTIN("symbol->string", symbol_TO_string), // Arithmetic operators BUILTIN("=", EQ), BUILTIN("+", PLUS), BUILTIN("-", MINUS), // IO BUILTIN("display", display), BUILTIN("newline", newline), // NULL { .type = TYPE_PROCEDURE, .is_frozen = true, .procedure = { NULL, NULL } }, }; struct Object *builtins_get(const char *name) { for (size_t index = 0; builtins[index].procedure.name; ++index) { if (strcmp(name, builtins[index].procedure.name) == 0) { return &builtins[index]; } } return NULL; } /************** * Assertions * **************/ struct Object *func_assert_equal( size_t args_count, struct Object **args_array ) { struct Object *const result = func_equal_QN(args_count, args_array); if (!Object_is_true(result)) exit(EXIT_FAILURE); return NULL; } struct Object *func_assert_false( size_t args_count, struct Object **args_array ) { assert(args_count == 1); if (!Object_is_false(args_array[0])) exit(EXIT_FAILURE); return NULL; } struct Object *func_assert_true( size_t args_count, struct Object **args_array ) { assert(args_count == 1); if (!Object_is_true(args_array[0])) exit(EXIT_FAILURE); return NULL; } /************************* * Arcana Lisp internals * *************************/ struct Object *func_arcana_SLASH_builtin( size_t args_count, struct Object **args_array ) { assert(args_count == 1); struct Object *const name = args_array[0]; assert(Object_is_symbol(name)); return builtins_get(name->s); } struct Object *func_arcana_SLASH_parse( size_t args_count, struct Object **args_array ) { assert(args_count == 1); assert(args_array); struct Object *tokens_obj = args_array[0]; assert(OBJECT_IS_LIST_HEAD(tokens_obj)); const Tokens tokens = Tokens_new(); assert(tokens); while (!OBJECT_IS_NULL(tokens_obj)) { assert(Object_is_pair(tokens_obj)); struct Object *const token_obj = tokens_obj->pair.car; assert(Object_is_pair(token_obj)); struct Object *const type_obj = token_obj->pair.car; assert(Object_is_symbol(type_obj)); struct Object *const val_obj = token_obj->pair.cdr; assert(Object_is_string(val_obj)); enum TokenType token_type; if (strcmp(type_obj->s, "TOKEN_ROUND_OPEN") == 0) { token_type = TOKEN_ROUND_OPEN; } else if (strcmp(type_obj->s, "TOKEN_ROUND_CLOSE") == 0) { token_type = TOKEN_ROUND_CLOSE; } else if (strcmp(type_obj->s, "TOKEN_SQUARE_OPEN") == 0) { token_type = TOKEN_SQUARE_OPEN; } else if (strcmp(type_obj->s, "TOKEN_SQUARE_CLOSE") == 0) { token_type = TOKEN_SQUARE_CLOSE; } else if (strcmp(type_obj->s, "TOKEN_CURLY_OPEN") == 0) { token_type = TOKEN_CURLY_OPEN; } else if (strcmp(type_obj->s, "TOKEN_CURLY_CLOSE") == 0) { token_type = TOKEN_CURLY_CLOSE; } else if (strcmp(type_obj->s, "TOKEN_QUOTE") == 0) { token_type = TOKEN_QUOTE; } else if (strcmp(type_obj->s, "TOKEN_QUASI_QUOTE") == 0) { token_type = TOKEN_QUASI_QUOTE; } else if (strcmp(type_obj->s, "TOKEN_QUASI_UNQUOTE") == 0) { token_type = TOKEN_QUASI_UNQUOTE; } else if (strcmp(type_obj->s, "TOKEN_TAG") == 0) { token_type = TOKEN_TAG; } else if (strcmp(type_obj->s, "TOKEN_IDENT") == 0) { token_type = TOKEN_IDENT; } else if (strcmp(type_obj->s, "TOKEN_NUM") == 0) { token_type = TOKEN_NUM; } else if (strcmp(type_obj->s, "TOKEN_STRING") == 0) { token_type = TOKEN_STRING; } else { assert(0); } Tokens_append(tokens, token_type, val_obj->s); tokens_obj = tokens_obj->pair.cdr; } struct Object *const program = parse(tokens); Tokens_delete(tokens); return program; } struct Object *func_arcana_SLASH_tokenize( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); assert(args_array); struct Object *const str_obj = args_array[0]; assert(Object_is_string(str_obj)); const char *const str = str_obj->s; assert(str); Tokens tokens = Tokens_new(); assert(tokens); Lexer lexer = Lexer_new(tokens); assert(lexer); for (const char *chr = str; *chr; ++chr) { Lexer_lex(lexer, *chr); } Lexer_lex(lexer, '\n'); LEXER_DELETE(lexer); struct Object *list = NULL; if (Tokens_top(tokens)) { struct Object *last = NULL; list = Object_new_pair( Object_new_pair( Object_new_symbol(TokenType_to_str(Tokens_top(tokens)->type)), Object_new_string(Tokens_top(tokens)->val) ), NULL ); Tokens_pop(tokens); while (Tokens_top(tokens)) { struct Object *const new_pair = Object_new_pair( Object_new_pair( Object_new_symbol(TokenType_to_str(Tokens_top(tokens)->type)), Object_new_string(Tokens_top(tokens)->val) ), NULL ); Tokens_pop(tokens); if (last) { last->pair.cdr = new_pair; last = new_pair; } else { last = new_pair; list->pair.cdr = last; } } } TOKENS_DELETE(tokens); return list; } struct Object *func_arcana_SLASH_typeof( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); assert(args_array); struct Object *const object = args_array[0]; if (OBJECT_IS_NULL(object)) return Object_new_symbol("null"); switch (object->type) { case TYPE_PROCEDURE: return Object_new_symbol("procedure"); case TYPE_PAIR: return Object_new_symbol("pair"); case TYPE_BOOLEAN: return Object_new_symbol("boolean"); case TYPE_CHAR: return Object_new_symbol("char"); case TYPE_SYMBOL: return Object_new_symbol("symbol"); case TYPE_STRING: return Object_new_symbol("string"); case TYPE_NUMBER: return Object_new_symbol("number"); } assert(0); return NULL; } /************ * Freezing * ************/ struct Object *func_freeze( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); if (!OBJECT_IS_NULL(args_array[0])) args_array[0]->is_frozen = true; return args_array[0]; } struct Object *func_frozen_QN( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); return Object_new_boolean( OBJECT_IS_NULL(args_array[0]) || args_array[0]->is_frozen ); } /************************* * Basic data structures * *************************/ struct Object *func_car( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); struct Object *const arg = args_array[0]; assert(Object_is_pair(arg)); return arg->pair.car; } struct Object *func_cdr( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); struct Object *const arg = args_array[0]; assert(Object_is_pair(arg)); return arg->pair.cdr; } struct Object *func_cons( const size_t args_count, struct Object **const args_array ) { assert(args_count == 2); return Object_new_pair(args_array[0], args_array[1]); } struct Object *func_list( const size_t args_count, struct Object **const args_array ) { if (args_count == 0) return NULL; return Object_new_pair( args_array[0], func_list(args_count - 1, &args_array[1]) ); } /************************** * Equivalence predicates * **************************/ struct Object *func_equal_QN( const size_t args_count, struct Object **const args_array ) { if (args_count <= 1) return Object_new_boolean(true); struct Object *const first = args_array[0]; struct Object *const result = Object_new_boolean(true); for (size_t index = 1; result->boolean && index < args_count; ++index) { struct Object *const curr = args_array[index]; if (OBJECT_IS_NULL(first)) { if (!OBJECT_IS_NULL(curr)) result->boolean = false; } else { if (curr->type != first->type) { result->boolean = false; break; } switch (first->type) { case TYPE_PROCEDURE: // Built-in if (first->procedure.func) { result->boolean = curr->procedure.func && !strcmp(first->procedure.name, curr->procedure.name); } // Lambda else { result->boolean = curr == first; } break; case TYPE_PAIR: { struct Object *car_args[2] = { first->pair.car, curr->pair.car }; struct Object *cdr_args[2] = { first->pair.cdr, curr->pair.cdr }; struct Object *car_obj = func_equal_QN(2, car_args); struct Object *cdr_obj = func_equal_QN(2, cdr_args); assert(Object_is_boolean(car_obj)); assert(Object_is_boolean(cdr_obj)); result->boolean = car_obj->boolean && cdr_obj->boolean; break; } case TYPE_BOOLEAN: result->boolean = first->boolean == curr->boolean; break; case TYPE_CHAR: result->boolean = first->chr == curr->chr; break; case TYPE_SYMBOL: case TYPE_STRING: result->boolean = !strcmp(first->s, curr->s); break; case TYPE_NUMBER: result->boolean = first->number.i64 == curr->number.i64; break; } } } return result; } /******************************* * Type equivalence predicates * *******************************/ struct Object *func_boolean_EQ_QN( const size_t args_count, struct Object **const args_array ) { assert(args_count > 0); struct Object *const first = args_array[0]; assert(Object_is_boolean(first)); struct Object *const result = Object_new_boolean(true); for (size_t index = 1; result->boolean && index < args_count; ++index) { assert(Object_is_boolean(args_array[index])); } for (size_t index = 1; result->boolean && index < args_count; ++index) { struct Object *const curr = args_array[index]; if (curr->boolean != first->boolean) result->boolean = false; } return result; } struct Object *func_symbol_EQ_QN( const size_t args_count, struct Object **const args_array ) { assert(args_count > 0); struct Object *const first = args_array[0]; assert(Object_is_symbol(first)); struct Object *const result = Object_new_boolean(true); for (size_t index = 1; result->boolean && index < args_count; ++index) { assert(Object_is_symbol(args_array[index])); } for (size_t index = 1; result->boolean && index < args_count; ++index) { struct Object *const curr = args_array[index]; if (strcmp(curr->s, first->s)) result->boolean = false; } return result; } /******************* * Type conversion * *******************/ struct Object *func_number_TO_string( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1 || args_count == 2); struct Object *const z = args_array[0]; assert(Object_is_number(z)); int64_t radix = 10; if (args_count == 2) { struct Object *radix_obj = args_array[1]; assert(Object_is_number(radix_obj)); radix = radix_obj->number.i64; } char buffer[70]; switch (radix) { case 2: assert(0); // TODO break; case 8: snprintf(buffer, 70, "%lo", z->number.i64); break; case 10: snprintf(buffer, 70, "%ld", z->number.i64); break; case 16: snprintf(buffer, 70, "%lx", z->number.i64); break; default: assert(0); } return Object_new_string(buffer); } struct Object *func_string_TO_symbol( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); struct Object *const string = args_array[0]; assert(Object_is_string(string)); return Object_new_symbol(string->s); } struct Object *func_symbol_TO_string( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); struct Object *const symbol = args_array[0]; assert(Object_is_symbol(symbol)); return Object_new_string(symbol->s); } /************************ * Arithmetic operators * ************************/ struct Object *func_EQ( const size_t args_count, struct Object **const args_array ) { assert(args_count >= 1); struct Object *const first = args_array[0]; assert(Object_is_number(first)); struct Object *const result = Object_new_boolean(true); for (size_t index = 1; index < args_count; ++index) { struct Object *const cur = args_array[index]; assert(Object_is_number(cur)); if (cur->number.i64 != first->number.i64) { result->boolean = false; break; } } return result; } struct Object *func_PLUS( const size_t args_count, struct Object **const args_array ) { struct Object *const object = Object_new_number(0); if (args_count == 0) return object; struct Object *const arg = args_array[0]; assert(Object_is_number(arg)); object->number.i64 = arg->number.i64; if (args_count == 1) return object; struct Object *const b_sum = func_PLUS(args_count - 1, &args_array[1]); object->number.i64 += b_sum->number.i64; return object; } struct Object *func_MINUS( const size_t args_count, struct Object **const args_array ) { assert(args_count >= 1); struct Object *const arg = args_array[0]; assert(Object_is_number(arg)); struct Object *const object = Object_new_number(arg->number.i64); if (args_count >= 2) { struct Object *const sum = func_PLUS(args_count - 1, &args_array[1]); assert(Object_is_number(sum)); object->number.i64 -= sum->number.i64; } return object; } /****** * IO * ******/ static void display_pair(struct Object *pair); struct Object *func_display( const size_t args_count, struct Object **const args_array ) { assert(args_count == 1); struct Object *const object = args_array[0]; if (!object) { printf("()"); return NULL; } switch (object->type) { case TYPE_PROCEDURE: if (object->procedure.name) { printf("#", object->procedure.name); } else { printf("#"); } break; case TYPE_PAIR: printf("("); display_pair(object); printf(")"); break; case TYPE_BOOLEAN: printf("%s", object->boolean ? "#true" : "#false"); break; case TYPE_CHAR: printf("#\\TODO"); // TODO break; case TYPE_SYMBOL: printf("%s", object->s); break; case TYPE_NUMBER: printf("%li", object->number.i64); break; case TYPE_STRING: putchar('"'); for (char *str = object->s; *str; ++str) { const char chr = *str; if (chr == '\\') { printf("\\\\"); } else if (chr == '\"') { printf("\\\""); } else { putchar(chr); } } putchar('"'); break; } return NULL; } struct Object *func_newline( const size_t args_count, struct Object **const args_array ) { assert(args_count == 0); (void)args_array; printf("\n"); return NULL; } void display_pair(struct Object *const pair) { assert(Object_is_pair(pair)); struct Object *pair1[2] = { pair->pair.car, NULL }; func_display(1, pair1); if (!pair->pair.cdr) return; printf(" "); if (Object_is_pair(pair->pair.cdr)) { display_pair(pair->pair.cdr); return; } printf(". "); struct Object *pair2[2] = { pair->pair.cdr, NULL }; func_display(1, pair2); }