jimzah/freebsd-src
1
0
Fork 0
mirror of https://github.com/freebsd/freebsd-src.git synced 2024-11-29 17:32:43 +00:00
Code Issues Actions 2 Packages Projects Releases Wiki Activity

Bring in ficl version 2.03. No version bump for loader.

Browse Source
This commit is contained in:
Daniel C. Sobral 1999-09-29 04:43:16 +00:00
parent 0212898e1c
commit de271252c9
Notes: svn2git 2020-12-20 02:59:44 +00:00 
svn path=/head/; revision=51786
21 changed files with 1503 additions and 833 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
sys/boot/common/interp.c
View File

@ -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

18
sys/boot/common/interp_forth.c
View File

@ -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);

3
sys/boot/ficl/Makefile
View File

@ -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

18
sys/boot/ficl/alpha/sysdep.c
View File

@ -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

96
sys/boot/ficl/alpha/sysdep.h
View File

@ -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__*/

5
sys/boot/ficl/dict.c
View File

@ -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;

233
sys/boot/ficl/ficl.c
View File

@ -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.

110
sys/boot/ficl/ficl.h
View File

@ -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.

18
sys/boot/ficl/i386/sysdep.c
View File

@ -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

96
sys/boot/ficl/i386/sysdep.h
View File

@ -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__*/

342
sys/boot/ficl/math64.c
View File

@ -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

46
sys/boot/ficl/math64.h
View File

@ -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
View 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
View 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

36
sys/boot/ficl/softwords/softcore.fr
View File

@ -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 ( -- )

10
sys/boot/ficl/stack.c
View File

@ -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);
}

18
sys/boot/ficl/sysdep.c
View File

@ -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

96
sys/boot/ficl/sysdep.h
View File

@ -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__*/

41
sys/boot/ficl/testmain.c
View File

@ -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);

112
sys/boot/ficl/vm.c
View File

@ -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)
{

931
sys/boot/ficl/words.c
View File

File diff suppressed because it is too large Load Diff