Commit b966b024 authored by pazsan's avatar pazsan

float.fs: Added f~ (f-proximate)

wordsets.fs: Added missing float words
Added 16 bit and 64 bit support in cross.fs
Fixed some bugs which asume sizeof(int)=sizeof(Cell)
parent a713facd
...@@ -49,13 +49,14 @@ FORTH_SRC = add.fs assert.fs ansi.fs blocks.fs bufio.fs checkans.fs \ ...@@ -49,13 +49,14 @@ FORTH_SRC = add.fs assert.fs ansi.fs blocks.fs bufio.fs checkans.fs \
colorize.fs cross.fs debug.fs debugging.fs doskey.fs ds2texi.fs \ colorize.fs cross.fs debug.fs debugging.fs doskey.fs ds2texi.fs \
dumpimage.fs environ.fs errore.fs etags.fs extend.fs filedump.fs \ dumpimage.fs environ.fs errore.fs etags.fs extend.fs filedump.fs \
float.fs glocals.fs glosgen.fs gray.fs hash.fs history.fs \ float.fs glocals.fs glosgen.fs gray.fs hash.fs history.fs \
kernal.fs locals-test.fs look.fs mach32b.fs mach32l.fs main.fs \ kernal.fs locals-test.fs look.fs main.fs \
mach16b.fs mach16l.fs mach32b.fs mach32l.fs mach64b.fs mach64l.fs \
other.fs prims2x.fs random.fs search-order.fs see.fs sieve.fs \ other.fs prims2x.fs random.fs search-order.fs see.fs sieve.fs \
startup.fs struct.fs tools.fs toolsext.fs tt.fs vars.fs vt100.fs \ startup.fs struct.fs tools.fs toolsext.fs tt.fs vars.fs vt100.fs \
vt100key.fs wordinfo.fs wordsets.fs vt100key.fs wordinfo.fs wordsets.fs
SOURCES = Makefile.in configure.in configure config.sub config.guess \ SOURCES = Makefile.in configure.in configure config.sub config.guess \
INSTALL README ToDo BUGS model gforth.ds \ INSTALL README ToDo BUGS model gforth.ds install-sh \
primitives engine.c main.c io.c \ primitives engine.c main.c io.c \
m68k.h mips.h 386.h hppa.h cache.c sparc.h 32bit.h \ m68k.h mips.h 386.h hppa.h cache.c sparc.h 32bit.h \
getopt.c getopt1.c getopt.h \ getopt.c getopt1.c getopt.h \
...@@ -136,6 +137,20 @@ gforth: $(OBJECTS) ...@@ -136,6 +137,20 @@ gforth: $(OBJECTS)
$(GCC) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o $@ $(GCC) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o $@
@MAKE_EXE@ @MAKE_EXE@
kernl16l.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach16l.fs $(FORTH_GEN)
-$(CP) kernl16l.fi kernl16l.fi~
$(FORTH) -e 's" mach16l.fs"' main.fs
@LINK_KERNL16L@
kernl16b.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach16b.fs $(FORTH_GEN)
-$(CP) kernl16b.fi kernl16b.fi~
$(FORTH) -e 's" mach16b.fs"' main.fs
@LINK_KERNL16B@
kernl32l.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \ kernl32l.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \ errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach32l.fs $(FORTH_GEN) mach32l.fs $(FORTH_GEN)
...@@ -150,6 +165,20 @@ kernl32b.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \ ...@@ -150,6 +165,20 @@ kernl32b.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
$(FORTH) -e 's" mach32b.fs"' main.fs $(FORTH) -e 's" mach32b.fs"' main.fs
@LINK_KERNL32B@ @LINK_KERNL32B@
kernl64l.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach64l.fs $(FORTH_GEN)
-$(CP) kernl64l.fi kernl64l.fi~
$(FORTH) -e 's" mach64l.fs"' main.fs
@LINK_KERNL64L@
kernl64b.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach64b.fs $(FORTH_GEN)
-$(CP) kernl64b.fi kernl64b.fi~
$(FORTH) -e 's" mach64b.fs"' main.fs
@LINK_KERNL64B@
engine.s: engine.c primitives.i prim_labels.i machine.h $(INCLUDES) engine.s: engine.c primitives.i prim_labels.i machine.h $(INCLUDES)
$(GCC) $(CFLAGS) $(ENGINE_FLAGS) -S engine.c $(GCC) $(CFLAGS) $(ENGINE_FLAGS) -S engine.c
......
...@@ -490,6 +490,8 @@ case "$host_cpu" in ...@@ -490,6 +490,8 @@ case "$host_cpu" in
hppa*) hppa*)
mach_h=hppa mach_h=hppa
LIBOBJS="cache.o" LIBOBJS="cache.o"
LDFLAGS="-Xlinker -N"
LIBS="-L/lib/pa1.1/ $LIBS"
;; ;;
sparc*) sparc*)
mach_h=sparc mach_h=sparc
...@@ -504,6 +506,7 @@ case "$host_cpu" in ...@@ -504,6 +506,7 @@ case "$host_cpu" in
;; ;;
mips*) mips*)
mach_h=mips mach_h=mips
LDFLAGS="-Xlinker -N"
#!! link text and data segment into the same 256M region! #!! link text and data segment into the same 256M region!
#!! does cacheflush work on OSs other than Ultrix? #!! does cacheflush work on OSs other than Ultrix?
;; ;;
...@@ -520,10 +523,18 @@ esac ...@@ -520,10 +523,18 @@ esac
MAKE_EXE="" MAKE_EXE=""
LINK_KERNL16L=""
LINK_KERNL16B=""
LINK_KERNL32L="" LINK_KERNL32L=""
LINK_KERNL32B="" LINK_KERNL32B=""
LINK_KERNL64L=""
LINK_KERNL64B=""
#if test $host_os=dos #if test $host_os=dos
#then #then
# echo Configuring for DOS!!! # echo Configuring for DOS!!!
...@@ -540,7 +551,7 @@ else ...@@ -540,7 +551,7 @@ else
ac_cv_cross=yes ac_cv_cross=yes
else else
cat > conftest.$ac_ext <<EOF cat > conftest.$ac_ext <<EOF
#line 544 "configure" #line 555 "configure"
#include "confdefs.h" #include "confdefs.h"
main(){return(0);} main(){return(0);}
EOF EOF
...@@ -564,7 +575,7 @@ else ...@@ -564,7 +575,7 @@ else
{ echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else else
cat > conftest.$ac_ext <<EOF cat > conftest.$ac_ext <<EOF
#line 568 "configure" #line 579 "configure"
#include "confdefs.h" #include "confdefs.h"
main () { main () {
/* Are we little or big endian? From Harbison&Steele. */ /* Are we little or big endian? From Harbison&Steele. */
...@@ -597,10 +608,10 @@ fi ...@@ -597,10 +608,10 @@ fi
if test $ac_cv_c_bigendian = yes; then if test $ac_cv_c_bigendian = yes; then
bytesex=b bytesex=b
KERNAL="kernl32b.fi kernl32l.fi" KERNAL="kernl16b.fi kernl16l.fi kernl32b.fi kernl32l.fi kernl64b.fi kernl64l.fi"
else else
bytesex=l bytesex=l
KERNAL="kernl32l.fi kernl32b.fi" KERNAL="kernl16l.fi kernl16b.fi kernl32l.fi kernl32b.fi kernl64l.fi kernl64b.fi"
fi fi
echo $ac_n "checking whether ln -s works""... $ac_c" 1>&4 echo $ac_n "checking whether ln -s works""... $ac_c" 1>&4
...@@ -682,7 +693,7 @@ else ...@@ -682,7 +693,7 @@ else
ac_save_LIBS="$LIBS" ac_save_LIBS="$LIBS"
LIBS="$LIBS -lm " LIBS="$LIBS -lm "
cat > conftest.$ac_ext <<EOF cat > conftest.$ac_ext <<EOF
#line 686 "configure" #line 697 "configure"
#include "confdefs.h" #include "confdefs.h"
int main() { return 0; } int main() { return 0; }
...@@ -722,7 +733,7 @@ else ...@@ -722,7 +733,7 @@ else
ac_cv_func_memcmp=no ac_cv_func_memcmp=no
else else
cat > conftest.$ac_ext <<EOF cat > conftest.$ac_ext <<EOF
#line 726 "configure" #line 737 "configure"
#include "confdefs.h" #include "confdefs.h"
main() main()
...@@ -751,7 +762,7 @@ if eval "test \"`echo '${'ac_cv_func_$ac_func'+set}'`\" = set"; then ...@@ -751,7 +762,7 @@ if eval "test \"`echo '${'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&4 echo $ac_n "(cached) $ac_c" 1>&4
else else
cat > conftest.$ac_ext <<EOF cat > conftest.$ac_ext <<EOF
#line 755 "configure" #line 766 "configure"
#include "confdefs.h" #include "confdefs.h"
#include <ctype.h> /* Arbitrary system header to define __stub macros. */ #include <ctype.h> /* Arbitrary system header to define __stub macros. */
/* Override any gcc2 internal prototype to avoid an error. */ /* Override any gcc2 internal prototype to avoid an error. */
...@@ -796,7 +807,7 @@ if eval "test \"`echo '${'ac_cv_func_getopt_long'+set}'`\" = set"; then ...@@ -796,7 +807,7 @@ if eval "test \"`echo '${'ac_cv_func_getopt_long'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&4 echo $ac_n "(cached) $ac_c" 1>&4
else else
cat > conftest.$ac_ext <<EOF cat > conftest.$ac_ext <<EOF
#line 800 "configure" #line 811 "configure"
#include "confdefs.h" #include "confdefs.h"
#include <ctype.h> /* Arbitrary system header to define __stub macros. */ #include <ctype.h> /* Arbitrary system header to define __stub macros. */
/* Override any gcc2 internal prototype to avoid an error. */ /* Override any gcc2 internal prototype to avoid an error. */
...@@ -842,7 +853,7 @@ if eval "test \"`echo '${'ac_cv_func_$ac_func'+set}'`\" = set"; then ...@@ -842,7 +853,7 @@ if eval "test \"`echo '${'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&4 echo $ac_n "(cached) $ac_c" 1>&4
else else
cat > conftest.$ac_ext <<EOF cat > conftest.$ac_ext <<EOF
#line 846 "configure" #line 857 "configure"
#include "confdefs.h" #include "confdefs.h"
#include <ctype.h> /* Arbitrary system header to define __stub macros. */ #include <ctype.h> /* Arbitrary system header to define __stub macros. */
/* Override any gcc2 internal prototype to avoid an error. */ /* Override any gcc2 internal prototype to avoid an error. */
...@@ -891,7 +902,7 @@ if eval "test \"`echo '${'ac_cv_func_$ac_func'+set}'`\" = set"; then ...@@ -891,7 +902,7 @@ if eval "test \"`echo '${'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&4 echo $ac_n "(cached) $ac_c" 1>&4
else else
cat > conftest.$ac_ext <<EOF cat > conftest.$ac_ext <<EOF
#line 895 "configure" #line 906 "configure"
#include "confdefs.h" #include "confdefs.h"
#include <ctype.h> /* Arbitrary system header to define __stub macros. */ #include <ctype.h> /* Arbitrary system header to define __stub macros. */
/* Override any gcc2 internal prototype to avoid an error. */ /* Override any gcc2 internal prototype to avoid an error. */
...@@ -1047,8 +1058,12 @@ s%@host_cpu@%$host_cpu%g ...@@ -1047,8 +1058,12 @@ s%@host_cpu@%$host_cpu%g
s%@host_vendor@%$host_vendor%g s%@host_vendor@%$host_vendor%g
s%@host_os@%$host_os%g s%@host_os@%$host_os%g
s%@MAKE_EXE@%$MAKE_EXE%g s%@MAKE_EXE@%$MAKE_EXE%g
s%@LINK_KERNL16L@%$LINK_KERNL16L%g
s%@LINK_KERNL16B@%$LINK_KERNL16B%g
s%@LINK_KERNL32L@%$LINK_KERNL32L%g s%@LINK_KERNL32L@%$LINK_KERNL32L%g
s%@LINK_KERNL32B@%$LINK_KERNL32B%g s%@LINK_KERNL32B@%$LINK_KERNL32B%g
s%@LINK_KERNL64L@%$LINK_KERNL64L%g
s%@LINK_KERNL64B@%$LINK_KERNL64B%g
s%@KERNAL@%$KERNAL%g s%@KERNAL@%$KERNAL%g
s%@LN_S@%$LN_S%g s%@LN_S@%$LN_S%g
s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
......
...@@ -27,6 +27,8 @@ case "$host_cpu" in ...@@ -27,6 +27,8 @@ case "$host_cpu" in
hppa*) hppa*)
mach_h=hppa mach_h=hppa
LIBOBJS="cache.o" LIBOBJS="cache.o"
LDFLAGS="-Xlinker -N"
LIBS="-L/lib/pa1.1/"
;; ;;
sparc*) sparc*)
mach_h=sparc mach_h=sparc
...@@ -41,6 +43,7 @@ case "$host_cpu" in ...@@ -41,6 +43,7 @@ case "$host_cpu" in
;; ;;
mips*) mips*)
mach_h=mips mach_h=mips
LDFLAGS="-Xlinker -N"
#!! link text and data segment into the same 256M region! #!! link text and data segment into the same 256M region!
#!! does cacheflush work on OSs other than Ultrix? #!! does cacheflush work on OSs other than Ultrix?
;; ;;
...@@ -58,10 +61,18 @@ AC_SUBST(MAKE_EXE) ...@@ -58,10 +61,18 @@ AC_SUBST(MAKE_EXE)
MAKE_EXE="" MAKE_EXE=""
dnl copy commands for systems that don't have links dnl copy commands for systems that don't have links
AC_SUBST(LINK_KERNL16L)
LINK_KERNL16L=""
AC_SUBST(LINK_KERNL16B)
LINK_KERNL16B=""
AC_SUBST(LINK_KERNL32L) AC_SUBST(LINK_KERNL32L)
LINK_KERNL32L="" LINK_KERNL32L=""
AC_SUBST(LINK_KERNL32B) AC_SUBST(LINK_KERNL32B)
LINK_KERNL32B="" LINK_KERNL32B=""
AC_SUBST(LINK_KERNL64L)
LINK_KERNL64L=""
AC_SUBST(LINK_KERNL64B)
LINK_KERNL64B=""
#if test $host_os=dos #if test $host_os=dos
#then #then
...@@ -76,10 +87,10 @@ AC_SUBST(KERNAL) ...@@ -76,10 +87,10 @@ AC_SUBST(KERNAL)
dnl ac_cv_c_bigendian is an undocumented variable of autoconf-2.1 dnl ac_cv_c_bigendian is an undocumented variable of autoconf-2.1
if test $ac_cv_c_bigendian = yes; then if test $ac_cv_c_bigendian = yes; then
bytesex=b bytesex=b
KERNAL="kernl32b.fi kernl32l.fi" KERNAL="kernl16b.fi kernl16l.fi kernl32b.fi kernl32l.fi kernl64b.fi kernl64l.fi"
else else
bytesex=l bytesex=l
KERNAL="kernl32l.fi kernl32b.fi" KERNAL="kernl16l.fi kernl16b.fi kernl32l.fi kernl32b.fi kernl64l.fi kernl64b.fi"
fi fi
dnl Checks for programs. dnl Checks for programs.
......
\ CROSS.FS The Cross-Compiler 06oct92py \ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.18 1994-12-15 12:35:12 pazsan Exp $ \ $Id: cross.fs,v 1.19 1995-01-19 17:47:59 pazsan Exp $
\ Idea and implementation: Bernd Paysan (py) \ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992-94 by the GNU Forth Development Group \ Copyright 1992-94 by the GNU Forth Development Group
...@@ -86,17 +86,28 @@ Variable tdp ...@@ -86,17 +86,28 @@ Variable tdp
included included
\ Create additional parameters 19jan95py
T
cell Constant tcell
cell<< Constant tcell<<
cell>bit Constant tcell>bit
bits/byte Constant tbits/byte
float Constant tfloat
1 bits/byte lshift Constant maxbyte
H
>TARGET >TARGET
\ Byte ordering and cell size 06oct92py \ Byte ordering and cell size 06oct92py
: cell+ cell + ; : cell+ tcell + ;
: cells cell<< lshift ; : cells tcell<< lshift ;
: chars ; : chars ;
: floats float * ; : floats tfloat * ;
>CROSS >CROSS
: cell/ cell<< rshift ; : cell/ tcell<< rshift ;
>TARGET >TARGET
20 CONSTANT bl 20 CONSTANT bl
-1 Constant NIL -1 Constant NIL
...@@ -111,11 +122,23 @@ included ...@@ -111,11 +122,23 @@ included
>CROSS >CROSS
bigendian 0 pad ! -1 pad c! pad @ 0< bigendian 0 pad ! -1 pad c! pad @ 0<
= [IF] : bswap ; immediate = [IF]
[ELSE] : bswap ( big / little -- little / big ) 0 \ : bswap ; immediate
cell 1- FOR bits/byte lshift over : T! ( n addr -- ) >r s>d r> tcell bounds swap 1-
[ 1 bits/byte lshift 1- ] Literal and or DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
swap bits/byte rshift swap NEXT nip ; : T@ ( addr -- n ) >r 0 0 r> tcell bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
[ELSE]
: T! ( n addr -- ) >r s>d r> tcell bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;
: T@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
\ : bswap ( big / little -- little / big ) 0
\ cell 1- FOR bits/byte lshift over
\ [ 1 bits/byte lshift 1- ] Literal and or
\ swap bits/byte rshift swap NEXT nip ;
[THEN] [THEN]
\ Memory initialisation 05dec92py \ Memory initialisation 05dec92py
...@@ -164,8 +187,8 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, ...@@ -164,8 +187,8 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
>CROSS >CROSS
: >image ( taddr -- absaddr ) image @ + ; : >image ( taddr -- absaddr ) image @ + ;
>TARGET >TARGET
: @ ( taddr -- w ) >image @ bswap ; : @ ( taddr -- w ) >image t@ ;
: ! ( w taddr -- ) >r bswap r> >image ! ; : ! ( w taddr -- ) >image t! ;
: c@ ( taddr -- char ) >image c@ ; : c@ ( taddr -- char ) >image c@ ;
: c! ( char taddr -- ) >image c! ; : c! ( char taddr -- ) >image c! ;
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ; : 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
...@@ -547,10 +570,10 @@ Variable tup 0 tup ! ...@@ -547,10 +570,10 @@ Variable tup 0 tup !
Variable tudp 0 tudp ! Variable tudp 0 tudp !
: u, ( n -- udp ) : u, ( n -- udp )
tup @ tudp @ + T ! H tup @ tudp @ + T ! H
tudp @ dup cell+ tudp ! ; tudp @ dup T cell+ H tudp ! ;
: au, ( n -- udp ) : au, ( n -- udp )
tup @ tudp @ + T A! H tup @ tudp @ + T A! H
tudp @ dup cell+ tudp ! ; tudp @ dup T cell+ H tudp ! ;
>TARGET >TARGET
Build: T 0 u, , H ; Build: T 0 u, , H ;
...@@ -751,8 +774,9 @@ bigendian Constant bigendian ...@@ -751,8 +774,9 @@ bigendian Constant bigendian
: * * ; : / / ; : * * ; : / / ;
: dup dup ; : over over ; : dup dup ; : over over ;
: swap swap ; : rot rot ; : swap swap ; : rot rot ;
: drop drop ; : drop drop ; : = = ;
: lshift lshift ; : 2/ 2/ ; : lshift lshift ; : 2/ 2/ ;
: . . ;
cell constant cell cell constant cell
\ include bug5.fs \ include bug5.fs
......
...@@ -103,5 +103,10 @@ ...@@ -103,5 +103,10 @@
\ : facosh fdup fdup f* 1e0 f- fsqrt f+ fln ; \ : facosh fdup fdup f* 1e0 f- fsqrt f+ fln ;
\ : fasinh fdup fdup f* 1e0 f+ fsqrt f/ fatanh ; \ : fasinh fdup fdup f* 1e0 f+ fsqrt f/ fatanh ;
: f~ ( f1 f2 f3 -- flag ) fdup f0= IF fdrop f= EXIT THEN
fdup f0> IF frot frot f- fabs fswap
ELSE fnegate frot frot fover fabs fover fabs f+ frot frot
f- fabs frot frot f* THEN f< ;
: f.s ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0 : f.s ." <" fdepth 0 .r ." > " fdepth 0 max maxdepth-.s @ min dup 0
?DO dup i - 1- floats fp@ + f@ f. LOOP drop ; ?DO dup i - 1- floats fp@ + f@ f. LOOP drop ;
...@@ -59,12 +59,12 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp); ...@@ -59,12 +59,12 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
#define MAKE_DOES_CF(cfa,does_code) ({MAKE_CF(cfa,symbols[DODOES]); \ #define MAKE_DOES_CF(cfa,does_code) ({MAKE_CF(cfa,symbols[DODOES]); \
((Cell *)cfa)[1] = (Cell)does_code;}) ((Cell *)cfa)[1] = (Cell)does_code;})
/* the does handler resides between DOES> and the following Forth code */ /* the does handler resides between DOES> and the following Forth code */
#define DOES_HANDLER_SIZE 8 #define DOES_HANDLER_SIZE (2*sizeof(Cell))
#define MAKE_DOES_HANDLER(addr) 0 /* do nothing */ #define MAKE_DOES_HANDLER(addr) 0 /* do nothing */
#endif #endif
#ifdef DEBUG #ifdef DEBUG
# define NAME(string) fprintf(stderr,"%08x: "string"\n",(int)ip); # define NAME(string) fprintf(stderr,"%08x: "string"\n",(Cell)ip);
#else #else
# define NAME(string) # define NAME(string)
#endif #endif
......
\ Parameter for target systems 06oct92py
2 Constant cell
1 Constant cell<<
4 Constant cell>bit
8 Constant bits/byte
8 Constant float
true Constant bigendian
( true=big, false=little )
\ Parameter for target systems 06oct92py
2 Constant cell
1 Constant cell<<
4 Constant cell>bit
8 Constant bits/byte
8 Constant float
false Constant bigendian
( true=big, false=little )
\ Parameter for target systems 06oct92py
8 Constant cell
3 Constant cell<<
6 Constant cell>bit
8 Constant bits/byte
8 Constant float
true Constant bigendian
( true=big, false=little )
\ Parameter for target systems 06oct92py
8 Constant cell
3 Constant cell<<
6 Constant cell>bit
8 Constant bits/byte
8 Constant float
false Constant bigendian
( true=big, false=little )
/* /*
$Id: main.c,v 1.20 1994-12-12 17:10:42 anton Exp $ $Id: main.c,v 1.21 1995-01-19 17:48:08 pazsan Exp $
Copyright 1993 by the ANSI figForth Development Group Copyright 1993 by the ANSI figForth Development Group
*/ */
...@@ -23,16 +23,16 @@ ...@@ -23,16 +23,16 @@
#ifdef DIRECT_THREADED #ifdef DIRECT_THREADED
# define CA(n) (symbols[(n)]) # define CA(n) (symbols[(n)])
#else #else
# define CA(n) ((int)(symbols+(n))) # define CA(n) ((Cell)(symbols+(n)))
#endif #endif
#define maxaligned(n) ((((Cell)n)+sizeof(Float)-1)&-sizeof(Float)) #define maxaligned(n) ((((Cell)n)+sizeof(Float)-1)&-sizeof(Float))
static int dictsize=0; static Cell dictsize=0;
static int dsize=0; static Cell dsize=0;
static int rsize=0; static Cell rsize=0;
static int fsize=0; static Cell fsize=0;
static int lsize=0; static Cell lsize=0;
char *progname; char *progname;
...@@ -76,7 +76,7 @@ void relocate(Cell *image, char *bitstring, int size, Label symbols[]) ...@@ -76,7 +76,7 @@ void relocate(Cell *image, char *bitstring, int size, Label symbols[])
case CF(DOCON) : case CF(DOCON) :
case CF(DOUSER) : case CF(DOUSER) :
case CF(DODEFER) : MAKE_CF(image+i,symbols[CF(image[i])]); break; case CF(DODEFER) : MAKE_CF(image+i,symbols[CF(image[i])]); break;
case CF(DODOES) : MAKE_DOES_CF(image+i,image[i+1]+((int)image)); case CF(DODOES) : MAKE_DOES_CF(image+i,image[i+1]+((Cell)image));
break; break;
case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break; case CF(DOESJUMP): MAKE_DOES_HANDLER(image+i); break;
default : image[i]=(Cell)CA(CF(image[i])); default : image[i]=(Cell)CA(CF(image[i]));
...@@ -96,7 +96,7 @@ Cell *loader(FILE *imagefile) ...@@ -96,7 +96,7 @@ Cell *loader(FILE *imagefile)
do do
{ {
if(fread(magic,sizeof(Char),8,imagefile) < 8) { if(fread(magic,sizeof(Char),8,imagefile) < 8) {
fprintf(stderr,"This file doesn't seam to be a gforth image\n"); fprintf(stderr,"This file doesn't seem to be a gforth image\n");
exit(1); exit(1);
} }
#ifdef DEBUG #ifdef DEBUG
...@@ -154,7 +154,7 @@ int go_forth(Cell *image, int stack, Cell *entries) ...@@ -154,7 +154,7 @@ int go_forth(Cell *image, int stack, Cell *entries)
Address lp=(Address)((void *)sp+lsize); Address lp=(Address)((void *)sp+lsize);
Float *fp=(Float *)((void *)lp+fsize); Float *fp=(Float *)((void *)lp+fsize);
Cell *rp=(Cell*)((void *)fp+rsize); Cell *rp=(Cell*)((void *)fp+rsize);
Xt *ip=(Xt *)(image[3]); Xt *ip=(Xt *)((Cell)image[3]);
int throw_code; int throw_code;
for(;stack>0;stack--) for(;stack>0;stack--)
......
...@@ -42,9 +42,9 @@ here normal-dp ! ...@@ -42,9 +42,9 @@ here normal-dp !
tudp H @ minimal udp ! tudp H @ minimal udp !
decimal decimal
\ 64 KB 0 cells ! \ total Space... defined above! \ 64 KB 0 cells ! \ total Space... defined above!
here 1 cells ! \ Size of the system here 1 cells ! \ Size of the system
16 KB 2 cells ! \ Return and fp stack size 16 KB 2 cells ! \ Return and fp stack size
' boot >body 3 cells ! \ Entry point ' boot >body 3 cells ! \ Entry point
UNLOCK Tlast @ UNLOCK Tlast @
...@@ -52,11 +52,16 @@ LOCK ...@@ -52,11 +52,16 @@ LOCK
1 cells - dup forth-wordlist ! Last ! 1 cells - dup forth-wordlist ! Last !
.unresolved .unresolved
cr cr cr cr
bigendian [IF] cell bigendian
save-cross kernl32b.fi [IF]
dup 2 = [IF] save-cross kernl16b.fi [THEN]
dup 4 = [IF] save-cross kernl32b.fi [THEN]
dup 8 = [IF] save-cross kernl64b.fi [THEN]
[ELSE] [ELSE]
save-cross kernl32l.fi dup 2 = [IF] save-cross kernl16l.fi [THEN]
[THEN] cr dup 4 = [IF] save-cross kernl32l.fi [THEN]
dup 8 = [IF] save-cross kernl64l.fi [THEN]
[THEN] drop cr
bye bye
...@@ -96,12 +96,12 @@ NEXT1; ...@@ -96,12 +96,12 @@ NEXT1;
branch-lp+!# -- new branch_lp_plus_store_number branch-lp+!# -- new branch_lp_plus_store_number
/* this will probably not be used */ /* this will probably not be used */
branch_adjust_lp: branch_adjust_lp:
lp += (int)(ip[1]); lp += (Cell)(ip[1]);
goto branch; goto branch;
branch -- fig branch -- fig
branch: branch:
ip = (Xt *)(((int)ip)+(int)*ip); ip = (Xt *)(((Cell)ip)+(Cell)*ip);
: :
r> dup @ + >r ; r> dup @ + >r ;
...@@ -149,7 +149,7 @@ if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ ...@@ -149,7 +149,7 @@ if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */
|| (olddiff^n)>=0 /* it is a wrap-around effect */) { || (olddiff^n)>=0 /* it is a wrap-around effect */) {
#else #else
#ifndef MAXINT #ifndef MAXINT
#define MAXINT ((1<<(8*sizeof(Cell)-1))-1) #define MAXINT ((((Cell)1)<<(8*sizeof(Cell)-1))-1)
#endif #endif
if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) { if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {
#endif #endif
...@@ -852,7 +852,7 @@ while(a_addr != NULL) ...@@ -852,7 +852,7 @@ while(a_addr != NULL)
(hashkey) c_addr u1 -- u2 new paren_hashkey (hashkey) c_addr u1 -- u2 new paren_hashkey
u2=0; u2=0;
while(u1--) while(u1--)
u2+=(int)toupper(*c_addr++); u2+=(Cell)toupper(*c_addr++);
: :
0 -rot bounds ?DO I c@ toupper + LOOP ; 0 -rot bounds ?DO I c@ toupper + LOOP ;
...@@ -944,7 +944,7 @@ wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf)); ...@@ -944,7 +944,7 @@ wior = FILEEXIST(fstat(fileno((FILE *)wfileid), &buf));
ud = buf.st_size; ud = buf.st_size;
resize-file ud wfileid -- wior file resize_file resize-file ud wfileid -- wior file resize_file
wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (int)ud)); wior = FILEIO(ftruncate(fileno((FILE *)wfileid), (Cell)ud));
read-file c_addr u1 wfileid -- u2 wior file read_file read-file c_addr u1 wfileid -- u2 wior file read_file
/* !! fread does not guarantee enough */ /* !! fread does not guarantee enough */
...@@ -1121,7 +1121,7 @@ switch(number[u-1]) ...@@ -1121,7 +1121,7 @@ switch(number[u-1])
} }
number[u]='\0'; number[u]='\0';
r=strtod(number,&endconv); r=strtod(number,&endconv);
if((flag=FLAG(!(int)*endconv))) if((flag=FLAG(!(Cell)*endconv)))
{ {
IF_FTOS(fp[0] = FTOS); IF_FTOS(fp[0] = FTOS);
fp += -1; fp += -1;
...@@ -1131,7 +1131,7 @@ else if(*endconv=='d' || *endconv=='D') ...@@ -1131,7 +1131,7 @@ else if(*endconv=='d' || *endconv=='D')
{ {
*endconv='E'; *endconv='E';
r=strtod(number,&endconv); r=strtod(number,&endconv);
if((flag=FLAG(!(int)*endconv))) if((flag=FLAG(!(Cell)*endconv)))
{ {
IF_FTOS(fp[0] = FTOS);