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 #define _GNU_SOURCE
  16 #include "ao_scheme.h"
  17 #include <limits.h>
  18 #include <math.h>
  19 #include <stdarg.h>
  20
  21 static int
  22 builtin_size(void *addr)
  23 {
  24         (void) addr;
  25         return sizeof (struct ao_scheme_builtin);
  26 }
  27
  28 static void
  29 builtin_mark(void *addr)
  30 {
  31         (void) addr;
  32 }
  33
  34 static void
  35 builtin_move(void *addr)
  36 {
  37         (void) addr;
  38 }
  39
  40 const struct ao_scheme_type ao_scheme_builtin_type = {
  41         .size = builtin_size,
  42         .mark = builtin_mark,
  43         .move = builtin_move
  44 };
  45
  46 #ifdef AO_SCHEME_MAKE_CONST
  47
  48 #define AO_SCHEME_BUILTIN_CASENAME
  49 #include "ao_scheme_builtin.h"
  50
  51 char *ao_scheme_args_name(uint8_t args) {
  52         args &= AO_SCHEME_FUNC_MASK;
  53         switch (args) {
  54         case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name;
  55         case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name;
  56         case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name;
  57         default: return (char *) "???";
  58         }
  59 }
  60 #else
  61
  62 #define AO_SCHEME_BUILTIN_ARRAYNAME
  63 #include "ao_scheme_builtin.h"
  64
  65 static char *
  66 ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {
  67         if (b < _builtin_last)
  68                 return ao_scheme_poly_atom(builtin_names[b])->name;
  69         return (char *) "???";
  70 }
  71
  72 static const ao_poly ao_scheme_args_atoms[] = {
  73         [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda,
  74         [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda,
  75         [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro,
  76 };
  77
  78 char *
  79 ao_scheme_args_name(uint8_t args)
  80 {
  81         args &= AO_SCHEME_FUNC_MASK;
  82         if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0])
  83                 return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name;
  84         return (char *) "(unknown)";
  85 }
  86 #endif
  87
  88 void
  89 ao_scheme_builtin_write(FILE *out, ao_poly b, bool write)
  90 {
  91         struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b);
  92         (void) write;
  93         fputs(ao_scheme_builtin_name(builtin->func), out);
  94 }
  95
  96 static bool
  97 ao_scheme_typecheck(ao_poly actual, int formal_type) {
  98         int     actual_type;
  99
 100         if ((formal_type & AO_SCHEME_ARG_MASK) == AO_SCHEME_POLY)
 101                 return true;
 102
 103         /* allow nil? */
 104         if (actual == AO_SCHEME_NIL)
 105                 return (formal_type & AO_SCHEME_ARG_NIL_OK) != 0;
 106
 107         actual_type = ao_scheme_poly_type(actual);
 108         formal_type &= AO_SCHEME_ARG_MASK;
 109
 110         if (actual_type == formal_type)
 111                 return true;
 112         if (actual_type == AO_SCHEME_BUILTIN && formal_type == AO_SCHEME_LAMBDA)
 113                 return true;
 114
 115 #ifdef AO_SCHEME_FEATURE_BIGINT
 116         if (ao_scheme_integer_typep(actual_type) && formal_type == AO_SCHEME_INT)
 117                 return true;
 118 #endif
 119 #ifdef AO_SCHEME_FEATURE_FLOAT
 120         if (ao_scheme_number_typep(actual_type) && formal_type == AO_SCHEME_FLOAT)
 121                 return true;
 122 #endif
 123         return false;
 124 }
 125
 126 int
 127 ao_scheme_parse_args(ao_poly name, struct ao_scheme_cons *cons, ...)
 128 {
 129         va_list ap;
 130         int formal;
 131         int argc = 0;
 132         ao_poly car;
 133
 134         va_start(ap, cons);
 135         while ((formal = va_arg(ap, int)) != AO_SCHEME_ARG_END) {
 136                 if (formal & AO_SCHEME_ARG_OPTIONAL)
 137                         car = (ao_poly) va_arg(ap, int);
 138                 if (cons) {
 139                         car = cons->car;
 140                         cons = ao_scheme_cons_cdr(cons);
 141                         if (!ao_scheme_typecheck(car, formal)) {
 142                                 ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car);
 143                                 return 0;
 144                         }
 145                 } else if (!(formal & AO_SCHEME_ARG_OPTIONAL)) {
 146                         goto bad_args;
 147                 }
 148                 if (formal & AO_SCHEME_ARG_RET_POLY)
 149                         formal = AO_SCHEME_POLY;
 150
 151                 switch (formal & AO_SCHEME_ARG_MASK) {
 152                 case AO_SCHEME_INT:
 153 #ifdef AO_SCHEME_FEATURE_BIGINT
 154                 case AO_SCHEME_BIGINT:
 155 #endif
 156                         *(va_arg(ap, int32_t *)) = ao_scheme_poly_integer(car);
 157                         break;
 158 #ifdef AO_SCHEME_FEATURE_FLOAT
 159                 case AO_SCHEME_FLOAT:
 160                         *(va_arg(ap, float *)) = ao_scheme_poly_number(car);
 161                         break;
 162 #endif
 163                 case AO_SCHEME_POLY:
 164                         *(va_arg(ap, ao_poly *)) = car;
 165                         break;
 166                 default:
 167                         *(va_arg(ap, void **)) = ao_scheme_ref(car);
 168                         break;
 169                 }
 170                 argc++;
 171         }
 172         if (cons) {
 173         bad_args:
 174                 ao_scheme_error(AO_SCHEME_INVALID, "%v: invalid arg count", name);
 175                 return 0;
 176         }
 177         return 1;
 178 }
 179
 180 ao_poly
 181 ao_scheme_arg(struct ao_scheme_cons *cons, int argc)
 182 {
 183         for (;;) {
 184                 if (!cons)
 185                         return AO_SCHEME_NIL;
 186                 if (argc == 0)
 187                         return cons->car;
 188                 cons = ao_scheme_cons_cdr(cons);
 189                 argc--;
 190         }
 191 }
 192
 193 ao_poly
 194 ao_scheme_do_quote(struct ao_scheme_cons *cons)
 195 {
 196         ao_poly val;
 197
 198         if (!ao_scheme_parse_args(_ao_scheme_atom_quote, cons,
 199                                   AO_SCHEME_POLY, &val,
 200                                   AO_SCHEME_ARG_END))
 201                 return AO_SCHEME_NIL;
 202         return val;
 203 }
 204
 205 ao_poly
 206 ao_scheme_do_cond(struct ao_scheme_cons *cons)
 207 {
 208         ao_scheme_set_cond(cons);
 209         return AO_SCHEME_NIL;
 210 }
 211
 212 ao_poly
 213 ao_scheme_do_begin(struct ao_scheme_cons *cons)
 214 {
 215         ao_scheme_stack->state = eval_begin;
 216         ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons);
 217         return AO_SCHEME_NIL;
 218 }
 219
 220 ao_poly
 221 ao_scheme_do_while(struct ao_scheme_cons *cons)
 222 {
 223         ao_scheme_stack->state = eval_while;
 224         ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons);
 225         return AO_SCHEME_NIL;
 226 }
 227
 228 static ao_poly
 229 ao_scheme_do_display_or_write(ao_poly proc, struct ao_scheme_cons *cons, bool write)
 230 {
 231 #ifndef AO_SCHEME_FEATURE_PORT
 232         ao_poly val;
 233         ao_poly port;
 234
 235         if (!ao_scheme_parse_args(proc, cons,
 236                                   AO_SCHEME_POLY, &val,
 237                                   AO_SCHEME_POLY | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 238                                   AO_SCHEME_ARG_END))
 239                 return AO_SCHEME_NIL;
 240         ao_scheme_poly_write(stdout, val, write);
 241 #else
 242         ao_poly                 val;
 243         struct ao_scheme_port   *port;
 244         FILE                    *file = stdout;
 245
 246         if (!ao_scheme_parse_args(proc, cons,
 247                                   AO_SCHEME_POLY, &val,
 248                                   AO_SCHEME_PORT | AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 249                                   AO_SCHEME_ARG_END))
 250                 return AO_SCHEME_NIL;
 251         if (port) {
 252                 file = port->file;
 253                 if (!file)
 254                         return _ao_scheme_bool_true;
 255         }
 256         ao_scheme_poly_write(file, val, write);
 257 #endif
 258         return _ao_scheme_bool_true;
 259 }
 260
 261 ao_poly
 262 ao_scheme_do_write(struct ao_scheme_cons *cons)
 263 {
 264         return ao_scheme_do_display_or_write(_ao_scheme_atom_write, cons, true);
 265 }
 266
 267 ao_poly
 268 ao_scheme_do_display(struct ao_scheme_cons *cons)
 269 {
 270         return ao_scheme_do_display_or_write(_ao_scheme_atom_display, cons, false);
 271 }
 272
 273 static ao_poly
 274 ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op)
 275 {
 276         struct ao_scheme_cons *cons;
 277         ao_poly ret = AO_SCHEME_NIL;
 278
 279         for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) {
 280                 ao_poly         car = cons->car;
 281                 uint8_t         rt = ao_scheme_poly_type(ret);
 282                 uint8_t         ct = ao_scheme_poly_type(car);
 283
 284                 if (cons == orig_cons) {
 285                         ret = car;
 286                         ao_scheme_cons_stash(cons);
 287                         if (cons->cdr == AO_SCHEME_NIL) {
 288                                 switch (op) {
 289                                 case builtin_minus:
 290                                         if (ao_scheme_integer_typep(ct))
 291                                                 ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret));
 292 #ifdef AO_SCHEME_FEATURE_FLOAT
 293                                         else if (ct == AO_SCHEME_FLOAT)
 294                                                 ret = ao_scheme_float_get(-ao_scheme_poly_number(ret));
 295 #endif
 296                                         break;
 297                                 case builtin_divide:
 298                                         if (ao_scheme_poly_integer(ret) == 1) {
 299                                         } else {
 300 #ifdef AO_SCHEME_FEATURE_FLOAT
 301                                                 if (ao_scheme_number_typep(ct)) {
 302                                                         float   v = ao_scheme_poly_number(ret);
 303                                                         ret = ao_scheme_float_get(1/v);
 304                                                 }
 305 #else
 306                                                 ret = ao_scheme_integer_poly(0);
 307 #endif
 308                                         }
 309                                         break;
 310                                 default:
 311                                         break;
 312                                 }
 313                         }
 314                         cons = ao_scheme_cons_fetch();
 315                 } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) {
 316                         int32_t r = ao_scheme_poly_integer(ret);
 317                         int32_t c = ao_scheme_poly_integer(car);
 318 #ifdef AO_SCHEME_FEATURE_FLOAT
 319                         int64_t t;
 320 #endif
 321
 322                         switch(op) {
 323                         case builtin_plus:
 324                                 r += c;
 325                         check_overflow:
 326 #ifdef AO_SCHEME_FEATURE_FLOAT
 327                                 if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r)
 328                                         goto inexact;
 329 #endif
 330                                 break;
 331                         case builtin_minus:
 332                                 r -= c;
 333                                 goto check_overflow;
 334                                 break;
 335                         case builtin_times:
 336 #ifdef AO_SCHEME_FEATURE_FLOAT
 337                                 t = (int64_t) r * (int64_t) c;
 338                                 if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t)
 339                                         goto inexact;
 340                                 r = (int32_t) t;
 341 #else
 342                                 r = r * c;
 343 #endif
 344                                 break;
 345                         case builtin_divide:
 346 #ifdef AO_SCHEME_FEATURE_FLOAT
 347                                 if (c != 0 && (r % c) == 0)
 348                                         r /= c;
 349                                 else
 350                                         goto inexact;
 351 #else
 352                                 r /= c;
 353 #endif
 354                                 break;
 355                         case builtin_quotient:
 356                                 if (c == 0)
 357                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero");
 358                                 r = r / c;
 359                                 break;
 360                         case builtin_floor_quotient:
 361                                 if (c == 0)
 362                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "floor-quotient by zero");
 363                                 if (r % c != 0 && (c < 0) != (r < 0))
 364                                         r = r / c - 1;
 365                                 else
 366                                         r = r / c;
 367                                 break;
 368                         case builtin_remainder:
 369                                 if (c == 0)
 370                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero");
 371                                 r %= c;
 372                                 break;
 373                         case builtin_modulo:
 374                                 if (c == 0)
 375                                         return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero");
 376                                 r %= c;
 377                                 if ((r < 0) != (c < 0))
 378                                         r += c;
 379                                 break;
 380                         default:
 381                                 break;
 382                         }
 383                         ao_scheme_cons_stash(cons);
 384                         ret = ao_scheme_integer_poly(r);
 385                         cons = ao_scheme_cons_fetch();
 386 #ifdef AO_SCHEME_FEATURE_FLOAT
 387                 } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) {
 388                         float r, c;
 389                 inexact:
 390                         r = ao_scheme_poly_number(ret);
 391                         c = ao_scheme_poly_number(car);
 392                         switch(op) {
 393                         case builtin_plus:
 394                                 r += c;
 395                                 break;
 396                         case builtin_minus:
 397                                 r -= c;
 398                                 break;
 399                         case builtin_times:
 400                                 r *= c;
 401                                 break;
 402                         case builtin_divide:
 403                                 r /= c;
 404                                 break;
 405                         case builtin_quotient:
 406                         case builtin_floor_quotient:
 407                         case builtin_remainder:
 408                         case builtin_modulo:
 409                                 return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide");
 410                         default:
 411                                 break;
 412                         }
 413                         ao_scheme_cons_stash(cons);
 414                         ret = ao_scheme_float_get(r);
 415                         cons = ao_scheme_cons_fetch();
 416 #endif
 417                 }
 418                 else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) {
 419                         ao_scheme_cons_stash(cons);
 420                         ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret),
 421                                                                          ao_scheme_poly_string(car)));
 422                         cons = ao_scheme_cons_fetch();
 423                         if (!ret)
 424                                 return ret;
 425                 }
 426                 else
 427                         return ao_scheme_error(AO_SCHEME_INVALID, "invalid args");
 428         }
 429         return ret;
 430 }
 431
 432 ao_poly
 433 ao_scheme_do_plus(struct ao_scheme_cons *cons)
 434 {
 435         return ao_scheme_math(cons, builtin_plus);
 436 }
 437
 438 ao_poly
 439 ao_scheme_do_minus(struct ao_scheme_cons *cons)
 440 {
 441         return ao_scheme_math(cons, builtin_minus);
 442 }
 443
 444 ao_poly
 445 ao_scheme_do_times(struct ao_scheme_cons *cons)
 446 {
 447         return ao_scheme_math(cons, builtin_times);
 448 }
 449
 450 ao_poly
 451 ao_scheme_do_divide(struct ao_scheme_cons *cons)
 452 {
 453         return ao_scheme_math(cons, builtin_divide);
 454 }
 455
 456 ao_poly
 457 ao_scheme_do_quotient(struct ao_scheme_cons *cons)
 458 {
 459         return ao_scheme_math(cons, builtin_quotient);
 460 }
 461
 462 ao_poly
 463 ao_scheme_do_floor_quotient(struct ao_scheme_cons *cons)
 464 {
 465         return ao_scheme_math(cons, builtin_floor_quotient);
 466 }
 467
 468 ao_poly
 469 ao_scheme_do_modulo(struct ao_scheme_cons *cons)
 470 {
 471         return ao_scheme_math(cons, builtin_modulo);
 472 }
 473
 474 ao_poly
 475 ao_scheme_do_remainder(struct ao_scheme_cons *cons)
 476 {
 477         return ao_scheme_math(cons, builtin_remainder);
 478 }
 479
 480 static ao_poly
 481 ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op)
 482 {
 483         ao_poly left;
 484
 485         if (!cons)
 486                 return _ao_scheme_bool_true;
 487
 488         left = cons->car;
 489         for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) {
 490                 ao_poly right = cons->car;
 491
 492                 if (op == builtin_equal && left == right) {
 493                         ;
 494                 } else {
 495                         uint8_t lt = ao_scheme_poly_type(left);
 496                         uint8_t rt = ao_scheme_poly_type(right);
 497                         if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) {
 498                                 int32_t l = ao_scheme_poly_integer(left);
 499                                 int32_t r = ao_scheme_poly_integer(right);
 500
 501                                 switch (op) {
 502                                 case builtin_less:
 503                                         if (!(l < r))
 504                                                 return _ao_scheme_bool_false;
 505                                         break;
 506                                 case builtin_greater:
 507                                         if (!(l > r))
 508                                                 return _ao_scheme_bool_false;
 509                                         break;
 510                                 case builtin_less_equal:
 511                                         if (!(l <= r))
 512                                                 return _ao_scheme_bool_false;
 513                                         break;
 514                                 case builtin_greater_equal:
 515                                         if (!(l >= r))
 516                                                 return _ao_scheme_bool_false;
 517                                         break;
 518                                 case builtin_equal:
 519                                         if (!(l == r))
 520                                                 return _ao_scheme_bool_false;
 521                                 default:
 522                                         break;
 523                                 }
 524 #ifdef AO_SCHEME_FEATURE_FLOAT
 525                         } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) {
 526                                 float l, r;
 527
 528                                 l = ao_scheme_poly_number(left);
 529                                 r = ao_scheme_poly_number(right);
 530
 531                                 switch (op) {
 532                                 case builtin_less:
 533                                         if (!(l < r))
 534                                                 return _ao_scheme_bool_false;
 535                                         break;
 536                                 case builtin_greater:
 537                                         if (!(l > r))
 538                                                 return _ao_scheme_bool_false;
 539                                         break;
 540                                 case builtin_less_equal:
 541                                         if (!(l <= r))
 542                                                 return _ao_scheme_bool_false;
 543                                         break;
 544                                 case builtin_greater_equal:
 545                                         if (!(l >= r))
 546                                                 return _ao_scheme_bool_false;
 547                                         break;
 548                                 case builtin_equal:
 549                                         if (!(l == r))
 550                                                 return _ao_scheme_bool_false;
 551                                 default:
 552                                         break;
 553                                 }
 554 #endif /* AO_SCHEME_FEATURE_FLOAT */
 555                         } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) {
 556                                 int c = strcmp(ao_scheme_poly_string(left)->val,
 557                                                ao_scheme_poly_string(right)->val);
 558                                 switch (op) {
 559                                 case builtin_less:
 560                                         if (!(c < 0))
 561                                                 return _ao_scheme_bool_false;
 562                                         break;
 563                                 case builtin_greater:
 564                                         if (!(c > 0))
 565                                                 return _ao_scheme_bool_false;
 566                                         break;
 567                                 case builtin_less_equal:
 568                                         if (!(c <= 0))
 569                                                 return _ao_scheme_bool_false;
 570                                         break;
 571                                 case builtin_greater_equal:
 572                                         if (!(c >= 0))
 573                                                 return _ao_scheme_bool_false;
 574                                         break;
 575                                 case builtin_equal:
 576                                         if (!(c == 0))
 577                                                 return _ao_scheme_bool_false;
 578                                         break;
 579                                 default:
 580                                         break;
 581                                 }
 582                         } else
 583                                 return _ao_scheme_bool_false;
 584                 }
 585                 left = right;
 586         }
 587         return _ao_scheme_bool_true;
 588 }
 589
 590 ao_poly
 591 ao_scheme_do_equal(struct ao_scheme_cons *cons)
 592 {
 593         return ao_scheme_compare(cons, builtin_equal);
 594 }
 595
 596 ao_poly
 597 ao_scheme_do_less(struct ao_scheme_cons *cons)
 598 {
 599         return ao_scheme_compare(cons, builtin_less);
 600 }
 601
 602 ao_poly
 603 ao_scheme_do_greater(struct ao_scheme_cons *cons)
 604 {
 605         return ao_scheme_compare(cons, builtin_greater);
 606 }
 607
 608 ao_poly
 609 ao_scheme_do_less_equal(struct ao_scheme_cons *cons)
 610 {
 611         return ao_scheme_compare(cons, builtin_less_equal);
 612 }
 613
 614 ao_poly
 615 ao_scheme_do_greater_equal(struct ao_scheme_cons *cons)
 616 {
 617         return ao_scheme_compare(cons, builtin_greater_equal);
 618 }
 619
 620 ao_poly
 621 ao_scheme_do_flush_output(struct ao_scheme_cons *cons)
 622 {
 623 #ifndef AO_SCHEME_FEATURE_PORT
 624         ao_poly port;
 625         if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons,
 626                                   AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 627                                   AO_SCHEME_ARG_END))
 628                 return AO_SCHEME_NIL;
 629         fflush(stdout);
 630 #else
 631         struct ao_scheme_port   *port;
 632
 633         if (!ao_scheme_parse_args(_ao_scheme_atom_flush2doutput, cons,
 634                                   AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 635                                   AO_SCHEME_ARG_END))
 636                 return AO_SCHEME_NIL;
 637         fflush(stdout);
 638         if (port) {
 639                 if (port->file)
 640                         fflush(port->file);
 641         } else
 642                 fflush(stdout);
 643 #endif
 644         return _ao_scheme_bool_true;
 645 }
 646
 647 #ifdef AO_SCHEME_FEATURE_GPIO
 648
 649 ao_poly
 650 ao_scheme_do_led(struct ao_scheme_cons *cons)
 651 {
 652         int32_t led;
 653         if (!ao_scheme_parse_args(_ao_scheme_atom_led, cons,
 654                                   AO_SCHEME_INT, &led,
 655                                   AO_SCHEME_ARG_END))
 656                 return AO_SCHEME_NIL;
 657         ao_scheme_os_led(led);
 658         return _ao_scheme_bool_true;
 659 }
 660
 661 #endif
 662
 663 ao_poly
 664 ao_scheme_do_eval(struct ao_scheme_cons *cons)
 665 {
 666         ao_poly expr;
 667         ao_poly env;
 668
 669         if (!ao_scheme_parse_args(_ao_scheme_atom_eval, cons,
 670                                   AO_SCHEME_POLY, &expr,
 671                                   AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &env,
 672                                   AO_SCHEME_ARG_END))
 673                 return AO_SCHEME_NIL;
 674         ao_scheme_stack->state = eval_sexpr;
 675         ao_scheme_stack->frame = AO_SCHEME_NIL;
 676         ao_scheme_frame_current = NULL;
 677         return expr;
 678 }
 679
 680 ao_poly
 681 ao_scheme_do_apply(struct ao_scheme_cons *cons)
 682 {
 683         ao_scheme_stack->state = eval_apply;
 684         return ao_scheme_cons_poly(cons);
 685 }
 686
 687 ao_poly
 688 ao_scheme_do_read(struct ao_scheme_cons *cons)
 689 {
 690         FILE    *file = stdin;
 691 #ifndef AO_SCHEME_FEATURE_PORT
 692         ao_poly port;
 693         if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons,
 694                                   AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 695                                   AO_SCHEME_ARG_END))
 696                 return AO_SCHEME_NIL;
 697 #else
 698         struct ao_scheme_port   *port;
 699
 700         if (!ao_scheme_parse_args(_ao_scheme_atom_read, cons,
 701                                   AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 702                                   AO_SCHEME_ARG_END))
 703                 return AO_SCHEME_NIL;
 704         if (port) {
 705                 file = port->file;
 706                 if (!file)
 707                         return _ao_scheme_atom_eof;
 708         }
 709 #endif
 710         return ao_scheme_read(file);
 711 }
 712
 713 ao_poly
 714 ao_scheme_do_collect(struct ao_scheme_cons *cons)
 715 {
 716         int     free;
 717         (void) cons;
 718         free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL);
 719         return ao_scheme_integer_poly(free);
 720 }
 721
 722 ao_poly
 723 ao_scheme_do_nullp(struct ao_scheme_cons *cons)
 724 {
 725         ao_poly val;
 726
 727         if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons,
 728                                   AO_SCHEME_POLY, &val,
 729                                   AO_SCHEME_ARG_END))
 730                 return AO_SCHEME_NIL;
 731         if (val == AO_SCHEME_NIL)
 732                 return _ao_scheme_bool_true;
 733         else
 734                 return _ao_scheme_bool_false;
 735 }
 736
 737 ao_poly
 738 ao_scheme_do_not(struct ao_scheme_cons *cons)
 739 {
 740         ao_poly val;
 741
 742         if (!ao_scheme_parse_args(_ao_scheme_atom_not, cons,
 743                                   AO_SCHEME_POLY, &val,
 744                                   AO_SCHEME_ARG_END))
 745                 return AO_SCHEME_NIL;
 746         if (val == _ao_scheme_bool_false)
 747                 return _ao_scheme_bool_true;
 748         else
 749                 return _ao_scheme_bool_false;
 750 }
 751
 752 ao_poly
 753 ao_scheme_do_typep(ao_poly proc, int type, struct ao_scheme_cons *cons)
 754 {
 755         ao_poly val;
 756
 757         if (!ao_scheme_parse_args(proc, cons,
 758                                   AO_SCHEME_POLY, &val,
 759                                   AO_SCHEME_ARG_END))
 760                 return AO_SCHEME_NIL;
 761         if (ao_scheme_poly_type(val) == type)
 762                 return _ao_scheme_bool_true;
 763         return _ao_scheme_bool_false;
 764 }
 765
 766 ao_poly
 767 ao_scheme_do_procedurep(struct ao_scheme_cons *cons)
 768 {
 769         ao_poly val;
 770
 771         if (!ao_scheme_parse_args(_ao_scheme_atom_pair3f, cons,
 772                                   AO_SCHEME_POLY, &val,
 773                                   AO_SCHEME_ARG_END))
 774                 return AO_SCHEME_NIL;
 775         switch (ao_scheme_poly_type(val)) {
 776         case AO_SCHEME_BUILTIN:
 777         case AO_SCHEME_LAMBDA:
 778                 return _ao_scheme_bool_true;
 779         default:
 780                 return _ao_scheme_bool_false;
 781         }
 782 }
 783
 784 ao_poly
 785 ao_scheme_do_read_char(struct ao_scheme_cons *cons)
 786 {
 787         int     c;
 788 #ifndef AO_SCHEME_FEATURE_PORT
 789         ao_poly port;
 790         if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons,
 791                                   AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 792                                   AO_SCHEME_ARG_END))
 793                 return AO_SCHEME_NIL;
 794         c = getchar();
 795 #else
 796         struct ao_scheme_port   *port;
 797
 798         if (!ao_scheme_parse_args(_ao_scheme_atom_read2dchar, cons,
 799                                   AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 800                                   AO_SCHEME_ARG_END))
 801                 return AO_SCHEME_NIL;
 802         if (port)
 803                 c = ao_scheme_port_getc(port);
 804         else
 805                 c = getchar();
 806 #endif
 807         if (c == EOF)
 808                 return _ao_scheme_atom_eof;
 809         return ao_scheme_integer_poly(c);
 810 }
 811
 812 ao_poly
 813 ao_scheme_do_write_char(struct ao_scheme_cons *cons)
 814 {
 815         int32_t c;
 816 #ifndef AO_SCHEME_FEATURE_PORT
 817         ao_poly port;
 818         if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons,
 819                                   AO_SCHEME_INT, &c,
 820                                   AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 821                                   AO_SCHEME_ARG_END))
 822                 return AO_SCHEME_NIL;
 823         putchar(c);
 824 #else
 825         struct ao_scheme_port   *port;
 826         if (!ao_scheme_parse_args(_ao_scheme_atom_write2dchar, cons,
 827                                   AO_SCHEME_INT, &c,
 828                                   AO_SCHEME_PORT|AO_SCHEME_ARG_OPTIONAL, AO_SCHEME_NIL, &port,
 829                                   AO_SCHEME_ARG_END))
 830                 return AO_SCHEME_NIL;
 831         if (port)
 832                 ao_scheme_port_putc(port, c);
 833         else
 834                 putchar(c);
 835 #endif
 836         return _ao_scheme_bool_true;
 837 }
 838
 839 ao_poly
 840 ao_scheme_do_exit(struct ao_scheme_cons *cons)
 841 {
 842         ao_poly val;
 843
 844         if (!ao_scheme_parse_args(_ao_scheme_atom_exit, cons,
 845                                   AO_SCHEME_POLY|AO_SCHEME_ARG_OPTIONAL, _ao_scheme_bool_true, &val,
 846                                   AO_SCHEME_ARG_END))
 847                 return AO_SCHEME_NIL;
 848         ao_scheme_exception |= AO_SCHEME_EXIT;
 849         return val;
 850 }
 851
 852 #ifdef AO_SCHEME_FEATURE_TIME
 853
 854 ao_poly
 855 ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons)
 856 {
 857         if (!ao_scheme_parse_args(_ao_scheme_atom_current2djiffy, cons,
 858                                   AO_SCHEME_ARG_END))
 859                 return AO_SCHEME_NIL;
 860         return ao_scheme_integer_poly(ao_scheme_os_jiffy());
 861 }
 862
 863 ao_poly
 864 ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons)
 865 {
 866         if (!ao_scheme_parse_args(_ao_scheme_atom_jiffies2dper2dsecond, cons,
 867                                   AO_SCHEME_ARG_END))
 868                 return AO_SCHEME_NIL;
 869         return ao_scheme_integer_poly(AO_SCHEME_JIFFIES_PER_SECOND);
 870 }
 871
 872 ao_poly
 873 ao_scheme_do_delay(struct ao_scheme_cons *cons)
 874 {
 875         int32_t delay;
 876
 877         if (!ao_scheme_parse_args(_ao_scheme_atom_delay, cons,
 878                                   AO_SCHEME_INT, &delay,
 879                                   AO_SCHEME_ARG_END))
 880                 return AO_SCHEME_NIL;
 881         ao_scheme_os_delay(delay);
 882         return cons->car;
 883 }
 884 #endif
 885
 886 #ifdef AO_SCHEME_FEATURE_POSIX
 887
 888 #include <unistd.h>
 889
 890 static char     **ao_scheme_argv;
 891
 892 void
 893 ao_scheme_set_argv(char **argv)
 894 {
 895         ao_scheme_argv = argv;
 896 }
 897
 898 ao_poly
 899 ao_scheme_do_command_line(struct ao_scheme_cons *cons)
 900 {
 901         ao_poly args = AO_SCHEME_NIL;
 902         ao_poly arg;
 903         int     i;
 904
 905         if (!ao_scheme_parse_args(_ao_scheme_atom_command2dline, cons,
 906                                   AO_SCHEME_ARG_END))
 907                 return AO_SCHEME_NIL;
 908
 909         for (i = 0; ao_scheme_argv[i]; i++);
 910
 911         while (--i >= 0) {
 912                 ao_scheme_poly_stash(args);
 913                 arg = ao_scheme_string_poly(ao_scheme_string_new(ao_scheme_argv[i]));
 914                 args = ao_scheme_poly_fetch();
 915                 if (!arg)
 916                         return AO_SCHEME_NIL;
 917                 args = ao_scheme_cons(arg, args);
 918                 if (!args)
 919                         return AO_SCHEME_NIL;
 920         }
 921         return args;
 922 }
 923
 924 ao_poly
 925 ao_scheme_do_get_environment_variables(struct ao_scheme_cons *cons)
 926 {
 927         ao_poly envs = AO_SCHEME_NIL;
 928         ao_poly env;
 929         int     i;
 930
 931         if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariables, cons,
 932                                   AO_SCHEME_ARG_END))
 933                 return AO_SCHEME_NIL;
 934         for (i = 0; environ[i]; i++);
 935
 936         while (--i >= 0) {
 937                 ao_scheme_poly_stash(envs);
 938                 env = ao_scheme_string_poly(ao_scheme_string_new(environ[i]));
 939                 envs = ao_scheme_poly_fetch();
 940                 if (!env)
 941                         return AO_SCHEME_NIL;
 942                 envs = ao_scheme_cons(env, envs);
 943                 if (!envs)
 944                         return AO_SCHEME_NIL;
 945         }
 946         return envs;
 947 }
 948
 949 ao_poly
 950 ao_scheme_do_get_environment_variable(struct ao_scheme_cons *cons)
 951 {
 952         struct ao_scheme_string *name;
 953         char                    *val;
 954
 955         if (!ao_scheme_parse_args(_ao_scheme_atom_get2denvironment2dvariable, cons,
 956                                   AO_SCHEME_STRING, &name,
 957                                   AO_SCHEME_ARG_END))
 958                 return AO_SCHEME_NIL;
 959         val = secure_getenv(name->val);
 960         if (!val)
 961                 return _ao_scheme_bool_false;
 962         return ao_scheme_string_poly(ao_scheme_string_new(val));
 963 }
 964
 965 ao_poly
 966 ao_scheme_do_file_existsp(struct ao_scheme_cons *cons)
 967 {
 968         struct ao_scheme_string *name;
 969
 970         if (!ao_scheme_parse_args(_ao_scheme_atom_file2dexists3f, cons,
 971                                   AO_SCHEME_STRING, &name,
 972                                   AO_SCHEME_ARG_END))
 973                 return AO_SCHEME_NIL;
 974         if (access(name->val, F_OK) == 0)
 975                 return _ao_scheme_bool_true;
 976         return _ao_scheme_bool_false;
 977 }
 978
 979 ao_poly
 980 ao_scheme_do_delete_file(struct ao_scheme_cons *cons)
 981 {
 982         struct ao_scheme_string *name;
 983
 984         if (!ao_scheme_parse_args(_ao_scheme_atom_delete2dfile, cons,
 985                                   AO_SCHEME_STRING, &name,
 986                                   AO_SCHEME_ARG_END))
 987                 return AO_SCHEME_NIL;
 988         if (unlink(name->val) == 0)
 989                 return _ao_scheme_bool_true;
 990         return _ao_scheme_bool_false;
 991 }
 992
 993 ao_poly
 994 ao_scheme_do_current_second(struct ao_scheme_cons *cons)
 995 {
 996         int32_t second;
 997
 998         if (!ao_scheme_parse_args(_ao_scheme_atom_current2dsecond, cons,
 999                                   AO_SCHEME_ARG_END))
1000                 return AO_SCHEME_NIL;
1001         second = (int32_t) time(NULL);
1002         return ao_scheme_integer_poly(second);
1003 }
1004
1005 #endif /* AO_SCHEME_FEATURE_POSIX */
1006
1007 #define AO_SCHEME_BUILTIN_FUNCS
1008 #include "ao_scheme_builtin.h"