syntax.ml

   1: (** Abstract syntax *)
   2: 
   3: (** The type of identifiers *)
   4: type name = string
   5: 
   6: (** Arithmetical operations *)
   7: type arithop = Plus | Minus | Times | Divide | Remainder
   8: 
   9: (** Comparisons *)
  10: type cmpop = Less | Equal | Unequal
  11: 
  12: (** Logical operators *)
  13: type boolop = And | Or
  14: 
  15: (** Expressions *)
  16: type expr =
  17:   | Var of name                      (** variable *)
  18:   | Bool of bool                     (** boolean constant [true] or [false] *)                
  19:   | Int of int                       (** integer constant *)
  20:   | ArithOp of arithop * expr * expr (** arithmetical operation [e1 op e2] *)
  21:   | Not of expr                      (** logical negation [not e] *)
  22:   | CmpOp of cmpop * expr * expr     (** comparison [e1 cmp e2] *)
  23:   | BoolOp of boolop * expr * expr   (** logical operator [e1 op e2] *)
  24:   | If of expr * expr * expr         (** conditional statement [if e1 then e2 else e3] *)
  25:   | Skip                             (** command [skip], does nothing *)
  26:   | Seq of expr * expr               (** sequencing of expressions [e1; e2] *)
  27:   | Let of name * expr * expr        (** local definition [let x = e1 in e2] *)
  28:   | App of expr * expr               (** application [e1 e2] *)
  29:   | Fun of name * expr               (** function [fun x -> e] *)
  30:   | This                             (** the object [this] *)
  31:   | Object of (name * expr) list     (** object with given attributes [{a1=e1, ..., an=en}] *)
  32:   | Copy of expr                     (** (shallow) copy of an object [copy e] *)
  33:   | With of expr * expr              (** object extension [e1 with e2] *)
  34:   | Project of expr * name           (** attribute projection [e.x] *)
  35:   | Assign of expr * name * expr     (** set the value of an attribute [e1.x := e2] *)
  36: 
  37: 
  38: (** Expressions evaluate to objects which are represented by the type [ob]. *)
  39: type ob =
  40:   | ObjInt of int                    (** integer *)
  41:   | ObjBool of bool                  (** boolean *)
  42:   | ObjFunc of closure               (** closure (represents a function) *)
  43:   | ObjDict of (name * ob ref) list  (** object [{a1=e1, ..., an=en}] *)
  44:   | ObjWith of ob * ob               (** extended object [ob1 with ob2] *)
  45: 
  46: (** A closure [(th, (x, env, e))] represents a function [fun x -> e] in
  47:     environment [th, env], where [th] is the value of object [this] and [env]
  48:     is the environment of local definitions accessible by the function. *)
  49: and closure = ob option * (name * env * expr)
  50: 
  51: (** An environment is a list of pairs [(x,ob)], mapping a variable [x] to
  52:     a value [ob]. *)
  53: and env = (name * ob) list
  54: 
  55: (** Toplevel commands *)
  56: type toplevel_cmd =
  57:     Expr of expr (** Expressions *)
  58:   | Def of name * expr (** Global definition [let x = e] *)
  59:   | Use of string (** Include file [$use "<filename>"] *)
  60:   | Quit (** Exit toplevel [$quit] *)

