From 8e205822cb05ba2dc9ceacdb9fc7b3c3fe3ea0e7 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Thu, 10 Nov 2011 21:51:17 +0900
Subject: [PATCH] adding opcode utilities

---
 lib/chibi/ast.c   | 34 +++++++++++++++++++++++++++++-----
 lib/chibi/ast.sld |  2 +-
 2 files changed, 30 insertions(+), 6 deletions(-)

diff --git a/lib/chibi/ast.c b/lib/chibi/ast.c
index 51198e98..1ebc16d8 100644
--- a/lib/chibi/ast.c
+++ b/lib/chibi/ast.c
@@ -76,6 +76,8 @@ static sexp sexp_translate_opcode_type (sexp ctx, sexp type) {
 
 static sexp sexp_get_opcode_ret_type (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
   sexp res;
+  if (!op)
+    return sexp_type_by_index(ctx, SEXP_OBJECT);
   if (! sexp_opcodep(op))
     return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
   if (sexp_opcode_code(op) == SEXP_OP_RAISE)
@@ -104,7 +106,7 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp
     break;
   default:
     res = sexp_opcode_arg3_type(op);
-    if (sexp_vectorp(res)) {
+    if (res && sexp_vectorp(res)) {
       if (sexp_vector_length(res) > (sexp_unbox_fixnum(k)-2))
         res = sexp_vector_ref(res, sexp_fx_sub(k, SEXP_TWO));
       else
@@ -115,15 +117,34 @@ static sexp sexp_get_opcode_param_type (sexp ctx, sexp self, sexp_sint_t n, sexp
   return sexp_translate_opcode_type(ctx, res);
 }
 
+static sexp sexp_get_opcode_class (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_class(op));
+}
+
+static sexp sexp_get_opcode_code (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  return sexp_make_fixnum(sexp_opcode_code(op));
+}
+
+static sexp sexp_get_opcode_data (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
+  sexp data;
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
+  data = sexp_opcode_data(op);
+  if (!data) return SEXP_VOID;
+  return sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE
+    && 0 <= sexp_unbox_fixnum(data)
+    && sexp_unbox_fixnum(data) <= sexp_context_num_types(ctx) ?
+    sexp_type_by_index(ctx, sexp_unbox_fixnum(data)) : data;
+}
+
 static sexp sexp_get_opcode_num_params (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
-  if (! sexp_opcodep(op))
-    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_fixnum(sexp_opcode_num_args(op));
 }
 
 static sexp sexp_get_opcode_variadic_p (sexp ctx, sexp self, sexp_sint_t n, sexp op) {
-  if (! sexp_opcodep(op))
-    return sexp_type_exception(ctx, self, SEXP_OPCODE, op);
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, op);
   return sexp_make_boolean(sexp_opcode_variadic_p(op));
 }
 
@@ -412,6 +433,9 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char
   sexp_define_foreign(ctx, env, "extend-env", 2, sexp_extend_env);
   sexp_define_foreign(ctx, env, "env-cell", 2, sexp_get_env_cell);
   sexp_define_foreign(ctx, env, "opcode-name", 1, sexp_get_opcode_name);
+  sexp_define_foreign(ctx, env, "opcode-class", 1, sexp_get_opcode_class);
+  sexp_define_foreign(ctx, env, "opcode-code", 1, sexp_get_opcode_code);
+  sexp_define_foreign(ctx, env, "opcode-data", 1, sexp_get_opcode_data);
   sexp_define_foreign(ctx, env, "opcode-variadic?", 1, sexp_get_opcode_variadic_p);
   sexp_define_foreign(ctx, env, "opcode-num-params", 1, sexp_get_opcode_num_params);
   sexp_define_foreign(ctx, env, "opcode-return-type", 1, sexp_get_opcode_ret_type);
diff --git a/lib/chibi/ast.sld b/lib/chibi/ast.sld
index 2be4c90c..4222adb1 100644
--- a/lib/chibi/ast.sld
+++ b/lib/chibi/ast.sld
@@ -24,7 +24,7 @@
    seq-ls seq-ls-set! lit-value lit-value-set!
    exception-kind exception-message exception-irritants
    opcode-name opcode-num-params opcode-return-type opcode-param-type
-   opcode-variadic?
+   opcode-class opcode-code opcode-data opcode-variadic?
    macro-procedure macro-env macro-source
    procedure-code procedure-vars procedure-name procedure-name-set!
    bytecode-name bytecode-literals bytecode-source