c/core.c

   1 #include <stdarg.h>
   2 #include <stdio.h>
   3 #include <stdlib.h>
   4 #include <string.h>
   5 #include <sys/stat.h>
   6 #include <sys/time.h>
   7 #include <fcntl.h>
   8 #include <unistd.h>
   9
  10 #include "types.h"
  11 #include "core.h"
  12 #include "reader.h"
  13 #include "printer.h"
  14
  15 // Errors/Exceptions
  16 void throw(MalVal *obj) {
  17     mal_error = obj;
  18 }
  19
  20
  21 // General functions
  22
  23 MalVal *equal_Q(MalVal *a, MalVal *b) {
  24     if (_equal_Q(a, b)) { return &mal_true; }
  25     else { return &mal_false; }
  26 }
  27
  28
  29 // Scalar functions
  30
  31 MalVal *nil_Q(MalVal *seq) { return seq->type & MAL_NIL ? &mal_true : &mal_false; }
  32 MalVal *true_Q(MalVal *seq) { return seq->type & MAL_TRUE ? &mal_true : &mal_false; }
  33 MalVal *false_Q(MalVal *seq) { return seq->type & MAL_FALSE ? &mal_true : &mal_false; }
  34 MalVal *string_Q(MalVal *seq) {
  35     if ((seq->type & MAL_STRING) && (seq->val.string[0] != '\x7f')) {
  36         return &mal_true;
  37     } else {
  38         return &mal_false;
  39     }
  40 }
  41
  42
  43 // Symbol functions
  44
  45 MalVal *symbol(MalVal *args) {
  46     assert_type(args, MAL_STRING,
  47                 "symbol called with non-string value");
  48     args->type = MAL_SYMBOL; // change string to symbol
  49     return args;
  50 }
  51
  52 MalVal *symbol_Q(MalVal *seq) {
  53     return seq->type & MAL_SYMBOL ? &mal_true : &mal_false; }
  54
  55
  56 // Keyword functions
  57
  58 MalVal *keyword(MalVal *args) {
  59     assert_type(args, MAL_STRING,
  60                 "keyword called with non-string value");
  61     if (args->val.string[0] == '\x7f') {
  62         return args;
  63     } else {
  64         return malval_new_keyword(args->val.string);
  65     }
  66 }
  67
  68 MalVal *keyword_Q(MalVal *seq) {
  69     return seq->type & MAL_STRING && seq->val.string[0] == '\x7f'
  70         ? &mal_true
  71         : &mal_false;
  72 }
  73
  74
  75 // String functions
  76
  77 // Return a string representation of a MalVal sequence (in a format that can
  78 // be read by the reader). Returned string must be freed by caller.
  79 MalVal *pr_str(MalVal *args) {
  80     assert_type(args, MAL_LIST|MAL_VECTOR,
  81                 "pr_str called with non-sequential args");
  82     return malval_new_string(_pr_str_args(args, " ", 1));
  83 }
  84
  85 // Return a string representation of a MalVal sequence with every item
  86 // concatenated together. Returned string must be freed by caller.
  87 MalVal *str(MalVal *args) {
  88     assert_type(args, MAL_LIST|MAL_VECTOR,
  89                 "str called with non-sequential args");
  90     return malval_new_string(_pr_str_args(args, "", 0));
  91 }
  92
  93 // Print a string representation of a MalVal sequence (in a format that can
  94 // be read by the reader) followed by a newline. Returns nil.
  95 MalVal *prn(MalVal *args) {
  96     assert_type(args, MAL_LIST|MAL_VECTOR,
  97                 "prn called with non-sequential args");
  98     char *repr = _pr_str_args(args, " ", 1);
  99     g_print("%s\n", repr);
 100     free(repr);
 101     return &mal_nil;
 102 }
 103
 104 // Print a string representation of a MalVal sequence (for human consumption)
 105 // followed by a newline. Returns nil.
 106 MalVal *println(MalVal *args) {
 107     assert_type(args, MAL_LIST|MAL_VECTOR,
 108                 "println called with non-sequential args");
 109     char *repr = _pr_str_args(args, " ", 0);
 110     g_print("%s\n", repr);
 111     free(repr);
 112     return &mal_nil;
 113 }
 114
 115 MalVal *mal_readline(MalVal *str) {
 116     assert_type(str, MAL_STRING, "readline of non-string");
 117     char * line = _readline(str->val.string);
 118     if (line) { return malval_new_string(line); }
 119     else      { return &mal_nil; }
 120 }
 121
 122 MalVal *read_string(MalVal *str) {
 123     assert_type(str, MAL_STRING, "read_string of non-string");
 124     return read_str(str->val.string);
 125 }
 126
 127 char *slurp_raw(char *path) {
 128     char *data;
 129     struct stat fst;
 130     int fd = open(path, O_RDONLY),
 131         sz;
 132     if (fd < 0) {
 133         abort("slurp failed to open '%s'", path);
 134     }
 135     if (fstat(fd, &fst) < 0) {
 136         abort("slurp failed to stat '%s'", path);
 137     }
 138     data = malloc(fst.st_size+1);
 139     sz = read(fd, data, fst.st_size);
 140     if (sz < fst.st_size) {
 141         abort("slurp failed to read '%s'", path);
 142     }
 143     data[sz] = '\0';
 144     return data;
 145 }
 146 MalVal *slurp(MalVal *path) {
 147     assert_type(path, MAL_STRING, "slurp of non-string");
 148     char *data = slurp_raw(path->val.string);
 149     if (!data || mal_error) { return NULL; }
 150     return malval_new_string(data);
 151 }
 152
 153
 154
 155
 156 // Number functions
 157
 158 WRAP_INTEGER_OP(plus,+)
 159 WRAP_INTEGER_OP(minus,-)
 160 WRAP_INTEGER_OP(multiply,*)
 161 WRAP_INTEGER_OP(divide,/)
 162 WRAP_INTEGER_CMP_OP(gt,>)
 163 WRAP_INTEGER_CMP_OP(gte,>=)
 164 WRAP_INTEGER_CMP_OP(lt,<)
 165 WRAP_INTEGER_CMP_OP(lte,<=)
 166
 167 MalVal *time_ms(MalVal *_) {
 168     struct timeval tv;
 169     long msecs;
 170     gettimeofday(&tv, NULL);
 171     msecs = tv.tv_sec * 1000 + tv.tv_usec/1000.0 + 0.5;
 172
 173     return malval_new_integer(msecs);
 174 }
 175
 176
 177 // List functions
 178
 179 MalVal *list(MalVal *args) { return _list(args); }
 180 MalVal *list_Q(MalVal *seq) { return _list_Q(seq) ? &mal_true : &mal_false; }
 181
 182
 183 // Vector functions
 184
 185 MalVal *vector(MalVal *args) { return _vector(args); }
 186 MalVal *vector_Q(MalVal *seq) { return _vector_Q(seq) ? &mal_true : &mal_false; }
 187
 188
 189 // Hash map functions
 190
 191 MalVal *hash_map_Q(MalVal *seq) { return _hash_map_Q(seq) ? &mal_true : &mal_false; }
 192
 193 MalVal *assoc(MalVal *args) {
 194     assert_type(args, MAL_LIST|MAL_VECTOR,
 195                 "assoc called with non-sequential arguments");
 196     assert(_count(args) >= 2,
 197            "assoc needs at least 2 arguments");
 198     GHashTable *htable = g_hash_table_copy(_first(args)->val.hash_table);
 199     MalVal *hm = malval_new_hash_map(htable);
 200     return _assoc_BANG(hm, _rest(args));
 201 }
 202
 203 MalVal *dissoc(MalVal* args) {
 204     GHashTable *htable = g_hash_table_copy(_first(args)->val.hash_table);
 205     MalVal *hm = malval_new_hash_map(htable);
 206     return _dissoc_BANG(hm, _rest(args));
 207 }
 208
 209 MalVal *keys(MalVal *obj) {
 210     assert_type(obj, MAL_HASH_MAP,
 211                 "keys called on non-hash-map");
 212
 213     GHashTableIter iter;
 214     gpointer key, value;
 215     MalVal *seq = malval_new_list(MAL_LIST,
 216                                   g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
 217                                                     _count(obj)));
 218     g_hash_table_iter_init (&iter, obj->val.hash_table);
 219     while (g_hash_table_iter_next (&iter, &key, &value)) {
 220         MalVal *kname = malval_new_string((char *)key);
 221         g_array_append_val(seq->val.array, kname);
 222     }
 223     return seq;
 224 }
 225
 226 MalVal *vals(MalVal *obj) {
 227     assert_type(obj, MAL_HASH_MAP,
 228                 "vals called on non-hash-map");
 229
 230     GHashTableIter iter;
 231     gpointer key, value;
 232     MalVal *seq = malval_new_list(MAL_LIST,
 233                                   g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
 234                                                     _count(obj)));
 235     g_hash_table_iter_init (&iter, obj->val.hash_table);
 236     while (g_hash_table_iter_next (&iter, &key, &value)) {
 237         g_array_append_val(seq->val.array, value);
 238     }
 239     return seq;
 240 }
 241
 242
 243 // hash map and vector functions
 244 MalVal *get(MalVal *obj, MalVal *key) {
 245     MalVal *val;
 246     switch (obj->type) {
 247     case MAL_VECTOR:
 248         return _nth(obj, key->val.intnum);
 249     case MAL_HASH_MAP:
 250         if (g_hash_table_lookup_extended(obj->val.hash_table,
 251                                          key->val.string,
 252                                          NULL, (gpointer*)&val)) {
 253             return val;
 254         } else {
 255             return &mal_nil;
 256         }
 257     case MAL_NIL:
 258         return &mal_nil;
 259     default:
 260         abort("get called on unsupported type %d", obj->type);
 261     }
 262 }
 263
 264 MalVal *contains_Q(MalVal *obj, MalVal *key) {
 265     switch (obj->type) {
 266     case MAL_VECTOR:
 267         if (key->val.intnum < obj->val.array->len) {
 268             return &mal_true;
 269         } else {
 270             return &mal_false;
 271         }
 272     case MAL_HASH_MAP:
 273         if (g_hash_table_contains(obj->val.hash_table, key->val.string)) {
 274             return &mal_true;
 275         } else {
 276             return &mal_false;
 277         }
 278     default:
 279         abort("contains? called on unsupported type %d", obj->type);
 280     }
 281 }
 282
 283
 284 // Sequence functions
 285
 286 MalVal *sequential_Q(MalVal *seq) {
 287     return _sequential_Q(seq) ? &mal_true : &mal_false;
 288 }
 289
 290 MalVal *cons(MalVal *x, MalVal *seq) {
 291     assert_type(seq, MAL_LIST|MAL_VECTOR,
 292                 "second argument to cons is non-sequential");
 293     int i, len = _count(seq);
 294     GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
 295                                         len+1);
 296     g_array_append_val(new_arr, x);
 297     for (i=0; i<len; i++) {
 298         g_array_append_val(new_arr, g_array_index(seq->val.array, MalVal*, i));
 299     }
 300     return malval_new_list(MAL_LIST, new_arr);
 301 }
 302
 303 MalVal *concat(MalVal *args) {
 304     MalVal *arg, *e, *lst;
 305     int i, j, arg_cnt = _count(args);
 306     lst = malval_new_list(MAL_LIST,
 307                         g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), arg_cnt));
 308     for (i=0; i<arg_cnt; i++) {
 309         arg = g_array_index(args->val.array, MalVal*, i);
 310         assert_type(arg, MAL_LIST|MAL_VECTOR,
 311                     "concat called with non-sequential");
 312         for (j=0; j<_count(arg); j++) {
 313             e = g_array_index(arg->val.array, MalVal*, j);
 314             g_array_append_val(lst->val.array, e);
 315         }
 316     }
 317     return lst;
 318 }
 319
 320 MalVal *nth(MalVal *seq, MalVal *idx) {
 321     return _nth(seq, idx->val.intnum);
 322 }
 323
 324 MalVal *empty_Q(MalVal *seq) {
 325     assert_type(seq, MAL_LIST|MAL_VECTOR,
 326                 "empty? called with non-sequential");
 327     return (seq->val.array->len == 0) ? &mal_true : &mal_false;
 328 }
 329
 330 MalVal *count(MalVal *seq) {
 331     return malval_new_integer(_count(seq));
 332 }
 333
 334 MalVal *apply(MalVal *args) {
 335     assert_type(args, MAL_LIST|MAL_VECTOR,
 336                 "apply called with non-sequential");
 337     MalVal *f = _nth(args, 0);
 338     MalVal *last_arg = _last(args);
 339     assert_type(last_arg, MAL_LIST|MAL_VECTOR,
 340                 "last argument to apply is non-sequential");
 341     int i, len = _count(args) - 2 + _count(last_arg);
 342     GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
 343                                         len);
 344     // Initial arguments
 345     for (i=1; i<_count(args)-1; i++) {
 346         g_array_append_val(new_arr, g_array_index(args->val.array, MalVal*, i));
 347     }
 348     // Add arguments from last_arg
 349     for (i=0; i<_count(last_arg); i++) {
 350         g_array_append_val(new_arr, g_array_index(last_arg->val.array, MalVal*, i));
 351     }
 352     return _apply(f, malval_new_list(MAL_LIST, new_arr));
 353 }
 354
 355 MalVal *map(MalVal *mvf, MalVal *lst) {
 356     MalVal *res, *el;
 357     assert_type(mvf, MAL_FUNCTION_C|MAL_FUNCTION_MAL,
 358                 "map called with non-function");
 359     assert_type(lst, MAL_LIST|MAL_VECTOR,
 360                 "map called with non-sequential");
 361     int i, len = _count(lst);
 362     el = malval_new_list(MAL_LIST,
 363                          g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), len));
 364     for (i=0; i<len; i++) {
 365         // TODO: this is replicating some of apply functionality
 366         if (mvf->type & MAL_FUNCTION_MAL) {
 367             Env *fn_env = new_env(mvf->val.func.env,
 368                                   mvf->val.func.args,
 369                                   _slice(lst, i, i+1));
 370             res = mvf->val.func.evaluator(mvf->val.func.body, fn_env);
 371         } else {
 372             res = mvf->val.f1(g_array_index(lst->val.array, MalVal*, i));
 373         }
 374         if (!res || mal_error) return NULL;
 375         g_array_append_val(el->val.array, res);
 376     }
 377     return el;
 378 }
 379
 380 MalVal *sconj(MalVal *args) {
 381     assert_type(args, MAL_LIST|MAL_VECTOR,
 382                 "conj called with non-sequential");
 383     MalVal *src_lst = _nth(args, 0);
 384     assert_type(args, MAL_LIST|MAL_VECTOR,
 385                 "first argument to conj is non-sequential");
 386     int i, len = _count(src_lst) + _count(args) - 1;
 387     GArray *new_arr = g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
 388                                         len);
 389     // Copy in src_lst
 390     for (i=0; i<_count(src_lst); i++) {
 391         g_array_append_val(new_arr, g_array_index(src_lst->val.array, MalVal*, i));
 392     }
 393     // Conj extra args
 394     for (i=1; i<_count(args); i++) {
 395         if (src_lst->type & MAL_LIST) {
 396             g_array_prepend_val(new_arr, g_array_index(args->val.array, MalVal*, i));
 397         } else {
 398             g_array_append_val(new_arr, g_array_index(args->val.array, MalVal*, i));
 399         }
 400     }
 401     return malval_new_list(src_lst->type, new_arr);
 402 }
 403
 404 MalVal *seq(MalVal *obj) {
 405     assert_type(obj, MAL_LIST|MAL_VECTOR|MAL_STRING|MAL_NIL,
 406                 "seq: called with non-sequential");
 407     int cnt, i;
 408     MalVal *lst, *mstr;
 409     switch (obj->type) {
 410     case MAL_LIST:
 411         cnt = _count(obj);
 412         if (cnt == 0) { return &mal_nil; }
 413         return obj;
 414     case MAL_VECTOR:
 415         cnt = _count(obj);
 416         if (cnt == 0) { return &mal_nil; }
 417         lst = malval_new_list(MAL_LIST,
 418                             g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), cnt));
 419         lst->val.array = obj->val.array;
 420         return lst;
 421     case MAL_STRING:
 422         cnt = strlen(obj->val.string);
 423         if (cnt == 0) { return &mal_nil; }
 424         lst = malval_new_list(MAL_LIST,
 425                               g_array_sized_new(TRUE, TRUE, sizeof(MalVal*), cnt));
 426         for (i=0; i<cnt; i++) {
 427             mstr = malval_new_string(g_strdup_printf("%c", obj->val.string[i]));
 428             g_array_append_val(lst->val.array, mstr);
 429         }
 430         return lst;
 431     case MAL_NIL:
 432         return &mal_nil;
 433     }
 434 }
 435
 436
 437 // Metadata functions
 438
 439 MalVal *with_meta(MalVal *obj, MalVal *meta) {
 440     MalVal *new_obj = malval_new(obj->type, meta);
 441     new_obj->val = obj->val;
 442     return new_obj;
 443 }
 444
 445 MalVal *meta(MalVal *obj) {
 446     assert_type(obj, MAL_LIST|MAL_VECTOR|MAL_HASH_MAP|
 447                      MAL_FUNCTION_C|MAL_FUNCTION_MAL|MAL_ATOM,
 448                 "attempt to get metadata from non-collection type");
 449     if (obj->metadata == NULL) {
 450         return &mal_nil;
 451     } else {
 452         return obj->metadata;
 453     }
 454 }
 455
 456
 457 // Atoms
 458
 459 MalVal *atom(MalVal *val) {
 460     return malval_new_atom(val);
 461 }
 462
 463 MalVal *atom_Q(MalVal *exp) { return _atom_Q(exp) ? &mal_true : &mal_false; }
 464
 465 MalVal *deref(MalVal *atm) {
 466     assert_type(atm, MAL_ATOM,
 467                 "deref called on non-atom");
 468     return atm->val.atom_val;
 469 }
 470
 471 MalVal *reset_BANG(MalVal *atm, MalVal *val) {
 472     assert_type(atm, MAL_ATOM,
 473                 "reset! called with non-atom");
 474     atm->val.atom_val = val;
 475     return val;
 476 }
 477
 478 MalVal *swap_BANG(MalVal *args) {
 479     assert_type(args, MAL_LIST|MAL_VECTOR,
 480                 "swap! called with invalid arguments");
 481     assert(_count(args) >= 2,
 482            "swap! called with %d args, needs at least 2", _count(args));
 483     MalVal *atm = _nth(args, 0),
 484            *f = _nth(args, 1),
 485            *sargs = _slice(args, 2, _count(args)),
 486            *fargs = cons(atm->val.atom_val, sargs),
 487            *new_val = _apply(f, fargs);
 488     if (mal_error) { return NULL; }
 489     atm->val.atom_val = new_val;
 490     return new_val;
 491 }
 492
 493
 494
 495 core_ns_entry core_ns[58] = {
 496     {"=", (void*(*)(void*))equal_Q, 2},
 497     {"throw", (void*(*)(void*))throw, 1},
 498     {"nil?", (void*(*)(void*))nil_Q, 1},
 499     {"true?", (void*(*)(void*))true_Q, 1},
 500     {"false?", (void*(*)(void*))false_Q, 1},
 501     {"string?", (void*(*)(void*))string_Q, 1},
 502     {"symbol", (void*(*)(void*))symbol, 1},
 503     {"symbol?", (void*(*)(void*))symbol_Q, 1},
 504     {"keyword", (void*(*)(void*))keyword, 1},
 505     {"keyword?", (void*(*)(void*))keyword_Q, 1},
 506
 507     {"pr-str", (void*(*)(void*))pr_str, -1},
 508     {"str", (void*(*)(void*))str, -1},
 509     {"prn", (void*(*)(void*))prn, -1},
 510     {"println", (void*(*)(void*))println, -1},
 511     {"readline", (void*(*)(void*))mal_readline, 1},
 512     {"read-string", (void*(*)(void*))read_string, 1},
 513     {"slurp", (void*(*)(void*))slurp, 1},
 514     {"<", (void*(*)(void*))int_lt, 2},
 515     {"<=", (void*(*)(void*))int_lte, 2},
 516     {">", (void*(*)(void*))int_gt, 2},
 517     {">=", (void*(*)(void*))int_gte, 2},
 518     {"+", (void*(*)(void*))int_plus, 2},
 519     {"-", (void*(*)(void*))int_minus, 2},
 520     {"*", (void*(*)(void*))int_multiply, 2},
 521     {"/", (void*(*)(void*))int_divide, 2},
 522     {"time-ms", (void*(*)(void*))time_ms, 0},
 523
 524     {"list", (void*(*)(void*))list, -1},
 525     {"list?", (void*(*)(void*))list_Q, 1},
 526     {"vector", (void*(*)(void*))vector, -1},
 527     {"vector?", (void*(*)(void*))vector_Q, 1},
 528     {"hash-map", (void*(*)(void*))_hash_map, -1},
 529     {"map?", (void*(*)(void*))hash_map_Q, 1},
 530     {"assoc", (void*(*)(void*))assoc, -1},
 531     {"dissoc", (void*(*)(void*))dissoc, -1},
 532     {"get", (void*(*)(void*))get, 2},
 533     {"contains?", (void*(*)(void*))contains_Q, 2},
 534     {"keys", (void*(*)(void*))keys, 1},
 535     {"vals", (void*(*)(void*))vals, 1},
 536
 537     {"sequential?", (void*(*)(void*))sequential_Q, 1},
 538     {"cons", (void*(*)(void*))cons, 2},
 539     {"concat", (void*(*)(void*))concat, -1},
 540     {"nth", (void*(*)(void*))nth, 2},
 541     {"first", (void*(*)(void*))_first, 1},
 542     {"rest", (void*(*)(void*))_rest, 1},
 543     {"last", (void*(*)(void*))_last, 1},
 544     {"empty?", (void*(*)(void*))empty_Q, 1},
 545     {"count", (void*(*)(void*))count, 1},
 546     {"apply", (void*(*)(void*))apply, -1},
 547     {"map", (void*(*)(void*))map, 2},
 548
 549     {"conj", (void*(*)(void*))sconj, -1},
 550     {"seq", (void*(*)(void*))seq, 1},
 551
 552     {"with-meta", (void*(*)(void*))with_meta, 2},
 553     {"meta", (void*(*)(void*))meta, 1},
 554     {"atom", (void*(*)(void*))atom, 1},
 555     {"atom?", (void*(*)(void*))atom_Q, 1},
 556     {"deref", (void*(*)(void*))deref, 1},
 557     {"reset!", (void*(*)(void*))reset_BANG, 2},
 558     {"swap!", (void*(*)(void*))swap_BANG, -1},
 559     };