eval.ml

   1: (** Evaluation of expressions *)
   2: 
   3: open Syntax
   4: 
   5: (** Exception [Runtime_error] is raised if evaluation gets stuck. *)
   6: exception Runtime_error of string
   7: 
   8: let runtime msg = raise (Runtime_error msg)
   9: 
  10: (** [copy ob] makes a shallow copy of object [ob]. *)
  11: let rec copy = function
  12:   | (ObjInt _ | ObjBool _ | ObjFunc _) as u -> u
  13:   | ObjDict lst -> ObjDict (List.map (fun (x,v) -> (x, ref (!v))) lst)
  14:   | ObjWith (u,v) -> ObjWith (copy u, copy v)
  15: 
  16: (** [attributes ob] returns the list of atributes of object [ob]. *)
  17: let rec attributes = function
  18:   | ObjInt _ | ObjBool _ | ObjFunc _ -> []
  19:   | ObjDict lst -> List.map fst lst
  20:   | ObjWith (u, v) ->
  21:       let lst1 = attributes u in
  22:       let lst2 = attributes v in
  23:         lst1 @ (List.filter (fun x -> not (List.mem x lst1)) lst2)
  24: 
  25: (** [get_int ob] returns [ob] as an integer. *)
  26: let rec get_int = function
  27:   | ObjInt k -> k
  28:   | ObjBool _ | ObjFunc _ | ObjDict _ -> runtime "Not an integer"
  29:   | ObjWith (u, v) -> (try get_int v with Runtime_error _ -> get_int u)
  30: 
  31: (** [get_bool ob] returns [ob] as a boolean. *)
  32: let rec get_bool = function
  33:   | ObjBool b -> b
  34:   | ObjInt _ | ObjFunc _ | ObjDict _ -> runtime "Not an boolean"
  35:   | ObjWith (u, v) -> (try get_bool v with Runtime_error _ -> get_bool u)
  36: 
  37: (** [get_func ob] returns [ob] as a function. *)
  38: let rec get_func = function
  39:   | ObjFunc c -> c
  40:   | ObjInt _ | ObjBool _ | ObjDict _ -> runtime "Not a function"
  41:   | ObjWith (u, v) -> (try get_func v with Runtime_error _ -> get_func u)
  42: 
  43: (** [get_attr x ob] returns the value of attribute [x] in object [ob]. *)
  44: let rec get_attr x = function
  45:   | ObjInt _ | ObjBool _ | ObjFunc _ -> runtime ("No such attribute " ^ x)
  46:   | ObjDict d -> (try List.assoc x d with Not_found -> runtime ("No such attribute " ^ x))
  47:   | ObjWith (u, v) -> (try get_attr x v with Runtime_error _ -> get_attr x u)
  48: 
  49: (** Mapping from arithmetical operations to corresponding Ocaml functions. *)
  50: let arith = function
  51:   | Plus ->  ( + )
  52:   | Minus -> ( - )
  53:   | Times -> ( * )
  54:   | Divide -> ( / )
  55:   | Remainder -> ( mod )
  56: 
  57: (** Mapping from comparisons to corresponding Ocaml functions. *)
  58: let cmp = function
  59:   | Equal -> ( = )
  60:   | Unequal -> ( <> )
  61:   | Less -> ( < )
  62: 
  63: 
  64: (** [string_of_obj ob] converts [ob] to a string. *)
  65: let rec string_of_obj u =
  66:   let primitives =
  67:     (try [string_of_int (get_int u)] with Runtime_error _ -> []) @
  68:     (try [string_of_bool (get_bool u)] with Runtime_error _ -> []) @
  69:     (try ignore (get_func u); ["<fun>"] with Runtime_error _ -> [])
  70:   in
  71:     String.concat " with " (
  72:       primitives @
  73:         (match attributes u with
  74:            | [] -> if primitives = [] then ["{}"] else []
  75:            | lst -> ["{" ^
  76:                (String.concat ", " 
  77:                   (List.map (fun x -> x ^ " = " ^ string_of_obj !(get_attr x u)) lst)
  78:                ) ^ "}"]))
  79: 
  80: (** [eval th env e] evaluates expression [e] in environment [env] with object
  81:     this set to [th]. It returns a value of type [ob]. *)
  82: let rec eval th env = function
  83: 
  84:   | Var x ->
  85:       (try List.assoc x env with Not_found -> runtime ("No such variable " ^ x))
  86: 
  87:   | Int k -> ObjInt k
  88: 
  89:   | Bool b -> ObjBool b
  90: 
  91:   | ArithOp (op, e1, e2) -> 
  92:       let v1 = eval th env e1 in
  93:       let v2 = eval th env e2 in
  94:         ObjInt (arith op (get_int v1) (get_int v2))
  95: 
  96:   | Not e ->
  97:       let v = eval th env e in
  98:         ObjBool (not (get_bool v))
  99: 
 100:   | CmpOp (op, e1, e2) -> 
 101:       let v1 = eval th env e1 in
 102:       let v2 = eval th env e2 in
 103:         ObjBool (cmp op (get_int v1) (get_int v2))
 104: 
 105:   | BoolOp (And, e1, e2) ->
 106:       ObjBool (get_bool (eval th env e1) && get_bool (eval th env e2))
 107: 
 108:   | BoolOp (Or, e1, e2) ->
 109:       ObjBool (get_bool (eval th env e1) || get_bool (eval th env e2))
 110: 
 111:   | If (e1, e2, e3) ->
 112:       if get_bool (eval th env e1) then
 113:         eval th env e2
 114:       else
 115:         eval th env e3
 116: 
 117:   | Skip -> ObjDict []
 118: 
 119:   | Seq (e1, e2) ->
 120:       ignore (eval th env e1) ; eval th env e2
 121: 
 122:   | Let (x, e1, e2) ->
 123:       let v = eval th env e1 in
 124:         eval th ((x,v)::env) e2
 125: 
 126:   | App (e1, e2) ->
 127:       let v1 = eval th env e1 in
 128:       let v2 = eval th env e2 in
 129:       let th', (x, env', e) = get_func v1 in
 130:         eval th' ((x,v2)::env') e
 131: 
 132:   | Fun (x, e) -> ObjFunc (th, (x, env, e))
 133: 
 134:   | This ->
 135:       (match th with
 136:          | Some v -> v
 137:          | None -> runtime "No this here")
 138: 
 139:   | Object lst ->
 140:       ObjDict (List.map (fun (x,e) -> (x, ref (eval th env e))) lst)
 141: 
 142:   | Copy e -> copy (eval th env e)
 143: 
 144:   | With (e1, e2) ->
 145:       let v1 = eval th env e1 in
 146:       let v2 = eval th env e2 in
 147:         ObjWith (v1, v2)
 148: 
 149:   | Project (e, x) ->
 150:       let u = eval th env e in
 151:       let v = !(get_attr x u) in
 152:         (try
 153:            (* Ce je [e.x] funkcija, ji nastavimo vrednost this na [e]. *)
 154:            let (_, c) = get_func v in
 155:              ObjWith (v, ObjFunc (Some u, c))
 156:          with Runtime_error _ -> v)
 157: 
 158:   | Assign (e1, x, e2) ->
 159:       let v1 = eval th env e1 in
 160:       let v2 = eval th env e2 in
 161:         (get_attr x v1) := v2; v2

