Commit 202b40f2 authored by pazsan's avatar pazsan

SHARC-porting aids that benefit generally:

Cross: Added non-byte-addressed architectures as possible target (not hosts
yet).
Rest: all types are now Gforth-private types (so you could define as Char
whatever you where like). Some messing around with inabilities of Analog
Devices port of GCC.
parent 636f032e
......@@ -21,15 +21,6 @@
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/* define this if IEEE singles and doubles are available as C data types */
#define IEEE_FP
/* the IEEE types are used only for loading and storing */
/* the IEEE double precision type */
typedef double DFloat;
/* the IEEE single precision type */
typedef float SFloat;
/* define SYSCALL */
#ifndef SYSCALL
......@@ -55,3 +46,27 @@ typedef float SFloat;
we could not use this file in the other machine.h files */
#endif
/* Types: these types are used as Forth's internal types */
/* define this if IEEE singles and doubles are available as C data types */
#define IEEE_FP
/* the IEEE types are used only for loading and storing */
/* the IEEE double precision type */
typedef double DFloat;
/* the IEEE single precision type */
typedef float SFloat;
typedef CELL_TYPE Cell;
typedef unsigned CELL_TYPE UCell;
typedef Cell Bool;
typedef unsigned char Char;
typedef double Float;
typedef Char *Address;
#if defined(DOUBLY_INDIRECT)
typedef void **Label;
#else /* !defined(DOUBLY_INDIRECT) */
typedef void *Label;
#endif /* !defined(DOUBLY_INDIRECT) */
......@@ -85,6 +85,7 @@ case "$ac_cv_sizeof_char_p" in
;;
esac
AC_CHECK_SIZEOF(char)
AC_CHECK_SIZEOF(short)
AC_CHECK_SIZEOF(int)
AC_CHECK_SIZEOF(long)
......@@ -92,11 +93,14 @@ AC_CHECK_SIZEOF(long long)
ac_cv_int_type_cell=none
case "$ac_cv_sizeof_char_p" in
$ac_cv_sizeof_int)
ac_cv_int_type_cell=int
;;
$ac_cv_sizeof_short)
ac_cv_int_type_cell=short
;;
$ac_cv_sizeof_int)
ac_cv_int_type_cell=int
$ac_cv_sizeof_char)
ac_cv_int_type_cell=char
;;
$ac_cv_sizeof_long)
ac_cv_int_type_cell=long
......
......@@ -334,14 +334,16 @@ s" relocate" T environment? H
\ \ Create additional parameters 19jan95py
1 8 lshift Constant maxbyte
T
NIL Constant TNIL
cell Constant tcell
cell<< Constant tcell<<
cell>bit Constant tcell>bit
bits/byte Constant tbits/byte
bits/byte 8 / Constant tchar
float Constant tfloat
1 bits/byte lshift Constant maxbyte
1 bits/byte lshift Constant tmaxbyte
H
\ Variables 06oct92py
......@@ -589,11 +591,19 @@ bigendian
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: S@ ( addr -- n ) >r 0 0 r> tcell bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
: Sc! ( n addr -- ) >r s>d r> tchar bounds swap 1-
DO maxbyte ud/mod rot I c! -1 +LOOP 2drop ;
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap LOOP d>s ;
[ELSE]
: S! ( n addr -- ) >r s>d r> tcell bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;
: S@ ( addr -- n ) >r 0 0 r> tcell bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
: Sc! ( n addr -- ) >r s>d r> tchar bounds
DO maxbyte ud/mod rot I c! LOOP 2drop ;
: Sc@ ( addr -- n ) >r 0 0 r> tchar bounds swap 1-
DO maxbyte * swap maxbyte um* rot + swap I c@ + swap -1 +LOOP d>s ;
[THEN]
>CROSS
......@@ -629,8 +639,8 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
>TARGET
: @ ( taddr -- w ) >image S@ ;
: ! ( w taddr -- ) >image S! ;
: c@ ( taddr -- char ) >image c@ ;
: c! ( char taddr -- ) >image c! ;
: c@ ( taddr -- char ) >image Sc@ ;
: c! ( char taddr -- ) >image Sc! ;
: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
......@@ -640,7 +650,7 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
: here ( -- there ) there ;
: allot ( n -- ) tdp +! ;
: , ( w -- ) T here H tcell T allot ! H T here drop H ;
: c, ( char -- ) T here 1 allot c! H ;
: c, ( char -- ) T here tchar allot c! H ;
: align ( -- ) T here H align+ 0 ?DO bl T c, H LOOP ;
: cfalign ( -- )
T here H cfalign+ 0 ?DO bl T c, H LOOP ;
......@@ -652,9 +662,9 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
: tcmove ( source dest len -- )
\G cmove in target memory
bounds
tchar * bounds
?DO dup T c@ H I T c! H 1+
LOOP drop ;
tchar +LOOP drop ;
>TARGET
H also Forth definitions \ ." asm: " order
......@@ -1263,7 +1273,7 @@ Defer (end-code)
ELSE true ABORT" CROSS: Stack empty" THEN
;
Cond: chars ;Cond
( Cond ) : chars tchar * ; ( Cond )
>CROSS
......
......@@ -24,19 +24,23 @@
#include <stdio.h>
#include <string.h>
#include <math.h>
#include <assert.h>
#include <stdlib.h>
#include <errno.h>
#include "forth.h"
#include "io.h"
#include "threaded.h"
#ifndef STANDALONE
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <assert.h>
#include <stdlib.h>
#include <time.h>
#include <sys/time.h>
#include <unistd.h>
#include <errno.h>
#include <pwd.h>
#include "forth.h"
#include "io.h"
#include "threaded.h"
#else
#include "systypes.h"
#endif
#if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) /* what else? */
#include <dlfcn.h>
......@@ -52,11 +56,11 @@
#define IOR(flag) ((flag)? -512-errno : 0)
typedef struct F83Name {
struct F83Name *next; /* the link field for old hands */
char countetc;
Char name[0];
} F83Name;
struct F83Name {
struct F83Name *next; /* the link field for old hands */
char countetc;
char name[0];
};
/* are macros for setting necessary? */
#define F83NAME_COUNT(np) ((np)->countetc & 0x1f)
......@@ -105,6 +109,12 @@ char *cstr(Char *from, UCell size, int clear)
return b->buffer;
}
#ifdef STANDALONE
char *tilde_cstr(Char *from, UCell size, int clear)
{
return cstr(from, size, clear);
}
#else
char *tilde_cstr(Char *from, UCell size, int clear)
/* like cstr(), but perform tilde expansion on the string */
{
......@@ -146,7 +156,7 @@ char *tilde_cstr(Char *from, UCell size, int clear)
return cstr(path,s1_len+s2_len,clear);
}
}
#endif
#define NEWLINE '\n'
......@@ -231,18 +241,18 @@ Label *engine(Xt *ip0, Cell *sp0, Cell *rp0, Float *fp0, Address lp0)
#else /* !defined(DOUBLY_INDIRECT) */
static Label symbols[]= {
#endif /* !defined(DOUBLY_INDIRECT) */
&&docol,
&&docon,
&&dovar,
&&douser,
&&dodefer,
&&dofield,
&&dodoes,
(Label)&&docol,
(Label)&&docon,
(Label)&&dovar,
(Label)&&douser,
(Label)&&dodefer,
(Label)&&dofield,
(Label)&&dodoes,
/* the following entry is normally unused;
it's there because its index indicates a does-handler */
CPU_DEP1,
#include "prim_lab.i"
0
(Label)0
};
#ifdef CPU_DEP2
CPU_DEP2
......
......@@ -33,12 +33,6 @@
# include <libc.h>
#endif /* NeXT */
#if defined(DOUBLY_INDIRECT)
typedef void **Label;
#else /* !defined(DOUBLY_INDIRECT) */
typedef void *Label;
#endif /* !defined(DOUBLY_INDIRECT) */
/* symbol indexed constants */
#define DOCOL 0
......@@ -57,10 +51,7 @@ typedef void *Label;
/* Forth data types */
/* Cell and UCell must be the same size as a pointer */
typedef CELL_TYPE Cell;
typedef unsigned CELL_TYPE UCell;
#define CELL_BITS (sizeof(Cell) * CHAR_BIT)
typedef Cell Bool;
#define FLAG(b) (-(b))
#define FILEIO(error) (FLAG(error) & -37)
#define FILEEXIST(error) (FLAG(error) & -38)
......@@ -68,10 +59,6 @@ typedef Cell Bool;
#define F_TRUE (FLAG(0==0))
#define F_FALSE (FLAG(0!=0))
typedef unsigned char Char;
typedef double Float;
typedef char *Address;
#ifdef BUGGY_LONG_LONG
typedef struct {
Cell hi;
......@@ -224,7 +211,7 @@ UDCell umdiv (UDCell u, UCell v);
DCell smdiv (DCell num, Cell denom);
DCell fmdiv (DCell num, Cell denom);
int memcasecmp(const char *s1, const char *s2, long n);
Cell memcasecmp(const Char *s1, const Char *s2, Cell n);
extern int offset_image;
extern int die_on_signal;
......
......@@ -19,9 +19,11 @@
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
int memcmp(const char *s1, const char *s2, long n)
#include "forth.h"
Cell memcmp(const Char *s1, const Char *s2, Cell n)
{
int i;
Cell i;
for (i=0; i<n; i++)
if (s1[i] != s2[i])
......
......@@ -24,14 +24,15 @@
have to work with strcoll and some hackery */
#include <ctype.h>
#include "forth.h"
int memcasecmp(const char *s1, const char *s2, long n)
Cell memcasecmp(const Char *s1, const Char *s2, Cell n)
{
int i;
Cell i;
for (i=0; i<n; i++) {
char c1=toupper(s1[i]);
char c2=toupper(s2[i]);
Char c1=toupper(s1[i]);
Char c2=toupper(s2[i]);
if (c1 != c2)
return c1-c2;
}
......
......@@ -19,9 +19,11 @@
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
char *memmove(char *dest, const char *src, long n)
#include "forth.h"
Char *memmove(Char *dest, const Char *src, Cell n)
{
int i;
Cell i;
if (dest<src)
for (i=0; i<n; i++)
......
......@@ -1177,7 +1177,7 @@ c_addr2 = c_addr1+1;
dup 1+ swap c@ ;
(f83find) c_addr u f83name1 -- f83name2 new paren_f83find
for (; f83name1 != NULL; f83name1 = f83name1->next)
for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
if ((UCell)F83NAME_COUNT(f83name1)==u &&
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;
......@@ -1194,11 +1194,11 @@ f83name2=f83name1;
\+has? hash [IF]
(hashfind) c_addr u a_addr -- f83name2 new paren_hashfind
F83Name *f83name1;
struct F83Name *f83name1;
f83name2=NULL;
while(a_addr != NULL)
{
f83name1=(F83Name *)(a_addr[1]);
f83name1=(struct F83Name *)(a_addr[1]);
a_addr=(Cell *)(a_addr[0]);
if ((UCell)F83NAME_COUNT(f83name1)==u &&
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
......@@ -1217,11 +1217,11 @@ while(a_addr != NULL)
(tablefind) c_addr u a_addr -- f83name2 new paren_tablefind
""A case-sensitive variant of @code{(hashfind)}""
F83Name *f83name1;
struct F83Name *f83name1;
f83name2=NULL;
while(a_addr != NULL)
{
f83name1=(F83Name *)(a_addr[1]);
f83name1=(struct F83Name *)(a_addr[1]);
a_addr=(Cell *)(a_addr[0]);
if ((UCell)F83NAME_COUNT(f83name1)==u &&
memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
......@@ -1531,7 +1531,6 @@ reposition-file ud wfileid -- wior file reposition_file
wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);
file-size wfileid -- ud wior file file_size
#include <sys/stat.h>
struct stat buf;
wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
ud = LONG2UD(buf.st_size);
......
......@@ -466,7 +466,7 @@ s" DFloat *" single-type starts-with df_
s" SFloat *" single-type starts-with sf_
s" Xt" single-type starts-with xt
s" WID" single-type starts-with wid
s" F83Name *" single-type starts-with f83name
s" struct F83Name *" single-type starts-with f83name
set-current
......@@ -645,7 +645,7 @@ set-current
cr ;
: output-label ( -- )
." &&I_" c-name 2@ type ." ," cr ;
." (Label)&&I_" c-name 2@ type ." ," cr ;
: output-alias ( -- ) flush-comment on
?flush-comment
......
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