/* * PCN System Compiler: VT transformations * Author: Robert Olson * Argonne National Laboratory * * Please see the DISCLAIMER file in the top level directory of the * distribution regarding the provisions under which this software * is distributed. * * vtco_func.ptn - Transform function definitions * * */ /* * Transform function definitions. * * A procedure is a function if it either is listed in a -functions() * directive or a -_program_annotations() directive for the procedure * has the function attribute set. * */ -proc_metacalls(go, tests:is_program, tests:named, vtco_func:go1) go() {|| get_functions(funcs), transform(and(tests:is_program(),tests:named(funcs)), vtco_func:go1()) } -proc_metacalls(get_functions, tests:is_directive, coll:d_value) get_functions(funcs) {|| coll:collect(tests:is_directive(), coll:d_value("functions"), funcs0), massage_funcnames(funcs0, funcs1), get_pgm_annos(annos), funcs_from_annos(annos, funcs, funcs1) } massage_funcnames(funcs, new_funcs) {? funcs ?= [func | funcs_1] -> {? func ?= {":", _, _} -> {|| massage_funcnames(funcs_1, new_funcs_1), new_funcs = [func | new_funcs_1] }, char(func) -> {|| massage_funcnames(funcs_1, new_funcs_1), new_funcs = [func | new_funcs_1] }, func ?= {v, name, _}, v == "_var", char(name) -> {|| massage_funcnames(funcs_1, new_funcs_1), new_funcs = [name | new_funcs_1] }, default -> {; co_msg:error("Invalid function directive value %lt", {func}), massage_funcnames(funcs_1, new_funcs) } }, funcs ?= [] -> {|| new_funcs = [] } } funcs_from_annos(annos, funcs_b, funcs_e) {? annos ?= [] -> {|| funcs_b = funcs_e }, annos ?= [[name | his_annos] | annos_1] -> {; sys:list_member("function", his_annos, is_func), {? is_func == 0 -> {; tail = funcs_e }, default -> {; tail = [name | funcs_e] } }, funcs_from_annos(annos_1, funcs_b, tail) } } -proc_metacalls(get_pgm_annos, tests:is_directive, coll:d_value, co_meta_dir:merge_proc_metacalls) get_pgm_annos(annos) {|| combine(tests:is_directive(),coll:d_value("_program_annotations"), co_meta_dir:merge_proc_metacalls(),d), {? d ?= r(l, 0) -> {|| annos_0 = l }, d == [] -> {|| annos_0 = [] }, default -> {|| annos_0 = [d] } }, co_meta_dir:concat_directives(annos_0, [], annos) } /* * * Transform a program by * * creating a new variable retval for the return value * transforming its body as a block, passing retval into the transformation * appending retval tot he argument list. * */ go1(id, defn, newdefn) {? defn ?= program(args, decls, block) -> {; /* stdio:printf("Transforming function %t\n", {id}, _),*/ unique_variable("retval",retval), xform_block(retval, id, block, newblock), append_to_end(args, retval, newargs), newdefn = program(newargs, decls, newblock) } } /* * Transform a block by transforming all calls in the block. * */ xform_block(retval, id, defn, newdefn) {? defn ?= block(op, blocks) -> {|| xform_blocks(retval, id, blocks, newblocks), newdefn = block(op, newblocks) }, defn ?= {"->", guard, block} -> {|| xform_block(retval, id, block, newblock), newdefn = {"->", guard, newblock} }, defn ?= call(call_id, args, anno) -> {|| xform_call(retval, id, call_id, args, anno, newdefn) }, default -> {|| newdefn = defn } } xform_blocks(retval, id, blocks, newblocks) {? blocks ?= [] -> {|| newblocks = [] }, blocks ?= [block | blocks1] -> {; xform_block(retval, id, block, newblock), xform_blocks(retval, id, blocks1, newblocks1), newblocks = [newblock |newblocks1] } } /* * Transform any calls to return(x) by replacing them with the assignment * * retval = x * */ xform_call(retval, id, call_id, args, anno, newdefn) {? id ?= {":", mod, proc}, call_id ?= {":", call_mod, call_proc}, mod == call_mod, call_proc == "return" -> {? anno != [] -> {; co_msg:error("%s:%s: Return cannot be annotated", {mod, proc}), newdefn = prim("skip",{}) }, anno == [], args ?= [arg] -> {; newdefn = prim("=", [retval, arg]) }, default -> {; co_msg:error("%s:%s: Invalid return", {mod, proc}), newdefn = prim("skip",{}) } }, default -> {|| newdefn = call(call_id, args, anno) } } append_to_end(list, val, newlist) {? list ?= [] -> {|| newlist = [val] }, list ?= [h|t] -> {|| append_to_end(t, val, t1), newlist = [h | t1] } }