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 #include <limits.h>
  17
  18 static int
  19 builtin_size(void *addr)
  20 {
  21         (void) addr;
  22         return sizeof (struct ao_lisp_builtin);
  23 }
  24
  25 static void
  26 builtin_mark(void *addr)
  27 {
  28         (void) addr;
  29 }
  30
  31 static void
  32 builtin_move(void *addr)
  33 {
  34         (void) addr;
  35 }
  36
  37 const struct ao_lisp_type ao_lisp_builtin_type = {
  38         .size = builtin_size,
  39         .mark = builtin_mark,
  40         .move = builtin_move
  41 };
  42
  43 #ifdef AO_LISP_MAKE_CONST
  44
  45 #define AO_LISP_BUILTIN_CASENAME
  46 #include "ao_lisp_builtin.h"
  47
  48 char *ao_lisp_args_name(uint8_t args) {
  49         args &= AO_LISP_FUNC_MASK;
  50         switch (args) {
  51         case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name;
  52         case AO_LISP_FUNC_LEXPR: return ao_lisp_poly_atom(_ao_lisp_atom_lexpr)->name;
  53         case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name;
  54         case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name;
  55         default: return "???";
  56         }
  57 }
  58 #else
  59
  60 #define AO_LISP_BUILTIN_ARRAYNAME
  61 #include "ao_lisp_builtin.h"
  62
  63 static char *
  64 ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {
  65         if (b < _builtin_last)
  66                 return ao_lisp_poly_atom(builtin_names[b])->name;
  67         return "???";
  68 }
  69
  70 static const ao_poly ao_lisp_args_atoms[] = {
  71         [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda,
  72         [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr,
  73         [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda,
  74         [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro,
  75 };
  76
  77 char *
  78 ao_lisp_args_name(uint8_t args)
  79 {
  80         args &= AO_LISP_FUNC_MASK;
  81         if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0])
  82                 return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name;
  83         return "(unknown)";
  84 }
  85 #endif
  86
  87 void
  88 ao_lisp_builtin_write(ao_poly b)
  89 {
  90         struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b);
  91         printf("%s", ao_lisp_builtin_name(builtin->func));
  92 }
  93
  94 ao_poly
  95 ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max)
  96 {
  97         int     argc = 0;
  98
  99         while (cons && argc <= max) {
 100                 argc++;
 101                 cons = ao_lisp_poly_cons(cons->cdr);
 102         }
 103         if (argc < min || argc > max)
 104                 return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name);
 105         return _ao_lisp_bool_true;
 106 }
 107
 108 ao_poly
 109 ao_lisp_arg(struct ao_lisp_cons *cons, int argc)
 110 {
 111         if (!cons)
 112                 return AO_LISP_NIL;
 113         while (argc--) {
 114                 if (!cons)
 115                         return AO_LISP_NIL;
 116                 cons = ao_lisp_poly_cons(cons->cdr);
 117         }
 118         return cons->car;
 119 }
 120
 121 ao_poly
 122 ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok)
 123 {
 124         ao_poly car = ao_lisp_arg(cons, argc);
 125
 126         if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type)
 127                 return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc);
 128         return _ao_lisp_bool_true;
 129 }
 130
 131 ao_poly
 132 ao_lisp_do_car(struct ao_lisp_cons *cons)
 133 {
 134         if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1))
 135                 return AO_LISP_NIL;
 136         if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0))
 137                 return AO_LISP_NIL;
 138         return ao_lisp_poly_cons(cons->car)->car;
 139 }
 140
 141 ao_poly
 142 ao_lisp_do_cdr(struct ao_lisp_cons *cons)
 143 {
 144         if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1))
 145                 return AO_LISP_NIL;
 146         if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0))
 147                 return AO_LISP_NIL;
 148         return ao_lisp_poly_cons(cons->car)->cdr;
 149 }
 150
 151 ao_poly
 152 ao_lisp_do_cons(struct ao_lisp_cons *cons)
 153 {
 154         ao_poly car, cdr;
 155         if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2))
 156                 return AO_LISP_NIL;
 157         car = ao_lisp_arg(cons, 0);
 158         cdr = ao_lisp_arg(cons, 1);
 159         return ao_lisp__cons(car, cdr);
 160 }
 161
 162 ao_poly
 163 ao_lisp_do_last(struct ao_lisp_cons *cons)
 164 {
 165         ao_poly l;
 166         if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1))
 167                 return AO_LISP_NIL;
 168         if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1))
 169                 return AO_LISP_NIL;
 170         l = ao_lisp_arg(cons, 0);
 171         while (l) {
 172                 struct ao_lisp_cons *list = ao_lisp_poly_cons(l);
 173                 if (!list->cdr)
 174                         return list->car;
 175                 l = list->cdr;
 176         }
 177         return AO_LISP_NIL;
 178 }
 179
 180 ao_poly
 181 ao_lisp_do_length(struct ao_lisp_cons *cons)
 182 {
 183         if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1))
 184                 return AO_LISP_NIL;
 185         if (!ao_lisp_check_argt(_ao_lisp_atom_length, cons, 0, AO_LISP_CONS, 1))
 186                 return AO_LISP_NIL;
 187         return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))));
 188 }
 189
 190 ao_poly
 191 ao_lisp_do_quote(struct ao_lisp_cons *cons)
 192 {
 193         if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1))
 194                 return AO_LISP_NIL;
 195         return ao_lisp_arg(cons, 0);
 196 }
 197
 198 ao_poly
 199 ao_lisp_do_set(struct ao_lisp_cons *cons)
 200 {
 201         if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2))
 202                 return AO_LISP_NIL;
 203         if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0))
 204                 return AO_LISP_NIL;
 205
 206         return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1));
 207 }
 208
 209 ao_poly
 210 ao_lisp_do_setq(struct ao_lisp_cons *cons)
 211 {
 212         ao_poly name;
 213         if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2))
 214                 return AO_LISP_NIL;
 215         name = cons->car;
 216         if (ao_lisp_poly_type(name) != AO_LISP_ATOM)
 217                 return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom");
 218         if (!ao_lisp_atom_ref(ao_lisp_frame_current, name))
 219                 return ao_lisp_error(AO_LISP_INVALID, "atom not defined");
 220         return ao_lisp__cons(_ao_lisp_atom_set,
 221                              ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote,
 222                                                          ao_lisp__cons(name, AO_LISP_NIL)),
 223                                            cons->cdr));
 224 }
 225
 226 ao_poly
 227 ao_lisp_do_cond(struct ao_lisp_cons *cons)
 228 {
 229         ao_lisp_set_cond(cons);
 230         return AO_LISP_NIL;
 231 }
 232
 233 ao_poly
 234 ao_lisp_do_progn(struct ao_lisp_cons *cons)
 235 {
 236         ao_lisp_stack->state = eval_progn;
 237         ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons);
 238         return AO_LISP_NIL;
 239 }
 240
 241 ao_poly
 242 ao_lisp_do_while(struct ao_lisp_cons *cons)
 243 {
 244         ao_lisp_stack->state = eval_while;
 245         ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons);
 246         return AO_LISP_NIL;
 247 }
 248
 249 ao_poly
 250 ao_lisp_do_write(struct ao_lisp_cons *cons)
 251 {
 252         ao_poly val = AO_LISP_NIL;
 253         while (cons) {
 254                 val = cons->car;
 255                 ao_lisp_poly_write(val);
 256                 cons = ao_lisp_poly_cons(cons->cdr);
 257                 if (cons)
 258                         printf(" ");
 259         }
 260         printf("\n");
 261         return _ao_lisp_bool_true;
 262 }
 263
 264 ao_poly
 265 ao_lisp_do_display(struct ao_lisp_cons *cons)
 266 {
 267         ao_poly val = AO_LISP_NIL;
 268         while (cons) {
 269                 val = cons->car;
 270                 ao_lisp_poly_display(val);
 271                 cons = ao_lisp_poly_cons(cons->cdr);
 272         }
 273         return _ao_lisp_bool_true;
 274 }
 275
 276 ao_poly
 277 ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op)
 278 {
 279         struct ao_lisp_cons *orig_cons = cons;
 280         ao_poly ret = AO_LISP_NIL;
 281
 282         while (cons) {
 283                 ao_poly         car = cons->car;
 284                 ao_poly         cdr;
 285                 uint8_t         rt = ao_lisp_poly_type(ret);
 286                 uint8_t         ct = ao_lisp_poly_type(car);
 287
 288                 if (cons == orig_cons) {
 289                         ret = car;
 290                         if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) {
 291                                 switch (op) {
 292                                 case builtin_minus:
 293                                         ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret));
 294                                         break;
 295                                 case builtin_divide:
 296                                         switch (ao_lisp_poly_integer(ret)) {
 297                                         case 0:
 298                                                 return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero");
 299                                         case 1:
 300                                                 break;
 301                                         default:
 302                                                 ret = ao_lisp_int_poly(0);
 303                                                 break;
 304                                         }
 305                                         break;
 306                                 default:
 307                                         break;
 308                                 }
 309                         }
 310                 } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) {
 311                         int32_t r = ao_lisp_poly_integer(ret);
 312                         int32_t c = ao_lisp_poly_integer(car);
 313
 314                         switch(op) {
 315                         case builtin_plus:
 316                                 r += c;
 317                                 break;
 318                         case builtin_minus:
 319                                 r -= c;
 320                                 break;
 321                         case builtin_times:
 322                                 r *= c;
 323                                 break;
 324                         case builtin_divide:
 325                                 if (c == 0)
 326                                         return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero");
 327                                 r /= c;
 328                                 break;
 329                         case builtin_quotient:
 330                                 if (c == 0)
 331                                         return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero");
 332                                 if (r % c != 0 && (c < 0) != (r < 0))
 333                                         r = r / c - 1;
 334                                 else
 335                                         r = r / c;
 336                                 break;
 337                         case builtin_remainder:
 338                                 if (c == 0)
 339                                         return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero");
 340                                 r %= c;
 341                                 break;
 342                         case builtin_modulo:
 343                                 if (c == 0)
 344                                         return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero");
 345                                 r %= c;
 346                                 if ((r < 0) != (c < 0))
 347                                         r += c;
 348                                 break;
 349                         default:
 350                                 break;
 351                         }
 352                         ret = ao_lisp_integer_poly(r);
 353                 }
 354
 355                 else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus)
 356                         ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret),
 357                                                                      ao_lisp_poly_string(car)));
 358                 else
 359                         return ao_lisp_error(AO_LISP_INVALID, "invalid args");
 360
 361                 cdr = cons->cdr;
 362                 if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS)
 363                         return ao_lisp_error(AO_LISP_INVALID, "improper list");
 364                 cons = ao_lisp_poly_cons(cdr);
 365         }
 366         return ret;
 367 }
 368
 369 ao_poly
 370 ao_lisp_do_plus(struct ao_lisp_cons *cons)
 371 {
 372         return ao_lisp_math(cons, builtin_plus);
 373 }
 374
 375 ao_poly
 376 ao_lisp_do_minus(struct ao_lisp_cons *cons)
 377 {
 378         return ao_lisp_math(cons, builtin_minus);
 379 }
 380
 381 ao_poly
 382 ao_lisp_do_times(struct ao_lisp_cons *cons)
 383 {
 384         return ao_lisp_math(cons, builtin_times);
 385 }
 386
 387 ao_poly
 388 ao_lisp_do_divide(struct ao_lisp_cons *cons)
 389 {
 390         return ao_lisp_math(cons, builtin_divide);
 391 }
 392
 393 ao_poly
 394 ao_lisp_do_quotient(struct ao_lisp_cons *cons)
 395 {
 396         return ao_lisp_math(cons, builtin_quotient);
 397 }
 398
 399 ao_poly
 400 ao_lisp_do_modulo(struct ao_lisp_cons *cons)
 401 {
 402         return ao_lisp_math(cons, builtin_modulo);
 403 }
 404
 405 ao_poly
 406 ao_lisp_do_remainder(struct ao_lisp_cons *cons)
 407 {
 408         return ao_lisp_math(cons, builtin_remainder);
 409 }
 410
 411 ao_poly
 412 ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op)
 413 {
 414         ao_poly left;
 415
 416         if (!cons)
 417                 return _ao_lisp_bool_true;
 418
 419         left = cons->car;
 420         cons = ao_lisp_poly_cons(cons->cdr);
 421         while (cons) {
 422                 ao_poly right = cons->car;
 423
 424                 if (op == builtin_equal) {
 425                         if (left != right)
 426                                 return _ao_lisp_bool_false;
 427                 } else {
 428                         uint8_t lt = ao_lisp_poly_type(left);
 429                         uint8_t rt = ao_lisp_poly_type(right);
 430                         if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) {
 431                                 int32_t l = ao_lisp_poly_integer(left);
 432                                 int32_t r = ao_lisp_poly_integer(right);
 433
 434                                 switch (op) {
 435                                 case builtin_less:
 436                                         if (!(l < r))
 437                                                 return _ao_lisp_bool_false;
 438                                         break;
 439                                 case builtin_greater:
 440                                         if (!(l > r))
 441                                                 return _ao_lisp_bool_false;
 442                                         break;
 443                                 case builtin_less_equal:
 444                                         if (!(l <= r))
 445                                                 return _ao_lisp_bool_false;
 446                                         break;
 447                                 case builtin_greater_equal:
 448                                         if (!(l >= r))
 449                                                 return _ao_lisp_bool_false;
 450                                         break;
 451                                 default:
 452                                         break;
 453                                 }
 454                         } else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) {
 455                                 int c = strcmp(ao_lisp_poly_string(left),
 456                                                ao_lisp_poly_string(right));
 457                                 switch (op) {
 458                                 case builtin_less:
 459                                         if (!(c < 0))
 460                                                 return _ao_lisp_bool_false;
 461                                         break;
 462                                 case builtin_greater:
 463                                         if (!(c > 0))
 464                                                 return _ao_lisp_bool_false;
 465                                         break;
 466                                 case builtin_less_equal:
 467                                         if (!(c <= 0))
 468                                                 return _ao_lisp_bool_false;
 469                                         break;
 470                                 case builtin_greater_equal:
 471                                         if (!(c >= 0))
 472                                                 return _ao_lisp_bool_false;
 473                                         break;
 474                                 default:
 475                                         break;
 476                                 }
 477                         }
 478                 }
 479                 left = right;
 480                 cons = ao_lisp_poly_cons(cons->cdr);
 481         }
 482         return _ao_lisp_bool_true;
 483 }
 484
 485 ao_poly
 486 ao_lisp_do_equal(struct ao_lisp_cons *cons)
 487 {
 488         return ao_lisp_compare(cons, builtin_equal);
 489 }
 490
 491 ao_poly
 492 ao_lisp_do_less(struct ao_lisp_cons *cons)
 493 {
 494         return ao_lisp_compare(cons, builtin_less);
 495 }
 496
 497 ao_poly
 498 ao_lisp_do_greater(struct ao_lisp_cons *cons)
 499 {
 500         return ao_lisp_compare(cons, builtin_greater);
 501 }
 502
 503 ao_poly
 504 ao_lisp_do_less_equal(struct ao_lisp_cons *cons)
 505 {
 506         return ao_lisp_compare(cons, builtin_less_equal);
 507 }
 508
 509 ao_poly
 510 ao_lisp_do_greater_equal(struct ao_lisp_cons *cons)
 511 {
 512         return ao_lisp_compare(cons, builtin_greater_equal);
 513 }
 514
 515 ao_poly
 516 ao_lisp_do_list_to_string(struct ao_lisp_cons *cons)
 517 {
 518         if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1))
 519                 return AO_LISP_NIL;
 520         if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, cons, 0, AO_LISP_CONS, 1))
 521                 return AO_LISP_NIL;
 522         return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)));
 523 }
 524
 525 ao_poly
 526 ao_lisp_do_string_to_list(struct ao_lisp_cons *cons)
 527 {
 528         if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1))
 529                 return AO_LISP_NIL;
 530         if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, cons, 0, AO_LISP_STRING, 0))
 531                 return AO_LISP_NIL;
 532         return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0)));
 533 }
 534
 535 ao_poly
 536 ao_lisp_do_flush_output(struct ao_lisp_cons *cons)
 537 {
 538         if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0))
 539                 return AO_LISP_NIL;
 540         ao_lisp_os_flush();
 541         return _ao_lisp_bool_true;
 542 }
 543
 544 ao_poly
 545 ao_lisp_do_led(struct ao_lisp_cons *cons)
 546 {
 547         ao_poly led;
 548         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 549                 return AO_LISP_NIL;
 550         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0))
 551                 return AO_LISP_NIL;
 552         led = ao_lisp_arg(cons, 0);
 553         ao_lisp_os_led(ao_lisp_poly_int(led));
 554         return led;
 555 }
 556
 557 ao_poly
 558 ao_lisp_do_delay(struct ao_lisp_cons *cons)
 559 {
 560         ao_poly delay;
 561         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 562                 return AO_LISP_NIL;
 563         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0))
 564                 return AO_LISP_NIL;
 565         delay = ao_lisp_arg(cons, 0);
 566         ao_lisp_os_delay(ao_lisp_poly_int(delay));
 567         return delay;
 568 }
 569
 570 ao_poly
 571 ao_lisp_do_eval(struct ao_lisp_cons *cons)
 572 {
 573         if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1))
 574                 return AO_LISP_NIL;
 575         ao_lisp_stack->state = eval_sexpr;
 576         return cons->car;
 577 }
 578
 579 ao_poly
 580 ao_lisp_do_apply(struct ao_lisp_cons *cons)
 581 {
 582         if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX))
 583                 return AO_LISP_NIL;
 584         ao_lisp_stack->state = eval_apply;
 585         return ao_lisp_cons_poly(cons);
 586 }
 587
 588 ao_poly
 589 ao_lisp_do_read(struct ao_lisp_cons *cons)
 590 {
 591         if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0))
 592                 return AO_LISP_NIL;
 593         return ao_lisp_read();
 594 }
 595
 596 ao_poly
 597 ao_lisp_do_collect(struct ao_lisp_cons *cons)
 598 {
 599         int     free;
 600         (void) cons;
 601         free = ao_lisp_collect(AO_LISP_COLLECT_FULL);
 602         return ao_lisp_int_poly(free);
 603 }
 604
 605 ao_poly
 606 ao_lisp_do_nullp(struct ao_lisp_cons *cons)
 607 {
 608         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 609                 return AO_LISP_NIL;
 610         if (ao_lisp_arg(cons, 0) == AO_LISP_NIL)
 611                 return _ao_lisp_bool_true;
 612         else
 613                 return _ao_lisp_bool_false;
 614 }
 615
 616 ao_poly
 617 ao_lisp_do_not(struct ao_lisp_cons *cons)
 618 {
 619         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 620                 return AO_LISP_NIL;
 621         if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false)
 622                 return _ao_lisp_bool_true;
 623         else
 624                 return _ao_lisp_bool_false;
 625 }
 626
 627 static ao_poly
 628 ao_lisp_do_typep(int type, struct ao_lisp_cons *cons)
 629 {
 630         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 631                 return AO_LISP_NIL;
 632         if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type)
 633                 return _ao_lisp_bool_true;
 634         return _ao_lisp_bool_false;
 635 }
 636
 637 ao_poly
 638 ao_lisp_do_pairp(struct ao_lisp_cons *cons)
 639 {
 640         return ao_lisp_do_typep(AO_LISP_CONS, cons);
 641 }
 642
 643 ao_poly
 644 ao_lisp_do_numberp(struct ao_lisp_cons *cons)
 645 {
 646         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 647                 return AO_LISP_NIL;
 648         switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) {
 649         case AO_LISP_INT:
 650         case AO_LISP_BIGINT:
 651                 return _ao_lisp_bool_true;
 652         default:
 653                 return _ao_lisp_bool_false;
 654         }
 655 }
 656
 657 ao_poly
 658 ao_lisp_do_stringp(struct ao_lisp_cons *cons)
 659 {
 660         return ao_lisp_do_typep(AO_LISP_STRING, cons);
 661 }
 662
 663 ao_poly
 664 ao_lisp_do_symbolp(struct ao_lisp_cons *cons)
 665 {
 666         return ao_lisp_do_typep(AO_LISP_ATOM, cons);
 667 }
 668
 669 ao_poly
 670 ao_lisp_do_booleanp(struct ao_lisp_cons *cons)
 671 {
 672         return ao_lisp_do_typep(AO_LISP_BOOL, cons);
 673 }
 674
 675 ao_poly
 676 ao_lisp_do_procedurep(struct ao_lisp_cons *cons)
 677 {
 678         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 679                 return AO_LISP_NIL;
 680         switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) {
 681         case AO_LISP_BUILTIN:
 682         case AO_LISP_LAMBDA:
 683                 return _ao_lisp_bool_true;
 684         default:
 685         return _ao_lisp_bool_false;
 686         }
 687 }
 688
 689 /* This one is special -- a list is either nil or
 690  * a 'proper' list with only cons cells
 691  */
 692 ao_poly
 693 ao_lisp_do_listp(struct ao_lisp_cons *cons)
 694 {
 695         ao_poly v;
 696         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 697                 return AO_LISP_NIL;
 698         v = ao_lisp_arg(cons, 0);
 699         for (;;) {
 700                 if (v == AO_LISP_NIL)
 701                         return _ao_lisp_bool_true;
 702                 if (ao_lisp_poly_type(v) != AO_LISP_CONS)
 703                         return _ao_lisp_bool_false;
 704                 v = ao_lisp_poly_cons(v)->cdr;
 705         }
 706 }
 707
 708 ao_poly
 709 ao_lisp_do_set_car(struct ao_lisp_cons *cons)
 710 {
 711         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2))
 712                 return AO_LISP_NIL;
 713         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0))
 714                 return AO_LISP_NIL;
 715         return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1);
 716 }
 717
 718 ao_poly
 719 ao_lisp_do_set_cdr(struct ao_lisp_cons *cons)
 720 {
 721         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2))
 722                 return AO_LISP_NIL;
 723         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0))
 724                 return AO_LISP_NIL;
 725         return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1);
 726 }
 727
 728 ao_poly
 729 ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons)
 730 {
 731         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 732                 return AO_LISP_NIL;
 733         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_ATOM, 0))
 734                 return AO_LISP_NIL;
 735         return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name));
 736 }
 737
 738 ao_poly
 739 ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons)
 740 {
 741         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 742                 return AO_LISP_NIL;
 743         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_STRING, 0))
 744                 return AO_LISP_NIL;
 745
 746         return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0))));
 747 }
 748
 749 ao_poly
 750 ao_lisp_do_read_char(struct ao_lisp_cons *cons)
 751 {
 752         int     c;
 753         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0))
 754                 return AO_LISP_NIL;
 755         c = getchar();
 756         return ao_lisp_int_poly(c);
 757 }
 758
 759 ao_poly
 760 ao_lisp_do_write_char(struct ao_lisp_cons *cons)
 761 {
 762         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1))
 763                 return AO_LISP_NIL;
 764         if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0))
 765                 return AO_LISP_NIL;
 766         putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0)));
 767         return _ao_lisp_bool_true;
 768 }
 769
 770 ao_poly
 771 ao_lisp_do_exit(struct ao_lisp_cons *cons)
 772 {
 773         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0))
 774                 return AO_LISP_NIL;
 775         ao_lisp_exception |= AO_LISP_EXIT;
 776         return _ao_lisp_bool_true;
 777 }
 778
 779 ao_poly
 780 ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons)
 781 {
 782         int     jiffy;
 783
 784         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0))
 785                 return AO_LISP_NIL;
 786         jiffy = ao_lisp_os_jiffy();
 787         return (ao_lisp_int_poly(jiffy));
 788 }
 789
 790 ao_poly
 791 ao_lisp_do_current_second(struct ao_lisp_cons *cons)
 792 {
 793         int     second;
 794
 795         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0))
 796                 return AO_LISP_NIL;
 797         second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND;
 798         return (ao_lisp_int_poly(second));
 799 }
 800
 801 ao_poly
 802 ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons)
 803 {
 804         if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0))
 805                 return AO_LISP_NIL;
 806         return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND));
 807 }
 808
 809 #define AO_LISP_BUILTIN_FUNCS
 810 #include "ao_lisp_builtin.h"