pforth: improve 64-bit support

Use CELL instead of 4 in various places.
Fix broken members in c_struct.fth

diff --git a/csrc/pf_guts.h b/csrc/pf_guts.h
index 3667824..c0180c1 100644 (file)
--- a/csrc/pf_guts.h
+++ b/csrc/pf_guts.h
@@ -568,9 +568,12 @@ extern cell_t         gIncludeIndex;
 /* Force Quad alignment. */
 #define QUADUP(x) (((x)+3)&~3)
 
 /* Force Quad alignment. */
 #define QUADUP(x) (((x)+3)&~3)
 

+#ifndef MIN

 #define MIN(a,b)  ( ((a)<(b)) ? (a) : (b) )
 #define MIN(a,b)  ( ((a)<(b)) ? (a) : (b) )

+#endif
+#ifndef MAX

 #define MAX(a,b)  ( ((a)>(b)) ? (a) : (b) )
 #define MAX(a,b)  ( ((a)>(b)) ? (a) : (b) )

-
+#endif

 
 #ifndef TOUCH
     #define TOUCH(argument) ((void)argument)
 
 #ifndef TOUCH
     #define TOUCH(argument) ((void)argument)

diff --git a/csrc/pf_inner.c b/csrc/pf_inner.c
index 8ecdec7..8a31b0e 100644 (file)
--- a/csrc/pf_inner.c
+++ b/csrc/pf_inner.c
@@ -199,11 +199,11 @@ static void TraceNames( ExecToken Token, cell_t Level )
 /* Use local copy of CODE_BASE for speed. */
 #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))
 
 /* Use local copy of CODE_BASE for speed. */
 #define LOCAL_CODEREL_TO_ABS( a ) ((cell_t *) (((cell_t) a) + CodeBase))
 

-static const char *pfSelectFileModeCreate( int fam );
-static const char *pfSelectFileModeOpen( int fam );
+static const char *pfSelectFileModeCreate( cell_t fam );
+static const char *pfSelectFileModeOpen( cell_t fam );

 
 /**************************************************************/
 
 /**************************************************************/

-static const char *pfSelectFileModeCreate( int fam )
+static const char *pfSelectFileModeCreate( cell_t fam )

 {
     const char *famText = NULL;
     switch( fam )
 {
     const char *famText = NULL;
     switch( fam )


@@ -228,7 +228,7 @@ static const char *pfSelectFileModeCreate( int fam )
 }
 
 /**************************************************************/
 }
 
 /**************************************************************/

