static COMMAND_FUNC( do_disp_obj )
{
Data_Obj *dp;
FILE *fp;
dp=PICK_OBJ("");
if( dp==NO_OBJ ) return;
// We used to insist that the object be in RAM,
// but we make life easier by automatically creating
// a temporary object...
dp = insure_ram_obj(QSP_ARG dp);
if( dp == NO_OBJ ) return;
fp = tell_msgfile(SINGLE_QSP_ARG);
if( fp == stdout ){
if( IS_IMAGE(dp) || IS_SEQUENCE(dp) )
if( !CONFIRM(
"are you sure you want to display an image/sequence in ascii") )
return;
list_dobj(QSP_ARG dp);
}
pntvec(QSP_ARG dp,fp);
fflush(fp);
DELETE_IF_COPY(dp)
}
static COMMAND_FUNC( do_wrt_obj )
{
Data_Obj *dp;
FILE *fp;
/* BUG what if pathname is longer than 256??? */
const char *filename;
dp=PICK_OBJ("");
filename = NAMEOF("output file");
if( dp==NO_OBJ ) return;
if( strcmp(filename,"-") && strcmp(filename,"stdout") ){
// BUG? we don't check append flag here,
// but there is a separate append command...
fp=TRYNICE( filename, "w" );
if( !fp ) return;
} else {
// If the invoking script has redirected stdout,
// then use that
if( QS_MSG_FILE(THIS_QSP)!=NULL )
fp = QS_MSG_FILE(THIS_QSP);
else
fp = stdout;
}
if( IS_IMAGE(dp) || IS_SEQUENCE(dp) )
if( !CONFIRM(
"are you sure you want to write an image/sequence in ascii") ){
fclose(fp);
return;
}
dp = insure_ram_obj(QSP_ARG dp);
if( dp == NO_OBJ ) return;
pntvec(QSP_ARG dp,fp);
if( fp != stdout && QS_MSG_FILE(THIS_QSP)!=NULL && fp != QS_MSG_FILE(THIS_QSP) ) {
if( verbose ){
sprintf(MSG_STR,"closing file %s",filename);
prt_msg(MSG_STR);
}
fclose(fp);
}
DELETE_IF_COPY(dp)
}
static COMMAND_FUNC( do_append )
{
Data_Obj *dp;
FILE *fp;
dp=PICK_OBJ("");
if( dp==NO_OBJ ) return;
if( IS_IMAGE(dp) || IS_SEQUENCE(dp) )
if( !CONFIRM(
"are you sure you want to write an image/sequence in ascii") )
return;
fp=TRYNICE( NAMEOF("output file"), "a" );
if( !fp ) return;
dp = insure_ram_obj(QSP_ARG dp);
if( dp == NO_OBJ ) return;
pntvec(QSP_ARG dp,fp);
fclose(fp);
DELETE_IF_COPY(dp)
}
object call_c(int func, object proc_ad, object arg_list)
/* Call a WIN32 or Linux C function in a DLL or shared library.
Alternatively, call a machine-code routine at a given address. */
{
volatile unsigned long arg; // !!!! magic var to push values on the stack
volatile int argsize; // !!!! number of bytes to pop
s1_ptr arg_list_ptr, arg_size_ptr;
object_ptr next_arg_ptr, next_size_ptr;
object next_arg, next_size;
int iresult, i;
double dbl_arg, dresult;
float flt_arg, fresult;
unsigned long size;
int proc_index;
int cdecl_call;
int (*int_proc_address)();
unsigned return_type;
char NameBuff[100];
// Setup and Check for Errors
proc_index = get_pos_int("c_proc/c_func", proc_ad);
if ((unsigned)proc_index >= c_routine_next) {
sprintf(TempBuff, "c_proc/c_func: bad routine number (%d)", proc_index);
RTFatal(TempBuff);
}
int_proc_address = c_routine[proc_index].address;
#if defined(EWINDOWS) && !defined(EWATCOM)
cdecl_call = c_routine[proc_index].convention;
#endif
if (IS_ATOM(arg_list)) {
RTFatal("c_proc/c_func: argument list must be a sequence");
}
arg_list_ptr = SEQ_PTR(arg_list);
next_arg_ptr = arg_list_ptr->base + arg_list_ptr->length;
// only look at length of arg size sequence for now
arg_size_ptr = c_routine[proc_index].arg_size;
next_size_ptr = arg_size_ptr->base + arg_size_ptr->length;
return_type = c_routine[proc_index].return_size; // will be INT
if (func && return_type == 0 || !func && return_type != 0) {
if (c_routine[proc_index].name->length < 100)
MakeCString(NameBuff, MAKE_SEQ(c_routine[proc_index].name));
else
NameBuff[0] = '\0';
sprintf(TempBuff, func ? "%s does not return a value" :
"%s returns a value",
NameBuff);
RTFatal(TempBuff);
}
if (arg_list_ptr->length != arg_size_ptr->length) {
if (c_routine[proc_index].name->length < 100)
MakeCString(NameBuff, MAKE_SEQ(c_routine[proc_index].name));
else
NameBuff[0] = '\0';
sprintf(TempBuff, "C routine %s() needs %d argument%s, not %d",
NameBuff,
arg_size_ptr->length,
(arg_size_ptr->length == 1) ? "" : "s",
arg_list_ptr->length);
RTFatal(TempBuff);
}
argsize = arg_list_ptr->length << 2;
// Push the Arguments
for (i = 1; i <= arg_list_ptr->length; i++) {
next_arg = *next_arg_ptr--;
next_size = *next_size_ptr--;
if (IS_ATOM_INT(next_size))
size = INT_VAL(next_size);
else if (IS_ATOM(next_size))
size = (unsigned long)DBL_PTR(next_size)->dbl;
else
RTFatal("This C routine was defined using an invalid argument type");
if (size == C_DOUBLE || size == C_FLOAT) {
/* push 8-byte double or 4-byte float */
if (IS_ATOM_INT(next_arg))
dbl_arg = (double)next_arg;
else if (IS_ATOM(next_arg))
dbl_arg = DBL_PTR(next_arg)->dbl;
else {
arg = arg+argsize+9999; // 9999 = 270f hex - just a marker for asm code
RTFatal("arguments to C routines must be atoms");
}
if (size == C_DOUBLE) {
arg = *(1+(unsigned long *)&dbl_arg);
push(); // push high-order half first
argsize += 4;
arg = *(unsigned long *)&dbl_arg;
push(); // don't combine this with the push() below - Lcc bug
}
else {
/* C_FLOAT */
flt_arg = (float)dbl_arg;
arg = *(unsigned long *)&flt_arg;
push();
}
}
else {
/* push 4-byte integer */
if (size >= E_INTEGER) {
if (IS_ATOM_INT(next_arg)) {
if (size == E_SEQUENCE)
RTFatal("passing an integer where a sequence is required");
}
else {
if (IS_SEQUENCE(next_arg)) {
if (size != E_SEQUENCE && size != E_OBJECT)
RTFatal("passing a sequence where an atom is required");
}
else {
if (size == E_SEQUENCE)
RTFatal("passing an atom where a sequence is required");
}
RefDS(next_arg);
}
arg = next_arg;
push();
}
else if (IS_ATOM_INT(next_arg)) {
arg = next_arg;
push();
}
else if (IS_ATOM(next_arg)) {
// atoms are rounded to integers
arg = (unsigned long)DBL_PTR(next_arg)->dbl; //correct
// if it's a -ve f.p. number, Watcom converts it to int and
// then to unsigned int. This is exactly what we want.
// Works with the others too.
push();
}
else {
arg = arg+argsize+9999; // just a marker for asm code
RTFatal("arguments to C routines must be atoms");
}
}
}
// Make the Call - The C compiler thinks it's a 0-argument call
// might be VOID C routine, but shouldn't crash
if (return_type == C_DOUBLE) {
// expect double to be returned from C routine
#if defined(EWINDOWS) && !defined(EWATCOM)
if (cdecl_call) {
dresult = (*((double ( __cdecl *)())int_proc_address))();
pop();
}
else
#endif
dresult = (*((double (__stdcall *)())int_proc_address))();
#ifdef ELINUX
pop();
#endif
return NewDouble(dresult);
}
else if (return_type == C_FLOAT) {
// expect float to be returned from C routine
#if defined(EWINDOWS) && !defined(EWATCOM)
if (cdecl_call) {
fresult = (*((float ( __cdecl *)())int_proc_address))();
pop();
}
else
#endif
fresult = (*((float (__stdcall *)())int_proc_address))();
#ifdef ELINUX
pop();
#endif
return NewDouble((double)fresult);
}
else {
// expect integer to be returned
#if defined(EWINDOWS) && !defined(EWATCOM)
if (cdecl_call) {
iresult = (*((int ( __cdecl *)())int_proc_address))();
pop();
}
else
#endif
iresult = (*((int (__stdcall *)())int_proc_address))();
#ifdef ELINUX
pop();
#endif
if ((return_type & 0x000000FF) == 04) {
/* 4-byte integer - usual case */
// check if unsigned result is required
if ((return_type & C_TYPE) == 0x02000000) {
// unsigned integer result
if ((unsigned)iresult <= (unsigned)MAXINT) {
return iresult;
}
else
return NewDouble((double)(unsigned)iresult);
}
else {
// signed integer result
if (return_type >= E_INTEGER ||
(iresult >= MININT && iresult <= MAXINT)) {
return iresult;
}
else
return NewDouble((double)iresult);
}
}
else if (return_type == 0) {
return 0; /* void - procedure */
}
/* less common cases */
else if (return_type == C_UCHAR) {
return (unsigned char)iresult;
}
else if (return_type == C_CHAR) {
return (signed char)iresult;
}
else if (return_type == C_USHORT) {
return (unsigned short)iresult;
}
else if (return_type == C_SHORT) {
return (short)iresult;
}
else
return 0; // unknown function return type
}
}
