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 (char *) "???";
  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 (char *) "???";
  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 (char *) "(unknown)";
  83 }
  84 #endif
  85
  86 void
  87 ao_scheme_builtin_write(ao_poly b, bool write)
  88 {
  89         struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b);
  90         (void) write;
  91         printf("%s", ao_scheme_builtin_name(builtin->func));
  92 }
  93
  94 ao_poly
  95 ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max)
  96 {
  97         int     argc = 0;
  98
  99         while (cons && argc <= max) {
 100                 argc++;
 101                 cons = ao_scheme_cons_cdr(cons);
 102         }
 103         if (argc < min || argc > max)
 104                 return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name);
 105         return _ao_scheme_bool_true;
 106 }
 107
 108 ao_poly
 109 ao_scheme_arg(struct ao_scheme_cons *cons, int argc)
 110 {
 111         if (!cons)
 112                 return AO_SCHEME_NIL;
 113         while (argc--) {
 114                 if (!cons)
 115                         return AO_SCHEME_NIL;
 116                 cons = ao_scheme_cons_cdr(cons);
 117         }
 118         return cons->car;
 119 }
 120
 121 ao_poly
 122 ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok)
 123 {
 124         ao_poly car = ao_scheme_arg(cons, argc);
 125
 126         if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type)
 127                 return ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car);
 128         return _ao_scheme_bool_true;
 129 }
 130
 131 static int32_t
 132 ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc)
 133 {
 134         ao_poly         p = ao_scheme_arg(cons, argc);
 135         bool            fail = false;
 136         int32_t         i = ao_scheme_poly_integer(p, &fail);
 137
 138         if (fail)
 139                 (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p);
 140         return i;
 141 }
 142
 143 ao_poly
 144 ao_scheme_do_car(struct ao_scheme_cons *cons)
 145 {
 146         if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1))
 147                 return AO_SCHEME_NIL;
 148         if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0))
 149                 return AO_SCHEME_NIL;
 150         return ao_scheme_poly_cons(cons->car)->car;
 151 }
 152
 153 ao_poly
 154 ao_scheme_do_cdr(struct ao_scheme_cons *cons)
 155 {
 156         if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1))
 157                 return AO_SCHEME_NIL;
 158         if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0))
 159                 return AO_SCHEME_NIL;
 160         return ao_scheme_poly_cons(cons->car)->cdr;
 161 }
 162
 163 ao_poly
 164 ao_scheme_do_cons(struct ao_scheme_cons *cons)
 165 {
 166         ao_poly car, cdr;
 167         if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2))
 168                 return AO_SCHEME_NIL;
 169         car = ao_scheme_arg(cons, 0);
 170         cdr = ao_scheme_arg(cons, 1);
 171         return ao_scheme__cons(car, cdr);
 172 }
 173
 174 ao_poly
 175 ao_scheme_do_last(struct ao_scheme_cons *cons)
 176 {
 177         struct ao_scheme_cons   *list;
 178         if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1))
 179                 return AO_SCHEME_NIL;
 180         if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1))
 181                 return AO_SCHEME_NIL;
 182         for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0));
 183              list;
 184              list = ao_scheme_cons_cdr(list))
 185         {
 186                 if (!list->cdr)
 187                         return list->car;
 188         }
 189         return AO_SCHEME_NIL;
 190 }
 191
 192 ao_poly
 193 ao_scheme_do_length(struct ao_scheme_cons *cons)
 194 {
 195         if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1))
 196                 return AO_SCHEME_NIL;
 197         if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1))
 198                 return AO_SCHEME_NIL;
 199         return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))));
 200 }
 201
 202 ao_poly
 203 ao_scheme_do_list_copy(struct ao_scheme_cons *cons)
 204 {
 205         struct ao_scheme_cons *new;
 206
 207         if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1))
 208                 return AO_SCHEME_NIL;
 209         if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1))
 210                 return AO_SCHEME_NIL;
 211         new = ao_scheme_cons_copy(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)));
 212         return ao_scheme_cons_poly(new);
 213 }
 214
 215 ao_poly
 216 ao_scheme_do_quote(struct ao_scheme_cons *cons)
 217 {
 218         if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1))
 219                 return AO_SCHEME_NIL;
 220         return ao_scheme_arg(cons, 0);
 221 }
 222
 223 ao_poly
 224 ao_scheme_do_set(struct ao_scheme_cons *cons)
 225 {
 226         if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2))
 227                 return AO_SCHEME_NIL;
 228         if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0))
 229                 return AO_SCHEME_NIL;
 230
 231         return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
 232 }
 233
 234 ao_poly
 235 ao_scheme_do_def(struct ao_scheme_cons *cons)
 236 {
 237         if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2))
 238                 return AO_SCHEME_NIL;
 239         if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0))
 240                 return AO_SCHEME_NIL;
 241
 242         return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
 243 }
 244
 245 ao_poly
 246 ao_scheme_do_setq(struct ao_scheme_cons *cons)
 247 {
 248         ao_poly name;
 249         if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2))
 250                 return AO_SCHEME_NIL;
 251         name = cons->car;
 252         if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM)
 253                 return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name);
 254         if (!ao_scheme_atom_ref(name, NULL))
 255                 return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name);
 256         return ao_scheme__cons(_ao_scheme_atom_set,
 257                              ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote,
 258                                                          ao_scheme__cons(name, AO_SCHEME_NIL)),
 259                                            cons->cdr));
 260 }
 261
 262 ao_poly
 263 ao_scheme_do_cond(struct ao_scheme_cons *cons)
 264 {
 265         ao_scheme_set_cond(cons);
 266         return AO_SCHEME_NIL;
 267 }
 268
 269 ao_poly
 270 ao_scheme_do_begin(struct ao_scheme_cons *cons)
 271 {
 272         ao_scheme_stack->state = eval_begin;
 273         ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons);
 274         return AO_SCHEME_NIL;
 275 }
 276
 277 ao_poly
 278 ao_scheme_do_while(struct ao_scheme_cons *cons)
 279 {
 280         ao_scheme_stack->state = eval_while;
 281         ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons);
 282         return AO_SCHEME_NIL;
 283 }
 284
 285 ao_poly
 286 ao_scheme_do_write(struct ao_scheme_cons *cons)
 287 {
 288         ao_poly val = AO_SCHEME_NIL;
 289         while (cons) {
 290                 val = cons->car;
 291                 ao_scheme_poly_write(val, true);
 292                 cons = ao_scheme_cons_cdr(cons);
 293                 if (cons)
 294                         printf(" ");
 295         }
 296         return _ao_scheme_bool_true;
 297 }
 298
 299 ao_poly
 300 ao_scheme_do_display(struct ao_scheme_cons *cons)
 301 {
 302         ao_poly val = AO_SCHEME_NIL;
 303         while (cons) {
 304                 val = cons->car;
 305                 ao_scheme_poly_write(val, false);
 306                 cons = ao_scheme_cons_cdr(cons);
 307         }
 308         return _ao_scheme_bool_true;
 309 }
 310
 311 static ao_poly
 312 ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op)
 313 {
 314         struct ao_scheme_cons *cons;
 315         ao_poly ret = AO_SCHEME_NIL;
 316
 317         for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) {
 318                 ao_poly         car = cons->car;
 319                 uint8_t         rt = ao_scheme_poly_type(ret);
 320                 uint8_t         ct = ao_scheme_poly_type(car);
 321
 322                 if (cons == orig_cons) {
 323                         ret = car;
 324                         ao_scheme_cons_stash(0, cons);
 325                         if (cons->cdr == AO_SCHEME_NIL) {
 326                                 switch (op) {
 327                                 case builtin_minus:
 328                                         if (ao_scheme_integer_typep(ct))
 329                                                 ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret, NULL));
 330 #ifdef AO_SCHEME_FEATURE_FLOAT
 331                                         else if (ct == AO_SCHEME_FLOAT)
 332                                                 ret = ao_scheme_float_get(-ao_scheme_poly_number(ret));
 333 #endif
 334                                         break;
 335                                 case builtin_divide:
 336                                         if (ao_scheme_poly_integer(ret, NULL) == 1) {
 337                                         } else {
 338 #ifdef AO_SCHEME_FEATURE_FLOAT
 339                                                 if (ao_scheme_number_typep(ct)) {
 340                                                         float   v = ao_scheme_poly_number(ret);
 341                                                         ret = ao_scheme_float_get(1/v);
 342                                                 }
 343 #else
 344                                                 ret = ao_scheme_integer_poly(0);
 345 #endif
 346                                         }
 347                                         break;
 348                                 default:
 349                                         break;
 350                                 }
 351                         }
 352                         cons = ao_scheme_cons_fetch(0);
 353                 } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) {
 354                         int32_t r = ao_scheme_poly_integer(ret, NULL);
 355                         int32_t c = ao_scheme_poly_integer(car, NULL);
 356 #ifdef AO_SCHEME_FEATURE_FLOAT
 357                         int64_t t;
 358 #endif
 359
 360                         switch(op) {
 361                         case builtin_plus:
 362                                 r += c;
 363                         check_overflow:
 364 #ifdef AO_SCHEME_FEATURE_FLOAT
 365                                 if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r)
 366                                         goto inexact;
 367 #endif
 368                                 break;
 369                         case builtin_minus:
 370                                 r -= c;
 371                                 goto check_overflow;
 372                                 break;
 373                         case builtin_times:
 374 #ifdef AO_SCHEME_FEATURE_FLOAT
 375                                 t = (int64_t) r * (int64_t) c;
 376                                 if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t)
 377                                         goto inexact;
 378                                 r = (int32_t) t;
 379 #else
 380                                 r = r * c;
 381 #endif
 382                                 break;
 383                         case builtin_divide:
 384 #ifdef AO_SCHEME_FEATURE_FLOAT
 385                                 if (c != 0 && (r % c) == 0)
 386                                         r /= c;
 387                                 else
 388                                         goto inexact;
 389 #else
 390                                 r /= c;
 391 #endif
 392                                 break;
 393                         case builtin_quotient:
 394                                 if (c == 0)
 395                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero");
 396                                 if (r % c != 0 && (c < 0) != (r < 0))
 397                                         r = r / c - 1;
 398                                 else
 399                                         r = r / c;
 400                                 break;
 401                         case builtin_remainder:
 402                                 if (c == 0)
 403                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero");
 404                                 r %= c;
 405                                 break;
 406                         case builtin_modulo:
 407                                 if (c == 0)
 408                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero");
 409                                 r %= c;
 410                                 if ((r < 0) != (c < 0))
 411                                         r += c;
 412                                 break;
 413                         default:
 414                                 break;
 415                         }
 416                         ao_scheme_cons_stash(0, cons);
 417                         ret = ao_scheme_integer_poly(r);
 418                         cons = ao_scheme_cons_fetch(0);
 419 #ifdef AO_SCHEME_FEATURE_FLOAT
 420                 } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) {
 421                         float r, c;
 422                 inexact:
 423                         r = ao_scheme_poly_number(ret);
 424                         c = ao_scheme_poly_number(car);
 425                         switch(op) {
 426                         case builtin_plus:
 427                                 r += c;
 428                                 break;
 429                         case builtin_minus:
 430                                 r -= c;
 431                                 break;
 432                         case builtin_times:
 433                                 r *= c;
 434                                 break;
 435                         case builtin_divide:
 436                                 r /= c;
 437                                 break;
 438                         case builtin_quotient:
 439                         case builtin_remainder:
 440                         case builtin_modulo:
 441                                 return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide");
 442                         default:
 443                                 break;
 444                         }
 445                         ao_scheme_cons_stash(0, cons);
 446                         ret = ao_scheme_float_get(r);
 447                         cons = ao_scheme_cons_fetch(0);
 448 #endif
 449                 }
 450                 else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) {
 451                         ao_scheme_cons_stash(0, cons);
 452                         ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret),
 453                                                                          ao_scheme_poly_string(car)));
 454                         cons = ao_scheme_cons_fetch(0);
 455                         if (!ret)
 456                                 return ret;
 457                 }
 458                 else
 459                         return ao_scheme_error(AO_SCHEME_INVALID, "invalid args");
 460         }
 461         return ret;
 462 }
 463
 464 ao_poly
 465 ao_scheme_do_plus(struct ao_scheme_cons *cons)
 466 {
 467         return ao_scheme_math(cons, builtin_plus);
 468 }
 469
 470 ao_poly
 471 ao_scheme_do_minus(struct ao_scheme_cons *cons)
 472 {
 473         return ao_scheme_math(cons, builtin_minus);
 474 }
 475
 476 ao_poly
 477 ao_scheme_do_times(struct ao_scheme_cons *cons)
 478 {
 479         return ao_scheme_math(cons, builtin_times);
 480 }
 481
 482 ao_poly
 483 ao_scheme_do_divide(struct ao_scheme_cons *cons)
 484 {
 485         return ao_scheme_math(cons, builtin_divide);
 486 }
 487
 488 ao_poly
 489 ao_scheme_do_quotient(struct ao_scheme_cons *cons)
 490 {
 491         return ao_scheme_math(cons, builtin_quotient);
 492 }
 493
 494 ao_poly
 495 ao_scheme_do_modulo(struct ao_scheme_cons *cons)
 496 {
 497         return ao_scheme_math(cons, builtin_modulo);
 498 }
 499
 500 ao_poly
 501 ao_scheme_do_remainder(struct ao_scheme_cons *cons)
 502 {
 503         return ao_scheme_math(cons, builtin_remainder);
 504 }
 505
 506 static ao_poly
 507 ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op)
 508 {
 509         ao_poly left;
 510
 511         if (!cons)
 512                 return _ao_scheme_bool_true;
 513
 514         left = cons->car;
 515         for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) {
 516                 ao_poly right = cons->car;
 517
 518                 if (op == builtin_equal && left == right) {
 519                         ;
 520                 } else {
 521                         uint8_t lt = ao_scheme_poly_type(left);
 522                         uint8_t rt = ao_scheme_poly_type(right);
 523                         if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) {
 524                                 int32_t l = ao_scheme_poly_integer(left, NULL);
 525                                 int32_t r = ao_scheme_poly_integer(right, NULL);
 526
 527                                 switch (op) {
 528                                 case builtin_less:
 529                                         if (!(l < r))
 530                                                 return _ao_scheme_bool_false;
 531                                         break;
 532                                 case builtin_greater:
 533                                         if (!(l > r))
 534                                                 return _ao_scheme_bool_false;
 535                                         break;
 536                                 case builtin_less_equal:
 537                                         if (!(l <= r))
 538                                                 return _ao_scheme_bool_false;
 539                                         break;
 540                                 case builtin_greater_equal:
 541                                         if (!(l >= r))
 542                                                 return _ao_scheme_bool_false;
 543                                         break;
 544                                 case builtin_equal:
 545                                         if (!(l == r))
 546                                                 return _ao_scheme_bool_false;
 547                                 default:
 548                                         break;
 549                                 }
 550 #ifdef AO_SCHEME_FEATURE_FLOAT
 551                         } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) {
 552                                 float l, r;
 553
 554                                 l = ao_scheme_poly_number(left);
 555                                 r = ao_scheme_poly_number(right);
 556
 557                                 switch (op) {
 558                                 case builtin_less:
 559                                         if (!(l < r))
 560                                                 return _ao_scheme_bool_false;
 561                                         break;
 562                                 case builtin_greater:
 563                                         if (!(l > r))
 564                                                 return _ao_scheme_bool_false;
 565                                         break;
 566                                 case builtin_less_equal:
 567                                         if (!(l <= r))
 568                                                 return _ao_scheme_bool_false;
 569                                         break;
 570                                 case builtin_greater_equal:
 571                                         if (!(l >= r))
 572                                                 return _ao_scheme_bool_false;
 573                                         break;
 574                                 case builtin_equal:
 575                                         if (!(l == r))
 576                                                 return _ao_scheme_bool_false;
 577                                 default:
 578                                         break;
 579                                 }
 580 #endif /* AO_SCHEME_FEATURE_FLOAT */
 581                         } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) {
 582                                 int c = strcmp(ao_scheme_poly_string(left)->val,
 583                                                ao_scheme_poly_string(right)->val);
 584                                 switch (op) {
 585                                 case builtin_less:
 586                                         if (!(c < 0))
 587                                                 return _ao_scheme_bool_false;
 588                                         break;
 589                                 case builtin_greater:
 590                                         if (!(c > 0))
 591                                                 return _ao_scheme_bool_false;
 592                                         break;
 593                                 case builtin_less_equal:
 594                                         if (!(c <= 0))
 595                                                 return _ao_scheme_bool_false;
 596                                         break;
 597                                 case builtin_greater_equal:
 598                                         if (!(c >= 0))
 599                                                 return _ao_scheme_bool_false;
 600                                         break;
 601                                 case builtin_equal:
 602                                         if (!(c == 0))
 603                                                 return _ao_scheme_bool_false;
 604                                         break;
 605                                 default:
 606                                         break;
 607                                 }
 608                         } else
 609                                 return _ao_scheme_bool_false;
 610                 }
 611                 left = right;
 612         }
 613         return _ao_scheme_bool_true;
 614 }
 615
 616 ao_poly
 617 ao_scheme_do_equal(struct ao_scheme_cons *cons)
 618 {
 619         return ao_scheme_compare(cons, builtin_equal);
 620 }
 621
 622 ao_poly
 623 ao_scheme_do_less(struct ao_scheme_cons *cons)
 624 {
 625         return ao_scheme_compare(cons, builtin_less);
 626 }
 627
 628 ao_poly
 629 ao_scheme_do_greater(struct ao_scheme_cons *cons)
 630 {
 631         return ao_scheme_compare(cons, builtin_greater);
 632 }
 633
 634 ao_poly
 635 ao_scheme_do_less_equal(struct ao_scheme_cons *cons)
 636 {
 637         return ao_scheme_compare(cons, builtin_less_equal);
 638 }
 639
 640 ao_poly
 641 ao_scheme_do_greater_equal(struct ao_scheme_cons *cons)
 642 {
 643         return ao_scheme_compare(cons, builtin_greater_equal);
 644 }
 645
 646 ao_poly
 647 ao_scheme_do_list_to_string(struct ao_scheme_cons *cons)
 648 {
 649         if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1))
 650                 return AO_SCHEME_NIL;
 651         if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1))
 652                 return AO_SCHEME_NIL;
 653         return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)));
 654 }
 655
 656 ao_poly
 657 ao_scheme_do_string_to_list(struct ao_scheme_cons *cons)
 658 {
 659         if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1))
 660                 return AO_SCHEME_NIL;
 661         if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0))
 662                 return AO_SCHEME_NIL;
 663         return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0)));
 664 }
 665
 666 ao_poly
 667 ao_scheme_do_string_ref(struct ao_scheme_cons *cons)
 668 {
 669         char    *string;
 670         int32_t ref;
 671         if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2))
 672                 return AO_SCHEME_NIL;
 673         if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0))
 674                 return AO_SCHEME_NIL;
 675         ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1);
 676         if (ao_scheme_exception)
 677                 return AO_SCHEME_NIL;
 678         string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val;
 679         while (*string && ref) {
 680                 ++string;
 681                 --ref;
 682         }
 683         if (!*string)
 684                 return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
 685                                        _ao_scheme_atom_string2dref,
 686                                        ao_scheme_arg(cons, 0),
 687                                        ao_scheme_arg(cons, 1));
 688         return ao_scheme_int_poly(*string);
 689 }
 690
 691 ao_poly
 692 ao_scheme_do_string_length(struct ao_scheme_cons *cons)
 693 {
 694         struct ao_scheme_string *string;
 695
 696         if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1))
 697                 return AO_SCHEME_NIL;
 698         if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0))
 699                 return AO_SCHEME_NIL;
 700         string = ao_scheme_poly_string(ao_scheme_arg(cons, 0));
 701         return ao_scheme_integer_poly(strlen(string->val));
 702 }
 703
 704 ao_poly
 705 ao_scheme_do_string_copy(struct ao_scheme_cons *cons)
 706 {
 707         struct ao_scheme_string *string;
 708
 709         if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1))
 710                 return AO_SCHEME_NIL;
 711         if (!ao_scheme_check_argt(_ao_scheme_atom_string2dcopy, cons, 0, AO_SCHEME_STRING, 0))
 712                 return AO_SCHEME_NIL;
 713         string = ao_scheme_poly_string(ao_scheme_arg(cons, 0));
 714         return ao_scheme_string_poly(ao_scheme_string_copy(string));
 715 }
 716
 717 ao_poly
 718 ao_scheme_do_string_set(struct ao_scheme_cons *cons)
 719 {
 720         char    *string;
 721         int32_t ref;
 722         int32_t val;
 723
 724         if (!ao_scheme_check_argc(_ao_scheme_atom_string2dset21, cons, 3, 3))
 725                 return AO_SCHEME_NIL;
 726         if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0))
 727                 return AO_SCHEME_NIL;
 728         string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val;
 729         ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1);
 730         if (ao_scheme_exception)
 731                 return AO_SCHEME_NIL;
 732         val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2);
 733         if (ao_scheme_exception)
 734                 return AO_SCHEME_NIL;
 735         while (*string && ref) {
 736                 ++string;
 737                 --ref;
 738         }
 739         if (!*string)
 740                 return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
 741                                        _ao_scheme_atom_string2dset21,
 742                                        ao_scheme_arg(cons, 0),
 743                                        ao_scheme_arg(cons, 1));
 744         *string = val;
 745         return ao_scheme_int_poly(*string);
 746 }
 747
 748 ao_poly
 749 ao_scheme_do_flush_output(struct ao_scheme_cons *cons)
 750 {
 751         if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0))
 752                 return AO_SCHEME_NIL;
 753         ao_scheme_os_flush();
 754         return _ao_scheme_bool_true;
 755 }
 756
 757 ao_poly
 758 ao_scheme_do_led(struct ao_scheme_cons *cons)
 759 {
 760         int32_t led;
 761         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 762                 return AO_SCHEME_NIL;
 763         led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0);
 764         if (ao_scheme_exception)
 765                 return AO_SCHEME_NIL;
 766         led = ao_scheme_arg(cons, 0);
 767         ao_scheme_os_led(ao_scheme_poly_int(led));
 768         return led;
 769 }
 770
 771 ao_poly
 772 ao_scheme_do_delay(struct ao_scheme_cons *cons)
 773 {
 774         int32_t delay;
 775
 776         if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1))
 777                 return AO_SCHEME_NIL;
 778         delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0);
 779         if (ao_scheme_exception)
 780                 return AO_SCHEME_NIL;
 781         ao_scheme_os_delay(delay);
 782         return delay;
 783 }
 784
 785 ao_poly
 786 ao_scheme_do_eval(struct ao_scheme_cons *cons)
 787 {
 788         if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1))
 789                 return AO_SCHEME_NIL;
 790         ao_scheme_stack->state = eval_sexpr;
 791         return cons->car;
 792 }
 793
 794 ao_poly
 795 ao_scheme_do_apply(struct ao_scheme_cons *cons)
 796 {
 797         if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX))
 798                 return AO_SCHEME_NIL;
 799         ao_scheme_stack->state = eval_apply;
 800         return ao_scheme_cons_poly(cons);
 801 }
 802
 803 ao_poly
 804 ao_scheme_do_read(struct ao_scheme_cons *cons)
 805 {
 806         if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0))
 807                 return AO_SCHEME_NIL;
 808         return ao_scheme_read();
 809 }
 810
 811 ao_poly
 812 ao_scheme_do_collect(struct ao_scheme_cons *cons)
 813 {
 814         int     free;
 815         (void) cons;
 816         free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL);
 817         return ao_scheme_integer_poly(free);
 818 }
 819
 820 ao_poly
 821 ao_scheme_do_nullp(struct ao_scheme_cons *cons)
 822 {
 823         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 824                 return AO_SCHEME_NIL;
 825         if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL)
 826                 return _ao_scheme_bool_true;
 827         else
 828                 return _ao_scheme_bool_false;
 829 }
 830
 831 ao_poly
 832 ao_scheme_do_not(struct ao_scheme_cons *cons)
 833 {
 834         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 835                 return AO_SCHEME_NIL;
 836         if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false)
 837                 return _ao_scheme_bool_true;
 838         else
 839                 return _ao_scheme_bool_false;
 840 }
 841
 842 static ao_poly
 843 ao_scheme_do_typep(int type, struct ao_scheme_cons *cons)
 844 {
 845         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 846                 return AO_SCHEME_NIL;
 847         if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type)
 848                 return _ao_scheme_bool_true;
 849         return _ao_scheme_bool_false;
 850 }
 851
 852 ao_poly
 853 ao_scheme_do_pairp(struct ao_scheme_cons *cons)
 854 {
 855         ao_poly v;
 856         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 857                 return AO_SCHEME_NIL;
 858         v = ao_scheme_arg(cons, 0);
 859         if (v != AO_SCHEME_NIL && AO_SCHEME_IS_CONS(v))
 860                 return _ao_scheme_bool_true;
 861         return _ao_scheme_bool_false;
 862 }
 863
 864 ao_poly
 865 ao_scheme_do_integerp(struct ao_scheme_cons *cons)
 866 {
 867 #ifdef AO_SCHEME_FEATURE_BIGINT
 868         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 869                 return AO_SCHEME_NIL;
 870         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 871         case AO_SCHEME_INT:
 872         case AO_SCHEME_BIGINT:
 873                 return _ao_scheme_bool_true;
 874         default:
 875                 return _ao_scheme_bool_false;
 876         }
 877 #else
 878         return ao_scheme_do_typep(AO_SCHEME_INT, cons);
 879 #endif
 880 }
 881
 882 ao_poly
 883 ao_scheme_do_numberp(struct ao_scheme_cons *cons)
 884 {
 885 #if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT)
 886         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 887                 return AO_SCHEME_NIL;
 888         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 889         case AO_SCHEME_INT:
 890 #ifdef AO_SCHEME_FEATURE_BIGINT
 891         case AO_SCHEME_BIGINT:
 892 #endif
 893 #ifdef AO_SCHEME_FEATURE_FLOAT
 894         case AO_SCHEME_FLOAT:
 895 #endif
 896                 return _ao_scheme_bool_true;
 897         default:
 898                 return _ao_scheme_bool_false;
 899         }
 900 #else
 901         return ao_scheme_do_integerp(cons);
 902 #endif
 903 }
 904
 905 ao_poly
 906 ao_scheme_do_stringp(struct ao_scheme_cons *cons)
 907 {
 908         return ao_scheme_do_typep(AO_SCHEME_STRING, cons);
 909 }
 910
 911 ao_poly
 912 ao_scheme_do_symbolp(struct ao_scheme_cons *cons)
 913 {
 914         return ao_scheme_do_typep(AO_SCHEME_ATOM, cons);
 915 }
 916
 917 ao_poly
 918 ao_scheme_do_booleanp(struct ao_scheme_cons *cons)
 919 {
 920         return ao_scheme_do_typep(AO_SCHEME_BOOL, cons);
 921 }
 922
 923 ao_poly
 924 ao_scheme_do_procedurep(struct ao_scheme_cons *cons)
 925 {
 926         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 927                 return AO_SCHEME_NIL;
 928         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 929         case AO_SCHEME_BUILTIN:
 930         case AO_SCHEME_LAMBDA:
 931                 return _ao_scheme_bool_true;
 932         default:
 933         return _ao_scheme_bool_false;
 934         }
 935 }
 936
 937 /* This one is special -- a list is either nil or
 938  * a 'proper' list with only cons cells
 939  */
 940 ao_poly
 941 ao_scheme_do_listp(struct ao_scheme_cons *cons)
 942 {
 943         ao_poly v;
 944         if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1))
 945                 return AO_SCHEME_NIL;
 946         v = ao_scheme_arg(cons, 0);
 947         for (;;) {
 948                 if (v == AO_SCHEME_NIL)
 949                         return _ao_scheme_bool_true;
 950                 if (!AO_SCHEME_IS_CONS(v))
 951                         return _ao_scheme_bool_false;
 952                 v = ao_scheme_poly_cons(v)->cdr;
 953         }
 954 }
 955
 956 ao_poly
 957 ao_scheme_do_set_car(struct ao_scheme_cons *cons)
 958 {
 959         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
 960                 return AO_SCHEME_NIL;
 961         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
 962                 return AO_SCHEME_NIL;
 963         return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1);
 964 }
 965
 966 ao_poly
 967 ao_scheme_do_set_cdr(struct ao_scheme_cons *cons)
 968 {
 969         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
 970                 return AO_SCHEME_NIL;
 971         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
 972                 return AO_SCHEME_NIL;
 973         return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1);
 974 }
 975
 976 ao_poly
 977 ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons)
 978 {
 979         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 980                 return AO_SCHEME_NIL;
 981         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0))
 982                 return AO_SCHEME_NIL;
 983         return ao_scheme_string_poly(ao_scheme_atom_to_string(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))));
 984 }
 985
 986 ao_poly
 987 ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons)
 988 {
 989         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 990                 return AO_SCHEME_NIL;
 991         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0))
 992                 return AO_SCHEME_NIL;
 993
 994         return ao_scheme_atom_poly(ao_scheme_string_to_atom(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));;
 995 }
 996
 997 ao_poly
 998 ao_scheme_do_read_char(struct ao_scheme_cons *cons)
 999 {
1000         int     c;
1001         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1002                 return AO_SCHEME_NIL;
1003         c = getchar();
1004         return ao_scheme_int_poly(c);
1005 }
1006
1007 ao_poly
1008 ao_scheme_do_write_char(struct ao_scheme_cons *cons)
1009 {
1010         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
1011                 return AO_SCHEME_NIL;
1012         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0))
1013                 return AO_SCHEME_NIL;
1014         putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0), NULL));
1015         return _ao_scheme_bool_true;
1016 }
1017
1018 ao_poly
1019 ao_scheme_do_exit(struct ao_scheme_cons *cons)
1020 {
1021         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1022                 return AO_SCHEME_NIL;
1023         ao_scheme_exception |= AO_SCHEME_EXIT;
1024         return _ao_scheme_bool_true;
1025 }
1026
1027 ao_poly
1028 ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons)
1029 {
1030         int     jiffy;
1031
1032         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1033                 return AO_SCHEME_NIL;
1034         jiffy = ao_scheme_os_jiffy();
1035         return (ao_scheme_int_poly(jiffy));
1036 }
1037
1038 ao_poly
1039 ao_scheme_do_current_second(struct ao_scheme_cons *cons)
1040 {
1041         int     second;
1042
1043         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1044                 return AO_SCHEME_NIL;
1045         second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND;
1046         return (ao_scheme_int_poly(second));
1047 }
1048
1049 ao_poly
1050 ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons)
1051 {
1052         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1053                 return AO_SCHEME_NIL;
1054         return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND));
1055 }
1056
1057 #ifdef AO_SCHEME_FEATURE_VECTOR
1058
1059 ao_poly
1060 ao_scheme_do_vector(struct ao_scheme_cons *cons)
1061 {
1062         return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons));
1063 }
1064
1065 ao_poly
1066 ao_scheme_do_make_vector(struct ao_scheme_cons *cons)
1067 {
1068         int32_t k;
1069
1070         if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2))
1071                 return AO_SCHEME_NIL;
1072         k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0);
1073         if (ao_scheme_exception)
1074                 return AO_SCHEME_NIL;
1075         return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1)));
1076 }
1077
1078 ao_poly
1079 ao_scheme_do_vector_ref(struct ao_scheme_cons *cons)
1080 {
1081         if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2))
1082                 return AO_SCHEME_NIL;
1083         if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0))
1084                 return AO_SCHEME_NIL;
1085         return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
1086 }
1087
1088 ao_poly
1089 ao_scheme_do_vector_set(struct ao_scheme_cons *cons)
1090 {
1091         if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3))
1092                 return AO_SCHEME_NIL;
1093         if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0))
1094                 return AO_SCHEME_NIL;
1095         return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2));
1096 }
1097
1098 ao_poly
1099 ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons)
1100 {
1101         if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1))
1102                 return AO_SCHEME_NIL;
1103         if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0))
1104                 return AO_SCHEME_NIL;
1105         return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))));
1106 }
1107
1108 ao_poly
1109 ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons)
1110 {
1111         if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1))
1112                 return AO_SCHEME_NIL;
1113         if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0))
1114                 return AO_SCHEME_NIL;
1115         return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))));
1116 }
1117
1118 ao_poly
1119 ao_scheme_do_vector_length(struct ao_scheme_cons *cons)
1120 {
1121         if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1))
1122                 return AO_SCHEME_NIL;
1123         if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0))
1124                 return AO_SCHEME_NIL;
1125         return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length);
1126 }
1127
1128 ao_poly
1129 ao_scheme_do_vectorp(struct ao_scheme_cons *cons)
1130 {
1131         return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons);
1132 }
1133
1134 #endif /* AO_SCHEME_FEATURE_VECTOR */
1135
1136 #define AO_SCHEME_BUILTIN_FUNCS
1137 #include "ao_scheme_builtin.h"