< 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