ftp.nice.ch/pub/next/developer/languages/ada/Adaed.1.11.s.tar.gz#/Adaed-1.11.0a/lang.c

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.