Adding types to STk (via C functions)?

From: Dipankar Gupta <dg_at_hplb.hpl.hp.com>
Date: Mon, 31 Oct 1994 17:30:16 GMT

 SP> I'm adding a GDBM interface to STk. I would like to have a stk
 SP> function return an opaque type (GDMB_FILE) for use as an argument to
 SP> other stk functions. How do I do it?

Hi, you might want to look at the file `Extensions/hash.c'. In
addition, here is a small hack I wrote for traversing the directory
tree semi-efficiently. It adds an extended scheme type, and has
(trivial) hooks for the garbage-collector. A extension supporting
persistence would clearly need a more substantial hook, especially if
it supports persistence of non-trivial objects (eg extensions,
pointers to arbitrary bits of memory, etc). As Erick mentioned in an
earlier reply to my query, you don't need to worry about live objects
on the stack as STk's mark/sweep GC scans the stack during the mark
phase, and does the right thing.

Hope this helps...
--Dipankar

--- dirent.c ---
#include <stk.h>
#include <dirent.h>
#include <sys/stat.h>
#include <sys/errno.h>

static void free_dirent( SCM dent );
static void mark_dirent( SCM dent );

static int ux_dirent;
static extended_scheme_type dirent_type =
{ "directory-entry",
  0,
  mark_dirent,
  free_dirent,
  NULL,
  NULL /* Display routine */
};

#define L_DIRHANDLE(x) (x->storage_as.extension.data) /* Usable as lvalue */
#define C_DIRHANDLE(x) ((DIR*) (x->storage_as.extension.data)) /* Usable as DIR* */
#define DIRENT_P(x) (TYPEP(x, ux_dirent)) /* type checking */

DIR *OpenDir( const char *name )
{
    DIR *h = opendir( name );
    if (h) return h;
    return 0;
}
static PRIMITIVE make_dirent( SCM root )
{
    SCM z;
    DIR *handle;


    if (NSTRINGP( root ))
        err( "make-dirent: not a string", root );

    NEWCELL( z, ux_dirent );
    
    handle = OpenDir( CHARS(root) );
    if (handle == 0) {
        err( "OpenDir: failed to open", root );
    }
    L_DIRHANDLE(z) = handle;
    return z;
}

static PRIMITIVE dirent_p( SCM obj )
{
    return DIRENT_P( obj ) ? truth : ntruth;
}

static PRIMITIVE dirent_query_pos( SCM obj )
{
    if (!DIRENT_P(obj)) {
        err( "dirent-query-pos: not a directory entry", obj );
    }
    return makeinteger( telldir( C_DIRHANDLE( obj )));
}

static PRIMITIVE dirent_set_pos( SCM obj, SCM pos )
{
    if (!DIRENT_P(obj))
        err ( "dirent-set-pos!: not a directory entry", obj );

    if (NNUMBERP( pos ))
        err ( "dirent-set-pos!: not a directory position", pos );

    seekdir( C_DIRHANDLE( obj), integer_value( pos ));
    return UNDEFINED;
}

static PRIMITIVE dirent_next( SCM obj )
{
    struct dirent *recp;
    if (!DIRENT_P( obj ))
        err( "dirent-next: not a directory entry", obj );

    if ((recp = readdir( C_DIRHANDLE(obj))) == 0) {
        return ntruth;
    }
    return makestrg( recp->d_namlen, recp->d_name );
}

static PRIMITIVE dirent_rewind( SCM obj )
{
    if (!DIRENT_P( obj ))
        err( "dirent-rewind: not a directory entry", obj );

    rewinddir( C_DIRHANDLE( obj ));
    return UNDEFINED;
}

static PRIMITIVE dirent_foreach_rest( SCM obj, SCM proc )
{
    struct dirent *recp;
    
    if (!DIRENT_P( obj ))
        err( "dirent-map-rest: bad directory entry", obj );

    if (procedurep( proc ) == ntruth)
        err( "dirent-map-rest: bad procedure", proc );

    while( (recp = readdir( C_DIRHANDLE( obj ))) != 0)
        {
            apply( proc, LIST1( makestrg( recp->d_namlen,
                                          recp->d_name )) );
        }
    return UNDEFINED;
}

static PRIMITIVE dirent_foreach( SCM obj, SCM proc )
{
    struct dirent *recp;
    DIR *handle;
    if (NSTRINGP( obj ))
        err ( "dirent-foreach: expected a string", obj );

    if (procedurep( proc ) == ntruth)
        err( "dirent-foreach: bad procedure", proc );

    handle = OpenDir( CHARS( obj ));
    if ( handle == 0)
        return ntruth;
    while( (recp = readdir( handle )) != 0)
        {
            apply( proc, LIST1( makestrg( recp->d_namlen,
                                          recp->d_name )) );
        }
    closedir( handle );
    return truth;
}

static PRIMITIVE dirent_map( SCM obj, SCM proc )
{
    struct dirent *recp;
    DIR *handle;
    SCM result = NIL;

    if (NSTRINGP( obj ))
        err ( "dirent-map: expected a string", obj );
    
    if (procedurep( proc ) == ntruth)
        err( "dirent-map: expected a procedure", proc );

    handle = OpenDir( CHARS( obj ));
    if ( handle == 0)
        return ntruth;

    while (( recp = readdir( handle )) != 0)
        {
            result = cons( apply( proc, LIST1( makestrg( recp->d_namlen,
                                                         recp->d_name ) )),
                           result );
        }
    closedir( handle );
    return result;
}

static PRIMITIVE dirent_map_rest( SCM obj, SCM proc )
{
    struct dirent *recp;
    SCM result = NIL;

    if (!DIRENT_P( obj ))
        err( "dirent-map-rest: bad directory entry", obj );

    if (procedurep( proc ) == ntruth)
        err( "dirent-map-rest: bad procedure", proc );

    while( (recp = readdir ( C_DIRHANDLE( obj ))) != 0)
        {
            result = cons (apply (proc, LIST1(makestrg(recp->d_namlen,
                                                       recp->d_name ))),
                           result );
        }
    return result;
}
        
static void free_dirent( SCM dent )
{
#if 0
    printf ("Freeing dirent: %p\n", dent );
#endif
    closedir( C_DIRHANDLE( dent ));
    free( C_DIRHANDLE( dent ) );
}

static void mark_dirent( SCM dent )
{
    /* rien */
}

static PRIMITIVE fs_file_probe( SCM path )
{
    SCM z;
    struct stat s;
    
    if (NSTRINGP( path ))
        err( "fs-type: expected string argument", path );
    
    if (lstat (CHARS( path ), &s ) == -1) /* We use lstat(2) to handle symlinks */
        return ntruth;
    
    z = makevect( 4, 0 );
    VECT(z)[1] = makeinteger( s.st_size );
    VECT(z)[2] = makeinteger( s.st_mtime );
    VECT(z)[3] = makeinteger( s.st_mode );
    
    if (S_ISREG( s.st_mode ))
        VECT(z)[0] = makeinteger( 0 );
    else if (S_ISDIR(s.st_mode ))
        VECT(z)[0] = makeinteger( 1 );
    else if (S_ISLNK( s.st_mode ))
        VECT(z)[0] = makeinteger( 2 );
    else if (S_ISCHR( s.st_mode ) || S_ISBLK( s.st_mode ))
        VECT(z)[0] = makeinteger( 3 );
    else if (S_ISSOCK( s.st_mode ))
        VECT(z)[0] = makeinteger( 4 );
    else
        VECT(z)[0]= makeinteger( 5 );

    return z;
}

PRIMITIVE init_dirent( void )
{
    ux_dirent = add_new_type( &dirent_type );
    add_new_primitive( "make-dirent", tc_subr_1, make_dirent );
    add_new_primitive( "dirent?", tc_subr_1, dirent_p );
    add_new_primitive( "dirent-get-pos", tc_subr_1, dirent_query_pos );
    add_new_primitive( "dirent-set-pos!", tc_subr_2, dirent_set_pos );
    add_new_primitive( "dirent-rewind!", tc_subr_1, dirent_rewind );
    add_new_primitive( "dirent-next", tc_subr_1, dirent_next );
    add_new_primitive( "dirent-foreach", tc_subr_2, dirent_foreach );
    add_new_primitive( "dirent-map", tc_subr_2, dirent_map );
    add_new_primitive( "dirent-foreach-rest", tc_subr_2, dirent_foreach_rest );
    add_new_primitive( "dirent-map-rest", tc_subr_2, dirent_map_rest );
    add_new_primitive( "file-probe", tc_subr_1, fs_file_probe );
    return UNDEFINED;
}
Received on Mon Oct 31 1994 - 18:29:46 CET