diff --git a/.gitignore b/.gitignore index c6869174..55b00357 100644 --- a/.gitignore +++ b/.gitignore @@ -76,8 +76,30 @@ /scaffold/tests/x86-mes-* /scaffold/tests/[0-9a][0-9a-z]-[^.]* -/src/*.h -/src/*.i +/src/mes.mes.symbols.h +/src/gc.mes.h +/src/hash.mes.h +/src/lib.mes.h +/src/math.mes.h +/src/mes.mes.h +/src/module.mes.h +/src/posix.mes.h +/src/reader.mes.h +/src/strings.mes.h +/src/struct.mes.h +/src/vector.mes.h +/src/gc.mes.i +/src/hash.mes.i +/src/lib.mes.i +/src/math.mes.i +/src/mes.mes.i +/src/module.mes.i +/src/posix.mes.i +/src/reader.mes.i +/src/strings.mes.i +/src/struct.mes.i +/src/vector.mes.i + /src/mes /src/x86-mes-mes /src/x86_64-mes-mes diff --git a/build-aux/bootstrap.sh.in b/build-aux/bootstrap.sh.in index 6ec12e87..ca1ece6f 100644 --- a/build-aux/bootstrap.sh.in +++ b/build-aux/bootstrap.sh.in @@ -10,18 +10,6 @@ MES_ARENA=${MES_ARENA-100000000} MES_MAX_ARENA=${MES_MAX_ARENA-100000000} MES_STACK=${MES_STACK-500000} -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/gc.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/hash.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/lib.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/math.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/mes.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/module.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/posix.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/reader.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/strings.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/struct.c -@GUILE@ -e '(mes-snarf)' build-aux/mes-snarf.scm --mes src/vector.c - hex2 --LittleEndian --Architecture 1 --BaseAddress 0x1000000 -f lib/x86-mes/elf32-0header.hex2 -f lib/x86-mes/elf32-body-exit-42.hex2 -f lib/x86-mes/elf-0footer.hex2 --exec_enable -o lib/x86-mes/0exit-42 hex2 --LittleEndian --Architecture 1 --BaseAddress 0x1000000 -f lib/x86-mes/elf32-header.hex2 -f lib/x86-mes/elf32-body-exit-42.hex2 -f lib/x86-mes/elf32-footer-single-main.hex2 --exec_enable -o lib/x86-mes/exit-42 M1 --LittleEndian --Architecture 1 -f lib/x86-mes/x86.M1 -f @MES_SEED@/x86-mes/crt1.S -o lib/x86-mes/crt1.o diff --git a/build-aux/build.sh.in b/build-aux/build.sh.in index ceb4d78a..68727d30 100644 --- a/build-aux/build.sh.in +++ b/build-aux/build.sh.in @@ -27,13 +27,6 @@ if [ -n "$GUILE" -a "$GUILE" != true ]; then sh ${srcdest}build-aux/build-guile.sh fi -if [ ! "$mes_p" ]; then - sh ${srcdest}build-aux/snarf.sh -#elif [ ! -d "$MES_SEED" ]; then -#else -fi -sh ${srcdest}build-aux/snarf.sh --mes - if [ "$gcc_p$tcc_p" ]; then sh ${srcdest}build-aux/build-mes.sh elif [ -d "$MES_SEED" ]; then diff --git a/build-aux/snarf.sh b/build-aux/snarf.sh index 07f8f78d..7f544a11 100755 --- a/build-aux/snarf.sh +++ b/build-aux/snarf.sh @@ -23,18 +23,14 @@ set -e . ${srcdest}build-aux/config.sh . ${srcdest}build-aux/trace.sh -snarf=" " -if [ -n "$1" ]; then - snarf=.mes -fi -trace "SNARF$snarf gc.c" ${srcdest}build-aux/mes-snarf.scm $1 src/gc.c -trace "SNARF$snarf hash.c" ${srcdest}build-aux/mes-snarf.scm $1 src/hash.c -trace "SNARF$snarf lib.c" ${srcdest}build-aux/mes-snarf.scm $1 src/lib.c -trace "SNARF$snarf math.c" ${srcdest}build-aux/mes-snarf.scm $1 src/math.c -trace "SNARF$snarf mes.c" ${srcdest}build-aux/mes-snarf.scm $1 src/mes.c -trace "SNARF$snarf module.c" ${srcdest}build-aux/mes-snarf.scm $1 src/module.c -trace "SNARF$snarf posix.c" ${srcdest}build-aux/mes-snarf.scm $1 src/posix.c -trace "SNARF$snarf reader.c" ${srcdest}build-aux/mes-snarf.scm $1 src/reader.c -trace "SNARF$snarf strings.c" ${srcdest}build-aux/mes-snarf.scm $1 src/strings.c -trace "SNARF$snarf struct.c" ${srcdest}build-aux/mes-snarf.scm $1 src/struct.c -trace "SNARF$snarf vector.c" ${srcdest}build-aux/mes-snarf.scm $1 src/vector.c +trace "SNARF$snarf gc.c" ${srcdest}build-aux/mes-snarf.scm src/gc.c +trace "SNARF$snarf hash.c" ${srcdest}build-aux/mes-snarf.scm src/hash.c +trace "SNARF$snarf lib.c" ${srcdest}build-aux/mes-snarf.scm src/lib.c +trace "SNARF$snarf math.c" ${srcdest}build-aux/mes-snarf.scm src/math.c +trace "SNARF$snarf mes.c" ${srcdest}build-aux/mes-snarf.scm src/mes.c +trace "SNARF$snarf module.c" ${srcdest}build-aux/mes-snarf.scm src/module.c +trace "SNARF$snarf posix.c" ${srcdest}build-aux/mes-snarf.scm src/posix.c +trace "SNARF$snarf reader.c" ${srcdest}build-aux/mes-snarf.scm src/reader.c +trace "SNARF$snarf strings.c" ${srcdest}build-aux/mes-snarf.scm src/strings.c +trace "SNARF$snarf struct.c" ${srcdest}build-aux/mes-snarf.scm src/struct.c +trace "SNARF$snarf vector.c" ${srcdest}build-aux/mes-snarf.scm src/vector.c diff --git a/mes/module/mes/display.mes b/mes/module/mes/display.mes index 71a1fb0e..6d3f59d8 100644 --- a/mes/module/mes/display.mes +++ b/mes/module/mes/display.mes @@ -148,13 +148,30 @@ (if (keyword? x) (display "#:" port)) (for-each (display-cut2 display-char <> port write?) (string->list x)) (if (and (string? x) write?) (write-char #\" port))) + ((builtin? x) + (display "#" port)) ((struct? x) - (display "#<" port) - (for-each (lambda (i) - (let ((x (struct-ref x i))) - (d x #f (if (= i 0) "" " ")))) - (iota (struct-length x))) - (display ")" port)) + (let* ((printer (struct-ref x 1))) + (if (or (builtin? printer) (closure? printer)) + (printer x) + (begin + (display "#<" port) + (for-each (lambda (i) + (let ((x (struct-ref x i))) + (d x #f (if (= i 0) "" " ")))) + (iota (struct-length x))) + (display ")" port))))) ((vector? x) (display "#(" port) (for-each (lambda (i) @@ -166,19 +183,6 @@ (d x #f (if (= i 0) "" " "))))) (iota (vector-length x))) (display ")" port)) - ((function? x) - (display "#" port)) ((broken-heart? x) (display "<3" port)) (#t diff --git a/mes/module/mes/type-0.mes b/mes/module/mes/type-0.mes index e81868fd..e01e6e50 100644 --- a/mes/module/mes/type-0.mes +++ b/mes/module/mes/type-0.mes @@ -30,7 +30,6 @@ (cons (quote )) (cons (quote )) (cons (quote )) - (cons (quote )) (cons (quote )) (cons (quote )) (cons (quote )) @@ -65,11 +64,6 @@ (define (continuation? x) (eq? (core:type x) )) -(define (function? x) - (eq? (core:type x) )) - -(define builtin? function?) - (define (keyword? x) (eq? (core:type x) )) diff --git a/src/builtins.h b/src/builtins.h new file mode 100644 index 00000000..cfd0b92d --- /dev/null +++ b/src/builtins.h @@ -0,0 +1,391 @@ +// src/gc.mes +SCM gc_check (); +SCM gc (); +// src/hash.mes +SCM hashq (SCM x, SCM size); +SCM hash (SCM x, SCM size); +SCM hashq_get_handle (SCM table, SCM key, SCM dflt); +SCM hashq_ref (SCM table, SCM key, SCM dflt); +SCM hash_ref (SCM table, SCM key, SCM dflt); +SCM hashq_set_x (SCM table, SCM key, SCM value); +SCM hash_set_x (SCM table, SCM key, SCM value); +SCM hash_table_printer (SCM table); +SCM make_hash_table (SCM x); +// src/lib.mes +SCM procedure_name_ (SCM x); +SCM display_ (SCM x); +SCM display_error_ (SCM x); +SCM display_port_ (SCM x, SCM p); +SCM write_ (SCM x); +SCM write_error_ (SCM x); +SCM write_port_ (SCM x, SCM p); +SCM exit_ (SCM x); +SCM frame_printer (SCM frame); +SCM make_stack (SCM stack); +SCM stack_length (SCM stack); +SCM stack_ref (SCM stack, SCM index); +SCM xassq (SCM x, SCM a); +SCM memq (SCM x, SCM a); +SCM equal2_p (SCM a, SCM b); +SCM last_pair (SCM x); +SCM pair_p (SCM x); +// src/math.mes +SCM greater_p (SCM x); +SCM less_p (SCM x); +SCM is_p (SCM x); +SCM minus (SCM x); +SCM plus (SCM x); +SCM divide (SCM x); +SCM modulo (SCM a, SCM b); +SCM multiply (SCM x); +SCM logand (SCM x); +SCM logior (SCM x); +SCM lognot (SCM x); +SCM logxor (SCM x); +SCM ash (SCM n, SCM count); +// src/mes.mes +SCM make_cell_ (SCM type, SCM car, SCM cdr); +SCM type_ (SCM x); +SCM car_ (SCM x); +SCM cdr_ (SCM x); +SCM arity_ (SCM x); +SCM cons (SCM x, SCM y); +SCM car (SCM x); +SCM cdr (SCM x); +SCM list (SCM x); +SCM null_p (SCM x); +SCM eq_p (SCM x, SCM y); +SCM values (SCM x); +SCM acons (SCM key, SCM value, SCM alist); +SCM length (SCM x); +SCM error (SCM key, SCM x); +SCM append2 (SCM x, SCM y); +SCM append_reverse (SCM x, SCM y); +SCM reverse_x_ (SCM x, SCM t); +SCM pairlis (SCM x, SCM y, SCM a); +SCM call (SCM fn, SCM x); +SCM assq (SCM x, SCM a); +SCM assoc (SCM x, SCM a); +SCM set_car_x (SCM x, SCM e); +SCM set_cdr_x (SCM x, SCM e); +SCM set_env_x (SCM x, SCM e, SCM a); +SCM macro_get_handle (SCM name); +SCM add_formals (SCM formals, SCM x); +SCM eval_apply (); +SCM make_builtin_type (); +SCM make_builtin (SCM builtin_type, SCM name, SCM arity, SCM function); +SCM builtin_arity (SCM builtin); +SCM builtin_p (SCM x); +SCM builtin_printer (SCM builtin); +// CONSTANT cell_nil 1 +#define cell_nil 1 +// CONSTANT cell_f 2 +#define cell_f 2 +// CONSTANT cell_t 3 +#define cell_t 3 +// CONSTANT cell_dot 4 +#define cell_dot 4 +// CONSTANT cell_arrow 5 +#define cell_arrow 5 +// CONSTANT cell_undefined 6 +#define cell_undefined 6 +// CONSTANT cell_unspecified 7 +#define cell_unspecified 7 +// CONSTANT cell_closure 8 +#define cell_closure 8 +// CONSTANT cell_circular 9 +#define cell_circular 9 +// CONSTANT cell_begin 10 +#define cell_begin 10 +// CONSTANT cell_call_with_current_continuation 11 +#define cell_call_with_current_continuation 11 +// CONSTANT cell_vm_apply 12 +#define cell_vm_apply 12 +// CONSTANT cell_vm_apply2 13 +#define cell_vm_apply2 13 +// CONSTANT cell_vm_begin 14 +#define cell_vm_begin 14 +// CONSTANT cell_vm_begin_eval 15 +#define cell_vm_begin_eval 15 +// CONSTANT cell_vm_begin_expand 16 +#define cell_vm_begin_expand 16 +// CONSTANT cell_vm_begin_expand_eval 17 +#define cell_vm_begin_expand_eval 17 +// CONSTANT cell_vm_begin_expand_macro 18 +#define cell_vm_begin_expand_macro 18 +// CONSTANT cell_vm_begin_expand_primitive_load 19 +#define cell_vm_begin_expand_primitive_load 19 +// CONSTANT cell_vm_begin_primitive_load 20 +#define cell_vm_begin_primitive_load 20 +// CONSTANT cell_vm_begin_read_input_file 21 +#define cell_vm_begin_read_input_file 21 +// CONSTANT cell_vm_call_with_current_continuation2 22 +#define cell_vm_call_with_current_continuation2 22 +// CONSTANT cell_vm_call_with_values2 23 +#define cell_vm_call_with_values2 23 +// CONSTANT cell_vm_eval 24 +#define cell_vm_eval 24 +// CONSTANT cell_vm_eval2 25 +#define cell_vm_eval2 25 +// CONSTANT cell_vm_eval_check_func 26 +#define cell_vm_eval_check_func 26 +// CONSTANT cell_vm_eval_define 27 +#define cell_vm_eval_define 27 +// CONSTANT cell_vm_eval_macro_expand_eval 28 +#define cell_vm_eval_macro_expand_eval 28 +// CONSTANT cell_vm_eval_macro_expand_expand 29 +#define cell_vm_eval_macro_expand_expand 29 +// CONSTANT cell_vm_eval_pmatch_car 30 +#define cell_vm_eval_pmatch_car 30 +// CONSTANT cell_vm_eval_pmatch_cdr 31 +#define cell_vm_eval_pmatch_cdr 31 +// CONSTANT cell_vm_eval_set_x 32 +#define cell_vm_eval_set_x 32 +// CONSTANT cell_vm_evlis 33 +#define cell_vm_evlis 33 +// CONSTANT cell_vm_evlis2 34 +#define cell_vm_evlis2 34 +// CONSTANT cell_vm_evlis3 35 +#define cell_vm_evlis3 35 +// CONSTANT cell_vm_if 36 +#define cell_vm_if 36 +// CONSTANT cell_vm_if_expr 37 +#define cell_vm_if_expr 37 +// CONSTANT cell_vm_macro_expand 38 +#define cell_vm_macro_expand 38 +// CONSTANT cell_vm_macro_expand_car 39 +#define cell_vm_macro_expand_car 39 +// CONSTANT cell_vm_macro_expand_cdr 40 +#define cell_vm_macro_expand_cdr 40 +// CONSTANT cell_vm_macro_expand_define 41 +#define cell_vm_macro_expand_define 41 +// CONSTANT cell_vm_macro_expand_define_macro 42 +#define cell_vm_macro_expand_define_macro 42 +// CONSTANT cell_vm_macro_expand_lambda 43 +#define cell_vm_macro_expand_lambda 43 +// CONSTANT cell_vm_macro_expand_set_x 44 +#define cell_vm_macro_expand_set_x 44 +// CONSTANT cell_vm_return 45 +#define cell_vm_return 45 +// CONSTANT cell_symbol_dot 46 +#define cell_symbol_dot 46 +// CONSTANT cell_symbol_lambda 47 +#define cell_symbol_lambda 47 +// CONSTANT cell_symbol_begin 48 +#define cell_symbol_begin 48 +// CONSTANT cell_symbol_if 49 +#define cell_symbol_if 49 +// CONSTANT cell_symbol_quote 50 +#define cell_symbol_quote 50 +// CONSTANT cell_symbol_define 51 +#define cell_symbol_define 51 +// CONSTANT cell_symbol_define_macro 52 +#define cell_symbol_define_macro 52 +// CONSTANT cell_symbol_quasiquote 53 +#define cell_symbol_quasiquote 53 +// CONSTANT cell_symbol_unquote 54 +#define cell_symbol_unquote 54 +// CONSTANT cell_symbol_unquote_splicing 55 +#define cell_symbol_unquote_splicing 55 +// CONSTANT cell_symbol_syntax 56 +#define cell_symbol_syntax 56 +// CONSTANT cell_symbol_quasisyntax 57 +#define cell_symbol_quasisyntax 57 +// CONSTANT cell_symbol_unsyntax 58 +#define cell_symbol_unsyntax 58 +// CONSTANT cell_symbol_unsyntax_splicing 59 +#define cell_symbol_unsyntax_splicing 59 +// CONSTANT cell_symbol_set_x 60 +#define cell_symbol_set_x 60 +// CONSTANT cell_symbol_sc_expand 61 +#define cell_symbol_sc_expand 61 +// CONSTANT cell_symbol_macro_expand 62 +#define cell_symbol_macro_expand 62 +// CONSTANT cell_symbol_portable_macro_expand 63 +#define cell_symbol_portable_macro_expand 63 +// CONSTANT cell_symbol_sc_expander_alist 64 +#define cell_symbol_sc_expander_alist 64 +// CONSTANT cell_symbol_call_with_values 65 +#define cell_symbol_call_with_values 65 +// CONSTANT cell_symbol_call_with_current_continuation 66 +#define cell_symbol_call_with_current_continuation 66 +// CONSTANT cell_symbol_boot_module 67 +#define cell_symbol_boot_module 67 +// CONSTANT cell_symbol_current_module 68 +#define cell_symbol_current_module 68 +// CONSTANT cell_symbol_primitive_load 69 +#define cell_symbol_primitive_load 69 +// CONSTANT cell_symbol_read_input_file 70 +#define cell_symbol_read_input_file 70 +// CONSTANT cell_symbol_write 71 +#define cell_symbol_write 71 +// CONSTANT cell_symbol_display 72 +#define cell_symbol_display 72 +// CONSTANT cell_symbol_car 73 +#define cell_symbol_car 73 +// CONSTANT cell_symbol_cdr 74 +#define cell_symbol_cdr 74 +// CONSTANT cell_symbol_not_a_number 75 +#define cell_symbol_not_a_number 75 +// CONSTANT cell_symbol_not_a_pair 76 +#define cell_symbol_not_a_pair 76 +// CONSTANT cell_symbol_system_error 77 +#define cell_symbol_system_error 77 +// CONSTANT cell_symbol_throw 78 +#define cell_symbol_throw 78 +// CONSTANT cell_symbol_unbound_variable 79 +#define cell_symbol_unbound_variable 79 +// CONSTANT cell_symbol_wrong_number_of_args 80 +#define cell_symbol_wrong_number_of_args 80 +// CONSTANT cell_symbol_wrong_type_arg 81 +#define cell_symbol_wrong_type_arg 81 +// CONSTANT cell_symbol_buckets 82 +#define cell_symbol_buckets 82 +// CONSTANT cell_symbol_builtin 83 +#define cell_symbol_builtin 83 +// CONSTANT cell_symbol_frame 84 +#define cell_symbol_frame 84 +// CONSTANT cell_symbol_hashq_table 85 +#define cell_symbol_hashq_table 85 +// CONSTANT cell_symbol_module 86 +#define cell_symbol_module 86 +// CONSTANT cell_symbol_procedure 87 +#define cell_symbol_procedure 87 +// CONSTANT cell_symbol_record_type 88 +#define cell_symbol_record_type 88 +// CONSTANT cell_symbol_size 89 +#define cell_symbol_size 89 +// CONSTANT cell_symbol_stack 90 +#define cell_symbol_stack 90 +// CONSTANT cell_symbol_argv 91 +#define cell_symbol_argv 91 +// CONSTANT cell_symbol_mes_prefix 92 +#define cell_symbol_mes_prefix 92 +// CONSTANT cell_symbol_mes_version 93 +#define cell_symbol_mes_version 93 +// CONSTANT cell_symbol_internal_time_units_per_second 94 +#define cell_symbol_internal_time_units_per_second 94 +// CONSTANT cell_symbol_compiler 95 +#define cell_symbol_compiler 95 +// CONSTANT cell_symbol_arch 96 +#define cell_symbol_arch 96 +// CONSTANT cell_symbol_pmatch_car 97 +#define cell_symbol_pmatch_car 97 +// CONSTANT cell_symbol_pmatch_cdr 98 +#define cell_symbol_pmatch_cdr 98 +// CONSTANT cell_type_bytes 99 +#define cell_type_bytes 99 +// CONSTANT cell_type_char 100 +#define cell_type_char 100 +// CONSTANT cell_type_closure 101 +#define cell_type_closure 101 +// CONSTANT cell_type_continuation 102 +#define cell_type_continuation 102 +// CONSTANT cell_type_function 103 +#define cell_type_function 103 +// CONSTANT cell_type_keyword 104 +#define cell_type_keyword 104 +// CONSTANT cell_type_macro 105 +#define cell_type_macro 105 +// CONSTANT cell_type_number 106 +#define cell_type_number 106 +// CONSTANT cell_type_pair 107 +#define cell_type_pair 107 +// CONSTANT cell_type_port 108 +#define cell_type_port 108 +// CONSTANT cell_type_ref 109 +#define cell_type_ref 109 +// CONSTANT cell_type_special 110 +#define cell_type_special 110 +// CONSTANT cell_type_string 111 +#define cell_type_string 111 +// CONSTANT cell_type_struct 112 +#define cell_type_struct 112 +// CONSTANT cell_type_symbol 113 +#define cell_type_symbol 113 +// CONSTANT cell_type_values 114 +#define cell_type_values 114 +// CONSTANT cell_type_variable 115 +#define cell_type_variable 115 +// CONSTANT cell_type_vector 116 +#define cell_type_vector 116 +// CONSTANT cell_type_broken_heart 117 +#define cell_type_broken_heart 117 +// CONSTANT cell_symbol_test 118 +#define cell_symbol_test 118 +// src/module.mes +SCM make_module_type (); +SCM module_printer (SCM module); +SCM module_variable (SCM module, SCM name); +SCM module_ref (SCM module, SCM name); +SCM module_define_x (SCM module, SCM name, SCM value); +// src/posix.mes +SCM peek_byte (); +SCM read_byte (); +SCM unread_byte (SCM i); +SCM peek_char (); +SCM read_char (SCM port); +SCM unread_char (SCM i); +SCM write_char (SCM i); +SCM write_byte (SCM x); +SCM getenv_ (SCM s); +SCM setenv_ (SCM s, SCM v); +SCM access_p (SCM file_name, SCM mode); +SCM current_input_port (); +SCM open_input_file (SCM file_name); +SCM open_input_string (SCM string); +SCM set_current_input_port (SCM port); +SCM current_output_port (); +SCM current_error_port (); +SCM open_output_file (SCM x); +SCM set_current_output_port (SCM port); +SCM set_current_error_port (SCM port); +SCM force_output (SCM p); +SCM chmod_ (SCM file_name, SCM mode); +SCM isatty_p (SCM port); +SCM primitive_fork (); +SCM execl_ (SCM file_name, SCM args); +SCM waitpid_ (SCM pid, SCM options); +SCM current_time (); +SCM gettimeofday_ (); +SCM get_internal_run_time (); +SCM getcwd_ (); +SCM dup_ (SCM port); +SCM dup2_ (SCM old, SCM new); +SCM delete_file (SCM file_name); +// src/reader.mes +SCM read_input_file_env_ (SCM e, SCM a); +SCM read_input_file_env (SCM a); +SCM read_env (SCM a); +SCM reader_read_sexp (SCM c, SCM s, SCM a); +SCM reader_read_character (); +SCM reader_read_binary (); +SCM reader_read_octal (); +SCM reader_read_hex (); +SCM reader_read_string (); +// src/strings.mes +SCM string_equal_p (SCM a, SCM b); +SCM symbol_to_string (SCM symbol); +SCM symbol_to_keyword (SCM symbol); +SCM keyword_to_string (SCM keyword); +SCM string_to_symbol (SCM string); +SCM make_symbol (SCM string); +SCM string_to_list (SCM string); +SCM list_to_string (SCM list); +SCM read_string (SCM port); +SCM string_append (SCM x); +SCM string_length (SCM string); +SCM string_ref (SCM str, SCM k); +// src/struct.mes +SCM make_struct (SCM type, SCM fields, SCM printer); +SCM struct_length (SCM x); +SCM struct_ref (SCM x, SCM i); +SCM struct_set_x (SCM x, SCM i, SCM e); +// src/vector.mes +SCM make_vector_ (SCM n); +SCM vector_length (SCM x); +SCM vector_ref (SCM x, SCM i); +SCM vector_entry (SCM x); +SCM vector_set_x (SCM x, SCM i, SCM e); +SCM list_to_vector (SCM x); +SCM vector_to_list (SCM v); diff --git a/src/gc.c b/src/gc.c index 498bd859..21e2675e 100644 --- a/src/gc.c +++ b/src/gc.c @@ -124,7 +124,7 @@ gc_loop (SCM scan) ///((internal)) while (scan < g_free) { if (NTYPE (scan) == TBROKEN_HEART) - error (cell_symbol_system_error, cell_gc); + error (cell_symbol_system_error, cstring_to_symbol ("gc")); if (NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR || NTYPE (scan) == TREF @@ -136,7 +136,6 @@ gc_loop (SCM scan) ///((internal)) } if ((NTYPE (scan) == TCLOSURE || NTYPE (scan) == TCONTINUATION - || NTYPE (scan) == TFUNCTION || NTYPE (scan) == TKEYWORD || NTYPE (scan) == TMACRO || NTYPE (scan) == TPAIR diff --git a/src/hash.c b/src/hash.c index ab963c38..1e2c4a81 100644 --- a/src/hash.c +++ b/src/hash.c @@ -221,7 +221,8 @@ make_hash_table_ (long size) values = cons (buckets, values); values = cons (MAKE_NUMBER (size), values); values = cons (cell_symbol_hashq_table, values); - return make_struct (hashq_type, values, cell_hash_table_printer); + //FIXME: symbol/printer return make_struct (hashq_type, values, cstring_to_symbol ("hash-table-printer"); + return make_struct (hashq_type, values, cell_unspecified); } SCM diff --git a/src/lib.c b/src/lib.c index e16dc653..94484821 100644 --- a/src/lib.c +++ b/src/lib.c @@ -18,6 +18,11 @@ * along with GNU Mes. If not, see . */ +// CONSTANT STRUCT_TYPE 0 +#define STRUCT_TYPE 0 +// CONSTANT STRUCT_PRINTER 1 +#define STRUCT_PRINTER 1 + int g_depth; SCM fdisplay_ (SCM, int, int); @@ -68,19 +73,6 @@ display_helper (SCM x, int cont, char* sep, int fd, int write_p) display_helper (args, 0, "", fd, 0); fdputs (">", fd); } - else if (t == TFUNCTION) - { - fdputs ("#", fd); - } else if (t == TMACRO) { fdputs ("#. */ +#include #include #include #include @@ -63,14 +64,6 @@ SCM m0 = 0; SCM g_macros = 0; SCM g_ports = 1; -#if __x86_64__ -#define HALFLONG_MAX UINT_MAX -typedef int halflong; -#else -#define HALFLONG_MAX UINT16_MAX -typedef short halflong; -#endif - // CONSTANT TBYTES 0 #define TBYTES 0 // CONSTANT TCHAR 1 @@ -79,101 +72,46 @@ typedef short halflong; #define TCLOSURE 2 // CONSTANT TCONTINUATION 3 #define TCONTINUATION 3 -// CONSTANT TFUNCTION 4 -#define TFUNCTION 4 -// CONSTANT TKEYWORD 5 -#define TKEYWORD 5 -// CONSTANT TMACRO 6 -#define TMACRO 6 -// CONSTANT TNUMBER 7 -#define TNUMBER 7 -// CONSTANT TPAIR 8 -#define TPAIR 8 -// CONSTANT TPORT 9 -#define TPORT 9 -// CONSTANT TREF 10 -#define TREF 10 -// CONSTANT TSPECIAL 11 -#define TSPECIAL 11 -// CONSTANT TSTRING 12 -#define TSTRING 12 -// CONSTANT TSTRUCT 13 -#define TSTRUCT 13 -// CONSTANT TSYMBOL 14 -#define TSYMBOL 14 -// CONSTANT TVALUES 15 -#define TVALUES 15 -// CONSTANT TVARIABLE 16 -#define TVARIABLE 16 -// CONSTANT TVECTOR 17 -#define TVECTOR 17 -// CONSTANT TBROKEN_HEART 18 -#define TBROKEN_HEART 18 +// CONSTANT TKEYWORD 4 +#define TKEYWORD 4 +// CONSTANT TMACRO 5 +#define TMACRO 5 +// CONSTANT TNUMBER 6 +#define TNUMBER 6 +// CONSTANT TPAIR 7 +#define TPAIR 7 +// CONSTANT TPORT 8 +#define TPORT 8 +// CONSTANT TREF 9 +#define TREF 9 +// CONSTANT TSPECIAL 10 +#define TSPECIAL 10 +// CONSTANT TSTRING 11 +#define TSTRING 11 +// CONSTANT TSTRUCT 12 +#define TSTRUCT 12 +// CONSTANT TSYMBOL 13 +#define TSYMBOL 13 +// CONSTANT TVALUES 14 +#define TVALUES 14 +// CONSTANT TVARIABLE 15 +#define TVARIABLE 15 +// CONSTANT TVECTOR 16 +#define TVECTOR 16 +// CONSTANT TBROKEN_HEART 17 +#define TBROKEN_HEART 17 typedef SCM (*function0_t) (void); typedef SCM (*function1_t) (SCM); typedef SCM (*function2_t) (SCM, SCM); typedef SCM (*function3_t) (SCM, SCM, SCM); typedef SCM (*functionn_t) (SCM); -#if !POSIX -struct scm { +struct scm +{ long type; SCM car; SCM cdr; }; -struct function { -#if __M2_PLANET__ - FUNCTION function; -#else // !__M2_PLANET__ - SCM (*function) (SCM); -#endif // !__M2_PLANET__ - long arity; - char *name; -}; -#else -struct function { - union { - function0_t function0; - function1_t function1; - function2_t function2; - function3_t function3; - functionn_t functionn; - }; - long arity; - char const *name; -}; -struct scm { - long type; - union - { -#if 0 - struct - { - unsigned halflong start; - unsigned halflong end; - }; -#endif - unsigned long function; - unsigned long length; - long port; - SCM car; - SCM macro; - SCM ref; - SCM variable; - }; - union - { - long value; - char const* name; - char const* bytes; - SCM cdr; - SCM closure; - SCM continuation; - SCM string; - SCM vector; - }; -}; -#endif #if __MESC__ //FIXME @@ -357,110 +295,84 @@ struct scm *g_news = 0; // CONSTANT cell_symbol_buckets 82 #define cell_symbol_buckets 82 -// CONSTANT cell_symbol_frame 83 -#define cell_symbol_frame 83 -// CONSTANT cell_symbol_hashq_table 84 -#define cell_symbol_hashq_table 84 -// CONSTANT cell_symbol_module 85 -#define cell_symbol_module 85 -// CONSTANT cell_symbol_procedure 86 -#define cell_symbol_procedure 86 -// CONSTANT cell_symbol_record_type 87 -#define cell_symbol_record_type 87 -// CONSTANT cell_symbol_size 88 -#define cell_symbol_size 88 -// CONSTANT cell_symbol_stack 89 -#define cell_symbol_stack 89 +// CONSTANT cell_symbol_builtin 83 +#define cell_symbol_builtin 83 +// CONSTANT cell_symbol_frame 84 +#define cell_symbol_frame 84 +// CONSTANT cell_symbol_hashq_table 85 +#define cell_symbol_hashq_table 85 +// CONSTANT cell_symbol_module 86 +#define cell_symbol_module 86 +// CONSTANT cell_symbol_procedure 87 +#define cell_symbol_procedure 87 +// CONSTANT cell_symbol_record_type 88 +#define cell_symbol_record_type 88 +// CONSTANT cell_symbol_size 89 +#define cell_symbol_size 89 +// CONSTANT cell_symbol_stack 90 +#define cell_symbol_stack 90 -// CONSTANT cell_symbol_argv 90 -#define cell_symbol_argv 90 -// CONSTANT cell_symbol_mes_prefix 91 -#define cell_symbol_mes_prefix 91 -// CONSTANT cell_symbol_mes_version 92 -#define cell_symbol_mes_version 92 +// CONSTANT cell_symbol_argv 91 +#define cell_symbol_argv 91 +// CONSTANT cell_symbol_mes_prefix 92 +#define cell_symbol_mes_prefix 92 +// CONSTANT cell_symbol_mes_version 93 +#define cell_symbol_mes_version 93 -// CONSTANT cell_symbol_internal_time_units_per_second 93 -#define cell_symbol_internal_time_units_per_second 93 -// CONSTANT cell_symbol_compiler 94 -#define cell_symbol_compiler 94 -// CONSTANT cell_symbol_arch 95 -#define cell_symbol_arch 95 +// CONSTANT cell_symbol_internal_time_units_per_second 94 +#define cell_symbol_internal_time_units_per_second 94 +// CONSTANT cell_symbol_compiler 95 +#define cell_symbol_compiler 95 +// CONSTANT cell_symbol_arch 96 +#define cell_symbol_arch 96 +// CONSTANT cell_symbol_pmatch_car 97 +#define cell_symbol_pmatch_car 97 +// CONSTANT cell_symbol_pmatch_cdr 98 +#define cell_symbol_pmatch_cdr 98 -// CONSTANT cell_symbol_pmatch_car 96 -#define cell_symbol_pmatch_car 96 -// CONSTANT cell_symbol_pmatch_cdr 97 -#define cell_symbol_pmatch_cdr 97 +// CONSTANT cell_type_bytes 99 +#define cell_type_bytes 99 +// CONSTANT cell_type_char 100 +#define cell_type_char 100 +// CONSTANT cell_type_closure 101 +#define cell_type_closure 101 +// CONSTANT cell_type_continuation 102 +#define cell_type_continuation 102 +// CONSTANT cell_type_function 103 +#define cell_type_function 103 +// CONSTANT cell_type_keyword 104 +#define cell_type_keyword 104 +// CONSTANT cell_type_macro 105 +#define cell_type_macro 105 +// CONSTANT cell_type_number 106 +#define cell_type_number 106 +// CONSTANT cell_type_pair 107 +#define cell_type_pair 107 +// CONSTANT cell_type_port 108 +#define cell_type_port 108 +// CONSTANT cell_type_ref 109 +#define cell_type_ref 109 +// CONSTANT cell_type_special 110 +#define cell_type_special 110 +// CONSTANT cell_type_string 111 +#define cell_type_string 111 +// CONSTANT cell_type_struct 112 +#define cell_type_struct 112 +// CONSTANT cell_type_symbol 113 +#define cell_type_symbol 113 +// CONSTANT cell_type_values 114 +#define cell_type_values 114 +// CONSTANT cell_type_variable 115 +#define cell_type_variable 115 +// CONSTANT cell_type_vector 116 +#define cell_type_vector 116 +// CONSTANT cell_type_broken_heart 117 +#define cell_type_broken_heart 117 -// CONSTANT cell_type_bytes 98 -#define cell_type_bytes 98 -// CONSTANT cell_type_char 99 -#define cell_type_char 99 -// CONSTANT cell_type_closure 100 -#define cell_type_closure 100 -// CONSTANT cell_type_continuation 101 -#define cell_type_continuation 101 -// CONSTANT cell_type_function 102 -#define cell_type_function 102 -// CONSTANT cell_type_keyword 103 -#define cell_type_keyword 103 -// CONSTANT cell_type_macro 104 -#define cell_type_macro 104 -// CONSTANT cell_type_number 105 -#define cell_type_number 105 -// CONSTANT cell_type_pair 106 -#define cell_type_pair 106 -// CONSTANT cell_type_port 107 -#define cell_type_port 107 -// CONSTANT cell_type_ref 108 -#define cell_type_ref 108 -// CONSTANT cell_type_special 109 -#define cell_type_special 109 -// CONSTANT cell_type_string 110 -#define cell_type_string 110 -// CONSTANT cell_type_struct 111 -#define cell_type_struct 111 -// CONSTANT cell_type_symbol 112 -#define cell_type_symbol 112 -// CONSTANT cell_type_values 113 -#define cell_type_values 113 -// CONSTANT cell_type_variable 114 -#define cell_type_variable 114 -// CONSTANT cell_type_vector 115 -#define cell_type_vector 115 -// CONSTANT cell_type_broken_heart 116 -#define cell_type_broken_heart 116 +// CONSTANT cell_test 118 +#define cell_test 118 -// CONSTANT cell_symbol_test 117 -#define cell_symbol_test 117 - -struct function g_functions[200]; -int g_function = 0; - -#if !__GNUC__ || !POSIX -#include "src/gc.mes.h" -#include "src/hash.mes.h" -#include "src/lib.mes.h" -#include "src/math.mes.h" -#include "src/mes.mes.h" -#include "src/module.mes.h" -#include "src/posix.mes.h" -#include "src/reader.mes.h" -#include "src/strings.mes.h" -#include "src/struct.mes.h" -#include "src/vector.mes.h" -#else -#include "src/gc.h" -#include "src/hash.h" -#include "src/lib.h" -#include "src/math.h" -#include "src/mes.h" -#include "src/module.h" -#include "src/posix.h" -#include "src/reader.h" -#include "src/strings.h" -#include "src/struct.h" -#include "src/vector.h" -#endif +#include "builtins.h" #define TYPE(x) g_cells[x].type #define CAR(x) g_cells[x].car @@ -484,8 +396,6 @@ int g_function = 0; #define CBYTES(x) &g_cells[x].cdr #define CSTRING_STRUCT(x) &g_cells[x.cdr].cdr -#define FUNCTION(x) g_functions[g_cells[x].car] -#define FUNCTION0(x) g_functions[g_cells[x].car].function #define MACRO(x) g_cells[x].car #define NAME(x) g_cells[x].cdr #define PORT(x) g_cells[x].car @@ -502,8 +412,6 @@ int g_function = 0; #else #define BYTES(x) g_cells[x].bytes -#define FUNCTION(x) g_functions[g_cells[x].function] -#define FUNCTION0(x) g_functions[g_cells[x].function].function0 #define LENGTH(x) g_cells[x].length #define REF(x) g_cells[x].ref #define START(x) g_cells[x].start @@ -550,8 +458,12 @@ int g_function = 0; #define CADDR(x) CAR (CDR (CDR (x))) #define CDADAR(x) CAR (CDR (CAR (CDR (x)))) -SCM make_bytes (char const* s, size_t length); +SCM apply_builtin (SCM fn, SCM x); SCM cstring_to_list (char const* s); +SCM cstring_to_symbol (char const *s); +SCM make_bytes (char const* s, size_t length); +SCM make_hash_table_ (long size); +SCM read_input_file_env (SCM); SCM string_equal_p (SCM a, SCM b); SCM @@ -647,13 +559,6 @@ cdr_ (SCM x) || TYPE (CDR (x)) == TSTRING)) ? CDR (x) : MAKE_NUMBER (CDR (x)); } -SCM -arity_ (SCM x) -{ - assert (TYPE (x) == TFUNCTION); - return MAKE_NUMBER (FUNCTION (x).arity); -} - SCM cons (SCM x, SCM y) { @@ -806,7 +711,8 @@ check_apply (SCM f, SCM e) ///((internal)) type = "number"; if (TYPE (f) == TSTRING) type = "string"; - if (TYPE (f) == TSTRUCT) + if (TYPE (f) == TSTRUCT + && builtin_p (f) == cell_f) type = "#<...>"; if (TYPE (f) == TBROKEN_HEART) type = "<3"; @@ -862,7 +768,7 @@ append2 (SCM x, SCM y) if (x == cell_nil) return y; if (TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cell_append2)); + error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append2"))); SCM r = cell_nil; while (x != cell_nil) { @@ -878,7 +784,7 @@ append_reverse (SCM x, SCM y) if (x == cell_nil) return y; if (TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cell_append_reverse)); + error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("append-reverse"))); while (x != cell_nil) { y = cons (CAR (x), y); @@ -891,7 +797,7 @@ SCM reverse_x_ (SCM x, SCM t) { if (x != cell_nil && TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cell_reverse_x_)); + error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("core:reverse!"))); SCM r = t; while (x != cell_nil) { @@ -914,80 +820,6 @@ pairlis (SCM x, SCM y, SCM a) pairlis (cdr (x), cdr (y), a)); } -SCM -call (SCM fn, SCM x) -{ -#if __M2_PLANET__ - struct function *f = FUNCTION (fn); -#else - struct function *f = &FUNCTION (fn); -#endif - int arity = f->arity; - if ((arity > 0 || arity == -1) - && x != cell_nil && TYPE (CAR (x)) == TVALUES) - x = cons (CADAR (x), CDR (x)); - if ((arity > 1 || arity == -1) - && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES) - x = cons (CAR (x), cons (CDADAR (x), CDR (x))); - -#if __M2_PLANET__ - FUNCTION fp = f->function; - if (arity == 0) - return fp (); - else if (arity == 1) - return fp (CAR (x)); - else if (arity == 2) - return fp (CAR (x), CADR (x)); - else if (arity == 3) - return fp (CAR (x), CADR (x), CAR (CDDR (x))); - else if (arity == -1) - return fp (x); -#elif !POSIX - if (arity == 0) - { - //function0_t fp = f->function; - SCM (*fp) (void) = f->function; - return fp (); - } - else if (arity == 1) - { - //function1_t fp = f->function; - SCM (*fp) (SCM) = f->function; - return fp (CAR (x)); - } - else if (arity == 2) - { - //function2_t fp = f->function; - SCM (*fp) (SCM, SCM) = f->function; - return fp (CAR (x), CADR (x)); - } - else if (arity == 3) - { - //function3_t fp = f->function; - SCM (*fp) (SCM, SCM, SCM) = f->function; - return fp (CAR (x), CADR (x), CAR (CDDR (x))); - } - else if (arity == -1) - { - //functionn_t fp = f->function; - SCM (*fp) (SCM) = f->function; - return fp (x); - } -#else - if (arity == 0) - return FUNCTION (fn).function0 (); - else if (arity == 1) - return FUNCTION (fn).function1 (CAR (x)); - else if (arity == 2) - return FUNCTION (fn).function2 (CAR (x), CADR (x)); - else if (arity == 3) - return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x))); - else if (arity == -1) - return FUNCTION (fn).functionn (x); -#endif //! (__M2_PLANET__ || !POSIX) - return cell_unspecified; -} - SCM assq (SCM x, SCM a) { @@ -1031,7 +863,7 @@ SCM set_car_x (SCM x, SCM e) { if (TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cell_set_car_x)); + error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("set-car!"))); CAR (x) = e; return cell_unspecified; } @@ -1040,7 +872,7 @@ SCM set_cdr_x (SCM x, SCM e) { if (TYPE (x) != TPAIR) - error (cell_symbol_not_a_pair, cons (x, cell_set_cdr_x)); + error (cell_symbol_not_a_pair, cons (x, cstring_to_symbol ("set-cdr!"))); CDR (x) = e; return cell_unspecified; } @@ -1292,10 +1124,10 @@ eval_apply () apply: g_stack_array[g_stack+FRAME_PROCEDURE] = CAR (r1); t = TYPE (CAR (r1)); - if (t == TFUNCTION) + if (t == TSTRUCT && builtin_p (CAR (r1)) == cell_t) { - check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1)); - r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply + check_formals (CAR (r1), builtin_arity (CAR (r1)), CDR (r1)); + r1 = apply_builtin (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply goto vm_return; } else if (t == TCLOSURE) @@ -1817,14 +1649,6 @@ mes_g_stack (SCM a) ///((internal)) return r0; } -// Environment setup - -#include "src/hash.c" -#include "src/module.c" -#include "src/posix.c" -#include "src/math.c" -#include "src/lib.c" - // Jam Collector SCM g_symbol_max; @@ -1955,6 +1779,7 @@ mes_symbols () ///((internal)) init_symbol (cell_symbol_wrong_type_arg, TSYMBOL, "wrong-type-arg"); init_symbol (cell_symbol_buckets, TSYMBOL, "buckets"); + init_symbol (cell_symbol_builtin, TSYMBOL, ""); init_symbol (cell_symbol_frame, TSYMBOL, ""); init_symbol (cell_symbol_hashq_table, TSYMBOL, ""); init_symbol (cell_symbol_module, TSYMBOL, ""); @@ -2009,7 +1834,6 @@ mes_symbols () ///((internal)) a = acons (cell_type_char, MAKE_NUMBER (TCHAR), a); a = acons (cell_type_closure, MAKE_NUMBER (TCLOSURE), a); a = acons (cell_type_continuation, MAKE_NUMBER (TCONTINUATION), a); - a = acons (cell_type_function, MAKE_NUMBER (TFUNCTION), a); a = acons (cell_type_keyword, MAKE_NUMBER (TKEYWORD), a); a = acons (cell_type_macro, MAKE_NUMBER (TMACRO), a); a = acons (cell_type_number, MAKE_NUMBER (TNUMBER), a); @@ -2059,196 +1883,324 @@ mes_environment (int argc, char *argv[]) return mes_g_stack (a); } +SCM +init_builtin (SCM builtin_type, char const* name, int arity, SCM (*function) (SCM), SCM a) +{ + SCM s = cstring_to_symbol (name); + return acons (s, make_builtin (builtin_type, symbol_to_string (s), MAKE_NUMBER (arity), MAKE_NUMBER (function)), a); +} + +SCM +make_builtin_type () ///(internal)) +{ + SCM record_type = cell_symbol_record_type; + SCM fields = cell_nil; + fields = cons (cstring_to_symbol ("address"), fields); + fields = cons (cstring_to_symbol ("arity"), fields); + fields = cons (cstring_to_symbol ("name"), fields); + fields = cons (fields, cell_nil); + fields = cons (cell_symbol_builtin, fields); + return make_struct (record_type, fields, cell_unspecified); +} + +SCM +make_builtin (SCM builtin_type, SCM name, SCM arity, SCM function) +{ + SCM values = cell_nil; + values = cons (function, values); + values = cons (arity, values); + values = cons (name, values); + values = cons (cell_symbol_builtin, values); + return make_struct (builtin_type, values, cstring_to_symbol ("builtin-printer")); +} + +SCM +builtin_name (SCM builtin) +{ + return struct_ref_ (builtin, 3); +} + +SCM +builtin_arity (SCM builtin) +{ + return struct_ref_ (builtin, 4); +} + +#if __MESC__ +long +builtin_function (SCM builtin) +#else +SCM +(*builtin_function (SCM builtin)) (SCM) +#endif +{ + return VALUE (struct_ref_ (builtin, 5)); +} + +SCM +builtin_p (SCM x) +{ + return (TYPE (x) == TSTRUCT && struct_ref_ (x, 2) == cell_symbol_builtin) + ? cell_t : cell_f; +} + +SCM +builtin_printer (SCM builtin) +{ + fdputs ("#', g_stdout); +} + +SCM +apply_builtin (SCM fn, SCM x) ///((internal)) +{ + int arity = VALUE (builtin_arity (fn)); + if ((arity > 0 || arity == -1) + && x != cell_nil && TYPE (CAR (x)) == TVALUES) + x = cons (CADAR (x), CDR (x)); + if ((arity > 1 || arity == -1) + && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES) + x = cons (CAR (x), cons (CDADAR (x), CDR (x))); + +#if __M2_PLANET__ + FUNCTION fp = builtin_function (fn) + if (arity == 0) + return fp (); + else if (arity == 1) + return fp (CAR (x)); + else if (arity == 2) + return fp (CAR (x), CADR (x)); + else if (arity == 3) + return fp (CAR (x), CADR (x), CAR (CDDR (x))); + else if (arity == -1) + return fp (x); +#elif !POSIX + if (arity == 0) + { + //function0_t fp = f->function; + SCM (*fp) (void) = builtin_function (fn); + return fp (); + } + else if (arity == 1) + { + //function1_t fp = f->function; + SCM (*fp) (SCM) = builtin_function (fn); + return fp (CAR (x)); + } + else if (arity == 2) + { + //function2_t fp = f->function; + SCM (*fp) (SCM, SCM) = builtin_function (fn); + return fp (CAR (x), CADR (x)); + } + else if (arity == 3) + { + //function3_t fp = f->function; + SCM (*fp) (SCM, SCM, SCM) = builtin_function (fn); + return fp (CAR (x), CADR (x), CAR (CDDR (x))); + } + else if (arity == -1) + { + //functionn_t fp = f->function; + SCM (*fp) (SCM) = builtin_function (fn); + return fp (x); + } +#else + #error POSIX + if (arity == 0) + return FUNCTION (fn).function0 (); + else if (arity == 1) + return FUNCTION (fn).function1 (CAR (x)); + else if (arity == 2) + return FUNCTION (fn).function2 (CAR (x), CADR (x)); + else if (arity == 3) + return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x))); + else if (arity == -1) + return FUNCTION (fn).functionn (x); +#endif //! (__M2_PLANET__ || !POSIX) + return cell_unspecified; +} + SCM mes_builtins (SCM a) ///((internal)) { -#if MES_MINI + // TODO minimal: cons, car, cdr, list, null_p, eq_p minus, plus + // display_, display_error_, getenv -#if !POSIX - #define function car -#endif + SCM builtin_type = make_builtin_type (); -//mes -scm_cons.function = g_function; -g_functions[g_function++] = fun_cons; -cell_cons = g_free++; -g_cells[cell_cons] = scm_cons; - -scm_car.function = g_function; -g_functions[g_function++] = fun_car; -cell_car = g_free++; -g_cells[cell_car] = scm_car; - -scm_cdr.function = g_function; -g_functions[g_function++] = fun_cdr; -cell_cdr = g_free++; -g_cells[cell_cdr] = scm_cdr; - -scm_list.function = g_function; -g_functions[g_function++] = fun_list; -cell_list = g_free++; -g_cells[cell_list] = scm_list; - -scm_null_p.function = g_function; -g_functions[g_function++] = fun_null_p; -cell_null_p = g_free++; -g_cells[cell_null_p] = scm_null_p; - -scm_eq_p.function = g_function; -g_functions[g_function++] = fun_eq_p; -cell_eq_p = g_free++; -g_cells[cell_eq_p] = scm_eq_p; - -//math -scm_minus.function = g_function; -g_functions[g_function++] = fun_minus; -cell_minus = g_free++; -g_cells[cell_minus] = scm_minus; - -scm_plus.function = g_function; -g_functions[g_function++] = fun_plus; -cell_plus = g_free++; -g_cells[cell_plus] = scm_plus; - -//lib -scm_display_.function = g_function; -g_functions[g_function++] = fun_display_; -cell_display_ = g_free++; -g_cells[cell_display_] = scm_display_; - -scm_display_error_.function = g_function; -g_functions[g_function++] = fun_display_error_; -cell_display_error_ = g_free++; -g_cells[cell_display_error_] = scm_display_error_; - -//posix -scm_getenv_.function = g_function; -g_functions[g_function++] = fun_getenv_; -cell_getenv_ = g_free++; -g_cells[cell_getenv_] = scm_getenv_; - -#if !POSIX - #undef name - #define string cdr -#endif - -//mes.environment -scm_cons.string = MAKE_BYTES0 (fun_cons.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_cons)), cell_cons, a); - -scm_car.string = MAKE_BYTES0 (fun_car.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_car)), cell_car, a); - -scm_cdr.string = MAKE_BYTES0 (fun_cdr.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_cdr)), cell_cdr, a); - -scm_list.string = MAKE_BYTES0 (fun_list.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_list)), cell_list, a); - -scm_null_p.string = MAKE_BYTES0 (fun_null_p.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_null_p)), cell_null_p, a); - -scm_eq_p.string = MAKE_BYTES0 (fun_eq_p.name); - a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_eq_p)), cell_eq_p, a); - -//math.environment -scm_minus.string = MAKE_BYTES0 (fun_minus.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_minus)), cell_minus, a); - -scm_plus.string = MAKE_BYTES0 (fun_plus.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_plus)), cell_plus, a); - -//lib.environment -scm_display_.string = MAKE_BYTES0 (fun_display_.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_display_)), cell_display_, a); - -scm_display_error_.string = MAKE_BYTES0 (fun_display_error_.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_display_error_)), cell_display_error_, a); - -//posix.environment -scm_getenv_.string = MAKE_BYTES0 (fun_getenv_.name); -a = acons (cstring_to_symbol (CSTRING_STRUCT (scm_getenv_)), cell_getenv_, a); - -#if !POSIX - #undef function - #undef string -#endif - -#elif !__GNUC__ || !POSIX -#include "src/mes.mes.i" - - // Do not sort: Order of these includes define builtins -#include "src/hash.mes.i" -#include "src/module.mes.i" -#include "src/posix.mes.i" -#include "src/math.mes.i" -#include "src/lib.mes.i" -#include "src/vector.mes.i" -#include "src/strings.mes.i" -#include "src/struct.mes.i" -#include "src/gc.mes.i" -#include "src/reader.mes.i" - -#include "src/gc.mes.environment.i" -#include "src/hash.mes.environment.i" -#include "src/lib.mes.environment.i" -#include "src/math.mes.environment.i" -#include "src/mes.mes.environment.i" -#include "src/module.mes.environment.i" -#include "src/posix.mes.environment.i" -#include "src/reader.mes.environment.i" -#include "src/strings.mes.environment.i" -#include "src/struct.mes.environment.i" -#include "src/vector.mes.environment.i" -#else -#include "src/mes.i" - - // Do not sort: Order of these includes define builtins -#include "src/hash.i" -#include "src/module.i" -#include "src/posix.i" -#include "src/math.i" -#include "src/lib.i" -#include "src/vector.i" -#include "src/strings.i" -#include "src/struct.i" -#include "src/gc.i" -#include "src/reader.i" - -#include "src/gc.environment.i" -#include "src/hash.environment.i" -#include "src/lib.environment.i" -#include "src/math.environment.i" -#include "src/mes.environment.i" -#include "src/module.environment.i" -#include "src/posix.environment.i" -#include "src/reader.environment.i" -#include "src/strings.environment.i" -#include "src/struct.environment.i" -#include "src/vector.environment.i" -#endif - - if (g_debug > 3) - { - fdputs ("functions: ", g_stderr); - fdputs (itoa (g_function), g_stderr); - fdputs ("\n", g_stderr); - for (int i = 0; i < g_function; i++) - { - fdputs ("[", g_stderr); - fdputs (itoa (i), g_stderr); - fdputs ("]: ", g_stderr); - fdputs (g_functions[i].name, g_stderr); - fdputs ("\n", g_stderr); - } - fdputs ("\n", g_stderr); - } + // src/gc.mes + a = init_builtin (builtin_type, "gc-check", 0, &gc_check, a); + a = init_builtin (builtin_type, "gc", 0, &gc, a); + // src/hash.mes + a = init_builtin (builtin_type, "hashq", 2, &hashq, a); + a = init_builtin (builtin_type, "hash", 2, &hash, a); + a = init_builtin (builtin_type, "hashq-get-handle", 3, &hashq_get_handle, a); + a = init_builtin (builtin_type, "hashq-ref", 3, &hashq_ref, a); + a = init_builtin (builtin_type, "hash-ref", 3, &hash_ref, a); + a = init_builtin (builtin_type, "hashq-set!", 3, &hashq_set_x, a); + a = init_builtin (builtin_type, "hash-set!", 3, &hash_set_x, a); + a = init_builtin (builtin_type, "hash-table-printer", 1, &hash_table_printer, a); + a = init_builtin (builtin_type, "make-hash-table", 1, &make_hash_table, a); + // src/lib.mes + a = init_builtin (builtin_type, "core:display", 1, &display_, a); + a = init_builtin (builtin_type, "core:display-error", 1, &display_error_, a); + a = init_builtin (builtin_type, "core:display-port", 2, &display_port_, a); + a = init_builtin (builtin_type, "core:write", 1, &write_, a); + a = init_builtin (builtin_type, "core:write-error", 1, &write_error_, a); + a = init_builtin (builtin_type, "core:write-port", 2, &write_port_, a); + a = init_builtin (builtin_type, "exit", 1, &exit_, a); + a = init_builtin (builtin_type, "frame-printer", 1, &frame_printer, a); + a = init_builtin (builtin_type, "make-stack", -1, &make_stack, a); + a = init_builtin (builtin_type, "stack-length", 1, &stack_length, a); + a = init_builtin (builtin_type, "stack-ref", 2, &stack_ref, a); + a = init_builtin (builtin_type, "xassq", 2, &xassq, a); + a = init_builtin (builtin_type, "memq", 2, &memq, a); + a = init_builtin (builtin_type, "equal2?", 2, &equal2_p, a); + a = init_builtin (builtin_type, "last-pair", 1, &last_pair, a); + a = init_builtin (builtin_type, "pair?", 1, &pair_p, a); + // src/math.mes + a = init_builtin (builtin_type, ">", -1, &greater_p, a); + a = init_builtin (builtin_type, "<", -1, &less_p, a); + a = init_builtin (builtin_type, "=", -1, &is_p, a); + a = init_builtin (builtin_type, "-", -1, &minus, a); + a = init_builtin (builtin_type, "+", -1, &plus, a); + a = init_builtin (builtin_type, "/", -1, ÷, a); + a = init_builtin (builtin_type, "modulo", 2, &modulo, a); + a = init_builtin (builtin_type, "*", -1, &multiply, a); + a = init_builtin (builtin_type, "logand", -1, &logand, a); + a = init_builtin (builtin_type, "logior", -1, &logior, a); + a = init_builtin (builtin_type, "lognot", 1, &lognot, a); + a = init_builtin (builtin_type, "logxor", -1, &logxor, a); + a = init_builtin (builtin_type, "ash", 2, &ash, a); + // src/mes.mes + a = init_builtin (builtin_type, "core:make-cell", 3, &make_cell_, a); + a = init_builtin (builtin_type, "core:type", 1, &type_, a); + a = init_builtin (builtin_type, "core:car", 1, &car_, a); + a = init_builtin (builtin_type, "core:cdr", 1, &cdr_, a); + a = init_builtin (builtin_type, "cons", 2, &cons, a); + a = init_builtin (builtin_type, "car", 1, &car, a); + a = init_builtin (builtin_type, "cdr", 1, &cdr, a); + a = init_builtin (builtin_type, "list", -1, &list, a); + a = init_builtin (builtin_type, "null?", 1, &null_p, a); + a = init_builtin (builtin_type, "eq?", 2, &eq_p, a); + a = init_builtin (builtin_type, "values", -1, &values, a); + a = init_builtin (builtin_type, "acons", 3, &acons, a); + a = init_builtin (builtin_type, "length", 1, &length, a); + a = init_builtin (builtin_type, "error", 2, &error, a); + a = init_builtin (builtin_type, "append2", 2, &append2, a); + a = init_builtin (builtin_type, "append-reverse", 2, &append_reverse, a); + a = init_builtin (builtin_type, "core:reverse!", 2, &reverse_x_, a); + a = init_builtin (builtin_type, "pairlis", 3, &pairlis, a); + a = init_builtin (builtin_type, "assq", 2, &assq, a); + a = init_builtin (builtin_type, "assoc", 2, &assoc, a); + a = init_builtin (builtin_type, "set-car!", 2, &set_car_x, a); + a = init_builtin (builtin_type, "set-cdr!", 2, &set_cdr_x, a); + a = init_builtin (builtin_type, "set-env!", 3, &set_env_x, a); + a = init_builtin (builtin_type, "macro-get-handle", 1, ¯o_get_handle, a); + a = init_builtin (builtin_type, "add-formals", 2, &add_formals, a); + a = init_builtin (builtin_type, "eval-apply", 0, &eval_apply, a); + a = init_builtin (builtin_type, "make-builtin-type", 0, &make_builtin_type, a); + a = init_builtin (builtin_type, "make-builtin", 4, &make_builtin, a); + a = init_builtin (builtin_type, "builtin-name", 1, &builtin_name, a); + a = init_builtin (builtin_type, "builtin-arity", 1, &builtin_arity, a); + a = init_builtin (builtin_type, "builtin?", 1, &builtin_p, a); + a = init_builtin (builtin_type, "builtin-printer", 1, &builtin_printer, a); + // src/module.mes + a = init_builtin (builtin_type, "make-module-type", 0, &make_module_type, a); + a = init_builtin (builtin_type, "module-printer", 1, &module_printer, a); + a = init_builtin (builtin_type, "module-variable", 2, &module_variable, a); + a = init_builtin (builtin_type, "module-ref", 2, &module_ref, a); + a = init_builtin (builtin_type, "module-define!", 3, &module_define_x, a); + // src/posix.mes + a = init_builtin (builtin_type, "peek-byte", 0, &peek_byte, a); + a = init_builtin (builtin_type, "read-byte", 0, &read_byte, a); + a = init_builtin (builtin_type, "unread-byte", 1, &unread_byte, a); + a = init_builtin (builtin_type, "peek-char", 0, &peek_char, a); + a = init_builtin (builtin_type, "read-char", -1, &read_char, a); + a = init_builtin (builtin_type, "unread-char", 1, &unread_char, a); + a = init_builtin (builtin_type, "write-char", -1, &write_char, a); + a = init_builtin (builtin_type, "write-byte", -1, &write_byte, a); + a = init_builtin (builtin_type, "getenv", 1, &getenv_, a); + a = init_builtin (builtin_type, "setenv", 2, &setenv_, a); + a = init_builtin (builtin_type, "access?", 2, &access_p, a); + a = init_builtin (builtin_type, "current-input-port", 0, ¤t_input_port, a); + a = init_builtin (builtin_type, "open-input-file", 1, &open_input_file, a); + a = init_builtin (builtin_type, "open-input-string", 1, &open_input_string, a); + a = init_builtin (builtin_type, "set-current-input-port", 1, &set_current_input_port, a); + a = init_builtin (builtin_type, "current-output-port", 0, ¤t_output_port, a); + a = init_builtin (builtin_type, "current-error-port", 0, ¤t_error_port, a); + a = init_builtin (builtin_type, "open-output-file", -1, &open_output_file, a); + a = init_builtin (builtin_type, "set-current-output-port", 1, &set_current_output_port, a); + a = init_builtin (builtin_type, "set-current-error-port", 1, &set_current_error_port, a); + a = init_builtin (builtin_type, "force-output", -1, &force_output, a); + a = init_builtin (builtin_type, "chmod", 2, &chmod_, a); + a = init_builtin (builtin_type, "isatty?", 1, &isatty_p, a); + a = init_builtin (builtin_type, "primitive-fork", 0, &primitive_fork, a); + a = init_builtin (builtin_type, "execl", 2, &execl_, a); + a = init_builtin (builtin_type, "core:waitpid", 2, &waitpid_, a); + a = init_builtin (builtin_type, "current-time", 0, ¤t_time, a); + a = init_builtin (builtin_type, "gettimeofday", 0, &gettimeofday_, a); + a = init_builtin (builtin_type, "get-internal-run-time", 0, &get_internal_run_time, a); + a = init_builtin (builtin_type, "getcwd", 0, &getcwd_, a); + a = init_builtin (builtin_type, "dup", 1, &dup_, a); + a = init_builtin (builtin_type, "dup2", 2, &dup2_, a); + a = init_builtin (builtin_type, "delete-file", 1, &delete_file, a); + // src/reader.mes + a = init_builtin (builtin_type, "core:read-input-file-env", 2, &read_input_file_env_, a); + a = init_builtin (builtin_type, "read-input-file-env", 1, &read_input_file_env, a); + a = init_builtin (builtin_type, "read-env", 1, &read_env, a); + a = init_builtin (builtin_type, "reader-read-sexp", 3, &reader_read_sexp, a); + a = init_builtin (builtin_type, "reader-read-character", 0, &reader_read_character, a); + a = init_builtin (builtin_type, "reader-read-binary", 0, &reader_read_binary, a); + a = init_builtin (builtin_type, "reader-read-octal", 0, &reader_read_octal, a); + a = init_builtin (builtin_type, "reader-read-hex", 0, &reader_read_hex, a); + a = init_builtin (builtin_type, "reader-read-string", 0, &reader_read_string, a); + // src/strings.mes + a = init_builtin (builtin_type, "string=?", 2, &string_equal_p, a); + a = init_builtin (builtin_type, "symbol->string", 1, &symbol_to_string, a); + a = init_builtin (builtin_type, "symbol->keyword", 1, &symbol_to_keyword, a); + a = init_builtin (builtin_type, "keyword->string", 1, &keyword_to_string, a); + a = init_builtin (builtin_type, "string->symbol", 1, &string_to_symbol, a); + a = init_builtin (builtin_type, "make-symbol", 1, &make_symbol, a); + a = init_builtin (builtin_type, "string->list", 1, &string_to_list, a); + a = init_builtin (builtin_type, "list->string", 1, &list_to_string, a); + a = init_builtin (builtin_type, "read-string", -1, &read_string, a); + a = init_builtin (builtin_type, "string-append", -1, &string_append, a); + a = init_builtin (builtin_type, "string-length", 1, &string_length, a); + a = init_builtin (builtin_type, "string-ref", 2, &string_ref, a); + // src/struct.mes + a = init_builtin (builtin_type, "make-struct", 3, &make_struct, a); + a = init_builtin (builtin_type, "struct-length", 1, &struct_length, a); + a = init_builtin (builtin_type, "struct-ref", 2, &struct_ref, a); + a = init_builtin (builtin_type, "struct-set!", 3, &struct_set_x, a); + // src/vector.mes + a = init_builtin (builtin_type, "core:make-vector", 1, &make_vector_, a); + a = init_builtin (builtin_type, "vector-length", 1, &vector_length, a); + a = init_builtin (builtin_type, "vector-ref", 2, &vector_ref, a); + a = init_builtin (builtin_type, "vector-entry", 1, &vector_entry, a); + a = init_builtin (builtin_type, "vector-set!", 3, &vector_set_x, a); + a = init_builtin (builtin_type, "list->vector", 1, &list_to_vector, a); + a = init_builtin (builtin_type, "vector->list", 1, &vector_to_list, a); return a; } -SCM read_input_file_env (SCM); - int load_boot (char *prefix, char const *boot, char const *location) { @@ -2317,11 +2269,16 @@ load_env () ///((internal)) return r2; } -#include "src/vector.c" -#include "src/strings.c" -#include "src/struct.c" -#include "src/gc.c" -#include "src/reader.c" +#include "hash.c" +#include "module.c" +#include "posix.c" +#include "math.c" +#include "lib.c" +#include "vector.c" +#include "strings.c" +#include "struct.c" +#include "gc.c" +#include "reader.c" int main (int argc, char *argv[]) diff --git a/src/module.c b/src/module.c index 773e1793..79c43dfd 100644 --- a/src/module.c +++ b/src/module.c @@ -53,7 +53,7 @@ make_initial_module (SCM a) ///((internal)) values = cons (locals, values); values = cons (name, values); values = cons (cell_symbol_module, values); - SCM module = make_struct (module_type, values, cell_module_printer); + SCM module = make_struct (module_type, values, cstring_to_symbol ("module-printer")); r0 = cell_nil; r0 = cons (CADR (a), r0); r0 = cons (CAR (a), r0); diff --git a/src/struct.c b/src/struct.c index 0460729d..dea9fdc2 100644 --- a/src/struct.c +++ b/src/struct.c @@ -18,6 +18,11 @@ * along with GNU Mes. If not, see . */ +// CONSTANT STRUCT_TYPE 0 +#define STRUCT_TYPE 0 +// CONSTANT STRUCT_PRINTER 1 +#define STRUCT_PRINTER 1 + SCM make_struct (SCM type, SCM fields, SCM printer) {