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

syntax "cond"

Browse source
This commit is contained in:
Alex Kotov 2023-05-08 19:16:52 +04:00
parent 3b70624610
commit 8748f2722c
Signed by: kotovalexarian
GPG key ID: 553C0EBBEB5D5F08
4 changed files with 57 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
src/eval.c
View file

@ -38,6 +38,9 @@ struct Object *eval(
if (strcmp(func_expr->s, "begin") == 0) {
return syntax_begin(args, environment);
}
if (strcmp(func_expr->s, "cond") == 0) {
return syntax_cond(args, environment);
}
if (strcmp(func_expr->s, "define") == 0) {
return syntax_define(args, environment);
}

42
src/syntax.c
View file

@ -4,6 +4,7 @@
#include "object.h"
#include <assert.h>
#include <string.h>
/*******************************************
* Special syntax to use in the executable *
@ -41,6 +42,47 @@ struct Object *syntax_begin(
return result;
}
struct Object *syntax_cond(
struct Object *const args,
struct Object *const environment
) {
assert(Object_is_pair(environment));
assert(OBJECT_IS_LIST_HEAD(environment->pair.cdr));
assert(OBJECT_IS_LIST_HEAD(environment->pair.car));
assert(OBJECT_IS_LIST_HEAD(args));
for (struct Object *arg = args; !OBJECT_IS_NULL(arg); arg = arg->pair.cdr)
{
assert(Object_is_pair(arg));
assert(Object_is_pair(arg->pair.car));
assert(Object_is_pair(arg->pair.car->pair.cdr));
assert(OBJECT_IS_NULL(arg->pair.car->pair.cdr->pair.cdr));
struct Object *const cond_prog = arg->pair.car->pair.car;
if (Object_is_symbol(cond_prog) && strcmp(cond_prog->s, "else") == 0) {
assert(OBJECT_IS_NULL(arg->pair.cdr));
}
}
for (struct Object *arg = args; !OBJECT_IS_NULL(arg); arg = arg->pair.cdr)
{
struct Object *const cond_prog = arg->pair.car->pair.car;
struct Object *const val_prog = arg->pair.car->pair.cdr->pair.car;
if (Object_is_symbol(cond_prog) && strcmp(cond_prog->s, "else") == 0) {
return eval(val_prog, environment);
}
if (!Object_is_false(eval(cond_prog, environment))) {
return eval(val_prog, environment);
}
}
return NULL;
}
struct Object *syntax_define(
struct Object *const args,
struct Object *const environment

1
src/syntax.h
View file

@ -15,6 +15,7 @@ struct Object *syntax_script(struct Object *args, struct Object *environment);
*******************/
struct Object *syntax_begin(struct Object *args, struct Object *environment);
struct Object *syntax_cond(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);

11
tests/syntax.scm
View file

@ -4,6 +4,17 @@
(assert-equal 456 (begin 123 456))
(assert-equal 789 (begin 123 456 789))
;;; cond ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(assert-equal '() (cond))
(assert-equal '() (cond (#false 123)))
(assert-equal 123 (cond (#true 123)))
(assert-equal '() (cond (#false 123) (#false 456)))
(assert-equal 123 (cond (#true 123) (#true 456)))
(assert-equal 456 (cond (#false 123) (#true 456)))
(assert-equal 123 (cond (#true 123) (#true 456) (else 789)))
(assert-equal 456 (cond (#false 123) (#true 456) (else 789)))
(assert-equal 789 (cond (#false 123) (#false 456) (else 789)))
;;; define ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(assert-equal
'(123 579)