src/ebisp/builtins.c

   1 #include <assert.h>
   2 #include <math.h>
   3 #include <stdarg.h>
   4 #include <stdio.h>
   5 #include <string.h>
   6
   7 #include "builtins.h"
   8
   9 static bool equal_atoms(struct Atom *atom1, struct Atom *atom2)
  10 {
  11     assert(atom1);
  12     assert(atom2);
  13
  14     if (atom1->type != atom2->type) {
  15         return false;
  16     }
  17
  18     switch (atom1->type) {
  19     case ATOM_SYMBOL:
  20         return strcmp(atom1->sym, atom2->sym) == 0;
  21
  22     case ATOM_NUMBER:
  23         return atom1->num == atom2->num;
  24
  25     case ATOM_STRING:
  26         return strcmp(atom1->str, atom2->str) == 0;
  27
  28     case ATOM_NATIVE:
  29         return atom1->native.fun == atom2->native.fun
  30             && atom1->native.param == atom2->native.param;
  31     }
  32
  33     return false;
  34 }
  35
  36 static bool equal_cons(struct Cons *cons1, struct Cons *cons2)
  37 {
  38     assert(cons1);
  39     assert(cons2);
  40     return equal(cons1->car, cons2->car) && equal(cons1->cdr, cons2->cdr);
  41 }
  42
  43 bool equal(struct Expr obj1, struct Expr obj2)
  44 {
  45     if (obj1.type != obj2.type) {
  46         return false;
  47     }
  48
  49     switch (obj1.type) {
  50     case EXPR_ATOM:
  51         return equal_atoms(obj1.atom, obj2.atom);
  52
  53     case EXPR_CONS:
  54         return equal_cons(obj1.cons, obj2.cons);
  55
  56     case EXPR_VOID:
  57         return true;
  58     }
  59
  60     return true;
  61 }
  62
  63 bool nil_p(struct Expr obj)
  64 {
  65     return symbol_p(obj)
  66         && strcmp(obj.atom->sym, "nil") == 0;
  67 }
  68
  69
  70 bool symbol_p(struct Expr obj)
  71 {
  72     return obj.type == EXPR_ATOM
  73         && obj.atom->type == ATOM_SYMBOL;
  74 }
  75
  76 bool number_p(struct Expr obj)
  77 {
  78     return obj.type == EXPR_ATOM
  79         && obj.atom->type == ATOM_NUMBER;
  80 }
  81
  82 bool string_p(struct Expr obj)
  83 {
  84     return obj.type == EXPR_ATOM
  85         && obj.atom->type == ATOM_STRING;
  86 }
  87
  88 bool cons_p(struct Expr obj)
  89 {
  90     return obj.type == EXPR_CONS;
  91 }
  92
  93 bool list_p(struct Expr obj)
  94 {
  95     if (nil_p(obj)) {
  96         return true;
  97     }
  98
  99     if (obj.type == EXPR_CONS) {
 100         return list_p(obj.cons->cdr);
 101     }
 102
 103     return false;
 104 }
 105
 106 bool list_of_symbols_p(struct Expr obj)
 107 {
 108     if (nil_p(obj)) {
 109         return true;
 110     }
 111
 112     if (obj.type == EXPR_CONS && symbol_p(obj.cons->car)) {
 113         return list_of_symbols_p(obj.cons->cdr);
 114     }
 115
 116     return false;
 117 }
 118
 119 bool lambda_p(struct Expr obj)
 120 {
 121     if (!list_p(obj)) {
 122         return false;
 123     }
 124
 125     if (length_of_list(obj) < 2) {
 126         return false;
 127     }
 128
 129     if (!symbol_p(obj.cons->car)) {
 130         return false;
 131     }
 132
 133     if (strcmp("lambda", obj.cons->car.atom->sym) != 0) {
 134         return false;
 135     }
 136
 137     if (!list_of_symbols_p(obj.cons->cdr.cons->car)) {
 138         return false;
 139     }
 140
 141     return true;
 142 }
 143
 144 long int length_of_list(struct Expr obj)
 145 {
 146     long int count = 0;
 147
 148     while (!nil_p(obj)) {
 149         count++;
 150         obj = obj.cons->cdr;
 151     }
 152
 153     return count;
 154 }
 155
 156 struct Expr assoc(struct Expr key, struct Expr alist)
 157 {
 158     while (cons_p(alist)) {
 159         if (cons_p(alist.cons->car) && equal(alist.cons->car.cons->car, key)) {
 160             return alist.cons->car;
 161         }
 162
 163         alist = alist.cons->cdr;
 164     }
 165
 166     return alist;
 167 }
 168
 169 static struct Expr list_rec(Gc *gc, size_t n, va_list args)
 170 {
 171     if (n == 0) {
 172         return NIL(gc);
 173     }
 174
 175     struct Expr obj = va_arg(args, struct Expr);
 176     return CONS(gc, obj, list_rec(gc, n - 1, args));
 177 }
 178
 179 struct Expr list(Gc *gc, size_t n, ...)
 180 {
 181     va_list args;
 182     va_start(args, n);
 183     struct Expr obj = list_rec(gc, n, args);
 184     va_end(args);
 185     return obj;
 186 }