< 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)
=
let
i
=
ref
0
in
(function
()
->
incr
i
;
"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_nomme
of
string
;;
type occurence = | Une_fois | Plusieurs_fois | Deja_nomme of string
# lettable
=
Hashtbl.create
1
7
;;
val table : ('_a, '_b) Hashtbl.t = <abstr>
# letajoute
(adr
:
adresse)
=
try
match
Hashtbl.find
table
adr
with
Une_fois
->
Hashtbl.remove
table
adr
;
Hashtbl.add
table
adr
Plusieurs_fois
;
true
|
_
->
true
with
Not_found
->
Hashtbl.add
table
adr
Une_fois
;
false
;;
val ajoute : adresse -> bool = <fun>
# letmultiple_occ
adr
=
match
Hashtbl.find
table
adr
with
Une_fois
->
false
|
_
->
true
;;
val multiple_occ : adresse -> bool = <fun>
# letdeja_nomme
adr
=
match
Hashtbl.find
table
adr
with
Une_fois
->
failwith
"deja_nomme"
|
Plusieurs_fois
->
Hashtbl.remove
table
adr
;
Hashtbl.add
table
adr
(Deja_nomme
(gensym
()))
;
false
|
_
->
true
;;
val deja_nomme : adresse -> bool = <fun>
# letnom_de
adr
=
match
Hashtbl.find
table
adr
with
Deja_nomme
s
->
s
|
_
->
raise
Not_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.clear
table
;
init_gensym
()
;
explore_value
v
;
print_rec
v
;;
# 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
:
float
array
array
->
float_matrix
=
"conversion_to_C"
;;
# externalof_matrix
:
float_matrix
->
float
array
array
=
"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.create
1
7
;;
val table : ('_a, '_b) Hashtbl.t = <abstr>
# letajoute_mot
(m
:
string)
=
try
let
p
=
Hashtbl.find
table
m
in
incr
p
with
Not_found
->
Hashtbl.add
table
m
(ref
1
);;
val ajoute_mot : string -> unit = <fun>
# letnb_mots_repetes
()
=
let
i
=
ref
0
in
Hashtbl.iter
(fun
_
n
->
if
!
n>
1
then
incr
i)
table
;
!
i;;
val nb_mots_repetes : unit -> int = <fun>
# letnb_mots_differents
()
=
let
i
=
ref
0
in
Hashtbl.iter
(fun
_
_
->
incr
i)
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