summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorschottstaedt <schottstaedt@b278ec2f-9027-4a79-a958-f306da2c2c68>2020-09-29 09:38:27 +0000
committerschottstaedt <schottstaedt@b278ec2f-9027-4a79-a958-f306da2c2c68>2020-09-29 09:38:27 +0000
commitb08bce196003e1075e90872f9814bee3c3dd3db2 (patch)
treea09b43d178a9b39c690d81fc06fd91bc07fa4d46
parent273f923170d251526c8e61039cd624955ec0a276 (diff)
git-svn-id: https://svn.code.sf.net/p/snd/svn1/trunk@959 b278ec2f-9027-4a79-a958-f306da2c2c68
-rw-r--r--notcurses_s7.c37
-rw-r--r--nrepl.scm2
-rw-r--r--s7.c55
-rw-r--r--s7test.scm2
4 files changed, 33 insertions, 63 deletions
diff --git a/notcurses_s7.c b/notcurses_s7.c
index ea530b4..b255fcd 100644
--- a/notcurses_s7.c
+++ b/notcurses_s7.c
@@ -1,7 +1,7 @@
/* s7 FFI for the notcurses library
*
* Fedora: notcurses notcurses-devel notcurses-utils
- * tested in 1.6.19 (fedora 32) -- set NC_1_6_19 below
+ * tested in 1.7.2 (fedora 32) -- set NC_1_7_2 below
* 1.7.4 (fedora 33 via fedora-rawhide) -- set NC_1_7_4 below
*/
@@ -33,10 +33,10 @@ static const char *s7_string_checked(s7_scheme *sc, s7_pointer val)
/* notcurses does not export its version number */
#ifndef NC_1_7_4
- #define NC_1_7_4 1
+ #define NC_1_7_4 0
#endif
-#ifndef NC_1_6_19
- #define NC_1_6_19 0
+#ifndef NC_1_7_2
+ #define NC_1_7_2 1
#endif
#ifndef NC_2_0_0
#define NC_2_0_0 0
@@ -120,12 +120,6 @@ static void init_symbols(s7_scheme *sc)
sigset_t_symbol = s7_make_symbol(sc, "sigset_t*");
}
-#if NC_1_7_4
-#define local_ncdirect_init(A, B, C) ncdirect_init(A, B, C)
-#else
-#define local_ncdirect_init(A, B, C) ncdirect_init(A, B)
-#endif
-
static s7_pointer g_ncdirect_init(s7_scheme *sc, s7_pointer args)
{
s7_pointer termtype;
@@ -140,8 +134,8 @@ static s7_pointer g_ncdirect_init(s7_scheme *sc, s7_pointer args)
flags = s7_integer_checked(sc, s7_caddr(args));
if ((s7_is_c_pointer(termtype)) &&
(s7_c_pointer(termtype) == NULL))
- return(s7_make_c_pointer_with_type(sc, local_ncdirect_init(NULL, fp, flags), ncdirect_symbol, s7_f(sc)));
- return(s7_make_c_pointer_with_type(sc, local_ncdirect_init((const char *)s7_string_checked(sc, termtype), fp, flags), ncdirect_symbol, s7_f(sc)));
+ return(s7_make_c_pointer_with_type(sc, ncdirect_init(NULL, fp, flags), ncdirect_symbol, s7_f(sc)));
+ return(s7_make_c_pointer_with_type(sc, ncdirect_init((const char *)s7_string_checked(sc, termtype), fp, flags), ncdirect_symbol, s7_f(sc)));
}
static s7_pointer g_ncdirect_palette_size(s7_scheme *sc, s7_pointer args)
@@ -3410,7 +3404,12 @@ static s7_pointer g_ncreel_offer_input(s7_scheme *sc, s7_pointer args)
static s7_pointer g_ncreel_destroy(s7_scheme *sc, s7_pointer args)
{
+#if NC_2_0_0
+ ncreel_destroy((struct ncreel *)s7_c_pointer_with_type(sc, s7_car(args), ncreel_symbol, __func__, 1));
+ return(s7_f(sc));
+#else
return(s7_make_integer(sc, ncreel_destroy((struct ncreel *)s7_c_pointer_with_type(sc, s7_car(args), ncreel_symbol, __func__, 1))));
+#endif
}
static s7_pointer g_ncreel_del(s7_scheme *sc, s7_pointer args)
@@ -3425,11 +3424,19 @@ static s7_pointer g_nctablet_userptr(s7_scheme *sc, s7_pointer args)
void_symbol, s7_f(sc)));
}
+#if NC_2_0_0
+static s7_pointer g_nctablet_plane(s7_scheme *sc, s7_pointer args)
+{
+ return(s7_make_c_pointer_with_type(sc, nctablet_plane((struct nctablet *)s7_c_pointer_with_type(sc, s7_car(args), nctablet_symbol, __func__, 1)),
+ ncplane_symbol, s7_f(sc)));
+}
+#else
static s7_pointer g_nctablet_ncplane(s7_scheme *sc, s7_pointer args)
{
return(s7_make_c_pointer_with_type(sc, nctablet_ncplane((struct nctablet *)s7_c_pointer_with_type(sc, s7_car(args), nctablet_symbol, __func__, 1)),
ncplane_symbol, s7_f(sc)));
}
+#endif
#if 0
@@ -4285,7 +4292,7 @@ void notcurses_s7_init(s7_scheme *sc)
nc_func(ncdirect_cursor_pop, 1, 0, false);
nc_func(ncdirect_clear, 1, 0, false);
nc_func(ncdirect_stop, 1, 0, false);
-#if (NC_1_7_4)
+#if NC_1_7_4
nc_func(ncdirect_fg_rgb, 2, 0, false);
nc_func(ncdirect_bg_rgb, 2, 0, false);
#else
@@ -4722,7 +4729,11 @@ void notcurses_s7_init(s7_scheme *sc)
nc_func(ncreel_del, 2, 0, false);
nc_func(ncreel_offer_input, 2, 0, false);
nc_func(nctablet_userptr, 1, 0, false);
+#if NC_2_0_0
+ nc_func(nctablet_plane, 1, 0, false);
+#else
nc_func(nctablet_ncplane, 1, 0, false);
+#endif
nc_func(ncvisual_options_make, 0, 0, false);
nc_func(ncvisual_options_free, 1, 0, false);
diff --git a/nrepl.scm b/nrepl.scm
index b3a7435..6a479ee 100644
--- a/nrepl.scm
+++ b/nrepl.scm
@@ -12,7 +12,7 @@
(unless (defined? '*notcurses*) ; nrepl.c has notcurses_s7.c (thus *notcurses*) built-in
(load "notcurses_s7.so" (inlet 'init_func 'notcurses_s7_init)))
-(unless (string=? (notcurses_version) "1.6.19")
+(unless (string=? (notcurses_version) "1.7.2")
(define ncdirect_fg ncdirect_fg_rgb)
(define ncdirect_bg ncdirect_bg_rgb))
diff --git a/s7.c b/s7.c
index 5f22831..6d3c477 100644
--- a/s7.c
+++ b/s7.c
@@ -106,7 +106,7 @@
* #define HAVE_COMPLEX_NUMBERS 1
* #define HAVE_COMPLEX_TRIG 0
*
- * In windows, both are 0.
+ * In Windows, both are 0.
*
* Some systems (FreeBSD) have complex.h, but some random subset of the trig funcs, so
* HAVE_COMPLEX_NUMBERS means we can find
@@ -8673,9 +8673,7 @@ static s7_pointer call_let_set_fallback(s7_scheme *sc, s7_pointer let, s7_pointe
inline s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
{
s7_pointer x, y;
- /* (let ((a 1)) ((curlet) 'a))
- * ((rootlet) 'abs)
- */
+ /* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */
if (!is_let(let))
return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 1, let, a_let_string));
@@ -74043,7 +74041,8 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
(is_normal_symbol(arg1)))
{
set_optimize_op(expr, OP_APPLY_SA);
- if (is_pair(arg2))
+ if ((is_pair(arg2)) &&
+ (is_normal_symbol(car(arg2)))) /* arg2 might be ((if expr op1 op2) ...) */
{
s7_pointer lister;
lister = lookup(sc, car(arg2));
@@ -87034,7 +87033,6 @@ static s7_pointer update_let_with_four_slots(s7_scheme *sc, s7_pointer let, s7_p
static void make_let_with_four_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4)
{
s7_pointer last_slot;
- /* may need gc protection here */
sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(closure_args(func)), val1, cadr(closure_args(func)), val2);
last_slot = next_slot(let_slots(sc->curlet));
last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(closure_args(func)), val3);
@@ -87533,14 +87531,12 @@ static void op_closure_fx(s7_scheme *sc)
s7_int id;
exprs = cdr(sc->code);
- /* sc->w = exprs; */ /* unnecessary? GC protection, but sc->w can be clobbered by fx_call, sc->code should provide the protection here */
func = opt1_lambda(sc->code);
e = make_let(sc, closure_let(func));
sc->z = e;
pars = closure_args(func);
just_another_slot(sc, e, car(pars));
- /* this and below are wrong because they set local_slot -- need just_another_slot and just_add_slot_at_end -- no id, no value, no local_slot */
last_slot = let_slots(e);
slot_set_pending_value(last_slot, fx_call(sc, exprs));
@@ -94350,7 +94346,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_ERROR_HOOK_QUIT:
op_error_hook_quit(sc);
#if S7_DEBUGGING
- fprintf(stderr, "%d: op_error_hook_quit did not jump, returns %s\n", __LINE__, display(sc->value));
+ fprintf(stderr, "%d: op_error_hook_quit did not jump, sc->value: %s\n", __LINE__, display(sc->value)); /* actually returns #f (below) */
#endif
case OP_EVAL_DONE_NO_MV:
@@ -97574,44 +97570,7 @@ s7_scheme *s7_init(void)
sc->unentry = (hash_entry_t *)malloc(sizeof(hash_entry_t));
hash_entry_set_value(sc->unentry, sc->F);
sc->begin_op = OP_BEGIN1;
- sc->geq_2 = NULL;
-#if (!WITH_GMP)
- sc->seed_symbol = NULL;
- sc->carry_symbol = NULL;
-#endif
- sc->active_symbol = NULL;
- sc->goto_symbol = NULL;
- sc->data_symbol = NULL;
- sc->weak_symbol = NULL;
- sc->dimensions_symbol = NULL;
- sc->info_symbol = NULL;
- sc->c_type_symbol = NULL;
- sc->at_end_symbol = NULL;
- sc->sequence_symbol = NULL;
- sc->position_symbol = NULL;
- sc->entries_symbol = NULL;
- sc->locked_symbol = NULL;
- sc->function_symbol = NULL;
- sc->open_symbol = NULL;
- sc->alias_symbol = NULL;
- sc->current_value_symbol = NULL;
- sc->source_symbol = NULL;
- sc->file_symbol = NULL;
- sc->line_symbol = NULL;
- sc->c_object_let_symbol = NULL;
- sc->class_symbol = NULL;
- sc->c_object_length_symbol = NULL;
- sc->c_object_set_symbol = NULL;
- sc->c_object_ref_symbol = NULL;
- sc->c_object_copy_symbol = NULL;
- sc->c_object_fill_symbol = NULL;
- sc->c_object_reverse_symbol = NULL;
- sc->c_object_to_list_symbol = NULL;
- sc->c_object_to_string_symbol = NULL;
- sc->closed_symbol = NULL;
- sc->port_type_symbol = NULL;
- sc->permanent_objects = NULL;
- sc->permanent_lets = NULL;
+ /* we used to laboriously set various other fields to null, but the calloc takes care of that */
sc->tree_pointers = NULL;
sc->tree_pointers_size = 0;
sc->tree_pointers_top = 0;
@@ -97820,7 +97779,6 @@ void s7_free(s7_scheme *sc)
{
/* free the memory associated with sc
* most pointers are in the saved_pointers table, but any that might be realloc'd need to be handled explicitly
- *
* valgrind --leak-check=full --show-reachable=yes --suppressions=/home/bil/cl/free.supp repl s7test.scm
* valgrind --leak-check=full --show-reachable=yes --gen-suppressions=all --error-limit=no --log-file=raw.log repl s7test.scm
*/
@@ -98181,7 +98139,6 @@ int main(int argc, char **argv)
*
* nrepl+notcurses, menu items, (if selection, C-space+move also),
* colorize: offer hook into all repl output and example of colorizing
- * support for 1.7.2 in fedora 32?
* nc-display, but what about input?
* t725 gaps
*/
diff --git a/s7test.scm b/s7test.scm
index d7d0c1b..3d51d3f 100644
--- a/s7test.scm
+++ b/s7test.scm
@@ -29945,6 +29945,8 @@ in s7:
(test (apply (lambda args (apply list args)) () (cons 1 2)) 'error)
(test (apply (lambda args (apply list args)) (cons 1 2)) 'error)
(test (apply (apply lambda (signature +) '('x)) #i(1)) 'error)
+(test (let () (define (f x) (apply x ((if (> 3 2) list vector) 3 2))) (f +)) 5) ; optimizer bug
+(test (let () (define (f x) (apply x ((if (> 3 2) + -) 3 2))) (f abs)) 'error)
(test (apply "hi" '(1 2)) 'error)
(test ("hi" 1 2) 'error)