git.gag.com Git - fw/altos/blob - src/lisp/ao_lisp_builtin.c

   1 /*
   2  * Copyright © 2016 Keith Packard <keithp@keithp.com>
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation, either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful, but
  10  * WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12  * General Public License for more details.
  13  */
  14
  15 #include "ao_lisp.h"
  16
  17 static int
  18 builtin_size(void *addr)
  19 {
  20         (void) addr;
  21         return sizeof (struct ao_lisp_builtin);
  22 }
  23
  24 static void
  25 builtin_mark(void *addr)
  26 {
  27         (void) addr;
  28 }
  29
  30 static void
  31 builtin_move(void *addr)
  32 {
  33         (void) addr;
  34 }
  35
  36 const struct ao_lisp_type ao_lisp_builtin_type = {
  37         .size = builtin_size,
  38         .mark = builtin_mark,
  39         .move = builtin_move
  40 };
  41
  42 #ifdef AO_LISP_MAKE_CONST
  43 char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {
  44         return "???";
  45 }
  46 char *ao_lisp_args_name(uint8_t args) {
  47         return "???";
  48 }
  49 #else
  50 static const ao_poly builtin_names[] = {
  51         [builtin_eval] = _ao_lisp_atom_eval,
  52         [builtin_read] = _ao_lisp_atom_read,
  53         [builtin_lambda] = _ao_lisp_atom_lambda,
  54         [builtin_lexpr] = _ao_lisp_atom_lexpr,
  55         [builtin_nlambda] = _ao_lisp_atom_nlambda,
  56         [builtin_macro] = _ao_lisp_atom_macro,
  57         [builtin_car] = _ao_lisp_atom_car,
  58         [builtin_cdr] = _ao_lisp_atom_cdr,
  59         [builtin_cons] = _ao_lisp_atom_cons,
  60         [builtin_last] = _ao_lisp_atom_last,
  61         [builtin_quote] = _ao_lisp_atom_quote,
  62         [builtin_set] = _ao_lisp_atom_set,
  63         [builtin_setq] = _ao_lisp_atom_setq,
  64         [builtin_cond] = _ao_lisp_atom_cond,
  65         [builtin_progn] = _ao_lisp_atom_progn,
  66         [builtin_while] = _ao_lisp_atom_while,
  67         [builtin_print] = _ao_lisp_atom_print,
  68         [builtin_patom] = _ao_lisp_atom_patom,
  69         [builtin_plus] = _ao_lisp_atom_2b,
  70         [builtin_minus] = _ao_lisp_atom_2d,
  71         [builtin_times] = _ao_lisp_atom_2a,
  72         [builtin_divide] = _ao_lisp_atom_2f,
  73         [builtin_mod] = _ao_lisp_atom_25,
  74         [builtin_equal] = _ao_lisp_atom_3d,
  75         [builtin_less] = _ao_lisp_atom_3c,
  76         [builtin_greater] = _ao_lisp_atom_3e,
  77         [builtin_less_equal] = _ao_lisp_atom_3c3d,
  78         [builtin_greater_equal] = _ao_lisp_atom_3e3d,
  79         [builtin_delay] = _ao_lisp_atom_delay,
  80         [builtin_led] = _ao_lisp_atom_led,
  81 };
  82
  83 static char *
  84 ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {
  85         if (b < _builtin_last)
  86                 return ao_lisp_poly_atom(builtin_names[b])->name;
  87         return "???";
  88 }
  89
  90 static const ao_poly ao_lisp_args_atoms[] = {
  91         [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda,
  92         [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr,
  93         [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda,
  94         [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro,
  95 };
  96
  97 char *
  98 ao_lisp_args_name(uint8_t args)
  99 {
 100         if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0])
 101                 return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name;
 102         return "(unknown)";
 103 }
 104 #endif
 105
 106 void
 107 ao_lisp_builtin_print(ao_poly b)
 108 {
 109         struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b);
 110         printf("[builtin %s %s]",
 111                ao_lisp_args_name(builtin->args),
 112                ao_lisp_builtin_name(builtin->func));
 113 }
 114
 115 ao_poly
 116 ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max)
 117 {
 118         int     argc = 0;
 119
 120         while (cons && argc <= max) {
 121                 argc++;
 122                 cons = ao_lisp_poly_cons(cons->cdr);
 123         }
 124         if (argc < min || argc > max)
 125                 return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name);
 126         return _ao_lisp_atom_t;
 127 }
 128
 129 ao_poly
 130 ao_lisp_arg(struct ao_lisp_cons *cons, int argc)
 131 {
 132         if (!cons)
 133                 return AO_LISP_NIL;
 134         while (argc--) {
 135                 if (!cons)
 136                         return AO_LISP_NIL;
 137                 cons = ao_lisp_poly_cons(cons->cdr);
 138         }
 139         return cons->car;
 140 }
 141
 142 ao_poly
 143 ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok)
 144 {
 145         ao_poly car = ao_lisp_arg(cons, argc);
 146
 147         if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type)
 148                 return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc);
 149         return _ao_lisp_atom_t;
 150 }
 151
 152 ao_poly
 153 ao_lisp_car(struct ao_lisp_cons *cons)
 154 {
 155         if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1))
 156                 return AO_LISP_NIL;
 157         if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0))
 158                 return AO_LISP_NIL;
 159         return ao_lisp_poly_cons(cons->car)->car;
 160 }
 161
 162 ao_poly
 163 ao_lisp_cdr(struct ao_lisp_cons *cons)
 164 {
 165         if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1))
 166                 return AO_LISP_NIL;
 167         if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0))
 168                 return AO_LISP_NIL;
 169         return ao_lisp_poly_cons(cons->car)->cdr;
 170 }
 171
 172 ao_poly
 173 ao_lisp_cons(struct ao_lisp_cons *cons)
 174 {
 175         ao_poly car, cdr;
 176         if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2))
 177                 return AO_LISP_NIL;
 178         if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1))
 179                 return AO_LISP_NIL;
 180         car = ao_lisp_arg(cons, 0);
 181         cdr = ao_lisp_arg(cons, 1);
 182         return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr)));
 183 }
 184
 185 ao_poly
 186 ao_lisp_last(struct ao_lisp_cons *cons)
 187 {
 188         ao_poly l;
 189         if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1))
 190                 return AO_LISP_NIL;
 191         if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1))
 192                 return AO_LISP_NIL;
 193         l = ao_lisp_arg(cons, 0);
 194         while (l) {
 195                 struct ao_lisp_cons *list = ao_lisp_poly_cons(l);
 196                 if (!list->cdr)
 197                         return list->car;
 198                 l = list->cdr;
 199         }
 200         return AO_LISP_NIL;
 201 }
 202
 203 ao_poly
 204 ao_lisp_quote(struct ao_lisp_cons *cons)
 205 {
 206         if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1))
 207                 return AO_LISP_NIL;
 208         return ao_lisp_arg(cons, 0);
 209 }
 210
 211 ao_poly
 212 ao_lisp_set(struct ao_lisp_cons *cons)
 213 {
 214         if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2))
 215                 return AO_LISP_NIL;
 216         if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0))
 217                 return AO_LISP_NIL;
 218
 219         return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1));
 220 }
 221
 222 ao_poly
 223 ao_lisp_setq(struct ao_lisp_cons *cons)
 224 {
 225         struct ao_lisp_cons     *expand = 0;
 226         if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2))
 227                 return AO_LISP_NIL;
 228         expand = ao_lisp_cons_cons(_ao_lisp_atom_set,
 229                                    ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote,
 230                                                                        ao_lisp_cons_cons(cons->car, NULL))),
 231                                                      ao_lisp_poly_cons(cons->cdr)));
 232         return ao_lisp_cons_poly(expand);
 233 }
 234
 235 ao_poly
 236 ao_lisp_cond(struct ao_lisp_cons *cons)
 237 {
 238         ao_lisp_set_cond(cons);
 239         return AO_LISP_NIL;
 240 }
 241
 242 ao_poly
 243 ao_lisp_progn(struct ao_lisp_cons *cons)
 244 {
 245         ao_lisp_stack->state = eval_progn;
 246         ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons);
 247         return AO_LISP_NIL;
 248 }
 249
 250 ao_poly
 251 ao_lisp_while(struct ao_lisp_cons *cons)
 252 {
 253         ao_lisp_stack->state = eval_while;
 254         ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons);
 255         return AO_LISP_NIL;
 256 }
 257
 258 ao_poly
 259 ao_lisp_print(struct ao_lisp_cons *cons)
 260 {
 261         ao_poly val = AO_LISP_NIL;
 262         while (cons) {
 263                 val = cons->car;
 264                 ao_lisp_poly_print(val);
 265                 cons = ao_lisp_poly_cons(cons->cdr);
 266                 if (cons)
 267                         printf(" ");
 268         }
 269         printf("\n");
 270         return val;
 271 }
 272
 273 ao_poly
 274 ao_lisp_patom(struct ao_lisp_cons *cons)
 275 {
 276         ao_poly val = AO_LISP_NIL;
 277         while (cons) {
 278                 val = cons->car;
 279                 ao_lisp_poly_patom(val);
 280                 cons = ao_lisp_poly_cons(cons->cdr);
 281         }
 282         return val;
 283 }
 284
 285 ao_poly
 286 ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op)
 287 {
 288         ao_poly ret = AO_LISP_NIL;
 289
 290         while (cons) {
 291                 ao_poly         car = cons->car;
 292                 uint8_t         rt = ao_lisp_poly_type(ret);
 293                 uint8_t         ct = ao_lisp_poly_type(car);
 294
 295                 cons = ao_lisp_poly_cons(cons->cdr);
 296
 297                 if (rt == AO_LISP_NIL)
 298                         ret = car;
 299
 300                 else if (rt == AO_LISP_INT && ct == AO_LISP_INT) {
 301                         int     r = ao_lisp_poly_int(ret);
 302                         int     c = ao_lisp_poly_int(car);
 303
 304                         switch(op) {
 305                         case builtin_plus:
 306                                 r += c;
 307                                 break;
 308                         case builtin_minus:
 309                                 r -= c;
 310                                 break;
 311                         case builtin_times:
 312                                 r *= c;
 313                                 break;
 314                         case builtin_divide:
 315                                 if (c == 0)
 316                                         return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero");
 317                                 r /= c;
 318                                 break;
 319                         case builtin_mod:
 320                                 if (c == 0)
 321                                         return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero");
 322                                 r %= c;
 323                                 break;
 324                         default:
 325                                 break;
 326                         }
 327                         ret = ao_lisp_int_poly(r);
 328                 }
 329
 330                 else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus)
 331                         ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret),
 332                                                                      ao_lisp_poly_string(car)));
 333                 else
 334                         return ao_lisp_error(AO_LISP_INVALID, "invalid args");
 335         }
 336         return ret;
 337 }
 338
 339 ao_poly
 340 ao_lisp_plus(struct ao_lisp_cons *cons)
 341 {
 342         return ao_lisp_math(cons, builtin_plus);
 343 }
 344
 345 ao_poly
 346 ao_lisp_minus(struct ao_lisp_cons *cons)
 347 {
 348         return ao_lisp_math(cons, builtin_minus);
 349 }
 350
 351 ao_poly
 352 ao_lisp_times(struct ao_lisp_cons *cons)
 353 {
 354         return ao_lisp_math(cons, builtin_times);
 355 }
 356
 357 ao_poly
 358 ao_lisp_divide(struct ao_lisp_cons *cons)
 359 {
 360         return ao_lisp_math(cons, builtin_divide);
 361 }
 362
 363 ao_poly
 364 ao_lisp_mod(struct ao_lisp_cons *cons)
 365 {
 366         return ao_lisp_math(cons, builtin_mod);
 367 }
 368
 369 ao_poly
 370 ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op)
 371 {
 372         ao_poly left;
 373
 374         if (!cons)
 375                 return _ao_lisp_atom_t;
 376
 377         left = cons->car;
 378         cons = ao_lisp_poly_cons(cons->cdr);
 379         while (cons) {
 380                 ao_poly right = cons->car;
 381
 382                 if (op == builtin_equal) {
 383                         if (left != right)
 384                                 return AO_LISP_NIL;
 385                 } else {
 386                         uint8_t lt = ao_lisp_poly_type(left);
 387                         uint8_t rt = ao_lisp_poly_type(right);
 388                         if (lt == AO_LISP_INT && rt == AO_LISP_INT) {
 389                                 int l = ao_lisp_poly_int(left);
 390                                 int r = ao_lisp_poly_int(right);
 391
 392                                 switch (op) {
 393                                 case builtin_less:
 394                                         if (!(l < r))
 395                                                 return AO_LISP_NIL;
 396                                         break;
 397                                 case builtin_greater:
 398                                         if (!(l > r))
 399                                                 return AO_LISP_NIL;
 400                                         break;
 401                                 case builtin_less_equal:
 402                                         if (!(l <= r))
 403                                                 return AO_LISP_NIL;
 404                                         break;
 405                                 case builtin_greater_equal:
 406                                         if (!(l >= r))
 407                                                 return AO_LISP_NIL;
 408                                         break;
 409                                 default:
 410                                         break;
 411                                 }
 412                         } else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) {
 413                                 int c = strcmp(ao_lisp_poly_string(left),
 414                                                ao_lisp_poly_string(right));
 415                                 switch (op) {
 416                                 case builtin_less:
 417                                         if (!(c < 0))
 418                                                 return AO_LISP_NIL;
 419                                         break;
 420                                 case builtin_greater:
 421                                         if (!(c > 0))
 422                                                 return AO_LISP_NIL;
 423                                         break;
 424                                 case builtin_less_equal:
 425                                         if (!(c <= 0))
 426                                                 return AO_LISP_NIL;
 427                                         break;
 428                                 case builtin_greater_equal:
 429                                         if (!(c >= 0))
 430                                                 return AO_LISP_NIL;
 431                                         break;
 432                                 default:
 433                                         break;
 434                                 }
 435                         }
 436                 }
 437                 left = right;
 438                 cons = ao_lisp_poly_cons(cons->cdr);
 439         }
 440         return _ao_lisp_atom_t;
 441 }
 442
 443 ao_poly
 444 ao_lisp_equal(struct ao_lisp_cons *cons)
 445 {
 446         return ao_lisp_compare(cons, builtin_equal);
 447 }
 448
 449 ao_poly
 450 ao_lisp_less(struct ao_lisp_cons *cons)
 451 {
 452         return ao_lisp_compare(cons, builtin_less);
 453 }
 454
 455 ao_poly
 456 ao_lisp_greater(struct ao_lisp_cons *cons)
 457 {
 458         return ao_lisp_compare(cons, builtin_greater);
 459 }
 460
 461 ao_poly
 462 ao_lisp_less_equal(struct ao_lisp_cons *cons)
 463 {
 464         return ao_lisp_compare(cons, builtin_less_equal);
 465 }
 466
 467 ao_poly
 468 ao_lisp_greater_equal(struct ao_lisp_cons *cons)
 469 {
 470         return ao_lisp_compare(cons, builtin_greater_equal);
 471 }
 472
 473 ao_poly
 474 ao_lisp_led(struct ao_lisp_cons *cons)
 475 {
 476         ao_poly led;
 477         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 478                 return AO_LISP_NIL;
 479         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0))
 480                 return AO_LISP_NIL;
 481         led = ao_lisp_arg(cons, 0);
 482         ao_lisp_os_led(ao_lisp_poly_int(led));
 483         return led;
 484 }
 485
 486 ao_poly
 487 ao_lisp_delay(struct ao_lisp_cons *cons)
 488 {
 489         ao_poly delay;
 490         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 491                 return AO_LISP_NIL;
 492         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0))
 493                 return AO_LISP_NIL;
 494         delay = ao_lisp_arg(cons, 0);
 495         ao_lisp_os_delay(ao_lisp_poly_int(delay));
 496         return delay;
 497 }
 498
 499 ao_poly
 500 ao_lisp_do_eval(struct ao_lisp_cons *cons)
 501 {
 502         if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1))
 503                 return AO_LISP_NIL;
 504         ao_lisp_stack->state = eval_sexpr;
 505         return cons->car;
 506 }
 507
 508 ao_poly
 509 ao_lisp_do_read(struct ao_lisp_cons *cons)
 510 {
 511         if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0))
 512                 return AO_LISP_NIL;
 513         return ao_lisp_read();
 514 }
 515
 516 const ao_lisp_func_t ao_lisp_builtins[] = {
 517         [builtin_eval] = ao_lisp_do_eval,
 518         [builtin_read] = ao_lisp_do_read,
 519         [builtin_lambda] = ao_lisp_lambda,
 520         [builtin_lexpr] = ao_lisp_lexpr,
 521         [builtin_nlambda] = ao_lisp_nlambda,
 522         [builtin_macro] = ao_lisp_macro,
 523         [builtin_car] = ao_lisp_car,
 524         [builtin_cdr] = ao_lisp_cdr,
 525         [builtin_cons] = ao_lisp_cons,
 526         [builtin_last] = ao_lisp_last,
 527         [builtin_quote] = ao_lisp_quote,
 528         [builtin_set] = ao_lisp_set,
 529         [builtin_setq] = ao_lisp_setq,
 530         [builtin_cond] = ao_lisp_cond,
 531         [builtin_progn] = ao_lisp_progn,
 532         [builtin_while] = ao_lisp_while,
 533         [builtin_print] = ao_lisp_print,
 534         [builtin_patom] = ao_lisp_patom,
 535         [builtin_plus] = ao_lisp_plus,
 536         [builtin_minus] = ao_lisp_minus,
 537         [builtin_times] = ao_lisp_times,
 538         [builtin_divide] = ao_lisp_divide,
 539         [builtin_mod] = ao_lisp_mod,
 540         [builtin_equal] = ao_lisp_equal,
 541         [builtin_less] = ao_lisp_less,
 542         [builtin_greater] = ao_lisp_greater,
 543         [builtin_less_equal] = ao_lisp_less_equal,
 544         [builtin_greater_equal] = ao_lisp_greater_equal,
 545         [builtin_led] = ao_lisp_led,
 546         [builtin_delay] = ao_lisp_delay,
 547 };
 548