C-based Gforth EC starts to work

arch/generic/machine.h

@@ -86,6 +86,8 @@ typedef void *Label;
 #define HAS_FLOATING
 #define HAS_OS
 #define HAS_DEBUG
+#define HAS_GLOCALS
+#define HAS_HASH
 #ifndef HAS_PEEPHOLE
 #define HAS_PEEPHOLE
 #endif
@@ -95,10 +97,16 @@ typedef void *Label;
 #undef HAS_FLOATING
 #undef HAS_OS
 #undef HAS_DEBUG
+#undef HAS_GLOCALS
+#undef HAS_HASH
+#ifndef PUTC
+# define PUTC(x) putc(x, stdout)
+#endif
+#ifndef TYPE
+# define TYPE(x, l) fwrite(x, l, 1, stdout)
+#endif
 #endif
 #define HAS_DCOMPS
-#define HAS_GLOCALS
-#define HAS_HASH
 #define HAS_XCONDS
 #define HAS_STANDARDTHREADING
 

configure.in

@@ -94,9 +94,19 @@ if test "$enable_ec" = "yes"; then
   echo "defining standalone system"
   AC_DEFINE(STANDALONE,,[Define if you want a Gforth without OS])
   EC_MODE="true"
+  EC="-ec"
+  engine2=""
+  engine_fast2=""
+  no_dynamic="-DNO_DYNAMIC"
+  image_i="image.i"
 else
   echo "defining hosted system"
   EC_MODE="false"
+  EC=""
+  engine2="engine2.o"
+  engine_fast2="engine-fast2.o"
+  no_dynamic=""
+  image_i=""
 fi
 
 #variables mentioned in INSTALL
