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