/* read a problem from a file; use %g for integers to avoid int conflicts */
problem *get_problem (FILE *f, double tol)
{
cs *T, *A, *C ;
int sym, m, n, mn, nz1, nz2 ;
problem *Prob ;
Prob = cs_calloc (1, sizeof (problem)) ;
if (!Prob) return (NULL) ;
T = cs_load (f) ; /* load triplet matrix T from a file */
Prob->A = A = cs_compress (T) ; /* A = compressed-column form of T */
cs_spfree (T) ; /* clear T */
if (!cs_dupl (A)) return (free_problem (Prob)) ; /* sum up duplicates */
Prob->sym = sym = is_sym (A) ; /* determine if A is symmetric */
m = A->m ; n = A->n ;
mn = CS_MAX (m,n) ;
nz1 = A->p [n] ;
cs_dropzeros (A) ; /* drop zero entries */
nz2 = A->p [n] ;
if (tol > 0) cs_droptol (A, tol) ; /* drop tiny entries (just to test) */
Prob->C = C = sym ? make_sym (A) : A ; /* C = A + triu(A,1)', or C=A */
if (!C) return (free_problem (Prob)) ;
printf ("\n--- Matrix: %g-by-%g, nnz: %g (sym: %g: nnz %g), norm: %8.2e\n",
(double) m, (double) n, (double) (A->p [n]), (double) sym,
(double) (sym ? C->p [n] : 0), cs_norm (C)) ;
if (nz1 != nz2) printf ("zero entries dropped: %g\n", (double) (nz1 - nz2));
if (nz2 != A->p [n]) printf ("tiny entries dropped: %g\n",
(double) (nz2 - A->p [n])) ;
Prob->b = cs_malloc (mn, sizeof (double)) ;
Prob->x = cs_malloc (mn, sizeof (double)) ;
Prob->resid = cs_malloc (mn, sizeof (double)) ;
return ((!Prob->b || !Prob->x || !Prob->resid) ? free_problem (Prob) : Prob) ;
}
/* In unified keyword, we include preceding ':' to the name. */
ScmObj Scm_MakeKeyword(ScmString *name)
{
#if GAUCHE_UNIFY_SYMBOL_KEYWORD
/* We could optimize this later. */
ScmObj prefix = Scm_MakeString(":", 1, 1, SCM_STRING_IMMUTABLE);
ScmObj sname = Scm_StringAppend2(SCM_STRING(prefix), name);
ScmSymbol *s = make_sym(SCM_CLASS_KEYWORD, SCM_STRING(sname), TRUE);
Scm_DefineConst(Scm_KeywordModule(), s, SCM_OBJ(s));
return SCM_OBJ(s);
#else /*!GAUCHE_UNIFY_SYMBOL_KEYWORD*/
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
ScmObj r = Scm_HashTableRef(keywords.table, SCM_OBJ(name), SCM_FALSE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
if (SCM_KEYWORDP(r)) return r;
ScmKeyword *k = SCM_NEW(ScmKeyword);
SCM_SET_CLASS(k, SCM_CLASS_KEYWORD);
k->name = SCM_STRING(Scm_CopyString(name));
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
r = Scm_HashTableSet(keywords.table, SCM_OBJ(name), SCM_OBJ(k),
SCM_DICT_NO_OVERWRITE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
return r;
#endif /*!GAUCHE_UNIFY_SYMBOL_KEYWORD*/
}
krb5_error_code
hdb_create(krb5_context context, HDB **db, const char *filename)
{
struct cb_s cb_ctx;
if (filename == NULL)
filename = HDB_DEFAULT_DB;
cb_ctx.h = find_method (filename, &cb_ctx.residual);
cb_ctx.filename = filename;
if (cb_ctx.h == NULL || cb_ctx.h->create == NULL) {
char *sym;
if ((sym = make_sym(filename)) == NULL)
return krb5_enomem(context);
(void)_krb5_plugin_run_f(context, "krb5", sym, HDB_INTERFACE_VERSION,
0, &cb_ctx, callback);
free(sym);
}
if (cb_ctx.h == NULL)
krb5_errx(context, 1, "No database support for %s", cb_ctx.filename);
return (*cb_ctx.h->create)(context, db, cb_ctx.residual);
}
/* In unified keyword, we include preceding ':' to the name. */
ScmObj Scm_MakeKeyword(ScmString *name)
{
#if GAUCHE_KEEP_DISJOINT_KEYWORD_OPTION
if (keyword_disjoint_p) {
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
ScmObj r = Scm_HashTableRef(keywords.table, SCM_OBJ(name), SCM_FALSE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
if (SCM_KEYWORDP(r)) return r;
ScmKeyword *k = SCM_NEW(ScmKeyword);
SCM_SET_CLASS(k, SCM_CLASS_KEYWORD);
k->name = SCM_STRING(Scm_CopyString(name));
(void)SCM_INTERNAL_MUTEX_LOCK(keywords.mutex);
r = Scm_HashTableSet(keywords.table, SCM_OBJ(name), SCM_OBJ(k),
SCM_DICT_NO_OVERWRITE);
(void)SCM_INTERNAL_MUTEX_UNLOCK(keywords.mutex);
return r;
}
#endif /*GAUCHE_KEEP_DISJOINT_KEYWORD_OPTION*/
ScmObj sname = Scm_StringAppend2(&keyword_prefix, name);
ScmSymbol *s = make_sym(SCM_CLASS_KEYWORD, SCM_STRING(sname), TRUE);
Scm_DefineConst(Scm__GaucheKeywordModule(), s, SCM_OBJ(s));
return SCM_OBJ(s);
}
/* In unified keyword, we include preceding ':' to the name. */
ScmObj Scm_MakeKeyword(ScmString *name)
{
/* We could optimize this later. */
ScmObj prefix = Scm_MakeString(":", 1, 1, SCM_STRING_IMMUTABLE);
ScmObj sname = Scm_StringAppend2(SCM_STRING(prefix), name);
ScmSymbol *s = make_sym(SCM_CLASS_KEYWORD, SCM_STRING(sname), TRUE);
Scm_DefineConst(Scm_KeywordModule(), s, SCM_OBJ(s));
return SCM_OBJ(s);
}
krb5_error_code
hdb_list_builtin(krb5_context context, char **list)
{
const struct hdb_method *h;
size_t len = 0;
char *buf = NULL;
for (h = methods; h->prefix != NULL; ++h) {
if (h->prefix[0] == '\0')
continue;
len += strlen(h->prefix) + 2;
}
len += 1;
buf = malloc(len);
if (buf == NULL) {
return krb5_enomem(context);
}
buf[0] = '\0';
for (h = methods; h->prefix != NULL; ++h) {
if (h->create == NULL) {
struct cb_s cb_ctx;
char *f;
char *sym;
/* Try loading the plugin */
if (asprintf(&f, "%sfoo", h->prefix) == -1)
f = NULL;
if ((sym = make_sym(h->prefix)) == NULL) {
free(buf);
free(f);
return krb5_enomem(context);
}
cb_ctx.filename = f;
cb_ctx.residual = NULL;
cb_ctx.h = NULL;
(void)_krb5_plugin_run_f(context, "krb5", sym,
HDB_INTERFACE_VERSION, 0, &cb_ctx,
callback);
free(f);
free(sym);
if (cb_ctx.h == NULL || cb_ctx.h->create == NULL)
continue;
}
if (h != methods)
strlcat(buf, ", ", len);
strlcat(buf, h->prefix, len);
}
*list = buf;
return 0;
}
/* Returns uninterned symbol. PREFIX can be NULL */
ScmObj Scm_Gensym(ScmString *prefix)
{
char numbuf[50];
/* We don't need mutex for this variable, since a race on it is
tolerated---multiple threads may be get the same name symbols,
but they are uninterned and never be eq? to each other. */
static intptr_t gensym_count = 0;
if (prefix == NULL) prefix = &default_prefix;
int nc = snprintf(numbuf, 49, "%"PRIdPTR, gensym_count++);
numbuf[49] = '\0';
ScmObj name = Scm_StringAppendC(prefix, numbuf, nc, nc);
ScmSymbol *sym = make_sym(SCM_CLASS_SYMBOL, SCM_STRING(name), FALSE);
return SCM_OBJ(sym);
}
//SYMのパース
object_t *parse_sym(FILE *fp){
int i=0;
char buf;
char tmp[BUFFER_SIZE];
buf=skip_space_getchar(fp);
while(isalpha(buf) || buf=='+' || buf=='*' || buf=='-'){
tmp[i]=buf;
buf = getc(fp);
i++;
}
tmp[i]='\0';
ungetc(buf,fp);
return make_sym(tmp);
}
SinglePtr Parser::read_single()
{
if (m_word.type == "sym") {
return make_sym(m_word.content);
}
if (m_word.type == "int") {
#if defined(__CYGWIN32__) || defined(__MINGW32__)
istringstream iss(m_word.content);
int x;
iss >> x;
return make_int(x);
#else
return make_int(stoi(m_word.content));
#endif
}
/* Intern */
ScmObj Scm_MakeSymbol(ScmString *name, int interned)
{
ScmObj sname = Scm_CopyStringWithFlags(name, SCM_STRING_IMMUTABLE,
SCM_STRING_IMMUTABLE);
return SCM_OBJ(make_sym(SCM_CLASS_SYMBOL, SCM_STRING(sname), interned));
}
void defs( void )
{
token_t gentoken;
a_sym *sym;
int ctype;
char *dupbuf( void );
char *type;
a_prec prec;
eofsym = make_sym( "$eof", TOKEN_EOF );
nosym = make_sym( "$impossible", TOKEN_IMPOSSIBLE );
errsym = make_sym( "error", TOKEN_ERROR );
if( denseflag ) {
gentoken = TOKEN_DENSE_BASE;
} else {
gentoken = TOKEN_SPARSE_BASE;
}
scan( 0 );
prec.prec = 0;
prec.assoc = NON_ASSOC;
for( ;; ) {
switch( token ) {
case MARK:
scan( 0 );
return;
case START:
if( scan( 0 ) != IDENTIFIER )
msg( "Identifier needed after %%start.\n" );
startsym = addsym( buf );
scan( 0 );
break;
case UNION:
if( scan( 0 ) != '{' ) {
msg( "Need '{' after %%union.\n" );
}
fprintf( actout, "#ifndef __YYSTYPE_DEFINED\n" );
fprintf( actout, "#define __YYSTYPE_DEFINED\n" );
fprintf( actout, "typedef union " );
lineinfo();
fprintf( actout, "%s YYSTYPE;\n", buf );
fprintf( actout, "#endif\n" );
fprintf( tokout, "#ifndef __YYSTYPE_DEFINED\n" );
fprintf( tokout, "#define __YYSTYPE_DEFINED\n" );
fprintf( tokout, "typedef union %s YYSTYPE;\n", buf );
fprintf( tokout, "#endif\n" );
scan( 0 );
break;
case LCURL:
lineinfo();
copycurl();
scan( 0 );
break;
case KEYWORD_ID:
switch( scan( 0 ) ) {
case IDENTIFIER:
sym = addsym( buf );
if( ! sym->token ) {
msg( "Token must be assigned number before %keyword_id\n" );
}
value = sym->token;
break;
case NUMBER:
break;
default:
msg( "Expecting identifier or number.\n" );
}
keyword_id_low = value;
switch( scan( 0 ) ) {
case IDENTIFIER:
sym = addsym( buf );
if( ! sym->token ) {
msg( "Token must be assigned number before %keyword_id\n" );
}
value = sym->token;
break;
case NUMBER:
break;
default:
msg( "Expecting identifier or number.\n" );
}
keyword_id_high = value;
scan( 0 );
break;
case LEFT:
case RIGHT:
case NONASSOC:
++prec.prec;
prec.assoc = value;
// pass through
case TOKEN:
case TYPE:
ctype = token;
if( scan( 0 ) == '<' ) {
if( scan_typename( 0 ) != TYPENAME ) {
msg( "Expecting type specifier.\n" );
}
type = dupbuf();
if( scan( 0 ) != '>' ) {
msg( "Expecting '>'.\n" );
}
scan( 0 );
} else {
type = NULL;
}
while( token == IDENTIFIER ) {
sym = addsym( buf );
if( type != NULL && sym->type != NULL ) {
if( strcmp( sym->type, type ) != 0 ) {
msg( "'%s' type redeclared from '%s' to '%s'\n",
buf, sym->type, type );
}
}
sym->type = type;
if( ctype == TYPE ) {
scan( 0 );
} else {
if( !sym->token ) {
sym->token = value;
}
if( ctype != TOKEN ) {
sym->prec = prec;
}
if( scan( 0 ) == NUMBER ) {
if( sym->token ) {
if( sym->name[ 0 ] != '\'' ) {
fprintf( tokout, "#undef\t%-20s\n", sym->name );
}
}
sym->token = value;
scan( 0 );
}
if( !sym->token ) {
sym->token = gentoken++;
}
if( sym->name[ 0 ] != '\'' ) {
fprintf( tokout, "#define\t%-20s\t0x%02x\n",
sym->name, sym->token );
}
}
if( token == ',' ) {
scan( 0 );
}
}
break;
default:
msg( "Incorrect syntax.\n" );
}
}
}
