sambuc/retrobsd
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Import from SVN

Browse Source
This commit is contained in:
Matt Jenkins
2014-04-09 14:27:18 +01:00
parent 8976e834c4
commit 895f96d2f7
3153 changed files with 748589 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
src/cmd/forth/Makefile Normal file
View File

@@ -0,0 +1,30 @@
TOPSRC = $(shell cd ../../..; pwd)
include $(TOPSRC)/target.mk
#include $(TOPSRC)/cross.mk
CFLAGS += -Werror -Wall
LIBS += -lm -lc
OBJS = forth.o func.o
all: forth
forth: ${OBJS}
${CC} ${LDFLAGS} -o forth.elf ${OBJS} ${LIBS}
${OBJDUMP} -S forth.elf > forth.dis
${SIZE} forth.elf
${ELF2AOUT} forth.elf $@ && rm forth.elf
clean:
rm -f *.o *.elf forth *.dis *~
func.txt: func.c
grep '^ \*+' func.c | expand | sed 's/^ \*+ *$$//' |\
sed 's/^ \*+ //' > func.txt
install: all
install forth $(DESTDIR)/bin/
###
forth.o: forth.c io.h forth.h
func.o: func.c io.h forth.h

23
src/cmd/forth/fact.fth Normal file
View File

@@ -0,0 +1,23 @@
\ Iterative factorial function.
." Defining fact function ... "
: fact ( n -- n! )
dup 2 < if drop 1 else
dup begin 1- swap over * swap dup 1 = until
drop then
; ." done." cr
." 1! = " 1 fact . cr
." 2! = " 2 fact . cr
." 3! = " 3 fact . cr
." 4! = " 4 fact . cr
." 5! = " 5 fact . cr
." 6! = " 6 fact . cr
." 7! = " 7 fact . cr
." 8! = " 8 fact . cr
." 9! = " 9 fact . cr
." 10! = " 10 fact . cr
." 11! = " 11 fact . cr
." 12! = " 12 fact . cr
halt

800
src/cmd/forth/forth.c Normal file
View File

