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