mirror of
https://github.com/Interlisp/maiko.git
synced 2026-01-27 04:12:51 +00:00
Maiko sources matching state as of 020102 prior to initial patching for Mac OSX
This commit is contained in:
Nick Briggs
997
src/foreign.c
Executable file
997
src/foreign.c
Executable file
@@ -0,0 +1,997 @@
|
||||
/* $Id: foreign.c,v 1.3 1999/05/31 23:35:28 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */
|
||||
static char *id = "$Id: foreign.c,v 1.3 1999/05/31 23:35:28 sybalsky Exp $ Copyright (C) Venue";
|
||||
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
|
||||
/* Manufactured in the United States of America. */
|
||||
/* */
|
||||
/* The contents of this file are proprietary information */
|
||||
/* belonging to Venue, and are provided to you under license. */
|
||||
/* They may not be further distributed or disclosed to third */
|
||||
/* parties without the specific permission of Venue. */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
#include "version.h"
|
||||
|
||||
|
||||
#ifndef NOFORN
|
||||
#include <sys/param.h>
|
||||
#include "dld.h"
|
||||
#include "lispemul.h"
|
||||
#include "lspglob.h"
|
||||
#include "emlglob.h"
|
||||
#include "adr68k.h"
|
||||
#include "lispmap.h"
|
||||
#include "lsptypes.h"
|
||||
#include "locfile.h"
|
||||
#include "medleyfp.h"
|
||||
#include "arith.h"
|
||||
#include "stack.h"
|
||||
|
||||
|
||||
|
||||
/***********************************************************/
|
||||
/* L S t r i n g T o C S t r i n g */
|
||||
/* */
|
||||
/* Convert a lisp string to a C string up to MaxLen long. */
|
||||
/***********************************************************/
|
||||
|
||||
#define LStringToCString(Lisp, C, MaxLen ,Len) \
|
||||
{ \
|
||||
OneDArray *arrayp; \
|
||||
char *base; \
|
||||
short *sbase; \
|
||||
int i; \
|
||||
\
|
||||
arrayp = (OneDArray *)(Addr68k_from_LADDR((unsigned int)Lisp)); \
|
||||
Len = min(MaxLen, arrayp->fillpointer); \
|
||||
\
|
||||
switch(arrayp->typenumber) \
|
||||
{ \
|
||||
case THIN_CHAR_TYPENUMBER: \
|
||||
base = ((char *) \
|
||||
(Addr68k_from_LADDR((unsigned int)arrayp->base))) \
|
||||
+ ((int)(arrayp->offset)); \
|
||||
for(i=0;i<Len;i++) \
|
||||
C[i] = base[i]; \
|
||||
C[Len] = '\0'; \
|
||||
break; \
|
||||
\
|
||||
case FAT_CHAR_TYPENUMBER: \
|
||||
sbase = ((short *) \
|
||||
(Addr68k_from_LADDR((unsigned int)arrayp->base))) \
|
||||
+ ((int)(arrayp->offset)); \
|
||||
base = (char *)sbase; \
|
||||
for(i=0;i<Len*2;i++) \
|
||||
C[i] = base[i]; \
|
||||
C[Len*2] = '\0'; \
|
||||
break; \
|
||||
\
|
||||
default: \
|
||||
error("LStringToCString can not handle\n"); \
|
||||
} \
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* F O R E I G N - F U N C T I O N C A L L I N T E R F A C E */
|
||||
/* */
|
||||
/* */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
/* void ( *fn ) () = args[0];
|
||||
(*fn)();
|
||||
return(NIL);
|
||||
*/
|
||||
|
||||
#define VOIDTYPE 0
|
||||
|
||||
typedef void (*PFV)(); /* Pointer to Function returning Void */
|
||||
typedef int (*PFI)(); /* Pointer to Function returning Int */
|
||||
typedef char (*PFC)(); /* Pointer to Function returning Char */
|
||||
typedef float (*PFF)(); /* Pointer to Function returning Float */
|
||||
typedef int (*PFP)(); /* Pointer to Function returning a Pointer */
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* C A L L _ C _ F N */
|
||||
/* */
|
||||
/* args[0]: descriptor block for the function */
|
||||
/* 0 is the function address if the function is callable */
|
||||
/* or 0 if the function is undefined or unresolved */
|
||||
/* 1 is the result type */
|
||||
/* 2 is the error return flag: 0=no errors. 1 if there's */
|
||||
/* some problem */
|
||||
/* 3 is the lenght of the arglist passed */
|
||||
/* 4 is the pointer to the smasher place or 0 if return */
|
||||
/* 5-n the arglist types */
|
||||
/* args[1-<number-of-args+1>]: arguments */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
#define Max_Arg 32
|
||||
|
||||
LispPTR call_c_fn(LispPTR *args)
|
||||
{
|
||||
int intarg[Max_Arg], result, i, j;
|
||||
int fnaddr, resulttype, *errorflag, *smasher, arglistlength, *descriptorblock;
|
||||
PFI pickapart1, pickapart2, pickapart3, pickapart4;
|
||||
float fresult;
|
||||
|
||||
DLword *fword, *createcell68k(unsigned int type);
|
||||
|
||||
FX2 *caller;
|
||||
struct fnhead *fnhead;
|
||||
ByteCode *pc;
|
||||
|
||||
/* Initialize the variables from the descriptorblock */
|
||||
descriptorblock = (int *)Addr68k_from_LADDR(args[0]);
|
||||
fnaddr=*descriptorblock++;
|
||||
resulttype=*descriptorblock++;
|
||||
errorflag=descriptorblock++;
|
||||
arglistlength=*descriptorblock++;
|
||||
smasher=descriptorblock++;
|
||||
|
||||
/* initialize the errorflag */
|
||||
*errorflag=0;
|
||||
|
||||
/* Initialize the argvector */
|
||||
for(i=0; i<Max_Arg ; i++){ intarg[i]=0; };
|
||||
|
||||
/* Test the function addr. If it is 0 we can not execute. */
|
||||
if (fnaddr==0) {
|
||||
*errorflag= -1;
|
||||
return(NIL);
|
||||
}
|
||||
|
||||
#ifdef TRACE
|
||||
{ int *tracedesc;
|
||||
|
||||
printf("Start Foreign function call=====\n");
|
||||
tracedesc = (int *)Addr68k_from_LADDR(args[0]);
|
||||
printf("fnaddr: %d\n", *tracedesc++);
|
||||
printf("resulttype: %d\n", *tracedesc++);
|
||||
printf("errorflag: %d\n", *tracedesc++);
|
||||
printf("arglistlength: %d\n", *tracedesc++);
|
||||
printf("smasher: %d\n", *tracedesc++);
|
||||
for (i=0; i<arglistlength; i++){
|
||||
printf("arg[%d]= %d\n",i , *tracedesc++);
|
||||
}
|
||||
printf("End Foreign function call=====\n");
|
||||
}
|
||||
#endif /* TRACE */
|
||||
for(i=1, j=0; i<(arglistlength + 1) ; i++, j++){
|
||||
int expectedtype;
|
||||
expectedtype=*descriptorblock++;
|
||||
switch (GetTypeNumber( args[i] )){
|
||||
case TYPE_ARRAYBLOCK :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_SMALLP :
|
||||
if(expectedtype <= TYPE_FIXP) {
|
||||
intarg[j] = LispIntToCInt(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_FIXP :
|
||||
if(expectedtype <= TYPE_FIXP) {
|
||||
intarg[j] = LispIntToCInt(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_FLOATP :
|
||||
if(expectedtype == TYPE_FLOATP) {
|
||||
float temp;
|
||||
temp = FLOATP_VALUE(args[i]);
|
||||
intarg[j++] = pickapart1(temp);
|
||||
intarg[j++] = pickapart2(temp);
|
||||
intarg[j++] = pickapart3(temp);
|
||||
intarg[j++] = pickapart4(temp);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_LITATOM :
|
||||
case TYPE_NEWATOM:
|
||||
if(expectedtype == TYPE_LITATOM) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_LISTP :
|
||||
if(expectedtype == TYPE_LISTP) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_ARRAYP :
|
||||
if(expectedtype == TYPE_ARRAYP) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_STRINGP :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_STACKP :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_CHARACTERP :
|
||||
if(expectedtype == TYPE_CHARACTERP) {
|
||||
intarg[j] = (0xFFFF & args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_VMEMPAGEP :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_STREAM :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_BITMAP :
|
||||
if(expectedtype == TYPE_BITMAP) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_COMPILED_CLOSURE :
|
||||
break;
|
||||
case TYPE_ONED_ARRAY :
|
||||
if(expectedtype == TYPE_ONED_ARRAY) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_TWOD_ARRAY :
|
||||
if(expectedtype == TYPE_TWOD_ARRAY) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_GENERAL_ARRAY :
|
||||
if(expectedtype == TYPE_GENERAL_ARRAY) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_BIGNUM :
|
||||
if(expectedtype == TYPE_BIGNUM) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_RATIO :
|
||||
if(expectedtype == TYPE_RATIO) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_COMPLEX :
|
||||
if(expectedtype == TYPE_COMPLEX) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_PATHNAME :
|
||||
break;
|
||||
default:
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
switch (resulttype) {
|
||||
case VOIDTYPE:
|
||||
((PFV)fnaddr)(intarg[0], intarg[1], intarg[2], intarg[3],
|
||||
intarg[4], intarg[5], intarg[6], intarg[7],
|
||||
intarg[8], intarg[9], intarg[10], intarg[11],
|
||||
intarg[12], intarg[13], intarg[14], intarg[15],
|
||||
intarg[16], intarg[17], intarg[18], intarg[19],
|
||||
intarg[20], intarg[21], intarg[22], intarg[23],
|
||||
intarg[24], intarg[25], intarg[26], intarg[27],
|
||||
intarg[28], intarg[29], intarg[30], intarg[31]
|
||||
);
|
||||
caller = (FX2 *) CURRENTFX; /* Don't return values, just continue. */
|
||||
fnhead = (struct fnhead *)
|
||||
Addr68k_from_LADDR(POINTERMASK & swapx((int)caller->fnheader));
|
||||
pc = (ByteCode *)fnhead+(caller->pc);
|
||||
break;
|
||||
case TYPE_SMALLP:
|
||||
case TYPE_FIXP:
|
||||
{ int tmp;
|
||||
tmp = ((PFI)fnaddr)
|
||||
(intarg[0], intarg[1], intarg[2], intarg[3],
|
||||
intarg[4], intarg[5], intarg[6], intarg[7],
|
||||
intarg[8], intarg[9], intarg[10], intarg[11],
|
||||
intarg[12], intarg[13], intarg[14], intarg[15],
|
||||
intarg[16], intarg[17], intarg[18], intarg[19],
|
||||
intarg[20], intarg[21], intarg[22], intarg[23],
|
||||
intarg[24], intarg[25], intarg[26], intarg[27],
|
||||
intarg[28], intarg[29], intarg[30], intarg[31]
|
||||
);
|
||||
return(CIntToLispInt(tmp));
|
||||
};
|
||||
break;
|
||||
case TYPE_CHARACTERP:
|
||||
{ int tmp;
|
||||
tmp = ((PFC)fnaddr)
|
||||
(intarg[0], intarg[1], intarg[2], intarg[3],
|
||||
intarg[4], intarg[5], intarg[6], intarg[7],
|
||||
intarg[8], intarg[9], intarg[10], intarg[11],
|
||||
intarg[12], intarg[13], intarg[14], intarg[15],
|
||||
intarg[16], intarg[17], intarg[18], intarg[19],
|
||||
intarg[20], intarg[21], intarg[22], intarg[23],
|
||||
intarg[24], intarg[25], intarg[26], intarg[27],
|
||||
intarg[28], intarg[29], intarg[30], intarg[31]
|
||||
);
|
||||
return(S_CHAR | tmp);
|
||||
};
|
||||
break;
|
||||
case TYPE_FLOATP:
|
||||
fresult = ((PFF)fnaddr)
|
||||
(intarg[0], intarg[1], intarg[2], intarg[3],
|
||||
intarg[4], intarg[5], intarg[6], intarg[7],
|
||||
intarg[8], intarg[9], intarg[10], intarg[11],
|
||||
intarg[12], intarg[13], intarg[14], intarg[15],
|
||||
intarg[16], intarg[17], intarg[18], intarg[19],
|
||||
intarg[20], intarg[21], intarg[22], intarg[23],
|
||||
intarg[24], intarg[25], intarg[26], intarg[27],
|
||||
intarg[28], intarg[29], intarg[30], intarg[31]
|
||||
);
|
||||
fword = createcell68k(TYPE_FLOATP);
|
||||
*((float *)fword) = fresult;
|
||||
return(LADDR_from_68k(fword));
|
||||
break;
|
||||
default:
|
||||
*errorflag=-2;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* S M A S H I N G _ C _ F N */
|
||||
/* */
|
||||
/* args[0]: descriptor block for the function */
|
||||
/* 0 is the function address if the function is callable */
|
||||
/* or 0 if the function is undefined or unresolved */
|
||||
/* 1 is the result type */
|
||||
/* 2 is the error return flag: 0=no errors. 1 if there's */
|
||||
/* some problem */
|
||||
/* 3 is the lenght of the arglist passed */
|
||||
/* 4-n the arglist types */
|
||||
/* args[1]: Smashing place */
|
||||
/* args[2 - <number-of-args+1>]: arguments */
|
||||
/* */
|
||||
/* This is an aboration. It is only implemented on the speciffic */
|
||||
/* request of an influential customer. The things we do for money! */
|
||||
/* */
|
||||
/* The result of this functioncall will be smashed into what */
|
||||
/* arg[0] points to. If it is a cell of the right type we are ok. */
|
||||
/* If it is not we are on the road to hell. /jarl nilsson */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
LispPTR smashing_c_fn(LispPTR *args)
|
||||
{
|
||||
int intarg[Max_Arg], result, i, j;
|
||||
int fnaddr, resulttype, *errorflag, arglistlength, *descriptorblock;
|
||||
PFI pickapart1, pickapart2, pickapart3, pickapart4;
|
||||
float fresult;
|
||||
|
||||
int *valueplace;
|
||||
DLword *fword, *createcell68k(unsigned int type);
|
||||
|
||||
FX2 *caller;
|
||||
struct fnhead *fnhead;
|
||||
ByteCode *pc;
|
||||
|
||||
/* Initialize the variables from the descriptorblock */
|
||||
descriptorblock = (int *)Addr68k_from_LADDR(args[0]);
|
||||
fnaddr=*descriptorblock++;
|
||||
resulttype=*descriptorblock++;
|
||||
errorflag=descriptorblock++;
|
||||
arglistlength=*descriptorblock++;
|
||||
|
||||
/* initialize the errorflag */
|
||||
*errorflag=0;
|
||||
|
||||
/* Initialize the valueplace */
|
||||
valueplace = (int *)Addr68k_from_LADDR(args[1]);
|
||||
|
||||
/* Initialize the argvector */
|
||||
for(i=0; i<Max_Arg ; i++){ intarg[i]=0; };
|
||||
|
||||
/* Test the function addr. If it is 0 we can not execute. */
|
||||
if (fnaddr==0) {
|
||||
*errorflag=-1;
|
||||
return(NIL);
|
||||
}
|
||||
|
||||
for(i=2, j=0; i<(arglistlength + 2) ; i++, j++){
|
||||
int expectedtype;
|
||||
expectedtype=*descriptorblock++;
|
||||
switch (GetTypeNumber( args[i] )){
|
||||
case TYPE_ARRAYBLOCK :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_SMALLP :
|
||||
if(expectedtype <= TYPE_FIXP) {
|
||||
intarg[j] = LispIntToCInt(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_FIXP :
|
||||
if(expectedtype <= TYPE_FIXP) {
|
||||
intarg[j] = LispIntToCInt(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_FLOATP :
|
||||
if(expectedtype == TYPE_FLOATP) {
|
||||
float temp;
|
||||
temp = FLOATP_VALUE(args[i]);
|
||||
intarg[j++] = pickapart1(temp);
|
||||
intarg[j++] = pickapart2(temp);
|
||||
intarg[j++] = pickapart3(temp);
|
||||
intarg[j++] = pickapart4(temp);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_LITATOM :
|
||||
case TYPE_NEWATOM:
|
||||
if(expectedtype == TYPE_LITATOM) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_LISTP :
|
||||
if(expectedtype == TYPE_LISTP) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_ARRAYP :
|
||||
if(expectedtype == TYPE_ARRAYP) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_STRINGP :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_STACKP :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_CHARACTERP :
|
||||
if(expectedtype == TYPE_CHARACTERP) {
|
||||
intarg[j] = (char)(0xFF && args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_VMEMPAGEP :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_STREAM :
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
case TYPE_BITMAP :
|
||||
if(expectedtype == TYPE_BITMAP) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_COMPILED_CLOSURE :
|
||||
break;
|
||||
case TYPE_ONED_ARRAY :
|
||||
if(expectedtype == TYPE_ONED_ARRAY) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_TWOD_ARRAY :
|
||||
if(expectedtype == TYPE_TWOD_ARRAY) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_GENERAL_ARRAY :
|
||||
if(expectedtype == TYPE_GENERAL_ARRAY) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_BIGNUM :
|
||||
if(expectedtype == TYPE_BIGNUM) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_RATIO :
|
||||
if(expectedtype == TYPE_RATIO) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_COMPLEX :
|
||||
if(expectedtype == TYPE_COMPLEX) {
|
||||
intarg[j] = *(int *)Addr68k_from_LADDR(args[i]);
|
||||
} else {
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
}
|
||||
break;
|
||||
case TYPE_PATHNAME :
|
||||
break;
|
||||
default:
|
||||
*errorflag=i;
|
||||
return(NIL);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
switch (resulttype) {
|
||||
case VOIDTYPE:
|
||||
((PFV)fnaddr)(intarg[0], intarg[1], intarg[2], intarg[3],
|
||||
intarg[4], intarg[5], intarg[6], intarg[7],
|
||||
intarg[8], intarg[9], intarg[10], intarg[11],
|
||||
intarg[12], intarg[13], intarg[14], intarg[15],
|
||||
intarg[16], intarg[17], intarg[18], intarg[19],
|
||||
intarg[20], intarg[21], intarg[22], intarg[23],
|
||||
intarg[24], intarg[25], intarg[26], intarg[27],
|
||||
intarg[28], intarg[29], intarg[30], intarg[31]
|
||||
);
|
||||
caller = (FX2 *) CURRENTFX; /* Don't return values, just continue. */
|
||||
fnhead = (struct fnhead *)
|
||||
Addr68k_from_LADDR(POINTERMASK & swapx((int)caller->fnheader));
|
||||
pc = (ByteCode *)fnhead+(caller->pc);
|
||||
break;
|
||||
case TYPE_SMALLP:
|
||||
case TYPE_FIXP:
|
||||
{ int tmp;
|
||||
tmp = ((PFI)fnaddr)
|
||||
(intarg[0], intarg[1], intarg[2], intarg[3],
|
||||
intarg[4], intarg[5], intarg[6], intarg[7],
|
||||
intarg[8], intarg[9], intarg[10], intarg[11],
|
||||
intarg[12], intarg[13], intarg[14], intarg[15],
|
||||
intarg[16], intarg[17], intarg[18], intarg[19],
|
||||
intarg[20], intarg[21], intarg[22], intarg[23],
|
||||
intarg[24], intarg[25], intarg[26], intarg[27],
|
||||
intarg[28], intarg[29], intarg[30], intarg[31]
|
||||
);
|
||||
*valueplace=tmp;
|
||||
return(NIL);
|
||||
};
|
||||
break;
|
||||
case TYPE_CHARACTERP:
|
||||
return(S_CHAR | (((PFC)fnaddr)
|
||||
(intarg[0], intarg[1], intarg[2], intarg[3],
|
||||
intarg[4], intarg[5], intarg[6], intarg[7],
|
||||
intarg[8], intarg[9], intarg[10], intarg[11],
|
||||
intarg[12], intarg[13], intarg[14], intarg[15],
|
||||
intarg[16], intarg[17], intarg[18], intarg[19],
|
||||
intarg[20], intarg[21], intarg[22], intarg[23],
|
||||
intarg[24], intarg[25], intarg[26], intarg[27],
|
||||
intarg[28], intarg[29], intarg[30], intarg[31]
|
||||
)));
|
||||
break;
|
||||
case TYPE_FLOATP:
|
||||
fresult = ((PFF)fnaddr)
|
||||
(intarg[0], intarg[1], intarg[2], intarg[3],
|
||||
intarg[4], intarg[5], intarg[6], intarg[7],
|
||||
intarg[8], intarg[9], intarg[10], intarg[11],
|
||||
intarg[12], intarg[13], intarg[14], intarg[15],
|
||||
intarg[16], intarg[17], intarg[18], intarg[19],
|
||||
intarg[20], intarg[21], intarg[22], intarg[23],
|
||||
intarg[24], intarg[25], intarg[26], intarg[27],
|
||||
intarg[28], intarg[29], intarg[30], intarg[31]
|
||||
);
|
||||
*valueplace=fresult;
|
||||
return(NIL);
|
||||
break;
|
||||
default:
|
||||
*errorflag=-2;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* M d l d _ l i n k */
|
||||
/* */
|
||||
/* args[0] - The lisp string name of the path to the filename */
|
||||
/* Return value: 0 -> ok. */
|
||||
/* 1 - 16 -> errorcode */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
int Mdld_link(LispPTR *args)
|
||||
{
|
||||
char filename[MAXPATHLEN];
|
||||
int result, leng;
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "TRACE: dld_link(" );
|
||||
#endif
|
||||
|
||||
LStringToCString( args[0], filename, MAXPATHLEN, leng);
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "%s)\n", filename );
|
||||
#endif
|
||||
|
||||
result = dld_link( filename );
|
||||
N_ARITH_SWITCH ( result );
|
||||
};
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* M d l d _ u n l i n k _ b y _ f i l e */
|
||||
/* */
|
||||
/* args[0] - The lisp string name of the path to the filename */
|
||||
/* args[1] - Force flag. If NonZero, force the unlinking, even */
|
||||
/* if there are references to this module. */
|
||||
/* Return value: 0 -> ok. */
|
||||
/* 1 - 16 -> errorcode */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
int Mdld_unlink_by_file(LispPTR *args)
|
||||
{
|
||||
char filename[MAXPATHLEN];
|
||||
int hard, result, leng;
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "TRACE: dld_unlink_by_file(" );
|
||||
#endif
|
||||
|
||||
LStringToCString( args[0], filename, MAXPATHLEN, leng );
|
||||
hard = GetSmalldata( args[1] );
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "%s, %d)\n", filename, hard );
|
||||
#endif
|
||||
|
||||
result = dld_unlink_by_file( filename, hard );
|
||||
N_ARITH_SWITCH ( result );
|
||||
};
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* M d l d _ u n l i n k _ b y _ s y m b o l */
|
||||
/* */
|
||||
/* args[0] - The lisp string name of the symbol in some module. */
|
||||
/* args[1] - Force flag. If NonZero, force the unlinking, even */
|
||||
/* if there are references to this module. */
|
||||
/* Return value: 0 -> ok. */
|
||||
/* 1 - 16 -> errorcode */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
int Mdld_unlink_by_symbol(LispPTR *args)
|
||||
{
|
||||
char symbolname[MAXPATHLEN];
|
||||
int hard, result, leng;
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "TRACE: dld_unlink_by_symbol(" );
|
||||
#endif
|
||||
|
||||
LStringToCString( args[0], symbolname, MAXPATHLEN, leng );
|
||||
hard = GetSmalldata( args[1] );
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "%s, %d)\n", symbolname, hard );
|
||||
#endif
|
||||
|
||||
result = dld_unlink_by_symbol( symbolname, hard );
|
||||
N_ARITH_SWITCH ( result );
|
||||
};
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* M d l d _ g e t _ s y m b o l */
|
||||
/* */
|
||||
/* args[0] - The lisp string name of the symbol. */
|
||||
/* Return value - a pointer to the symbol or 0 */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
|
||||
unsigned long Mdld_get_symbol(LispPTR *args)
|
||||
{
|
||||
char symbolname[MAXPATHLEN];
|
||||
int result, leng;
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "TRACE: dld_get_symbol(" );
|
||||
#endif
|
||||
|
||||
LStringToCString( args[0], symbolname, MAXPATHLEN, leng );
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "%s, %d)\n", symbolname );
|
||||
#endif
|
||||
|
||||
result = dld_get_symbol( symbolname );
|
||||
N_ARITH_SWITCH ( result );
|
||||
};
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* M d l d _ g e t _ f u n c */
|
||||
/* */
|
||||
/* args[0] - The lisp string name of the function. */
|
||||
/* Return value - a pointer to the function or 0. */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
unsigned long Mdld_get_func(LispPTR *args)
|
||||
{
|
||||
char funcname[MAXPATHLEN];
|
||||
int result, leng;
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "TRACE: dld_get_func(" );
|
||||
#endif
|
||||
|
||||
LStringToCString( args[0], funcname, MAXPATHLEN, leng );
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "%s )\n", funcname );
|
||||
#endif
|
||||
|
||||
result = dld_get_func( funcname );
|
||||
N_ARITH_SWITCH ( result );
|
||||
};
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* M d l d _ f u n c t i o n _ e x e c u t a b l e _ p */
|
||||
/* */
|
||||
/* args[0] - The lisp string name of the function. */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
int Mdld_function_executable_p(LispPTR *args)
|
||||
{
|
||||
char funcname[MAXPATHLEN];
|
||||
int result, leng;
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "TRACE: dld_function_executable_p(" );
|
||||
#endif
|
||||
|
||||
LStringToCString( args[0], funcname, MAXPATHLEN, leng );
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "%s, %d)\n", funcname );
|
||||
#endif
|
||||
|
||||
result = dld_function_executable_p( funcname );
|
||||
N_ARITH_SWITCH ( result );
|
||||
};
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* M d l d _ l i s t _ u n d e f i n e d _ s y m */
|
||||
/* */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
int Mdld_list_undefined_sym(void)
|
||||
{
|
||||
char **dld_list_undefined_sym();
|
||||
int temp;
|
||||
extern int dld_undefined_sym_count;
|
||||
|
||||
#ifdef TRACE
|
||||
printf( "TRACE: dld_list_undefined_sym()\n" );
|
||||
#endif
|
||||
|
||||
if (dld_undefined_sym_count == 0) {
|
||||
return (NIL);
|
||||
}
|
||||
|
||||
temp = (int)dld_list_undefined_sym( );
|
||||
N_ARITH_SWITCH ( temp );
|
||||
};
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* m a l l o c */
|
||||
/* */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
int c_malloc (LispPTR *args)
|
||||
{
|
||||
printf ("malloc!\n");
|
||||
return(NIL);
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* f r e e */
|
||||
/* */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
int c_free (LispPTR *args)
|
||||
{
|
||||
printf ("free!\n");
|
||||
return(NIL);
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* P U T B A S E B Y T E */
|
||||
/* */
|
||||
/* arg[0] = the base address. */
|
||||
/* arg[1] = the offset as calculated by the type */
|
||||
/* arg[2] = type of access. */
|
||||
/* 0 = set the bit pointed out by address + offset */
|
||||
/* 1 = set the byte pointed out by address + offset */
|
||||
/* 2 = set the word (16bit) pointed to by address + offset */
|
||||
/* 3 = set the integer pointed out by address + offset */
|
||||
/* 4 = set the float pointed out by address + offset */
|
||||
/* arg[3] = the new value. */
|
||||
/* The offset changes depending on the type argument. If type is */
|
||||
/* 0 the changed value will be the bit at ADDRESS + OFFSET bits. */
|
||||
/* If type is 1 the changedvalue will be the byte at ADDRESS + */
|
||||
/* OFFSET bytes. If type is 2 the changed value will be the int */
|
||||
/* at ADDRESS + OFFSET. */
|
||||
/* */
|
||||
/* This makes it easy to set values in arrays. */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
int put_c_basebyte (LispPTR *args)
|
||||
{
|
||||
int addr, offset, newval;
|
||||
|
||||
addr = LispIntToCInt(args[0]);
|
||||
offset = LispIntToCInt(args[1]);
|
||||
newval= LispIntToCInt(args[3]);
|
||||
|
||||
switch (LispIntToCInt(args[2])) {
|
||||
case 0: /* bit */
|
||||
if (newval == 0) {
|
||||
GETBYTE((char *)(addr + (offset >> 3))) &= (~(1 << (0x7 & offset)));
|
||||
} else {
|
||||
GETBYTE((char *)(addr + (offset >> 3))) |= (1 << (0x7 & offset));
|
||||
};
|
||||
break;
|
||||
case 1: /* byte */
|
||||
GETBYTE((char*)(addr + offset)) = 0xFF & newval;
|
||||
break;
|
||||
case 2: /* word */
|
||||
newval &= 0xFFFF;
|
||||
(*((short *) ((addr & 0xFFFFFFFE) + (offset << 1)))) = newval;
|
||||
break;
|
||||
case 3: /* int */
|
||||
(*((int *) ((addr & 0xFFFFFFFE) + (offset << 2)))) = newval;
|
||||
break;
|
||||
case 4: /* float */
|
||||
(*((float *) ((addr & 0xFFFFFFFE) + (offset << 2)))) = FLOATP_VALUE(args[3]);
|
||||
break;
|
||||
}
|
||||
return(NIL);
|
||||
}
|
||||
|
||||
/************************************************************************/
|
||||
/* */
|
||||
/* G E T _ C _ B A S E B Y T E */
|
||||
/* */
|
||||
/* arg[0] = the base address. */
|
||||
/* arg[1] = the offset as calculated by the type */
|
||||
/* arg[2] = type of access. */
|
||||
/* 0 = get the bit pointed out by address + offset */
|
||||
/* 1 = get the byte pointed out by address + offset */
|
||||
/* 2 = get the word (16bit) pointed to by address + offset */
|
||||
/* 3 = get the integer pointed out by address + offset */
|
||||
/* 4 = get the float pointed out by address + offset */
|
||||
/* The offset changes depending on the type argument. If type */
|
||||
/* is 0 the return value will be the bit at ADDRESS + OFFSET bits. */
|
||||
/* If type is 1 the return value will be the byte at ADDRESS + */
|
||||
/* OFFSET bytes. If type is 2 the return value will be the integer */
|
||||
/* at ADDRESS + OFFSET. */
|
||||
/* */
|
||||
/* This makes it easy to access arrays. */
|
||||
/* */
|
||||
/************************************************************************/
|
||||
int get_c_basebyte(LispPTR *args)
|
||||
{
|
||||
int addr, offset, type;
|
||||
DLword *fword, *createcell68k(unsigned int type);
|
||||
|
||||
addr = LispIntToCInt(args[0]);
|
||||
offset = LispIntToCInt(args[1]);
|
||||
|
||||
switch (LispIntToCInt(args[2])) {
|
||||
case 0: /* bit */
|
||||
if ((GETBYTE((char *)(addr + (offset >> 3)))) & (1 << (0x7 & offset))) {
|
||||
/* ^get bitmask from offset ^get the byte at the byteaddress */
|
||||
return(ATOM_T);
|
||||
} else {
|
||||
return(NIL);
|
||||
};
|
||||
break;
|
||||
case 1: /* byte */
|
||||
return((0xFF & (GETBYTE((char *)(addr + offset)))) | S_POSITIVE);
|
||||
break;
|
||||
case 2: /* word */
|
||||
return( CIntToLispInt (0xFFFF & (*((short *) ((addr & 0xFFFFFFFE) + (offset << 1))))));
|
||||
break;
|
||||
case 3: /* int */
|
||||
return( CIntToLispInt (*((int *) ((addr & 0xFFFFFFFE) + (offset << 2)))));
|
||||
break;
|
||||
case 4: /* float */
|
||||
fword = createcell68k(TYPE_FLOATP);
|
||||
*((float *)fword) = *(float *)((addr & 0xFFFFFFFE) + (offset << 2));
|
||||
return(LADDR_from_68k(fword));
|
||||
break;
|
||||
}
|
||||
}
|
||||
#endif /* NOFORN */
|
||||
Reference in New Issue
Block a user