github.com/Interlisp.maiko
1
0
Fork 0
mirror of https://github.com/Interlisp/maiko.git synced 2026-01-15 15:57:13 +00:00
Code Issues Projects Releases Wiki Activity
Interlisp.maiko/src/fvar.c
Bruce Mitchener 16c6b8f7c3
Fix typos. (#196)
2021-01-08 21:42:11 -08:00

588 lines
18 KiB
C
Raw Blame History

/* $Id: fvar.c,v 1.3 1999/05/31 23:35:29 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */
/************************************************************************/
/* */
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
/* Manufactured in the United States of America. */
/* */
/************************************************************************/
#include "version.h"
#include <stdio.h>
#include "lispemul.h"
#include "lspglob.h"
#include "adr68k.h"
#include "stack.h"
#include "emlglob.h"
#include "lispmap.h"
#include "lsptypes.h"
#include "gcdata.h"
#include "fvardefs.h"
#include "byteswapdefs.h"
#include "commondefs.h"
#include "gchtfinddefs.h"
#ifdef GCC386
#include "inlnPS2.h"
#endif
#define MaskShift(x) (((x) << 16) & SEGMASK)
#ifdef BIGATOMS
#define NT_OFFSET_MASK 0xFFFFFFF
#define NT_TYPE_MASK 0xFF000000
#define GetNTEntry(X) GetLongWord(X)
#define NAMETABLE LispPTR
#else
#define NT_OFFSET_MASK 0xFF
#define NT_TYPE_MASK 0xFF00
#define GetNTEntry(X) GETWORD(X)
#define NAMETABLE DLword
#endif
#define FVSTACK 2
#define FVGLOBAL 6
#ifdef BIGATOMS
#define FVIVARHI 0x0
#define FVPVARHI (0x80000000)
#define FVFVARHI (0xC0000000)
#else
#define FVIVARHI 0x0
#define FVPVARHI 0x8000
#define FVFVARHI 0xC000
#endif
#define ENDSTACKMARK 0xb
/******************************************************************************
nnewframe
This routine is used by fvlookup and OP_stkscan.
1. scan Name table in new function header.
2. if found, set address of searching variable to chain address.
3. return the type of var, on stack, or global. (fs: unused, removed)
******************************************************************************/
void nnewframe(register struct frameex1 *newpfra2, register DLword *achain, register int name)
/* pointer to new frame extension */
/* pointer to 1st word of the searching
FVAR slot in CurrentFrameExtension */
/* Atom index num. of target FVAR slot. */
{
register NAMETABLE *pindex; /* '90/06/06 osamu changed from DLword *
* index to indexs of new name table */
register UNSIGNED i; /* temp for control */
register int nametablesize; /* NameTable size of current function header. */
register int ph; /* alink temp, also phase */
struct frameex1 *onewpfra2, *oonewpfra2, *ooonewpfra2;
newframe:
#ifdef SUN3_OS3_OR_OS4_IL
newframe_setup_label();
#endif
/* assume that apframe1 points to the next frame to be scanned */
ph = newpfra2->alink;
if (ph == 0) error("alink = 0 in nnewframe");
if (ph == ENDSTACKMARK) {
/* endStack */
#ifdef BIGATOMS
if ((name & SEGMASK) != 0) /* New symbol */
{
register int result = name + NEWATOM_VALUE_OFFSET;
/* printf("NEW-SYMBOL in nnewframe, 0x%x, result = 0x%x\n", name, result); */
GETBASEWORD(achain, 1) = result >> 16;
GETBASEWORD(achain, 0) = result & 0xFFFF;
} else
#endif /* BIGATOMS */
#ifdef BIGVM
if (name & SEGMASK) { /* It's a big-atom, so just offset from the base to get value */
register int result = name + NEWATOM_VALUE_OFFSET;
GETBASEWORD(achain, 1) = result >> 16;
GETBASEWORD(achain, 0) = result & 0xFFFF;
} else { /* It's an "old" atom, so offset into the table of atoms */
register int result = (ATOMS_HI << 16) + (10 * name) + NEWATOM_VALUE_OFFSET;
GETBASEWORD(achain, 1) = result >> 16;
GETBASEWORD(achain, 0) = result & 0xFFFF;
}
#else
if (name >= 0x8000) {
GETBASEWORD(achain, 1) = VALS_HI + 1;
GETBASEWORD(achain, 0) = name * 2;
} else {
GETBASEWORD(achain, 1) = VALS_HI;
GETBASEWORD(achain, 0) = name * 2;
}
#endif /* BIGVM */
return;
}
ph &= 0xFFFE; /* to mask off SLOW bit */
ooonewpfra2 = oonewpfra2;
oonewpfra2 = onewpfra2;
onewpfra2 = newpfra2;
newpfra2 = (struct frameex1 *)(-FRAMESIZE + Stackspace + ph);
{ /* open new block to try and conserve address register */
register struct fnhead *newpfn2; /* ptr to new fn header */
if (newpfra2->validnametable) /* check VALIDNAMETABLE */
#ifdef BIGVM
newpfn2 = (struct fnhead *)(Addr68k_from_LADDR(newpfra2->nametable));
else
newpfn2 = (struct fnhead *)(Addr68k_from_LADDR(newpfra2->fnheader));
#else
newpfn2 = (struct fnhead *)(Addr68k_from_LADDR(
((newpfra2->hi2nametable) << 16 | newpfra2->lonametable)));
else
newpfn2 = (struct fnhead *)(Addr68k_from_LADDR(
((newpfra2->hi2fnheader) << 16 | newpfra2->lofnheader)));
#endif /* BIGVM */
pindex = (NAMETABLE *)((DLword *)newpfn2 + FNHEADSIZE);
/* now pindex points 1st word of Nametable. */
#ifdef BIGATOMS
nametablesize = (newpfn2->ntsize >> 1); /* ntsize is # of words in NT
not # of element */
#else
nametablesize = newpfn2->ntsize;
#endif
}
#ifdef SUN3_OS3_OR_OS4_IL
newframe_loop_label();
#endif
i = (UNSIGNED)(pindex + nametablesize);
for (; (UNSIGNED)i > (UNSIGNED)pindex;) { /* searching in NewFuncHeader */
#ifdef BIGATOMS
/* These used to be GETWORDs, but NAMETABLE is a CELL in 3-byte */
#if 1
if ((int)*((NAMETABLE *)pindex++) == (int)name) {
ph = 1;
goto foundit;
}
cont2:
if ((int)*((NAMETABLE *)pindex++) == (int)name) {
ph = 0;
goto foundit;
}
#else
if ((int)*((NAMETABLE *)pindex++) == (int)name) {
ph = 1;
goto foundit;
}
cont2:
if ((int)*((NAMETABLE *)pindex++) == (int)name) {
ph = 2;
goto foundit;
}
cont3:
if ((int)*((NAMETABLE *)pindex++) == (int)name) {
ph = 3;
goto foundit;
}
cont4:
if ((int)*((NAMETABLE *)pindex++) == (int)name) {
ph = 0;
goto foundit;
}
#endif
#else
if (GETWORD((NAMETABLE *)pindex++) == (DLword)name) {
ph = 1;
goto foundit;
}
cont2:
if (GETWORD((NAMETABLE *)pindex++) == (DLword)name) {
ph = 2;
goto foundit;
}
cont3:
if (GETWORD((NAMETABLE *)pindex++) == (DLword)name) {
ph = 3;
goto foundit;
}
cont4:
if (GETWORD((NAMETABLE *)pindex++) == (DLword)name) {
ph = 0;
goto foundit;
}
#endif
continue;
foundit : {
register int fvartype; /* probing fvar vartype */
register int fvaroffset; /* probing fvar varoffset */
register DLword *ppvar; /* ptr to probing var candidate */
#ifdef BIGATOMS
fvartype = (int)*(pindex + nametablesize - 1);
#else
fvartype = GETWORD(pindex + nametablesize - 1);
#endif /* BIGATOMS */
fvaroffset = NT_OFFSET_MASK & fvartype;
fvaroffset <<= 1;
fvartype &= NT_TYPE_MASK;
switch (fvartype) {
case FVPVARHI: /* 0x8000 or 0x80000000(BIGATOMS) */
ppvar = FRAMESIZE + (DLword *)newpfra2 + fvaroffset;
/* ppvar points to argued Pvar */
if (WBITSPTR(ppvar)->xMSB) /* check UNBOUND (if *ppvar is negative , unbound) */
switch (ph) {
case 0: continue;
case 1:
goto cont2;
/* case 2 : goto cont3;
case 3 : goto cont4; */
}
GETBASEWORD(achain, 1) = STK_HI;
GETBASEWORD(achain, 0) = 0xFFFF & LADDR_from_68k(ppvar);
/* save High word of PVAR slot address to FVAR slot */
/* achain points to target FVAR slot */
return;
case FVFVARHI: /* 0xC000 or 0xC0000000(BIGATOMS) */
ppvar = FRAMESIZE + (DLword *)newpfra2 + fvaroffset;
if (WBITSPTR(ppvar)->LSB) goto endlookfor;
/* Not Found in new FnHeader, scan next one. */
*((int *)achain) = *((int *)ppvar);
/* save address of FX to FVAR slot */
/* achain points to target FVAR slot */
return;
case FVIVARHI: /* 0x000: */
ppvar = -1 + (DLword *)newpfra2;
/* ppvar points to IVAR field in Basic frame */
GETBASEWORD(achain, 1) = STK_HI;
GETBASEWORD(achain, 0) = GETWORD(ppvar) + fvaroffset;
return;
default: error("Stack corrupted: bad value in name table");
} /* end switch */
} /* end if */
} /* end for */
endlookfor:
goto newframe; /* scan the next one */
}
/**************************************************************************
nfvlookup:
This routine is used by only OP_fvarn.
( in addition to N_OP_fvar_() )
1. get Atom index number of target fvar slot.
2. call fvlookfor.
****************************************************************************/
void nfvlookup(struct frameex1 *apframe1, register DLword *achain,
register struct fnhead *apfnhead1)
/* pointer to current frame extension */
/* pointer to 1st word of the searching
FVAR slot in CurrentFrameExtension */
/* pointer to current function heaer */
{
register DLword *pfh; /* pointer to current function header */
register int paoffset; /* 2word offset in PVAR AREA */
pfh = (DLword *)apfnhead1;
paoffset = ((UNSIGNED)achain - (UNSIGNED)PVar) >> 2;
/* slot to looked for, 2word offset from PVar */
#ifdef BIGATOMS
nnewframe(apframe1, achain, (*((LispPTR *)((DLword *)pfh + apfnhead1->fvaroffset) + paoffset -
apfnhead1->nlocals)));
#else
nnewframe(apframe1, achain,
(GETWORD(pfh + (apfnhead1->fvaroffset + paoffset - apfnhead1->nlocals))));
#endif
}
/*************************************************************************
N_OP_fvarn
entry of OPCODE[120b-127b]: FVAR, FVARX
1. save TopOfStack to evaluation stack.
2. set address of searching FVAR slot to chain.
3. call lookfor. (It sets some content to FVAR slot)
4. get some address by calculation of content of FVAR slot.
5. set the address to TopOfStack.
**************************************************************************/
LispPTR N_OP_fvarn(register int n)
/* n is word offset */
{
register DLword *chain; /* keep FVAR slot2 in CurrentFrameExtension */
chain = PVar + n;
if (WBITSPTR(chain)->LSB) {
/* check 15bit of FVAR slot1 in CurrentFrameExtension.
0: bound
1: unbound */
nfvlookup(CURRENTFX, chain, FuncObj);
}
return (GetLongWord(
Addr68k_from_LADDR(POINTERMASK & (((GETBASEWORD(chain, 1)) << 16) | GETBASEWORD(chain, 0)))));
}
/******************************************************************************
N_OP_stkscan
entry STKSCAN OPCODE[057]
<<Enter>>
TopOfStack: Low word - Atom index number of variable to be scanned.
<<Exit>>
TopOfStack: Address of found value.
1. call fvlookup.
2. Set *chain to TopOfStack.
3. Increment Pc by 1.
******************************************************************************/
LispPTR N_OP_stkscan(LispPTR tos) {
#ifdef I386
int scratchx[3];
int *scratch = (int *)(0xFFFFFFFC & (3 + (UNSIGNED)scratchx));
*scratch = tos;
nnewframe(CURRENTFX, (DLword *)scratch, POINTERMASK & *scratch);
return (swapx(*scratch));
#else
int scratch;
scratch = tos;
nnewframe(CURRENTFX, (DLword *)&scratch, POINTERMASK & scratch);
return (swapx(scratch));
#endif /* I386 */
}
/**************************************************
N_OP_fvar_
Entry: FVAR_ opcode[0143]
***************************************************/
LispPTR N_OP_fvar_(register LispPTR tos, register int n) {
register DLword *ppvar; /* pointer to argued Fvar slot in pvar area */
register DLword *pfreeval; /* pointer to argued free value */
ppvar = PVar + n;
if (WBITSPTR(ppvar)->LSB) /* check unbound ? */
{ /* unbound */
nfvlookup(CURRENTFX, ppvar, FuncObj);
}
pfreeval = Addr68k_from_LADDR(MaskShift((GETWORD(ppvar + 1))) | GETWORD(ppvar));
if (((0xFF & GETWORD(ppvar + 1)) != STK_HI)) {
GCLOOKUP(*((LispPTR *)pfreeval), DELREF);
GCLOOKUP(tos, ADDREF);
}
*((LispPTR *)pfreeval) = tos;
return (tos);
}
#ifndef BIGATOMS
#ifdef SUN3_OS3_OR_OS4_IL
#define VALS_HI_RET(x) newframe_vals_hi_ret(x)
#define STK_HI_RET(x) newframe_stk_hi_ret(x)
#else
#define VALS_HI_RET(x) ((int)(x) << 17) + VALS_HI + ((unsigned short)(x) >> 15)
#define STK_HI_RET(x) ((int)(x) << 16) | 1 | ((unsigned int)(x) >> 16)
#endif /* SUN3_IL */
#else
#ifdef BIGVM
#define VALS_HI_RET(x) \
((((int)(x)&SEGMASK) == 0) ? (swapx((ATOMS_HI << 16) + (10 * (int)(x)) + NEWATOM_VALUE_OFFSET)) \
: (swapx((int)(x) + NEWATOM_VALUE_OFFSET)))
#else
#define VALS_HI_RET(x) \
((((int)(x)&SEGMASK) == 0) ? (((int)(x) << 17) + VALS_HI + ((unsigned short)(x) >> 15)) \
: (swapx((int)(x) + NEWATOM_VALUE_OFFSET)))
#endif /* BIGVM */
#define STK_HI_RET(x) ((unsigned int)(x) << 16) | 1 | ((unsigned int)(x) >> 16)
#endif /* BIGATOMS */
/******************************************************************************
native_newframe
1. scan Name table in new function header.
2. if found, set address of searching variable to chain address.
3. return the pointer
******************************************************************************/
LispPTR native_newframe(int slot)
/* index of FVAR slot. */
{
register struct frameex2 *newpfra2; /* pointer to new frame extension */
register DLword *achain; /* pointer to 1st word of the searching
FVAR slot in CurrentFrameExtension */
register int name; /* Atom# of target FVAR slot. */
struct frameex2 *onewpfra2, *oonewpfra2, *ooonewpfra2;
{ /* LOCAL temp regs */
register int rslot = slot;
register struct fnhead *fnobj = FuncObj;
register LispPTR *pvar = (LispPTR *)PVar;
#ifdef BIGATOMS
name = (int)*((LispPTR *)((DLword *)fnobj + fnobj->fvaroffset) + rslot - fnobj->nlocals);
#else
name = GETWORD((DLword *)fnobj + (fnobj->fvaroffset + rslot - fnobj->nlocals));
#endif
newpfra2 = (struct frameex2 *)((DLword *)pvar - FRAMESIZE);
achain = (DLword *)(pvar + rslot);
}
{
register NAMETABLE *pindex; /* index to indexs of new name table */
register int i; /* temp for control */
register int nametablesize; /* NameTable size of current fnhdr */
register int alink;
natnewframe:
#ifdef SUN3_OS3_OR_OS4_IL
natnewframe_label();
#endif
/* assume that apframe1 points to the next frame to be scanned */
alink = newpfra2->alink;
if (alink == 0) error("alink is 0 in native_newframe");
if (alink == ENDSTACKMARK) { /* End of stack, so return top-level-value */
/* if (name & SEGMASK) printf("native_newframe returning name 0x%x, result
0x%x.\n",
name, VALS_HI_RET(name)); */
return (*((LispPTR *)achain) = VALS_HI_RET(name));
}
ooonewpfra2 = oonewpfra2;
oonewpfra2 = onewpfra2;
onewpfra2 = newpfra2;
newpfra2 = (struct frameex2 *)(-FRAMESIZE + Stackspace + (alink & 0xFFFE));
{ /* open new block to try and conserve address register */
register struct fnhead *newpfn2; /* ptr to new fn header */
newpfn2 = GETNAMETABLE(newpfra2);
pindex = (NAMETABLE *)(((DLword *)newpfn2) + FNHEADSIZE);
/* now pindex points 1st word of Nametable. */
#ifdef BIGATOMS
nametablesize = (newpfn2->ntsize >> 1); /* ntsize is # of words in NT
nametablesize is # of items in NT */
#else
nametablesize = newpfn2->ntsize;
#endif /* */
}
#ifdef SUN4_OS4_IL
i = (UNSIGNED)(pindex + nametablesize);
lookup:
#ifdef BIGATOMS
pindex = (LispPTR *)name_scan2((UNSIGNED)pindex, i, name);
#else
pindex = (DLword *)name_scan((UNSIGNED)pindex, i, name | (name << 16));
#endif
if (!pindex) goto natnewframe;
{
{
#else
#ifdef SUN3_OS3_OR_OS4_IL
i = nametablesize;
if (--i < 0) goto natnewframe;
/* **** assumes:
d7 = name
d6 = i
a3 = pindex
*** */
#ifdef BIGATOMS
lookup:
fvar_lookup_loop2();
#else
lookup:
fvar_lookup_loop();
#endif
{
{
#else
for (i = nametablesize; --i >= 0;) {
/* searching in NewFuncHeader */
#ifdef BIGATOMS
if ((LispPTR) * ((NAMETABLE *)pindex++) == (LispPTR)name) {
#else
if (GETWORD((NAMETABLE *)pindex++) == (DLword)name) {
#endif /* BIGATOMS */
#endif
#endif
register int fvartype; /* probing fvar vartype */
register int fvaroffset; /* probing fvar varoffset */
register DLword *ppvar; /* ptr to probing var candidate */
#ifdef BIGATOMS
fvartype = (int)*(pindex + nametablesize - 1);
#else
fvartype = GETWORD(pindex + nametablesize - 1);
#endif /* BIGATOMS */
fvaroffset = (NT_OFFSET_MASK & fvartype) << 1;
fvartype &= NT_TYPE_MASK;
switch (fvartype) {
case FVPVARHI: /* 0x8000 or 0x80000000(NEWATOM): */
ppvar = FRAMESIZE + (DLword *)newpfra2 + fvaroffset;
/* ppvar points to argued Pvar */
if (WBITSPTR(ppvar)->xMSB) /* check UNBOUND (if *ppvar is negative , unbound) */
#ifdef SUN4_OS4_IL
goto lookup;
#else
#ifdef SUN3_OS3_OR_OS4_IL
goto lookup;
#else
{
continue;
}
#endif
#endif
/* save High word of PVAR slot address to FVAR slot */
/* achain points to target FVAR slot */
return (*((LispPTR *)achain) = STK_HI_RET(LADDR_from_68k(ppvar)));
case FVFVARHI: /* 0xC000 or 0xC0000000(NEWATOM S) */
ppvar = FRAMESIZE + (DLword *)newpfra2 + fvaroffset;
if (WBITSPTR(ppvar)->LSB) { goto endlookfor; }
/* Not Found in new FuncHeader, scan next one. */
/* save address of frame extension to FVAR slot */
/* achain points to target FVAR slot */
return (*((int *)achain) = *((int *)ppvar));
case FVIVARHI: /* 0x0000000: */
ppvar = (DLword *)newpfra2 - 1;
/* ppvar points to IVAR field in Basic frame */
return (*((LispPTR *)achain) = STK_HI_RET(GETWORD(ppvar) + fvaroffset));
;
default: error("Stack corrupted: bad value in name table");
} /* end switch */
} /* end if */
} /* end for */
endlookfor:
goto natnewframe; /* scan the next one */
}
}
Reference in New Issue View Git Blame Copy Permalink