Bring in ficl version 2.03. No version bump for loader.
This commit is contained in:
parent
0212898e1c
commit
de271252c9
Notes:
svn2git
2020-12-20 02:59:44 +00:00
svn path=/head/; revision=51786
@ -37,7 +37,7 @@
|
||||
|
||||
#ifdef BOOT_FORTH
|
||||
#include "ficl.h"
|
||||
#define RETURN(x) stackPushINT32(bf_vm->pStack,!x); return(x)
|
||||
#define RETURN(x) stackPushINT(bf_vm->pStack,!x); return(x)
|
||||
|
||||
extern FICL_VM *bf_vm;
|
||||
#else
|
||||
|
@ -84,7 +84,7 @@ bf_command(FICL_VM *vm)
|
||||
panic("callout for unknown command '%s'", name);
|
||||
|
||||
/* Check whether we have been compiled or are being interpreted */
|
||||
if (stackPopINT32(vm->pStack)) {
|
||||
if (stackPopINT(vm->pStack)) {
|
||||
/*
|
||||
* Get parameters from stack, in the format:
|
||||
* an un ... a2 u2 a1 u1 n --
|
||||
@ -92,7 +92,7 @@ bf_command(FICL_VM *vm)
|
||||
* address/size for strings, and they will be concatenated
|
||||
* in LIFO order.
|
||||
*/
|
||||
nstrings = stackPopINT32(vm->pStack);
|
||||
nstrings = stackPopINT(vm->pStack);
|
||||
for (i = 0, len = 0; i < nstrings; i++)
|
||||
len += stackFetch(vm->pStack, i * 2).i + 1;
|
||||
line = malloc(strlen(name) + len + 1);
|
||||
@ -100,7 +100,7 @@ bf_command(FICL_VM *vm)
|
||||
|
||||
if (nstrings)
|
||||
for (i = 0; i < nstrings; i++) {
|
||||
len = stackPopINT32(vm->pStack);
|
||||
len = stackPopINT(vm->pStack);
|
||||
cp = stackPopPtr(vm->pStack);
|
||||
strcat(line, " ");
|
||||
strncat(line, cp, len);
|
||||
@ -131,7 +131,7 @@ bf_command(FICL_VM *vm)
|
||||
}
|
||||
free(line);
|
||||
/* This is going to be thrown!!! */
|
||||
stackPushINT32(vm->pStack,result);
|
||||
stackPushINT(vm->pStack,result);
|
||||
}
|
||||
|
||||
/*
|
||||
@ -232,17 +232,17 @@ bf_init(void)
|
||||
char create_buf[41]; /* 31 characters-long builtins */
|
||||
int fd;
|
||||
|
||||
ficlInitSystem(8000); /* Default dictionary ~4000 cells */
|
||||
ficlInitSystem(10000); /* Default dictionary ~4000 cells */
|
||||
bf_vm = ficlNewVM();
|
||||
|
||||
/* Builtin constructor word */
|
||||
ficlExec(bf_vm, BUILTIN_CONSTRUCTOR, -1);
|
||||
ficlExec(bf_vm, BUILTIN_CONSTRUCTOR);
|
||||
|
||||
/* make all commands appear as Forth words */
|
||||
SET_FOREACH(cmdp, Xcommand_set) {
|
||||
ficlBuild((*cmdp)->c_name, bf_command, FW_DEFAULT);
|
||||
sprintf(create_buf, "builtin: %s", (*cmdp)->c_name);
|
||||
ficlExec(bf_vm, create_buf, -1);
|
||||
ficlExec(bf_vm, create_buf);
|
||||
}
|
||||
|
||||
/* Export some version numbers so that code can detect the loader/host version */
|
||||
@ -271,9 +271,7 @@ bf_run(char *line)
|
||||
|
||||
id = bf_vm->sourceID;
|
||||
bf_vm->sourceID.i = -1;
|
||||
vmPushIP(bf_vm, &pInterp);
|
||||
result = ficlExec(bf_vm, line, -1);
|
||||
vmPopIP(bf_vm);
|
||||
result = ficlExec(bf_vm, line);
|
||||
bf_vm->sourceID = id;
|
||||
|
||||
DEBUG("ficlExec '%s' = %d", line, result);
|
||||
|
@ -9,7 +9,8 @@ SRCS= ${BASE_SRCS} softcore.c
|
||||
CLEANFILES= softcore.c testmain
|
||||
|
||||
# Standard softwords
|
||||
SOFTWORDS= softcore.fr jhlocal.fr marker.fr freebsd.fr
|
||||
SOFTWORDS= softcore.fr jhlocal.fr marker.fr freebsd.fr ficllocal.fr \
|
||||
ifbrack.fr
|
||||
# Optional OO extension softwords
|
||||
#SOFTWORDS+= oo.fr classes.fr
|
||||
|
||||
|
@ -7,6 +7,8 @@
|
||||
**
|
||||
*******************************************************************/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#ifdef TESTMAIN
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
@ -22,9 +24,10 @@
|
||||
******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
|
||||
*/
|
||||
|
||||
UNS64 ficlLongMul(UNS32 x, UNS32 y)
|
||||
#if PORTABLE_LONGMULDIV == 0
|
||||
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
|
||||
{
|
||||
UNS64 q;
|
||||
DPUNS q;
|
||||
u_int64_t qx;
|
||||
|
||||
qx = (u_int64_t)x * (u_int64_t) y;
|
||||
@ -35,7 +38,7 @@ UNS64 ficlLongMul(UNS32 x, UNS32 y)
|
||||
return q;
|
||||
}
|
||||
|
||||
UNSQR ficlLongDiv(UNS64 q, UNS32 y)
|
||||
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
|
||||
{
|
||||
UNSQR result;
|
||||
u_int64_t qx, qh;
|
||||
@ -48,6 +51,7 @@ UNSQR ficlLongDiv(UNS64 q, UNS32 y)
|
||||
|
||||
return result;
|
||||
}
|
||||
#endif
|
||||
|
||||
void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
|
||||
{
|
||||
@ -88,8 +92,8 @@ ficlOutb(FICL_VM *pVM)
|
||||
u_char c;
|
||||
u_int32_t port;
|
||||
|
||||
port=stackPopUNS32(pVM->pStack);
|
||||
c=(u_char)stackPopINT32(pVM->pStack);
|
||||
port=stackPopUNS(pVM->pStack);
|
||||
c=(u_char)stackPopINT(pVM->pStack);
|
||||
outb(port,c);
|
||||
}
|
||||
|
||||
@ -103,9 +107,9 @@ ficlInb(FICL_VM *pVM)
|
||||
u_char c;
|
||||
u_int32_t port;
|
||||
|
||||
port=stackPopUNS32(pVM->pStack);
|
||||
port=stackPopUNS(pVM->pStack);
|
||||
c=inb(port);
|
||||
stackPushINT32(pVM->pStack,c);
|
||||
stackPushINT(pVM->pStack,c);
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
|
@ -32,6 +32,8 @@
|
||||
** send me email at the address above.
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#if !defined (__SYSDEP_H__)
|
||||
#define __SYSDEP_H__
|
||||
|
||||
@ -60,48 +62,75 @@
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
** System dependent data type declarations...
|
||||
*/
|
||||
#if !defined INT32
|
||||
#define INT32 int32_t
|
||||
#define INT32 long
|
||||
#endif
|
||||
|
||||
#if !defined UNS32
|
||||
#define UNS32 u_int32_t
|
||||
#define UNS32 unsigned long
|
||||
#endif
|
||||
|
||||
#if !defined UNS16
|
||||
#define UNS16 u_int16_t
|
||||
#define UNS16 unsigned short
|
||||
#endif
|
||||
|
||||
#if !defined UNS8
|
||||
#define UNS8 u_int8_t
|
||||
#define UNS8 unsigned char
|
||||
#endif
|
||||
|
||||
#if !defined NULL
|
||||
#define NULL ((void *)0)
|
||||
#endif
|
||||
|
||||
typedef struct
|
||||
{
|
||||
UNS32 hi;
|
||||
UNS32 lo;
|
||||
} UNS64;
|
||||
/*
|
||||
** FICL_UNS and FICL_INT must have the same size as a void* on
|
||||
** the target system. A CELL is a union of void*, FICL_UNS, and
|
||||
** FICL_INT.
|
||||
*/
|
||||
#if !defined FICL_INT
|
||||
#define FICL_INT INT32
|
||||
#endif
|
||||
|
||||
#if !defined FICL_UNS
|
||||
#define FICL_UNS UNS32
|
||||
#endif
|
||||
|
||||
/*
|
||||
** Ficl presently supports values of 32 and 64 for BITS_PER_CELL
|
||||
*/
|
||||
#if !defined BITS_PER_CELL
|
||||
#define BITS_PER_CELL 32
|
||||
#endif
|
||||
|
||||
#if ((BITS_PER_CELL != 32) && (BITS_PER_CELL != 64))
|
||||
Error!
|
||||
#endif
|
||||
|
||||
typedef struct
|
||||
{
|
||||
UNS32 quot;
|
||||
UNS32 rem;
|
||||
FICL_UNS hi;
|
||||
FICL_UNS lo;
|
||||
} DPUNS;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
FICL_UNS quot;
|
||||
FICL_UNS rem;
|
||||
} UNSQR;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
INT32 hi;
|
||||
INT32 lo;
|
||||
} INT64;
|
||||
FICL_INT hi;
|
||||
FICL_INT lo;
|
||||
} DPINT;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
INT32 quot;
|
||||
INT32 rem;
|
||||
FICL_INT quot;
|
||||
FICL_INT rem;
|
||||
} INTQR;
|
||||
|
||||
|
||||
@ -114,6 +143,30 @@ typedef struct
|
||||
#define FICL_MULTITHREAD 0
|
||||
#endif
|
||||
|
||||
/*
|
||||
** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be
|
||||
** defined in C in sysdep.c. Use this if you cannot easily
|
||||
** generate an inline asm definition
|
||||
*/
|
||||
#if !defined (PORTABLE_LONGMULDIV)
|
||||
#define PORTABLE_LONGMULDIV 0
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
** INLINE_INNER_LOOP causes the inner interpreter to be inline code
|
||||
** instead of a function call. This is mainly because MS VC++ 5
|
||||
** chokes with an internal compiler error on the function version.
|
||||
** in release mode. Sheesh.
|
||||
*/
|
||||
#if !defined INLINE_INNER_LOOP
|
||||
#if defined _DEBUG
|
||||
#define INLINE_INNER_LOOP 0
|
||||
#else
|
||||
#define INLINE_INNER_LOOP 1
|
||||
#endif
|
||||
#endif
|
||||
|
||||
/*
|
||||
** FICL_ROBUST enables bounds checking of stacks and the dictionary.
|
||||
** This will detect stack over and underflows and dictionary overflows.
|
||||
@ -192,7 +245,7 @@ typedef struct
|
||||
** pointer address must be aligned. This value is usually
|
||||
** either 1 or 2, depending on the memory architecture
|
||||
** of the target system; 2 is safe on any 16 or 32 bit
|
||||
** machine.
|
||||
** machine. 3 would be appropriate for a 64 bit machine.
|
||||
*/
|
||||
#if !defined FICL_ALIGN
|
||||
#define FICL_ALIGN 2
|
||||
@ -215,9 +268,8 @@ typedef struct
|
||||
struct vm;
|
||||
void ficlTextOut(struct vm *pVM, char *msg, int fNewline);
|
||||
void *ficlMalloc (size_t size);
|
||||
void *ficlRealloc (void *p, size_t size);
|
||||
void ficlFree (void *p);
|
||||
|
||||
void *ficlRealloc(void *p, size_t size);
|
||||
/*
|
||||
** Stub function for dictionary access control - does nothing
|
||||
** by default, user can redefine to guarantee exclusive dict
|
||||
@ -241,12 +293,12 @@ int ficlLockDictionary(short fLock);
|
||||
|
||||
/*
|
||||
** 64 bit integer math support routines: multiply two UNS32s
|
||||
** to get a 64 bit prodict, & divide the product by an UNS32
|
||||
** to get a 64 bit product, & divide the product by an UNS32
|
||||
** to get an UNS32 quotient and remainder. Much easier in asm
|
||||
** on a 32 bit CPU than in C, which usually doesn't support
|
||||
** the double length result (but it should).
|
||||
*/
|
||||
UNS64 ficlLongMul(UNS32 x, UNS32 y);
|
||||
UNSQR ficlLongDiv(UNS64 q, UNS32 y);
|
||||
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y);
|
||||
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y);
|
||||
|
||||
#endif /*__SYSDEP_H__*/
|
||||
|
@ -17,6 +17,8 @@
|
||||
** 29 jun 1998 (sadler) added variable sized hash table support
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#ifdef TESTMAIN
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
@ -197,7 +199,6 @@ FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
|
||||
UNS8 flags)
|
||||
{
|
||||
FICL_COUNT len = (FICL_COUNT)SI_COUNT(si);
|
||||
char *name = SI_PTR(si);
|
||||
char *pName;
|
||||
FICL_WORD *pFW;
|
||||
|
||||
@ -232,7 +233,7 @@ FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
|
||||
d i c t A p p e n d U N S 3 2
|
||||
** Append the specified UNS32 to the dictionary
|
||||
**************************************************************************/
|
||||
void dictAppendUNS32(FICL_DICT *pDict, UNS32 u)
|
||||
void dictAppendUNS(FICL_DICT *pDict, UNS32 u)
|
||||
{
|
||||
*pDict->here++ = LVALUEtoCELL(u);
|
||||
return;
|
||||
|
@ -21,6 +21,8 @@
|
||||
** Code is written in ANSI C for portability.
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#ifdef TESTMAIN
|
||||
#include <stdlib.h>
|
||||
#else
|
||||
@ -174,20 +176,30 @@ int ficlBuild(char *name, FICL_CODE code, char flags)
|
||||
** time to delete the vm, etc -- or you can ignore this
|
||||
** signal.
|
||||
**************************************************************************/
|
||||
int ficlExec(FICL_VM *pVM, char *pText, INT32 size)
|
||||
int ficlExec(FICL_VM *pVM, char *pText)
|
||||
{
|
||||
#ifdef FICL_TRACE
|
||||
extern int isAFiclWord(FICL_WORD *pFW);
|
||||
#endif
|
||||
return ficlExecC(pVM, pText, -1);
|
||||
}
|
||||
|
||||
int ficlExecC(FICL_VM *pVM, char *pText, FICL_INT size)
|
||||
{
|
||||
static FICL_WORD *pInterp = NULL;
|
||||
|
||||
int except;
|
||||
FICL_WORD *tempFW;
|
||||
jmp_buf vmState;
|
||||
TIB saveTib;
|
||||
FICL_VM VM;
|
||||
FICL_STACK rStack;
|
||||
|
||||
if (!pInterp)
|
||||
pInterp = ficlLookup("interpret");
|
||||
|
||||
assert(pInterp);
|
||||
assert(pVM);
|
||||
|
||||
if (size < 0)
|
||||
size = strlen(pText);
|
||||
|
||||
vmPushTib(pVM, pText, size, &saveTib);
|
||||
|
||||
/*
|
||||
@ -207,106 +219,12 @@ int ficlExec(FICL_VM *pVM, char *pText, INT32 size)
|
||||
pVM->fRestart = 0;
|
||||
pVM->runningWord->code(pVM);
|
||||
}
|
||||
|
||||
/*
|
||||
** the mysterious inner interpreter...
|
||||
** vmThrow gets you out of this loop with a longjmp()
|
||||
*/
|
||||
for (;;)
|
||||
{
|
||||
#ifdef FICL_TRACE
|
||||
CELL c;
|
||||
char buffer[40];
|
||||
#endif
|
||||
tempFW = *pVM->ip++;
|
||||
#ifdef FICL_TRACE
|
||||
if (ficl_trace && isAFiclWord(tempFW))
|
||||
{
|
||||
extern void literalParen(FICL_VM*);
|
||||
extern void stringLit(FICL_VM*);
|
||||
extern void ifParen(FICL_VM*);
|
||||
extern void branchParen(FICL_VM*);
|
||||
extern void qDoParen(FICL_VM*);
|
||||
extern void doParen(FICL_VM*);
|
||||
extern void loopParen(FICL_VM*);
|
||||
extern void plusLoopParen(FICL_VM*);
|
||||
|
||||
if (tempFW->code == literalParen)
|
||||
{
|
||||
c = *PTRtoCELL(pVM->ip);
|
||||
if (isAFiclWord(c.p))
|
||||
{
|
||||
FICL_WORD *pLit = (FICL_WORD *)c.p;
|
||||
sprintf(buffer, " literal %.*s (%#lx)",
|
||||
pLit->nName, pLit->name, c.u);
|
||||
}
|
||||
else
|
||||
sprintf(buffer, " literal %ld (%#lx)", c.i, c.u);
|
||||
}
|
||||
else if (tempFW->code == stringLit)
|
||||
{
|
||||
FICL_STRING *sp = PTRtoSTRING(pVM->ip);
|
||||
sprintf(buffer, " s\" %.*s\"", sp->count, sp->text);
|
||||
}
|
||||
else if (tempFW->code == ifParen)
|
||||
{
|
||||
c = *PTRtoCELL(pVM->ip);
|
||||
if (c.i > 0)
|
||||
sprintf(buffer, " if / while (branch rel %ld)", c.i);
|
||||
else
|
||||
sprintf(buffer, " until (branch rel %ld)", c.i);
|
||||
}
|
||||
else if (tempFW->code == branchParen)
|
||||
{
|
||||
c = *PTRtoCELL(pVM->ip);
|
||||
if (c.i > 0)
|
||||
sprintf(buffer, " else (branch rel %ld)", c.i);
|
||||
else
|
||||
sprintf(buffer, " repeat (branch rel %ld)", c.i);
|
||||
}
|
||||
else if (tempFW->code == qDoParen)
|
||||
{
|
||||
c = *PTRtoCELL(pVM->ip);
|
||||
sprintf(buffer, " ?do (leave abs %#lx)", c.u);
|
||||
}
|
||||
else if (tempFW->code == doParen)
|
||||
{
|
||||
c = *PTRtoCELL(pVM->ip);
|
||||
sprintf(buffer, " do (leave abs %#lx)", c.u);
|
||||
}
|
||||
else if (tempFW->code == loopParen)
|
||||
{
|
||||
c = *PTRtoCELL(pVM->ip);
|
||||
sprintf(buffer, " loop (branch rel %ld)", c.i);
|
||||
}
|
||||
else if (tempFW->code == plusLoopParen)
|
||||
{
|
||||
c = *PTRtoCELL(pVM->ip);
|
||||
sprintf(buffer, " +loop (branch rel %ld)", c.i);
|
||||
}
|
||||
else /* default: print word's name */
|
||||
{
|
||||
sprintf(buffer, " %.*s", tempFW->nName, tempFW->name);
|
||||
}
|
||||
|
||||
vmTextOut(pVM, buffer, 1);
|
||||
}
|
||||
else if (ficl_trace) /* probably not a word
|
||||
* - punt and print value
|
||||
*/
|
||||
{
|
||||
sprintf(buffer, " %ld (%#lx)", (PTRtoCELL(pVM->ip))->i, (PTRtoCELL(pVM->ip))->u);
|
||||
vmTextOut(pVM, buffer, 1);
|
||||
}
|
||||
#endif FICL_TRACE
|
||||
/*
|
||||
** inline code for
|
||||
** vmExecute(pVM, tempFW);
|
||||
*/
|
||||
pVM->runningWord = tempFW;
|
||||
tempFW->code(pVM);
|
||||
else
|
||||
{ /* set VM up to interpret text */
|
||||
vmPushIP(pVM, &pInterp);
|
||||
}
|
||||
|
||||
vmInnerLoop(pVM);
|
||||
break;
|
||||
|
||||
case VM_RESTART:
|
||||
@ -315,6 +233,7 @@ int ficlExec(FICL_VM *pVM, char *pText, INT32 size)
|
||||
break;
|
||||
|
||||
case VM_OUTOFTEXT:
|
||||
vmPopIP(pVM);
|
||||
#ifdef TESTMAIN
|
||||
if ((pVM->state != COMPILE) && (pVM->sourceID.i == 0))
|
||||
ficlTextOut(pVM, FICL_PROMPT, 0);
|
||||
@ -322,14 +241,18 @@ int ficlExec(FICL_VM *pVM, char *pText, INT32 size)
|
||||
break;
|
||||
|
||||
case VM_USEREXIT:
|
||||
case VM_INNEREXIT:
|
||||
break;
|
||||
|
||||
case VM_QUIT:
|
||||
if (pVM->state == COMPILE)
|
||||
{
|
||||
dictAbortDefinition(dp);
|
||||
|
||||
memcpy((void*)pVM, (void*)&VM, sizeof(FICL_VM));
|
||||
memcpy((void*)pVM->rStack, (void*)&rStack, sizeof(FICL_STACK));
|
||||
#if FICL_WANT_LOCALS
|
||||
dictEmpty(localp, localp->pForthWords->size);
|
||||
#endif
|
||||
}
|
||||
vmQuit(pVM);
|
||||
break;
|
||||
|
||||
case VM_ERREXIT:
|
||||
@ -386,7 +309,7 @@ int ficlExecFD(FICL_VM *pVM, int fd)
|
||||
break;
|
||||
continue;
|
||||
}
|
||||
rval = ficlExec(pVM, cp, i);
|
||||
rval = ficlExecC(pVM, cp, i);
|
||||
if(rval != VM_QUIT && rval != VM_USEREXIT && rval != VM_OUTOFTEXT)
|
||||
{
|
||||
pVM->sourceID = id;
|
||||
@ -398,12 +321,85 @@ int ficlExecFD(FICL_VM *pVM, int fd)
|
||||
** any pending REFILLs (as required by FILE wordset)
|
||||
*/
|
||||
pVM->sourceID.i = -1;
|
||||
ficlExec(pVM, "", 0);
|
||||
ficlExec(pVM, "");
|
||||
|
||||
pVM->sourceID = id;
|
||||
return rval;
|
||||
}
|
||||
|
||||
/**************************************************************************
|
||||
f i c l E x e c X T
|
||||
** Given a pointer to a FICL_WORD, push an inner interpreter and
|
||||
** execute the word to completion. This is in contrast with vmExecute,
|
||||
** which does not guarantee that the word will have completed when
|
||||
** the function returns (ie in the case of colon definitions, which
|
||||
** need an inner interpreter to finish)
|
||||
**
|
||||
** Returns one of the VM_XXXX exception codes listed in ficl.h. Normal
|
||||
** exit condition is VM_INNEREXIT, ficl's private signal to exit the
|
||||
** inner loop under normal circumstances. If another code is thrown to
|
||||
** exit the loop, this function will re-throw it if it's nested under
|
||||
** itself or ficlExec.
|
||||
**
|
||||
** NOTE: this function is intended so that C code can execute ficlWords
|
||||
** given their address in the dictionary (xt).
|
||||
**************************************************************************/
|
||||
int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord)
|
||||
{
|
||||
static FICL_WORD *pQuit = NULL;
|
||||
int except;
|
||||
jmp_buf vmState;
|
||||
jmp_buf *oldState;
|
||||
|
||||
if (!pQuit)
|
||||
pQuit = ficlLookup("exit-inner");
|
||||
|
||||
assert(pVM);
|
||||
assert(pQuit);
|
||||
|
||||
/*
|
||||
** Save and restore VM's jmp_buf to enable nested calls
|
||||
*/
|
||||
oldState = pVM->pState;
|
||||
pVM->pState = &vmState; /* This has to come before the setjmp! */
|
||||
except = setjmp(vmState);
|
||||
|
||||
if (except)
|
||||
vmPopIP(pVM);
|
||||
else
|
||||
vmPushIP(pVM, &pQuit);
|
||||
|
||||
switch (except)
|
||||
{
|
||||
case 0:
|
||||
vmExecute(pVM, pWord);
|
||||
vmInnerLoop(pVM);
|
||||
break;
|
||||
|
||||
case VM_INNEREXIT:
|
||||
break;
|
||||
|
||||
case VM_RESTART:
|
||||
case VM_OUTOFTEXT:
|
||||
case VM_USEREXIT:
|
||||
case VM_QUIT:
|
||||
case VM_ERREXIT:
|
||||
case VM_ABORT:
|
||||
case VM_ABORTQ:
|
||||
default: /* user defined exit code?? */
|
||||
if (oldState)
|
||||
{
|
||||
pVM->pState = oldState;
|
||||
vmThrow(pVM, except);
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
||||
pVM->pState = oldState;
|
||||
return (except);
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
f i c l L o o k u p
|
||||
** Look in the system dictionary for a match to the given name. If
|
||||
@ -443,7 +439,7 @@ FICL_DICT *ficlGetEnv(void)
|
||||
** Create an environment variable with a one-CELL payload. ficlSetEnvD
|
||||
** makes one with a two-CELL payload.
|
||||
**************************************************************************/
|
||||
void ficlSetEnv(char *name, UNS32 value)
|
||||
void ficlSetEnv(char *name, FICL_UNS value)
|
||||
{
|
||||
STRINGINFO si;
|
||||
FICL_WORD *pFW;
|
||||
@ -464,7 +460,7 @@ void ficlSetEnv(char *name, UNS32 value)
|
||||
return;
|
||||
}
|
||||
|
||||
void ficlSetEnvD(char *name, UNS32 hi, UNS32 lo)
|
||||
void ficlSetEnvD(char *name, FICL_UNS hi, FICL_UNS lo)
|
||||
{
|
||||
FICL_WORD *pFW;
|
||||
STRINGINFO si;
|
||||
@ -500,6 +496,23 @@ FICL_DICT *ficlGetLoc(void)
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
f i c l S e t S t a c k S i z e
|
||||
** Set the stack sizes (return and parameter) to be used for all
|
||||
** subsequently created VMs. Returns actual stack size to be used.
|
||||
**************************************************************************/
|
||||
int ficlSetStackSize(int nStackCells)
|
||||
{
|
||||
if (nStackCells >= FICL_DEFAULT_STACK)
|
||||
defaultStack = nStackCells;
|
||||
else
|
||||
defaultStack = FICL_DEFAULT_STACK;
|
||||
|
||||
return defaultStack;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
f i c l T e r m S y s t e m
|
||||
** Tear the system down by deleting the dictionaries and all VMs.
|
||||
|
@ -27,6 +27,8 @@
|
||||
** send me email at the address above.
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#if !defined (__FICL_H__)
|
||||
#define __FICL_H__
|
||||
/*
|
||||
@ -114,19 +116,6 @@
|
||||
** 4. Ficl uses the pad in CORE words - this violates the standard,
|
||||
** but it's cleaner for a multithreaded system. I'll have to make a
|
||||
** second pad for reference by the word PAD to fix this.
|
||||
** 5. The whole inner interpreter is screwed up. It ought to be detached
|
||||
** from ficlExec. Also, it should fall in line with exception
|
||||
** handling by saving state. (sobral)
|
||||
** 6. EXCEPTION should be cleaned. Right now, it doubles ficlExec's
|
||||
** inner interpreter. (sobral)
|
||||
** 7. colonParen must get the inner interpreter working on it's "case"
|
||||
** *before* returning, so that it becomes possible to execute them
|
||||
** inside other definitions without recreating the inner interpreter
|
||||
** or other such hacks. (sobral)
|
||||
** 8. We now have EXCEPTION word set. Let's:
|
||||
** 8.1. Use the appropriate exceptions throughout the code.
|
||||
** 8.2. Print the error messages at ficlExec, so someone can catch
|
||||
** them first. (sobral)
|
||||
**
|
||||
** F o r M o r e I n f o r m a t i o n
|
||||
**
|
||||
@ -166,7 +155,9 @@
|
||||
|
||||
/*
|
||||
** Revision History:
|
||||
**
|
||||
**
|
||||
** 15 Apr 1999 (sadler) Merged FreeBSD changes for exception wordset and
|
||||
** counted strings in ficlExec.
|
||||
** 12 Jan 1999 (sobral) Corrected EVALUATE behavior. Now TIB has an
|
||||
** "end" field, and all words respect this. ficlExec is passed a "size"
|
||||
** of TIB, as well as vmPushTib. This size is used to calculate the "end"
|
||||
@ -228,9 +219,9 @@ struct ficl_dict;
|
||||
/*
|
||||
** the Good Stuff starts here...
|
||||
*/
|
||||
#define FICL_VER "2.02"
|
||||
#ifndef FICL_PROMPT
|
||||
# define FICL_PROMPT "ok> "
|
||||
#define FICL_VER "2.03"
|
||||
#if !defined (FICL_PROMPT)
|
||||
#define FICL_PROMPT "ok> "
|
||||
#endif
|
||||
|
||||
/*
|
||||
@ -245,13 +236,13 @@ struct ficl_dict;
|
||||
|
||||
/*
|
||||
** A CELL is the main storage type. It must be large enough
|
||||
** to contain a pointer or a scalar. Let's be picky and make
|
||||
** a 32 bit cell explicitly...
|
||||
** to contain a pointer or a scalar. In order to accommodate
|
||||
** 32 bit and 64 bit processors, use abstract types for i and u.
|
||||
*/
|
||||
typedef union _cell
|
||||
{
|
||||
INT32 i;
|
||||
UNS32 u;
|
||||
FICL_INT i;
|
||||
FICL_UNS u;
|
||||
void *p;
|
||||
} CELL;
|
||||
|
||||
@ -342,7 +333,7 @@ typedef struct
|
||||
*/
|
||||
typedef struct _ficlStack
|
||||
{
|
||||
UNS32 nCells; /* size of the stack */
|
||||
FICL_UNS nCells; /* size of the stack */
|
||||
CELL *pFrame; /* link reg for stack frame */
|
||||
CELL *sp; /* stack pointer */
|
||||
CELL base[1]; /* Bottom of the stack */
|
||||
@ -361,12 +352,12 @@ void stackLink (FICL_STACK *pStack, int nCells);
|
||||
void stackPick (FICL_STACK *pStack, int n);
|
||||
CELL stackPop (FICL_STACK *pStack);
|
||||
void *stackPopPtr (FICL_STACK *pStack);
|
||||
UNS32 stackPopUNS32 (FICL_STACK *pStack);
|
||||
INT32 stackPopINT32 (FICL_STACK *pStack);
|
||||
FICL_UNS stackPopUNS(FICL_STACK *pStack);
|
||||
FICL_INT stackPopINT(FICL_STACK *pStack);
|
||||
void stackPush (FICL_STACK *pStack, CELL c);
|
||||
void stackPushPtr (FICL_STACK *pStack, void *ptr);
|
||||
void stackPushUNS32(FICL_STACK *pStack, UNS32 u);
|
||||
void stackPushINT32(FICL_STACK *pStack, INT32 i);
|
||||
void stackPushUNS(FICL_STACK *pStack, FICL_UNS u);
|
||||
void stackPushINT(FICL_STACK *pStack, FICL_INT i);
|
||||
void stackReset (FICL_STACK *pStack);
|
||||
void stackRoll (FICL_STACK *pStack, int n);
|
||||
void stackSetTop(FICL_STACK *pStack, CELL c);
|
||||
@ -459,6 +450,12 @@ typedef struct vm
|
||||
*/
|
||||
typedef void (*FICL_CODE)(FICL_VM *pVm);
|
||||
|
||||
#if 0
|
||||
#define VM_ASSERT(pVM) assert((*(pVM->ip - 1)) == pVM->runningWord)
|
||||
#else
|
||||
#define VM_ASSERT(pVM)
|
||||
#endif
|
||||
|
||||
/*
|
||||
** Ficl models memory as a contiguous space divided into
|
||||
** words in a linked list called the dictionary.
|
||||
@ -501,10 +498,11 @@ int wordIsCompileOnly(FICL_WORD *pFW);
|
||||
/*
|
||||
** Exit codes for vmThrow
|
||||
*/
|
||||
#define VM_OUTOFTEXT -256 /* hungry - normal exit */
|
||||
#define VM_RESTART -257 /* word needs more text to suxcceed - re-run it */
|
||||
#define VM_USEREXIT -258 /* user wants to quit */
|
||||
#define VM_ERREXIT -259 /* interp found an error */
|
||||
#define VM_INNEREXIT -256 /* tell ficlExecXT to exit inner loop */
|
||||
#define VM_OUTOFTEXT -257 /* hungry - normal exit */
|
||||
#define VM_RESTART -258 /* word needs more text to succeed - re-run it */
|
||||
#define VM_USEREXIT -259 /* user wants to quit */
|
||||
#define VM_ERREXIT -260 /* interp found an error */
|
||||
#define VM_ABORT -1 /* like errexit -- abort */
|
||||
#define VM_ABORTQ -2 /* like errexit -- abort" */
|
||||
#define VM_QUIT -56 /* like errexit, but leave pStack & base alone */
|
||||
@ -528,6 +526,28 @@ void vmTextOut(FICL_VM *pVM, char *text, int fNewline);
|
||||
void vmThrow (FICL_VM *pVM, int except);
|
||||
void vmThrowErr(FICL_VM *pVM, char *fmt, ...);
|
||||
|
||||
#define vmGetRunningWord(pVM) ((pVM)->runningWord)
|
||||
|
||||
|
||||
/*
|
||||
** The inner interpreter - coded as a macro (see note for
|
||||
** INLINE_INNER_LOOP in sysdep.h for complaints about VC++ 5
|
||||
*/
|
||||
#define M_INNER_LOOP(pVM) \
|
||||
for (;;) \
|
||||
{ \
|
||||
FICL_WORD *tempFW = *(pVM)->ip++; \
|
||||
(pVM)->runningWord = tempFW; \
|
||||
tempFW->code(pVM); \
|
||||
}
|
||||
|
||||
|
||||
#if INLINE_INNER_LOOP != 0
|
||||
#define vmInnerLoop(pVM) M_INNER_LOOP(pVM)
|
||||
#else
|
||||
void vmInnerLoop(FICL_VM *pVM);
|
||||
#endif
|
||||
|
||||
/*
|
||||
** vmCheckStack needs a vm pointer because it might have to say
|
||||
** something if it finds a problem. Parms popCells and pushCells
|
||||
@ -546,9 +566,11 @@ void vmCheckStack(FICL_VM *pVM, int popCells, int pushCells);
|
||||
** PopTib restores the TIB state given a saved TIB from PushTib
|
||||
** GetInBuf returns a pointer to the next unused char of the TIB
|
||||
*/
|
||||
void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib);
|
||||
void vmPushTib(FICL_VM *pVM, char *text, INT32 nChars, TIB *pSaveTib);
|
||||
void vmPopTib(FICL_VM *pVM, TIB *pTib);
|
||||
#define vmGetInBuf(pVM) ((pVM)->tib.cp + (pVM)->tib.index)
|
||||
#define vmGetInBufLen(pVM) ((pVM)->tib.end - (pVM)->tib.cp)
|
||||
#define vmGetInBufEnd(pVM) ((pVM)->tib.end)
|
||||
#define vmSetTibIndex(pVM, i) (pVM)->tib.index = i
|
||||
#define vmUpdateTib(pVM, str) (pVM)->tib.index = (str) - (pVM)->tib.cp
|
||||
|
||||
@ -564,11 +586,13 @@ void vmPopTib(FICL_VM *pVM, TIB *pTib);
|
||||
#pragma warning(disable: 4273)
|
||||
#endif
|
||||
|
||||
char *ltoa( INT32 value, char *string, int radix );
|
||||
char *ultoa(UNS32 value, char *string, int radix );
|
||||
int isPowerOfTwo(FICL_UNS u);
|
||||
|
||||
char *ltoa( FICL_INT value, char *string, int radix );
|
||||
char *ultoa(FICL_UNS value, char *string, int radix );
|
||||
char digit_to_char(int value);
|
||||
char *strrev( char *string );
|
||||
char *skipSpace(char *cp,char *end);
|
||||
char *skipSpace(char *cp, char *end);
|
||||
char *caseFold(char *cp);
|
||||
int strincmp(char *cp1, char *cp2, FICL_COUNT count);
|
||||
|
||||
@ -583,7 +607,7 @@ int strincmp(char *cp1, char *cp2, FICL_COUNT count);
|
||||
** A WORDLIST (see the search order word set in DPANS) is
|
||||
** just a pointer to a FICL_HASH in this implementation.
|
||||
*/
|
||||
#if !defined HASHSIZE /* Default size of hash table. For best */
|
||||
#if !defined HASHSIZE /* Default size of hash table. For most uniform */
|
||||
#define HASHSIZE 127 /* performance, use a prime number! */
|
||||
#endif
|
||||
|
||||
@ -660,7 +684,7 @@ FICL_WORD *dictAppendWord2(FICL_DICT *pDict,
|
||||
STRINGINFO si,
|
||||
FICL_CODE pCode,
|
||||
UNS8 flags);
|
||||
void dictAppendUNS32(FICL_DICT *pDict, UNS32 u);
|
||||
void dictAppendUNS(FICL_DICT *pDict, FICL_UNS u);
|
||||
int dictCellsAvail(FICL_DICT *pDict);
|
||||
int dictCellsUsed (FICL_DICT *pDict);
|
||||
void dictCheck(FICL_DICT *pDict, FICL_VM *pVM, int nCells);
|
||||
@ -709,8 +733,8 @@ void ficlTermSystem(void);
|
||||
** f i c l E x e c
|
||||
** Evaluates a block of input text in the context of the
|
||||
** specified interpreter. Emits any requested output to the
|
||||
** interpreter's output function. If the size of the input
|
||||
** is not known, pass -1.
|
||||
** interpreter's output function. If the input string is NULL
|
||||
** terminated, you can pass -1 as nChars rather than count it.
|
||||
** Execution returns when the text block has been executed,
|
||||
** or an error occurs.
|
||||
** Returns one of the VM_XXXX codes defined in ficl.h:
|
||||
@ -727,7 +751,9 @@ void ficlTermSystem(void);
|
||||
** Preconditions: successful execution of ficlInitSystem,
|
||||
** Successful creation and init of the VM by ficlNewVM (or equiv)
|
||||
*/
|
||||
int ficlExec(FICL_VM *pVM, char *pText, INT32 size);
|
||||
int ficlExec (FICL_VM *pVM, char *pText);
|
||||
int ficlExecC(FICL_VM *pVM, char *pText, INT32 nChars);
|
||||
int ficlExecXT(FICL_VM *pVM, FICL_WORD *pWord);
|
||||
|
||||
/*
|
||||
** ficlExecFD(FICL_VM *pVM, int fd);
|
||||
@ -745,6 +771,12 @@ int ficlExecFD(FICL_VM *pVM, int fd);
|
||||
*/
|
||||
FICL_VM *ficlNewVM(void);
|
||||
|
||||
/*
|
||||
** Set the stack sizes (return and parameter) to be used for all
|
||||
** subsequently created VMs. Returns actual stack size to be used.
|
||||
*/
|
||||
int ficlSetStackSize(int nStackCells);
|
||||
|
||||
/*
|
||||
** Returns the address of the most recently defined word in the system
|
||||
** dictionary with the given name, or NULL if no match.
|
||||
|
@ -7,6 +7,8 @@
|
||||
**
|
||||
*******************************************************************/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#ifdef TESTMAIN
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
@ -22,9 +24,10 @@
|
||||
******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
|
||||
*/
|
||||
|
||||
UNS64 ficlLongMul(UNS32 x, UNS32 y)
|
||||
#if PORTABLE_LONGMULDIV == 0
|
||||
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
|
||||
{
|
||||
UNS64 q;
|
||||
DPUNS q;
|
||||
u_int64_t qx;
|
||||
|
||||
qx = (u_int64_t)x * (u_int64_t) y;
|
||||
@ -35,7 +38,7 @@ UNS64 ficlLongMul(UNS32 x, UNS32 y)
|
||||
return q;
|
||||
}
|
||||
|
||||
UNSQR ficlLongDiv(UNS64 q, UNS32 y)
|
||||
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
|
||||
{
|
||||
UNSQR result;
|
||||
u_int64_t qx, qh;
|
||||
@ -48,6 +51,7 @@ UNSQR ficlLongDiv(UNS64 q, UNS32 y)
|
||||
|
||||
return result;
|
||||
}
|
||||
#endif
|
||||
|
||||
void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
|
||||
{
|
||||
@ -88,8 +92,8 @@ ficlOutb(FICL_VM *pVM)
|
||||
u_char c;
|
||||
u_int32_t port;
|
||||
|
||||
port=stackPopUNS32(pVM->pStack);
|
||||
c=(u_char)stackPopINT32(pVM->pStack);
|
||||
port=stackPopUNS(pVM->pStack);
|
||||
c=(u_char)stackPopINT(pVM->pStack);
|
||||
outb(port,c);
|
||||
}
|
||||
|
||||
@ -103,9 +107,9 @@ ficlInb(FICL_VM *pVM)
|
||||
u_char c;
|
||||
u_int32_t port;
|
||||
|
||||
port=stackPopUNS32(pVM->pStack);
|
||||
port=stackPopUNS(pVM->pStack);
|
||||
c=inb(port);
|
||||
stackPushINT32(pVM->pStack,c);
|
||||
stackPushINT(pVM->pStack,c);
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
|
@ -32,6 +32,8 @@
|
||||
** send me email at the address above.
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#if !defined (__SYSDEP_H__)
|
||||
#define __SYSDEP_H__
|
||||
|
||||
@ -60,48 +62,75 @@
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
** System dependent data type declarations...
|
||||
*/
|
||||
#if !defined INT32
|
||||
#define INT32 int32_t
|
||||
#define INT32 long
|
||||
#endif
|
||||
|
||||
#if !defined UNS32
|
||||
#define UNS32 u_int32_t
|
||||
#define UNS32 unsigned long
|
||||
#endif
|
||||
|
||||
#if !defined UNS16
|
||||
#define UNS16 u_int16_t
|
||||
#define UNS16 unsigned short
|
||||
#endif
|
||||
|
||||
#if !defined UNS8
|
||||
#define UNS8 u_int8_t
|
||||
#define UNS8 unsigned char
|
||||
#endif
|
||||
|
||||
#if !defined NULL
|
||||
#define NULL ((void *)0)
|
||||
#endif
|
||||
|
||||
typedef struct
|
||||
{
|
||||
UNS32 hi;
|
||||
UNS32 lo;
|
||||
} UNS64;
|
||||
/*
|
||||
** FICL_UNS and FICL_INT must have the same size as a void* on
|
||||
** the target system. A CELL is a union of void*, FICL_UNS, and
|
||||
** FICL_INT.
|
||||
*/
|
||||
#if !defined FICL_INT
|
||||
#define FICL_INT INT32
|
||||
#endif
|
||||
|
||||
#if !defined FICL_UNS
|
||||
#define FICL_UNS UNS32
|
||||
#endif
|
||||
|
||||
/*
|
||||
** Ficl presently supports values of 32 and 64 for BITS_PER_CELL
|
||||
*/
|
||||
#if !defined BITS_PER_CELL
|
||||
#define BITS_PER_CELL 32
|
||||
#endif
|
||||
|
||||
#if ((BITS_PER_CELL != 32) && (BITS_PER_CELL != 64))
|
||||
Error!
|
||||
#endif
|
||||
|
||||
typedef struct
|
||||
{
|
||||
UNS32 quot;
|
||||
UNS32 rem;
|
||||
FICL_UNS hi;
|
||||
FICL_UNS lo;
|
||||
} DPUNS;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
FICL_UNS quot;
|
||||
FICL_UNS rem;
|
||||
} UNSQR;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
INT32 hi;
|
||||
INT32 lo;
|
||||
} INT64;
|
||||
FICL_INT hi;
|
||||
FICL_INT lo;
|
||||
} DPINT;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
INT32 quot;
|
||||
INT32 rem;
|
||||
FICL_INT quot;
|
||||
FICL_INT rem;
|
||||
} INTQR;
|
||||
|
||||
|
||||
@ -114,6 +143,30 @@ typedef struct
|
||||
#define FICL_MULTITHREAD 0
|
||||
#endif
|
||||
|
||||
/*
|
||||
** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be
|
||||
** defined in C in sysdep.c. Use this if you cannot easily
|
||||
** generate an inline asm definition
|
||||
*/
|
||||
#if !defined (PORTABLE_LONGMULDIV)
|
||||
#define PORTABLE_LONGMULDIV 0
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
** INLINE_INNER_LOOP causes the inner interpreter to be inline code
|
||||
** instead of a function call. This is mainly because MS VC++ 5
|
||||
** chokes with an internal compiler error on the function version.
|
||||
** in release mode. Sheesh.
|
||||
*/
|
||||
#if !defined INLINE_INNER_LOOP
|
||||
#if defined _DEBUG
|
||||
#define INLINE_INNER_LOOP 0
|
||||
#else
|
||||
#define INLINE_INNER_LOOP 1
|
||||
#endif
|
||||
#endif
|
||||
|
||||
/*
|
||||
** FICL_ROBUST enables bounds checking of stacks and the dictionary.
|
||||
** This will detect stack over and underflows and dictionary overflows.
|
||||
@ -192,7 +245,7 @@ typedef struct
|
||||
** pointer address must be aligned. This value is usually
|
||||
** either 1 or 2, depending on the memory architecture
|
||||
** of the target system; 2 is safe on any 16 or 32 bit
|
||||
** machine.
|
||||
** machine. 3 would be appropriate for a 64 bit machine.
|
||||
*/
|
||||
#if !defined FICL_ALIGN
|
||||
#define FICL_ALIGN 2
|
||||
@ -215,9 +268,8 @@ typedef struct
|
||||
struct vm;
|
||||
void ficlTextOut(struct vm *pVM, char *msg, int fNewline);
|
||||
void *ficlMalloc (size_t size);
|
||||
void *ficlRealloc (void *p, size_t size);
|
||||
void ficlFree (void *p);
|
||||
|
||||
void *ficlRealloc(void *p, size_t size);
|
||||
/*
|
||||
** Stub function for dictionary access control - does nothing
|
||||
** by default, user can redefine to guarantee exclusive dict
|
||||
@ -241,12 +293,12 @@ int ficlLockDictionary(short fLock);
|
||||
|
||||
/*
|
||||
** 64 bit integer math support routines: multiply two UNS32s
|
||||
** to get a 64 bit prodict, & divide the product by an UNS32
|
||||
** to get a 64 bit product, & divide the product by an UNS32
|
||||
** to get an UNS32 quotient and remainder. Much easier in asm
|
||||
** on a 32 bit CPU than in C, which usually doesn't support
|
||||
** the double length result (but it should).
|
||||
*/
|
||||
UNS64 ficlLongMul(UNS32 x, UNS32 y);
|
||||
UNSQR ficlLongDiv(UNS64 q, UNS32 y);
|
||||
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y);
|
||||
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y);
|
||||
|
||||
#endif /*__SYSDEP_H__*/
|
||||
|
@ -3,18 +3,21 @@
|
||||
** Forth Inspired Command Language - 64 bit math support routines
|
||||
** Author: John Sadler (john_sadler@alum.mit.edu)
|
||||
** Created: 25 January 1998
|
||||
**
|
||||
** Rev 2.03: Support for 128 bit DP math. This file really ouught to
|
||||
** be renamed!
|
||||
*******************************************************************/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#include "ficl.h"
|
||||
#include "math64.h"
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 A b s
|
||||
** Returns the absolute value of an INT64
|
||||
** Returns the absolute value of an DPINT
|
||||
**************************************************************************/
|
||||
INT64 m64Abs(INT64 x)
|
||||
DPINT m64Abs(DPINT x)
|
||||
{
|
||||
if (m64IsNegative(x))
|
||||
x = m64Negate(x);
|
||||
@ -51,7 +54,7 @@ INT64 m64Abs(INT64 x)
|
||||
** 10 -7 3 -1
|
||||
** -10 -7 -3 1
|
||||
**************************************************************************/
|
||||
INTQR m64FlooredDivI(INT64 num, INT32 den)
|
||||
INTQR m64FlooredDivI(DPINT num, FICL_INT den)
|
||||
{
|
||||
INTQR qr;
|
||||
UNSQR uqr;
|
||||
@ -71,7 +74,7 @@ INTQR m64FlooredDivI(INT64 num, INT32 den)
|
||||
signQuot = -signQuot;
|
||||
}
|
||||
|
||||
uqr = ficlLongDiv(m64CastIU(num), (UNS32)den);
|
||||
uqr = ficlLongDiv(m64CastIU(num), (FICL_UNS)den);
|
||||
qr = m64CastQRUI(uqr);
|
||||
if (signQuot < 0)
|
||||
{
|
||||
@ -92,9 +95,9 @@ INTQR m64FlooredDivI(INT64 num, INT32 den)
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 I s N e g a t i v e
|
||||
** Returns TRUE if the specified INT64 has its sign bit set.
|
||||
** Returns TRUE if the specified DPINT has its sign bit set.
|
||||
**************************************************************************/
|
||||
int m64IsNegative(INT64 x)
|
||||
int m64IsNegative(DPINT x)
|
||||
{
|
||||
return (x.hi < 0);
|
||||
}
|
||||
@ -103,15 +106,15 @@ int m64IsNegative(INT64 x)
|
||||
/**************************************************************************
|
||||
m 6 4 M a c
|
||||
** Mixed precision multiply and accumulate primitive for number building.
|
||||
** Multiplies UNS64 u by UNS32 mul and adds UNS32 add. Mul is typically
|
||||
** Multiplies DPUNS u by FICL_UNS mul and adds FICL_UNS add. Mul is typically
|
||||
** the numeric base, and add represents a digit to be appended to the
|
||||
** growing number.
|
||||
** Returns the result of the operation
|
||||
**************************************************************************/
|
||||
UNS64 m64Mac(UNS64 u, UNS32 mul, UNS32 add)
|
||||
DPUNS m64Mac(DPUNS u, FICL_UNS mul, FICL_UNS add)
|
||||
{
|
||||
UNS64 resultLo = ficlLongMul(u.lo, mul);
|
||||
UNS64 resultHi = ficlLongMul(u.hi, mul);
|
||||
DPUNS resultLo = ficlLongMul(u.lo, mul);
|
||||
DPUNS resultHi = ficlLongMul(u.hi, mul);
|
||||
resultLo.hi += resultHi.lo;
|
||||
resultHi.lo = resultLo.lo + add;
|
||||
|
||||
@ -126,11 +129,11 @@ UNS64 m64Mac(UNS64 u, UNS32 mul, UNS32 add)
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 M u l I
|
||||
** Multiplies a pair of INT32s and returns an INT64 result.
|
||||
** Multiplies a pair of FICL_INTs and returns an DPINT result.
|
||||
**************************************************************************/
|
||||
INT64 m64MulI(INT32 x, INT32 y)
|
||||
DPINT m64MulI(FICL_INT x, FICL_INT y)
|
||||
{
|
||||
UNS64 prod;
|
||||
DPUNS prod;
|
||||
int sign = 1;
|
||||
|
||||
if (x < 0)
|
||||
@ -155,9 +158,9 @@ INT64 m64MulI(INT32 x, INT32 y)
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 N e g a t e
|
||||
** Negates an INT64 by complementing and incrementing.
|
||||
** Negates an DPINT by complementing and incrementing.
|
||||
**************************************************************************/
|
||||
INT64 m64Negate(INT64 x)
|
||||
DPINT m64Negate(DPINT x)
|
||||
{
|
||||
x.hi = ~x.hi;
|
||||
x.lo = ~x.lo;
|
||||
@ -171,56 +174,56 @@ INT64 m64Negate(INT64 x)
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 P u s h
|
||||
** Push an INT64 onto the specified stack in the order required
|
||||
** Push an DPINT onto the specified stack in the order required
|
||||
** by ANS Forth (most significant cell on top)
|
||||
** These should probably be macros...
|
||||
**************************************************************************/
|
||||
void i64Push(FICL_STACK *pStack, INT64 i64)
|
||||
void i64Push(FICL_STACK *pStack, DPINT i64)
|
||||
{
|
||||
stackPushINT32(pStack, i64.lo);
|
||||
stackPushINT32(pStack, i64.hi);
|
||||
stackPushINT(pStack, i64.lo);
|
||||
stackPushINT(pStack, i64.hi);
|
||||
return;
|
||||
}
|
||||
|
||||
void u64Push(FICL_STACK *pStack, UNS64 u64)
|
||||
void u64Push(FICL_STACK *pStack, DPUNS u64)
|
||||
{
|
||||
stackPushINT32(pStack, u64.lo);
|
||||
stackPushINT32(pStack, u64.hi);
|
||||
stackPushINT(pStack, u64.lo);
|
||||
stackPushINT(pStack, u64.hi);
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 P o p
|
||||
** Pops an INT64 off the stack in the order required by ANS Forth
|
||||
** Pops an DPINT off the stack in the order required by ANS Forth
|
||||
** (most significant cell on top)
|
||||
** These should probably be macros...
|
||||
**************************************************************************/
|
||||
INT64 i64Pop(FICL_STACK *pStack)
|
||||
DPINT i64Pop(FICL_STACK *pStack)
|
||||
{
|
||||
INT64 ret;
|
||||
ret.hi = stackPopINT32(pStack);
|
||||
ret.lo = stackPopINT32(pStack);
|
||||
DPINT ret;
|
||||
ret.hi = stackPopINT(pStack);
|
||||
ret.lo = stackPopINT(pStack);
|
||||
return ret;
|
||||
}
|
||||
|
||||
UNS64 u64Pop(FICL_STACK *pStack)
|
||||
DPUNS u64Pop(FICL_STACK *pStack)
|
||||
{
|
||||
UNS64 ret;
|
||||
ret.hi = stackPopINT32(pStack);
|
||||
ret.lo = stackPopINT32(pStack);
|
||||
DPUNS ret;
|
||||
ret.hi = stackPopINT(pStack);
|
||||
ret.lo = stackPopINT(pStack);
|
||||
return ret;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 S y m m e t r i c D i v
|
||||
** Divide an INT64 by an INT32 and return an INT32 quotient and an INT32
|
||||
** remainder. The absolute values of quotient and remainder are not
|
||||
** Divide an DPINT by a FICL_INT and return a FICL_INT quotient and a
|
||||
** FICL_INT remainder. The absolute values of quotient and remainder are not
|
||||
** affected by the signs of the numerator and denominator (the operation
|
||||
** is symmetric on the number line)
|
||||
**************************************************************************/
|
||||
INTQR m64SymmetricDivI(INT64 num, INT32 den)
|
||||
INTQR m64SymmetricDivI(DPINT num, FICL_INT den)
|
||||
{
|
||||
INTQR qr;
|
||||
UNSQR uqr;
|
||||
@ -240,7 +243,7 @@ INTQR m64SymmetricDivI(INT64 num, INT32 den)
|
||||
signQuot = -signQuot;
|
||||
}
|
||||
|
||||
uqr = ficlLongDiv(m64CastIU(num), (UNS32)den);
|
||||
uqr = ficlLongDiv(m64CastIU(num), (FICL_UNS)den);
|
||||
qr = m64CastQRUI(uqr);
|
||||
if (signRem < 0)
|
||||
qr.rem = -qr.rem;
|
||||
@ -254,39 +257,51 @@ INTQR m64SymmetricDivI(INT64 num, INT32 den)
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 U M o d
|
||||
** Divides an UNS64 by base (an UNS16) and returns an UNS16 remainder.
|
||||
** Writes the quotient back to the original UNS64 as a side effect.
|
||||
** This operation is typically used to convert an UNS64 to a text string
|
||||
** Divides a DPUNS by base (an UNS16) and returns an UNS16 remainder.
|
||||
** Writes the quotient back to the original DPUNS as a side effect.
|
||||
** This operation is typically used to convert an DPUNS to a text string
|
||||
** in any base. See words.c:numberSignS, for example.
|
||||
** Mechanics: performs 4 ficlLongDivs, each of which produces 16 bits
|
||||
** of the quotient. C does not provide a way to divide an UNS32 by an
|
||||
** UNS16 and get an UNS32 quotient (ldiv is closest, but it's signed,
|
||||
** of the quotient. C does not provide a way to divide an FICL_UNS by an
|
||||
** UNS16 and get an FICL_UNS quotient (ldiv is closest, but it's signed,
|
||||
** unfortunately), so I've used ficlLongDiv.
|
||||
**************************************************************************/
|
||||
UNS16 m64UMod(UNS64 *pUD, UNS16 base)
|
||||
#if (BITS_PER_CELL == 32)
|
||||
|
||||
#define UMOD_SHIFT 16
|
||||
#define UMOD_MASK 0x0000ffff
|
||||
|
||||
#elif (BITS_PER_CELL == 64)
|
||||
|
||||
#define UMOD_SHIFT 32
|
||||
#define UMOD_MASK 0x00000000ffffffff
|
||||
|
||||
#endif
|
||||
|
||||
UNS16 m64UMod(DPUNS *pUD, UNS16 base)
|
||||
{
|
||||
UNS64 ud;
|
||||
DPUNS ud;
|
||||
UNSQR qr;
|
||||
UNS64 result;
|
||||
DPUNS result;
|
||||
|
||||
result.hi = result.lo = 0;
|
||||
|
||||
ud.hi = 0;
|
||||
ud.lo = pUD->hi >> 16;
|
||||
qr = ficlLongDiv(ud, (UNS32)base);
|
||||
result.hi = qr.quot << 16;
|
||||
ud.lo = pUD->hi >> UMOD_SHIFT;
|
||||
qr = ficlLongDiv(ud, (FICL_UNS)base);
|
||||
result.hi = qr.quot << UMOD_SHIFT;
|
||||
|
||||
ud.lo = (qr.rem << 16) | (pUD->hi & 0x0000ffff);
|
||||
qr = ficlLongDiv(ud, (UNS32)base);
|
||||
result.hi |= qr.quot & 0x0000ffff;
|
||||
ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->hi & UMOD_MASK);
|
||||
qr = ficlLongDiv(ud, (FICL_UNS)base);
|
||||
result.hi |= qr.quot & UMOD_MASK;
|
||||
|
||||
ud.lo = (qr.rem << 16) | (pUD->lo >> 16);
|
||||
qr = ficlLongDiv(ud, (UNS32)base);
|
||||
result.lo = qr.quot << 16;
|
||||
ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->lo >> UMOD_SHIFT);
|
||||
qr = ficlLongDiv(ud, (FICL_UNS)base);
|
||||
result.lo = qr.quot << UMOD_SHIFT;
|
||||
|
||||
ud.lo = (qr.rem << 16) | (pUD->lo & 0x0000ffff);
|
||||
qr = ficlLongDiv(ud, (UNS32)base);
|
||||
result.lo |= qr.quot & 0x0000ffff;
|
||||
ud.lo = (qr.rem << UMOD_SHIFT) | (pUD->lo & UMOD_MASK);
|
||||
qr = ficlLongDiv(ud, (FICL_UNS)base);
|
||||
result.lo |= qr.quot & UMOD_MASK;
|
||||
|
||||
*pUD = result;
|
||||
|
||||
@ -294,3 +309,218 @@ UNS16 m64UMod(UNS64 *pUD, UNS16 base)
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
** Contributed by
|
||||
** Michael A. Gauland gaulandm@mdhost.cse.tek.com
|
||||
**************************************************************************/
|
||||
#if PORTABLE_LONGMULDIV != 0
|
||||
/**************************************************************************
|
||||
m 6 4 A d d
|
||||
**
|
||||
**************************************************************************/
|
||||
DPUNS m64Add(DPUNS x, DPUNS y)
|
||||
{
|
||||
DPUNS result;
|
||||
int carry;
|
||||
|
||||
result.hi = x.hi + y.hi;
|
||||
result.lo = x.lo + y.lo;
|
||||
|
||||
|
||||
carry = ((x.lo | y.lo) & CELL_HI_BIT) && !(result.lo & CELL_HI_BIT);
|
||||
carry |= ((x.lo & y.lo) & CELL_HI_BIT);
|
||||
|
||||
if (carry)
|
||||
{
|
||||
result.hi++;
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 S u b
|
||||
**
|
||||
**************************************************************************/
|
||||
DPUNS m64Sub(DPUNS x, DPUNS y)
|
||||
{
|
||||
DPUNS result;
|
||||
|
||||
result.hi = x.hi - y.hi;
|
||||
result.lo = x.lo - y.lo;
|
||||
|
||||
if (x.lo < y.lo)
|
||||
{
|
||||
result.hi--;
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 A S L
|
||||
** 64 bit left shift
|
||||
**************************************************************************/
|
||||
DPUNS m64ASL( DPUNS x )
|
||||
{
|
||||
DPUNS result;
|
||||
|
||||
result.hi = x.hi << 1;
|
||||
if (x.lo & CELL_HI_BIT)
|
||||
{
|
||||
result.hi++;
|
||||
}
|
||||
|
||||
result.lo = x.lo << 1;
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 A S R
|
||||
** 64 bit right shift (unsigned - no sign extend)
|
||||
**************************************************************************/
|
||||
DPUNS m64ASR( DPUNS x )
|
||||
{
|
||||
DPUNS result;
|
||||
|
||||
result.lo = x.lo >> 1;
|
||||
if (x.hi & 1)
|
||||
{
|
||||
result.lo |= CELL_HI_BIT;
|
||||
}
|
||||
|
||||
result.hi = x.hi >> 1;
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 O r
|
||||
** 64 bit bitwise OR
|
||||
**************************************************************************/
|
||||
DPUNS m64Or( DPUNS x, DPUNS y )
|
||||
{
|
||||
DPUNS result;
|
||||
|
||||
result.hi = x.hi | y.hi;
|
||||
result.lo = x.lo | y.lo;
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
m 6 4 C o m p a r e
|
||||
** Return -1 if x < y; 0 if x==y, and 1 if x > y.
|
||||
**************************************************************************/
|
||||
int m64Compare(DPUNS x, DPUNS y)
|
||||
{
|
||||
int result;
|
||||
|
||||
if (x.hi > y.hi)
|
||||
{
|
||||
result = +1;
|
||||
}
|
||||
else if (x.hi < y.hi)
|
||||
{
|
||||
result = -1;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* High parts are equal */
|
||||
if (x.lo > y.lo)
|
||||
{
|
||||
result = +1;
|
||||
}
|
||||
else if (x.lo < y.lo)
|
||||
{
|
||||
result = -1;
|
||||
}
|
||||
else
|
||||
{
|
||||
result = 0;
|
||||
}
|
||||
}
|
||||
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
f i c l L o n g M u l
|
||||
** Portable versions of ficlLongMul and ficlLongDiv in C
|
||||
** Contributed by:
|
||||
** Michael A. Gauland gaulandm@mdhost.cse.tek.com
|
||||
**************************************************************************/
|
||||
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
|
||||
{
|
||||
DPUNS result = { 0, 0 };
|
||||
DPUNS addend;
|
||||
|
||||
addend.lo = y;
|
||||
addend.hi = 0; /* No sign extension--arguments are unsigned */
|
||||
|
||||
while (x != 0)
|
||||
{
|
||||
if ( x & 1)
|
||||
{
|
||||
result = m64Add(result, addend);
|
||||
}
|
||||
x >>= 1;
|
||||
addend = m64ASL(addend);
|
||||
}
|
||||
return result;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
f i c l L o n g D i v
|
||||
** Portable versions of ficlLongMul and ficlLongDiv in C
|
||||
** Contributed by:
|
||||
** Michael A. Gauland gaulandm@mdhost.cse.tek.com
|
||||
**************************************************************************/
|
||||
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
|
||||
{
|
||||
UNSQR result;
|
||||
DPUNS quotient;
|
||||
DPUNS subtrahend;
|
||||
DPUNS mask;
|
||||
|
||||
quotient.lo = 0;
|
||||
quotient.hi = 0;
|
||||
|
||||
subtrahend.lo = y;
|
||||
subtrahend.hi = 0;
|
||||
|
||||
mask.lo = 1;
|
||||
mask.hi = 0;
|
||||
|
||||
while ((m64Compare(subtrahend, q) < 0) &&
|
||||
(subtrahend.hi & CELL_HI_BIT) == 0)
|
||||
{
|
||||
mask = m64ASL(mask);
|
||||
subtrahend = m64ASL(subtrahend);
|
||||
}
|
||||
|
||||
while (mask.lo != 0 || mask.hi != 0)
|
||||
{
|
||||
if (m64Compare(subtrahend, q) <= 0)
|
||||
{
|
||||
q = m64Sub( q, subtrahend);
|
||||
quotient = m64Or(quotient, mask);
|
||||
}
|
||||
mask = m64ASR(mask);
|
||||
subtrahend = m64ASR(subtrahend);
|
||||
}
|
||||
|
||||
result.quot = quotient.lo;
|
||||
result.rem = q.lo;
|
||||
return result;
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
|
@ -24,8 +24,14 @@
|
||||
** a problem, a success story, a defect, an enhancement request, or
|
||||
** if you would like to contribute to the ficl release (yay!), please
|
||||
** send me email at the address above.
|
||||
**
|
||||
** NOTE: this file depends on sysdep.h for the definition
|
||||
** of PORTABLE_LONGMULDIV and several abstract types.
|
||||
**
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#if !defined (__MATH64_H__)
|
||||
#define __MATH64_H__
|
||||
|
||||
@ -33,25 +39,37 @@
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
INT64 m64Abs(INT64 x);
|
||||
int m64IsNegative(INT64 x);
|
||||
UNS64 m64Mac(UNS64 u, UNS32 mul, UNS32 add);
|
||||
INT64 m64MulI(INT32 x, INT32 y);
|
||||
INT64 m64Negate(INT64 x);
|
||||
INTQR m64FlooredDivI(INT64 num, INT32 den);
|
||||
void i64Push(FICL_STACK *pStack, INT64 i64);
|
||||
INT64 i64Pop(FICL_STACK *pStack);
|
||||
void u64Push(FICL_STACK *pStack, UNS64 u64);
|
||||
UNS64 u64Pop(FICL_STACK *pStack);
|
||||
INTQR m64SymmetricDivI(INT64 num, INT32 den);
|
||||
UNS16 m64UMod(UNS64 *pUD, UNS16 base);
|
||||
DPINT m64Abs(DPINT x);
|
||||
int m64IsNegative(DPINT x);
|
||||
DPUNS m64Mac(DPUNS u, FICL_UNS mul, FICL_UNS add);
|
||||
DPINT m64MulI(FICL_INT x, FICL_INT y);
|
||||
DPINT m64Negate(DPINT x);
|
||||
INTQR m64FlooredDivI(DPINT num, FICL_INT den);
|
||||
void i64Push(FICL_STACK *pStack, DPINT i64);
|
||||
DPINT i64Pop(FICL_STACK *pStack);
|
||||
void u64Push(FICL_STACK *pStack, DPUNS u64);
|
||||
DPUNS u64Pop(FICL_STACK *pStack);
|
||||
INTQR m64SymmetricDivI(DPINT num, FICL_INT den);
|
||||
UNS16 m64UMod(DPUNS *pUD, UNS16 base);
|
||||
|
||||
|
||||
#if PORTABLE_LONGMULDIV != 0 /* see sysdep.h */
|
||||
DPUNS m64Add(DPUNS x, DPUNS y);
|
||||
DPUNS m64ASL( DPUNS x );
|
||||
DPUNS m64ASR( DPUNS x );
|
||||
int m64Compare(DPUNS x, DPUNS y);
|
||||
DPUNS m64Or( DPUNS x, DPUNS y );
|
||||
DPUNS m64Sub(DPUNS x, DPUNS y);
|
||||
#endif
|
||||
|
||||
#define i64Extend(i64) (i64).hi = ((i64).lo < 0) ? -1L : 0
|
||||
#define m64CastIU(i64) (*(UNS64 *)(&(i64)))
|
||||
#define m64CastUI(u64) (*(INT64 *)(&(u64)))
|
||||
#define m64CastIU(i64) (*(DPUNS *)(&(i64)))
|
||||
#define m64CastUI(u64) (*(DPINT *)(&(u64)))
|
||||
#define m64CastQRIU(iqr) (*(UNSQR *)(&(iqr)))
|
||||
#define m64CastQRUI(uqr) (*(INTQR *)(&(uqr)))
|
||||
|
||||
#define CELL_HI_BIT (1L << (BITS_PER_CELL-1))
|
||||
|
||||
#ifdef __cplusplus
|
||||
}
|
||||
#endif
|
||||
|
49
sys/boot/ficl/softwords/ficllocal.fr
Normal file
49
sys/boot/ficl/softwords/ficllocal.fr
Normal file
@ -0,0 +1,49 @@
|
||||
\ ** ficl/softwords/ficllocal.fr
|
||||
\ ** stack comment style local syntax...
|
||||
\ {{ a b c -- d e }}
|
||||
\ variables before the "--" are initialized in reverse order
|
||||
\ from the stack. Those after the "--" are zero initialized
|
||||
\ Uses locals...
|
||||
\ locstate: 0 = looking for -- or }}
|
||||
\ 1 = found --
|
||||
\
|
||||
\ $FreeBSD$
|
||||
|
||||
hide
|
||||
0 constant zero
|
||||
|
||||
: ?-- s" --" compare 0= ;
|
||||
: ?}} s" }}" compare 0= ;
|
||||
|
||||
set-current
|
||||
|
||||
: {{
|
||||
0 dup locals| nLocs locstate |
|
||||
begin
|
||||
parse-word
|
||||
?dup 0= abort" Error: out of text without seeing }}"
|
||||
2dup 2dup ?-- -rot ?}} or 0=
|
||||
while
|
||||
nLocs 1+ to nLocs
|
||||
repeat
|
||||
|
||||
?-- if 1 to locstate endif
|
||||
|
||||
nLocs 0 do
|
||||
(local)
|
||||
loop
|
||||
|
||||
locstate 1 = if
|
||||
begin
|
||||
parse-word
|
||||
2dup ?}} 0=
|
||||
while
|
||||
postpone zero (local)
|
||||
repeat
|
||||
2drop
|
||||
endif
|
||||
|
||||
0 0 (local)
|
||||
; immediate compile-only
|
||||
|
||||
previous
|
56
sys/boot/ficl/softwords/ifbrack.fr
Normal file
56
sys/boot/ficl/softwords/ifbrack.fr
Normal file
@ -0,0 +1,56 @@
|
||||
\ ** ficl/softwords/ifbrack.fr
|
||||
\ ** ANS conditional compile directives [if] [else] [then]
|
||||
\ ** Requires ficl 2.0 or greater...
|
||||
|
||||
\ $FreeBSD$
|
||||
|
||||
hidden dup >search ficl-set-current
|
||||
|
||||
: ?[if] ( c-addr u -- c-addr u flag )
|
||||
2dup 2dup
|
||||
s" [if]" compare 0= >r
|
||||
s" [IF]" compare 0= r>
|
||||
or
|
||||
;
|
||||
|
||||
: ?[else] ( c-addr u -- c-addr u flag )
|
||||
2dup 2dup
|
||||
s" [else]" compare 0= >r
|
||||
s" [ELSE]" compare 0= r>
|
||||
or
|
||||
;
|
||||
|
||||
: ?[then] ( c-addr u -- c-addr u flag )
|
||||
2dup 2dup
|
||||
s" [then]" compare 0= >r
|
||||
s" [THEN]" compare 0= r>
|
||||
or
|
||||
;
|
||||
|
||||
set-current
|
||||
|
||||
: [else] ( -- )
|
||||
1 \ ( level )
|
||||
begin
|
||||
begin
|
||||
parse-word dup while \ ( level addr len )
|
||||
?[if] if \ ( level addr len )
|
||||
2drop 1+ \ ( level )
|
||||
else \ ( level addr len )
|
||||
?[else] if \ ( level addr len )
|
||||
2drop 1- dup if 1+ endif
|
||||
else
|
||||
?[then] if 2drop 1- else 2drop endif
|
||||
endif
|
||||
endif ?dup 0= if exit endif \ level
|
||||
repeat 2drop \ level
|
||||
refill 0= until \ level
|
||||
drop
|
||||
; immediate
|
||||
|
||||
: [if] ( flag -- )
|
||||
0= if postpone [else] then ; immediate
|
||||
|
||||
: [then] ( -- ) ; immediate
|
||||
|
||||
previous
|
@ -3,6 +3,8 @@
|
||||
\ ** John Sadler (john_sadler@alum.mit.edu)
|
||||
\ ** September, 1998
|
||||
|
||||
\ $FreeBSD$
|
||||
|
||||
\ ** Ficl USER variables
|
||||
\ ** See words.c for primitive def'n of USER
|
||||
\ #if FICL_WANT_USER
|
||||
@ -49,6 +51,8 @@ decimal 32 constant bl
|
||||
: erase ( addr u -- ) 0 fill ;
|
||||
: nip ( y x -- x ) swap drop ;
|
||||
: tuck ( y x -- x y x) swap over ;
|
||||
: within ( test low high -- flag ) over - >r - r> u< ;
|
||||
|
||||
|
||||
\ ** LOCAL EXT word set
|
||||
\ #if FICL_WANT_LOCALS
|
||||
@ -78,38 +82,6 @@ decimal 32 constant bl
|
||||
loop drop
|
||||
;
|
||||
|
||||
\ ** Some TOOLS EXT words, straight from the standard
|
||||
: [else] ( -- )
|
||||
1 begin \ level
|
||||
begin
|
||||
bl word count dup while \ level adr len
|
||||
2dup s" [IF]" compare 0= >r
|
||||
2dup s" [if]" compare 0= r> or
|
||||
if \ level adr len
|
||||
2drop 1+ \ level'
|
||||
else \ level adr len
|
||||
2dup s" [ELSE]" compare 0= >r
|
||||
2dup s" [else]" compare 0= r> or
|
||||
if \ level adr len
|
||||
2drop 1- dup if 1+ then \ level'
|
||||
else \ level adr len
|
||||
2dup
|
||||
s" [THEN]" compare 0= >r \ level adr len
|
||||
s" [then]" compare 0= r> or
|
||||
if \ level
|
||||
1- \ level'
|
||||
then
|
||||
then
|
||||
then ?dup 0= if exit then \ level'
|
||||
repeat 2drop \ level
|
||||
refill 0= until \ level
|
||||
drop
|
||||
; immediate
|
||||
|
||||
: [if] ( flag -- )
|
||||
0= if postpone [else] then ; immediate
|
||||
|
||||
: [then] ( -- ) ; immediate
|
||||
\ ** SEARCH+EXT words and ficl helpers
|
||||
\
|
||||
: wordlist ( -- )
|
||||
|
@ -6,6 +6,8 @@
|
||||
**
|
||||
*******************************************************************/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#ifdef TESTMAIN
|
||||
#include <stdlib.h>
|
||||
#else
|
||||
@ -200,12 +202,12 @@ void *stackPopPtr(FICL_STACK *pStack)
|
||||
return (*--pStack->sp).p;
|
||||
}
|
||||
|
||||
UNS32 stackPopUNS32(FICL_STACK *pStack)
|
||||
FICL_UNS stackPopUNS(FICL_STACK *pStack)
|
||||
{
|
||||
return (*--pStack->sp).u;
|
||||
}
|
||||
|
||||
INT32 stackPopINT32(FICL_STACK *pStack)
|
||||
FICL_INT stackPopINT(FICL_STACK *pStack)
|
||||
{
|
||||
return (*--pStack->sp).i;
|
||||
}
|
||||
@ -226,12 +228,12 @@ void stackPushPtr(FICL_STACK *pStack, void *ptr)
|
||||
*pStack->sp++ = LVALUEtoCELL(ptr);
|
||||
}
|
||||
|
||||
void stackPushUNS32(FICL_STACK *pStack, UNS32 u)
|
||||
void stackPushUNS(FICL_STACK *pStack, FICL_UNS u)
|
||||
{
|
||||
*pStack->sp++ = LVALUEtoCELL(u);
|
||||
}
|
||||
|
||||
void stackPushINT32(FICL_STACK *pStack, INT32 i)
|
||||
void stackPushINT(FICL_STACK *pStack, FICL_INT i)
|
||||
{
|
||||
*pStack->sp++ = LVALUEtoCELL(i);
|
||||
}
|
||||
|
@ -7,6 +7,8 @@
|
||||
**
|
||||
*******************************************************************/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#ifdef TESTMAIN
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
@ -22,9 +24,10 @@
|
||||
******************* FreeBSD P O R T B E G I N S H E R E ******************** Michael Smith
|
||||
*/
|
||||
|
||||
UNS64 ficlLongMul(UNS32 x, UNS32 y)
|
||||
#if PORTABLE_LONGMULDIV == 0
|
||||
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y)
|
||||
{
|
||||
UNS64 q;
|
||||
DPUNS q;
|
||||
u_int64_t qx;
|
||||
|
||||
qx = (u_int64_t)x * (u_int64_t) y;
|
||||
@ -35,7 +38,7 @@ UNS64 ficlLongMul(UNS32 x, UNS32 y)
|
||||
return q;
|
||||
}
|
||||
|
||||
UNSQR ficlLongDiv(UNS64 q, UNS32 y)
|
||||
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y)
|
||||
{
|
||||
UNSQR result;
|
||||
u_int64_t qx, qh;
|
||||
@ -48,6 +51,7 @@ UNSQR ficlLongDiv(UNS64 q, UNS32 y)
|
||||
|
||||
return result;
|
||||
}
|
||||
#endif
|
||||
|
||||
void ficlTextOut(FICL_VM *pVM, char *msg, int fNewline)
|
||||
{
|
||||
@ -88,8 +92,8 @@ ficlOutb(FICL_VM *pVM)
|
||||
u_char c;
|
||||
u_int32_t port;
|
||||
|
||||
port=stackPopUNS32(pVM->pStack);
|
||||
c=(u_char)stackPopINT32(pVM->pStack);
|
||||
port=stackPopUNS(pVM->pStack);
|
||||
c=(u_char)stackPopINT(pVM->pStack);
|
||||
outb(port,c);
|
||||
}
|
||||
|
||||
@ -103,9 +107,9 @@ ficlInb(FICL_VM *pVM)
|
||||
u_char c;
|
||||
u_int32_t port;
|
||||
|
||||
port=stackPopUNS32(pVM->pStack);
|
||||
port=stackPopUNS(pVM->pStack);
|
||||
c=inb(port);
|
||||
stackPushINT32(pVM->pStack,c);
|
||||
stackPushINT(pVM->pStack,c);
|
||||
}
|
||||
#endif
|
||||
#endif
|
||||
|
@ -32,6 +32,8 @@
|
||||
** send me email at the address above.
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#if !defined (__SYSDEP_H__)
|
||||
#define __SYSDEP_H__
|
||||
|
||||
@ -60,48 +62,75 @@
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
** System dependent data type declarations...
|
||||
*/
|
||||
#if !defined INT32
|
||||
#define INT32 int32_t
|
||||
#define INT32 long
|
||||
#endif
|
||||
|
||||
#if !defined UNS32
|
||||
#define UNS32 u_int32_t
|
||||
#define UNS32 unsigned long
|
||||
#endif
|
||||
|
||||
#if !defined UNS16
|
||||
#define UNS16 u_int16_t
|
||||
#define UNS16 unsigned short
|
||||
#endif
|
||||
|
||||
#if !defined UNS8
|
||||
#define UNS8 u_int8_t
|
||||
#define UNS8 unsigned char
|
||||
#endif
|
||||
|
||||
#if !defined NULL
|
||||
#define NULL ((void *)0)
|
||||
#endif
|
||||
|
||||
typedef struct
|
||||
{
|
||||
UNS32 hi;
|
||||
UNS32 lo;
|
||||
} UNS64;
|
||||
/*
|
||||
** FICL_UNS and FICL_INT must have the same size as a void* on
|
||||
** the target system. A CELL is a union of void*, FICL_UNS, and
|
||||
** FICL_INT.
|
||||
*/
|
||||
#if !defined FICL_INT
|
||||
#define FICL_INT INT32
|
||||
#endif
|
||||
|
||||
#if !defined FICL_UNS
|
||||
#define FICL_UNS UNS32
|
||||
#endif
|
||||
|
||||
/*
|
||||
** Ficl presently supports values of 32 and 64 for BITS_PER_CELL
|
||||
*/
|
||||
#if !defined BITS_PER_CELL
|
||||
#define BITS_PER_CELL 32
|
||||
#endif
|
||||
|
||||
#if ((BITS_PER_CELL != 32) && (BITS_PER_CELL != 64))
|
||||
Error!
|
||||
#endif
|
||||
|
||||
typedef struct
|
||||
{
|
||||
UNS32 quot;
|
||||
UNS32 rem;
|
||||
FICL_UNS hi;
|
||||
FICL_UNS lo;
|
||||
} DPUNS;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
FICL_UNS quot;
|
||||
FICL_UNS rem;
|
||||
} UNSQR;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
INT32 hi;
|
||||
INT32 lo;
|
||||
} INT64;
|
||||
FICL_INT hi;
|
||||
FICL_INT lo;
|
||||
} DPINT;
|
||||
|
||||
typedef struct
|
||||
{
|
||||
INT32 quot;
|
||||
INT32 rem;
|
||||
FICL_INT quot;
|
||||
FICL_INT rem;
|
||||
} INTQR;
|
||||
|
||||
|
||||
@ -114,6 +143,30 @@ typedef struct
|
||||
#define FICL_MULTITHREAD 0
|
||||
#endif
|
||||
|
||||
/*
|
||||
** PORTABLE_LONGMULDIV causes ficlLongMul and ficlLongDiv to be
|
||||
** defined in C in sysdep.c. Use this if you cannot easily
|
||||
** generate an inline asm definition
|
||||
*/
|
||||
#if !defined (PORTABLE_LONGMULDIV)
|
||||
#define PORTABLE_LONGMULDIV 0
|
||||
#endif
|
||||
|
||||
|
||||
/*
|
||||
** INLINE_INNER_LOOP causes the inner interpreter to be inline code
|
||||
** instead of a function call. This is mainly because MS VC++ 5
|
||||
** chokes with an internal compiler error on the function version.
|
||||
** in release mode. Sheesh.
|
||||
*/
|
||||
#if !defined INLINE_INNER_LOOP
|
||||
#if defined _DEBUG
|
||||
#define INLINE_INNER_LOOP 0
|
||||
#else
|
||||
#define INLINE_INNER_LOOP 1
|
||||
#endif
|
||||
#endif
|
||||
|
||||
/*
|
||||
** FICL_ROBUST enables bounds checking of stacks and the dictionary.
|
||||
** This will detect stack over and underflows and dictionary overflows.
|
||||
@ -192,7 +245,7 @@ typedef struct
|
||||
** pointer address must be aligned. This value is usually
|
||||
** either 1 or 2, depending on the memory architecture
|
||||
** of the target system; 2 is safe on any 16 or 32 bit
|
||||
** machine.
|
||||
** machine. 3 would be appropriate for a 64 bit machine.
|
||||
*/
|
||||
#if !defined FICL_ALIGN
|
||||
#define FICL_ALIGN 2
|
||||
@ -215,9 +268,8 @@ typedef struct
|
||||
struct vm;
|
||||
void ficlTextOut(struct vm *pVM, char *msg, int fNewline);
|
||||
void *ficlMalloc (size_t size);
|
||||
void *ficlRealloc (void *p, size_t size);
|
||||
void ficlFree (void *p);
|
||||
|
||||
void *ficlRealloc(void *p, size_t size);
|
||||
/*
|
||||
** Stub function for dictionary access control - does nothing
|
||||
** by default, user can redefine to guarantee exclusive dict
|
||||
@ -241,12 +293,12 @@ int ficlLockDictionary(short fLock);
|
||||
|
||||
/*
|
||||
** 64 bit integer math support routines: multiply two UNS32s
|
||||
** to get a 64 bit prodict, & divide the product by an UNS32
|
||||
** to get a 64 bit product, & divide the product by an UNS32
|
||||
** to get an UNS32 quotient and remainder. Much easier in asm
|
||||
** on a 32 bit CPU than in C, which usually doesn't support
|
||||
** the double length result (but it should).
|
||||
*/
|
||||
UNS64 ficlLongMul(UNS32 x, UNS32 y);
|
||||
UNSQR ficlLongDiv(UNS64 q, UNS32 y);
|
||||
DPUNS ficlLongMul(FICL_UNS x, FICL_UNS y);
|
||||
UNSQR ficlLongDiv(DPUNS q, FICL_UNS y);
|
||||
|
||||
#endif /*__SYSDEP_H__*/
|
||||
|
@ -3,9 +3,12 @@
|
||||
**
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
#include <time.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
#include <unistd.h>
|
||||
@ -144,7 +147,7 @@ static void ficlLoad(FICL_VM *pVM)
|
||||
if (len <= 0)
|
||||
continue;
|
||||
|
||||
result = ficlExec(pVM, cp, len);
|
||||
result = ficlExecC(pVM, cp, len);
|
||||
if (result != VM_QUIT && result != VM_USEREXIT && result != VM_OUTOFTEXT )
|
||||
{
|
||||
pVM->sourceID = id;
|
||||
@ -154,7 +157,7 @@ static void ficlLoad(FICL_VM *pVM)
|
||||
}
|
||||
}
|
||||
/*
|
||||
** Pass an empty line with SOURCE-ID == 0 to flush
|
||||
** Pass an empty line with SOURCE-ID == -1 to flush
|
||||
** any pending REFILLs (as required by FILE wordset)
|
||||
*/
|
||||
pVM->sourceID.i = -1;
|
||||
@ -221,14 +224,46 @@ static void ficlBreak(FICL_VM *pVM)
|
||||
return;
|
||||
}
|
||||
|
||||
static void ficlClock(FICL_VM *pVM)
|
||||
{
|
||||
clock_t now = clock();
|
||||
stackPushUNS(pVM->pStack, (UNS32)now);
|
||||
return;
|
||||
}
|
||||
|
||||
static void clocksPerSec(FICL_VM *pVM)
|
||||
{
|
||||
stackPushUNS(pVM->pStack, CLOCKS_PER_SEC);
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
static void execxt(FICL_VM *pVM)
|
||||
{
|
||||
FICL_WORD *pFW;
|
||||
#if FICL_ROBUST > 1
|
||||
vmCheckStack(pVM, 1, 0);
|
||||
#endif
|
||||
|
||||
pFW = stackPopPtr(pVM->pStack);
|
||||
ficlExecXT(pVM, pFW);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
void buildTestInterface(void)
|
||||
{
|
||||
ficlBuild("break", ficlBreak, FW_DEFAULT);
|
||||
ficlBuild("clock", ficlClock, FW_DEFAULT);
|
||||
ficlBuild("cd", ficlChDir, FW_DEFAULT);
|
||||
ficlBuild("execxt", execxt, FW_DEFAULT);
|
||||
ficlBuild("load", ficlLoad, FW_DEFAULT);
|
||||
ficlBuild("pwd", ficlGetCWD, FW_DEFAULT);
|
||||
ficlBuild("system", ficlSystem, FW_DEFAULT);
|
||||
ficlBuild("spewhash", spewHash, FW_DEFAULT);
|
||||
ficlBuild("clocks/sec",
|
||||
clocksPerSec, FW_DEFAULT);
|
||||
|
||||
return;
|
||||
}
|
||||
@ -236,7 +271,7 @@ void buildTestInterface(void)
|
||||
|
||||
int main(int argc, char **argv)
|
||||
{
|
||||
char in[256];
|
||||
char in[nINBUF];
|
||||
FICL_VM *pVM;
|
||||
|
||||
ficlInitSystem(10000);
|
||||
|
@ -1,4 +1,4 @@
|
||||
/*******************************************************************
|
||||
/*******************************************************************
|
||||
** v m . c
|
||||
** Forth Inspired Command Language - virtual machine methods
|
||||
** Author: John Sadler (john_sadler@alum.mit.edu)
|
||||
@ -13,6 +13,8 @@
|
||||
** of the interp.
|
||||
*/
|
||||
|
||||
/* $FreeBSD$ */
|
||||
|
||||
#ifdef TESTMAIN
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
@ -47,11 +49,9 @@ FICL_VM *vmCreate(FICL_VM *pVM, unsigned nPStack, unsigned nRStack)
|
||||
if (pVM == NULL)
|
||||
{
|
||||
pVM = (FICL_VM *)ficlMalloc(sizeof (FICL_VM));
|
||||
pVM->pStack = NULL;
|
||||
pVM->rStack = NULL;
|
||||
pVM->link = NULL;
|
||||
assert (pVM);
|
||||
memset(pVM, 0, sizeof (FICL_VM));
|
||||
}
|
||||
assert (pVM);
|
||||
|
||||
if (pVM->pStack)
|
||||
stackDelete(pVM->pStack);
|
||||
@ -87,7 +87,10 @@ void vmDelete (FICL_VM *pVM)
|
||||
|
||||
/**************************************************************************
|
||||
v m E x e c u t e
|
||||
**
|
||||
** Sets up the specified word to be run by the inner interpreter.
|
||||
** Executes the word's code part immediately, but in the case of
|
||||
** colon definition, the definition itself needs the inner interp
|
||||
** to complete. This does not happen until control reaches ficlExec
|
||||
**************************************************************************/
|
||||
void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
|
||||
{
|
||||
@ -97,6 +100,24 @@ void vmExecute(FICL_VM *pVM, FICL_WORD *pWord)
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
v m I n n e r L o o p
|
||||
** the mysterious inner interpreter...
|
||||
** This loop is the address interpreter that makes colon definitions
|
||||
** work. Upon entry, it assumes that the IP points to an entry in
|
||||
** a definition (the body of a colon word). It runs one word at a time
|
||||
** until something does vmThrow. The catcher for this is expected to exist
|
||||
** in the calling code.
|
||||
** vmThrow gets you out of this loop with a longjmp()
|
||||
** Visual C++ 5 chokes on this loop in Release mode. Aargh.
|
||||
**************************************************************************/
|
||||
#if INLINE_INNER_LOOP == 0
|
||||
void vmInnerLoop(FICL_VM *pVM)
|
||||
{
|
||||
M_INNER_LOOP(pVM);
|
||||
}
|
||||
#endif
|
||||
|
||||
/**************************************************************************
|
||||
v m G e t S t r i n g
|
||||
** Parses a string out of the VM input buffer and copies up to the first
|
||||
@ -151,22 +172,23 @@ STRINGINFO vmGetWord(FICL_VM *pVM)
|
||||
**************************************************************************/
|
||||
STRINGINFO vmGetWord0(FICL_VM *pVM)
|
||||
{
|
||||
char *pSrc = vmGetInBuf(pVM);
|
||||
char *pSrc = vmGetInBuf(pVM);
|
||||
char *pEnd = vmGetInBufEnd(pVM);
|
||||
STRINGINFO si;
|
||||
UNS32 count = 0;
|
||||
char ch;
|
||||
|
||||
pSrc = skipSpace(pSrc,pVM->tib.end);
|
||||
pSrc = skipSpace(pSrc, pEnd);
|
||||
SI_SETPTR(si, pSrc);
|
||||
|
||||
for (ch = *pSrc; (pVM->tib.end != pSrc) && (ch != '\0') && !isspace(ch); ch = *++pSrc)
|
||||
for (ch = *pSrc; (pEnd != pSrc) && !isspace(ch); ch = *++pSrc)
|
||||
{
|
||||
count++;
|
||||
}
|
||||
|
||||
SI_SETLEN(si, count);
|
||||
|
||||
if ((pVM->tib.end != pSrc) && isspace(ch)) /* skip one trailing delimiter */
|
||||
if ((pEnd != pSrc) && isspace(ch)) /* skip one trailing delimiter */
|
||||
pSrc++;
|
||||
|
||||
vmUpdateTib(pVM, pSrc);
|
||||
@ -210,16 +232,16 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim)
|
||||
{
|
||||
STRINGINFO si;
|
||||
char *pSrc = vmGetInBuf(pVM);
|
||||
char ch;
|
||||
char *pEnd = vmGetInBufEnd(pVM);
|
||||
char ch;
|
||||
|
||||
while ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* skip lead delimiters */
|
||||
while ((pSrc != pEnd) && (*pSrc == delim)) /* skip lead delimiters */
|
||||
pSrc++;
|
||||
|
||||
SI_SETPTR(si, pSrc); /* mark start of text */
|
||||
|
||||
for (ch = *pSrc; (pVM->tib.end != pSrc)
|
||||
&& (ch != delim)
|
||||
&& (ch != '\0')
|
||||
for (ch = *pSrc; (pSrc != pEnd)
|
||||
&& (ch != delim)
|
||||
&& (ch != '\r')
|
||||
&& (ch != '\n'); ch = *++pSrc)
|
||||
{
|
||||
@ -229,7 +251,7 @@ STRINGINFO vmParseString(FICL_VM *pVM, char delim)
|
||||
/* set length of result */
|
||||
SI_SETLEN(si, pSrc - SI_PTR(si));
|
||||
|
||||
if ((pVM->tib.end != pSrc) && (*pSrc == delim)) /* gobble trailing delimiter */
|
||||
if ((pSrc != pEnd) && (*pSrc == delim)) /* gobble trailing delimiter */
|
||||
pSrc++;
|
||||
|
||||
vmUpdateTib(pVM, pSrc);
|
||||
@ -264,7 +286,7 @@ void vmPushIP(FICL_VM *pVM, IPTYPE newIP)
|
||||
v m P u s h T i b
|
||||
** Binds the specified input string to the VM and clears >IN (the index)
|
||||
**************************************************************************/
|
||||
void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib)
|
||||
void vmPushTib(FICL_VM *pVM, char *text, FICL_INT nChars, TIB *pSaveTib)
|
||||
{
|
||||
if (pSaveTib)
|
||||
{
|
||||
@ -272,7 +294,7 @@ void vmPushTib(FICL_VM *pVM, char *text, INT32 size, TIB *pSaveTib)
|
||||
}
|
||||
|
||||
pVM->tib.cp = text;
|
||||
pVM->tib.end = text + size;
|
||||
pVM->tib.end = text + nChars;
|
||||
pVM->tib.index = 0;
|
||||
}
|
||||
|
||||
@ -361,7 +383,8 @@ void vmTextOut(FICL_VM *pVM, char *text, int fNewline)
|
||||
**************************************************************************/
|
||||
void vmThrow(FICL_VM *pVM, int except)
|
||||
{
|
||||
longjmp(*(pVM->pState), except);
|
||||
if (pVM->pState)
|
||||
longjmp(*(pVM->pState), except);
|
||||
}
|
||||
|
||||
|
||||
@ -432,33 +455,66 @@ char digit_to_char(int value)
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
i s P o w e r O f T w o
|
||||
** Tests whether supplied argument is an integer power of 2 (2**n)
|
||||
** where 32 > n > 1, and returns n if so. Otherwise returns zero.
|
||||
**************************************************************************/
|
||||
int isPowerOfTwo(FICL_UNS u)
|
||||
{
|
||||
int i = 1;
|
||||
FICL_UNS t = 2;
|
||||
|
||||
for (; ((t <= u) && (t != 0)); i++, t <<= 1)
|
||||
{
|
||||
if (u == t)
|
||||
return i;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/**************************************************************************
|
||||
l t o a
|
||||
**
|
||||
**************************************************************************/
|
||||
char *ltoa( INT32 value, char *string, int radix )
|
||||
char *ltoa( FICL_INT value, char *string, int radix )
|
||||
{ /* convert long to string, any base */
|
||||
char *cp = string;
|
||||
int sign = ((radix == 10) && (value < 0));
|
||||
UNSQR result;
|
||||
UNS64 v;
|
||||
int pwr;
|
||||
|
||||
assert(radix > 1);
|
||||
assert(radix < 37);
|
||||
assert(string);
|
||||
|
||||
pwr = isPowerOfTwo((FICL_UNS)radix);
|
||||
|
||||
if (sign)
|
||||
value = -value;
|
||||
|
||||
if (value == 0)
|
||||
*cp++ = '0';
|
||||
else if (pwr != 0)
|
||||
{
|
||||
FICL_UNS v = (FICL_UNS) value;
|
||||
FICL_UNS mask = (FICL_UNS) ~(-1 << pwr);
|
||||
while (v)
|
||||
{
|
||||
*cp++ = digits[v & mask];
|
||||
v >>= pwr;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
UNSQR result;
|
||||
DPUNS v;
|
||||
v.hi = 0;
|
||||
v.lo = (UNS32)value;
|
||||
v.lo = (FICL_UNS)value;
|
||||
while (v.lo)
|
||||
{
|
||||
result = ficlLongDiv(v, (UNS32)radix);
|
||||
result = ficlLongDiv(v, (FICL_UNS)radix);
|
||||
*cp++ = digits[result.rem];
|
||||
v.lo = result.quot;
|
||||
}
|
||||
@ -477,10 +533,10 @@ char *ltoa( INT32 value, char *string, int radix )
|
||||
u l t o a
|
||||
**
|
||||
**************************************************************************/
|
||||
char *ultoa(UNS32 value, char *string, int radix )
|
||||
char *ultoa(FICL_UNS value, char *string, int radix )
|
||||
{ /* convert long to string, any base */
|
||||
char *cp = string;
|
||||
UNS64 ud;
|
||||
DPUNS ud;
|
||||
UNSQR result;
|
||||
|
||||
assert(radix > 1);
|
||||
@ -554,8 +610,8 @@ int strincmp(char *cp1, char *cp2, FICL_COUNT count)
|
||||
s k i p S p a c e
|
||||
** Given a string pointer, returns a pointer to the first non-space
|
||||
** char of the string, or to the NULL terminator if no such char found.
|
||||
** If the pointer reaches "end" first, stop there. If you don't want
|
||||
** that, pass NULL.
|
||||
** If the pointer reaches "end" first, stop there. Pass NULL to
|
||||
** suppress this behavior.
|
||||
**************************************************************************/
|
||||
char *skipSpace(char *cp, char *end)
|
||||
{
|
||||
|
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user