@@ -0,0 +1,800 @@
/*
* Portable Forth interpreter.
* Copyright (C) 1990-2012 Serge Vakulenko, <serge@vak.ru>
*
* Permission to use, copy, modify, and distribute this software
* and its documentation for any purpose and without fee is hereby
* granted, provided that the above copyright notice appear in all
* copies and that both that the copyright notice and this
* permission notice and warranty disclaimer appear in supporting
* documentation, and that the name of the author not be used in
* advertising or publicity pertaining to distribution of the
* software without specific, written prior permission.
*
* The author disclaim all warranties with regard to this
* software, including all implied warranties of merchantability
* and fitness. In no event shall the author be liable for any
* special, indirect or consequential damages or any damages
* whatsoever resulting from loss of use, data or profits, whether
* in an action of contract, negligence or other tortious action,
* arising out of or in connection with the use or performance of
* this software.
*/
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <stdarg.h>
#include "io.h"
#include "forth.h"
#define OKPROMPT "Ok\n> "
#define ERRPROMPT "> "
#define COMPILEPROMPT ": "
value_t defbuf [DEFSZ];
value_t *defptr;
value_t *execstack [NESTSZ];
value_t *execptr;
int execcnt;
struct loop loopstack [LOOPSZ];
struct loop *loopptr;
union memory memory;
integer_t here = 0;
integer_t lowmem;
integer_t stack [STACKSZ];
integer_t *stackptr;
jmp_buf errjmp;
ident_t dict [DICTSZ];
ident_t *dictptr;
ident_t *lowdictptr;
int outstack [OUTSZ];
int outptr;
int instack [INSZ];
int inptr;
integer_t compindex;
integer_t baseindex;
integer_t spanindex;
integer_t hldindex;
int tty;
int debug;
int boln;
int errorflag;
value_t _x;
void forthresume (int clrflag)
{
errorflag = 1;
if (clrflag)
stackptr = stack;
longjmp (errjmp, 1);
}
void error (char *fmt, ...)
{
va_list ap;
va_start (ap, fmt);
vprintf (fmt, ap);
va_end (ap);
printf ("\n");
forthresume (1);
}
void usage ()
{
printf ("Usage: forth [-d] [files...]\n");
exit (1);
}
void initdict ()
{
struct table *t;
ident_t *w;
dictptr = dict;
for (t=func_table; t->name; ++t, ++dictptr) {
strncpy (dictptr->name, t->name, NAMESZ);
dictptr->name [NAMESZ-1] = 0;
dictptr->type = t->type;
dictptr->val.p = t->func;
dictptr->immed = t->immed;
}
w = enter ("bl");
++dictptr;
w->type = FGENINT;
w->val.i = ' ';
w = enter ("pad");
++dictptr;
w->type = FGENINT;
w->val.i = pad;
lowmem = here;
compindex = alloc ((integer_t) 1);
w = enter ("state");
++dictptr;
w->type = FGENINT;
w->val.i = compindex;
baseindex = alloc ((integer_t) 1);
w = enter ("base");
++dictptr;
w->type = FGENINT;
w->val.i = baseindex;
spanindex = alloc ((integer_t) 1);
w = enter ("span");
++dictptr;
w->type = FGENINT;
w->val.i = spanindex;
hldindex = alloc ((integer_t) 1);
w = enter ("hld");
++dictptr;
w->type = FGENINT;
w->val.i = hldindex;
lowdictptr = dictptr;
}
void scompile (ident_t *w)
{
(defptr++)->i = w->type;
switch (w->type) {
case FGENINT:
case FGENFLT:
case FSUBR:
case FHARDWARE:
*defptr++ = w->val;
break;
}
}
void sexecute (ident_t *w)
{
if (w >= dictptr)
error ("bad execute");
switch (w->type) {
case FGENINT:
push (w->val.i);
break;
case FGENFLT:
fpush (w->val.r);
break;
case FSUBR:
execute (w->val.v);
break;
case FHARDWARE:
(*w->val.p) ();
break;
default:
error ("%s ?", w->name);
}
}
int valsize (value_t *a)
{
switch (a->i) {
default: return (1);
case FGENINT:
case FGENFLT:
case FSUBR:
case FHARDWARE: return (2);
case FSTRING:
case FCSTRING:
case FQUOTE: return (3 + a[1].i / sizeof (value_t));
}
}
void run ()
{
int count;
integer_t c;
char *p;
while (execptr) {
switch ((execptr++)->i) {
case FGENINT:
push ((execptr++)->i);
continue;
case FGENFLT:
fpush ((execptr++)->r);
continue;
case FSUBR:
execute ((execptr++)->v);
continue;
case FHARDWARE:
(*(execptr++)->p) ();
continue;
case FSTRING:
case FCSTRING:
c = (execptr++)->i;
p = (char*) execptr++;
execptr += c / sizeof (value_t);
for (; *p; ++p)
putc (*p, stdout);
break;
case FQUOTE:
c = (execptr++)->i;
p = (char*) execptr++;
execptr += c / sizeof (value_t);
push (c = here);
while (*p)
STOREBYTE (c++, *p++);
STOREBYTE (c, 0);
break;
case FCONDIF:
if (pop ())
continue;
for (count=0; execptr->i; execptr+=valsize(execptr))
if (execptr->i == FCONDIF)
++count;
else if (execptr->i == FCONDTHEN) {
if (--count < 0) {
++execptr;
break;
}
} else if (execptr->i == FCONDELSE)
if (count <= 0) {
++execptr;
break;
}
continue;
case FCONDELSE:
for (count=0; execptr->i; execptr+=valsize(execptr))
if (execptr->i == FCONDIF)
++count;
else if (execptr->i == FCONDTHEN)
if (--count < 0) {
++execptr;
break;
}
continue;
case FUNTIL:
if (loopptr <= loopstack)
error ("until but no begin");
if (loopptr[-1].type != FBEGIN)
error ("bad until");
if (pop ()) {
--loopptr;
continue;
}
execptr = loopptr[-1].ptr;
continue;
case FREPEAT:
if (loopptr <= loopstack)
error ("repeat but no begin");
if (loopptr[-1].type != FBEGIN)
error ("bad repeat");
execptr = loopptr[-1].ptr;
continue;
case FWHILE:
if (pop ())
continue;
for (count=0; execptr->i; execptr+=valsize(execptr))
if (execptr->i == FBEGIN)
++count;
else if (execptr->i==FUNTIL || execptr->i==FREPEAT)
if (--count < 0) {
++execptr;
break;
}
continue;
case FLEAVE:
if (loopptr <= loopstack)
error ("bad leave");
leave: for (count=0; execptr->i; execptr+=valsize (execptr))
if (execptr->i==FBEGIN || execptr->i==FDO || execptr->i==FIFDO)
++count;
else if (execptr->i==FUNTIL || execptr->i==FREPEAT ||
execptr->i==FLOOP || execptr->i==FPLOOP)
if (--count < 0) {
++execptr;
break;
}
--loopptr;
continue;
case FDO:
if (loopptr >= loopstack+LOOPSZ)
error ("too deep do nesting");
loopptr->cnt = loopptr->low = pop ();
loopptr->up = pop ();
loopptr->type = FDO;
loopptr->ptr = execptr;
++loopptr;
continue;
case FIFDO:
if (loopptr >= loopstack+LOOPSZ)
error ("too deep ?do nesting");
loopptr->cnt = loopptr->low = pop ();
loopptr->up = pop ();
loopptr->type = FIFDO;
loopptr->ptr = execptr;
++loopptr;
if (loopptr[-1].low == loopptr[-1].up)
goto leave;
continue;
case FLOOP:
if (loopptr <= loopstack)
error ("bad loop");
if (loopptr[-1].type != FDO && loopptr[-1].type != FIFDO)
error ("invalid loop");
++loopptr[-1].cnt;
if (loopptr[-1].cnt >= loopptr[-1].up) {
--loopptr;
continue;
}
execptr = loopptr[-1].ptr;
continue;
case FPLOOP:
if (loopptr <= loopstack)
error ("bad +loop");
if (loopptr[-1].type != FDO && loopptr[-1].type != FIFDO)
error ("invalid loop");
c = pop ();
if ((c>0 && loopptr[-1].cnt<loopptr[-1].up &&
loopptr[-1].cnt+c>=loopptr[-1].up) ||
(c<0 && loopptr[-1].cnt>=loopptr[-1].up &&
loopptr[-1].cnt+c<loopptr[-1].up))
{
--loopptr;
continue;
}
loopptr[-1].cnt += c;
execptr = loopptr[-1].ptr;
continue;
case FCOUNTI:
if (loopptr <= loopstack)
error ("bad i");
push (loopptr[-1].cnt);
continue;
case FCOUNTJ:
if (loopptr <= loopstack+1)
error ("bad j");
push (loopptr[-2].cnt);
continue;
case FCOUNTK:
if (loopptr <= loopstack+2)
error ("bad k");
push (loopptr[-3].cnt);
continue;
case FBEGIN:
if (loopptr >= loopstack+LOOPSZ)
error ("too deep begin nesting");
loopptr->type = FBEGIN;
loopptr->ptr = execptr;
++loopptr;
continue;
case FCONDTHEN:
continue;
case FEXIT:
case 0:
doexit: --execcnt;
if (execcnt < 0)
return;
execptr = execstack [execcnt];
continue;
}
}
goto doexit;
}
int symdigit (int c)
{
c &= 0377;
switch (base) {
case BINARY:
switch (c) {
case '0': return (0);
case '1': return (1);
}
return (-1);
case OCTAL:
switch (c) {
case '0': case '1': case '2': case '3': case '4': case '5':
case '6': case '7':
return (c - '0');
}
return (-1);
case DECIMAL:
switch (c) {
case '0': case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9':
return (c - '0');
}
return (-1);
case HEX:
switch (c) {
case '0': case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9':
return (c - '0');
}
switch (c) {
case 'a': case 'A': return (10);
case 'b': case 'B': return (11);
case 'c': case 'C': return (12);
case 'd': case 'D': return (13);
case 'e': case 'E': return (14);
case 'f': case 'F': return (15);
}
return (-1);
}
return (-1);
}
int integ (char *s, integer_t *i)
{
integer_t c;
int neg, d;
neg = (*s == '-');
if (neg)
++s;
if (! *s)
return (0);
c = 0;
while ((d = symdigit (*s)) >= 0) {
c = c*base + d;
++s;
}
if (*s)
return (0);
*i = neg ? -c : c;
return (1);
}
int realnum (char *s, real_t *r)
{
int d, e;
int neg = 0, eneg = 0, ep = 0;
real_t v;
if (*s == '-') {
neg = 1;
++s;
}
if (! *s)
return (0);
v = 0;
while ((d = symdigit (*s)) >= 0) {
v = v*base + d;
++s;
}
if (*s=='.' || *s==',') {
++s;
while ((d = symdigit (*s)) >= 0) {
v = v*base + d;
++s;
++ep;
}
}
if (neg)
v = -v;
e = 0;
if (*s=='e' || *s=='E') {
++s;
if (*s == '-') {
eneg = 1;
++s;
}
while ((d = symdigit (*s)) >= 0) {
e = e*base + d;
++s;
}
}
if (*s)
return (0);
if (eneg)
e = -e;
e -= ep;
if (e < 0) {
while (++e <= 0)
v /= base;
} else {
while (--e >= 0)
v *= base;
}
*r = v;
return (1);
}
void forth ()
{
char *p;
ident_t *w;
integer_t i;
real_t r;
tty = isatty (fileno (stdin));
boln = 1;
compilation = 0;
base = DECIMAL;
errorflag = 0;
stackptr = stack;
setjmp (errjmp);
loopptr = loopstack;
defptr = defbuf;
execcnt = -1;
if (inptr) {
while (--inptr > 0)
close (instack [inptr]);
fclose (stdin);
fdopen (instack [0], "r");
}
if (outptr) {
while (--outptr > 0)
close (outstack [inptr]);
fclose (stdout);
fdopen (outstack [0], "a");
}
for (;;) {
if (! (p = getword (' ', 1)))
return;
errorflag = 0;
w = find (p);
if (w) {
if (compilation && ! w->immed) {
scompile (w);
continue;
}
sexecute (w);
if (execcnt >= 0)
run ();
continue;
}
if (integ (p, &i)) {
if (compilation) {
(defptr++)->i = FGENINT;
(defptr++)->i = i;
continue;
}
push (i);
continue;
}
if (realnum (p, &r)) {
if (compilation) {
(defptr++)->i = FGENFLT;
(defptr++)->r = r;
continue;
}
fpush (r);
continue;
}
error ("%s ?", p);
}
}
int main (int argc, char **argv)
{
int fdin;
printf ("Portable Forth, Version 1.4\n");
printf ("Copyright (C) 1990-2012 Serge Vakulenko\n\n");
for (++argv, --argc; argc>0 && **argv=='-'; ++argv, --argc) {
if (! strcmp ("-d", *argv))
++debug;
else
usage ();
}
initdict ();
fdin = dup (fileno (stdin));
for (; argc>0; ++argv, --argc) {
if (strcmp ("-", *argv) == 0) {
fclose (stdin);
fdopen (dup (fdin), "r");
} else {
FILE *fd = fopen (*argv, "r");
if (! fd) {
fprintf (stderr, "Cannot open %s\n", *argv);
exit (1);
}
fclose (stdin);
fdopen (dup (fileno (fd)), "r");
fclose (fd);
}
forth ();
}
fclose (stdin);
fdopen (dup (fdin), "r");
close (fdin);
forth ();
return (0);
}
char *getword (int delim, int contflag)
{
static char buf [256];
char *p;
int c;
if (! contflag && boln)
return (0);
p = buf;
for (;;) {
if (boln) {
if (tty)
printf (errorflag ? ERRPROMPT : compilation ?
COMPILEPROMPT : OKPROMPT);
boln = 0;
}
switch (c = getc (stdin)) {
case -1:
*p = 0;
if (p <= buf) {
if (inptr <= 0)
return (0);
fclose (stdin);
fdopen (dup (instack [--inptr]), "r");
close (instack [inptr]);
tty = isatty (fileno (stdin));
boln = 1;
continue;
}
return (buf);
case '\n':
boln = 1;
goto seedelim;
case 0:
c = delim;
goto seedelim;
case '\t':
c = ' ';
default:
if (c == delim) {
seedelim: *p = 0;
if (contflag && p<=buf)
continue;
return (buf);
}
if (p < buf+sizeof(buf)-1)
*p++ = c;
break;
}
}
}
int stackerr (int i)
{
error (i ? "stack overflow" : "stack empty");
return (0);
}
integer_t alloc (integer_t n)
{
integer_t p;
here = (here + sizeof (value_t) - 1) / sizeof (value_t) * sizeof (value_t);
n *= sizeof (value_t);
if (here+n > MEMSZ)
error ("memory overflow");
p = here;
here += n;
return (p);
}
integer_t allot (integer_t n)
{
integer_t p;
if (here+n > MEMSZ)
error ("memory overflow");
p = here;
here += n;
return (p);
}
void execute (value_t *a)
{
if (execcnt >= 0) {
if (execcnt >= NESTSZ)
error ("too deep recursion");
execstack [execcnt++] = execptr;
execptr = a;
} else {
execptr = a;
execcnt = 0;
}
}
ident_t *find (char *name)
{
ident_t *w;
for (w=dictptr-1; w>=dict; --w)
if (name[0]==w->name[0] && !strcmp (name, w->name))
return (w);
return (0);
}
ident_t *enter (char *name)
{
ident_t *w;
if (dictptr >= dict+DICTSZ)
error ("dictionary overflow");
w = dictptr;
strncpy (w->name, name, NAMESZ);
w->name [NAMESZ-1] = 0;
w->type = 0;
w->immed = 0;
return (w);
}
char *funcname (funcptr_t p, int type)
{
ident_t *w;
for (w=dictptr-1; w>=dict; --w)
if (type==w->type && p==w->val.p)
return (w->name);
return ("???");
}
void decompile (value_t *a)
{
char *p;
int c;
for (; a->i; ++a) {
switch (a->i) {
case FSUBR:
printf ("%s ", funcname ((++a)->p, FSUBR));
continue;
case FHARDWARE:
printf ("%s ", funcname ((++a)->p, FHARDWARE));
continue;
case FQUOTE:
printf ("\" ");
goto decompstring;
case FCSTRING:
printf (".( ");
c = (++a)->i;
p = (char*) ++a;
for (; *p; ++p)
putc (*p, stdout);
a += c / sizeof (value_t);
printf (") ");
continue;
case FSTRING:
printf (".\" ");
decompstring: c = (++a)->i;
p = (char*) ++a;
for (; *p; ++p)
putc (*p, stdout);
a += c / sizeof (value_t);
printf ("\" ");
continue;
case FGENINT: printf ("%ld ", (++a)->i); continue;
case FGENFLT: printf ("%g ", (double) (++a)->r); continue;
case FCONDIF: printf ("if "); continue;
case FCONDELSE: printf ("else "); continue;
case FUNTIL: printf ("until "); continue;
case FREPEAT: printf ("repeat "); continue;
case FWHILE: printf ("while "); continue;
case FLEAVE: printf ("leave "); continue;
case FDO: printf ("do "); continue;
case FIFDO: printf ("?do "); continue;
case FLOOP: printf ("loop "); continue;
case FPLOOP: printf ("+loop "); continue;
case FCOUNTI: printf ("i "); continue;
case FCOUNTJ: printf ("j "); continue;
case FCOUNTK: printf ("k "); continue;
case FBEGIN: printf ("begin "); continue;
case FCONDTHEN: printf ("then "); continue;
case FEXIT: printf ("exit "); continue;
default: printf ("?%ld ", a->i); continue;
}
}
}

