Skip to content

gforth
gforth
Commit 3664c932 authored by pazsan's avatar pazsan
Browse files
Options

Fixed problem with ?dup 

Deleted noop output like sp+=0 from prims2x.fs
Made wordinfo.fs work with DTC on i386
Added a faster (???) relocater
parent df2e7f03
Hide whitespace changes
Inline Side-by-side
Showing with 106 additions and 84 deletions
cross.fs
View file @ 3664c932
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.3 1994-05-05 15:46:38 pazsan Exp $
\ $Id: cross.fs,v 1.4 1994-05-18 17:29:50 pazsan Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -181,7 +181,9 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
: +bit ( addr n -- ) >bit over c@ or swap c! ;
: -bit ( addr n -- ) >bit invert over c@ and swap c! ;
: relon ( taddr -- ) bit$ @ swap cell/ +bit ;
: reloff ( taddr -- ) bit$ @ swap cell/ -bit ;
\ Target memory access 06oct92py
......@@ -510,7 +512,7 @@ Cond: DOES> restrict?
: gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <>
IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
:dodoes T A, H gexecute ;
:dodoes T A, H gexecute T here H cell - reloff ;
: TCreate ( ghost -- )
CreateFlag on
......
engine.c
View file @ 3664c932
/*
$Id: engine.c,v 1.5 1994-05-07 14:55:47 anton Exp $
$Id: engine.c,v 1.6 1994-05-18 17:29:52 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
......@@ -13,11 +13,16 @@
#include <assert.h>
#include <stdlib.h>
#include <time.h>
#include <sys/time.h>
#include "forth.h"
#include "io.h"
extern unlink(char *);
extern ftruncate(int, int);
#ifndef unlink
extern unlink(char *);
#endif
#ifndef ftruncate
extern ftruncate(int, int);
#endif
typedef union {
struct {
......@@ -72,10 +77,6 @@ typedef struct F83Name {
#define FTOS (fp[0])
#endif
/*
#define CA_DODOES (symbols[DODOES])
*/
int emitcounter;
#define NULLC '\0'
......@@ -86,10 +87,33 @@ int emitcounter;
static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};
#if ~defined(select) && defined(DOS)
/* select replacement for DOS computers for ms only */
void select(int n, int a, int b, int c, struct timeval * timeout)
{
struct timeval time1;
struct timeval time2;
struct timezone zone1;
gettimeofday(&time1,&zone1);
time1.tv_sec += timeout->tv_sec;
time1.tv_usec += timeout->tv_usec;
while(time1.tv_usec >= 1000000)
{
time1.tv_usec -= 1000000;
time1.tv_sec++;
}
do
{
gettimeofday(&time2,&zone1);
}
while(time2.tv_usec < time1.tv_usec || time2.tv_sec < time1.tv_sec);
}
#endif
Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
/* executes code at ip, if ip!=NULL
returns array of machine code labels (for use in a loader), if ip==NULL
This is very preliminary, as the bootstrap architecture is not yet decided
*/
{
Xt cfa;
......@@ -100,7 +124,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
&&dovar,
&&douser,
&&dodoes,
&&docol, /* dummy for does handler address */
&&dodoes, /* dummy for does handler address */
#include "prim_labels.i"
};
IF_TOS(register Cell TOS;)
......@@ -119,7 +143,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
docol:
#ifdef DEBUG
printf("col: %x\n",(Cell)PFA1(cfa));
printf("%08x: col: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
#endif
#ifdef undefined
/* this is the simple version */
......@@ -143,7 +167,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
docon:
#ifdef DEBUG
printf("con: %x\n",*(Cell*)PFA1(cfa));
printf("%08x: con: %08x\n",(Cell)ip,*(Cell*)PFA1(cfa));
#endif
#ifdef USE_TOS
*sp-- = TOS;
......@@ -155,7 +179,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
dovar:
#ifdef DEBUG
printf("var: %x\n",(Cell)PFA1(cfa));
printf("%08x: var: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
#endif
#ifdef USE_TOS
*sp-- = TOS;
......@@ -169,7 +193,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
douser:
#ifdef DEBUG
printf("user: %x\n",(Cell)PFA1(cfa));
printf("%08x: user: %08x\n",(Cell)ip,(Cell)PFA1(cfa));
#endif
#ifdef USE_TOS
*sp-- = TOS;
......@@ -198,7 +222,8 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
*/
#ifdef DEBUG
printf("does: %x\n",(Cell)PFA(cfa)); fflush(stdout);
printf("%08x/%08x: does: %08x\n",(Cell)ip,(Cell)cfa,*(Cell)PFA(cfa));
fflush(stdout);
#endif
*--rp = (Cell)ip;
/* PFA1 might collide with DOES_CODE1 here, so we use PFA */
......
forth.h
View file @ 3664c932
/*
$Id: forth.h,v 1.4 1994-05-07 14:55:51 anton Exp $
$Id: forth.h,v 1.5 1994-05-18 17:29:53 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
......@@ -21,6 +21,8 @@ typedef void *Label;
/* Forth data types */
typedef int Bool;
#define FLAG(b) (-(b))
#define FILEIO(error) (FLAG(error) & -37)
#define FILEEXIST(error) (FLAG(error) & -38)
#define F_TRUE (FLAG(0==0))
#define F_FALSE (FLAG(0!=0))
......@@ -62,7 +64,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
#endif
#ifdef DEBUG
# define NAME(string) printf("%08x: %s\n",(int)ip,string);
# define NAME(string) printf("%08x: "string"\n",(int)ip);
#else
# define NAME(string)
#endif
......
kernal.fs
View file @ 3664c932
......@@ -254,7 +254,8 @@ hex
handler @ >r
rp@ handler !
execute
r> handler ! rdrop rdrop 0 ;
r> handler ! rdrop rdrop rdrop 0 ;
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
?DUP IF
handler @ rp!
......@@ -263,6 +264,7 @@ hex
r> fp!
r> swap >r sp! r>
THEN ;
\ Bouncing is very fine,
\ programming without wasting time... jaw
: bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )
......@@ -779,8 +781,8 @@ create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
\ INCLUDE 9may93jaw
: include
bl word count included ;
: include ( "file" -- )
bl word count included ;
\ RECURSE 17may93jaw
......
main.c
View file @ 3664c932
/*
$Id: main.c,v 1.4 1994-05-07 14:56:01 anton Exp $
$Id: main.c,v 1.5 1994-05-18 17:29:56 pazsan Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
......@@ -13,6 +13,7 @@
#include <assert.h>
#include <stdlib.h>
#include "forth.h"
#include "io.h"
#ifndef DEFAULTBIN
# define DEFAULTBIN ""
......@@ -27,8 +28,7 @@
/* image file format:
* size of image with stacks without tags (in bytes)
* size of image without stacks and tags (in bytes)
* size of return, FP and locals stack (in bytes, just one entry)
* !! have a different number for each one!
* size of data and FP stack (in bytes)
* pointer to start of code
* data (size in image[1])
* tags (1 bit/data cell)
......@@ -45,38 +45,30 @@
void relocate(int *image, char *bitstring, int size, Label symbols[])
{
int i;
static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};
#ifdef DEBUG
printf("Dodoes-Adresse: %08x\n",(int)symbols[DODOES]);
#endif
for(i=0;i<size/sizeof(Cell);i++)
if(bitstring[i >> 3] & bits[i & 7])
if(image[i]<0)
switch(image[i])
{
case CF_NIL :
image[i]=0; break;
case CF(DOCOL) :
case CF(DOVAR) :
case CF(DOCON) :
case CF(DOUSER) :
MAKE_CF(image+i,symbols[CF(image[i])]); break;
case CF(DODOES) :
MAKE_DOES_CF(image+i,image[i+1]+((int)image));
i++; break; /* is this necessary? */
case CF(DOESJUMP):
MAKE_DOES_HANDLER(image+i);
break;
default:
image[i]=(Cell)CA(CF(image[i]));
}
else
image[i]+=(Cell)image;
CACHE_FLUSH(image,size);
int i=0, j, k, steps=(size/sizeof(Cell))/8;
char bits;
/* static char bits[8]={0x80,0x40,0x20,0x10,0x08,0x04,0x02,0x01};*/
for(k=0; k<=steps; k++)
for(j=0, bits=bitstring[k]; j<8; j++, i++, bits<<=1)
if(bits & 0x80)
if(image[i]<0)
switch(image[i])
{
case CF_NIL : image[i]=0; break;
case CF(DOCOL) :
case CF(DOVAR) :
case CF(DOCON) :
case CF(DOUSER) : MAKE_CF(image+i,symbols[CF(image[i])]); break;
case CF(DODOES) : MAKE_DOES_CF(image+i,image[i+1]+((int)image));
break;
case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;
default : image[i]=(Cell)CA(CF(image[i]));
}
else
image[i]+=(Cell)image;
CACHE_FLUSH(image,size);
}
int* loader(const char* filename)
......
primitives
View file @ 3664c932
......@@ -502,12 +502,10 @@ nip w1 w2 -- w2 core-ext
tuck w1 w2 -- w2 w1 w2 core-ext
?dup w -- w core question_dupe
/* resulting C code suboptimal */
/* make -dup an alias */
if (w!=0) {
--sp;
IF_TOS(*sp-- = w;)
#ifndef USE_TOS
*sp = w;
*--sp = w;
#endif
}
......@@ -644,13 +642,13 @@ else {
}
close-file wfileid -- wior file close_file
wior = FLAG(fclose((FILE *)wfileid)==EOF);
wior = FILEIO(fclose((FILE *)wfileid)==EOF);
open-file c_addr u ntype -- w2 wior file open_file
char fname[u+1];
cstr(fname, c_addr, u);
w2 = (Cell)fopen(fname, fileattr[ntype]);
wior = FLAG(w2 == NULL);
wior = FILEEXIST(w2 == NULL);
create-file c_addr u ntype -- w2 wior file create_file
int fd;
......@@ -663,21 +661,21 @@ if (fd > -1) {
wior = 0;
} else {
assert(fd == -1);
wior = fd;
wior = FILEIO(fd);
w2 = 0;
}
delete-file c_addr u -- wior file delete_file
char fname[u+1];
cstr(fname, c_addr, u);
wior = unlink(fname);
wior = FILEEXIST(unlink(fname));
rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file
char fname1[u1+1];
char fname2[u2+1];
cstr(fname1, c_addr1, u1);
cstr(fname2, c_addr2, u2);
wior = rename(fname1, fname2);
wior = FILEEXIST(rename(fname1, fname2));
file-position wfileid -- ud wior file file_position
/* !! use tell and lseek? */
......@@ -685,26 +683,26 @@ ud = ftell((FILE *)wfileid);
wior = 0; /* !! or wior = FLAG(ud<0) */
reposition-file ud wfileid -- wior file reposition_file
wior = fseek((FILE *)wfileid, (long)ud, SEEK_SET);
wior = FILEIO(fseek((FILE *)wfileid, (long)ud, SEEK_SET));
file-size wfileid -- ud wior file file_size
struct stat buf;
wior = fstat(fileno((FILE *)wfileid), &buf);
wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf));
ud = buf.st_size;
resize-file ud wfileid -- wior file resize_file
wior = ftruncate(fileno((FILE *)wfileid), (int)ud);
wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud));
read-file c_addr u1 wfileid -- u2 wior file read_file
/* !! fread does not guarantee enough */
u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
wior = FLAG(u2<u1 && ferror((FILE *)wfileid));
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
/* !! who performs clearerr((FILE *)wfileid); ? */
read-line c_addr u1 wfileid -- u2 flag wior file read_line
wior=(Cell)fgets(c_addr,u1+1,(FILE *)wfileid);
flag=FLAG(!feof((FILE *)wfileid) && wior);
wior=FLAG(ferror((FILE *)wfileid)) & flag;
wior=FILEIO(ferror((FILE *)wfileid)) & flag;
u2=(flag & strlen(c_addr));
u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
......@@ -712,11 +710,11 @@ write-file c_addr u1 wfileid -- wior file write_file
/* !! fwrite does not guarantee enough */
{
int u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
wior = FLAG(u2<u1 && ferror((FILE *)wfileid));
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
}
flush-file wfileid -- wior file-ext flush_file
wior = fflush((FILE *)wfileid);
wior = FILEIO(fflush((FILE *) wfileid));
comparisons(f, r1 r2, f_, r1, r2, new, new, float, new)
comparisons(f0, r, f_zero_, r, 0., float, new, float, new)
......
prims2x.fs
View file @ 3664c932
......@@ -204,6 +204,7 @@ parser primitives2something
here swap read-whole-file
dup endinput !
here - allot
align
primitives2something ;
\ types
......@@ -220,7 +221,7 @@ constant type-description
\ n1 is the offset of the accessed item, n2, n3 are effect-*-size
drop swap - 1- dup
if
." sp[" . ." ]"
." sp[" 0 .r ." ]"
else
drop ." TOS"
endif ;
......@@ -229,7 +230,7 @@ constant type-description
\ n1 is the offset of the accessed item, n2, n3 are effect-*-size
nip swap - 1- dup
if
." fp[" . ." ]"
." fp[" 0 .r ." ]"
else
drop ." FTOS"
endif ;
......@@ -300,8 +301,8 @@ constant type-description
>r
." {Double_Store _d; _d.dcell = " r@ item-name 2@ type ." ; "
r@ item-d-offset @ dup effect-out-size 2@ data-stack-access
." = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access
." = _d.cells.high;}" cr
." = _d.cells.low; " 1+ effect-out-size 2@ data-stack-access
." = _d.cells.high;}" cr
rdrop ;
: f-same-as-in? ( item -- f )
......@@ -489,8 +490,8 @@ set-current
effect-out-size 2@
rot swap - ( d-in d-out f-diff )
rot rot - ( f-diff d-diff )
." sp += " . ." ;" cr
." fp += " . ." ;" cr ;
?dup IF ." sp += " 0 .r ." ;" cr THEN
?dup IF ." fp += " 0 .r ." ;" cr THEN ;
: store ( item -- )
\ f is true if the item should be stored
......@@ -503,7 +504,7 @@ set-current
item-descr +loop ;
: output-c ( -- )
." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr
." I_" c-name 2@ type ." : /* " forth-name 2@ type ." ( " stack-string 2@ type ." ) */" cr
." /* " doc 2@ type ." */" cr
." {" cr
." DEF_CA" cr
......@@ -511,7 +512,7 @@ set-current
compute-offsets \ for everything else
flush-tos
fetches
stack-pointer-updates
stack-pointer-updates cr
." NAME(" [char] " emit forth-name 2@ type [char] " emit ." )" cr \ debugging
." {" cr
c-code 2@ type
......
wordinfo.fs
View file @ 3664c932
......@@ -21,15 +21,15 @@ INCLUDE look.fs
: var? ( nfa -- flag )
(name>)
@ ['] leavings @ = ;
>code-address ['] leavings >code-address = ;
: con? ( nfa -- flag )
(name>)
@ ['] bl @ = ;
>code-address ['] bl >code-address = ;
: does? ( nfa -- flag )
dup (name>)
@ ['] source @ =
>code-address ['] source >code-address =
dup IF swap (name>) cell+ @ here ! ELSE nip THEN ;
: defered? ( nfa -- flag )
......@@ -40,7 +40,7 @@ INCLUDE look.fs
: colon? ( nfa -- flag )
(name>)
@ ['] does? @ = ;
>code-address ['] does? >code-address = ;
\ VALUE VCheck
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment