causa-arcana-misc
/
lesson-lisp
1
0
Fork 0
Code

lambda

This commit is contained in:
Alex Kotov 2023-05-07 19:29:35 +04:00
parent 6b6f7abbea
commit 97a7a1f3e6
Signed by: kotovalexarian
GPG Key ID: 553C0EBBEB5D5F08
6 changed files with 149 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/eval.c
View File

@ -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);
}

133
src/object.c
View File

@ -1,5 +1,7 @@
#include "object.h"
#include "eval.h"
#include <assert.h>
#include <stdarg.h>
#include <stddef.h>
@ -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;
}

26
src/object.h
View File

@ -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);

16
src/syntax.c
View File

@ -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

1
src/syntax.h
View File

@ -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);

10
tests/syntax.scm
View File

@ -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)))