.ml. The files will be organized like this: abstract syntax (syntax.ml), printing (pprint.ml), parsing (alexsynt.ml) and evaluation of instructions (eval.ml). The head of each file should contain the open statements to load the modules required for compilation.
typeop_unr=OPPOSE|NON;;
typeop_bin=PLUS|MINUS|MULT|DIV|MOD|EQUAL|INF|INFEQ|SUP|SUPEQ|DIFF|AND|OR;;
typeexpression=ExpIntofint|ExpVarofstring|ExpStrofstring|ExpUnrofop_unr*expression|ExpBinofexpression*op_bin*expression;;
typeinstruction=Remofstring|Gotoofint|ofexpression|Inputofstring|Ifofexpression*int|Letofstring*expression;;
typeline={num:int;inst:instruction};;
typeprogram=linelist;;
typephrase=Lineofline|List|Run|End;;
letpriority_ou=functionNON->1|OPPOSE->7
letpriority_ob=functionMULT|DIV->6|PLUS|MINUS->5|MOD->4|EQUAL|INF|INFEQ|SUP|SUPEQ|DIFF->3|AND|OR->2;;
letpp_opbin=functionPLUS->"+"|MULT->"*"|MOD->"%"|MINUS->"-"|DIV->"/"|EQUAL->" = "|INF->" < "|INFEQ->" <= "|SUP->" > "|SUPEQ->" >= "|DIFF->" <> "|AND->" & "|OR->" | "
letpp_opunr=functionOPPOSE->"-"|NON->"!";;
openSyntax;;
letparenthesisx="("^x^")";;
letpp_expression=letrecppgpr=functionExpIntn->(string_of_intn)|ExpVarv->v|ExpStrs->"\""^s^"\""|ExpUnr(op,e)->letres=(pp_opunrop)^(ppg(priority_ouop)e)inifpr=0thenreselseparenthesisres|ExpBin(e1,op,e2)->letpr2=priority_obopinletres=(ppgpr2e1)^(pp_opbinop)^(ppdpr2e2)(* parenthesis if the priority is not higher *)inifpr2>=prthenreselseparenthesisresandppdprexp=matchexpwith(* the sub-trees could only be different *)(* in their binary operators *)ExpBin(e1,op,e2)->letpr2=priority_obopinletres=(ppgpr2e1)^(pp_opbinop)^(ppdpr2e2)inifpr2>prthenreselseparenthesisres|_->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_linel=(string_of_intl.num)^" "^(pp_instructionl.inst);;
openSyntax;;
typelexeme=Lintofint|Lidentofstring|Lsymbolofstring|Lstringofstring|Lfin;;
typestr_lexer={str:string;mutableposition:int;size:int};;
letinit_lexs={str=s;position=0;size=String.lengths};;
letadvancecl=cl.position<-cl.position+1;;
letadvance_ncln=cl.position<-cl.position+n;;
letextractpredcl=letst=cl.strandct=cl.positioninletrecextn=ifn<cl.size&&(predst.[n])thenext(n+1)elseninletres=extctincl.position<-res;String.subcl.strct(res-ct);;
letextract_int=letis_integer=function'0'..'9'->true|_->falseinfunctioncl->int_of_string(extractis_integercl)
letextract_ident=letis_alpha_num=function'a'..'z'|'A'..'Z'|'0'..'9'|'_'->true|_->falseinextractis_alpha_num;;
exceptionLexerError;;
letreclexercl=letlexer_charc=matchcwith' '|'\t'->advancecl;lexercl|'a'..'z'|'A'..'Z'->Lident(extract_identcl)|'0'..'9'->Lint(extract_intcl)|'"'->advancecl;letres=Lstring(extract((<>)'"')cl)inadvancecl;res|'+'|'-'|'*'|'/'|'%'|'&'|'|'|'!'|'='|'('|')'->advancecl;Lsymbol(String.make1c)|'<'|'>'->advancecl;ifcl.position>=cl.sizethenLsymbol(String.make1c)elseletcs=cl.str.[cl.position]in(match(c,cs)with('<','=')->advancecl;Lsymbol"<="|('>','=')->advancecl;Lsymbol">="|('<','>')->advancecl;Lsymbol"<>"|_->Lsymbol(String.make1c))|_->raiseLexerErrorinifcl.position>=cl.sizethenLfinelselexer_charcl.str.[cl.position];;
typeexp_elem=Texpofexpression(* expression *)|Tbinofop_bin(* binary operator *)|Tunrofop_unr(* unary operator *)|Tpg(* right parenthesis *);;
exceptionParseError;;
letsymb_unr=function"!"->NON|"-"->OPPOSE|_->raiseParseError
letsymb_bin=function"+"->PLUS|"-"->MINUS|"*"->MULT|"/"->DIV|"%"->MOD|"="->EQUAL|"<"->INF|"<="->INFEQ|">"->SUP|">="->SUPEQ|"<>"->DIFF|"&"->AND|"|"->OR|_->raiseParseError
lettsymbs=tryTbin(symb_bins)withParseError->Tunr(symb_unrs);;
letreducepr=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|_->raiseParseError;;
letrecpile_or_reducelexstack=matchlex,stackwithLintn,_->(Texp(ExpIntn))::stack|Lidentv,_->(Texp(ExpVarv))::stack|Lstrings,_->(Texp(ExpStrs))::stack|Lsymbol"(",_->Tpg::stack|Lsymbol")",(Texpe)::Tpg::st->(Texpe)::st|Lsymbol")",_->pile_or_reducelex(reduce0stack)|Lsymbols,_->letsymbole=ifs<>"-"thentsymbs(* resolve the ambiguity of the symbol ``-'' *)(* follow the stack (i.e last exp_elem pile) *)elsematchstackwith(Texp_)::_->TbinMINUS|_->TunrOPPOSEin(matchsymbolewithTunrop->(Tunrop)::stack|Tbinop->(trypile_or_reducelex(reduce(priority_obop)stack)withParseError->(Tbinop)::stack)|_->raiseParseError)|_,_->raiseParseError;;
letrecreduce_all=function|[]->raiseParseError|[Texpx]->x|st->reduce_all(reduce0st);;
letparse_expfincl=letp=ref0inletrecparse_unstack=letl=(p:=cl.position;lexercl)inifnot(finl)thenparse_un(pile_or_reducelstack)else(cl.position<-!p;reduce_allstack)inparse_un[];;
letparse_instcl=matchlexerclwithLidents->(matchswith"REM"->Rem(extract(fun_->true)cl)|"GOTO"->Goto(matchlexerclwithLintp->p|_->raiseParseError)|"INPUT"->Input(matchlexerclwithLidentv->v|_->raiseParseError)|"PRINT"->(parse_exp((=)Lfin)cl)|"LET"->letl2=lexerclandl3=lexerclin(matchl2,l3with(Lidentv,Lsymbol"=")->Let(v,parse_exp((=)Lfin)cl)|_->raiseParseError)|"IF"->lettest=parse_exp((=)(Lident"THEN"))clin(matchignore(lexercl);lexerclwithLintn->If(test,n)|_->raiseParseError)|_->raiseParseError)|_->raiseParseError;;
letparsestr=letcl=init_lexstrinmatchlexerclwithLintn->Line{num=n;inst=parse_instcl}|Lident"LIST"->List|Lident"RUN"->Run|Lident"END"->End|_->raiseParseError;;
openSyntax;;
openPprint;;
openAlexsynt;;
typevl=Vintofint|Vstrofstring|Vboolofbool;;
typeenvironment=(string*vl)list;;
typestate={line:int;prog:program;env:environment};;
exceptionRunErrorofint
letrunerrn=raise(RunErrorn);;
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,MINUS,Vintv2->Vint(v1-v2)|Vintv1,MULT,Vintv2->Vint(v1*v2)|Vintv1,DIV,Vintv2whenv2<>0->Vint(v1/v2)|Vintv1,MOD,Vintv2whenv2<>0->Vint(v1modv2)|Vintv1,EQUAL,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,AND,Vboolv2->Vbool(v1&&v2)|Vboolv1,OR,Vboolv2->Vbool(v1||v2)|Vstrv1,PLUS,Vstrv2->Vstr(v1^v2)|_,_,_->runerrn;;
letrecaddveenv=matchenvwith[]->[v,e]|(w,f)::l->ifw=vthen(v,e)::lelse(w,f)::(addvel);;
letrecgoto_linenprog=matchprogwith[]->runerrn|l::ll->ifl.num=nthenprogelseifl.num<nthengoto_linenllelserunerrn;;
letprint_vlv=matchvwithVintn->print_intn|Vbooltrue->print_string"true"|Vboolfalse->print_string"false"|Vstrs->print_strings;;
leteval_inststate=letlc,ns=matchgoto_linestate.linestate.progwith[]->failwith"empty program"|lc::[]->lc,-1|lc::ls::_->lc,ls.numinmatchlc.instwithRem_->{statewithline=ns}|e->print_vl(eval_explc.numstate.enve);print_newline();{statewithline=ns}|Let(v,e)->letev=eval_explc.numstate.envein{statewithline=ns;env=addvevstate.env}|Goton->{statewithline=n}|Inputv->letx=tryread_int()withFailure"int_of_string"->0in{statewithline=ns;env=addv(Vintx)state.env}|If(t,n)->matcheval_explc.numstate.envtwithVbooltrue->{statewithline=n}|Vboolfalse->{statewithline=ns}|_->runerrn;;
letrecrunstate=ifstate.line=-1thenstateelserun(eval_inststate);;
letrecinsertlinep=matchpwith[]->[line]|l::prog->ifl.num<line.numthenl::(insertlineprog)elseifl.num=line.numthenline::progelseline::l::prog;;
letprint_progstate=letprint_linex=print_string(pp_linex);print_newline()inprint_newline();List.iterprint_linestate.prog;print_newline();;
letpremiere_line=function[]->0|i::_->i.num;;
exceptionFin
letone_commandstate=print_string"> ";flushstdout;trymatchparse(input_linestdin)withLinel->{statewithprog=insertlstate.prog}|List->(print_progstate;state)|Run->run{statewithline=premiere_linestate.prog}|End->raiseFinwithLexerError->print_string"Illegal character\n";state|ParseError->print_string"syntax error\n";state|RunErrorn->print_string"runtime error at line ";print_intn;print_string"\n";state;;
letgo()=
tryprint_string"Mini-BASIC version 0.1\n\n";letrecloopstate=loop(one_commandstate)inloop{line=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.1.1 2000/06/26 14:37:50 xleroy 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.1.1 2000/06/26 14:37:50 xleroy 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 |