1 (*****************************************************************************) 2 (***** Devellopement d'applications avec Objective Caml *****) 3 (***** *****) 4 (***** Application : évaluateur BASIC *****) 5 (*****************************************************************************) 6 7 type op_unr = OPPOSE | NON ;; 8 9 type op_bin = 10 PLUS 11 | MOINS 12 | MULT 13 | DIV 14 | MOD 15 | EGAL 16 | INF 17 | INFEQ 18 | SUP 19 | SUPEQ 20 | DIFF 21 | ET 22 | OU;; 23 24 type expression = 25 ExpInt of int 26 | ExpVar of string 27 | ExpStr of string 28 | ExpUnr of op_unr * expression 29 | ExpBin of expression * op_bin * expression;; 30 31 type instruction = 32 Rem of string 33 | Goto of int 34 | Print of expression 35 | Input of string 36 | If of expression * int 37 | Let of string * expression;; 38 39 type ligne = 40 { 41 num : int; 42 inst : instruction 43 };; 44 45 type program = ligne list ;; 46 47 type phrase = 48 Ligne of 49 ligne 50 | List 51 | Run 52 | End;; 53 54 (***************************************************************************) 55 56 let priority_ou = function 57 NON -> 1 58 | OPPOSE -> 7 59 60 let priority_ob = function 61 MULT | DIV -> 6 62 | PLUS | MOINS -> 5 63 | MOD -> 4 64 | EGAL | INF | INFEQ | SUP | SUPEQ | DIFF -> 3 65 | ET | OU -> 2;; 66 67 let pp_opbin = function 68 PLUS -> "+" 69 | MULT -> "*" 70 | MOD -> "%" 71 | MOINS -> "-" 72 | DIV -> "/" 73 | EGAL -> " = " 74 | INF -> " < " 75 | INFEQ -> " <= " 76 | SUP -> " > " 77 | SUPEQ -> " >= " 78 | DIFF -> " <> " 79 | ET -> " & " 80 | OU -> " | " 81 82 let pp_opunr = function 83 OPPOSE -> "-" 84 | NON -> "!";; 85 86 let parenthese x = "(" ^ x ^ ")";; 87 88 let pp_expression = 89 90 let rec ppg pr = function 91 ExpInt n -> (string_of_int n) 92 | ExpVar v -> v 93 | ExpStr s -> "\"" ^ s ^ "\"" 94 | ExpUnr (op,e) -> 95 let res = (pp_opunr op)^(ppg (priority_ou op) e) 96 in if pr=0 then res else parenthese res 97 | ExpBin (e1,op,e2) -> 98 let pr2 = priority_ob op 99 in let res = (ppg pr2 e1)^(pp_opbin op)^(ppd pr2 e2) 100 (* parenthèse si la priorité n'est pas supérieure *) 101 in if pr2 >= pr then res else parenthese res 102 and ppd pr exp = match exp with 103 (* les sous-arbres droits ne diffèrent *) 104 (* que pour les opérateurs binaires *) 105 ExpBin (e1,op,e2) -> 106 let pr2 = priority_ob op 107 in let res = (ppg pr2 e1)^(pp_opbin op)^(ppd pr2 e2) 108 in if pr2 > pr then res else parenthese res 109 | _ -> ppg pr exp 110 in ppg 0 ;; 111 112 let pp_instruction = function 113 Rem s -> "REM " ^ s 114 | Goto n -> "GOTO " ^ (string_of_int n) 115 | Print e -> "PRINT " ^ (pp_expression e) 116 | Input v -> "INPUT " ^ v 117 | If (e,n) -> "IF "^(pp_expression e)^" THEN "^(string_of_int n) 118 | Let (v,e) -> "LET " ^ v ^ " = " ^ (pp_expression e) ;; 119 let pp_ligne l = (string_of_int l.num) ^ " " ^ (pp_instruction l.inst) ;; 120 121 (***************************************************************************) 122 123 type lexeme = Lint of int 124 | Lident of string 125 | Lsymbol of string 126 | Lstring of string 127 | Lfin ;; 128 129 type chaine_lexer = {chaine:string; mutable courant:int; taille:int } ;; 130 131 let init_lex s = { chaine=s; courant=0 ; taille=String.length s } ;; 132 let avance cl = cl.courant <- cl.courant+1 ;; 133 let avance_n cl n = cl.courant <- cl.courant+n ;; 134 let extrait pred cl = 135 let st = cl.chaine and ct = cl.courant in 136 let rec ext n = if n true | _ -> false 142 in function cl -> int_of_string (extrait est_entier cl) 143 let extrait_ident = 144 let est_alpha_num = function 145 'a'..'z' | 'A'..'Z' | '0' .. '9' | '_' -> true 146 | _ -> false 147 in extrait est_alpha_num ;; 148 149 exception LexerErreur ;; 150 let rec lexer cl = 151 let lexer_char c = match c with 152 ' ' 153 | '\t' -> avance cl ; lexer cl 154 | 'a'..'z' 155 | 'A'..'Z' -> Lident (extrait_ident cl) 156 | '0'..'9' -> Lint (extrait_int cl) 157 | '"' -> avance cl ; 158 let res = Lstring (extrait ((<>) '"') cl) 159 in avance cl ; res 160 | '+' | '-' | '*' | '/' | '%' | '&' | '|' | '!' | '=' | '(' | ')' -> 161 avance cl; Lsymbol (String.make 1 c) 162 | '<' 163 | '>' -> avance cl; 164 if cl.courant >= cl.taille then Lsymbol (String.make 1 c) 165 else let cs = cl.chaine.[cl.courant] 166 in ( match (c,cs) with 167 ('<','=') -> avance cl; Lsymbol "<=" 168 | ('>','=') -> avance cl; Lsymbol ">=" 169 | ('<','>') -> avance cl; Lsymbol "<>" 170 | _ -> Lsymbol (String.make 1 c) ) 171 | _ -> raise LexerErreur 172 in 173 if cl.courant >= cl.taille then Lfin 174 else lexer_char cl.chaine.[cl.courant] ;; 175 176 (***************************************************************************) 177 178 type exp_elem = 179 Texp of expression (* expression *) 180 | Tbin of op_bin (* opérateur binaire *) 181 | Tunr of op_unr (* opérateur unaire *) 182 | Tpg (* parenthèse gauche *) ;; 183 184 exception ParseErreur ;; 185 186 let symb_unr = function 187 "!" -> NON | "-" -> OPPOSE | _ -> raise ParseErreur 188 189 let symb_bin = function 190 "+" -> PLUS | "-" -> MOINS | "*" -> MULT | "/" -> DIV | "%" -> MOD 191 | "=" -> EGAL | "<" -> INF | "<=" -> INFEQ | ">" -> SUP 192 | ">=" -> SUPEQ | "<>" -> DIFF | "&" -> ET | "|" -> OU 193 | _ -> raise ParseErreur 194 let tsymb s = try Tbin (symb_bin s) with ParseErreur -> Tunr (symb_unr s) ;; 195 196 let reduit pr = function 197 (Texp e)::(Tunr op)::st when (priority_ou op) >= pr 198 -> (Texp (ExpUnr (op,e)))::st 199 | (Texp e1)::(Tbin op)::(Texp e2)::st when (priority_ob op) >= pr 200 -> (Texp (ExpBin (e2,op,e1)))::st 201 | _ -> raise ParseErreur ;; 202 203 let rec empile_ou_reduit lex stack = match lex , stack with 204 Lint n , _ -> (Texp (ExpInt n))::stack 205 | Lident v , _ -> (Texp (ExpVar v))::stack 206 | Lstring s , _ -> (Texp (ExpStr s))::stack 207 | Lsymbol "(" , _ -> Tpg::stack 208 | Lsymbol ")" , (Texp e)::Tpg::st -> (Texp e)::st 209 | Lsymbol ")" , _ -> empile_ou_reduit lex (reduit 0 stack) 210 | Lsymbol s , _ 211 -> let symbole = 212 if s<>"-" then tsymb s 213 (* lever l'ambiguïté du symbole ``-'' *) 214 (* suivant la pile (i.e dernier exp_elem empilé) *) 215 else match stack 216 with (Texp _)::_ -> Tbin MOINS 217 | _ -> Tunr OPPOSE 218 in ( match symbole with 219 Tunr op -> (Tunr op)::stack 220 | Tbin op -> 221 ( try empile_ou_reduit lex (reduit (priority_ob op) 222 stack ) 223 with ParseErreur -> (Tbin op)::stack ) 224 | _ -> raise ParseErreur ) 225 | _ , _ -> raise ParseErreur ;; 226 227 let rec reduit_tout = function 228 | [] -> raise ParseErreur 229 | [Texp x] -> x 230 | st -> reduit_tout (reduit 0 st) ;; 231 232 let parse_exp fin cl = 233 let p = ref 0 234 in let rec parse_un stack = 235 let l = ( p:=cl.courant ; lexer cl) 236 in if not (fin l) then parse_un (empile_ou_reduit l stack) 237 else ( cl.courant <- !p ; reduit_tout stack ) 238 in parse_un [] ;; 239 240 let parse_inst cl = match lexer cl with 241 Lident s -> ( match s with 242 "REM" -> Rem (extrait (fun _ -> true) cl) 243 | "GOTO" -> Goto (match lexer cl with 244 Lint p -> p 245 | _ -> raise ParseErreur) 246 | "INPUT" -> Input (match lexer cl with 247 Lident v -> v 248 | _ -> raise ParseErreur) 249 | "PRINT" -> Print (parse_exp ((=) Lfin) cl) 250 | "LET" -> 251 let l2 = lexer cl and l3 = lexer cl 252 in ( match l2 ,l3 with 253 (Lident v,Lsymbol "=") -> Let (v,parse_exp ((=) Lfin) cl) 254 | _ -> raise ParseErreur ) 255 | "IF" -> 256 let test = parse_exp ((=) (Lident "THEN")) cl 257 in ( match ignore (lexer cl) ; lexer cl with 258 Lint n -> If (test,n) 259 | _ -> raise ParseErreur ) 260 | _ -> raise ParseErreur ) 261 | _ -> raise ParseErreur ;; 262 263 let parse str = 264 let cl = init_lex str 265 in match lexer cl with 266 Lint n -> Ligne { num=n ; inst=parse_inst cl } 267 | Lident "LIST" -> List 268 | Lident "RUN" -> Run 269 | Lident "END" -> End 270 | _ -> raise ParseErreur ;; 271 272 (***************************************************************************) 273 274 type valeur = Vint of int | Vstr of string | Vbool of bool ;; 275 276 type environnement = (string * valeur) list ;; 277 278 type code = ligne array ;; 279 280 type etat_exec = { ligne:int ; xprog:code ; xenv:environnement } ;; 281 282 exception RunErreur of int 283 let runerr n = raise (RunErreur n) ;; 284 285 exception Resultat_cherche_indice of int ;; 286 let cherche_indice tprog num_ligne = 287 try 288 for i=0 to (Array.length tprog)-1 do 289 let mun_i = tprog.(i).num 290 in if mun_i=num_ligne then raise (Resultat_cherche_indice i) 291 else if mun_i>num_ligne then raise (Resultat_cherche_indice (-1)) 292 done ; 293 (-1 ) 294 with Resultat_cherche_indice i -> i ;; 295 296 let assemble prog = 297 let tprog = Array.of_list prog in 298 for i=0 to (Array.length tprog)-1 do 299 match tprog.(i).inst with 300 Goto n -> let indice = cherche_indice tprog n 301 in tprog.(i) <- { tprog.(i) with inst = Goto indice } 302 | If(c,n) -> let indice = cherche_indice tprog n 303 in tprog.(i) <- { tprog.(i) with inst = If (c,indice) } 304 | _ -> () 305 done ; 306 tprog ;; 307 308 let rec eval_exp n envt expr = match expr with 309 ExpInt p -> Vint p 310 | ExpVar v -> ( try List.assoc v envt with Not_found -> runerr n ) 311 | ExpUnr (OPPOSE,e) -> 312 ( match eval_exp n envt e with 313 Vint p -> Vint (-p) 314 | _ -> runerr n ) 315 | ExpUnr (NON,e) -> 316 ( match eval_exp n envt e with 317 Vbool p -> Vbool (not p) 318 | _ -> runerr n ) 319 | ExpStr s -> Vstr s 320 | ExpBin (e1,op,e2) 321 -> match eval_exp n envt e1 , op , eval_exp n envt e2 with 322 Vint v1 , PLUS , Vint v2 -> Vint (v1 + v2) 323 | Vint v1 , MOINS , Vint v2 -> Vint (v1 - v2) 324 | Vint v1 , MULT , Vint v2 -> Vint (v1 * v2) 325 | Vint v1 , DIV , Vint v2 when v2<>0 -> Vint (v1 / v2) 326 | Vint v1 , MOD , Vint v2 when v2<>0 -> Vint (v1 mod v2) 327 328 | Vint v1 , EGAL , Vint v2 -> Vbool (v1 = v2) 329 | Vint v1 , DIFF , Vint v2 -> Vbool (v1 <> v2) 330 | Vint v1 , INF , Vint v2 -> Vbool (v1 < v2) 331 | Vint v1 , SUP , Vint v2 -> Vbool (v1 > v2) 332 | Vint v1 , INFEQ , Vint v2 -> Vbool (v1 <= v2) 333 | Vint v1 , SUPEQ , Vint v2 -> Vbool (v1 >= v2) 334 335 | Vbool v1 , ET , Vbool v2 -> Vbool (v1 && v2) 336 | Vbool v1 , OU , Vbool v2 -> Vbool (v1 || v2) 337 338 | Vstr v1 , PLUS , Vstr v2 -> Vstr (v1 ^ v2) 339 | _ , _ , _ -> runerr n ;; 340 341 let rec ajoute v e env = match env with 342 [] -> [v,e] 343 | (w,f)::l -> if w=v then (v,e)::l else (w,f)::(ajoute v e l) ;; 344 345 let print_valeur v = match v with 346 Vint n -> print_int n 347 | Vbool true -> print_string "true" 348 | Vbool false -> print_string "false" 349 | Vstr s -> print_string s ;; 350 351 let ligne_suivante etat = 352 let n = etat.ligne+1 in 353 if n < Array.length etat.xprog then n else -1 ;; 354 355 let eval_inst etat = 356 match etat.xprog.(etat.ligne).inst with 357 Rem _ -> { etat with ligne = ligne_suivante etat } 358 | Print e -> print_valeur (eval_exp etat.ligne etat.xenv e) ; 359 print_newline () ; 360 { etat with ligne = ligne_suivante etat } 361 | Let(v,e) -> let ev = eval_exp etat.ligne etat.xenv e 362 in { etat with ligne = ligne_suivante etat ; 363 xenv = ajoute v ev etat.xenv } 364 | Goto n -> { etat with ligne = n } 365 | Input v -> let x = try read_int () 366 with Failure "int_of_string" -> 0 367 in { etat with ligne = ligne_suivante etat; 368 xenv = ajoute v (Vint x) etat.xenv } 369 | If (t,n) -> match eval_exp etat.ligne etat.xenv t with 370 Vbool true -> { etat with ligne = n } 371 | Vbool false -> { etat with ligne = ligne_suivante etat } 372 | _ -> runerr etat.ligne ;; 373 374 let rec run etat = 375 if etat.ligne = -1 then etat else run (eval_inst etat) ;; 376 377 (***************************************************************************) 378 379 380 let rec inserer ligne p = match p with 381 [] -> [ligne] 382 | l::prog -> 383 if l.num < ligne.num then l::(inserer ligne prog) 384 else if l.num=ligne.num then ligne::prog 385 else ligne::l::prog ;; 386 387 let print_prog prog = 388 let print_ligne x = print_string (pp_ligne x) ; print_newline () in 389 print_newline () ; 390 List.iter print_ligne prog ; 391 print_newline () ;; 392 393 type etat_boucle = { prog:program; env:environnement } ;; 394 395 exception Fin ;; 396 let une_commande etat = 397 print_string "> " ; flush stdout ; 398 try 399 match parse (input_line stdin) with 400 Ligne l -> { etat with prog = inserer l etat.prog } 401 | List -> (print_prog etat.prog ; etat ) 402 | Run 403 -> let tprog = assemble etat.prog in 404 let xetat = run { ligne = 0; xprog = tprog; xenv = etat.env } in 405 {etat with env = xetat.xenv } 406 | End -> raise Fin 407 with 408 LexerErreur -> print_string "Illegal character\n"; etat 409 | ParseErreur -> print_string "syntax error\n"; etat 410 | RunErreur n -> 411 print_string "runtime error at line "; 412 print_int n ; 413 print_string "\n"; 414 etat ;; 415 416 let go () = 417 try 418 print_string "Mini-BASIC version 0.1\n\n"; 419 let rec loop etat = loop (une_commande etat) in 420 loop { prog = []; env = [] } 421 with Fin -> print_string "A bientôt...\n";; 422 423 go () ;; 424 425 426 427 428