C++ SCM_ASSERT函数代码示例

void
graphicsGdImageMarkDestroyed(ScmObj obj)
{
  SCM_ASSERT(SCM_FOREIGN_POINTER_P(obj));
  Scm_ForeignPointerAttrSet(SCM_FOREIGN_POINTER(obj),
							sym_destroyed, SCM_TRUE);
}

int
graphicsGdImageDestroyedP(ScmObj obj)
{
  SCM_ASSERT(SCM_FOREIGN_POINTER_P(obj));
  return !SCM_FALSEP(Scm_ForeignPointerAttrGet(SCM_FOREIGN_POINTER(obj),
											   sym_destroyed, SCM_FALSE));
}

/*------------------------------------------------------------
 * Vport Getb
 */
static int vport_getb(ScmPort *p)
{
    vport *data = (vport*)p->src.vt.data;
    SCM_ASSERT(data != NULL);

    if (SCM_FALSEP(data->getb_proc)) {
        /* If the port doesn't have get-byte method, use get-char
           if possible. */
        char buf[SCM_CHAR_MAX_BYTES];

        if (SCM_FALSEP(data->getc_proc)) return EOF;
        ScmObj ch = Scm_ApplyRec(data->getc_proc, SCM_NIL);
        if (!SCM_CHARP(ch)) return EOF;

        ScmChar c = SCM_CHAR_VALUE(ch);
        int nb = SCM_CHAR_NBYTES(c);
        SCM_CHAR_PUT(buf, c);

        for (int i=1; i<nb; i++) {
            /* pushback for later use.  this isn't very efficient;
               if efficiency becomes a problem, we need another API
               to pushback multiple bytes. */
            Scm_UngetbUnsafe(buf[i], p);
        }
        return (unsigned char)buf[0];
    } else {
        ScmObj b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
        if (!SCM_INTP(b)) return EOF;
        return (SCM_INT_VALUE(b) & 0xff);
    }
}

/*------------------------------------------------------------
 * Vport puts
 */
static void vport_puts(ScmString *s, ScmPort *p)
{
    vport *data = (vport*)p->src.vt.data;
    const ScmStringBody *b = SCM_STRING_BODY(s);
    SCM_ASSERT(data != NULL);

    if (!SCM_FALSEP(data->puts_proc)) {
        Scm_ApplyRec(data->puts_proc, SCM_LIST1(SCM_OBJ(s)));
    } else if (SCM_STRING_BODY_INCOMPLETE_P(b)
               || (SCM_FALSEP(data->putc_proc)
                   && !SCM_FALSEP(data->putb_proc))) {
        /* we perform binary output */
        vport_putz(SCM_STRING_BODY_START(b), SCM_STRING_BODY_SIZE(b), p);
    } else if (!SCM_FALSEP(data->putc_proc)) {
        const char *cp = SCM_STRING_BODY_START(b);
        for (int i=0; i < (int)SCM_STRING_BODY_LENGTH(b); i++) {
            ScmChar c;
            SCM_CHAR_GET(cp, c);
            cp += SCM_CHAR_NFOLLOWS(*cp)+1;
            Scm_ApplyRec(data->putc_proc, SCM_LIST1(SCM_MAKE_CHAR(c)));
        }
    } else {
        Scm_PortError(p, SCM_PORT_ERROR_OTHER,
                      "cannot perform output to the port %S", p);
    }
}

/**
 * Replace entire content of recentmost frame of an env
 *
 * The environment must be replaced with returned one in caller side even if
 * this implementation returns identical to the one passed. This rule is
 * required to be compatible with future alternative implementations.
 */
SCM_EXPORT ScmObj
scm_replace_environment(ScmObj formals, ScmObj actuals, ScmObj env)
{
    ScmObj frame;
    DECLARE_INTERNAL_FUNCTION("scm_replace_environment");

    SCM_ASSERT(scm_valid_environment_extensionp(formals, actuals));
    SCM_ASSERT(VALID_ENVP(env));
    SCM_ASSERT(CONSP(env));

    frame = CAR(env);
    SET_CAR(frame, formals);
    SET_CDR(frame, actuals);

    return env;
}

/* places a single char in the input buffer.  */
static int 
sf_fill_input (SCM port)
{
  SCM p = SCM_PACK (SCM_STREAM (port));
  SCM ans;
  scm_t_port *pt;

  ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char.  */
  if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
    return EOF;
  SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
  pt = SCM_PTAB_ENTRY (port);    

  if (pt->encoding == NULL)
    {
      scm_t_port *pt = SCM_PTAB_ENTRY (port);    
      
      *pt->read_buf = SCM_CHAR (ans);
      pt->read_pos = pt->read_buf;
      pt->read_end = pt->read_buf + 1;
      return *pt->read_buf;
    }
  else
    scm_ungetc_unlocked (SCM_CHAR (ans), port);
  return SCM_CHAR (ans);
}

/*------------------------------------------------------------
 * Vport Getc
 */