lexer.mll

   1: {
   2:   open Parser
   3:   open Lexing
   4: 
   5:   let incr_linenum lexbuf =
   6:     let pos = lexbuf.lex_curr_p in
   7:     lexbuf.lex_curr_p <- { pos with
   8:       pos_lnum = pos.pos_lnum + 1;
   9:       pos_bol = pos.pos_cnum;
  10:     }
  11: }
  12: 
  13: let var = ['_' 'a'-'z' 'A'-'Z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9']*
  14: 
  15: rule token = parse
  16:     "#" [^'\n']* '\n'   { incr_linenum lexbuf; token lexbuf }
  17:   | '\n'            { incr_linenum lexbuf; token lexbuf }
  18:   | [' ' '\t']      { token lexbuf }
  19:   | ['0'-'9']+      { INT (int_of_string(lexeme lexbuf)) }
  20:   | "and"           { AND }
  21:   | "copy"          { COPY }
  22:   | "else"          { ELSE }
  23:   | "false"         { FALSE }
  24:   | "fun"           { FUN }
  25:   | "if"            { IF }
  26:   | "in"            { IN }
  27:   | "let"           { LET }  
  28:   | "not"           { NOT }
  29:   | "or"            { OR }
  30:   | "skip"          { SKIP }
  31:   | "then"          { THEN }
  32:   | "this"          { THIS }
  33:   | "true"          { TRUE }
  34:   | "with"          { WITH }
  35:   | "$use"          { USE }
  36:   | "$quit"         { QUIT }
  37:   | "->"            { ARROW }
  38:   | ":="            { ASSIGN }
  39:   | ";"             { SEMICOLON }
  40:   | ";;"            { SEMICOLON2 }
  41:   | '\"' [^'\"']* '\"' { let str = lexeme lexbuf in
  42:                         STRING (String.sub str 1 (String.length str - 2)) }
  43:   | '('             { LPAREN }
  44:   | ')'             { RPAREN }
  45:   | '{'             { LBRACE }
  46:   | '}'             { RBRACE }
  47:   | '+'             { PLUS }
  48:   | '-'             { MINUS }
  49:   | '*'             { TIMES }
  50:   | '/'             { DIVIDE }
  51:   | '%'             { REMAINDER }
  52:   | ','             { COMMA }
  53:   | '.'             { PERIOD }
  54:   | '='             { EQUAL }
  55:   | '<'             { LESS }
  56:   | "<>"            { UNEQUAL }
  57:   | var             { VAR (lexeme lexbuf) }
  58:   | eof             { EOF }
  59: 
  60: {
  61: }