@@ -145,7 +155,12 @@ test "$GCC" = "yes" || AC_MSG_ERROR(Gforth uses GNU C extensions and requires GC
 
 AC_SUBST(CC)
 AC_SUBST(DEBUGFLAG)
+AC_SUBST(EC)
 AC_SUBST(EC_MODE)
+AC_SUBST(engine2)
+AC_SUBST(engine_fast2)
+AC_SUBST(no_dynamic)
+AC_SUBST(image_i)
 
 #this is used to disable some (not generally essential) part of the
 #Makefile that some makes don't grok.  It would be better to test for
@@ -719,7 +734,9 @@ AC_CHECK_FUNCS(mmap sysconf getpagesize)
 AM_PATH_LISPDIR
 
 kernel_fi=kernl${wordsize}${bytesex}.fi
+include_fi=kernl${wordsize}${bytesex}${EC}.fi
 AC_SUBST(kernel_fi)
+AC_SUBST(include_fi)
 
 #this breaks bindists
 #dnl replace srource directory by absolute value

cross.fs

@@ -1175,6 +1175,7 @@ false DefaultValue header
 false DefaultValue backtrace
 false DefaultValue new-input
 false DefaultValue peephole
+false DefaultValue primcentric
 false DefaultValue abranch
 true DefaultValue f83headerstring
 true DefaultValue control-rack
@@ -2625,7 +2626,7 @@ Cond: [ ( -- ) interpreting-state ;Cond
 
 Defer instant-interpret-does>-hook  ' noop IS instant-interpret-does>-hook
 
-T has? peephole H [IF]
+T has? primcentric H [IF]
 : does-resolved ( ghost -- )
     compile does-exec g>xt T a, H ;
 [ELSE]
@@ -2640,7 +2641,7 @@ T has? peephole H [IF]
 
 >TARGET
 Cond: DOES>
-        T here H [ T has? peephole H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells
+        T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells
         H + alit, compile (does>2) compile ;s
         doeshandler, resolve-does>-part
         ;Cond
@@ -2960,7 +2961,7 @@ DO:  abort" Not in cross mode" ;DO
 \ optimizer for cross
 
 
-T has? peephole H [IF]
+T has? primcentric H [IF]
 
 \ .( loading peephole optimization) cr
 

engine/Makefile.in

@@ -27,8 +27,8 @@ EXE=@EXEEXT@
 # ------------- System specific variables
 
 machine=@machine@
-kernel_fi=@kernel_fi@
-include_fi=gforth.fi
+kernel_fi = @kernel_fi@
+include_fi = @include_fi@
 # this is the type of machine
 # used to extend the include path with ./arch/$machine
 # so we could include a machine specific
@@ -38,6 +38,8 @@ PATHSEP = @PATHSEP@
 
 osclass = @OSCLASS@
 
+EC = @EC@
+
 # ------------- Utility programs
 
 SHELL	= /bin/sh
@@ -79,6 +81,7 @@ CFLAGS	= $(DEBUGFLAG) -I$(srcdir)/../arch/$(machine) -I. -Wall $(SWITCHES) -DDEF
 CFLAGS2	= $(DEBUGFLAG) -I$(srcdir)/../arch/$(machine) -I. -Wall $(SWITCHES) -DDEFAULTPATH='"$(FORTHPATH)"'
 FORTHKFLAGS= --die-on-signal -p "..$(PATHSEP)$(srcdir)" -i ../$(kernel_fi)
 FORTHK	= ../gforth $(FORTHKFLAGS)
+FORTH	= ../gforth --die-on-signal -p "..$(PATHSEP)$(srcdir)" -i ../gforth.fi
 
 #John Wavrik should use -Xlinker -N to get a writable text (executable)
 XLDFLAGS = @LDFLAGS@
@@ -87,9 +90,9 @@ LDLIBS  = @LIBS@
 
 AOBJECTS = io.o signals.o support.o @LIBOBJS@
 
-OBJECTS = engine.o engine2.o main.o
+OBJECTS = engine.o @engine2@ main.o
 OBJECTS_NATIVE = engine-native.o engine-native2.o engine-native3.o main-native.o
-OBJECTS_FAST = engine-fast.o engine-fast2.o main-fast.o
+OBJECTS_FAST = engine-fast.o @engine_fast2@ main-fast.o
 OBJECTS_ITC = engine-itc.o main-itc.o
 OBJECTS_DITC = engine-ditc.o main-ditc.o
 OBJECTS_PROF = engine-prof.o main-prof.o
@@ -98,7 +101,7 @@ OBJECTS_FI =  engine.o main-fi.o
 # In engine subdirectory there are (or should be) only files that belong to
 # our engine, so we can make life easy
 DEPS =  config.h *.h $(srcdir)/../arch/$(machine)/*.[h]
-ENGINE_DEPS = engine.c $(DEPS) prim_lab.i prim.i
+ENGINE_DEPS = engine.c $(DEPS) prim_lab.i prim.i @image_i@
 MAIN_DEPS = main.c $(DEPS) prim_superend.i prim_num.i prim_grp.i costs.i super2.i
 ENGINE_FAST_DEPS = engine.c $(DEPS) prim_lab-fast.i prim-fast.i
 MAIN_FAST_DEPS = main.c $(DEPS) prim_superend-fast.i prim_num-fast.i prim_grp-fast.i costs-fast.i super2-fast.i
@@ -109,25 +112,25 @@ MAIN_FAST_DEPS = main.c $(DEPS) prim_superend-fast.i prim_num-fast.i prim_grp-fa
 
 support.o: support.c config.h forth.h longlong.h
 
-gforth$(EXE):	$(OBJECTS) $(AOBJECTS)
+gforth$(EC)$(EXE):	$(OBJECTS) $(AOBJECTS)
 	$(GCC) $(LDFLAGS) $(OBJECTS) $(AOBJECTS) $(LDLIBS) -o $@
 
-gforth-native$(EXE):	$(OBJECTS_NATIVE) $(AOBJECTS)
+gforth-native$(EC)$(EXE):	$(OBJECTS_NATIVE) $(AOBJECTS)
 	$(GCC) $(LDFLAGS) $(OBJECTS_NATIVE) $(AOBJECTS) $(LDLIBS) -o $@
 
-gforth-fast$(EXE):	$(OBJECTS_FAST) $(AOBJECTS)
+gforth-fast$(EC)$(EXE):	$(OBJECTS_FAST) $(AOBJECTS)
 	$(GCC) $(LDFLAGS) $(OBJECTS_FAST) $(AOBJECTS) $(LDLIBS) -o $@
 
-gforth-itc$(EXE):	$(OBJECTS_ITC) $(AOBJECTS)
+gforth-itc$(EC)$(EXE):	$(OBJECTS_ITC) $(AOBJECTS)
 	$(GCC) $(LDFLAGS) $(OBJECTS_ITC) $(AOBJECTS) $(LDLIBS) -o $@
 
-gforth-ditc$(EXE): $(OBJECTS_DITC) $(AOBJECTS)
+gforth-ditc$(EC)$(EXE): $(OBJECTS_DITC) $(AOBJECTS)
 	$(GCC) $(LDFLAGS) $(OBJECTS_DITC) $(AOBJECTS) $(LDLIBS) -o $@
 
-gforth-prof$(EXE): $(OBJECTS_PROF) $(AOBJECTS) profile.o
+gforth-prof$(EC)$(EXE): $(OBJECTS_PROF) $(AOBJECTS) profile.o
 	$(GCC) $(LDFLAGS) $(OBJECTS_PROF) $(AOBJECTS) profile.o $(LDLIBS) -o $@
 
-gforth-fi$(EXE):	$(OBJECTS_FI) $(AOBJECTS)
+gforth-fi$(EC)$(EXE):	$(OBJECTS_FI) $(AOBJECTS)
 	$(GCC) $(LDFLAGS) $(OBJECTS_FI) $(AOBJECTS) $(LDLIBS) -o $@
 
 engine.s:	$(ENGINE_FAST_DEPS)
@@ -164,7 +167,7 @@ engine-prof.o:	$(ENGINE_DEPS)
 		$(GCC) $(CFLAGS2) $(ENGINE_FLAGS) -DVM_PROFILING -o $@ -c $(srcdir)/engine.c
 
 main.o:		$(MAIN_DEPS) 
-		$(GCC) $(CFLAGS) -DGFORTH_DEBUGGING -o $@ -c $(srcdir)/main.c
+		$(GCC) $(CFLAGS) -DGFORTH_DEBUGGING @no_dynamic@ -o $@ -c $(srcdir)/main.c
 
 main-native.o:	$(MAIN_FAST_DEPS) 
 		$(GCC) $(CFLAGS) -DNO_IP -o $@ -c $(srcdir)/main.c
@@ -222,8 +225,8 @@ stamp-h:	config.h.in ../config.status ../stamp-h.in
 		cd .. && CONFIG_FILES=$@ CONFIG_HEADERS=engine/config.h ./config.status
 		echo timestamp > stamp-h
 
-image.c:	../fi2c.fs ../$(include_fi)
-		$(FORTHK) fi2c.fs -e "s\" ../$(include_fi)\" fi2c bye" >$@
+image.i:	../fi2c.fs ../$(include_fi)
+		$(FORTH) fi2c.fs -e "s\" ../$(include_fi)\" fi2c bye" >$@
 
 ../$(include_fi):	FORCE
 		cd .. && $(MAKE) $(include_fi)

engine/main.c

@@ -641,7 +641,7 @@ void alloc_stacks(ImageHeader * h)
   h->return_stack_size=rsize;
   h->locals_stack_size=lsize;
 
-#if defined(HAVE_MMAP)
+#if defined(HAVE_MMAP) && !defined(STANDALONE)
   if (pagesize > 1) {
     size_t p = pagesize;
     size_t totalsize =
@@ -1105,6 +1105,21 @@ static Address append_prim(Cell p)
 }
 #endif
 
+#ifdef STANDALONE
+Address gforth_alloc(Cell size)
+{
+  Address r;
+  /* leave a little room (64B) for stack underflows */
+  if ((r = malloc(size+64))==NULL) {
+    perror(progname);
+    exit(1);
+  }
+  r = (Address)((((Cell)r)+(sizeof(Float)-1))&(-sizeof(Float)));
+  debugp(stderr, "malloc succeeds, address=$%lx\n", (long)r);
+  return r;
+}
+#endif
+
 int forget_dyncode(Address code)
 {
 #ifdef NO_DYNAMIC
@@ -1740,6 +1755,7 @@ void compile_prim1(Cell *start)
 #endif /* !(defined(DOUBLY_INDIRECT) || defined(INDIRECT_THREADED)) */
 }
 
+#ifndef STANDALONE
 Address gforth_loader(FILE *imagefile, char* filename)
 /* returns the address of the image proper (after the preamble) */
 {
@@ -1862,6 +1878,7 @@ Address gforth_loader(FILE *imagefile, char* filename)
 
   return imp;
 }
+#endif
 
 /* pointer to last '/' or '\' in file, 0 if there is none. */
 static char *onlypath(char *filename)

engine/signals.c

@@ -415,9 +415,11 @@ void install_signal_handlers(void)
     sigstack.ss_flags=0;
     sas_retval=sigaltstack(&sigstack,(stack_t *)0);
   }
+#ifdef HAS_FILE
   if (debug)
     fprintf(stderr,"sigaltstack: %s\n",strerror(sas_retval));
 #endif
+#endif
 
 #define DIM(X)		(sizeof (X) / sizeof *(X))
 /*

engine/support.c

@@ -282,6 +282,7 @@ struct Cellpair parse_white(Char *c_addr1, UCell u1)
   return result;
 }
 
+#ifdef HAS_FILE
 Cell rename_file(Char *c_addr1, UCell u1, Char *c_addr2, UCell u2)
 {
   char *s1=tilde_cstr(c_addr2, u2, 1);
@@ -404,6 +405,7 @@ Cell to_float(Char *c_addr, UCell u, Float *rp)
   *rp = r;
   return flag;
 }
+#endif
 
 Float v_star(Float *f_addr1, Cell nstride1, Float *f_addr2, Cell nstride2, UCell ucount)
 {

fi2c.fs

@@ -49,9 +49,15 @@ Variable env-current
    t-env? dup IF drop THEN ;
 
 ' Value Alias DefaultValue
+' Value Alias SetValue
 
 : kb 1024 * ;
 
+' noop alias T
+' noop alias H
+
+: has?  parse-name 2drop true ;
+
 include machpc.fs
 ENVIRON>
 
@@ -106,27 +112,6 @@ Variable au
     THEN
     dup 1 8 tcell @ * 1- lshift and negate or ;
 
-1 cells 4 = [IF]
-: bswap ( n -- n' )  bswap? @ 0= ?EXIT  0
-    over 24 rshift $FF       and or
-    over  8 rshift $FF00     and or
-    over  8 lshift $FF0000   and or
-    over 24 lshift $FF000000 and or nip ;
-[THEN]
-
-1 cells 8 = [IF]
-: bswap ( n -- n' )  bswap? @ 0= ?EXIT  0
-    over 56 rshift $FF               and or
-    over 40 rshift $FF00             and or
-    over 24 rshift $FF0000           and or
-    over  8 rshift $FF000000         and or
-    over  8 lshift $FF00000000       and or
-    over 24 lshift $FF0000000000     and or
-    over 40 lshift $FF000000000000   and or
-    over 56 lshift $FF00000000000000 and or
-    nip ;
-[THEN]
-
 : search-magic ( fd -- )  >r
     BEGIN  magicbuf 8 r@ read-file throw  8 =  WHILE
 	magicbuf s" Gforth3" tuck str=  UNTIL
@@ -214,7 +199,7 @@ Variable bitmap-chars
 
 : fi2c ( addr u -- )  base @ >r hex
     read-image
-    ." static const void* image[" .imagesize ." ] = {" cr .image ." };" cr
+    ." static void* image[" .imagesize ." ] = {" cr .image ." };" cr
     ." #ifdef USE_RELOC" cr
     ." const char reloc_bits[" .relocsize ." ] = {" cr .reloc ." };" cr
     ." #endif" cr

kernel/io.fs

@@ -65,6 +65,9 @@ Defer emit ( c -- ) \ core
 
 Defer key ( -- char ) \ core
 \G Receive (but do not display) one character, @var{char}.
+: (key) ( -- c ) \ gforth
+    infile-id key-file ;
+: infile-id  stdin ;
 
 [IFDEF] (key) ' (key) IS key [THEN]
 
@@ -74,6 +77,9 @@ Defer key? ( -- flag ) \ facility key-question
 \G yield the character. Once @code{key?} returns true, subsequent
 \G calls to @code{key?} before calling @code{key} or @code{ekey} will
 \G also return true.
+: (key?) ( -- flag ) \ gforth
+    infile-id key?-file ;
+: infile-id  stdin ;
 
 [IFDEF] (key?) ' (key?) IS key? [THEN]
 

machpc.fs.in

@@ -25,7 +25,7 @@ true DefaultValue NIL  \ relocating
 
 @EC_MODE@ DefaultValue ec
 
-has? ec 0= [IF]
+T has? ec H 0= [IF]
 true DefaultValue file		\ controls the presence of the
 				\ file access wordset
 true DefaultValue OS		\ flag to indicate a operating system
@@ -57,6 +57,7 @@ true DefaultValue new-input	\ enables object oriented input
 
 @PEEPHOLEFLAG@ DefaultValue peephole      \ enables peephole optimizer
 
+true DefaultValue primcentric   \ enables primcentric code
 
 true DefaultValue abranch       \ enables absolute branches
 
@@ -76,11 +77,13 @@ false DefaultValue file		\ controls the presence of the
 				\ file access wordset
 false DefaultValue OS		\ flag to indicate a operating system
 
-@FFCALLFLAG@ DefaultValue ffcall \ Foreign Function Calls
+true SetValue relocate
 
-@LIBFFIFLAG@ DefaultValue libffi \ Foreign Function Calls
+false DefaultValue ffcall \ Foreign Function Calls
 
-@OLDCALLFLAG@ DefaultValue oldcall \ old Foreign Function Calls
+false DefaultValue libffi \ Foreign Function Calls
+
+false DefaultValue oldcall \ old Foreign Function Calls
 
 true DefaultValue prims		\ true: primitives are c-code
 
@@ -101,7 +104,9 @@ false DefaultValue backtrace	\ enables backtrace code
 
 false DefaultValue new-input	\ enables object oriented input
 
-@PEEPHOLEFLAG@ DefaultValue peephole      \ enables peephole optimizer
+false DefaultValue peephole     \ enables peephole optimizer
+
+true DefaultValue primcentric   \ enables primcentric code
 
 
 true DefaultValue abranch       \ enables absolute branches
@@ -112,7 +117,7 @@ false DefaultValue crlf
 
 true DefaultValue flash
     
-$100 DefaultValue kernel-start
+$0 DefaultValue kernel-start   \ no artificial offset
 cell 2 = [IF] &32 KB [ELSE] &64 KB [THEN] DefaultValue kernel-size
 
 &1 KB		DefaultValue stack-size

prim

@@ -1642,8 +1642,6 @@ f = key_query((FILE*)wfileid);
 f = key_query(stdin);
 #endif
 
-\+os
-
 stdin	( -- wfileid )	gforth
 ""The standard input file of the Gforth process.""
 wfileid = (Cell)stdin;
@@ -1656,6 +1654,8 @@ stderr	( -- wfileid )	gforth
 ""The standard error output file of the Gforth process.""
 wfileid = (Cell)stderr;
 
+\+os
+
 form	( -- urows ucols )	gforth
 ""The number of lines and columns in the terminal. These numbers may change
 with the window size.""