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