libguile/instructions.c

   1 /* Copyright (C) 2001 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 #if HAVE_CONFIG_H
  43 #  include <config.h>
  44 #endif
  45
  46 #include <string.h>
  47 #include "vm-bootstrap.h"
  48 #include "instructions.h"
  49
  50 struct scm_instruction {
  51   enum scm_opcode opcode;       /* opcode */
  52   const char *name;             /* instruction name */
  53   signed char len;              /* Instruction length.  This may be -1 for
  54                                    the loader (see the `VM_LOADER'
  55                                    macro).  */
  56   signed char npop;             /* The number of values popped.  This may be
  57                                    -1 for insns like `call' which can take
  58                                    any number of arguments.  */
  59   char npush;                   /* the number of values pushed */
  60   SCM symname;                  /* filled in later */
  61 };
  62
  63 #define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar)               \
  64   do {                                                                \
  65     cvar = scm_lookup_instruction_by_name (var);                      \
  66     SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P");     \
  67   } while (0)
  68
  69
  70 static struct scm_instruction*
  71 fetch_instruction_table ()
  72 {
  73   static struct scm_instruction *table = NULL;
  74
  75   if (SCM_UNLIKELY (!table))
  76     {
  77       size_t bytes = scm_op_last * sizeof(struct scm_instruction);
  78       int i;
  79       table = malloc (bytes);
  80       memset (table, 0, bytes);
  81 #define VM_INSTRUCTION_TO_TABLE 1
  82 #include "vm-expand.h"
  83 #include "vm-i-system.i"
  84 #include "vm-i-scheme.i"
  85 #include "vm-i-loader.i"
  86 #undef VM_INSTRUCTION_TO_TABLE
  87       for (i = 0; i < scm_op_last; i++)
  88         {
  89           table[i].opcode = i;
  90           if (table[i].name)
  91             table[i].symname = scm_from_locale_symbol (table[i].name);
  92           else
  93             table[i].symname = SCM_BOOL_F;
  94         }
  95     }
  96   return table;
  97 }
  98
  99 static struct scm_instruction *
 100 scm_lookup_instruction_by_name (SCM name)
 101 {
 102   static SCM instructions_by_name = SCM_BOOL_F;
 103   struct scm_instruction *table = fetch_instruction_table ();
 104   SCM op;
 105
 106   if (SCM_UNLIKELY (SCM_FALSEP (instructions_by_name)))
 107     {
 108       int i;
 109       instructions_by_name = scm_make_hash_table (SCM_I_MAKINUM (scm_op_last));
 110       for (i = 0; i < scm_op_last; i++)
 111         if (scm_is_true (table[i].symname))
 112           scm_hashq_set_x (instructions_by_name, table[i].symname,
 113                            SCM_I_MAKINUM (i));
 114       instructions_by_name = scm_permanent_object (instructions_by_name);
 115     }
 116
 117   op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
 118   if (SCM_I_INUMP (op))
 119     return &table[SCM_I_INUM (op)];
 120
 121   return NULL;
 122 }
 123
 124
 125 /* Scheme interface */
 126
 127 SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
 128             (void),
 129             "")
 130 #define FUNC_NAME s_scm_instruction_list
 131 {
 132   SCM list = SCM_EOL;
 133   struct scm_instruction *ip;
 134   for (ip = fetch_instruction_table (); ip->opcode != scm_op_last; ip++)
 135     if (ip->name)
 136       list = scm_cons (ip->symname, list);
 137   return scm_reverse_x (list, SCM_EOL);
 138 }
 139 #undef FUNC_NAME
 140
 141 SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
 142             (SCM obj),
 143             "")
 144 #define FUNC_NAME s_scm_instruction_p
 145 {
 146   return SCM_BOOL (scm_lookup_instruction_by_name (obj));
 147 }
 148 #undef FUNC_NAME
 149
 150 SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
 151             (SCM inst),
 152             "")
 153 #define FUNC_NAME s_scm_instruction_length
 154 {
 155   struct scm_instruction *ip;
 156   SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
 157   return SCM_I_MAKINUM (ip->len);
 158 }
 159 #undef FUNC_NAME
 160
 161 SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
 162             (SCM inst),
 163             "")
 164 #define FUNC_NAME s_scm_instruction_pops
 165 {
 166   struct scm_instruction *ip;
 167   SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
 168   return SCM_I_MAKINUM (ip->npop);
 169 }
 170 #undef FUNC_NAME
 171
 172 SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
 173             (SCM inst),
 174             "")
 175 #define FUNC_NAME s_scm_instruction_pushes
 176 {
 177   struct scm_instruction *ip;
 178   SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
 179   return SCM_I_MAKINUM (ip->npush);
 180 }
 181 #undef FUNC_NAME
 182
 183 SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
 184             (SCM inst),
 185             "")
 186 #define FUNC_NAME s_scm_instruction_to_opcode
 187 {
 188   struct scm_instruction *ip;
 189   SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
 190   return SCM_I_MAKINUM (ip->opcode);
 191 }
 192 #undef FUNC_NAME
 193
 194 SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
 195             (SCM op),
 196             "")
 197 #define FUNC_NAME s_scm_opcode_to_instruction
 198 {
 199   int opcode;
 200   SCM ret = SCM_BOOL_F;
 201
 202   SCM_MAKE_VALIDATE (1, op, I_INUMP);
 203   opcode = SCM_I_INUM (op);
 204
 205   if (opcode < scm_op_last)
 206     ret = fetch_instruction_table ()[opcode].symname;
 207
 208   if (scm_is_false (ret))
 209     scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");
 210
 211   return ret;
 212 }
 213 #undef FUNC_NAME
 214
 215 void
 216 scm_bootstrap_instructions (void)
 217 {
 218 }
 219
 220 void
 221 scm_init_instructions (void)
 222 {
 223   scm_bootstrap_vm ();
 224
 225 #ifndef SCM_MAGIC_SNARFER
 226 #include "instructions.x"
 227 #endif
 228 }
 229
 230 /*
 231   Local Variables:
 232   c-file-style: "gnu"
 233   End:
 234 */