195
src/cmd/forth/forth.h Normal file
View File

@@ -0,0 +1,195 @@
/*
* Portable Forth interpreter.
* Copyright (C) 1990-2012 Serge Vakulenko, <vak@cronyx.ru>
*
* Permission to use, copy, modify, and distribute this software
* and its documentation for any purpose and without fee is hereby
* granted, provided that the above copyright notice appear in all
* copies and that both that the copyright notice and this
* permission notice and warranty disclaimer appear in supporting
* documentation, and that the name of the author not be used in
* advertising or publicity pertaining to distribution of the
* software without specific, written prior permission.
*
* The author disclaim all warranties with regard to this
* software, including all implied warranties of merchantability
* and fitness. In no event shall the author be liable for any
* special, indirect or consequential damages or any damages
* whatsoever resulting from loss of use, data or profits, whether
* in an action of contract, negligence or other tortious action,
* arising out of or in connection with the use or performance of
* this software.
*/
#include <setjmp.h>
#define MEMSZ 4096 /* max size of allot'ated memory */
#define DEFSZ 512 /* max size of compiled function */
#define STACKSZ 256 /* max size of data stack */
#define NAMESZ 32 /* max length of ident name */
#define DICTSZ 256 /* max size of dictionary */
#define NESTSZ 512 /* max depth of function calls nesting */
#define LOOPSZ 32 /* max loop nesting */
#define OUTSZ 8 /* max output file nesting */
#define INSZ 8 /* max input file nesting */
/* types of idents */
#define FGENINT 1 /* constant */
#define FGENFLT 2 /* float constant */
#define FSUBR 3 /* compiled function */
#define FHARDWARE 4 /* builtin function */
#define FSTRING 5 /* ." */
#define FCSTRING 6 /* .( */
#define FQUOTE 7 /* " */
#define FCQUOTE 8 /* ascii */
/* */
#define FREPEAT 10 /* repeat */
#define FDO 11 /* do */
#define FLOOP 12 /* loop */
#define FPLOOP 13 /* +loop */
#define FCONDIF 14 /* if */
#define FCONDELSE 15 /* else */
#define FCONDTHEN 16 /* then */
#define FBEGIN 17 /* begin */
#define FUNTIL 18 /* until */
#define FWHILE 19 /* while */
#define FCOUNTI 20 /* i */
#define FCOUNTJ 21 /* j */
#define FCOUNTK 22 /* k */
#define FLEAVE 23 /* leave */
#define FIFDO 24 /* ?do */
#define FEXIT 25 /* exit */
#define FETCHWORD(a) (memory.v [(a) / sizeof(value_t)])
#define STOREWORD(a,w) (memory.v [(a) / sizeof(value_t)] = (w))
#define FETCHBYTE(a) ((int) (unsigned char) memory.c [a])
#define STOREBYTE(a,w) (memory.c [a] = (w))
#define compilation FETCHWORD (compindex).i
#define base FETCHWORD (baseindex).i
#define span FETCHWORD (spanindex).i
#define hld FETCHWORD (hldindex).i
#define pad (MEMSZ-1)
#define push(i) ((stackptr < stack+STACKSZ) ? \
*stackptr++ = (i) : stackerr (1))
#define fpush(f) ((stackptr < stack+STACKSZ) ? \
*stackptr++ = ftoi (f) : stackerr (1))
#define pop() ((stackptr > stack) ? *--stackptr : \
(integer_t) stackerr (0))
#define fpop() ((stackptr > stack) ? itof (*--stackptr) : \
(real_t) stackerr (0))
/*
* Size of integer_t must be equal to size of real_t.
* All known machines have longs and floats of the same size,
* so we will use these types.
*/
typedef long integer_t;
typedef unsigned long uinteger_t;
typedef float real_t;
typedef void (*funcptr_t) (void);
typedef union value {
integer_t i;
real_t r;
union value *v;
funcptr_t p;
} value_t;
typedef struct ident {
int type;
int immed;
value_t val;
char name [NAMESZ];
} ident_t;
struct table {
char *name;
funcptr_t func;
int type;
int immed;
};
struct loop {
int type;
integer_t cnt;
integer_t low;
integer_t up;
value_t *ptr;
};
union memory {
char c [MEMSZ];
value_t v [MEMSZ / sizeof(value_t)];
};
enum {
BINARY = 2,
OCTAL = 8,
DECIMAL = 10,
HEX = 16,
};
static inline integer_t ftoi (real_t z)
{
value_t x;
x.r = z;
return x.i;
}
static inline real_t itof (integer_t z)
{
value_t x;
x.i = z;
return x.r;
}
static inline value_t itov (integer_t z)
{
value_t x;
x.i = z;
return x;
}
extern ident_t dict [];
extern ident_t *dictptr;
extern ident_t *lowdictptr;
extern jmp_buf errjmp;
extern value_t defbuf [];
extern value_t *defptr;
extern union memory memory;
extern integer_t here;
extern integer_t lowmem;
extern integer_t stack [];
extern integer_t *stackptr;
extern struct table func_table [];
extern integer_t compindex;
extern integer_t baseindex;
extern integer_t spanindex;
extern integer_t hldindex;
extern int outstack [];
extern int outptr;
extern int instack [];
extern int inptr;
extern int tty;
extern int boln;
extern value_t *execptr;
extern int execcnt;
extern void error (char *fmt, ...);
extern ident_t *find (char *name);
extern ident_t *enter (char *name);
extern char *getword (int delim, int contflag);
extern integer_t allot (integer_t n);
extern integer_t alloc (integer_t n);
extern void sexecute (ident_t *w);
extern void execute (value_t *a);
extern int stackerr (int i);
extern void forthresume (int clrflag);
extern void decompile (value_t *a);

