mirror of
https://github.com/Interlisp/maiko.git
synced 2026-01-15 15:57:13 +00:00
0ad69fc6fe
This also involves removing unnecessary forward declarations, inserting
includes for all cross-file function references, making some definitions
static if they are not otherwise used, correcting errors that were exposed
by having correct prototypes.
new file: inc/allocmdsdefs.h
new file: inc/arith2defs.h
new file: inc/arith3defs.h
new file: inc/arith4defs.h
new file: inc/array2defs.h
new file: inc/array3defs.h
new file: inc/array4defs.h
new file: inc/array5defs.h
new file: inc/array6defs.h
new file: inc/arraydefs.h
new file: inc/bbtsubdefs.h
new file: inc/bindefs.h
new file: inc/bindsdefs.h
new file: inc/bitbltdefs.h
new file: inc/bltdefs.h
new file: inc/byteswapdefs.h
new file: inc/car-cdrdefs.h
new file: inc/chardevdefs.h
new file: inc/commondefs.h
new file: inc/conspagedefs.h
new file: inc/dbgtooldefs.h
new file: inc/dirdefs.h
new file: inc/drawdefs.h
new file: inc/dskdefs.h
new file: inc/dspifdefs.h
new file: inc/dspsubrsdefs.h
new file: inc/eqfdefs.h
new file: inc/etherdefs.h
new file: inc/findkeydefs.h
new file: inc/fpdefs.h
new file: inc/fvardefs.h
new file: inc/gc2defs.h
new file: inc/gcarraydefs.h
new file: inc/gccodedefs.h
new file: inc/gcdefs.h
new file: inc/gcfinaldefs.h
new file: inc/gchtfinddefs.h
new file: inc/gcmain3defs.h
new file: inc/gcoflowdefs.h
new file: inc/gcrcelldefs.h
new file: inc/gcrdefs.h
new file: inc/gcscandefs.h
new file: inc/gvar2defs.h
new file: inc/hacksdefs.h
new file: inc/hardrtndefs.h
new file: inc/inetdefs.h
new file: inc/initdspdefs.h
new file: inc/initkbddefs.h
new file: inc/initsoutdefs.h
modified: inc/inlineC.h
new file: inc/intcalldefs.h
new file: inc/kbdsubrsdefs.h
new file: inc/keyeventdefs.h
new file: inc/keylibdefs.h
new file: inc/kprintdefs.h
new file: inc/ldsoutdefs.h
new file: inc/lineblt8defs.h
new file: inc/lisp2cdefs.h
modified: inc/lispemul.h
new file: inc/llcolordefs.h
new file: inc/llstkdefs.h
modified: inc/lnk-inlineC.h
new file: inc/loopsopsdefs.h
new file: inc/lowlev1defs.h
new file: inc/lowlev2defs.h
new file: inc/lsthandldefs.h
new file: inc/maindefs.h
new file: inc/misc7defs.h
new file: inc/miscndefs.h
new file: inc/mkatomdefs.h
new file: inc/mkcelldefs.h
new file: inc/mvsdefs.h
new file: inc/osmsgdefs.h
new file: inc/perrnodefs.h
new file: inc/returndefs.h
new file: inc/rpcdefs.h
new file: inc/rplconsdefs.h
new file: inc/shiftdefs.h
new file: inc/storagedefs.h
new file: inc/subr0374defs.h
new file: inc/subrdefs.h
new file: inc/sxhashdefs.h
new file: inc/testtooldefs.h
new file: inc/timerdefs.h
new file: inc/typeofdefs.h
new file: inc/ubf1defs.h
new file: inc/ubf2defs.h
new file: inc/ubf3defs.h
new file: inc/ufsdefs.h
new file: inc/unixcommdefs.h
new file: inc/unwinddefs.h
new file: inc/uraiddefs.h
new file: inc/usrsubrdefs.h
new file: inc/uutilsdefs.h
new file: inc/vars3defs.h
new file: inc/vmemsavedefs.h
new file: inc/xbbtdefs.h
new file: inc/xcdefs.h
new file: inc/xcursordefs.h
new file: inc/xinitdefs.h
new file: inc/xlspwindefs.h
new file: inc/xmkicondefs.h
new file: inc/xrdoptdefs.h
new file: inc/xscrolldefs.h
new file: inc/xwinmandefs.h
new file: inc/z2defs.h
modified: src/allocmds.c
modified: src/arith2.c
modified: src/arith3.c
modified: src/arith4.c
modified: src/array.c
modified: src/array2.c
modified: src/array3.c
modified: src/array4.c
modified: src/array5.c
modified: src/array6.c
modified: src/bbtsub.c
modified: src/bin.c
modified: src/binds.c
modified: src/bitblt.c
modified: src/blt.c
modified: src/byteswap.c
modified: src/car-cdr.c
modified: src/chardev.c
modified: src/common.c
modified: src/conspage.c
modified: src/dbgtool.c
modified: src/dir.c
modified: src/draw.c
modified: src/dsk.c
modified: src/dspif.c
modified: src/dspsubrs.c
modified: src/eqf.c
modified: src/ether.c
modified: src/findkey.c
modified: src/foreign.c
modified: src/fp.c
modified: src/fvar.c
modified: src/gc.c
modified: src/gc2.c
modified: src/gcarray.c
modified: src/gccode.c
modified: src/gcfinal.c
modified: src/gchtfind.c
modified: src/gcmain3.c
modified: src/gcoflow.c
modified: src/gcr.c
modified: src/gcrcell.c
modified: src/gcscan.c
modified: src/gvar2.c
modified: src/hacks.c
modified: src/hardrtn.c
modified: src/inet.c
modified: src/initdsp.c
modified: src/initkbd.c
modified: src/initsout.c
modified: src/intcall.c
modified: src/kbdsubrs.c
modified: src/keyevent.c
modified: src/keylib.c
modified: src/kprint.c
modified: src/ldsout.c
modified: src/lineblt8.c
modified: src/lisp2c.c
modified: src/llcolor.c
modified: src/llstk.c
modified: src/loopsops.c
modified: src/lowlev1.c
modified: src/lowlev2.c
modified: src/lsthandl.c
modified: src/main.c
modified: src/misc7.c
modified: src/miscn.c
modified: src/mkatom.c
modified: src/mkcell.c
modified: src/mvs.c
modified: src/osmsg.c
modified: src/perrno.c
modified: src/return.c
modified: src/rpc.c
modified: src/rplcons.c
modified: src/setsout.c
modified: src/shift.c
modified: src/storage.c
modified: src/subr.c
modified: src/subr0374.c
modified: src/sxhash.c
modified: src/testtool.c
modified: src/timer.c
modified: src/truecolor.c
modified: src/tstsout.c
modified: src/typeof.c
modified: src/ubf1.c
modified: src/ubf2.c
modified: src/ubf3.c
modified: src/ufn.c
modified: src/ufs.c
modified: src/unixcomm.c
modified: src/unwind.c
modified: src/uraid.c
modified: src/usrsubr.c
modified: src/uutils.c
modified: src/vars3.c
modified: src/vmemsave.c
modified: src/xbbt.c
modified: src/xc.c
modified: src/xcursor.c
modified: src/xinit.c
modified: src/xlspwin.c
modified: src/xmkicon.c
modified: src/xrdopt.c
modified: src/xscroll.c
modified: src/xwinman.c
modified: src/z2.c
917 lines
31 KiB
C
917 lines
31 KiB
C
/* $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. */
|
|
/* */
|
|
/************************************************************************/
|
|
|
|
#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"
|
|
|
|
#include "foreigndefs.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 */
|