static int vport_getc(ScmPort *p)
{
    vport *data = (vport*)p->src.vt.data;
    SCM_ASSERT(data != NULL);

    if (SCM_FALSEP(data->getc_proc)) {
        /* If the port doesn't have get-char method, try get-byte */
        char buf[SCM_CHAR_MAX_BYTES];

        if (SCM_FALSEP(data->getb_proc)) return EOF;
        ScmObj b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
        if (!SCM_INTP(b)) return EOF;
        buf[0] = (char)SCM_INT_VALUE(b);
        int n = SCM_CHAR_NFOLLOWS(p->scratch[0]);
        for (int i=0; i<n; i++) {
            b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
            if (!SCM_INTP(b)) {
                /* TODO: should raise an exception? */
                return EOF;
            }
            buf[i+1] = (char)SCM_INT_VALUE(b);
        }
        ScmChar ch;
        SCM_CHAR_GET(buf, ch);
        return ch;
    } else {
        ScmObj ch = Scm_ApplyRec(data->getc_proc, SCM_NIL);
        if (!SCM_CHARP(ch)) return EOF;
        return SCM_CHAR_VALUE(ch);
    }
}

/*
 * External entry to manage registering callbacks
 * 'xtra1' and 'xtra2' are ignored by most callbacks; only the two callbacks
 * use them:
 *   glutTimerFunc: xtra1 for millliseconds, xtra2 for value
 *   glutJoystickFunc: xtra1 for interval
 */
void Scm_GlutRegisterCallback(int type, ScmObj closure, int xtra1, int xtra2)
{
    SCM_ASSERT(type >= 0 && type < SCM_GLUT_NUM_CBS);
    if (type < SCM_GLUT_NUM_WINDOW_CBS) {
        int win = glutGetWindow();
        ScmObj entry = Scm_HashTableRef(SCM_HASH_TABLE(ScmGlutCallbackTable),
                                        SCM_MAKE_INT(win), SCM_FALSE);
        
        if (SCM_EQ(entry, SCM_FALSE)) {
            entry = Scm_MakeVector(SCM_GLUT_NUM_WINDOW_CBS, SCM_FALSE);
            Scm_HashTableSet(SCM_HASH_TABLE(ScmGlutCallbackTable),
                             SCM_MAKE_INT(win), entry, 0);
        }
        SCM_VECTOR_ELEMENT(entry, type) = closure;
        registrars[type](!SCM_FALSEP(closure), xtra1);
    } else if (type == SCM_GLUT_CB_IDLE) {
        idle_closure = closure;
        if (SCM_FALSEP(closure)) {
            glutIdleFunc(NULL);
        } else {
            glutIdleFunc(idle_cb);
        }
    } else {
        timer_closure = closure;
        if (!SCM_FALSEP(closure)) {
            glutTimerFunc(xtra1, timer_cb, xtra2);
        }
    }
}

/*! \brief Add a directory to the Guile load path.
 * \par Function Description
 * Prepends \a s_path to the Guile system '%load-path', after
 * expanding environment variables.
 *
 *  \param [in] s_path  Path to be added.
 *  \return SCM_BOOL_T.
 */
SCM g_rc_scheme_directory(SCM s_path)
{
  char *temp;
  gchar *expanded;
  SCM s_load_path_var;
  SCM s_load_path;

  SCM_ASSERT (scm_is_string (s_path), s_path,
              SCM_ARG1, "scheme-directory");

  /* take care of any shell variables */
  temp = scm_to_utf8_string (s_path);
  expanded = s_expand_env_variables (temp);
  s_path = scm_from_utf8_string (expanded);
  free (temp);
  g_free (expanded);

  s_load_path_var = scm_c_lookup ("%load-path");
  s_load_path = scm_variable_ref (s_load_path_var);
  scm_variable_set_x (s_load_path_var, scm_cons (s_path, s_load_path));

  scm_remember_upto_here_2 (s_load_path_var, s_load_path);
  scm_remember_upto_here_1 (s_path);

  return SCM_BOOL_T;
}

/*! \todo Finish function description!!!
 *  \brief
 *  \par Function Description
 *
 *  \param [in] path  
 *  \return SCM_BOOL_T on success, SCM_BOOL_F otherwise.
 */
SCM g_rc_bitmap_directory(SCM path)
{
  gchar *string;
  char *temp;

  SCM_ASSERT (scm_is_string (path), path,
              SCM_ARG1, "bitmap-directory");
  
  /* take care of any shell variables */
  temp = scm_to_utf8_string (path);
  string = s_expand_env_variables (temp);
  free (temp);

  /* invalid path? */
  if (!g_file_test (string, G_FILE_TEST_IS_DIR)) {
    fprintf (stderr,
             "Invalid path [%s] passed to bitmap-directory\n",
             string);
    g_free(string);
    return SCM_BOOL_F;
  }

  g_free(default_bitmap_directory);
  default_bitmap_directory = string;

  return SCM_BOOL_T;
}

