#lang shplait // Make all "class.rhm" definitions available here, where // the "class.rhm" file must be in the same directory // as this one: import: open: "class_abs.rhm" type ExpI | numI(n :: Int) | plusI(lhs :: ExpI, rhs :: ExpI) | multI(lhs :: ExpI, rhs :: ExpI) | argI() | thisI() | newI(class_name :: Symbol, args :: Listof(ExpI)) | getI(obj_exp :: ExpI, field_name :: Symbol) | sendI(obj_exp :: ExpI, method_name :: Symbol, arg_exp :: ExpI) | superI(super_name :: Symbol, method_name :: Symbol, arg_exp :: ExpI) | absI(arg :: ExpI) type ClassI | classI(super_names :: Listof(Symbol), field_names :: Listof(Symbol), methods :: Listof(Symbol * ExpI)) // ---------------------------------------- fun exp_i_to_c(a :: ExpI) :: Exp: block: fun recur(exp): exp_i_to_c(exp) match a | numI(n): intE(n) | plusI(l, r): plusE(recur(l), recur(r)) | multI(l, r): multE(recur(l), recur(r)) | argI(): argE() | thisI(): thisE() | newI(class_name, field_exps): newE(class_name, map(recur, field_exps)) | getI(exp, field_name): getE(recur(exp), field_name) | sendI(exp, method_name, arg_exp): sendE(recur(exp), method_name, recur(arg_exp)) | superI(super_name, method_name, arg_exp): ssendE(thisE(), super_name, method_name, recur(arg_exp)) | absI(arg): absE(recur(arg)) module test: check: exp_i_to_c(absI(numI(-1))) ~is absE(intE(-1)) check: exp_i_to_c(numI(10)) ~is intE(10) check: exp_i_to_c(plusI(numI(10), numI(2))) ~is plusE(intE(10), intE(2)) check: exp_i_to_c(multI(numI(10), numI(2))) ~is multE(intE(10), intE(2)) check: exp_i_to_c(argI()) ~is argE() check: exp_i_to_c(thisI()) ~is thisE() check: exp_i_to_c (newI(#'Object, [numI(1)])) ~is newE(#'Object, [intE(1)]) check: exp_i_to_c(getI(numI(1), #'x)) ~is getE(intE(1), #'x) check: exp_i_to_c(sendI(numI(1), #'mdist, numI(2))) ~is sendE(intE(1), #'mdist, intE(2)) check: exp_i_to_c(superI(#'Posn, #'mdist, numI(2))) ~is ssendE(thisE(), #'Posn, #'mdist, intE(2)) // ---------------------------------------- fun class_i_to_c_not_flat(c :: ClassI) :: Class: match c | classI(super_names, field_names, methods): classC(field_names, map(fun (m): values(fst(m), exp_i_to_c(snd(m))), methods)) module test: def posn3d_mdist_i_method: values(#'mdist, plusI(getI(thisI(), #'z), superI(#'Posn, #'mdist, argI()))) def posn3d_mdist_c_method: values(#'mdist, plusE(getE(thisE(), #'z), ssendE(thisE(), #'Posn, #'mdist, argE()))) def posn3d_i_class: values(#'Posn3D, classI([#'Posn], [#'z], [posn3d_mdist_i_method])) def posn3d_c_class_not_flat: values(#'Posn3D, classC([#'z], [posn3d_mdist_c_method])) check: class_i_to_c_not_flat(snd(posn3d_i_class)) ~is snd(posn3d_c_class_not_flat) // ---------------------------------------- fun merge_classes(class1 :: Class, class2 :: Class) :: Class: match class1 | classC(field_names, methods): match class2 | classC(super_field_names, super_methods): classC(add_fields(super_field_names, field_names), add_or_replace_methods(super_methods, methods)) fun flatten_class(name :: Symbol, classes_not_flat :: Listof(Symbol * Class), i_classes :: Listof(Symbol * ClassI)) :: Class: merge_classes(find(classes_not_flat, name), flatten_supers(name, classes_not_flat, i_classes)) fun flatten_supers(name :: Symbol, classes_not_flat :: Listof(Symbol * Class), i_classes :: Listof(Symbol * ClassI)) :: Class: match find(i_classes, name) | classI(super_names, field_names, i_methods): merge_named_classes(super_names, classes_not_flat, i_classes) fun merge_named_classes(super_names :: Listof(Symbol), classes_not_flat :: Listof(Symbol * Class), i_classes :: Listof(Symbol * ClassI)) :: Class: match super_names | []: classC([], []) | cons(super_name, rst_supers): // The order of the arguments matters, and we had // them in the wrong order in class. // Tests would have exposed the mistake! merge_classes(merge_named_classes(rst_supers, classes_not_flat, i_classes), flatten_class(super_name, classes_not_flat, i_classes)) module test: def posn_i_class: values(#'Posn, classI([], [#'x, #'y], [values(#'mdist, plusI(getI(thisI(), #'x), getI(thisI(), #'y))), values(#'addDist, plusI(sendI(thisI(), #'mdist, numI(0)), sendI(argI(), #'mdist, numI(0))))])) def addDist_c_method: values(#'addDist, plusE(sendE(thisE(), #'mdist, intE(0)), sendE(argE(), #'mdist, intE(0)))) def posn_c_class_not_flat: values(#'Posn, classC([#'x, #'y], [values(#'mdist, plusE(getE(thisE(), #'x), getE(thisE(), #'y))), addDist_c_method])) def posn3d_c_class: values(#'Posn3D, classC([#'x, #'y, #'z], [posn3d_mdist_c_method, addDist_c_method])) check: flatten_class(#'Posn3D, [posn_c_class_not_flat, posn3d_c_class_not_flat], [posn_i_class, posn3d_i_class]) ~is snd(posn3d_c_class) // ---------------------------------------- def add_fields = append fun add_or_replace_methods(methods :: Listof(Symbol * Exp), new_methods :: Listof(Symbol * Exp)) :: (Listof (Symbol * Exp)): match new_methods | []: methods | cons(fst_method, rst_new_methods): add_or_replace_methods(add_or_replace_method(methods, fst_method), rst_new_methods) fun add_or_replace_method(methods :: Listof(Symbol * Exp), new_method :: Symbol * Exp) :: (Listof (Symbol * Exp)): match methods | []: [new_method] | cons(fst_method, rst_methods): if fst(fst_method) == fst(new_method) | cons(new_method, rst_methods) | cons(fst_method, add_or_replace_method(rst_methods, new_method)) module test: check: add_fields([#'x, #'y], [#'z]) ~is [#'x, #'y, #'z] check: add_or_replace_methods([], []) ~is [] check: add_or_replace_methods([], [values(#'m, intE(0))]) ~is [values(#'m, intE(0))] check: add_or_replace_methods([values(#'m, intE(0))], []) ~is [values(#'m, intE(0))] check: add_or_replace_methods([values(#'m, intE(0))], [values(#'m, intE(1))]) ~is [values(#'m, intE(1))] check: add_or_replace_methods([values(#'m, intE(0)), values(#'n, intE(2))], [values(#'m, intE(1))]) ~is [values(#'m, intE(1)), values(#'n, intE(2))] check: add_or_replace_methods([values(#'m, intE(0))], [values(#'m, intE(1)), values(#'n, intE(2))]) ~is [values(#'m, intE(1)), values(#'n, intE(2))] check: add_or_replace_method([values(#'m, intE(0))], values(#'m, intE(1))) ~is [values(#'m, intE(1))] check: add_or_replace_method([values(#'m, intE(0))], values(#'n, intE(2))) ~is [values(#'m, intE(0)), values(#'n, intE(2))] // ---------------------------------------- fun interp_i(i_a :: ExpI, i_classes :: Listof(Symbol * ClassI)) :: Value: block: def a = exp_i_to_c(i_a) def classes_not_flat: map(fun (i): values(fst(i), class_i_to_c_not_flat(snd(i))), i_classes) def classes: map(fun (c): let name = fst(c): values(name, flatten_class(name, classes_not_flat, i_classes)), classes_not_flat) interp(a, classes, objV(#'Object, []), intV(0)) module test: check: interp_i(numI(0), []) ~is intV(0) check: interp_i( sendI(newI(#'Posn3D, [numI(5), numI(3), numI(1)]), #'addDist, newI(#'Posn, [numI(2), numI(7)])), [posn_i_class, posn3d_i_class] ) ~is intV(18)