static obj_t
passwd2list( struct passwd *pw ) {
if( !pw ) {
return BFALSE;
} else {
obj_t res;
/* the shell */
res = MAKE_PAIR( string_to_bstring( pw->pw_shell ), BNIL );
/* the home directory */
res = MAKE_PAIR( string_to_bstring( pw->pw_dir ), res );
/* the real name */
#if BGL_HAVE_GECOS
res = MAKE_PAIR( string_to_bstring( pw->pw_gecos ), res );
#endif
/* the group id */
res = MAKE_PAIR( BINT( pw->pw_gid ), res );
/* the user id */
res = MAKE_PAIR( BINT( pw->pw_uid ), res );
/* the password */
res = MAKE_PAIR( string_to_bstring( pw->pw_passwd ), res );
/* the name */
res = MAKE_PAIR( string_to_bstring( pw->pw_name ), res );
return res;
}
}
/*---------------------------------------------------------------------*/
BGL_RUNTIME_DEF int
bgl_symlink( char *s1, char *s2 ) {
#if BGL_HAVE_SYMLINK
if( symlink( s1, s2 ) ) {
C_SYSTEM_FAILURE( BGL_IO_ERROR, "make-symlink", strerror( errno ),
string_to_bstring( s2 ) );
}
return 0;
#else
C_SYSTEM_FAILURE( BGL_IO_ERROR, "make-symlink", "Not supported",
string_to_bstring( s2 ) );
return 1;
#endif
}
/* _make-string-ptr-null */
obj_t BGl__makezd2stringzd2ptrzd2nullzd2zz__foreignz00(obj_t BgL_envz00_671)
{ AN_OBJECT;
{ /* Llib/foreign.scm 127 */
return
string_to_bstring(
(0L));}
}
/*---------------------------------------------------------------------*/
int
bgl_utime( char *file, long atime, long mtime ) {
struct utimbuf buf = { .actime = (time_t)atime, .modtime= (time_t)mtime };
int r = utime( file, &buf );
if( r < 0 ) {
C_SYSTEM_FAILURE( BGL_ERROR, "file-times-set!",
strerror( errno ),
string_to_bstring( file ) );
}
return r;
}
/*---------------------------------------------------------------------*/
BGL_EXPORTED_DEF
long
obj_to_cobj( obj_t obj ) {
if( INTEGERP( obj ) )
return (long)CINT( obj );
if( BOOLEANP( obj ) )
return (long)((long)CBOOL( obj ));
if( STRINGP( obj ) )
return (long)BSTRING_TO_STRING( obj );
if( CHARP( obj ) )
return (long)((long)CCHAR( obj ));
if( FOREIGNP( obj ) )
return (long)FOREIGN_TO_COBJ( obj );
if( REALP( obj ) )
return (long)the_failure( string_to_bstring( "obj->cobj" ),
string_to_bstring( "Can't cast a real to foreign" ),
obj);
else
return (long)the_failure( string_to_bstring( "obj->cobj" ),
string_to_bstring( "Illegal object type" ),
obj);
}
/*---------------------------------------------------------------------*/
obj_t
bglk_gtk_glist_strings( GList *lst ) {
obj_t res = BNIL;
while( lst ) {
GtkListItem *li = GTK_LIST_ITEM( lst->data );
char *str = bglk_gtk_glist_item_get_string( li );
res = make_pair( string_to_bstring( str ), res );
lst = lst->next;
}
return res;
}
static void report_odbc_error(char* who,
SQLSMALLINT handle_type,
SQLHANDLE handle)
{
SQLTCHAR SQLErrorMessage[512];
SQLTCHAR SQLState[6];
SQLINTEGER NativeError = 0;
SQLSMALLINT ErrMsgLength = 0;
SQLGetDiagRec(handle_type, handle, 1, SQLState, &NativeError,
SQLErrorMessage, sizeof(SQLErrorMessage), &ErrMsgLength);
odbc_error(who,SQLErrorMessage,string_to_bstring(SQLState));
}
/*---------------------------------------------------------------------*/
static obj_t
make_names( int range, char *fmt ) {
obj_t names = (obj_t)create_vector( range );
char buf[ 40 ];
struct tm tm;
int i;
for( i = 0; i < range; i++ ) {
tm.tm_wday = i;
tm.tm_mon = i;
strftime( buf, 40, fmt, &tm );
VECTOR_SET( names, i, string_to_bstring( buf ) );
}
return names;
}
/*---------------------------------------------------------------------*/
obj_t
bgl_dload( char *filename, char *init_sym, char *init_mod ) {
#if !HAVE_DLOPEN
strcpy( dload_error, "Feature not supported" );
return __dload_noarch;
#else
void *handle = dlopen( filename, RTLD_LAZY | RTLD_GLOBAL );
obj_t p;
if( !handle ) {
char *error;
if( (error = dlerror()) != NULL ) {
strncpy( dload_error, error, DLOAD_ERROR_LEN );
} else {
strcpy( dload_error, "dlopen error" );
}
return __dload_error;
} else {
p = MAKE_PAIR( string_to_bstring( filename ), handle );
BGL_MUTEX_LOCK( dload_mutex );
dload_list = MAKE_PAIR( p, dload_list );
BGL_MUTEX_UNLOCK( dload_mutex );
if( *init_sym ) {
return dload_init_call( handle, init_sym );
}
if( *init_mod ) {
return dload_init_call( handle, init_mod );
}
return __dload_noinit;
}
#endif
}
/* declare-tvector! */
BGL_EXPORTED_DEF obj_t BGl_declarezd2tvectorz12zc0zz__tvectorz00(char
*BgL_idz00_23, obj_t BgL_allocatez00_24, obj_t BgL_refz00_25,
obj_t BgL_setz00_26)
{
AN_OBJECT;
{ /* Llib/tvector.scm 139 */
{ /* Llib/tvector.scm 140 */
obj_t BgL_idz00_787;
{ /* Llib/tvector.scm 140 */
obj_t BgL_arg1898z00_792;
{ /* Llib/tvector.scm 140 */
obj_t BgL_casezd2valuezd2_793;
BgL_casezd2valuezd2_793 =
BGl_bigloozd2casezd2sensitivityz00zz__readerz00();
if ((BgL_casezd2valuezd2_793 == BGl_symbol2204z00zz__tvectorz00))
{ /* Llib/tvector.scm 140 */
BgL_arg1898z00_792 =
BGl_stringzd2upcasezd2zz__r4_strings_6_7z00(string_to_bstring
(BgL_idz00_23));
}
else
{ /* Llib/tvector.scm 140 */
if (
(BgL_casezd2valuezd2_793 == BGl_symbol2206z00zz__tvectorz00))
{ /* Llib/tvector.scm 140 */
BgL_arg1898z00_792 =
BGl_stringzd2downcasezd2zz__r4_strings_6_7z00
(string_to_bstring(BgL_idz00_23));
}
else
{ /* Llib/tvector.scm 140 */
BgL_arg1898z00_792 = string_to_bstring(BgL_idz00_23);
}
}
}
BgL_idz00_787 =
string_to_symbol(BSTRING_TO_STRING(BgL_arg1898z00_792));
}
{ /* Llib/tvector.scm 140 */
obj_t BgL_oldz00_788;
if (PAIRP(BGl_za2tvectorzd2tableza2zd2zz__tvectorz00))
{ /* Llib/tvector.scm 147 */
obj_t BgL_cellz00_1335;
BgL_cellz00_1335 =
BGl_assqz00zz__r4_pairs_and_lists_6_3z00(BgL_idz00_787,
BGl_za2tvectorzd2tableza2zd2zz__tvectorz00);
if (PAIRP(BgL_cellz00_1335))
{ /* Llib/tvector.scm 147 */
BgL_oldz00_788 = CDR(BgL_cellz00_1335);
}
else
{ /* Llib/tvector.scm 147 */
BgL_oldz00_788 = BFALSE;
}
}
else
{ /* Llib/tvector.scm 147 */
BgL_oldz00_788 = BFALSE;
}
{ /* Llib/tvector.scm 147 */
{ /* Llib/tvector.scm 148 */
bool_t BgL_testz00_1752;
if (STRUCTP(BgL_oldz00_788))
{ /* Llib/tvector.scm 148 */
BgL_testz00_1752 =
(STRUCT_KEY(BgL_oldz00_788) ==
BGl_symbol2208z00zz__tvectorz00);
}
else
{ /* Llib/tvector.scm 148 */
BgL_testz00_1752 = ((bool_t) 0);
}
if (BgL_testz00_1752)
{ /* Llib/tvector.scm 148 */
return BgL_oldz00_788;
}
else
{ /* Llib/tvector.scm 149 */
obj_t BgL_newz00_790;
{ /* Llib/tvector.scm 149 */
obj_t BgL_newz00_1351;
BgL_newz00_1351 =
create_struct(BGl_symbol2208z00zz__tvectorz00,
(int) (((long) 4)));
{ /* Llib/tvector.scm 149 */
int BgL_auxz00_1759;
BgL_auxz00_1759 = (int) (((long) 3));
STRUCT_SET(BgL_newz00_1351, BgL_auxz00_1759,
BgL_setz00_26);
}
{ /* Llib/tvector.scm 149 */
int BgL_auxz00_1762;
BgL_auxz00_1762 = (int) (((long) 2));
STRUCT_SET(BgL_newz00_1351, BgL_auxz00_1762,
BgL_refz00_25);
}
{ /* Llib/tvector.scm 149 */
int BgL_auxz00_1765;
BgL_auxz00_1765 = (int) (((long) 1));
STRUCT_SET(BgL_newz00_1351, BgL_auxz00_1765,
BgL_allocatez00_24);
}
{ /* Llib/tvector.scm 149 */
int BgL_auxz00_1768;
BgL_auxz00_1768 = (int) (((long) 0));
STRUCT_SET(BgL_newz00_1351, BgL_auxz00_1768,
BgL_idz00_787);
}
BgL_newz00_790 = BgL_newz00_1351;
}
{ /* Llib/tvector.scm 150 */
obj_t BgL_arg1896z00_791;
BgL_arg1896z00_791 =
MAKE_PAIR(BgL_idz00_787, BgL_newz00_790);
BGl_za2tvectorzd2tableza2zd2zz__tvectorz00 =
MAKE_PAIR(BgL_arg1896z00_791,
BGl_za2tvectorzd2tableza2zd2zz__tvectorz00);
}
return BgL_newz00_790;
}
}
}
}
}
}
}
/*---------------------------------------------------------------------*/
obj_t
bdb_table_to_list( obj_t bdb ) {
obj_t cla_info = BNIL;
obj_t glo_info = BNIL;
obj_t mod_info = BNIL;
obj_t init_info = BNIL;
obj_t lnum_info = BNIL;
struct bdb_fun_info *table_entry = (struct bdb_fun_info *)bdb;
obj_t src_info = BNIL;
long mod_lnum;
/* we start reading the signature for the table in, */
/* just to check that the compiled table format is */
/* compatible with this version of blib. */
if( !(table_entry->sname == BDB_LIBRARY_MAGIC_NUMBER) ||
!(table_entry->cname == BDB_LIBRARY_MAGIC_NUMBER) ) {
fprintf( stderr,
"***ERROR: Incompatible versions -- "
"Bigloo compiler/Bdb library");
exit( -1 );
} else {
table_entry++;
}
/* we start fetching the module name and its */
/* C initialization function. */
mod_info = string_to_bstring( table_entry->sname );
init_info = string_to_bstring( table_entry->cname );
table_entry++;
/* and the source files implementing this module. */
while( ((int *)table_entry->sname) ) {
obj_t pair = MAKE_PAIR(string_to_bstring(table_entry->sname), src_info);
src_info = pair;
table_entry++;
}
mod_lnum = (long)table_entry->cname;
src_info = MAKE_PAIR( init_info, src_info );
lnum_info = MAKE_PAIR( BINT( mod_lnum ), src_info );
mod_info = MAKE_PAIR( mod_info, lnum_info );
table_entry++;
/* then we fetch global variables informations */
while( *((int *)table_entry) && table_entry->sname ) {
char *fname, *sname, *cname;
long lnum;
obj_t pair = BNIL;
obj_t entry = BNIL;
/* we first fetch the source file name and line num */
fname = table_entry->sname;
lnum = (long)table_entry->cname;
table_entry++;
/* now, we pickup the global scheme and C names */
sname = table_entry->sname;
cname = table_entry->cname;
/* is it a global function or a global variable ? */
if( !cname ) {
/* thie is a global function */
char *bp_cname;
obj_t pair2;
table_entry++;
cname = table_entry->sname;
bp_cname = table_entry->cname;
pair2 = MAKE_PAIR( cname ? string_to_bstring( cname ) : BUNSPEC,
BINT( lnum ) );
pair2 = MAKE_PAIR( pair2, string_to_bstring( bp_cname ) );
table_entry++;
/* this is a global function, we are now free */
/* to parse the local variables */
while( table_entry->sname ) {
pair = MAKE_PAIR( string_to_bstring( table_entry->sname ),
string_to_bstring( table_entry->cname ) );
entry = MAKE_PAIR( pair, entry );
table_entry++;
}
pair2 = MAKE_PAIR( pair2, BNIL );
pair = MAKE_PAIR( string_to_bstring( sname ), pair2 );
} else {
/* this is a global variable. */
pair = MAKE_PAIR( string_to_bstring( sname ),
string_to_bstring( cname ) );
}
entry = MAKE_PAIR( pair, entry );
entry = MAKE_PAIR( string_to_bstring( fname ), entry );
table_entry++;
glo_info = MAKE_PAIR( entry, glo_info );
}
table_entry++;
/* then we fetch classes information */
while( *((int *)table_entry) && table_entry->sname ) {
cla_info = MAKE_PAIR( string_to_bstring( table_entry->sname ),
cla_info );
table_entry++;
}
/* We now build the returned list to Bdb */
{
obj_t aux;
aux = MAKE_PAIR( glo_info, cla_info );
return MAKE_PAIR( mod_info, aux );
}
}
