From 9b3934d332bf09d05f46fa7aa4563384271f262b Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Mon, 11 Nov 2019 23:07:22 +0100 Subject: [PATCH] mes: Add hash-for-each. WIP! split me: fixup hash/make-hash table hacks. * mes/module/mes/scm.mes (hash-for-each): New function. * mes/module/mes/type-0.mes (cell:type-name): Resurrect. * src/hash.c (hash_): Hack: allow non-string keys. (make_hash_table_type): Rename from make_hash_type. WIP (hash_table_p): New function. (hash_clear_x): New function. * src/module.c (make_module_type): Rewrite. (module_p): x (get_pre_modules_obarray): x --- include/mes/builtins.h | 4 +++ include/mes/mes.h | 2 +- mes/module/mes/scm.mes | 5 ++++ mes/module/mes/type-0.mes | 2 +- src/builtins.c | 4 +++ src/hash.c | 55 +++++++++++++++++++++++++++------------ src/module.c | 39 ++++++++++++++++++++------- 7 files changed, 83 insertions(+), 28 deletions(-) diff --git a/include/mes/builtins.h b/include/mes/builtins.h index 41fa68ee..affab4ca 100644 --- a/include/mes/builtins.h +++ b/include/mes/builtins.h @@ -71,7 +71,9 @@ struct scm *hashq_set_x (struct scm *table, struct scm *key, struct scm *value); struct scm *hash_set_x (struct scm *table, struct scm *key, struct scm *value); struct scm *hash_table_printer (struct scm *table); struct scm *make_hash_table (struct scm *x); +struct scm *hash_table_p (struct scm *x); struct scm *hash_map_to_list (struct scm *proc, struct scm *table); +struct scm *hash_clear_x (struct scm *table); /* src/lib.c */ struct scm *type_ (struct scm *x); struct scm *car_ (struct scm *x); @@ -99,10 +101,12 @@ struct scm *logxor (struct scm *x); struct scm *ash (struct scm *n, struct scm *count); /* src/module.c */ struct scm *make_module_type (); +struct scm *module_p (struct scm *module); struct scm *module_printer (struct scm *module); struct scm *module_variable (struct scm *module, struct scm *name); struct scm *module_ref (struct scm *module, struct scm *name); struct scm *module_define_x (struct scm *module, struct scm *name, struct scm *value); +struct scm *get_pre_modules_obarray (); /* src/posix.c */ struct scm *abort_ (); struct scm *exit_ (struct scm *x); diff --git a/include/mes/mes.h b/include/mes/mes.h index 5311887f..bf783eb2 100644 --- a/include/mes/mes.h +++ b/include/mes/mes.h @@ -133,7 +133,7 @@ struct scm *make_value_cell (long type, long car, long cdr); struct scm *make_char (int n); struct scm *make_continuation (long n); struct scm *make_hash_table_ (long size); -struct scm *make_hashq_type (); +struct scm *make_hash_table_type (); struct scm *make_initial_module (struct scm *a); struct scm *make_macro (struct scm *name, struct scm *x); struct scm *make_number (long n); diff --git a/mes/module/mes/scm.mes b/mes/module/mes/scm.mes index 9909c426..d8625a57 100644 --- a/mes/module/mes/scm.mes +++ b/mes/module/mes/scm.mes @@ -205,6 +205,11 @@ (define (hash-fold proc init table) (fold proc init (hash-map->list cons table))) +(define (hash-for-each proc table) + (hash-map->list proc table) + ;;(hash-fold (lambda (key value x) (proc key value)) #f table) + *unspecified*) + ;; Variable (define (make-undefined-variable) diff --git a/mes/module/mes/type-0.mes b/mes/module/mes/type-0.mes index beefbf06..083a26b6 100644 --- a/mes/module/mes/type-0.mes +++ b/mes/module/mes/type-0.mes @@ -45,7 +45,7 @@ (cons (quote )))) (define (cell:type-name x) - (cond ((assq (core:type x) cell:type-alist) => cdr))) + (assq-ref cell:type-alist (core:type x))) (define (bytes? x) (eq? (core:type x) )) diff --git a/src/builtins.c b/src/builtins.c index e7c679d6..b36aece7 100644 --- a/src/builtins.c +++ b/src/builtins.c @@ -180,8 +180,10 @@ mes_builtins (struct scm *a) /*:((internal)) */ 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, "hash-table?", 1, &hash_table_p, a); a = init_builtin (builtin_type, "make-hash-table", -1, &make_hash_table, a); a = init_builtin (builtin_type, "hash-map->list", 2, &hash_map_to_list, a); + a = init_builtin (builtin_type, "hash-clear!", 1, &hash_clear_x, a); /* src/lib.c */ a = init_builtin (builtin_type, "core:type", 1, &type_, a); a = init_builtin (builtin_type, "core:car", 1, &car_, a); @@ -209,10 +211,12 @@ mes_builtins (struct scm *a) /*:((internal)) */ a = init_builtin (builtin_type, "ash", 2, &ash, a); /* src/module.c */ a = init_builtin (builtin_type, "make-module-type", 0, &make_module_type, a); + a = init_builtin (builtin_type, "module?", 1, &module_p, 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); + a = init_builtin (builtin_type, "%get-pre-modules-obarray", 0, &get_pre_modules_obarray, a); /* src/posix.c */ a = init_builtin (builtin_type, "abort", 0, &abort_, a); a = init_builtin (builtin_type, "exit", 1, &exit_, a); diff --git a/src/hash.c b/src/hash.c index a7977ec6..404cad55 100644 --- a/src/hash.c +++ b/src/hash.c @@ -46,13 +46,9 @@ hashq_ (struct scm *x, long size) int hash_ (struct scm *x, long size) { - if (x->type != TSTRING) - { - eputs ("hash_ failed, not a string:"); - display_error_ (x); - assert_msg (0, "0"); - } - return hash_cstring (cell_bytes (x->string), size); + if (x->type == TSTRING) + return hash_cstring (cell_bytes (x->string), size); + return 0; } struct scm * @@ -176,15 +172,21 @@ hash_table_printer (struct scm *table) fdputc ('>', __stdout); } +struct scm *scm_hash_table_type; /* FIXME: gc */ + struct scm * -make_hashq_type () /*:((internal)) */ +make_hash_table_type () /*:((internal)) */ { - struct scm *fields = cell_nil; - fields = cons (cell_symbol_buckets, fields); - fields = cons (cell_symbol_size, fields); - fields = cons (fields, cell_nil); - fields = cons (cell_symbol_hashq_table, fields); - return make_struct (cell_symbol_record_type, fields, cell_unspecified); + if (scm_hash_table_type == 0) + { + struct scm *fields = cell_nil; + fields = cons (cell_symbol_buckets, fields); + fields = cons (cell_symbol_size, fields); + fields = cons (fields, cell_nil); + fields = cons (cell_symbol_hashq_table, fields); + scm_hash_table_type = make_struct (cell_symbol_record_type, fields, cell_unspecified); + } + return scm_hash_table_type; /* FIXME: gc */ } struct scm * @@ -192,7 +194,7 @@ make_hash_table_ (long size) { if (size == 0) size = 100; - struct scm *hashq_type = make_hashq_type (); + struct scm *type = make_hash_table_type (); struct scm *buckets = make_vector_ (size, cell_unspecified); struct scm *values = cell_nil; @@ -200,8 +202,17 @@ make_hash_table_ (long size) values = cons (make_number (size), values); values = cons (cell_symbol_hashq_table, values); /*FIXME: symbol/printer - return make_struct (hashq_type, values, cstring_to_symbol ("hash-table-printer");*/ - return make_struct (hashq_type, values, cell_unspecified); + return make_struct (type, values, cstring_to_symbol ("hash-table-printer");*/ + return make_struct (type, values, cell_unspecified); +} + +struct scm * +hash_table_p (struct scm *table) +{ + if (table->type == TSTRUCT + && struct_ref_ (table, 0) == scm_hash_table_type) + return cell_t; + return cell_f; } struct scm * @@ -239,3 +250,13 @@ hash_map_to_list (struct scm *proc, struct scm *table) } return lst; } + +struct scm * +hash_clear_x (struct scm *table) +{ + struct scm *s = struct_ref_ (table, 3); + long size = s->value; + struct scm *buckets = make_vector_ (size, cell_unspecified); + struct_set_x_ (table, 4, buckets); + return cell_unspecified; +} diff --git a/src/module.c b/src/module.c index 413910ff..d20d7584 100644 --- a/src/module.c +++ b/src/module.c @@ -21,16 +21,31 @@ #include "mes/lib.h" #include "mes/mes.h" +struct scm *scm_module_type; /* FIXME: gc */ + struct scm * make_module_type () /*:(internal)) */ { - struct scm *fields = cell_nil; - fields = cons (cstring_to_symbol ("globals"), fields); - fields = cons (cstring_to_symbol ("locals"), fields); - fields = cons (cstring_to_symbol ("name"), fields); - fields = cons (fields, cell_nil); - fields = cons (cell_symbol_module, fields); - return make_struct (cell_symbol_record_type, fields, cell_unspecified); + if (scm_module_type == 0) + { + struct scm *fields = cell_nil; + fields = cons (cstring_to_symbol ("globals"), fields); + fields = cons (cstring_to_symbol ("locals"), fields); + fields = cons (cstring_to_symbol ("name"), fields); + fields = cons (fields, cell_nil); + fields = cons (cell_symbol_module, fields); + scm_module_type = make_struct (cell_symbol_record_type, fields, cell_unspecified); + } + return scm_module_type; +} + +struct scm * +module_p (struct scm *module) +{ + if (module->type == TSTRUCT + && struct_ref_ (module, 0) == scm_module_type) + return cell_t; + return cell_f; } struct scm * @@ -39,8 +54,8 @@ make_initial_module (struct scm *a) /*:((internal)) */ struct scm *module_type = make_module_type (); a = acons (cell_symbol_module, module_type, a); - struct scm *hashq_type = make_hashq_type (); - a = acons (cell_symbol_hashq_table, hashq_type, a); + struct scm *hash_table_type = make_hash_table_type (); + a = acons (cell_symbol_hashq_table, hash_table_type, a); struct scm *name = cons (cstring_to_symbol ("boot"), cell_nil); struct scm *globals = make_hash_table_ (0); @@ -114,3 +129,9 @@ module_define_x (struct scm *module, struct scm *name, struct scm *value) struct scm *globals = struct_ref_ (module, 5); return hashq_set_x (globals, name, value); } + +struct scm * +get_pre_modules_obarray () /*:((name . "%get-pre-modules-obarray")) */ +{ + return R0; +}