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