git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_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_scheme.h"
  16 #include <limits.h>
  17 #include <math.h>
  18
  19 static int
  20 builtin_size(void *addr)
  21 {
  22         (void) addr;
  23         return sizeof (struct ao_scheme_builtin);
  24 }
  25
  26 static void
  27 builtin_mark(void *addr)
  28 {
  29         (void) addr;
  30 }
  31
  32 static void
  33 builtin_move(void *addr)
  34 {
  35         (void) addr;
  36 }
  37
  38 const struct ao_scheme_type ao_scheme_builtin_type = {
  39         .size = builtin_size,
  40         .mark = builtin_mark,
  41         .move = builtin_move
  42 };
  43
  44 #ifdef AO_SCHEME_MAKE_CONST
  45
  46 #define AO_SCHEME_BUILTIN_CASENAME
  47 #include "ao_scheme_builtin.h"
  48
  49 char *ao_scheme_args_name(uint8_t args) {
  50         args &= AO_SCHEME_FUNC_MASK;
  51         switch (args) {
  52         case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name;
  53         case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name;
  54         case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name;
  55         default: return "???";
  56         }
  57 }
  58 #else
  59
  60 #define AO_SCHEME_BUILTIN_ARRAYNAME
  61 #include "ao_scheme_builtin.h"
  62
  63 static char *
  64 ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {
  65         if (b < _builtin_last)
  66                 return ao_scheme_poly_atom(builtin_names[b])->name;
  67         return "???";
  68 }
  69
  70 static const ao_poly ao_scheme_args_atoms[] = {
  71         [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda,
  72         [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda,
  73         [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro,
  74 };
  75
  76 char *
  77 ao_scheme_args_name(uint8_t args)
  78 {
  79         args &= AO_SCHEME_FUNC_MASK;
  80         if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0])
  81                 return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name;
  82         return "(unknown)";
  83 }
  84 #endif
  85
  86 void
  87 ao_scheme_builtin_write(ao_poly b)
  88 {
  89         struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b);
  90         printf("%s", ao_scheme_builtin_name(builtin->func));
  91 }
  92
  93 ao_poly
  94 ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max)
  95 {
  96         int     argc = 0;
  97
  98         while (cons && argc <= max) {
  99                 argc++;
 100                 cons = ao_scheme_cons_cdr(cons);
 101         }
 102         if (argc < min || argc > max)
 103                 return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name);
 104         return _ao_scheme_bool_true;
 105 }
 106
 107 ao_poly
 108 ao_scheme_arg(struct ao_scheme_cons *cons, int argc)
 109 {
 110         if (!cons)
 111                 return AO_SCHEME_NIL;
 112         while (argc--) {
 113                 if (!cons)
 114                         return AO_SCHEME_NIL;
 115                 cons = ao_scheme_cons_cdr(cons);
 116         }
 117         return cons->car;
 118 }
 119
 120 ao_poly
 121 ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok)
 122 {
 123         ao_poly car = ao_scheme_arg(cons, argc);
 124
 125         if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type)
 126                 return ao_scheme_error(AO_SCHEME_INVALID, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car);
 127         return _ao_scheme_bool_true;
 128 }
 129
 130 ao_poly
 131 ao_scheme_do_car(struct ao_scheme_cons *cons)
 132 {
 133         if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1))
 134                 return AO_SCHEME_NIL;
 135         if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0))
 136                 return AO_SCHEME_NIL;
 137         return ao_scheme_poly_cons(cons->car)->car;
 138 }
 139
 140 ao_poly
 141 ao_scheme_do_cdr(struct ao_scheme_cons *cons)
 142 {
 143         if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1))
 144                 return AO_SCHEME_NIL;
 145         if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0))
 146                 return AO_SCHEME_NIL;
 147         return ao_scheme_poly_cons(cons->car)->cdr;
 148 }
 149
 150 ao_poly
 151 ao_scheme_do_cons(struct ao_scheme_cons *cons)
 152 {
 153         ao_poly car, cdr;
 154         if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2))
 155                 return AO_SCHEME_NIL;
 156         car = ao_scheme_arg(cons, 0);
 157         cdr = ao_scheme_arg(cons, 1);
 158         return ao_scheme__cons(car, cdr);
 159 }
 160
 161 ao_poly
 162 ao_scheme_do_last(struct ao_scheme_cons *cons)
 163 {
 164         struct ao_scheme_cons   *list;
 165         if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1))
 166                 return AO_SCHEME_NIL;
 167         if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1))
 168                 return AO_SCHEME_NIL;
 169         for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0));
 170              list;
 171              list = ao_scheme_cons_cdr(list))
 172         {
 173                 if (!list->cdr)
 174                         return list->car;
 175         }
 176         return AO_SCHEME_NIL;
 177 }
 178
 179 ao_poly
 180 ao_scheme_do_length(struct ao_scheme_cons *cons)
 181 {
 182         if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1))
 183                 return AO_SCHEME_NIL;
 184         if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1))
 185                 return AO_SCHEME_NIL;
 186         return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))));
 187 }
 188
 189 ao_poly
 190 ao_scheme_do_quote(struct ao_scheme_cons *cons)
 191 {
 192         if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1))
 193                 return AO_SCHEME_NIL;
 194         return ao_scheme_arg(cons, 0);
 195 }
 196
 197 ao_poly
 198 ao_scheme_do_set(struct ao_scheme_cons *cons)
 199 {
 200         if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2))
 201                 return AO_SCHEME_NIL;
 202         if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0))
 203                 return AO_SCHEME_NIL;
 204
 205         return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
 206 }
 207
 208 ao_poly
 209 ao_scheme_do_def(struct ao_scheme_cons *cons)
 210 {
 211         if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2))
 212                 return AO_SCHEME_NIL;
 213         if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0))
 214                 return AO_SCHEME_NIL;
 215
 216         return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
 217 }
 218
 219 ao_poly
 220 ao_scheme_do_setq(struct ao_scheme_cons *cons)
 221 {
 222         ao_poly name;
 223         if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2))
 224                 return AO_SCHEME_NIL;
 225         name = cons->car;
 226         if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM)
 227                 return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name);
 228         if (!ao_scheme_atom_ref(name, NULL))
 229                 return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name);
 230         return ao_scheme__cons(_ao_scheme_atom_set,
 231                              ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote,
 232                                                          ao_scheme__cons(name, AO_SCHEME_NIL)),
 233                                            cons->cdr));
 234 }
 235
 236 ao_poly
 237 ao_scheme_do_cond(struct ao_scheme_cons *cons)
 238 {
 239         ao_scheme_set_cond(cons);
 240         return AO_SCHEME_NIL;
 241 }
 242
 243 ao_poly
 244 ao_scheme_do_begin(struct ao_scheme_cons *cons)
 245 {
 246         ao_scheme_stack->state = eval_begin;
 247         ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons);
 248         return AO_SCHEME_NIL;
 249 }
 250
 251 ao_poly
 252 ao_scheme_do_while(struct ao_scheme_cons *cons)
 253 {
 254         ao_scheme_stack->state = eval_while;
 255         ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons);
 256         return AO_SCHEME_NIL;
 257 }
 258
 259 ao_poly
 260 ao_scheme_do_write(struct ao_scheme_cons *cons)
 261 {
 262         ao_poly val = AO_SCHEME_NIL;
 263         while (cons) {
 264                 val = cons->car;
 265                 ao_scheme_poly_write(val);
 266                 cons = ao_scheme_cons_cdr(cons);
 267                 if (cons)
 268                         printf(" ");
 269         }
 270         printf("\n");
 271         return _ao_scheme_bool_true;
 272 }
 273
 274 ao_poly
 275 ao_scheme_do_display(struct ao_scheme_cons *cons)
 276 {
 277         ao_poly val = AO_SCHEME_NIL;
 278         while (cons) {
 279                 val = cons->car;
 280                 ao_scheme_poly_display(val);
 281                 cons = ao_scheme_cons_cdr(cons);
 282         }
 283         return _ao_scheme_bool_true;
 284 }
 285
 286 ao_poly
 287 ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op)
 288 {
 289         struct ao_scheme_cons *cons = cons;
 290         ao_poly ret = AO_SCHEME_NIL;
 291
 292         for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) {
 293                 ao_poly         car = cons->car;
 294                 uint8_t         rt = ao_scheme_poly_type(ret);
 295                 uint8_t         ct = ao_scheme_poly_type(car);
 296
 297                 if (cons == orig_cons) {
 298                         ret = car;
 299                         if (cons->cdr == AO_SCHEME_NIL) {
 300                                 switch (op) {
 301                                 case builtin_minus:
 302                                         if (ao_scheme_integer_typep(ct))
 303                                                 ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret));
 304                                         else if (ct == AO_SCHEME_FLOAT)
 305                                                 ret = ao_scheme_float_get(-ao_scheme_poly_number(ret));
 306                                         break;
 307                                 case builtin_divide:
 308                                         if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1)
 309                                                 ;
 310                                         else if (ao_scheme_number_typep(ct)) {
 311                                                 float   v = ao_scheme_poly_number(ret);
 312                                                 ret = ao_scheme_float_get(1/v);
 313                                         }
 314                                         break;
 315                                 default:
 316                                         break;
 317                                 }
 318                         }
 319                 } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) {
 320                         int32_t r = ao_scheme_poly_integer(ret);
 321                         int32_t c = ao_scheme_poly_integer(car);
 322                         int64_t t;
 323
 324                         switch(op) {
 325                         case builtin_plus:
 326                                 r += c;
 327                         check_overflow:
 328                                 if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r)
 329                                         goto inexact;
 330                                 break;
 331                         case builtin_minus:
 332                                 r -= c;
 333                                 goto check_overflow;
 334                                 break;
 335                         case builtin_times:
 336                                 t = (int64_t) r * (int64_t) c;
 337                                 if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t)
 338                                         goto inexact;
 339                                 r = (int32_t) t;
 340                                 break;
 341                         case builtin_divide:
 342                                 if (c != 0 && (r % c) == 0)
 343                                         r /= c;
 344                                 else
 345                                         goto inexact;
 346                                 break;
 347                         case builtin_quotient:
 348                                 if (c == 0)
 349                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero");
 350                                 if (r % c != 0 && (c < 0) != (r < 0))
 351                                         r = r / c - 1;
 352                                 else
 353                                         r = r / c;
 354                                 break;
 355                         case builtin_remainder:
 356                                 if (c == 0)
 357                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero");
 358                                 r %= c;
 359                                 break;
 360                         case builtin_modulo:
 361                                 if (c == 0)
 362                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero");
 363                                 r %= c;
 364                                 if ((r < 0) != (c < 0))
 365                                         r += c;
 366                                 break;
 367                         default:
 368                                 break;
 369                         }
 370                         ret = ao_scheme_integer_poly(r);
 371                 } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) {
 372                         float r, c;
 373                 inexact:
 374                         r = ao_scheme_poly_number(ret);
 375                         c = ao_scheme_poly_number(car);
 376                         switch(op) {
 377                         case builtin_plus:
 378                                 r += c;
 379                                 break;
 380                         case builtin_minus:
 381                                 r -= c;
 382                                 break;
 383                         case builtin_times:
 384                                 r *= c;
 385                                 break;
 386                         case builtin_divide:
 387                                 r /= c;
 388                                 break;
 389                         case builtin_quotient:
 390                         case builtin_remainder:
 391                         case builtin_modulo:
 392                                 return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide");
 393                         default:
 394                                 break;
 395                         }
 396                         ret = ao_scheme_float_get(r);
 397                 }
 398
 399                 else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus)
 400                         ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret),
 401                                                                      ao_scheme_poly_string(car)));
 402                 else
 403                         return ao_scheme_error(AO_SCHEME_INVALID, "invalid args");
 404         }
 405         return ret;
 406 }
 407
 408 ao_poly
 409 ao_scheme_do_plus(struct ao_scheme_cons *cons)
 410 {
 411         return ao_scheme_math(cons, builtin_plus);
 412 }
 413
 414 ao_poly
 415 ao_scheme_do_minus(struct ao_scheme_cons *cons)
 416 {
 417         return ao_scheme_math(cons, builtin_minus);
 418 }
 419
 420 ao_poly
 421 ao_scheme_do_times(struct ao_scheme_cons *cons)
 422 {
 423         return ao_scheme_math(cons, builtin_times);
 424 }
 425
 426 ao_poly
 427 ao_scheme_do_divide(struct ao_scheme_cons *cons)
 428 {
 429         return ao_scheme_math(cons, builtin_divide);
 430 }
 431
 432 ao_poly
 433 ao_scheme_do_quotient(struct ao_scheme_cons *cons)
 434 {
 435         return ao_scheme_math(cons, builtin_quotient);
 436 }
 437
 438 ao_poly
 439 ao_scheme_do_modulo(struct ao_scheme_cons *cons)
 440 {
 441         return ao_scheme_math(cons, builtin_modulo);
 442 }
 443
 444 ao_poly
 445 ao_scheme_do_remainder(struct ao_scheme_cons *cons)
 446 {
 447         return ao_scheme_math(cons, builtin_remainder);
 448 }
 449
 450 ao_poly
 451 ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op)
 452 {
 453         ao_poly left;
 454
 455         if (!cons)
 456                 return _ao_scheme_bool_true;
 457
 458         left = cons->car;
 459         for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) {
 460                 ao_poly right = cons->car;
 461
 462                 if (op == builtin_equal) {
 463                         if (left != right)
 464                                 return _ao_scheme_bool_false;
 465                 } else {
 466                         uint8_t lt = ao_scheme_poly_type(left);
 467                         uint8_t rt = ao_scheme_poly_type(right);
 468                         if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) {
 469                                 int32_t l = ao_scheme_poly_integer(left);
 470                                 int32_t r = ao_scheme_poly_integer(right);
 471
 472                                 switch (op) {
 473                                 case builtin_less:
 474                                         if (!(l < r))
 475                                                 return _ao_scheme_bool_false;
 476                                         break;
 477                                 case builtin_greater:
 478                                         if (!(l > r))
 479                                                 return _ao_scheme_bool_false;
 480                                         break;
 481                                 case builtin_less_equal:
 482                                         if (!(l <= r))
 483                                                 return _ao_scheme_bool_false;
 484                                         break;
 485                                 case builtin_greater_equal:
 486                                         if (!(l >= r))
 487                                                 return _ao_scheme_bool_false;
 488                                         break;
 489                                 default:
 490                                         break;
 491                                 }
 492                         } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) {
 493                                 int c = strcmp(ao_scheme_poly_string(left),
 494                                                ao_scheme_poly_string(right));
 495                                 switch (op) {
 496                                 case builtin_less:
 497                                         if (!(c < 0))
 498                                                 return _ao_scheme_bool_false;
 499                                         break;
 500                                 case builtin_greater:
 501                                         if (!(c > 0))
 502                                                 return _ao_scheme_bool_false;
 503                                         break;
 504                                 case builtin_less_equal:
 505                                         if (!(c <= 0))
 506                                                 return _ao_scheme_bool_false;
 507                                         break;
 508                                 case builtin_greater_equal:
 509                                         if (!(c >= 0))
 510                                                 return _ao_scheme_bool_false;
 511                                         break;
 512                                 default:
 513                                         break;
 514                                 }
 515                         }
 516                 }
 517                 left = right;
 518         }
 519         return _ao_scheme_bool_true;
 520 }
 521
 522 ao_poly
 523 ao_scheme_do_equal(struct ao_scheme_cons *cons)
 524 {
 525         return ao_scheme_compare(cons, builtin_equal);
 526 }
 527
 528 ao_poly
 529 ao_scheme_do_less(struct ao_scheme_cons *cons)
 530 {
 531         return ao_scheme_compare(cons, builtin_less);
 532 }
 533
 534 ao_poly
 535 ao_scheme_do_greater(struct ao_scheme_cons *cons)
 536 {
 537         return ao_scheme_compare(cons, builtin_greater);
 538 }
 539
 540 ao_poly
 541 ao_scheme_do_less_equal(struct ao_scheme_cons *cons)
 542 {
 543         return ao_scheme_compare(cons, builtin_less_equal);
 544 }
 545
 546 ao_poly
 547 ao_scheme_do_greater_equal(struct ao_scheme_cons *cons)
 548 {
 549         return ao_scheme_compare(cons, builtin_greater_equal);
 550 }
 551
 552 ao_poly
 553 ao_scheme_do_list_to_string(struct ao_scheme_cons *cons)
 554 {
 555         if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1))
 556                 return AO_SCHEME_NIL;
 557         if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1))
 558                 return AO_SCHEME_NIL;
 559         return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)));
 560 }
 561
 562 ao_poly
 563 ao_scheme_do_string_to_list(struct ao_scheme_cons *cons)
 564 {
 565         if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1))
 566                 return AO_SCHEME_NIL;
 567         if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0))
 568                 return AO_SCHEME_NIL;
 569         return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0)));
 570 }
 571
 572 ao_poly
 573 ao_scheme_do_flush_output(struct ao_scheme_cons *cons)
 574 {
 575         if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0))
 576                 return AO_SCHEME_NIL;
 577         ao_scheme_os_flush();
 578         return _ao_scheme_bool_true;
 579 }
 580
 581 ao_poly
 582 ao_scheme_do_led(struct ao_scheme_cons *cons)
 583 {
 584         ao_poly led;
 585         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 586                 return AO_SCHEME_NIL;
 587         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0))
 588                 return AO_SCHEME_NIL;
 589         led = ao_scheme_arg(cons, 0);
 590         ao_scheme_os_led(ao_scheme_poly_int(led));
 591         return led;
 592 }
 593
 594 ao_poly
 595 ao_scheme_do_delay(struct ao_scheme_cons *cons)
 596 {
 597         ao_poly delay;
 598         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 599                 return AO_SCHEME_NIL;
 600         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0))
 601                 return AO_SCHEME_NIL;
 602         delay = ao_scheme_arg(cons, 0);
 603         ao_scheme_os_delay(ao_scheme_poly_int(delay));
 604         return delay;
 605 }
 606
 607 ao_poly
 608 ao_scheme_do_eval(struct ao_scheme_cons *cons)
 609 {
 610         if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1))
 611                 return AO_SCHEME_NIL;
 612         ao_scheme_stack->state = eval_sexpr;
 613         return cons->car;
 614 }
 615
 616 ao_poly
 617 ao_scheme_do_apply(struct ao_scheme_cons *cons)
 618 {
 619         if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX))
 620                 return AO_SCHEME_NIL;
 621         ao_scheme_stack->state = eval_apply;
 622         return ao_scheme_cons_poly(cons);
 623 }
 624
 625 ao_poly
 626 ao_scheme_do_read(struct ao_scheme_cons *cons)
 627 {
 628         if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0))
 629                 return AO_SCHEME_NIL;
 630         return ao_scheme_read();
 631 }
 632
 633 ao_poly
 634 ao_scheme_do_collect(struct ao_scheme_cons *cons)
 635 {
 636         int     free;
 637         (void) cons;
 638         free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL);
 639         return ao_scheme_int_poly(free);
 640 }
 641
 642 ao_poly
 643 ao_scheme_do_nullp(struct ao_scheme_cons *cons)
 644 {
 645         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 646                 return AO_SCHEME_NIL;
 647         if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL)
 648                 return _ao_scheme_bool_true;
 649         else
 650                 return _ao_scheme_bool_false;
 651 }
 652
 653 ao_poly
 654 ao_scheme_do_not(struct ao_scheme_cons *cons)
 655 {
 656         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 657                 return AO_SCHEME_NIL;
 658         if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false)
 659                 return _ao_scheme_bool_true;
 660         else
 661                 return _ao_scheme_bool_false;
 662 }
 663
 664 static ao_poly
 665 ao_scheme_do_typep(int type, struct ao_scheme_cons *cons)
 666 {
 667         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 668                 return AO_SCHEME_NIL;
 669         if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type)
 670                 return _ao_scheme_bool_true;
 671         return _ao_scheme_bool_false;
 672 }
 673
 674 ao_poly
 675 ao_scheme_do_pairp(struct ao_scheme_cons *cons)
 676 {
 677         ao_poly v;
 678         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 679                 return AO_SCHEME_NIL;
 680         v = ao_scheme_arg(cons, 0);
 681         if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS)
 682                 return _ao_scheme_bool_true;
 683         return _ao_scheme_bool_false;
 684 }
 685
 686 ao_poly
 687 ao_scheme_do_integerp(struct ao_scheme_cons *cons)
 688 {
 689         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 690                 return AO_SCHEME_NIL;
 691         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 692         case AO_SCHEME_INT:
 693         case AO_SCHEME_BIGINT:
 694                 return _ao_scheme_bool_true;
 695         default:
 696                 return _ao_scheme_bool_false;
 697         }
 698 }
 699
 700 ao_poly
 701 ao_scheme_do_numberp(struct ao_scheme_cons *cons)
 702 {
 703         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 704                 return AO_SCHEME_NIL;
 705         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 706         case AO_SCHEME_INT:
 707         case AO_SCHEME_BIGINT:
 708         case AO_SCHEME_FLOAT:
 709                 return _ao_scheme_bool_true;
 710         default:
 711                 return _ao_scheme_bool_false;
 712         }
 713 }
 714
 715 ao_poly
 716 ao_scheme_do_stringp(struct ao_scheme_cons *cons)
 717 {
 718         return ao_scheme_do_typep(AO_SCHEME_STRING, cons);
 719 }
 720
 721 ao_poly
 722 ao_scheme_do_symbolp(struct ao_scheme_cons *cons)
 723 {
 724         return ao_scheme_do_typep(AO_SCHEME_ATOM, cons);
 725 }
 726
 727 ao_poly
 728 ao_scheme_do_booleanp(struct ao_scheme_cons *cons)
 729 {
 730         return ao_scheme_do_typep(AO_SCHEME_BOOL, cons);
 731 }
 732
 733 ao_poly
 734 ao_scheme_do_procedurep(struct ao_scheme_cons *cons)
 735 {
 736         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 737                 return AO_SCHEME_NIL;
 738         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 739         case AO_SCHEME_BUILTIN:
 740         case AO_SCHEME_LAMBDA:
 741                 return _ao_scheme_bool_true;
 742         default:
 743         return _ao_scheme_bool_false;
 744         }
 745 }
 746
 747 /* This one is special -- a list is either nil or
 748  * a 'proper' list with only cons cells
 749  */
 750 ao_poly
 751 ao_scheme_do_listp(struct ao_scheme_cons *cons)
 752 {
 753         ao_poly v;
 754         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 755                 return AO_SCHEME_NIL;
 756         v = ao_scheme_arg(cons, 0);
 757         for (;;) {
 758                 if (v == AO_SCHEME_NIL)
 759                         return _ao_scheme_bool_true;
 760                 if (ao_scheme_poly_type(v) != AO_SCHEME_CONS)
 761                         return _ao_scheme_bool_false;
 762                 v = ao_scheme_poly_cons(v)->cdr;
 763         }
 764 }
 765
 766 ao_poly
 767 ao_scheme_do_set_car(struct ao_scheme_cons *cons)
 768 {
 769         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
 770                 return AO_SCHEME_NIL;
 771         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
 772                 return AO_SCHEME_NIL;
 773         return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1);
 774 }
 775
 776 ao_poly
 777 ao_scheme_do_set_cdr(struct ao_scheme_cons *cons)
 778 {
 779         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
 780                 return AO_SCHEME_NIL;
 781         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
 782                 return AO_SCHEME_NIL;
 783         return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1);
 784 }
 785
 786 ao_poly
 787 ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons)
 788 {
 789         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 790                 return AO_SCHEME_NIL;
 791         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0))
 792                 return AO_SCHEME_NIL;
 793         return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name));
 794 }
 795
 796 ao_poly
 797 ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons)
 798 {
 799         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 800                 return AO_SCHEME_NIL;
 801         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0))
 802                 return AO_SCHEME_NIL;
 803
 804         return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));
 805 }
 806
 807 ao_poly
 808 ao_scheme_do_read_char(struct ao_scheme_cons *cons)
 809 {
 810         int     c;
 811         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
 812                 return AO_SCHEME_NIL;
 813         c = getchar();
 814         return ao_scheme_int_poly(c);
 815 }
 816
 817 ao_poly
 818 ao_scheme_do_write_char(struct ao_scheme_cons *cons)
 819 {
 820         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 821                 return AO_SCHEME_NIL;
 822         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0))
 823                 return AO_SCHEME_NIL;
 824         putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0)));
 825         return _ao_scheme_bool_true;
 826 }
 827
 828 ao_poly
 829 ao_scheme_do_exit(struct ao_scheme_cons *cons)
 830 {
 831         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
 832                 return AO_SCHEME_NIL;
 833         ao_scheme_exception |= AO_SCHEME_EXIT;
 834         return _ao_scheme_bool_true;
 835 }
 836
 837 ao_poly
 838 ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons)
 839 {
 840         int     jiffy;
 841
 842         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
 843                 return AO_SCHEME_NIL;
 844         jiffy = ao_scheme_os_jiffy();
 845         return (ao_scheme_int_poly(jiffy));
 846 }
 847
 848 ao_poly
 849 ao_scheme_do_current_second(struct ao_scheme_cons *cons)
 850 {
 851         int     second;
 852
 853         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
 854                 return AO_SCHEME_NIL;
 855         second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND;
 856         return (ao_scheme_int_poly(second));
 857 }
 858
 859 ao_poly
 860 ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons)
 861 {
 862         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
 863                 return AO_SCHEME_NIL;
 864         return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND));
 865 }
 866
 867 #define AO_SCHEME_BUILTIN_FUNCS
 868 #include "ao_scheme_builtin.h"