.ml contenant respectivement : la syntaxe abstraite
(syntax.ml), l'afficheur
(pprint.ml), l'analyse syntaxique
(alexsynt.ml) et l'évaluation des
instructions (eval.ml). Chaque début
de fichier contiendra l'ouverture des modules nécessaires à sa
compilation.
typeop_unr=OPPOSE|NON;;
typeop_bin=PLUS|MOINS|MULT|DIV|MOD|EGAL|INF|INFEQ|SUP|SUPEQ|DIFF|ET|OU;;
typeexpression=ExpIntofint|ExpVarofstring|ExpStrofstring|ExpUnrofop_unr*expression|ExpBinofexpression*op_bin*expression;;
typeinstruction=Remofstring|Gotoofint|ofexpression|Inputofstring|Ifofexpression*int|Letofstring*expression;;
typeligne={num:int;inst:instruction};;
typeprogram=lignelist;;
typephrase=Ligneofligne|List|Run|End;;
letpriority_ou=functionNON->1|OPPOSE->7
letpriority_ob=functionMULT|DIV->6|PLUS|MOINS->5|MOD->4|EGAL|INF|INFEQ|SUP|SUPEQ|DIFF->3|ET|OU->2;;
letpp_opbin=functionPLUS->"+"|MULT->"*"|MOD->"%"|MOINS->"-"|DIV->"/"|EGAL->" = "|INF->" < "|INFEQ->" <= "|SUP->" > "|SUPEQ->" >= "|DIFF->" <> "|ET->" & "|OU->" | "
letpp_opunr=functionOPPOSE->"-"|NON->"!";;
openSyntax;;
letparenthesex="("^x^")";;
letpp_expression=letrecppgpr=functionExpIntn->(string_of_intn)|ExpVarv->v|ExpStrs->"\""^s^"\""|ExpUnr(op,e)->letres=(pp_opunrop)^(ppg(priority_ouop)e)inifpr=0thenreselseparentheseres|ExpBin(e1,op,e2)->letpr2=priority_obopinletres=(ppgpr2e1)^(pp_opbinop)^(ppdpr2e2)(* parenthèse si la priorite n'est pas supérieure *)inifpr2>=prthenreselseparentheseresandppdprexp=matchexpwith(* les sous-arbres droits ne diffèrent *)(* que pour les opérateurs binaires *)ExpBin(e1,op,e2)->letpr2=priority_obopinletres=(ppgpr2e1)^(pp_opbinop)^(ppdpr2e2)inifpr2>prthenreselseparentheseres|_->ppgprexpinppg0;;
letpp_instruction=functionRems->"REM "^s|Goton->"GOTO "^(string_of_intn)|e->"PRINT "^(pp_expressione)|Inputv->"INPUT "^v|If(e,n)->"IF "^(pp_expressione)^" THEN "^(string_of_intn)|Let(v,e)->"LET "^v^" = "^(pp_expressione);;
letpp_lignel=(string_of_intl.num)^" "^(pp_instructionl.inst);;
openSyntax;;
typelexeme=Lintofint|Lidentofstring|Lsymbolofstring|Lstringofstring|Lfin;;
typechaine_lexer={chaine:string;mutablecourant:int;taille:int};;
letinit_lexs={chaine=s;courant=0;taille=String.lengths};;
letavancecl=cl.courant<-cl.courant+1;;
letavance_ncln=cl.courant<-cl.courant+n;;
letextraitpredcl=letst=cl.chaineandct=cl.courantinletrecextn=ifn<cl.taille&&(predst.[n])thenext(n+1)elseninletres=extctincl.courant<-res;String.subcl.chainect(res-ct);;
letextrait_int=letest_entier=function'0'..'9'->true|_->falseinfunctioncl->int_of_string(extraitest_entiercl)
letextrait_ident=letest_alpha_num=function'a'..'z'|'A'..'Z'|'0'..'9'|'_'->true|_->falseinextraitest_alpha_num;;
exceptionLexerErreur;;
letreclexercl=letlexer_charc=matchcwith' '|'\t'->avancecl;lexercl|'a'..'z'|'A'..'Z'->Lident(extrait_identcl)|'0'..'9'->Lint(extrait_intcl)|'"'->avancecl;letres=Lstring(extrait((<>)'"')cl)inavancecl;res|'+'|'-'|'*'|'/'|'%'|'&'|'|'|'!'|'='|'('|')'->avancecl;Lsymbol(String.make1c)|'<'|'>'->avancecl;ifcl.courant>=cl.taillethenLsymbol(String.make1c)elseletcs=cl.chaine.[cl.courant]in(match(c,cs)with('<','=')->avancecl;Lsymbol"<="|('>','=')->avancecl;Lsymbol">="|('<','>')->avancecl;Lsymbol"<>"|_->Lsymbol(String.make1c))|_->raiseLexerErreurinifcl.courant>=cl.taillethenLfinelselexer_charcl.chaine.[cl.courant];;
typeexp_elem=Texpofexpression(* expression *)|Tbinofop_bin(* opérateur binaire *)|Tunrofop_unr(* opérateur unaire *)|Tpg(* parenthèse gauche *);;
exceptionParseErreur;;
letsymb_unr=function"!"->NON|"-"->OPPOSE|_->raiseParseErreur
letsymb_bin=function"+"->PLUS|"-"->MOINS|"*"->MULT|"/"->DIV|"%"->MOD|"="->EGAL|"<"->INF|"<="->INFEQ|">"->SUP|">="->SUPEQ|"<>"->DIFF|"&"->ET|"|"->OU|_->raiseParseErreur
lettsymbs=tryTbin(symb_bins)withParseErreur->Tunr(symb_unrs);;
letreduitpr=function(Texpe)::(Tunrop)::stwhen(priority_ouop)>=pr->(Texp(ExpUnr(op,e)))::st|(Texpe1)::(Tbinop)::(Texpe2)::stwhen(priority_obop)>=pr->(Texp(ExpBin(e2,op,e1)))::st|_->raiseParseErreur;;
letrecempile_ou_reduitlexstack=matchlex,stackwithLintn,_->(Texp(ExpIntn))::stack|Lidentv,_->(Texp(ExpVarv))::stack|Lstrings,_->(Texp(ExpStrs))::stack|Lsymbol"(",_->Tpg::stack|Lsymbol")",(Texpe)::Tpg::st->(Texpe)::st|Lsymbol")",_->empile_ou_reduitlex(reduit0stack)|Lsymbols,_->letsymbole=ifs<>"-"thentsymbs(* lever l'ambiguïte du symbole ``-'' *)(* suivant la pile (i.e dernier exp_elem empile) *)elsematchstackwith(Texp_)::_->TbinMOINS|_->TunrOPPOSEin(matchsymbolewithTunrop->(Tunrop)::stack|Tbinop->(tryempile_ou_reduitlex(reduit(priority_obop)stack)withParseErreur->(Tbinop)::stack)|_->raiseParseErreur)|_,_->raiseParseErreur;;
letrecreduit_tout=function|[]->raiseParseErreur|[Texpx]->x|st->reduit_tout(reduit0st);;
letparse_expfincl=letp=ref0inletrecparse_unstack=letl=(p:=cl.courant;lexercl)inifnot(finl)thenparse_un(empile_ou_reduitlstack)else(cl.courant<-!p;reduit_toutstack)inparse_un[];;
letparse_instcl=matchlexerclwithLidents->(matchswith"REM"->Rem(extrait(fun_->true)cl)|"GOTO"->Goto(matchlexerclwithLintp->p|_->raiseParseErreur)|"INPUT"->Input(matchlexerclwithLidentv->v|_->raiseParseErreur)|"PRINT"->(parse_exp((=)Lfin)cl)|"LET"->letl2=lexerclandl3=lexerclin(matchl2,l3with(Lidentv,Lsymbol"=")->Let(v,parse_exp((=)Lfin)cl)|_->raiseParseErreur)|"IF"->lettest=parse_exp((=)(Lident"THEN"))clin(matchignore(lexercl);lexerclwithLintn->If(test,n)|_->raiseParseErreur)|_->raiseParseErreur)|_->raiseParseErreur;;
letparsestr=letcl=init_lexstrinmatchlexerclwithLintn->Ligne{num=n;inst=parse_instcl}|Lident"LIST"->List|Lident"RUN"->Run|Lident"END"->End|_->raiseParseErreur;;
openSyntax;;
openPprint;;
openAlexsynt;;
typevaleur=Vintofint|Vstrofstring|Vboolofbool;;
typeenvironnement=(string*valeur)list;;
typeetat={ligne:int;prog:program;env:environnement};;
exceptionRunErreurofint
letrunerrn=raise(RunErreurn);;
letreceval_expnenvtexpr=matchexprwithExpIntp->Vintp|ExpVarv->(tryList.assocvenvtwithNot_found->runerrn)|ExpUnr(OPPOSE,e)->(matcheval_expnenvtewithVintp->Vint(-p)|_->runerrn)|ExpUnr(NON,e)->(matcheval_expnenvtewithVboolp->Vbool(notp)|_->runerrn)|ExpStrs->Vstrs|ExpBin(e1,op,e2)->matcheval_expnenvte1,op,eval_expnenvte2withVintv1,PLUS,Vintv2->Vint(v1+v2)|Vintv1,MOINS,Vintv2->Vint(v1-v2)|Vintv1,MULT,Vintv2->Vint(v1*v2)|Vintv1,DIV,Vintv2whenv2<>0->Vint(v1/v2)|Vintv1,MOD,Vintv2whenv2<>0->Vint(v1modv2)|Vintv1,EGAL,Vintv2->Vbool(v1=v2)|Vintv1,DIFF,Vintv2->Vbool(v1<>v2)|Vintv1,INF,Vintv2->Vbool(v1<v2)|Vintv1,SUP,Vintv2->Vbool(v1>v2)|Vintv1,INFEQ,Vintv2->Vbool(v1<=v2)|Vintv1,SUPEQ,Vintv2->Vbool(v1>=v2)|Vboolv1,ET,Vboolv2->Vbool(v1&&v2)|Vboolv1,OU,Vboolv2->Vbool(v1||v2)|Vstrv1,PLUS,Vstrv2->Vstr(v1^v2)|_,_,_->runerrn;;
letrecajouteveenv=matchenvwith[]->[v,e]|(w,f)::l->ifw=vthen(v,e)::lelse(w,f)::(ajoutevel);;
letrecgoto_lignenprog=matchprogwith[]->runerrn|l::ll->ifl.num=nthenprogelseifl.num<nthengoto_lignenllelserunerrn;;
letprint_valeurv=matchvwithVintn->print_intn|Vbooltrue->print_string"true"|Vboolfalse->print_string"false"|Vstrs->print_strings;;
leteval_instetat=letlc,ns=matchgoto_ligneetat.ligneetat.progwith[]->failwith"programme vide"|lc::[]->lc,-1|lc::ls::_->lc,ls.numinmatchlc.instwithRem_->{etatwithligne=ns}|e->print_valeur(eval_explc.numetat.enve);print_newline();{etatwithligne=ns}|Let(v,e)->letev=eval_explc.numetat.envein{etatwithligne=ns;env=ajoutevevetat.env}|Goton->{etatwithligne=n}|Inputv->letx=tryread_int()withFailure"int_of_string"->0in{etatwithligne=ns;env=ajoutev(Vintx)etat.env}|If(t,n)->matcheval_explc.numetat.envtwithVbooltrue->{etatwithligne=n}|Vboolfalse->{etatwithligne=ns}|_->runerrn;;
letrecrunetat=ifetat.ligne=-1thenetatelserun(eval_instetat);;
letrecinsererlignep=matchpwith[]->[ligne]|l::prog->ifl.num<ligne.numthenl::(insererligneprog)elseifl.num=ligne.numthenligne::progelseligne::l::prog;;
letprint_progetat=letprint_lignex=print_string(pp_lignex);print_newline()inprint_newline();List.iterprint_ligneetat.prog;print_newline();;
letpremiere_ligne=function[]->0|i::_->i.num;;
exceptionFin
letune_commandeetat=print_string"> ";flushstdout;trymatchparse(input_linestdin)withLignel->{etatwithprog=insererletat.prog}|List->(print_progetat;etat)|Run->run{etatwithligne=premiere_ligneetat.prog}|End->raiseFinwithLexerErreur->print_string"Illegal character\n";etat|ParseErreur->print_string"syntax error\n";etat|RunErreurn->print_string"runtime error at line ";print_intn;print_string"\n";etat;;
letgo()=
tryprint_string"Mini-BASIC version 0.1\n\n";letrecloopetat=loop(une_commandeetat)inloop{ligne=0;prog=[];env=[]}
withFin->print_string"A bientôt...\n";;
$ ocamlc -c syntax.ml $ ocamlc -c pprint.ml $ ocamlc -c alexsynt.ml $ ocamlc -c eval.ml
openEval;;
go();;
$ ocamlmktop -o topbasic syntax.cmo pprint.cmo alexsynt.cmo eval.cmo mainbasic.mltest du toplevel :
$ topbasic
Mini-BASIC version 0.1
> 10 PRINT "DONNER UN NOMBRE"
> 20 INPUT X
> 30 PRINT X
> LIST
10 PRINT "DONNER UN NOMBRE"
20 INPUT X
30 PRINT X
> RUN
DONNER UN NOMBRE
44
44
> END
A bientôt...
Objective Caml version 2.04
#
$ ocamlc -custom -o basic.exe syntax.cmo pprint.cmo alexsynt.cmo eval.cmo mainbasic.mltest de l'exécutable autonome :
$ basic.exe Mini-BASIC version 0.1 > 10 PRINT "BONJOUR" > LIST 10 PRINT "BONJOUR" > RUN BONJOUR > END A bientôt... $
(***********************************************************************)(* *)(* Objective Caml *)(* *)(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)(* *)(* Copyright 1996 Institut National de Recherche en Informatique et *)(* Automatique. Distributed only by permission. *)(* *)(***********************************************************************)(* $Id: sort.mli,v 1.1 2000/01/21 09:40:00 emmanuel Exp $ *)(* Module [Sort]: sorting and merging lists *)
vallist:('a->'a->bool)->'alist->'alist(* Sort a list in increasing order according to an ordering predicate.The predicate should return [true] if its first argument isless than or equal to its second argument. *)
valarray:('a->'a->bool)->'aarray->unit(* Sort an array in increasing order according to anordering predicate.The predicate should return [true] if its first argument isless than or equal to its second argument.The array is sorted in place. *)
valmerge:('a->'a->bool)->'alist->'alist->'alist(* Merge two lists according to the given predicate.Assuming the two argument lists are sorted according to thepredicate, [merge] returns a sorted list containing the elementsfrom the two lists. The behavior is undefined if the twoargument lists were not sorted. *)
(***********************************************************************)(* *)(* Objective Caml *)(* *)(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)(* *)(* Copyright 1996 Institut National de Recherche en Informatique et *)(* Automatique. Distributed only by permission. *)(* *)(***********************************************************************)(* $Id: sort.ml,v 1.1 2000/01/21 09:18:40 emmanuel Exp $ *)(* Merging and sorting *)
openArray
letrecmergeorderl1l2=matchl1with[]->l2|h1::t1->matchl2with[]->l1|h2::t2->iforderh1h2thenh1::mergeordert1l2elseh2::mergeorderl1t2
letlistorderl=letrecinitlist=function[]->[]|[e]->[[e]]|e1::e2::rest->(ifordere1e2then[e1;e2]else[e2;e1])::initlistrestinletrecmerge2=functionl1::l2::rest->mergeorderl1l2::merge2rest|x->xinletrecmergeall=function[]->[]|[l]->l|llist->mergeall(merge2llist)inmergeall(initlistl)
letswaparrij=lettmp=unsafe_getarriinunsafe_setarri(unsafe_getarrj);unsafe_setarrjtmp
letarrayorderarr=letrecqsortlohi=ifhi<=lothen()elseifhi-lo<5thenbegin(* Use insertion sort *)fori=lo+1tohidoletval_i=unsafe_getarriiniforderval_i(unsafe_getarr(i-1))thenbeginunsafe_setarri(unsafe_getarr(i-1));letj=ref(i-1)inwhile!j>=1&&orderval_i(unsafe_getarr(!j-1))dounsafe_setarr!j(unsafe_getarr(!j-1));decrjdone;unsafe_setarr!jval_ienddoneendelsebeginletmid=(lo+hi)lsr1in(* Select median value from among LO, MID, and HI *)letpivotpos=letvlo=unsafe_getarrloandvhi=unsafe_getarrhiandvmid=unsafe_getarrmidinifordervlovmidthenifordervmidvhithenmidelseifordervlovhithenhielseloelseifordervhivmidthenmidelseifordervhivlothenhielseloinswaparrpivotposhi;letpivot=unsafe_getarrhiinleti=refloandj=refhiinwhile!i<!jdowhile!i<hi&&order(unsafe_getarr!i)pivotdoincridone;while!j>lo&&orderpivot(unsafe_getarr!j)dodecrjdone;if!i<!jthenswaparr!i!jdone;swaparr!ihi;(* Recurse on larger half first *)if(!i-1)-lo>=hi-(!i+1)thenbeginqsortlo(!i-1);qsort(!i+1)hiendelsebeginqsort(!i+1)hi;qsortlo(!i-1)endendinqsort0(Array.lengtharr-1)
letintervalordernextab=letrecauxa=ifnot(orderab)then[a]elsea::aux(nexta)inauxa;;
letmain()=letil=Interval.interval(>)(funx->x-1)5000020andil2=Interval.interval(<)(funx->x+1)2050000inSort.list(<)il,Sort.list(>)il2;;
main();;
ocamlc -custom -o trilbyte.exe sort.mli sort.ml interval.ml trilist.ml
ocamlopt -o trilopt.exe sort.mli sort.ml interval.ml trilist.ml
| trilbyte.exe | trilopt.exe |
| 2,55 secondes (user) | 1,67 secondes (user) |
letmain()=letil=Array.of_list(Interval.interval(>)(funx->x-1)5000020)andil2=Array.of_list(Interval.interval(<)(funx->x+1)2050000)inSort.array(<)il,Sort.array(>)il2;;
main();;
ocamlc -custom -o triabyte.exe sort.mli sort.ml interval.ml triarray.ml
ocamlopt -o triaoptu.exe sort.mli sort.ml interval.ml triarray.ml
| triabyte.exe | triaopt.exe |
| 515 s | 106 s |