diff --git a/src/eval.c b/src/eval.c index 24b227b..3f2602e 100644 --- a/src/eval.c +++ b/src/eval.c @@ -41,6 +41,9 @@ struct Object *eval( if (strcmp(func_expr->s, "define") == 0) { return syntax_define(args, environment); } + if (strcmp(func_expr->s, "lambda") == 0) { + return syntax_lambda(args, environment); + } if (strcmp(func_expr->s, "let") == 0) { return syntax_let(args, environment); } diff --git a/src/object.c b/src/object.c index 32252e0..7315101 100644 --- a/src/object.c +++ b/src/object.c @@ -1,5 +1,7 @@ #include "object.h" +#include "eval.h" + #include #include #include @@ -21,6 +23,10 @@ const char *Type_to_str(const enum Type type) return NULL; } +/************ + * Creation * + ************/ + static struct Object *new(const enum Type type) { struct Object *const object = malloc(sizeof(struct Object)); @@ -30,21 +36,6 @@ static struct Object *new(const enum Type type) return object; } -struct Object *Object_new_procedure( - const char *const name, - const Procedure_Func func -) { - struct Object *const object = new(TYPE_PROCEDURE); - object->procedure.name = NULL; - if (name && name[0]) { - object->procedure.name = malloc(strlen(name) + 1); - assert(object->procedure.name); - strcpy(object->procedure.name, name); - } - object->procedure.func = func; - return object; -} - struct Object *Object_new_pair( struct Object *const car, struct Object *const cdr @@ -94,6 +85,34 @@ struct Object *Object_new_number(const int64_t i64) return object; } +struct Object *Object_new_lambda( + const char *const name, + struct Object *const arg_names, + struct Object *const body +) { + assert(OBJECT_IS_LIST_HEAD(arg_names)); + for ( + struct Object *arg_name = arg_names; + !OBJECT_IS_NULL(arg_name); + arg_name = arg_name->pair.cdr + ) { + assert(Object_is_pair(arg_name)); + assert(Object_is_symbol(arg_name->pair.car)); + } + + struct Object *const object = new(TYPE_PROCEDURE); + object->procedure.name = NULL; + if (name && name[0]) { + object->procedure.name = malloc(strlen(name) + 1); + assert(object->procedure.name); + strcpy(object->procedure.name, name); + } + object->procedure.func = NULL; + object->procedure.arg_names = arg_names; + object->procedure.body = body; + return object; +} + struct Object *Object_build_list(int count, ...) { assert(count > 0); @@ -121,6 +140,10 @@ struct Object *Object_build_list(int count, ...) return list; } +/******************* + * Type predicates * + *******************/ + bool Object_is_procedure(struct Object *object) { return object && object->type == TYPE_PROCEDURE; @@ -156,6 +179,10 @@ bool Object_is_number(struct Object *object) return object && object->type == TYPE_NUMBER; } +/******************** + * Other predicates * + ********************/ + bool Object_is_false(struct Object *object) { return Object_is_boolean(object) && object->boolean == false; @@ -166,6 +193,10 @@ bool Object_is_true(struct Object *object) return Object_is_boolean(object) && object->boolean == true; } +/************************************** + * Helper functions for specific type * + **************************************/ + size_t Object_list_length(struct Object *list_obj) { assert(OBJECT_IS_LIST_HEAD(list_obj)); @@ -183,34 +214,64 @@ struct Object *Object_procedure_call( struct Object *const procedure, struct Object *const args ) { - assert(procedure); assert(Object_is_procedure(procedure)); assert(OBJECT_IS_LIST_HEAD(args)); - const size_t args_count = Object_list_length(args); + // Builtin procedure + if (procedure->procedure.func) { + const size_t args_count = Object_list_length(args); - if (args_count == 0) { - assert(OBJECT_IS_NULL(args)); - return procedure->procedure.func(0, NULL); + if (args_count == 0) { + assert(OBJECT_IS_NULL(args)); + return procedure->procedure.func(0, NULL); + } + + assert(Object_is_pair(args)); + + const size_t size = sizeof(struct Object*) * (args_count + 1); + struct Object **const args_array = malloc(size); + assert(args_array); + memset(args_array, 0, size); + + struct Object *arg = args; + for (size_t index = 0; index < args_count; ++index) { + assert(Object_is_pair(arg)); + args_array[index] = arg->pair.car; + arg = arg->pair.cdr; + } + + struct Object *const result = + procedure->procedure.func(args_count, args_array); + + free(args_array); + return result; } + // Lambda + else { + struct Object *const environment = Object_new_pair(NULL, NULL); - assert(Object_is_pair(args)); + for ( + struct Object + *arg_name_pair = procedure->procedure.arg_names, + *arg_pair = args + ; + !(OBJECT_IS_NULL(arg_name_pair)) || !(OBJECT_IS_NULL(arg_pair)) + ; + arg_name_pair = arg_name_pair->pair.cdr, + arg_pair = arg_pair->pair.cdr + ) { + assert(!OBJECT_IS_NULL(arg_name_pair)); + assert(!OBJECT_IS_NULL(arg_pair)); + struct Object *const arg_name = arg_name_pair->pair.car; + struct Object *const arg = arg_pair->pair.car; + assert(Object_is_symbol(arg_name)); - const size_t size = sizeof(struct Object*) * (args_count + 1); - struct Object **const args_array = malloc(size); - assert(args_array); - memset(args_array, 0, size); + environment->pair.car = Object_new_pair( + Object_new_pair(arg_name, arg), + environment->pair.car + ); + } - struct Object *arg = args; - for (size_t index = 0; index < args_count; ++index) { - assert(Object_is_pair(arg)); - args_array[index] = arg->pair.car; - arg = arg->pair.cdr; + return eval(procedure->procedure.body, environment); } - - struct Object *const result = - procedure->procedure.func(args_count, args_array); - - free(args_array); - return result; } diff --git a/src/object.h b/src/object.h index f4052d6..9359c38 100644 --- a/src/object.h +++ b/src/object.h @@ -26,7 +26,11 @@ typedef struct Object *(*Procedure_Func)( struct Procedure { char *name; + // For builtins Procedure_Func func; + // For lambdas + struct Object *arg_names; + struct Object *body; }; /******** @@ -69,10 +73,10 @@ struct Object { const char *Type_to_str(enum Type type); -struct Object *Object_new_procedure( - const char *name, - Procedure_Func func -); +/************ + * Creation * + ************/ + struct Object *Object_new_pair(struct Object *car, struct Object *cdr); struct Object *Object_new_boolean(bool boolean); struct Object *Object_new_char(char chr); @@ -80,8 +84,18 @@ struct Object *Object_new_symbol(const char *s); struct Object *Object_new_string(const char *s); struct Object *Object_new_number(int64_t i64); +struct Object *Object_new_lambda( + const char *name, + struct Object *arg_names, + struct Object *body +); + struct Object *Object_build_list(int count, ...); +/******************* + * Type predicates * + *******************/ + #define OBJECT_IS_NULL(object) ((object) == NULL) bool Object_is_procedure(struct Object *object); bool Object_is_pair(struct Object *object); @@ -91,6 +105,10 @@ bool Object_is_symbol(struct Object *object); bool Object_is_string(struct Object *object); bool Object_is_number(struct Object *object); +/******************** + * Other predicates * + ********************/ + #define OBJECT_IS_LIST_HEAD(object) \ (OBJECT_IS_NULL(object) || Object_is_pair(object)) bool Object_is_false(struct Object *object); diff --git a/src/syntax.c b/src/syntax.c index 15f0b09..97b67f3 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -86,6 +86,22 @@ struct Object *syntax_if( } } +struct Object *syntax_lambda( + struct Object *const args, + struct Object *environment +) { + (void)environment; + + assert(Object_is_pair(args)); + struct Object *const arg_names = args->pair.car; + assert(OBJECT_IS_LIST_HEAD(arg_names)); + assert(Object_is_pair(args->pair.cdr)); + struct Object *const body = args->pair.cdr->pair.car; + assert(OBJECT_IS_NULL(args->pair.cdr->pair.cdr)); + + return Object_new_lambda(NULL, arg_names, body); +} + struct Object *syntax_let( struct Object *const args, struct Object *environment diff --git a/src/syntax.h b/src/syntax.h index 494607a..df23294 100644 --- a/src/syntax.h +++ b/src/syntax.h @@ -17,6 +17,7 @@ struct Object *syntax_script(struct Object *args, struct Object *environment); struct Object *syntax_begin(struct Object *args, struct Object *environment); struct Object *syntax_define(struct Object *args, struct Object *environment); struct Object *syntax_if(struct Object *args, struct Object *environment); +struct Object *syntax_lambda(struct Object *args, struct Object *environment); struct Object *syntax_let(struct Object *args, struct Object *environment); struct Object *syntax_quote(struct Object *args, struct Object *environment); diff --git a/tests/syntax.scm b/tests/syntax.scm index deb0088..b844505 100644 --- a/tests/syntax.scm +++ b/tests/syntax.scm @@ -24,6 +24,16 @@ (assert-equal 123 (if "foo" 123 456)) (assert-equal 456 (if #false 123 456)) +;;; lambda ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(assert-true (procedure? (lambda () 123))) +(assert-true (procedure? (lambda (x) (+ x x)))) +(assert-true (procedure? (lambda (x y) (+ x y)))) +(assert-true (procedure? (lambda (x y z) (+ x y z)))) +(assert-equal 123 ((lambda () 123))) +(assert-equal 3 ((lambda (x) (+ 1 x)) 2)) +(assert-equal 6 ((lambda (x y) (+ 1 x y)) 2 3)) +(assert-equal 10 ((lambda (x y z) (+ 1 x y z)) 2 3 4)) + ;;; let ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (assert-equal 'foo (let () 'foo)) (assert-equal '(1) (let { [a 1] } (list a)))