/* this function will only return a unique list of packages */
SCM g_get_packages(SCM level)
{
    SCM list = SCM_EOL;
    GHashTable *ht;

    NETLIST *nl_current = NULL;

    SCM_ASSERT(scm_is_string (level), level, SCM_ARG1, "gnetlist:get-pins");

    /* build a hash table */
    ht = g_hash_table_new (g_str_hash, g_str_equal);
    for (nl_current = netlist_head; nl_current != NULL;
         nl_current = nl_current->next) {
      if (nl_current->component_uref != NULL) {
        /* add component_uref in the hash table */
        /* uniqueness of component_uref is guaranteed by the hashtable */

        if (g_hash_table_lookup (ht, nl_current->component_uref) == NULL) {
          g_hash_table_insert (ht, nl_current->component_uref,
                                   nl_current->component_uref);
          list = scm_cons (scm_makfrom0str (nl_current->component_uref), list);
        }
      }
    }
    g_hash_table_destroy (ht);

    return list;
}

/*! \todo Finish function documentation!!!
 *  \brief
 *  \par Function Description
 *
 */
SCM g_rc_mode_general(SCM scmmode, 
                      const char *rc_name,
                      int *mode_var,
                      const vstbl_entry *table,
                      int table_size)
{
  SCM ret;
  int index;
  char *mode;

  SCM_ASSERT (scm_is_string (scmmode), scmmode,
              SCM_ARG1, rc_name);
  
  mode = scm_to_utf8_string (scmmode);
  
  index = vstbl_lookup_str(table, table_size, mode);
  /* no match? */
  if(index == table_size) {
    fprintf(stderr,
            "Invalid mode [%s] passed to %s\n",
            mode,
            rc_name);
    ret = SCM_BOOL_F;
  } else {
    *mode_var = vstbl_get_val(table, index);
    ret = SCM_BOOL_T;
  }

  free (mode);

  return ret;
}

/*
 *Returns a list of the pins of the <B>object smob</B>.
 */
SCM g_get_object_pins (SCM object_smob)
{
    TOPLEVEL *toplevel=NULL;
    OBJECT *object=NULL;
    OBJECT *prim_obj;
    GList *iter;
    SCM returned=SCM_EOL;

    /* Get toplevel and o_current */
    SCM_ASSERT (g_get_data_from_object_smob (object_smob, &toplevel, &object),
                object_smob, SCM_ARG1, "get-object-pins");

    if (!object) {
        return (returned);
    }
    if (object->complex && object->complex->prim_objs) {
        iter = object->complex->prim_objs;
        while (iter != NULL) {
            prim_obj = (OBJECT *)iter->data;
            if (prim_obj->type == OBJ_PIN) {
                returned = scm_cons (g_make_object_smob(toplevel, prim_obj),returned);
            }
            iter = g_list_next (iter);
        }
    }

    return (returned);
}

void Scm_PutbUnsafe(ScmByte b, ScmPort *p)
#endif
{
    VMDECL;
    SHORTCUT(p, Scm_PutbUnsafe(b, p); return);
    WALKER_CHECK(p);
    LOCK(p);
    CLOSE_CHECK(p);

    switch (SCM_PORT_TYPE(p)) {
    case SCM_PORT_FILE:
        if (p->src.buf.current >= p->src.buf.end) {
            SAFE_CALL(p, bufport_flush(p, (int)(p->src.buf.current - p->src.buf.buffer), FALSE));
        }
        SCM_ASSERT(p->src.buf.current < p->src.buf.end);
        *p->src.buf.current++ = b;
        if (SCM_PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) {
            SAFE_CALL(p, bufport_flush(p, 1, FALSE));
        }
        UNLOCK(p);
        break;
    case SCM_PORT_OSTR:
        SCM_DSTRING_PUTB(&p->src.ostr, b);
        UNLOCK(p);
        break;
    case SCM_PORT_PROC:
        SAFE_CALL(p, p->src.vt.Putb(b, p));
        UNLOCK(p);
        break;
    default:
        UNLOCK(p);
        Scm_PortError(p, SCM_PORT_ERROR_OUTPUT,
                      "bad port type for output: %S", p);
    }
}

/*------------------------------------------------------------
 * Vport Gets
 */
static int vport_getz(char *buf, int buflen, ScmPort *p)
{
    vport *data = (vport*)p->src.vt.data;
    SCM_ASSERT(data != NULL);

    if (!SCM_FALSEP(data->gets_proc)) {
        u_int size;
        ScmObj s = Scm_ApplyRec(data->gets_proc,
                                SCM_LIST1(SCM_MAKE_INT(buflen)));
        if (!SCM_STRINGP(s)) return EOF;
        const char *start = Scm_GetStringContent(SCM_STRING(s), &size,
                                                 NULL, NULL);
        if ((int)size > buflen) {
            /* NB: should raise an exception? */
            memcpy(buf, start, buflen);
            return buflen;
        } else {
            memcpy(buf, start, size);
            return size;
        }
    } else {
        int i = 0;
        for (; i<buflen; i++) {
            int byte = vport_getb(p);
            if (byte == EOF) break;
            buf[i] = byte;
        }
        if (i==0) return EOF;
        else return i;
    }
}