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         while (*string && ref) {
 766                 ++string;
 767                 --ref;
 768         }
 769         if (!*string)
 770                 return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
 771                                        _ao_scheme_atom_string2dset21,
 772                                        ao_scheme_arg(cons, 0),
 773                                        ao_scheme_arg(cons, 1));
 774         *string = val;
 775         return ao_scheme_int_poly(*string);
 776 }
 777
 778 ao_poly
 779 ao_scheme_do_flush_output(struct ao_scheme_cons *cons)
 780 {
 781         if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0))
 782                 return AO_SCHEME_NIL;
 783         ao_scheme_os_flush();
 784         return _ao_scheme_bool_true;
 785 }
 786
 787 ao_poly
 788 ao_scheme_do_led(struct ao_scheme_cons *cons)
 789 {
 790         int32_t led;
 791         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 792                 return AO_SCHEME_NIL;
 793         led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0);
 794         if (ao_scheme_exception)
 795                 return AO_SCHEME_NIL;
 796         led = ao_scheme_arg(cons, 0);
 797         ao_scheme_os_led(ao_scheme_poly_int(led));
 798         return led;
 799 }
 800
 801 ao_poly
 802 ao_scheme_do_delay(struct ao_scheme_cons *cons)
 803 {
 804         int32_t delay;
 805
 806         if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1))
 807                 return AO_SCHEME_NIL;
 808         delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0);
 809         if (ao_scheme_exception)
 810                 return AO_SCHEME_NIL;
 811         ao_scheme_os_delay(delay);
 812         return delay;
 813 }
 814
 815 ao_poly
 816 ao_scheme_do_eval(struct ao_scheme_cons *cons)
 817 {
 818         if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1))
 819                 return AO_SCHEME_NIL;
 820         ao_scheme_stack->state = eval_sexpr;
 821         return cons->car;
 822 }
 823
 824 ao_poly
 825 ao_scheme_do_apply(struct ao_scheme_cons *cons)
 826 {
 827         if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX))
 828                 return AO_SCHEME_NIL;
 829         ao_scheme_stack->state = eval_apply;
 830         return ao_scheme_cons_poly(cons);
 831 }
 832
 833 ao_poly
 834 ao_scheme_do_read(struct ao_scheme_cons *cons)
 835 {
 836         if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0))
 837                 return AO_SCHEME_NIL;
 838         return ao_scheme_read();
 839 }
 840
 841 ao_poly
 842 ao_scheme_do_collect(struct ao_scheme_cons *cons)
 843 {
 844         int     free;
 845         (void) cons;
 846         free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL);
 847         return ao_scheme_integer_poly(free);
 848 }
 849
 850 ao_poly
 851 ao_scheme_do_nullp(struct ao_scheme_cons *cons)
 852 {
 853         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 854                 return AO_SCHEME_NIL;
 855         if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL)
 856                 return _ao_scheme_bool_true;
 857         else
 858                 return _ao_scheme_bool_false;
 859 }
 860
 861 ao_poly
 862 ao_scheme_do_not(struct ao_scheme_cons *cons)
 863 {
 864         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 865                 return AO_SCHEME_NIL;
 866         if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false)
 867                 return _ao_scheme_bool_true;
 868         else
 869                 return _ao_scheme_bool_false;
 870 }
 871
 872 static ao_poly
 873 ao_scheme_do_typep(int type, 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_poly_type(ao_scheme_arg(cons, 0)) == type)
 878                 return _ao_scheme_bool_true;
 879         return _ao_scheme_bool_false;
 880 }
 881
 882 ao_poly
 883 ao_scheme_do_pairp(struct ao_scheme_cons *cons)
 884 {
 885         ao_poly v;
 886         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 887                 return AO_SCHEME_NIL;
 888         v = ao_scheme_arg(cons, 0);
 889         if (ao_scheme_is_pair(v))
 890                 return _ao_scheme_bool_true;
 891         return _ao_scheme_bool_false;
 892 }
 893
 894 ao_poly
 895 ao_scheme_do_integerp(struct ao_scheme_cons *cons)
 896 {
 897 #ifdef AO_SCHEME_FEATURE_BIGINT
 898         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 899                 return AO_SCHEME_NIL;
 900         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 901         case AO_SCHEME_INT:
 902         case AO_SCHEME_BIGINT:
 903                 return _ao_scheme_bool_true;
 904         default:
 905                 return _ao_scheme_bool_false;
 906         }
 907 #else
 908         return ao_scheme_do_typep(AO_SCHEME_INT, cons);
 909 #endif
 910 }
 911
 912 ao_poly
 913 ao_scheme_do_numberp(struct ao_scheme_cons *cons)
 914 {
 915 #if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT)
 916         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 917                 return AO_SCHEME_NIL;
 918         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 919         case AO_SCHEME_INT:
 920 #ifdef AO_SCHEME_FEATURE_BIGINT
 921         case AO_SCHEME_BIGINT:
 922 #endif
 923 #ifdef AO_SCHEME_FEATURE_FLOAT
 924         case AO_SCHEME_FLOAT:
 925 #endif
 926                 return _ao_scheme_bool_true;
 927         default:
 928                 return _ao_scheme_bool_false;
 929         }
 930 #else
 931         return ao_scheme_do_integerp(cons);
 932 #endif
 933 }
 934
 935 ao_poly
 936 ao_scheme_do_stringp(struct ao_scheme_cons *cons)
 937 {
 938         return ao_scheme_do_typep(AO_SCHEME_STRING, cons);
 939 }
 940
 941 ao_poly
 942 ao_scheme_do_symbolp(struct ao_scheme_cons *cons)
 943 {
 944         return ao_scheme_do_typep(AO_SCHEME_ATOM, cons);
 945 }
 946
 947 ao_poly
 948 ao_scheme_do_booleanp(struct ao_scheme_cons *cons)
 949 {
 950         return ao_scheme_do_typep(AO_SCHEME_BOOL, cons);
 951 }
 952
 953 ao_poly
 954 ao_scheme_do_procedurep(struct ao_scheme_cons *cons)
 955 {
 956         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
 957                 return AO_SCHEME_NIL;
 958         switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
 959         case AO_SCHEME_BUILTIN:
 960         case AO_SCHEME_LAMBDA:
 961                 return _ao_scheme_bool_true;
 962         default:
 963         return _ao_scheme_bool_false;
 964         }
 965 }
 966
 967 /* This one is special -- a list is either nil or
 968  * a 'proper' list with only cons cells
 969  */
 970 ao_poly
 971 ao_scheme_do_listp(struct ao_scheme_cons *cons)
 972 {
 973         ao_poly v;
 974         if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1))
 975                 return AO_SCHEME_NIL;
 976         v = ao_scheme_arg(cons, 0);
 977         for (;;) {
 978                 if (v == AO_SCHEME_NIL)
 979                         return _ao_scheme_bool_true;
 980                 if (!ao_scheme_is_cons(v))
 981                         return _ao_scheme_bool_false;
 982                 v = ao_scheme_poly_cons(v)->cdr;
 983         }
 984 }
 985
 986 ao_poly
 987 ao_scheme_do_set_car(struct ao_scheme_cons *cons)
 988 {
 989         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
 990                 return AO_SCHEME_NIL;
 991         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
 992                 return AO_SCHEME_NIL;
 993         return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1);
 994 }
 995
 996 ao_poly
 997 ao_scheme_do_set_cdr(struct ao_scheme_cons *cons)
 998 {
 999         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
1000                 return AO_SCHEME_NIL;
1001         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
1002                 return AO_SCHEME_NIL;
1003         return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1);
1004 }
1005
1006 ao_poly
1007 ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons)
1008 {
1009         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
1010                 return AO_SCHEME_NIL;
1011         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0))
1012                 return AO_SCHEME_NIL;
1013         return ao_scheme_string_poly(ao_scheme_atom_to_string(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))));
1014 }
1015
1016 ao_poly
1017 ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons)
1018 {
1019         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
1020                 return AO_SCHEME_NIL;
1021         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0))
1022                 return AO_SCHEME_NIL;
1023
1024         return ao_scheme_atom_poly(ao_scheme_string_to_atom(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));;
1025 }
1026
1027 ao_poly
1028 ao_scheme_do_read_char(struct ao_scheme_cons *cons)
1029 {
1030         int     c;
1031         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1032                 return AO_SCHEME_NIL;
1033         c = getchar();
1034         return ao_scheme_int_poly(c);
1035 }
1036
1037 ao_poly
1038 ao_scheme_do_write_char(struct ao_scheme_cons *cons)
1039 {
1040         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
1041                 return AO_SCHEME_NIL;
1042         if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0))
1043                 return AO_SCHEME_NIL;
1044         putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0), NULL));
1045         return _ao_scheme_bool_true;
1046 }
1047
1048 ao_poly
1049 ao_scheme_do_exit(struct ao_scheme_cons *cons)
1050 {
1051         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1052                 return AO_SCHEME_NIL;
1053         ao_scheme_exception |= AO_SCHEME_EXIT;
1054         return _ao_scheme_bool_true;
1055 }
1056
1057 ao_poly
1058 ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons)
1059 {
1060         int     jiffy;
1061
1062         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1063                 return AO_SCHEME_NIL;
1064         jiffy = ao_scheme_os_jiffy();
1065         return (ao_scheme_int_poly(jiffy));
1066 }
1067
1068 ao_poly
1069 ao_scheme_do_current_second(struct ao_scheme_cons *cons)
1070 {
1071         int     second;
1072
1073         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1074                 return AO_SCHEME_NIL;
1075         second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND;
1076         return (ao_scheme_int_poly(second));
1077 }
1078
1079 ao_poly
1080 ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons)
1081 {
1082         if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
1083                 return AO_SCHEME_NIL;
1084         return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND));
1085 }
1086
1087 #ifdef AO_SCHEME_FEATURE_VECTOR
1088
1089 ao_poly
1090 ao_scheme_do_vector(struct ao_scheme_cons *cons)
1091 {
1092         return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons));
1093 }
1094
1095 ao_poly
1096 ao_scheme_do_make_vector(struct ao_scheme_cons *cons)
1097 {
1098         int32_t k;
1099
1100         if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2))
1101                 return AO_SCHEME_NIL;
1102         k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0);
1103         if (ao_scheme_exception)
1104                 return AO_SCHEME_NIL;
1105         return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1)));
1106 }
1107
1108 ao_poly
1109 ao_scheme_do_vector_ref(struct ao_scheme_cons *cons)
1110 {
1111         if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2))
1112                 return AO_SCHEME_NIL;
1113         if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0))
1114                 return AO_SCHEME_NIL;
1115         return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
1116 }
1117
1118 ao_poly
1119 ao_scheme_do_vector_set(struct ao_scheme_cons *cons)
1120 {
1121         if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3))
1122                 return AO_SCHEME_NIL;
1123         if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0))
1124                 return AO_SCHEME_NIL;
1125         return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2));
1126 }
1127
1128 ao_poly
1129 ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons)
1130 {
1131         if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1))
1132                 return AO_SCHEME_NIL;
1133         if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0))
1134                 return AO_SCHEME_NIL;
1135         return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))));
1136 }
1137
1138 ao_poly
1139 ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons)
1140 {
1141         int     start, end;
1142
1143         if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 3))
1144                 return AO_SCHEME_NIL;
1145         if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0))
1146                 return AO_SCHEME_NIL;
1147         start = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 1, ao_scheme_int_poly(0));
1148         if (ao_scheme_exception)
1149                 return AO_SCHEME_NIL;
1150         end = ao_scheme_opt_arg_int(_ao_scheme_atom_vector2d3elist, cons, 2, ao_scheme_int_poly(-1));
1151         if (ao_scheme_exception)
1152                 return AO_SCHEME_NIL;
1153         return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)),
1154                                                             start,
1155                                                             end));
1156 }
1157
1158 ao_poly
1159 ao_scheme_do_vector_length(struct ao_scheme_cons *cons)
1160 {
1161         if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1))
1162                 return AO_SCHEME_NIL;
1163         if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0))
1164                 return AO_SCHEME_NIL;
1165         return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length);
1166 }
1167
1168 ao_poly
1169 ao_scheme_do_vectorp(struct ao_scheme_cons *cons)
1170 {
1171         return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons);
1172 }
1173
1174 #endif /* AO_SCHEME_FEATURE_VECTOR */
1175
1176 #define AO_SCHEME_BUILTIN_FUNCS
1177 #include "ao_scheme_builtin.h"