 
 
 
< code, env >
#include <stdio.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
value print_ws (value v) {
  CAMLparam1(v);
  int size,i ;
  if (Is_long(v)) printf("%d", Long_val(v)); 
  else {
    size=Wosize_val(v);
    switch (Tag_val(v)) 
      {
      case String_tag :
 printf("\"%s\"", String_val(v));  
 break;
      case Double_tag:  
 printf("%g", Double_val(v));
 break;
      case Double_array_tag : 
 printf ("[|"); 
        if (size>0) printf("%g", Double_field(v,0));
 for (i=1;i<(size/Double_wosize);i++)  printf("; %g", Double_field(v,i));
 printf("|]");
 break;
      case Abstract_tag :
      case Custom_tag : 
 printf("<abstract>"); 
 break;
      case Closure_tag : 
 printf("<%d, ",Code_val(v)) ;
 if (size>1) print_ws(Field(v,1)) ;
 for (i=2;i<size;i++) {
   printf("; ") ;
   print_ws(Field(v,i));
 }
 printf(">");
 break;
      default:  
 if (Tag_val(v)>=No_scan_tag) printf("?"); 
 else {
   printf("(");
   if (size>0) print_ws(Field(v,0));
   for (i=1;i<size;i++) {
     printf(", ");
     print_ws(Field(v,i));
   }
   printf(")");
 }
      }
  }
  fflush(stdout);
  return Val_unit;
}
called from Objective CAML:
# externalprint_ws:'a->unit="print_ws";;external print_ws : 'a -> unit = "print_ws"
# typeaddress;;type address
# let(gensym,init_gensym)=leti=ref0in(function()->incri;"val_"^(string_of_int!i)),(function()->i:=0);;val gensym : unit -> string = <fun>val init_gensym : unit -> unit = <fun>
# typeoccurrence=Once|Several_times|Already_namedofstring;;type occurrence = | Once | Several_times | Already_named of string
# lettable=ref([]:(address*occurrence)list);;val table : (address * occurrence) list ref = {contents=[]}
# letrecordaddr=trymatchList.assqaddr!tablewithOnce->table:=(addr,Several_times)::!table;true|_->truewithNot_found->table:=(addr,Once)::!table;false;;val record : address -> bool = <fun>
# letmultiple_occaddr=matchList.assqaddr!tablewithOnce->false|_->true;;val multiple_occ : address -> bool = <fun>
# letalready_namedaddr=matchList.assqaddr!tablewithOnce->failwith"already_named"|Several_times->table:=(addr,Already_named(gensym()))::!table;false|Already_named_->true;;val already_named : address -> bool = <fun>
# letname_ofaddr=matchList.assqaddr!tablewithAlready_nameds->s|_->raiseNot_found;;val name_of : address -> string = <fun>
The C part:
# Callback.register"add"ajoute;;- : unit = ()
# Callback.register"multiple?"multiple_occ;;- : unit = ()
# Callback.register"named?"already_named;;- : unit = ()
# Callback.register"name"name_of;;- : unit = ()
# externalexplore_value:'a->unit="explore";;external explore_value : 'a -> unit = "explore"
#include <caml/callback.h>
value explore (value v) {
  CAMLparam1(v);
  int size,i;
  if (Is_long(v)) return Val_unit;
  if (Bool_val(callback(*caml_named_value("add"), v))) return Val_unit;
  size=Wosize_val(v);
  switch (Tag_val(v)) 
    {
      case String_tag :
      case Double_tag:  
      case Double_array_tag : 
      case Abstract_tag :
      case Final_tag : 
        break;
      case Closure_tag : 
        for (i=1;i<size;i++) explore(Field(v,i));
        break;
      default:  
        if (Tag_val(v)>=No_scan_tag) break ;
        for (i=0;i<size;i++) explore(Field(v,i));
    }
  return Val_unit;
}
# externalprint_rec:'a->unit="print_gen";;external print_rec : 'a -> unit = "print_gen"
value print_gen (value v)
{
  CAMLparam1(v);
  int size,i ;
  if (Is_long(v))  return print_ws(v) ;
  if (Bool_val(callback(*caml_named_value("multiple?"),v))) {
    if (Bool_val(callback(*caml_named_value("named?"),v))) {
      printf("%s",String_val(callback(*caml_named_value("name"),v))) ;
      return Val_unit ;
    }
    printf("%s = { ",String_val(callback(*caml_named_value("name"),v))) ;
  }
  size=Wosize_val(v);
  switch (Tag_val(v)) 
    {
      case String_tag :
      case Double_tag:  
      case Double_array_tag : 
      case Abstract_tag :
      case Final_tag : 
 print_ws(v);
 break;
      case Closure_tag : 
 printf("<%d, ",Code_val(v)) ;
 if (size>1) print_gen(Field(v,1)) ;
 for (i=2;i<size;i++) {
   printf("; ") ;
   print_gen(Field(v,i));
 }
 printf(">");
 break;
      default:  
 if (Tag_val(v)>=No_scan_tag) printf("?"); 
 else {
   printf("(");
   if (size>0) print_gen(Field(v,0));
   for (i=1;i<size;i++) {
     printf(", ");
     print_gen(Field(v,i));
   }
   printf(")");
 }
    }
  if (Bool_val(callback(*caml_named_value("multiple?"),v)))  printf(" }") ; 
  fflush(stdout);
  return Val_unit;
}
externalprint_rec:'a->unit="print_gen";;
letv=table:=[];init_gensym();explore_valuev;print_recv;table:=[];;
# typefloat_matrix;;type float_matrix
typedef struct { void (*finalization_function)(value) ;
                 int size_x , size_y ;
                 double * mat ;
               } Matrix ;
