2 * Copyright © 2016 Keith Packard <keithp@keithp.com>
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.
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.
15 #include "ao_scheme.h"
20 builtin_size(void *addr)
23 return sizeof (struct ao_scheme_builtin);
27 builtin_mark(void *addr)
33 builtin_move(void *addr)
38 const struct ao_scheme_type ao_scheme_builtin_type = {
44 #ifdef AO_SCHEME_MAKE_CONST
46 #define AO_SCHEME_BUILTIN_CASENAME
47 #include "ao_scheme_builtin.h"
49 char *ao_scheme_args_name(uint8_t args) {
50 args &= AO_SCHEME_FUNC_MASK;
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 "???";
60 #define AO_SCHEME_BUILTIN_ARRAYNAME
61 #include "ao_scheme_builtin.h"
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;
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,
77 ao_scheme_args_name(uint8_t args)
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;
87 ao_scheme_builtin_write(ao_poly b)
89 struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b);
90 printf("%s", ao_scheme_builtin_name(builtin->func));
94 ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max)
98 while (cons && argc <= max) {
100 cons = ao_scheme_cons_cdr(cons);
102 if (argc < min || argc > max)
103 return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name);
104 return _ao_scheme_bool_true;
108 ao_scheme_arg(struct ao_scheme_cons *cons, int argc)
111 return AO_SCHEME_NIL;
114 return AO_SCHEME_NIL;
115 cons = ao_scheme_cons_cdr(cons);
121 ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok)
123 ao_poly car = ao_scheme_arg(cons, argc);
125 if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type)
126 return ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car);
127 return _ao_scheme_bool_true;
131 ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc)
133 ao_poly p = ao_scheme_arg(cons, argc);
134 int32_t i = ao_scheme_poly_integer(p);
136 if (i == AO_SCHEME_NOT_INTEGER)
137 (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p);
142 ao_scheme_do_car(struct ao_scheme_cons *cons)
144 if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1))
145 return AO_SCHEME_NIL;
146 if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0))
147 return AO_SCHEME_NIL;
148 return ao_scheme_poly_cons(cons->car)->car;
152 ao_scheme_do_cdr(struct ao_scheme_cons *cons)
154 if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1))
155 return AO_SCHEME_NIL;
156 if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0))
157 return AO_SCHEME_NIL;
158 return ao_scheme_poly_cons(cons->car)->cdr;
162 ao_scheme_do_cons(struct ao_scheme_cons *cons)
165 if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2))
166 return AO_SCHEME_NIL;
167 car = ao_scheme_arg(cons, 0);
168 cdr = ao_scheme_arg(cons, 1);
169 return ao_scheme__cons(car, cdr);
173 ao_scheme_do_last(struct ao_scheme_cons *cons)
175 struct ao_scheme_cons *list;
176 if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1))
177 return AO_SCHEME_NIL;
178 if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1))
179 return AO_SCHEME_NIL;
180 for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0));
182 list = ao_scheme_cons_cdr(list))
187 return AO_SCHEME_NIL;
191 ao_scheme_do_length(struct ao_scheme_cons *cons)
193 if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1))
194 return AO_SCHEME_NIL;
195 if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1))
196 return AO_SCHEME_NIL;
197 return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))));
201 ao_scheme_do_quote(struct ao_scheme_cons *cons)
203 if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1))
204 return AO_SCHEME_NIL;
205 return ao_scheme_arg(cons, 0);
209 ao_scheme_do_set(struct ao_scheme_cons *cons)
211 if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2))
212 return AO_SCHEME_NIL;
213 if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0))
214 return AO_SCHEME_NIL;
216 return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
220 ao_scheme_do_def(struct ao_scheme_cons *cons)
222 if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2))
223 return AO_SCHEME_NIL;
224 if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0))
225 return AO_SCHEME_NIL;
227 return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
231 ao_scheme_do_setq(struct ao_scheme_cons *cons)
234 if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2))
235 return AO_SCHEME_NIL;
237 if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM)
238 return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name);
239 if (!ao_scheme_atom_ref(name, NULL))
240 return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name);
241 return ao_scheme__cons(_ao_scheme_atom_set,
242 ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote,
243 ao_scheme__cons(name, AO_SCHEME_NIL)),
248 ao_scheme_do_cond(struct ao_scheme_cons *cons)
250 ao_scheme_set_cond(cons);
251 return AO_SCHEME_NIL;
255 ao_scheme_do_begin(struct ao_scheme_cons *cons)
257 ao_scheme_stack->state = eval_begin;
258 ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons);
259 return AO_SCHEME_NIL;
263 ao_scheme_do_while(struct ao_scheme_cons *cons)
265 ao_scheme_stack->state = eval_while;
266 ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons);
267 return AO_SCHEME_NIL;
271 ao_scheme_do_write(struct ao_scheme_cons *cons)
273 ao_poly val = AO_SCHEME_NIL;
276 ao_scheme_poly_write(val);
277 cons = ao_scheme_cons_cdr(cons);
281 return _ao_scheme_bool_true;
285 ao_scheme_do_display(struct ao_scheme_cons *cons)
287 ao_poly val = AO_SCHEME_NIL;
290 ao_scheme_poly_display(val);
291 cons = ao_scheme_cons_cdr(cons);
293 return _ao_scheme_bool_true;
297 ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op)
299 struct ao_scheme_cons *cons = cons;
300 ao_poly ret = AO_SCHEME_NIL;
302 for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) {
303 ao_poly car = cons->car;
304 uint8_t rt = ao_scheme_poly_type(ret);
305 uint8_t ct = ao_scheme_poly_type(car);
307 if (cons == orig_cons) {
309 if (cons->cdr == AO_SCHEME_NIL) {
312 if (ao_scheme_integer_typep(ct))
313 ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret));
314 else if (ct == AO_SCHEME_FLOAT)
315 ret = ao_scheme_float_get(-ao_scheme_poly_number(ret));
318 if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1)
320 else if (ao_scheme_number_typep(ct)) {
321 float v = ao_scheme_poly_number(ret);
322 ret = ao_scheme_float_get(1/v);
329 } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) {
330 int32_t r = ao_scheme_poly_integer(ret);
331 int32_t c = ao_scheme_poly_integer(car);
338 if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r)
346 t = (int64_t) r * (int64_t) c;
347 if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t)
352 if (c != 0 && (r % c) == 0)
357 case builtin_quotient:
359 return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero");
360 if (r % c != 0 && (c < 0) != (r < 0))
365 case builtin_remainder:
367 return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero");
372 return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero");
374 if ((r < 0) != (c < 0))
380 ret = ao_scheme_integer_poly(r);
381 } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) {
384 r = ao_scheme_poly_number(ret);
385 c = ao_scheme_poly_number(car);
399 case builtin_quotient:
400 case builtin_remainder:
402 return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide");
406 ret = ao_scheme_float_get(r);
409 else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus)
410 ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret),
411 ao_scheme_poly_string(car)));
413 return ao_scheme_error(AO_SCHEME_INVALID, "invalid args");
419 ao_scheme_do_plus(struct ao_scheme_cons *cons)
421 return ao_scheme_math(cons, builtin_plus);
425 ao_scheme_do_minus(struct ao_scheme_cons *cons)
427 return ao_scheme_math(cons, builtin_minus);
431 ao_scheme_do_times(struct ao_scheme_cons *cons)
433 return ao_scheme_math(cons, builtin_times);
437 ao_scheme_do_divide(struct ao_scheme_cons *cons)
439 return ao_scheme_math(cons, builtin_divide);
443 ao_scheme_do_quotient(struct ao_scheme_cons *cons)
445 return ao_scheme_math(cons, builtin_quotient);
449 ao_scheme_do_modulo(struct ao_scheme_cons *cons)
451 return ao_scheme_math(cons, builtin_modulo);
455 ao_scheme_do_remainder(struct ao_scheme_cons *cons)
457 return ao_scheme_math(cons, builtin_remainder);
461 ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op)
466 return _ao_scheme_bool_true;
469 for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) {
470 ao_poly right = cons->car;
472 if (op == builtin_equal) {
474 return _ao_scheme_bool_false;
476 uint8_t lt = ao_scheme_poly_type(left);
477 uint8_t rt = ao_scheme_poly_type(right);
478 if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) {
479 int32_t l = ao_scheme_poly_integer(left);
480 int32_t r = ao_scheme_poly_integer(right);
485 return _ao_scheme_bool_false;
487 case builtin_greater:
489 return _ao_scheme_bool_false;
491 case builtin_less_equal:
493 return _ao_scheme_bool_false;
495 case builtin_greater_equal:
497 return _ao_scheme_bool_false;
502 } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) {
503 int c = strcmp(ao_scheme_poly_string(left),
504 ao_scheme_poly_string(right));
508 return _ao_scheme_bool_false;
510 case builtin_greater:
512 return _ao_scheme_bool_false;
514 case builtin_less_equal:
516 return _ao_scheme_bool_false;
518 case builtin_greater_equal:
520 return _ao_scheme_bool_false;
529 return _ao_scheme_bool_true;
533 ao_scheme_do_equal(struct ao_scheme_cons *cons)
535 return ao_scheme_compare(cons, builtin_equal);
539 ao_scheme_do_less(struct ao_scheme_cons *cons)
541 return ao_scheme_compare(cons, builtin_less);
545 ao_scheme_do_greater(struct ao_scheme_cons *cons)
547 return ao_scheme_compare(cons, builtin_greater);
551 ao_scheme_do_less_equal(struct ao_scheme_cons *cons)
553 return ao_scheme_compare(cons, builtin_less_equal);
557 ao_scheme_do_greater_equal(struct ao_scheme_cons *cons)
559 return ao_scheme_compare(cons, builtin_greater_equal);
563 ao_scheme_do_list_to_string(struct ao_scheme_cons *cons)
565 if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1))
566 return AO_SCHEME_NIL;
567 if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1))
568 return AO_SCHEME_NIL;
569 return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)));
573 ao_scheme_do_string_to_list(struct ao_scheme_cons *cons)
575 if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1))
576 return AO_SCHEME_NIL;
577 if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0))
578 return AO_SCHEME_NIL;
579 return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0)));
583 ao_scheme_do_string_ref(struct ao_scheme_cons *cons)
587 if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2))
588 return AO_SCHEME_NIL;
589 if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0))
590 return AO_SCHEME_NIL;
591 ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1);
592 if (ref == AO_SCHEME_NOT_INTEGER)
593 return AO_SCHEME_NIL;
594 string = ao_scheme_poly_string(ao_scheme_arg(cons, 0));
595 while (*string && ref) {
600 return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
601 _ao_scheme_atom_string2dref,
602 ao_scheme_arg(cons, 0),
603 ao_scheme_arg(cons, 1));
604 return ao_scheme_int_poly(*string);
608 ao_scheme_do_string_length(struct ao_scheme_cons *cons)
612 if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1))
613 return AO_SCHEME_NIL;
614 if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0))
615 return AO_SCHEME_NIL;
616 string = ao_scheme_poly_string(ao_scheme_arg(cons, 0));
617 return ao_scheme_integer_poly(strlen(string));
621 ao_scheme_do_string_copy(struct ao_scheme_cons *cons)
625 if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1))
626 return AO_SCHEME_NIL;
627 if (!ao_scheme_check_argt(_ao_scheme_atom_string2dcopy, cons, 0, AO_SCHEME_STRING, 0))
628 return AO_SCHEME_NIL;
629 string = ao_scheme_poly_string(ao_scheme_arg(cons, 0));
630 return ao_scheme_string_poly(ao_scheme_string_copy(string));
634 ao_scheme_do_string_set(struct ao_scheme_cons *cons)
640 if (!ao_scheme_check_argc(_ao_scheme_atom_string2dset21, cons, 3, 3))
641 return AO_SCHEME_NIL;
642 if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0))
643 return AO_SCHEME_NIL;
644 string = ao_scheme_poly_string(ao_scheme_arg(cons, 0));
645 ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1);
646 if (ref == AO_SCHEME_NOT_INTEGER)
647 return AO_SCHEME_NIL;
648 val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2);
649 if (val == AO_SCHEME_NOT_INTEGER)
650 return AO_SCHEME_NIL;
651 while (*string && ref) {
656 return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid",
657 _ao_scheme_atom_string2dset21,
658 ao_scheme_arg(cons, 0),
659 ao_scheme_arg(cons, 1));
661 return ao_scheme_int_poly(*string);
665 ao_scheme_do_flush_output(struct ao_scheme_cons *cons)
667 if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0))
668 return AO_SCHEME_NIL;
669 ao_scheme_os_flush();
670 return _ao_scheme_bool_true;
674 ao_scheme_do_led(struct ao_scheme_cons *cons)
677 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
678 return AO_SCHEME_NIL;
679 led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0);
680 if (led == AO_SCHEME_NOT_INTEGER)
681 return AO_SCHEME_NIL;
682 led = ao_scheme_arg(cons, 0);
683 ao_scheme_os_led(ao_scheme_poly_int(led));
688 ao_scheme_do_delay(struct ao_scheme_cons *cons)
692 if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1))
693 return AO_SCHEME_NIL;
694 delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0);
695 if (delay == AO_SCHEME_NOT_INTEGER)
696 return AO_SCHEME_NIL;
697 ao_scheme_os_delay(delay);
702 ao_scheme_do_eval(struct ao_scheme_cons *cons)
704 if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1))
705 return AO_SCHEME_NIL;
706 ao_scheme_stack->state = eval_sexpr;
711 ao_scheme_do_apply(struct ao_scheme_cons *cons)
713 if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX))
714 return AO_SCHEME_NIL;
715 ao_scheme_stack->state = eval_apply;
716 return ao_scheme_cons_poly(cons);
720 ao_scheme_do_read(struct ao_scheme_cons *cons)
722 if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0))
723 return AO_SCHEME_NIL;
724 return ao_scheme_read();
728 ao_scheme_do_collect(struct ao_scheme_cons *cons)
732 free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL);
733 return ao_scheme_integer_poly(free);
737 ao_scheme_do_nullp(struct ao_scheme_cons *cons)
739 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
740 return AO_SCHEME_NIL;
741 if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL)
742 return _ao_scheme_bool_true;
744 return _ao_scheme_bool_false;
748 ao_scheme_do_not(struct ao_scheme_cons *cons)
750 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
751 return AO_SCHEME_NIL;
752 if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false)
753 return _ao_scheme_bool_true;
755 return _ao_scheme_bool_false;
759 ao_scheme_do_typep(int type, struct ao_scheme_cons *cons)
761 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
762 return AO_SCHEME_NIL;
763 if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type)
764 return _ao_scheme_bool_true;
765 return _ao_scheme_bool_false;
769 ao_scheme_do_pairp(struct ao_scheme_cons *cons)
772 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
773 return AO_SCHEME_NIL;
774 v = ao_scheme_arg(cons, 0);
775 if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS)
776 return _ao_scheme_bool_true;
777 return _ao_scheme_bool_false;
781 ao_scheme_do_integerp(struct ao_scheme_cons *cons)
783 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
784 return AO_SCHEME_NIL;
785 switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
787 case AO_SCHEME_BIGINT:
788 return _ao_scheme_bool_true;
790 return _ao_scheme_bool_false;
795 ao_scheme_do_numberp(struct ao_scheme_cons *cons)
797 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
798 return AO_SCHEME_NIL;
799 switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
801 case AO_SCHEME_BIGINT:
802 case AO_SCHEME_FLOAT:
803 return _ao_scheme_bool_true;
805 return _ao_scheme_bool_false;
810 ao_scheme_do_stringp(struct ao_scheme_cons *cons)
812 return ao_scheme_do_typep(AO_SCHEME_STRING, cons);
816 ao_scheme_do_symbolp(struct ao_scheme_cons *cons)
818 return ao_scheme_do_typep(AO_SCHEME_ATOM, cons);
822 ao_scheme_do_booleanp(struct ao_scheme_cons *cons)
824 return ao_scheme_do_typep(AO_SCHEME_BOOL, cons);
828 ao_scheme_do_procedurep(struct ao_scheme_cons *cons)
830 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
831 return AO_SCHEME_NIL;
832 switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) {
833 case AO_SCHEME_BUILTIN:
834 case AO_SCHEME_LAMBDA:
835 return _ao_scheme_bool_true;
837 return _ao_scheme_bool_false;
841 /* This one is special -- a list is either nil or
842 * a 'proper' list with only cons cells
845 ao_scheme_do_listp(struct ao_scheme_cons *cons)
848 if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1))
849 return AO_SCHEME_NIL;
850 v = ao_scheme_arg(cons, 0);
852 if (v == AO_SCHEME_NIL)
853 return _ao_scheme_bool_true;
854 if (ao_scheme_poly_type(v) != AO_SCHEME_CONS)
855 return _ao_scheme_bool_false;
856 v = ao_scheme_poly_cons(v)->cdr;
861 ao_scheme_do_set_car(struct ao_scheme_cons *cons)
863 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
864 return AO_SCHEME_NIL;
865 if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
866 return AO_SCHEME_NIL;
867 return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1);
871 ao_scheme_do_set_cdr(struct ao_scheme_cons *cons)
873 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2))
874 return AO_SCHEME_NIL;
875 if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0))
876 return AO_SCHEME_NIL;
877 return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1);
881 ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons)
883 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
884 return AO_SCHEME_NIL;
885 if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0))
886 return AO_SCHEME_NIL;
887 return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name));
891 ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons)
893 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
894 return AO_SCHEME_NIL;
895 if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0))
896 return AO_SCHEME_NIL;
898 return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));
902 ao_scheme_do_read_char(struct ao_scheme_cons *cons)
905 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
906 return AO_SCHEME_NIL;
908 return ao_scheme_int_poly(c);
912 ao_scheme_do_write_char(struct ao_scheme_cons *cons)
914 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1))
915 return AO_SCHEME_NIL;
916 if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0))
917 return AO_SCHEME_NIL;
918 putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0)));
919 return _ao_scheme_bool_true;
923 ao_scheme_do_exit(struct ao_scheme_cons *cons)
925 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
926 return AO_SCHEME_NIL;
927 ao_scheme_exception |= AO_SCHEME_EXIT;
928 return _ao_scheme_bool_true;
932 ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons)
936 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
937 return AO_SCHEME_NIL;
938 jiffy = ao_scheme_os_jiffy();
939 return (ao_scheme_int_poly(jiffy));
943 ao_scheme_do_current_second(struct ao_scheme_cons *cons)
947 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
948 return AO_SCHEME_NIL;
949 second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND;
950 return (ao_scheme_int_poly(second));
954 ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons)
956 if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0))
957 return AO_SCHEME_NIL;
958 return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND));
962 ao_scheme_do_vector(struct ao_scheme_cons *cons)
964 return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons));
968 ao_scheme_do_make_vector(struct ao_scheme_cons *cons)
972 if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2))
973 return AO_SCHEME_NIL;
974 k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0);
975 if (k == AO_SCHEME_NOT_INTEGER)
976 return AO_SCHEME_NIL;
977 return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1)));
981 ao_scheme_do_vector_ref(struct ao_scheme_cons *cons)
983 if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2))
984 return AO_SCHEME_NIL;
985 if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0))
986 return AO_SCHEME_NIL;
987 return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1));
991 ao_scheme_do_vector_set(struct ao_scheme_cons *cons)
993 if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3))
994 return AO_SCHEME_NIL;
995 if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0))
996 return AO_SCHEME_NIL;
997 return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2));
1001 ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons)
1003 if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1))
1004 return AO_SCHEME_NIL;
1005 if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0))
1006 return AO_SCHEME_NIL;
1007 return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))));
1011 ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons)
1013 if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1))
1014 return AO_SCHEME_NIL;
1015 if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0))
1016 return AO_SCHEME_NIL;
1017 return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))));
1021 ao_scheme_do_vector_length(struct ao_scheme_cons *cons)
1023 if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1))
1024 return AO_SCHEME_NIL;
1025 if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0))
1026 return AO_SCHEME_NIL;
1027 return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length);
1031 ao_scheme_do_vectorp(struct ao_scheme_cons *cons)
1033 return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons);
1036 #define AO_SCHEME_BUILTIN_FUNCS
1037 #include "ao_scheme_builtin.h"