< code, env >
#include <stdio.h>
#include <caml/mlvalues.h>
#include <caml/memory.h>
value print_ws (value v) {
CAMLparam1(v);
int taille,i ;
if (Is_long(v)) printf("%d", Long_val(v));
else {
taille=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 (taille>0) printf("%g", Double_field(v,0));
for (i=1;i<(taille/2);i++) printf("; %g", Double_field(v,i));
printf("|]");
break;
case Abstract_tag :
case Final_tag :
printf("<abstract>");
break;
case Closure_tag :
printf("<%d, ",Code_val(v)) ;
if (taille>1) print_ws(Field(v,1)) ;
for (i=2;i<taille;i++) {
printf("; ") ;
print_ws(Field(v,i));
}
printf(">");
break;
default:
if (Tag_val(v)>=No_scan_tag) printf("?");
else {
printf("(");
if (taille>0) print_ws(Field(v,0));
for (i=1;i<taille;i++) {
printf(", ");
print_ws(Field(v,i));
}
printf(")");
}
}
}
fflush(stdout);
return Val_unit;
}
appelée depuis Objective CAML:
# externalprint_ws:'a->unit="print_ws";;external print_ws : 'a -> unit = "print_ws"
# typeadresse;;type adresse
# 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>
# typeoccurence=Une_fois|Plusieurs_fois|Deja_nommeofstring;;type occurence = | Une_fois | Plusieurs_fois | Deja_nomme of string
# lettable=Hashtbl.create17;;val table : ('_a, '_b) Hashtbl.t = <abstr>
# letajoute(adr:adresse)=trymatchHashtbl.findtableadrwithUne_fois->Hashtbl.removetableadr;Hashtbl.addtableadrPlusieurs_fois;true|_->truewithNot_found->Hashtbl.addtableadrUne_fois;false;;val ajoute : adresse -> bool = <fun>
# letmultiple_occadr=matchHashtbl.findtableadrwithUne_fois->false|_->true;;val multiple_occ : adresse -> bool = <fun>
# letdeja_nommeadr=matchHashtbl.findtableadrwithUne_fois->failwith"deja_nomme"|Plusieurs_fois->Hashtbl.removetableadr;Hashtbl.addtableadr(Deja_nomme(gensym()));false|_->true;;val deja_nomme : adresse -> bool = <fun>
# letnom_deadr=matchHashtbl.findtableadrwithDeja_nommes->s|_->raiseNot_found;;val nom_de : adresse -> string = <fun>
La partie C :
# Callback.register"add"ajoute;;- : unit = ()
# Callback.register"multiple?"multiple_occ;;- : unit = ()
# Callback.register"named?"deja_nomme;;- : unit = ()
# Callback.register"name"nom_de;;- : unit = ()
# externalexplore_value:'a->unit="explore";;external explore_value : 'a -> unit = "explore"
#include <caml/callback.h>
value explore (value v) {
CAMLparam1(v);
int taille,i ;
if (Is_long(v)) return Val_unit;
if (Bool_val(callback(*caml_named_value("add"),v))) return Val_unit;
taille=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<taille;i++) explore(Field(v,i));
break;
default:
if (Tag_val(v)>=No_scan_tag) break ;
for (i=1;i<taille;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 taille,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))) ;
}
taille=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 (taille>1) print_gen(Field(v,1)) ;
for (i=2;i<taille;i++) {
printf("; ") ;
print_gen(Field(v,i));
}
printf(">");
break;
default:
if (Tag_val(v)>=No_scan_tag) printf("?");
else {
printf("(");
if (taille>0) print_gen(Field(v,0));
for (i=1;i<taille;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=Hashtbl.cleartable;init_gensym();explore_valuev;print_recv;;
# typefloat_matrix;;type float_matrix
typedef struct { int size_x , size_y ;
float * mat ;
} Matrix ;
value conversion_to_C (value faa) {
CAMLparam1(faa) ;
CAMLlocal1(vres) ;
Matrix * res ;
int size_x, size_y ;
/* taille du vecteur de vecteur */
size_x = Wosize_val(faa) ;
if (size_x>0) size_y = Wosize_val(Field(faa,0))/2 ;
/* allocation de la valeur float_matrix */
vres=alloc(sizeof(Matrix),Abstract_tag) ;
res=(Matrix *) vres ;
res->size_x = size_x ;
res->size_y = size_y ;
if (size_x*size_y==0) res->mat=0 ;
else {
int i,j ;
float * tab ;
value vect ;
res->mat=tab=(float *) alloc(sizeof(float)*size_x*size_y,Abstract_tag) ;
for (i=0;i<size_x;i++) {
vect = Field(faa,i) ;
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 size = mat->size_x*mat->size_y ;
int i,j ;
res=alloc(mat->size_x,0);
for (i=0;i<mat->size_x;i++) {
aux = alloc(2*mat->size_y,Double_array_tag) ;
Field(res,i) = aux ;
for (j=0;j<mat->size_y;j++) Store_double_field(aux,j,*(tab++)) ;
}
CAMLreturn res ;
}
value plus (value arg1,value arg2) {
CAMLparam2(arg1,arg2) ;
CAMLlocal1(vres) ;
Matrix *m1=(Matrix*) arg1, *m2=(Matrix*) arg2,*res;
float *tab;
int i,size=m1->size_x*m1->size_y ;
vres=alloc(sizeof(Matrix),Abstract_tag) ;
res =(Matrix*) vres;
res->size_x=m1->size_x;
res->size_y=m1->size_y;
res->mat=tab=(float *) alloc(sizeof(float)*size,Abstract_tag) ;
for (i=0;i<size;i++) tab[i]=m1->mat[i]+m2->mat[i] ;
CAMLreturn vres;
}
value prod (value arg1,value arg2) {
CAMLparam2(arg1,arg2) ;
CAMLlocal1(vres) ;
Matrix *m1=(Matrix*) arg1, *m2=(Matrix*) arg2,*res;
float *tab;
int i,j,k;
vres=alloc(sizeof(Matrix),Abstract_tag) ;
res =(Matrix*) vres;
res->size_x=m1->size_x;
res->size_y=m2->size_y;
res->mat=tab=(float *) alloc(sizeof(float)*res->size_x*res->size_y,
Abstract_tag) ;
for (i=0;i<res->size_x;i++)
for (j=0;j<res->size_y;j++) {
float 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";;
# externalsomme:float_matrix->float_matrix->float_matrix="plus";;
# externalproduit:float_matrix->float_matrix->float_matrix="prod";;
#include <stdio.h>
void read_file (char *path) {
FILE *fd=fopen(path,"r");
int car=0;
char buffer[80], *buff;
int nb_car=0, nb_mots=0, nb_lignes=0;
buff=buffer; *buff=0;
if (!fd) exit(-1) ;
while ((car=getc(fd))!=EOF) {
nb_car++ ;
if (car=='\n') nb_lignes++ ;
if (car==' ' || car=='\n' ||(buff-buffer)>=80) {
if (buff!=buffer) { nb_mots++; buff=0; buff=buffer; }
}
else *(buff++)=car;
}
printf(" %d - %d - %d : %s\n",nb_lignes,nb_mots,nb_car,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>
# letajoute_mot(m:string)=tryletp=Hashtbl.findtableminincrpwithNot_found->Hashtbl.addtablem(ref1);;val ajoute_mot : string -> unit = <fun>
# letnb_mots_repetes()=leti=ref0inHashtbl.iter(fun_n->if!n>1thenincri)table;!i;;val nb_mots_repetes : unit -> int = <fun>
# letnb_mots_differents()=leti=ref0inHashtbl.iter(fun__->incri)table;!i;;val nb_mots_differents : unit -> int = <fun>
# Callback.register"add word"ajoute_mot;Callback.register"rep words"nb_mots_repetes;Callback.register"diff words"nb_mots_differents;;- : unit = ()
#include <caml/mlvalues.h> #include <caml/callback.h>
void read_file (char *path) {
FILE *fd = fopen(path,"r") ;
int car=0 ;
char buffer[80],*buff ;
int nb_car=0, nb_mots, nb_lignes=0;
buff=buffer; *buff=0;
if (!fd) exit(-1) ;
while ((car=getc(fd))!=EOF) {
nb_car++ ;
if (car=='\n') nb_lignes++ ;
if (car==' ' || car=='\n' ||(buff-buffer)>=80) {
if (buff!=buffer) {
nb_mots++;
*buff=0;
buff=buffer;
callback(*caml_named_value("add word"),copy_string(buffer));
}
}
else *(buff++)=car;
}
nb_mots=Int_val(callback(*caml_named_value("diff words"),Val_unit));
printf(" %d - %d - %d\n",nb_lignes,nb_mots,nb_car) ;
}
int main (int argc,char **argv)
{
caml_main(argv);
if (argc>1) read_file(argv[1]);
return 0;
}
Pour compiler en code-octet :
$ cc -c -I /usr/local/lib/ocaml/ wc.c $ ocamlc -custom mots.ml wc.oPour compiler en code-natif :
$ cc -c -I /usr/local/lib/ocaml/ wc.c $ ocamlopt mots.ml wc.o
int main (int argc,char **argv)
{
caml_startup(argv);
if (argc>1) read_file(argv[1]);
return 0;
}
Pour compiler en code-octet :
$ ocamlc -output-obj mots.ml -o mots.o $ gcc -c -I /usr/local/lib/ocaml/ wc.c $ gcc mots.o wc.o -L /usr/local/lib/ocaml/ -lcamlrun -lcursesPour compiler en code-natif :
$ ocamlopt -output-obj mots.ml -o motsprog.o $ gcc -c -I /usr/local/lib/ocaml/ wc.c $ gcc motsprog.o wc.o -L /usr/local/lib/ocaml/ -lasmrun