From 49f95dc1076e8c959799573a15da85f780a20d97 Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Wed, 5 Oct 2022 09:06:51 +0900
Subject: [PATCH] Fix bug in procedure-flags in (chibi ast) (issue #864)

We were incorrectly boxing an already boxed value.
---
 include/chibi/sexp.h  | 2 +-
 lib/chibi/ast.c       | 2 +-
 lib/srfi/229/test.sld | 7 ++++++-
 tests/lib-tests.scm   | 2 ++
 4 files changed, 10 insertions(+), 3 deletions(-)

diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
index 3ff3b53b..a3d6f8e9 100644
--- a/include/chibi/sexp.h
+++ b/include/chibi/sexp.h
@@ -533,7 +533,7 @@ struct sexp_struct {
     } bytecode;
     struct {
       sexp bc, vars;
-      char flags;
+      char flags;  /* a boxed fixnum truncated to char */
       sexp_proc_num_args_t num_args;
     } procedure;
     struct {
diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c
index 1432d028..51df718d 100644
--- a/lib/chibi/ast.c
+++ b/lib/chibi/ast.c
@@ -105,7 +105,7 @@ sexp sexp_get_procedure_variable_transformer_p (sexp ctx, sexp self, sexp_sint_t
 
 sexp sexp_get_procedure_flags (sexp ctx, sexp self, sexp_sint_t n, sexp proc) {
   sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, proc);
-  return sexp_make_fixnum(sexp_procedure_flags(proc));
+  return (sexp) (sexp_uint_t) sexp_procedure_flags(proc);
 }
 
 sexp sexp_make_variable_transformer_op (sexp ctx, sexp self, sexp_sint_t n, sexp base_proc) {
diff --git a/lib/srfi/229/test.sld b/lib/srfi/229/test.sld
index 95ef9c33..a9951e9f 100644
--- a/lib/srfi/229/test.sld
+++ b/lib/srfi/229/test.sld
@@ -14,11 +14,16 @@
           (lambda/tag 43
                       (x)
                       (* x x)))
+        (define g
+          (lambda/tag 44 args (apply list args)))
         (test-assert (procedure/tag? f))
         (test-not (procedure/tag? (lambda (x) (* x x))))
         (test-not (procedure/tag? +))
         (test 9 (f 3))
         (test 42 (procedure-tag f))
         (test-not (eqv? f f*))
-        (test 43 (procedure-tag f*)))
+        (test 43 (procedure-tag f*))
+        (test 44 (procedure-tag g))
+        (test '(1) (g 1))
+        (test '(1 2 3) (g 1 2 3)))
       (test-end))))
diff --git a/tests/lib-tests.scm b/tests/lib-tests.scm
index e66a6480..a1380a77 100644
--- a/tests/lib-tests.scm
+++ b/tests/lib-tests.scm
@@ -35,6 +35,7 @@
         (rename (srfi 160 test) (run-tests run-srfi-160-tests))
         (rename (srfi 166 test) (run-tests run-srfi-166-tests))
         (rename (srfi 219 test) (run-tests run-srfi-219-tests))
+        (rename (srfi 229 test) (run-tests run-srfi-229-tests))
         (rename (scheme bytevector-test) (run-tests run-scheme-bytevector-tests))
         (rename (chibi assert-test) (run-tests run-assert-tests))
         (rename (chibi base64-test) (run-tests run-base64-tests))
@@ -106,6 +107,7 @@
 (run-srfi-160-tests)
 (run-srfi-166-tests)
 (run-srfi-219-tests)
+(run-srfi-229-tests)
 (run-scheme-bytevector-tests)
 (run-assert-tests)
 (run-base64-tests)