src/ebisp/builtins.c

   1 #include "system/stacktrace.h"
   2 #include <math.h>
   3 #include <stdarg.h>
   4 #include <stdio.h>
   5 #include <string.h>
   6 #include <stdbool.h>
   7
   8 #include "builtins.h"
   9
  10 static bool equal_atoms(struct Atom *atom1, struct Atom *atom2)
  11 {
  12     trace_assert(atom1);
  13     trace_assert(atom2);
  14
  15     if (atom1->type != atom2->type) {
  16         return false;
  17     }
  18
  19     switch (atom1->type) {
  20     case ATOM_SYMBOL:
  21         return strcmp(atom1->sym, atom2->sym) == 0;
  22
  23     case ATOM_NUMBER:
  24         return atom1->num == atom2->num;
  25
  26     case ATOM_STRING:
  27         return strcmp(atom1->str, atom2->str) == 0;
  28
  29     case ATOM_NATIVE:
  30         return atom1->native.fun == atom2->native.fun
  31             && atom1->native.param == atom2->native.param;
  32     }
  33
  34     return false;
  35 }
  36
  37 static bool equal_cons(struct Cons *cons1, struct Cons *cons2)
  38 {
  39     trace_assert(cons1);
  40     trace_assert(cons2);
  41     return equal(cons1->car, cons2->car) && equal(cons1->cdr, cons2->cdr);
  42 }
  43
  44 bool equal(struct Expr obj1, struct Expr obj2)
  45 {
  46     if (obj1.type != obj2.type) {
  47         return false;
  48     }
  49
  50     switch (obj1.type) {
  51     case EXPR_ATOM:
  52         return equal_atoms(obj1.atom, obj2.atom);
  53
  54     case EXPR_CONS:
  55         return equal_cons(obj1.cons, obj2.cons);
  56
  57     case EXPR_VOID:
  58         return true;
  59     }
  60
  61     return true;
  62 }
  63
  64 bool nil_p(struct Expr obj)
  65 {
  66     return symbol_p(obj)
  67         && strcmp(obj.atom->sym, "nil") == 0;
  68 }
  69
  70
  71 bool symbol_p(struct Expr obj)
  72 {
  73     return obj.type == EXPR_ATOM
  74         && obj.atom->type == ATOM_SYMBOL;
  75 }
  76
  77 bool number_p(struct Expr obj)
  78 {
  79     return obj.type == EXPR_ATOM
  80         && obj.atom->type == ATOM_NUMBER;
  81 }
  82
  83 bool string_p(struct Expr obj)
  84 {
  85     return obj.type == EXPR_ATOM
  86         && obj.atom->type == ATOM_STRING;
  87 }
  88
  89 bool cons_p(struct Expr obj)
  90 {
  91     return obj.type == EXPR_CONS;
  92 }
  93
  94 bool list_p(struct Expr obj)
  95 {
  96     if (nil_p(obj)) {
  97         return true;
  98     }
  99
 100     if (obj.type == EXPR_CONS) {
 101         return list_p(obj.cons->cdr);
 102     }
 103
 104     return false;
 105 }
 106
 107 bool list_of_symbols_p(struct Expr obj)
 108 {
 109     if (nil_p(obj)) {
 110         return true;
 111     }
 112
 113     if (obj.type == EXPR_CONS && symbol_p(obj.cons->car)) {
 114         return list_of_symbols_p(obj.cons->cdr);
 115     }
 116
 117     return false;
 118 }
 119
 120 bool lambda_p(struct Expr obj)
 121 {
 122     if (!list_p(obj)) {
 123         return false;
 124     }
 125
 126     if (length_of_list(obj) < 2) {
 127         return false;
 128     }
 129
 130     if (!symbol_p(obj.cons->car)) {
 131         return false;
 132     }
 133
 134     if (!is_lambda(obj.cons)) {
 135         return false;
 136     }
 137
 138     if (!list_of_symbols_p(obj.cons->cdr.cons->car)) {
 139         return false;
 140     }
 141
 142     return true;
 143 }
 144
 145 long int length_of_list(struct Expr obj)
 146 {
 147     long int count = 0;
 148
 149     while (!nil_p(obj)) {
 150         count++;
 151         obj = obj.cons->cdr;
 152     }
 153
 154     return count;
 155 }
 156
 157 struct Expr assoc(struct Expr key, struct Expr alist)
 158 {
 159     while (cons_p(alist)) {
 160         if (cons_p(CAR(alist)) && equal(CAR(CAR(alist)), key)) {
 161             return CAR(alist);
 162         }
 163
 164         alist = CDR(alist);
 165     }
 166
 167     return alist;
 168 }
 169
 170 bool is_lambda(struct Cons *cons) {
 171     return (strcmp(cons->car.atom->sym, "lambda") == 0) ||
 172             (strcmp(cons->car.atom->sym, "λ") == 0);
 173 }
 174
 175 const char *specials[] = {
 176     "set", "quote", "begin",
 177     "defun", "lambda", "λ",
 178     "defun", "when", "quasiquote"
 179 };
 180
 181 bool is_special(const char *name)
 182 {
 183     trace_assert(name);
 184
 185     size_t n = sizeof(specials) / sizeof(const char*);
 186     for (size_t i = 0; i < n; ++i) {
 187         if (strcmp(name, specials[i]) == 0) {
 188             return true;
 189         }
 190     }
 191
 192     return false;
 193 }
 194
 195
 196 static struct Expr
 197 list_rec(Gc *gc, const char *format, va_list args)
 198 {
 199     trace_assert(gc);
 200     trace_assert(format);
 201
 202     if (*format == 0) {
 203         return NIL(gc);
 204     }
 205
 206     switch (*format) {
 207     case 'd': {
 208         long int p = va_arg(args, long int);
 209         return CONS(gc, NUMBER(gc, p),
 210                     list_rec(gc, format + 1, args));
 211     }
 212
 213     case 's': {
 214         const char* p = va_arg(args, const char*);
 215         return CONS(gc, STRING(gc, p),
 216                     list_rec(gc, format + 1, args));
 217     }
 218
 219     case 'q': {
 220         const char* p = va_arg(args, const char*);
 221         return CONS(gc, SYMBOL(gc, p),
 222                     list_rec(gc, format + 1, args));
 223     }
 224
 225     case 'e': {
 226         struct Expr p = va_arg(args, struct Expr);
 227         return CONS(gc, p, list_rec(gc, format + 1, args));
 228     }
 229
 230     default: {
 231         fprintf(stderr, "Wrong format parameter: %c\n", *format);
 232         trace_assert(0);
 233     }
 234     }
 235
 236     return NIL(gc);
 237 }
 238
 239 struct Expr
 240 list(Gc *gc, const char *format, ...)
 241 {
 242     va_list args;
 243     va_start(args, format);
 244     struct Expr result = list_rec(gc, format, args);
 245     va_end(args);
 246
 247     return result;
 248 }
 249
 250 struct Expr bool_as_expr(Gc *gc, bool condition)
 251 {
 252     return condition ? T(gc) : NIL(gc);
 253 }