parser.mly

   1: %{
   2:   open Syntax
   3: %}
   4: 
   5: %token LBRACE RBRACE WITH COPY
   6: %token COLON COMMA SEMICOLON PERIOD
   7: %token <Syntax.name> VAR
   8: %token THIS
   9: %token <int> INT
  10: %token PLUS MINUS TIMES DIVIDE REMAINDER
  11: %token TRUE FALSE
  12: %token EQUAL UNEQUAL LESS
  13: %token AND OR NOT
  14: %token IF THEN ELSE
  15: %token FUN ARROW
  16: %token LPAREN RPAREN
  17: %token LET IN
  18: %token ASSIGN SKIP
  19: %token QUIT
  20: %token SEMICOLON2
  21: %token USE
  22: %token <string>STRING
  23: %token EOF
  24: 
  25: %start toplevel
  26: %type <Syntax.toplevel_cmd list> toplevel
  27: 
  28: %right SEMICOLON2
  29: %right COMMA
  30: %nonassoc LET IN
  31: %right FUN ARROW
  32: $right SEMICOLON
  33: %nonassoc IF THEN ELSE
  34: %left OR
  35: %left AND
  36: $nonassoc NOT
  37: %nonassoc EQUAL UNEQUAL LESS
  38: %nonassoc ASSIGN
  39: %left PLUS MINUS
  40: %left TIMES DIVIDE REMAINDER
  41: %nonassoc COPY
  42: %left WITH
  43: %left PERIOD
  44: 
  45: 
  46: %%
  47: 
  48: toplevel:
  49:   | EOF                      { [] }
  50:   | exprtop                  { $1 }
  51:   | deftop                   { $1 }
  52:   | cmdtop                   { $1 }
  53: 
  54: deftop:
  55:   | def EOF                   { [$1] }
  56:   | def SEMICOLON2 toplevel   { $1 :: $3 }
  57:   | def deftop                { $1 :: $2 }
  58:   | def cmdtop                { $1 :: $2 }
  59: 
  60: exprtop:
  61:   | expr EOF                 { [Expr $1] }
  62:   | expr SEMICOLON2 toplevel { Expr $1 :: $3 }
  63: 
  64: cmdtop:
  65:   | cmd EOF                  { [$1] }
  66:   | cmd SEMICOLON2 toplevel  { $1 :: $3 }
  67: 
  68: cmd:
  69:   | USE STRING { Use $2 }
  70:   | QUIT       { Quit }
  71: 
  72: def:
  73:   | LET VAR EQUAL expr { Def ($2, $4) }
  74: 
  75: expr:
  76:   | non_app             { $1 }
  77:   | app                 { $1 }
  78:   | arith               { $1 }
  79:   | boolean             { $1 }
  80:   | IF expr THEN expr ELSE expr               { If ($2, $4, $6) }
  81:   | FUN VAR ARROW expr                 { Fun ($2, $4) }
  82:   | LET VAR EQUAL expr IN expr         { Let ($2, $4, $6) }
  83:   | non_app PERIOD VAR ASSIGN expr     { Assign ($1, $3, $5) }
  84:   | expr SEMICOLON expr                { Seq ($1, $3) }
  85: 
  86: app:
  87:     app non_app         { App ($1, $2) }
  88:   | non_app non_app     { App ($1, $2) }
  89: 
  90: non_app:
  91:     VAR                                  { Var $1 }
  92:   | THIS                          { This }
  93:   | TRUE                          { Bool true }
  94:   | FALSE                         { Bool false }
  95:   | INT                                  { Int $1 }
  96:   | SKIP                          { Skip }
  97:   | LPAREN expr RPAREN                  { $2 }    
  98:   | non_app PERIOD VAR            { Project ($1, $3) }
  99:   | LBRACE fields RBRACE          { Object $2 }
 100:   | COPY non_app                  { Copy $2 }
 101:   | non_app WITH non_app          { With ($1, $3) }
 102: 
 103: arith:
 104:   | expr PLUS   expr        { ArithOp (Plus, $1, $3) }
 105:   | expr MINUS expr        { ArithOp (Minus, $1, $3) }
 106:   | expr TIMES  expr        { ArithOp (Times, $1, $3) }
 107:   | expr DIVIDE expr        { ArithOp (Divide, $1, $3) }
 108:   | expr REMAINDER expr        { ArithOp (Remainder, $1, $3) }
 109: 
 110: boolean:
 111:   | NOT expr            { Not $2 }
 112:   | expr LESS expr      { CmpOp (Less, $1, $3) }
 113:   | expr EQUAL expr     { CmpOp (Equal, $1, $3) }
 114:   | expr UNEQUAL expr   { CmpOp (Unequal, $1, $3) }
 115:   | expr AND expr       { BoolOp (And, $1, $3) }
 116:   | expr OR expr        { BoolOp (Or, $1, $3) }
 117: 
 118: field:
 119:   | VAR EQUAL expr              { ($1, $3) }
 120: 
 121: fields:
 122:   |                                 { [] }
 123:   | field                           { [$1] }
 124:   | field COMMA fields              { $1 :: $3 }
 125: 
 126: %%