2001
src/cmd/forth/func.c Normal file
View File

File diff suppressed because it is too large Load Diff

302
src/cmd/forth/func.txt Normal file
View File

@@ -0,0 +1,302 @@
Portable Forth interpreter.
Copyright (C) 1990-2012 Serge Vakulenko, <serge@vak.ru>
(
Start a comment which is ended by a ")" or newline.
\
Start a comment to end of line.
dup ( x -- x x )
Duplicate the top item.
?dup ( x -- x x )
Duplicate the top item if nonzero.
2dup ( x y -- x y x y )
Duplicate the top two words.
drop ( x -- )
Drop the top of stack.
2drop ( x y -- )
Drop the top two items from the stack.
over ( x y -- x y x )
Copy second to top
2over ( x y z w -- x y z w x y )
Copy second to top
rot ( x y z -- y z x )
Move the third element to the top.
2rot ( x x y y z z -- y y z z x x )
Move the third element to the top.
-rot ( y z x -- x y z )
Move the top element to the third.
swap ( x y -- y x )
Exchange the top two items.
2swap ( w x y z -- y z w x )
Swap the top two words with the second-to-the-top two words.
pick ( an, an-1, a0, n -- an, an-1, a0, an )
Get the "n"th word on the opstack (zero-based, starting
from the word below "n") to the top of stack.
roll ( an, an-1, a0, n -- an-1, a0, an )
Roll n words on the opstack (zero-based, starting
from the word below "n").
sempty
Empty data stack.
/, f/, *, f*, -, f-, +, f+ ( x y -- d )
Return the result of the applied binary operation to the
two arguments. Dividing by zero is undefined.
mod ( x y -- r )
Return the remainder of x/y. This is explicitly calculated
as x-int(x/y)*x.
/mod ( x y -- r d )
Return x/y and the remainder of x/y.
abs, fabs ( x -- |x| )
Change sign of top of stack if it's negative
negate, fnegate ( x -- -x )
Replace top of stack with its negation.
1+, 1-, 2+, 2-, 2*, 2/ ( x -- op(x) )
Perform unary op.
* / ( x y z -- w )
Return x*y/z.
* /mod ( x y z -- r w )
Return x*y%z, x*y/z.
true, false ( -- b )
Push the boolean true and false values onto the stack. These
values are used uniformly by all of forth.
or, and, xor, not
Bitwise OR and AND operations. These will work with "true"
and "false" to provide logical functionality.
=, f= ( x y -- b )
Return whether x is equal to y.
>, f> ( x y -- b )
Return whether x is greater than y.
<, f< ( x y -- b )
Return whether x is less than y.
u< ( x y -- b )
Return whether unsigned x is less than unsigned y.
max, fmax ( x y -- max(x,y) )
Take the greater of the top two elements
min, fmin (x y -- min(x,y) )
Take the lesser of the top two elements
i->f ( i -- f )
Convert the integer_t "i" to the equivalent floating format "f".
f->i ( f -- i )
Convert the floating number "f" to the equivalent integer_t "i".
Integer portions of "f" will be truncated; for details, refer to the
"cvtfl" instruction in the VAX architecture handbook.
f. ( f -- )
Print the floating-point number.
. ( i -- )
Print the integer_t.
.s ( -- )
Print the stack.
halt
Exit back to OS.
quit
Start interpreting from the keyboard again,
don't clean the data stack.
:
Start compilation mode for the next word in the stream.
;
End compilation mode, unsmudge the entry.
immediate
Set 'immediate' mode for last compiled word
constant
fconstant
Like variable, but later references to this word return the
numerical constant. Thus
42 constant ascii_star
ascii_star emit
will print a star to the current output device.
variable
Take the next word and add it to the dictionary
as a variable. Subsequent references to this name
will return an address which is the word allocated
to this variable. Uses such as
variable foobar 400 allot
will make "foobar" return the address of a 404-byte array
(the initially allocated longword, 4 bytes, plus
the allot'ed 400 bytes).
create
Take the next word and add it to the dictionary
as a variable. Subsequent references to this name
will return current value of 'here'.
forget
Take the next word and forget all words, defined later
than given one. Depth is limited by 'freezedict'.
empty
Forget all words, defined after 'freezedict'.
freezedict
Update low margin of dictionary.
All words, defined up to moment, would not be
destroyed by 'forget'.
here ( -- a )
Push the address of the next open memory location in the
dictionary to stack.
allot ( d -- )
Add "d" to HERE, effectively moving the bottom of the dictionary
forward "d" bytes.
alloc ( d -- )
Alloc d words.
align ( -- )
Align 'here' on word boundary.
@ ( a -- x )
Fetch a word at address "a".
! ( x a -- )
Store a word at address "a".
c@ ( a -- d)
Fetch the byte quantity "d" from byte address "a".
c! ( d a -- )
Store the byte quantity "d" at byte address "a".
fill ( a n d -- )
Fill "n" bytes of memory starting at "a" with the value "d".
type ( a n -- )
Type string on stdout.
expect ( a n -- )
Read string from stdin.
, ( d -- )
Move the word "d" into the next open dictionary word,
advancing HERE.
c, ( d -- )
As ",", but only a byte operation is done.
allwords
List all user defined words.
words
List words, defined after 'freezedict'.
list
Take the next word in the input stream as a name of word.
If this word is user defined, print it's definition.
fsqrt ( f -- s )
Compute square root of f, both f and s are float.
flog ( f -- s )
Compute logarithm of f.
fexp ( f -- s )
Compute e to the f power.
sin ( i -- s )
"i" is a degree measure; "s" is sin(i)*10000.
fsin ( f -- s )
"f" is the radian measure; "s" is the sin() value.
cos, fcos
As sin, fsin, but for cos() values.
tan, ftan
As sin, fsin, but for tan() values.
fasin ( s -- f )
Compute asin(s) in radians (float).
Return value is in range -pi/2..pi/2.
facos
As fasin, but for acos() values.
Return value is in range 0..pi.
fatan
As fasin, but for atan() values.
Return value is in range -pi/2..pi/2.
fsinh ( f -- s )
Compute hyperbolic sine function.
fcosh
As fsinh, but for cosh() values.
ftanh
As fsinh, but for tanh() values.
key ( -- c )
Read character from input stream.
All characters codes are non-negative, -1 means EOF.
emit ( c -- )
Print the specified character to the current output unit.
cr
Print a newline sequence to the current output unit.
space
Print a space to the current output unit.
spaces ( n -- )
Print n spaces to the current output unit.
outpop
Close the current output file & start using the previous output
file. This is a no-op if this is the first output file.
output
Take the next word in the input stream & try to open it
for writing. If you can't, call "abort". Otherwise, make
it the current output file, pushing the current output
onto a stack so that a later "outpop" will close
this file & continue with the old one.
input
As output, but open for reading. There is no corresponding
"inpop", as EOF status will cause the equivalent action.
count ( a -- a n )
Count characters in string a.
word ( c -- a )
Input word to delimiter c, placing it 'here'. Return address
of 'here'.
<#
Begin format processing, set 'hld' to 'pad'.
hold ( c -- )
Add character to pad.
# ( x -- x/base )
Add remainder as a character to format string.
#s ( x -- 0 )
Add ascii representation of unsigned value
to format string. If value is zero, add '0'.
sign ( x -- )
Add minus to format string if value is negative.
#> ( x -- a n )
Close format processing, return address and length.
.(
Print the string immediately (in interpretive mode) or compile
code which will print the string (in compilation mode).
."
Print the string immediately (in interpretive mode) or compile
code which will print the string (in compilation mode).
"
Place string in data area. 'Here' will point on it.
ascii ( -- c )
Get the next word and push in stack the ascii value
of the first character.
ncompile ( n -- )
Get the integer_t value from stack and compile the code
generating that value.
fcompile ( f -- )
Get the float value from stack and compile the code
generating that value.
compile xxx ( -- )
Compile the code for executing given symbol.
execute ( i -- )
Get the index of symbol from stack and execute it.
latest ( -- i )
Push in stack the index of current symbol under definition.
find ( a -- i )
Stack contains the address of string with the name of symbol.
Find this symbol in dictionary and return it's index.
base
A variable which holds the current base.
bl
A constant which holds the code for blank character.
hld
A variable which holds the address of pad.
pad
A constant which holds the end address of memory.
state
A variable which holds the current state; 0 = interpreting,
non-0 means compiling.
if ... [ else ] ... endif
The conditional structure. Note "endif", not "then".
'endif' is equivalent to 'then'.
begin ... again
Unconditional looping structure.
'again' is equivalent to 'repeat'.
begin ... until
Conditional looping--will loop until the "until" receives a
boolean "true" on the stack.
begin ... while ... repeat
Looping structure where the test is at the "while" word.
do ... loop
Counting loop.
do ... +loop
As do...loop, but +loop takes the amount to increment by.
?do
The same as do, but does not execute loop if upper and lower
bounds are aqual.
leave
Causes the innermost loop to reach its exit condition. The
next execution of "loop" or "+loop" will fall through.
i, j, k
The loop indices of (respectively) the innermost, second, and
third loops.
myself
recurse
Compile address of function under definition.
Results in calling function by itself.
For example,
: hihi ." Hi! " recurse ;
calls itself indefinitely.

114
src/cmd/forth/io.h Normal file
View File

@@ -0,0 +1,114 @@
#if 0
/*
* Use standard I/O library.
*/
#include <stdio.h>
#else
/*
* Use internal I/O library.
*/
#include <stdarg.h>
#include <fcntl.h>
typedef int FILE;
#define stdin ((FILE*) 0)
#define stdout ((FILE*) 1)
#define stderr ((FILE*) 2)
static inline int fileno (FILE *stream)
{
return (int) stream;
}
static inline FILE *fopen (const char *path, const char *mode)
{
int fd, flags;
if (mode[0] == 'w')
flags = O_WRONLY;
else if (mode[0] == 'a')
flags = O_WRONLY | O_APPEND | O_CREAT;
else if (mode[0] == 'r' && mode[1] == '+')
flags = O_RDWR | O_CREAT;
else
flags = O_RDONLY;
fd = open (path, flags, 0664);
if (fd < 0)
return 0;
return (FILE*) fd;
}
static inline FILE *fdopen (int fildes, const char *mode)
{
if (fildes < 0)
return 0;
return (FILE*) fildes;
}
static inline int fclose (FILE *stream)
{
return close ((int) stream);
}
extern int vsprintf (char *s, const char *format, va_list ap);
static inline int vfprintf (FILE *stream, const char *format, va_list ap)
{
int len;
char str[160];
vsprintf (str, format, ap);
len = strlen (str);
if (len > 0) {
write ((int) stream, str, len);
}
return len;
}
static inline int vprintf (const char *format, va_list ap)
{
return vfprintf (stdout, format, ap);
}
static inline int fprintf (FILE *stream, const char *format, ...)
{
va_list ap;
int ret;
va_start (ap, format);
ret = vfprintf (stream, format, ap);
va_end (ap);
return ret;
}
static inline int printf (const char *format, ...)
{
va_list ap;
int ret;
va_start (ap, format);
ret = vfprintf (stdout, format, ap);
va_end (ap);
return ret;
}
static inline int putc (int c, FILE *stream)
{
unsigned char sym = c;
if (write ((int) stream, &sym, 1) < 0)
return -1;
return c;
}
static inline int getc (FILE *stream)
{
unsigned char sym;
if (read ((int) stream, &sym, 1) != 1)
return -1;
return sym;
}
#endif