static void finalize_matrix(value mat) {
  free(((Matrix *) mat)->mat);
}
static value alloc_matrix(int size_x,int size_y) {
  int byte_size ;
  Matrix * res ;
  vres=alloc(sizeof(Matrix)/sizeof(value),
             finalize_matrix, size_x*size_y, 1000000) ;
  res=(Matrix *) vres ;
  res->size_x = size_x ;
  res->size_y = size_y ;
  res->mat = malloc(size_x*size_y*sizeof(double)) ;
  return vres;
}
value conversion_to_C (value faa) {
  CAMLparam1(faa) ;
  CAMLlocal2(vres,vect) ;
  Matrix * res ;
  double * tab;
  int size_x, size_y, i, j ;
  /* size of the array of arrays */
  size_x = Wosize_val(faa) ;
  /* size of each array */
  if (size_x>0) size_y = Wosize_val(Field(faa,0))/2 ;
  /* allocate the value of type float_matrix */
  vres=alloc_matrix(size_x,size_y);
  res=(Matrix *) vres ;
  res->size_x = size_x ;
  res->size_y = size_y ;
  tab = res->mat;
  for (i=0;i<size_x;i++) {
    vect = Field(faa,i) ;
    if (Wosize_val(vect) != size_y)
      failwith("non-rectangular float array array") ;
    for (j=0;j<size_y;j++) *tab++ = Double_field(vect,j) ;
    }
  }
  CAMLreturn vres ;
}
value conversion_to_Caml (value matrix) {
  CAMLparam1(matrix) ;
  CAMLlocal2(res,aux) ;
  Matrix* mat = (Matrix *) matrix ;
  float * tab = mat->mat ;
  int i,j ;
  res=alloc(mat->size_x,0);
  for (i=0;i<mat->size_x;i++) {
    aux = alloc(mat->size_y*Double_wosize,Double_array_tag) ;
    Store_field(res,i,aux);
    for (j=0;j<mat->size_y;j++) Store_double_field(aux,j,*tab++) ;
  }
  CAMLreturn res ;
}
value matrix_sum (value arg1,value arg2) {
  CAMLparam2(arg1,arg2) ;
  CAMLlocal1(vres) ;
  Matrix *m1=(Matrix*) arg1, *m2=(Matrix*) arg2, *res;
  int size,i;
  if (m1->size_x != m2->size_x || m1->size_y != m2->size_y)
    failwith("illegal matrix addition");
  vres=alloc_matrix(m1->size_x,m1->size_y);
  res =(Matrix*) vres;
  tab=vres->mat;
  size=m1->size_x*m1->size_y;
  for (i=0;i<size;i++) tab[i]=m1->mat[i]+m2->mat[i] ;
  CAMLreturn vres;
}
value matrix_product (value arg1,value arg2) {
  CAMLparam2(arg1,arg2) ;
  CAMLlocal1(vres) ;
  Matrix *m1=(Matrix*) arg1, *m2=(Matrix*) arg2, *res;
  int i,j,k;
  if (m1->size_y != m2->size_x) failwith("illegal matrix product");
  vres=alloc_matrix(m1->size_x,m2->size_y);
  for (i=0;i<res->size_x;i++) 
    for (j=0;j<res->size_y;j++) {
      double acc=0 ;
      for (k=0;k<m1->size_y;k++) 
 acc += m1->mat[i*m1->size_x+k] * m1->mat[k*m2->size_x+j] ;
      tab[i*m1->size_x+j]=acc ;
    }
  CAMLreturn vres;
}
# externalto_matrix:floatarrayarray->float_matrix="conversion_to_C";;
# externalof_matrix:float_matrix->floatarrayarray="conversion_to_Caml";;
# externalsum:float_matrix->float_matrix->float_matrix="matrix_add";;
# externalprod:float_matrix->float_matrix->float_matrix="matrix_product";;
#include <stdio.h>
void read_file (char *path) {
  FILE *fd=fopen(path,"r");
  int chr=0;
  char buffer[80], *buff;
  int num_chr=0, nun_words=0, num_lines=0;
  if (fd == NULL) exit(2) ;
  buff=buffer ; *buff=0 ;
  while ((chr=getc(fd))!=EOF) {
    num_chr++ ;
    if (chr=='\n') num_lines++ ;
    if (chr==' ' || chr=='\n' ||(buff-buffer)>=80) {
      if (buff!=buffer) { num_words++; *buff=0; buff=buffer; }
    }
    else *(buff++)=chr; 
  }
  printf(" %d - %d - %d : %s\n",num_lines,num_words,num_chr,path);
}
int main (int argc,char **argv)
{
  if (argc>1) read_file(argv[1]);
  return 0;
}
# lettable=Hashtbl.create17;;val table : ('_a, '_b) Hashtbl.t = <abstr>
# letadd_word(w:string)=tryletp=Hashtbl.findtablewinincrpwithNot_found->Hashtbl.addtablew(ref1);;val add_word : string -> unit = <fun>
# letnum_repeated_words()=leti=ref0inHashtbl.iter(fun_n->if!n>1thenincri)table;!i;;val num_repeated_words : unit -> int = <fun>
# letnum_unique_words()=leti=ref0inHashtbl.iter(fun__->incri)table;!i;;val num_unique_words : unit -> int = <fun>
# Callback.register"add word"add_word;Callback.register"rep words"num_repeated_words;Callback.register"uni words"num_unique_words;
#include <caml/mlvalues.h> #include <caml/callback.h>
void read_file (char *path) {
  FILE *fd = fopen(path,"r") ;
  int chr=0 ;
  char buffer[80],*buff ;
  int num_chr=0, num_words, num_lines=0;
  if (fd == NULL) exit(2) ;
  buff=buffer; *buff=0;
  while ((chr=getc(fd))!=EOF) {
    num_chr++ ;
    if (chr=='\n') num_lines++ ;
    if (chr==' ' || chr=='\n' ||(buff-buffer)>=80) {
      if (buff!=buffer) { 
 *buff=0;
 buff=buffer;
 callback(*caml_named_value("add word"),copy_string(buffer));
      }
    }
    else *(buff++)=chr; 
  }
  num_words=Int_val(callback(*caml_named_value("uni words"),Val_unit)); 
  printf(" %d - %d - %d : %s\n",num_lines,num_words,num_chr,path);
}
int main (int argc,char **argv)
{
  caml_main(argv);
  if (argc>1) read_file(argv[1]);
  return 0;
}
Compiling to bytecode:
$ cc -c -I /usr/local/lib/ocaml/ wc.c $ ocamlc -custom words.ml wc.oCompiling to native code:
$ cc -c -I /usr/local/lib/ocaml/ wc.c $ ocamlopt words.ml wc.o
int main (int argc,char **argv)
{
  caml_startup(argv);
  if (argc>1) read_file(argv[1]);
  return 0;
}
Compiling to bytecode:
$ ocamlc -output-obj words.ml -o words.o $ gcc -c -I /usr/local/lib/ocaml/ wc.c $ gcc words.o wc.o -L /usr/local/lib/ocaml/ -lcamlrun -lcursesCompiling to native code:
$ ocamlopt -output-obj words.ml -o wordsnat.o $ gcc -c -I /usr/local/lib/ocaml/ wc.c $ gcc wordsnat.o wc.o -L /usr/local/lib/ocaml/ -lasmrun
 
 
