This is lang.c in view mode; [Download] [Up]
/* * Copyright (C) 1985-1992 New York University * * This file is part of the Ada/Ed-C system. See the Ada/Ed README file for * warranty (none) and distribution info and also the GNU General Public * License for more details. */ #define GEN #include "hdr.h" #include "libhdr.h" #include "vars.h" #include "gvars.h" #include "attr.h" #include "setprots.h" #include "gutilprots.h" #include "miscprots.h" #include "gmiscprots.h" #include "gmainprots.h" #include "langprots.h" char *c_interface(Symbol sym, int func_code) /*;c_interface*/ { /* generation of a branch of a switch in C containing a call to a * subprogram interfaced to C */ char dummy_array[80]; char *decl_code = ""; char *call_code; char *code; char *proc_name; Symbol formal, formal_type, return_type; Tuple formals; Fortup ft1; int indx; int position = 0; sprintf(dummy_array, "\tcase(%d):{\n", func_code); code = strjoin(dummy_array, ""); proc_name = strjoin(ORIG_NAME(sym), ""); fold_lower(proc_name); if (NATURE(sym) == na_function) { return_type = TYPE_OF(sym); if (is_integer_type(return_type)) sprintf(dummy_array, "\t\textern int %s();\n", proc_name); else if (is_float_type(return_type)) sprintf(dummy_array, "\t\textern float %s();\n", proc_name); else compiler_error("Interface: TBSL return_type"); decl_code = strjoin("", dummy_array); } if (NATURE(sym) == na_function) sprintf(dummy_array, "%s(", proc_name); else sprintf(dummy_array, "\t\t%s(", proc_name); call_code = strjoin(dummy_array, ""); formals = tup_copy(SIGNATURE(sym)); FORTUPI(formal = (Symbol), formals, indx, ft1); formal_type = TYPE_OF(formal); if (is_integer_type(formal_type) || is_enumeration_type(formal_type)) sprintf(dummy_array, "\n\t\t\t\t\tget_argument_value(%d)",position); else if (is_float_type(formal_type)) sprintf(dummy_array, "\n\t\t\t\t\tget_float_argument_value(%d)", position); else if (is_access_type(formal_type)) sprintf(dummy_array, "\n\t\t\t\t\tget_long_argument_value(%d)", position); else if (is_array_type(formal_type) || is_record_type(formal_type)) { position+=2; sprintf(dummy_array, "\n\t\t\t\t\tget_argument_ptr(%d)", position); } else compiler_error("Interface: TBSL non scalar types"); call_code = strjoin(call_code, dummy_array); if (indx != tup_size(formals)) call_code = strjoin(call_code, ","); position += 2; ENDFORTUP(ft1); if (NATURE(sym) == na_function) { if (is_integer_type(return_type)) { sprintf(dummy_array, "\t\tcur_stack[cur_stackptr - %d] = ", position); } else { sprintf(dummy_array, "\t\t((float *)cur_stack)[cur_stackptr - %d] = ", position); } call_code = strjoin(dummy_array, call_code); } call_code = strjoin(call_code, ");\n\t\tbreak;\n\t}\n"); code = strjoin(code, decl_code); code = strjoin(code, call_code); tup_free(formals); return code; } char *fortran_interface(Symbol sym, int func_code) /*;fortran_interface*/ { /* generation of a branch of a switch in C containing a call to a * subprogram interfaced to FORTRAN */ char dummy_array[80]; char *decl_code = ""; char *call_code; char *code; char *proc_name; Symbol formal, formal_type, return_type; Tuple formals; Fortup ft1; int indx; int position = 0; sprintf(dummy_array, "\tcase(%d):{\n", func_code); code = strjoin(dummy_array, ""); proc_name = strjoin(ORIG_NAME(sym), ""); fold_lower(proc_name); if (NATURE(sym) == na_function) { return_type = TYPE_OF(sym); if (is_integer_type(return_type)||is_float_type(return_type)) { sprintf(dummy_array, "\t\textern int %s();\n", proc_name); } else { compiler_error("Interface: TBSL return_type"); } decl_code = strjoin("", dummy_array); } if (NATURE(sym) == na_function) { sprintf(dummy_array, "%s_(", proc_name); } else { sprintf(dummy_array, "\t\t%s_(", proc_name); } call_code = strjoin(dummy_array, ""); formals = tup_copy(SIGNATURE(sym)); FORTUPI(formal = (Symbol), formals, indx, ft1); formal_type = TYPE_OF(formal); if (is_integer_type(formal_type) || is_float_type(formal_type) || is_array_type(formal_type) || is_record_type(formal_type)) { if (is_array_type(formal_type) || is_record_type(formal_type)) { position+=2; } if (indx == tup_size(formals)) { sprintf(dummy_array, "\n\t\t\t\t\tget_argument_ptr(%d)", position); } else { sprintf(dummy_array, "\n\t\t\t\t\tget_argument_ptr(%d),", position); } } else { compiler_error("Interface: unimplemented type for FORTRAN"); } call_code = strjoin(call_code, dummy_array); position += 2; ENDFORTUP(ft1); if (NATURE(sym) == na_function) { sprintf(dummy_array, "\t\tcur_stack[cur_stackptr - %d] = ", position); call_code = strjoin(dummy_array, call_code); } call_code = strjoin(call_code, ");\n\t\tbreak;\n\t}\n"); code = strjoin(code, decl_code); code = strjoin(code, call_code); tup_free(formals); return code; }
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.