Re: Octave and Guile?

[Doug Evans]

Miroslav Silovic writes:
 > I picked Guile for my projects simply because it's a *lot* easier to
 > integrate with C code than anything else tried to work with. For one,
 > you can -really- easily define your own low-level types, and still not
 > worry about memory management issues (in fact, I found out that by
 > using Guile's GC, you can simplify the C code a lot - this isn't true
 > with either Perl or Python).

I think Rscheme has some pretty slick Scheme/C support.
Maybe there's something the Guile folks can use here.

For example, here's an interface to bfd that I wrote for
something I needed [it only includes things I needed,
but you get the idea].

What the "glue" stuff does is generate C code with
machine generated argument type checking.
And I like being able to seamlessly mix Scheme/C in the same file.

---
; Never used except in error messages.
(define-class <raw-uint> (<object>) :abstract)

(define-macro (define-sim-glue args . body)
  `(define-safe-glue ,args
     type-handler: (<raw-uint>
                    (primitive "OBJ_ISA_UINT" <raw-uint>)
                    ("unsigned ~a" "rs_get_unsigned_int (~a)"))
     type-handler: (<bfd>
                    (direct-instance? <bfd>)
                    ("struct _bfd **~a"
                     "(struct _bfd **) PTR_TO_DATAPTR (~a)"))
     type-handler: (<bfd-section>
                    (direct-instance? <bfd-section>)
                    ("struct sec **~a"
                     "(struct sec **) PTR_TO_DATAPTR (~a)"))
     type-handler: (<bfd-symbol>
                    (direct-instance? <bfd-symbol>)
                    ("struct symbol_cache_entry **~a"
                     "(struct symbol_cache_entry **) PTR_TO_DATAPTR (~a)"))
     ,@body))
---
; bfd interface

; The bfd struct (a pointer to one, actually).
; This just assigns a name to a bvec (byte vector) of unspecified length.
; The length is specified when the object is created.
; It's convention that it contains a bfd*.
; Once created though, Rscheme emits code to do the type checking for us.
(define-class <bfd> (<object>) :bvec)

; A bfd section.
(define-class <bfd-section> (<object>) :bvec)

; A bfd symbol.
(define-class <bfd-symbol> (<object>) :bvec)

; General bfd operations.

(define-sim-glue (bfd-open (prog <raw-string>))
  literals: ((& <bfd>))
{
 obj bfdobj;
 bfd* abfd = bfd_openr (prog, 0);
 if (abfd == NULL)
 {
   REG0 = FALSE_OBJ;
   RETURN1 ();
 }
 bfdobj = alloc (sizeof (bfd*), TLREF (0));
 *(bfd**) PTR_TO_DATAPTR (bfdobj) = abfd;
 REG0 = bfdobj;
 RETURN1 ();
})

(define-sim-glue (bfd-check-format (abfd <bfd>))
{
 if (bfd_check_format (*abfd, bfd_object))
   REG0 = TRUE_OBJ;
 else
   REG0 = FALSE_OBJ;
 RETURN1 ();
})

(define-sim-glue (bfd-close (abfd <bfd>))
{
 if (bfd_close (*abfd))
   REG0 = TRUE_OBJ;
 else
   REG0 = FALSE_OBJ;
 RETURN1 ();
})

; Return a NULL ptr <bfd> object.

(define (bfd-null)
  (let ((bfd (bvec-alloc <bfd> 4)))
    (bvec-write-signed-32 bfd 0 0)
    bfd)
)

; Return #t if {bfd} is a NULL ptr.

(define (bfd-null? (bfd <bfd>))
  (= (bvec-read-signed-32 bfd 0) 0)
)

; Section operations.

(define-sim-glue (bfd-get-section-by-name (abfd <bfd>) (name <raw-string>))
  literals: ((& <bfd-section>))
{
 asection* s = bfd_get_section_by_name (*abfd, name);
 obj secobj = alloc (sizeof (asection*), TLREF (0));
 *(asection**) PTR_TO_DATAPTR (secobj) = s;
 REG0 = secobj;
 RETURN1 ();
})

(define (bfd-section-null? (sec <bfd-section>))
  (= (bvec-read-signed-32 sec 0) 0)
)

(define-sim-glue (bfd-section-get-name (sec <bfd-section>))
{
 const char* name = bfd_section_name (*sec->owner, *sec);
 REG0 = make_string (name);
 RETURN1 ();
})

(define-sim-glue (bfd-section-get-vma (sec <bfd-section>))
{
 bfd_vma value = bfd_section_vma (*sec->owner, *sec);
 // FIXME: 64 bit targets wip
 REG0 = rs_make_unsigned_int (value);
 RETURN1 ();
})

(define-sim-glue (bfd-section-get-lma (sec <bfd-section>))
{
 bfd_vma value = bfd_section_lma (*sec->owner, *sec);
 // FIXME: 64 bit targets wip
 REG0 = rs_make_unsigned_int (value);
 RETURN1 ();
})

; TODO: more section operations

; Symbol operations.

; Return a vector of symbols.
; Each element is a <bfd_symbol> which is just a pointer to the real symbol.
; FIXME: This crashes if bfd-check-format not done first.

(define-sim-glue (bfd-get-symbols (abfd <bfd>))
  literals: ((& <bfd-symbol>) (& <vector>))
{
 unsigned sym_size;
 unsigned nr_symbols;
 struct symbol_cache_entry** syms;
 unsigned i;

 sym_size = bfd_get_symtab_upper_bound (*abfd);
 syms = (asymbol **) xmalloc (sym_size);
 nr_symbols = bfd_canonicalize_symtab (*abfd, syms);

 REG0 = gvec_alloc (nr_symbols, TLREF (1));
 for (i = 0; i < nr_symbols; ++i)
 {
   obj symobj = alloc (sizeof (asymbol*), TLREF (0));
   *(asymbol**) PTR_TO_DATAPTR (symobj) = syms[i];
   gvec_write_fresh (REG0, SLOT (i), symobj);
 }
 free (syms);
 RETURN1 ();
})

(define-sim-glue (bfd-symbol-get-section (sym <bfd-symbol>))
  literals: ((& <bfd-section>))
{
 asection* sec = bfd_get_section (*sym);
 obj secobj = alloc (sizeof (asection*), TLREF (0));
 *(asection**) PTR_TO_DATAPTR (secobj) = sec;
 REG0 = secobj;
 RETURN1 ();
})

(define-sim-glue (bfd-symbol-get-name (sym <bfd-symbol>))
{
 const char* name = bfd_asymbol_name (*sym);
 REG0 = make_string (name);
 RETURN1 ();
})

(define-sim-glue (bfd-symbol-get-value (sym <bfd-symbol>))
{
 bfd_vma value = bfd_asymbol_value (*sym);
 // FIXME: 64 bit targets wip
 REG0 = rs_make_unsigned_int (value);
 RETURN1 ();
})