boa.ml

   1: (** Boa toplevel. *)
   2: 
   3: open Message
   4: open Syntax
   5: 
   6: (** Exception [Fatal_error] is raised when further evaluation is
   7:     impossible. *)
   8: exception Fatal_error of string
   9: 
  10: (** [fatal_error msg] raises exception [Fatal_error msg]. *)
  11: let fatal_error msg = raise (Fatal_error msg)
  12: 
  13: (** [exec_cmd env c] executes toplevel command [c] in global
  14:     environment [env]. It prints the result on standard output and return
  15:     the new environment. *)
  16: let rec exec_cmd env = function
  17:     Expr e ->
  18:       (* evaluate [e] *)
  19:       let v = Eval.eval None env e in
  20:         print_string (Eval.string_of_obj v) ;
  21:         print_newline () ;
  22:         env
  23:   | Def (x, e) ->
  24:       (* define a new global value *)
  25:       let v = Eval.eval None env e in
  26:         print_string (x ^ " = " ^ Eval.string_of_obj v) ;
  27:         print_newline () ;
  28:         (x,v)::env
  29:   | Quit -> raise End_of_file
  30:   | Use fn -> exec_file env fn
  31: 
  32: (** [exec file env fn] executes the contents of file [fn] in global
  33:     environment [env]. It prints results on the standard output and
  34:     returns the new environment. *)
  35: and exec_file env fn =
  36:   let fh = open_in fn in
  37:   let lex = Message.lexer_from_channel fn fh in
  38:     try
  39:       let cmds = Parser.toplevel Lexer.token lex in
  40:         close_in fh ;
  41:         exec_cmds env cmds
  42:     with
  43:       | Eval.Runtime_error msg -> fatal_error ("runtime error:" ^ msg)
  44:       | Sys.Break -> fatal_error "Interrupted."
  45:       | Parsing.Parse_error | Failure("lexing: empty token") ->
  46:           fatal_error (Message.syntax_error lex)
  47: 
  48: (** [exec_cmds env cmds] executes the list of commands [cmds] in
  49:     environment [env] and returns the new environment. *)
  50: and exec_cmds env cmds =
  51:   List.fold_left exec_cmd env cmds
  52: ;;
  53: 
  54: (** [shell env] runs the interactive shell in environment [env]. *)
  55: let shell env =
  56:   print_string ("Boa. Press ") ;
  57:   print_string (match Sys.os_type with
  58:                     "Unix" | "Cygwin" -> "Ctrl-D"
  59:                   | "Win32" -> "Ctrl-Z"
  60:                   | _ -> "EOF") ;
  61:   print_endline " to exit." ;
  62:   let global_env = ref env in
  63:     try
  64:       while true do
  65:         try
  66:           print_string "Boa> ";
  67:           let str = read_line () in
  68:           let lex = Message.lexer_from_string str in
  69:             (* parse a list of commands and execute them *)
  70:           let cmds =
  71:             try
  72:               Parser.toplevel Lexer.token lex
  73:             with
  74:               | Failure("lexing: empty token")
  75:               | Parsing.Parse_error -> fatal_error (Message.syntax_error lex)
  76:           in
  77:           let env = exec_cmds !global_env cmds in
  78:             (* set the new global environment *)
  79:             global_env := env
  80:         with
  81:           | Fatal_error msg -> Message.report msg
  82:           | Eval.Runtime_error msg -> Message.report ("runtime error: " ^ msg)
  83:           | Sys.Break -> Message.report ("Interrupted.")
  84:       done 
  85:     with
  86:         End_of_file -> print_endline "\nGood bye."
  87: 
  88: (** Main program *)
  89: let main =
  90:   Sys.catch_break true ;
  91:   let noninteractive = ref false in
  92:   let files = ref [] in
  93:     Arg.parse
  94:       [("-n", Arg.Set noninteractive, "do not run interactive shell")]
  95:       (fun f -> files := f :: !files)
  96:       "Usage: boa [-n] [file] ..." ;
  97:     files := List.rev !files ;
  98:     let env =
  99:       try
 100:         List.fold_left exec_file [] !files
 101:       with
 102:           Fatal_error msg -> Message.report msg ; exit 1
 103:     in    
 104:       if not !noninteractive then shell env