(* Bicicleta language interpreter Copyright (C) 2007 Kragen Javier Sitaker This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor Boston, MA 02110-1301, USA *) (* translation of metacircular_bicicleta_interpreter into OCaml, using polymorphic variants to avoid type declarations *) let rec get gkey = function | `Phi -> (`Error("key not found", gkey)) | `Add(key, value, next) -> if gkey = key then value else get gkey next ;; let rec eval env = function | `Name name -> get name env | `Call(object_, method_name) -> let object_ = eval env object_ in apply (objectget method_name object_) object_ | `Literal(self, methods) -> bind `ProtoObject env self methods | `Derivation(object_, self, methods) -> let object_ = eval env object_ in bind object_ env self methods | `StringConstant(string) -> `BicStr string and bind base env self = function | `NoDefs -> base | `Definition(name, body, next) -> bind (derive name body self env base) env self next and objectget key = function | `ProtoObject -> `Error("method not found", key) | `Derive(name, self, body, env, next) as m -> if key = name then m else objectget key next | `Error(_, _) as obj -> obj | `BicStr _ -> (`Error("strings have no methods", key)) and derive name body self env o = `Derive(name, self, body, env, o) and apply method_ self = match method_ with | `Derive(name, methodself, body, env, next) -> eval (`Add(methodself, self, env)) body | `Error(_, _) as err -> err (* is this right? *) | _ -> `Error("trying to apply non-method", "") ;; (* for debugging: deparse an expression. Could be considered a specification of a subset of the grammar, but does not exercise the following: - newlines - the x{...}.'()' as x(...) syntactic sugar - the x.'*'(y) as x * y syntactic sugar - the x{arg1=a, arg2=b, arg3=c} as x{a, b, c} syntactic sugar *) let is_identifier string = let is_id_start_char ch = let code = Char.code ch in (code >= Char.code 'A' && code <= Char.code 'Z') || (code >= Char.code 'a' && code <= Char.code 'z') || ch = '_' in let is_id_char ch = is_id_start_char ch || let code = Char.code ch in (code >= Char.code '0' && code <= Char.code '9') in let rec test string ii = if ii = String.length string then true else is_id_char string.[ii] && test string (ii + 1) in String.length string > 0 && is_id_start_char string.[0] && test string 1 ;; (* XXX '\'' *) let escname name = if is_identifier name then name else "'" ^ name ^ "'" ;; let rec show_bicexpr = function | `Name name -> escname name | `StringConstant(string) -> "\"" ^ string ^ "\"" (* XXX "\"" *) | `Derivation(object_, self, methods) -> show_bicexpr object_ ^ show_bicexpr (`Literal(self, methods)) | `Literal(self, methods) -> "{" ^ escname self ^ ": " ^ show_methods methods ^ " }" | `Call(object_, method_name) -> show_bicexpr object_ ^ "." ^ escname method_name and show_methods = function | `NoDefs -> "" | `Definition(name, body, `NoDefs) -> show_method name body | `Definition(name, body, next) -> show_method name body ^ ", " ^ show_methods next and show_method name body = escname name ^ " = " ^ (show_bicexpr body) ;; (* unit tests *) assert (is_identifier "foo") ;; assert (is_identifier "x") ;; assert (is_identifier "x3") ;; assert (not (is_identifier "3")) ;; assert (is_identifier "x_y") ;; assert (is_identifier "_x") ;; assert (not (is_identifier "()")) ;; assert (not (is_identifier "(3")) ;; assert (not (is_identifier "")) ;; assert ((escname "hips") = "hips") ;; assert ((escname "()") = "'()'") ;; assert (get "foo" (`Add("foo", `BicStr "bar", `Phi)) = `BicStr "bar") ;; assert ((get "foo" `Phi) = `Error("key not found", "foo")) ;; assert ((get "foo" (`Add("bar", `BicStr "baz", `Phi))) = `Error("key not found", "foo")) ;; assert ((eval `Phi (`StringConstant "foo")) = `BicStr "foo") ;; assert ((eval `Phi (`Call(`Literal("self", `Definition("foo", `StringConstant("quux"), `NoDefs)), "foo"))) = `BicStr "quux") ;; assert ((eval `Phi (`Call(`Literal("self", `Definition("foo", `StringConstant("quux"), `NoDefs)), "baz"))) = `Error("method not found", "baz")) ;; let booleans = `Literal("booleans", `Definition("true", `Literal("boolean", `Definition("if_true", `Literal("self", `Definition("()", `Call(`Name "self", "then"), `Definition("then", `StringConstant("no consequent given"), `Definition("else", `StringConstant("no alternate given"), `NoDefs)))), `Definition("negated", `Call(`Name "booleans", "false"), `Definition("if_false", `Call(`Call(`Name "boolean", "negated"), "if_true"), `NoDefs)))), `Definition("false", `Derivation(`Call(`Name "booleans", "true"), "boolean", `Definition("if_true", `Derivation(`Call(`Call(`Name "booleans", "true"), "if_true"), "self", `Definition("()", `Call(`Name "self", "else"), `NoDefs)), `Definition("negated", `Call(`Name "booleans", "true"), `NoDefs))), `NoDefs))) ;; (* print_endline (show_bicexpr booleans) ;; *) assert ((eval `Phi (`Call(`Call(`Call(booleans, "true"), "if_true"), "()"))) = `BicStr "no consequent given") ;; assert ((eval `Phi (`Call(`Derivation(`Call(`Call(booleans, "true"), "if_true"), "", `Definition("then", `StringConstant("is true"), `Definition("else", `StringConstant("is false"), `NoDefs))), "()"))) = `BicStr "is true") ;; assert ((eval `Phi (`Call(`Derivation(`Call(`Call(booleans, "false"), "if_true"), "", `Definition("then", `StringConstant("is true"), `Definition("else", `StringConstant("is false"), `NoDefs))), "()"))) = `BicStr "is false") ;;