-static const char *pfSelectFileModeOpen( int fam )
+static const char *pfSelectFileModeOpen( cell_t fam )

 {
     const char *famText = NULL;
     switch( fam )
 {
     const char *famText = NULL;
     switch( fam )

diff --git a/csrc/pf_save.c b/csrc/pf_save.c
index 455b847..ac2c85e 100644 (file)
--- a/csrc/pf_save.c
+++ b/csrc/pf_save.c
@@ -315,7 +315,7 @@ cell_t ffSaveForth( const char *FileName, ExecToken EntryPoint, cell_t NameSize,
 /***************************************************************/
 static int Write32ToFile( FileStream *fid, uint32_t Val )
 {
 /***************************************************************/
 static int Write32ToFile( FileStream *fid, uint32_t Val )
 {

-    int numw;
+    size_t numw;

     uint8_t pad[4];
 
     Write32BigEndian(pad,Val);
     uint8_t pad[4];
 
     Write32BigEndian(pad,Val);


@@ -332,8 +332,8 @@ static cell_t WriteChunkToFile( FileStream *fid, cell_t ID, char *Data, int32_t
 
     EvenNumW = EVENUP(NumBytes);
 
 
     EvenNumW = EVENUP(NumBytes);
 

-    if( Write32ToFile( fid, ID ) < 0 ) goto error;
-    if( Write32ToFile( fid, EvenNumW ) < 0 ) goto error;
+    if( Write32ToFile( fid, (uint32_t)ID ) < 0 ) goto error;
+    if( Write32ToFile( fid, (uint32_t)EvenNumW ) < 0 ) goto error;

 
     numw = sdWriteFile( Data, 1, EvenNumW, fid );
     if( numw != EvenNumW ) goto error;
 
     numw = sdWriteFile( Data, 1, EvenNumW, fid );
     if( numw != EvenNumW ) goto error;

diff --git a/csrc/pf_text.c b/csrc/pf_text.c
index e48e457..03430a7 100644 (file)
--- a/csrc/pf_text.c
+++ b/csrc/pf_text.c
@@ -222,7 +222,7 @@ DBUGX(("ffCompareText: return 0x%x\n", Result ));
 ** Compare two strings, case sensitive.
 ** Return zero if they match, -1 if s1<s2, +1 is s1>s2;
 */
 ** Compare two strings, case sensitive.
 ** Return zero if they match, -1 if s1<s2, +1 is s1>s2;
 */

-cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 )
+cell_t ffCompare( const char *s1, cell_t len1, const char *s2, cell_t len2 )

 {
     cell_t i, result, n, diff;
 
 {
     cell_t i, result, n, diff;
 

diff --git a/csrc/pf_text.h b/csrc/pf_text.h
index 05431d7..9918fe3 100644 (file)
--- a/csrc/pf_text.h
+++ b/csrc/pf_text.h
@@ -54,8 +54,9 @@ void pfReportThrow( ThrowCode code );
 char  *ForthStringToC( char *dst, const char *FString, cell_t dstSize );
 char  *CStringToForth( char *dst, const char *CString, cell_t dstSize  );
 
 char  *ForthStringToC( char *dst, const char *FString, cell_t dstSize );
 char  *CStringToForth( char *dst, const char *CString, cell_t dstSize  );
 

-cell_t ffCompare( const char *s1, cell_t len1, const char *s2, int32_t len2 );
-cell_t ffCompareText( const char *s1, const char *s2, cell_t len );
+cell_t ffCompare(const char *s1, cell_t len1,
+                 const char *s2, cell_t len2 );
+cell_t ffCompareText(const char *s1, const char *s2, cell_t len );

 cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len );
 
 void  DumpMemory( void *addr, cell_t cnt);
 cell_t ffCompareTextCaseN( const char *s1, const char *s2, cell_t len );
 
 void  DumpMemory( void *addr, cell_t cnt);

diff --git a/fth/c_struct.fth b/fth/c_struct.fth
index 78cf163..46651ad 100644 (file)
--- a/fth/c_struct.fth
+++ b/fth/c_struct.fth
@@ -94,13 +94,13 @@ decimal
 : (S+REL!)  ( ptr addr offset -- )  + >r if.use->rel r> ! ;
 
 : compile+!bytes ( offset size -- )
 : (S+REL!)  ( ptr addr offset -- )  + >r if.use->rel r> ! ;
 
 : compile+!bytes ( offset size -- )

-\   ." compile+!bytes ( " over . dup . ." )" cr
+    ." compile+!bytes ( " over . dup . ." )" cr

     swap [compile] literal   \ compile offset into word
     CASE
     cell OF compile (s+!)  ENDOF
     2 OF compile (s+w!)      ENDOF
     1 OF compile (s+c!)      ENDOF
     swap [compile] literal   \ compile offset into word
     CASE
     cell OF compile (s+!)  ENDOF
     2 OF compile (s+w!)      ENDOF
     1 OF compile (s+c!)      ENDOF

-    -4 OF compile (s+rel!)   ENDOF \ 00002
+    -cell OF compile (s+rel!)   ENDOF \ 00002

     -2 OF compile (s+w!)     ENDOF
     -1 OF compile (s+c!)     ENDOF
     true abort" s! - illegal size!"
     -2 OF compile (s+w!)     ENDOF
     -1 OF compile (s+c!)     ENDOF
     true abort" s! - illegal size!"


@@ -110,7 +110,7 @@ decimal
 : !BYTES ( value address size -- )
     CASE
     cell OF ! ENDOF
 : !BYTES ( value address size -- )
     CASE
     cell OF ! ENDOF

-    -4 OF ( aptr addr )  swap if.use->rel swap ! ENDOF \ 00002
+    -cell OF ( aptr addr )  swap if.use->rel swap ! ENDOF \ 00002

     ABS
        2 OF w! ENDOF
        1 OF c! ENDOF
     ABS
        2 OF w! ENDOF
        1 OF c! ENDOF


@@ -137,7 +137,7 @@ decimal
     cell OF @  ENDOF
        2 OF w@      ENDOF
        1 OF c@      ENDOF
     cell OF @  ENDOF
        2 OF w@      ENDOF
        1 OF c@      ENDOF

-      -4 OF @ if.rel->use      ENDOF \ 00002
+      -cell OF @ if.rel->use      ENDOF \ 00002

       -2 OF w@ w->s     ENDOF
       -1 OF c@ b->s     ENDOF
        true abort" s@ - illegal size!"
       -2 OF w@ w->s     ENDOF
       -1 OF c@ b->s     ENDOF
        true abort" s@ - illegal size!"


@@ -152,13 +152,13 @@ decimal
 : (S+W@)  ( addr offset -- val )  + w@ w->s ;
 
 : compile+@bytes ( offset size -- )
 : (S+W@)  ( addr offset -- val )  + w@ w->s ;
 
 : compile+@bytes ( offset size -- )

-\   ." compile+@bytes ( " over . dup . ." )" cr
+   ." compile+@bytes ( " over . dup . ." )" cr

     swap [compile] literal   \ compile offset into word
     CASE
     cell OF compile (s+@)  ENDOF
     2 OF compile (s+uw@)      ENDOF
     1 OF compile (s+uc@)      ENDOF
     swap [compile] literal   \ compile offset into word
     CASE
     cell OF compile (s+@)  ENDOF
     2 OF compile (s+uw@)      ENDOF
     1 OF compile (s+uc@)      ENDOF

-    -4 OF compile (s+rel@)      ENDOF \ 00002
+    -cell OF compile (s+rel@)      ENDOF \ 00002

     -2 OF compile (s+w@)     ENDOF
     -1 OF compile (s+c@)     ENDOF
     true abort" s@ - illegal size!"
     -2 OF compile (s+w@)     ENDOF
     -1 OF compile (s+c@)     ENDOF
     true abort" s@ - illegal size!"


@@ -213,21 +213,28 @@ exists? F* [IF]
 :struct mapper
     long map_l1
     long map_l2
 :struct mapper
     long map_l1
     long map_l2

-    aptr map_a1
-    rptr map_r1
-    flpt map_f1

     short map_s1
     ushort map_s2
     byte map_b1
     ubyte map_b2
     short map_s1
     ushort map_s2
     byte map_b1
     ubyte map_b2

+    aptr map_a1
+    rptr map_r1
+    flpt map_f1

 ;struct
 mapper map1
 
 ;struct
 mapper map1
 

+." compiling TT" cr

 : TT
 : TT

+    123456 map1 s! map_l1
+    map1 s@ map_l1 123456 - abort" map_l1 failed!"
+    987654 map1 s! map_l2
+    map1 s@ map_l2 987654 - abort" map_l2 failed!"
+

     -500 map1 s! map_s1
     -500 map1 s! map_s1

-    map1 s@ map_s1 -500 - abort" map_s1 failed!"
+    map1 s@ map_s1 dup . cr -500 - abort" map_s1 failed!"

     -500 map1 s! map_s2
     map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"
     -500 map1 s! map_s2
     map1 s@ map_s2 -500 $ FFFF and - abort" map_s2 failed!"

+

     -89 map1 s! map_b1
     map1 s@ map_b1 -89 - abort" map_s1 failed!"
     here map1 s! map_r1
     -89 map1 s! map_b1
     map1 s@ map_b1 -89 - abort" map_s1 failed!"
     here map1 s! map_r1

diff --git a/fth/member.fth b/fth/member.fth
index 5aa84bd..7ff61c5 100644 (file)
--- a/fth/member.fth
+++ b/fth/member.fth
@@ -41,12 +41,18 @@ decimal
 ;
 
 \ Variables shared with object oriented code.
 ;
 
 \ Variables shared with object oriented code.

-    VARIABLE OB-STATE  ( Compilation state. )
-    VARIABLE OB-CURRENT-CLASS  ( ABS_CLASS_BASE of current class )
-    1 constant OB_DEF_CLASS   ( defining a class )
-    2 constant OB_DEF_STRUCT  ( defining a structure )
+VARIABLE OB-STATE  ( Compilation state. )
+VARIABLE OB-CURRENT-CLASS  ( ABS_CLASS_BASE of current class )
+1 constant OB_DEF_CLASS   ( defining a class )
+2 constant OB_DEF_STRUCT  ( defining a structure )

 
 

-4 constant OB_OFFSET_SIZE
+\ A member contains:
+\   cell size of data in bytes (1, 2, cell)
+\   cell offset within structure
+
+cell 1- constant CELL_MASK
+cell negate constant -CELL
+cell constant OB_OFFSET_SIZE

 
 : OB.OFFSET@ ( member_def -- offset ) @ ;
 : OB.OFFSET, ( value -- ) , ;
 
 : OB.OFFSET@ ( member_def -- offset ) @ ;
 : OB.OFFSET, ( value -- ) , ;


@@ -60,7 +66,7 @@ decimal
     ABS     ( -- |+-b| )
     ob-current-class @ ( -- b addr-space)
     tuck @          ( as #b c , current space needed )
     ABS     ( -- |+-b| )
     ob-current-class @ ( -- b addr-space)
     tuck @          ( as #b c , current space needed )

-    over 3 and 0=        ( multiple of four? )
+    over CELL_MASK and 0=        ( multiple of cell? )

     IF
         aligned
     ELSE
     IF
         aligned
     ELSE


@@ -147,7 +153,7 @@ decimal
 
 \ Aliases
 : APTR    ( <name> -- ) long ;
 
 \ Aliases
 : APTR    ( <name> -- ) long ;

-: RPTR    ( <name> -- ) -4 bytes ; \ relative relocatable pointer 00001
+: RPTR    ( <name> -- ) -cell bytes ; \ relative relocatable pointer 00001

 : ULONG   ( <name> -- ) long ;
 
 : STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
 : ULONG   ( <name> -- ) long ;
 
 : STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )

diff --git a/fth/misc2.fth b/fth/misc2.fth
index cf20173..09f585f 100644 (file)
--- a/fth/misc2.fth
+++ b/fth/misc2.fth
@@ -118,18 +118,18 @@ variable rand-seed here rand-seed !
 : B->S ( c -- c' , sign extend byte )
     dup $ 80 and
     IF
 : B->S ( c -- c' , sign extend byte )
     dup $ 80 and
     IF

-        $ FFFFFF00 or
+        [ $ 0FF invert ] literal or

     ELSE
     ELSE

-        $ 000000FF and
+        $ 0FF and

     THEN
 ;
     THEN
 ;

-: W->S ( 16bit-signed -- 32bit-signed )
+: W->S ( 16bit-signed -- cell-signed )

     dup $ 8000 and
     dup $ 8000 and

-    if
-        $ FFFF0000 or
+    IF
+        [ $ 0FFFF invert ] literal or

     ELSE
     ELSE

-        $ 0000FFFF and
-    then
+        $ 0FFFF and
+    THEN

 ;
 
 : WITHIN { n1 n2 n3 -- flag }
 ;
 
 : WITHIN { n1 n2 n3 -- flag }

diff --git a/fth/system.fth b/fth/system.fth
index b74c812..bed4334 100644 (file)
--- a/fth/system.fth
+++ b/fth/system.fth
@@ -821,4 +821,6 @@ decimal
 FREEZE    \ prevent forgetting below this point
 
 .( Dictionary compiled, save in "pforth.dic".) cr
 FREEZE    \ prevent forgetting below this point
 
 .( Dictionary compiled, save in "pforth.dic".) cr

+\ 300000 headers-size !
+\ 700000 code-size !

 c" pforth.dic" save-forth
 c" pforth.dic" save-forth