signals are now translated into THROWs

A number of bug fixes (make a diff of BUGS for details)
added assert.fs and debugging.fs
made .s nicer
keep names of included files (in loadfilename) and print them upon error

BUGS

 The system quits on exceptions like segmentation faults. anton 5oct93
 
-compile does not have its traditional meaning. anton 5oct93
-
-include does not read the last line if it does not end with \n.  anton 6oct93
-
-in decimal mode aaa is accepted as 1110  anton 4feb94
-
-abort" does something to the control flow stack  anton 2mar94
-
-the compiler does not complain about undefined words; instead, it
-complains about unstructured  anton 2mar94
-
-the compiler tries to reveal anonymous words ( -> redefined complaints )  anton 2mar94
-
-'ansforth "include xxx"' gives a segmentation fault after processing
-the file; No segmentation fault when including from the Forth prompt
-anton 2apr94
-
 name> does not take the same argument as e.g. .name. Remedy: add cell+
 before name>, but adapt all uses.  anton 23apr94
 

Makefile

@@ -3,7 +3,7 @@
 RM	= echo 'Trying to remove'
 GCC	= gcc
 CC	= gcc
-SWITCHES = -D_POSIX_VERSION -DDEFAULTBIN='"'$(PWD)'"' -DUSE_TOS -DUSE_FTOS # -DDIRECT_THREADED 
+SWITCHES = -D_POSIX_VERSION -DDEFAULTBIN='"'`pwd`'"' #-DNDEBUG #turn off assertions
 CFLAGS	= -O4 -Wall -g $(SWITCHES)
 
 #-Xlinker -n puts text and data into the same 256M region

assert.fs

+\ assertions
+
+\ !! factor out line number printing, share with debugging.fs
+
+variable assert-level \ all assertions above this level are turned off
+1 assert-level !
+
+: assertn ( n -- )
+    assert-level @ >
+    if
+	POSTPONE (
+    then ;
+
+: assert0( ( -- )
+    0 assertn ; immediate
+: assert1( ( -- )
+    1 assertn ; immediate
+: assert2( ( -- )
+    2 assertn ; immediate
+: assert3( ( -- )
+    3 assertn ; immediate
+: assert( ( -- )
+    POSTPONE assert1( ; immediate
+
+: (endassert) ( flag -- )
+    \ three inline arguments
+    if
+	r> 3 cells + >r EXIT
+    else
+	r>
+	dup 2@ type ." :" cell+ cell+
+	@ 0 .r ." : failed assertion"
+	true abort" assertion failed" \ !! or use a new throw code?
+    then ;
+
+: ) ( -- )
+    POSTPONE (endassert) loadfilename 2@ 2, loadline @ , ; immediate

cross.fs

 \ CROSS.FS     The Cross-Compiler                      06oct92py
-\ $Id: cross.fs,v 1.6 1994-06-17 12:34:58 anton Exp $
+\ $Id: cross.fs,v 1.7 1994-07-08 15:00:30 anton Exp $
 \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group
 
@@ -208,6 +208,8 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
 : !  ( w taddr -- )     >r bswap r> >image ! ;
 : c@ ( taddr -- char )  >image c@ ;
 : c! ( char taddr -- )  >image c! ;
+: 2@ ( taddr -- x1 x2 ) T dup cell+ @ swap @ H ;
+: 2! ( x1 x2 taddr -- ) T swap over ! cell+ ! H ;
 
 \ Target compilation primitives                        06oct92py
 \ included A!                                          16may93jaw

debugging.fs

+\ Simple debugging aids
+
+\ They are meant to support a different style of debugging than the
+\ tracing/stepping debuggers used in languages with long turn-around
+\ times.
+
+\ IMO, a much better (faster) way in fast-compilig languages is to add
+\ printing code at well-selected places, let the program run, look at
+\ the output, see where things went wrong, add more printing code, etc.,
+\ until the bug is found.
+
+\ We support fast insertion and removal of the printing code.
+
+\ !!Warning: the default debugging actions will destroy the contents of pad
+
+
+defer printdebugdata ( -- )
+' .s IS printdebugdata
+defer printdebugline ( addr -- )
+
+: (printdebugline) ( addr -- )
+    cr
+    dup 2@ type ." :" cell+ cell+
+    @ 0 .r ." :"
+    \ it would be nice to print the name of the following word,
+    \ but that's not easily possible for primitives
+    printdebugdata
+    cr ;
+
+' (printdebugline) IS printdebugline
+
+: (~~) ( -- )
+    r@ printdebugline
+    r> 3 cells + >r ;
+
+: ~~ ( -- )
+    POSTPONE (~~) loadfilename 2@ 2, loadline @ , ; immediate
+

engine.c

 /*
-  $Id: engine.c,v 1.9 1994-07-07 14:59:21 pazsan Exp $
+  $Id: engine.c,v 1.10 1994-07-08 15:00:35 anton Exp $
   Copyright 1992 by the ANSI figForth Development Group
 */
 
@@ -96,6 +96,7 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
     &&dodoes,  /* dummy for does handler address */
 #include "prim_labels.i"
   };
+  int throw_code;
   IF_TOS(register Cell TOS;)
   IF_FTOS(Float FTOS;)
 #ifdef CPU_DEP
@@ -105,6 +106,19 @@ Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
   if (ip == NULL)
     return symbols;
   
+  if ((throw_code=setjmp(throw_jmp_buf))) {
+    static Cell signal_data_stack[8];
+
+     /* AFAIK, it's not guarateed that the registers have the right value
+	after a longjump, so we avoid using the current values.
+	If it were guaranteed that the registers keep their values, we could
+	call a signal handler in Forth instead of doing the throw from C */
+    sp = &signal_data_stack[7];
+    TOS = throw_code;
+    ip = throw_ip;
+    NEXT;
+  }
+
   IF_TOS(TOS = sp[0]);
   IF_FTOS(FTOS = fp[0]);
   prep_terminal();

errore.fs

@@ -15,6 +15,7 @@ AVARIABLE ErrLink              \ Linked list entry point
 decimal
 
 -1 ERR" Aborted"
+ErrLink @ unlock reloff lock \ make sure that the terminating 0 is not relocated
 -3 ERR" Stack overflow"                 -4 ERR" Stack underflow"
 -5 ERR" Return stack overflow"          -6 ERR" Return stack undeflow"
 -7 ERR" Do-loops nested too deeply"     -8 ERR" Dictionary overflow"
@@ -46,6 +47,20 @@ decimal
 -55 ERR" Floating-point unidentified fault"
 -56 ERR" QUIT"                          -57 ERR" Error in sending or receiving a character"
 -58 ERR" [IF], [ELSE], [THEN] error"
+\ signals: ( We list them all, execpt those already present, just in case )
+-256 ERR" Hangup signal"
+-257 ERR" Quit signal"
+-258 ERR" Illegal Instruction"
+-259 ERR" Trace Trap"
+-260 ERR" IOT instruction"
+-261 ERR" EMT instruction" \ abort() call?
+-262 ERR" Kill signal" \ cannot be caught but so what
+-263 ERR" Bad arg to system call"
+-264 ERR" Broken pipe"
+-265 ERR" Alarm signal"
+-266 ERR" Terminate signal"
+-267 ERR" User signal 1"
+-268 ERR" User signal 2"
 
 : .error ( n -- )
         cr ." Error: "

forth.h

 /*
-  $Id: forth.h,v 1.6 1994-05-31 07:25:12 benschop Exp $
+  $Id: forth.h,v 1.7 1994-07-08 15:00:39 anton Exp $
   Copyright 1992 by the ANSI figForth Development Group
 */
 
@@ -44,6 +44,7 @@ typedef Label *Xt;
 #endif
 
 Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp);
+extern Xt *throw_ip;
 
 #ifndef DIRECT_THREADED
 /* i.e. indirect threaded */

gforth.el

@@ -16,7 +16,7 @@
 ;; file named COPYING.  Among other things, the copyright notice
 ;; and this notice must be preserved on all copies.
 
-;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.2 1994-06-17 12:35:01 anton Exp $
+;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.3 1994-07-08 15:00:41 anton Exp $
 
 ;;-------------------------------------------------------------------
 ;; A Forth indentation, documentation search and interaction library
@@ -109,13 +109,13 @@ OBS! All words in forth-negatives must be surrounded by spaces.")
   (make-local-variable 'require-final-newline)
   (setq require-final-newline t)
   (make-local-variable 'comment-start)
-  (setq comment-start "( ")
-  (make-local-variable 'comment-end)
-  (setq comment-end " )")
+  (setq comment-start "\\ ")
+  ;(make-local-variable 'comment-end)
+  ;(setq comment-end " )")
   (make-local-variable 'comment-column)
   (setq comment-column 40)
   (make-local-variable 'comment-start-skip)
-  (setq comment-start-skip "( ")
+  (setq comment-start-skip "\\ ")
   (make-local-variable 'comment-indent-hook)
   (setq comment-indent-hook 'forth-comment-indent)
   (make-local-variable 'parse-sexp-ignore-comments)

glocals.fs

@@ -448,6 +448,7 @@ forth definitions
 : (local) ( addr u -- )
     \ a little space-inefficient, but well deserved ;-)
     \ In exchange, there are no restrictions whatsoever on using (local)
+    \ as long as you use it in a definition
     dup
     if
 	nextname POSTPONE { [ also locals-types ] W: } [ previous ]
@@ -455,34 +456,54 @@ forth definitions
 	2drop
     endif ;
 
-\ \ !! untested
-\ : TO ( c|w|d|r "name" -- )
-\ \ !! state smart
-\  0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
-\  ' dup >definer
-\  state @ 
-\  if
-\    case
-\      [ ' locals-wordlist >definer ] literal \ value
-\      OF >body POSTPONE Aliteral POSTPONE ! ENDOF
-\      [ ' clocal >definer ] literal
-\      OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
-\      [ ' wlocal >definer ] literal
-\      OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
-\      [ ' dlocal >definer ] literal
-\      OF POSTPONE laddr# >body @ lp-offset, POSTPONE d! ENDOF
-\      [ ' flocal >definer ] literal
-\      OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
-\      abort" can only store TO value or local value"
-\    endcase
-\  else
-\    [ ' locals-wordlist >definer ] literal =
-\    if
-\      >body !
-\    else
-\      abort" can only store TO value"
-\    endif
-\  endif ;   
+: >definer ( xt -- definer )
+    \ this gives a unique identifier for the way the xt was defined
+    \ words defined with different does>-codes have different definers
+    \ the definer can be used for comparison and in definer!
+    dup >code-address [ ' bits >code-address ] Literal =
+    \ !! this definition will not work on some implementations for `bits'
+    if  \ if >code-address delivers the same value for all does>-def'd words
+	>does-code 1 or \ bit 0 marks special treatment for does codes
+    else
+	>code-address
+    then ;
+
+: definer! ( definer xt -- )
+    \ gives the word represented by xt the behaviour associated with definer
+    over 1 and if
+	does-code!
+    else
+	code-address!
+    then ;
+
+\ !! untested
+: TO ( c|w|d|r "name" -- )
+\ !! state smart
+ 0 0 0. 0.0e0 { c: clocal w: wlocal d: dlocal f: flocal }
+ ' dup >definer
+ state @ 
+ if
+   case
+     [ ' locals-wordlist >definer ] literal \ value
+     OF >body POSTPONE Aliteral POSTPONE ! ENDOF
+     [ ' clocal >definer ] literal
+     OF POSTPONE laddr# >body @ lp-offset, POSTPONE c! ENDOF
+     [ ' wlocal >definer ] literal
+     OF POSTPONE laddr# >body @ lp-offset, POSTPONE ! ENDOF
+     [ ' dlocal >definer ] literal
+     OF POSTPONE laddr# >body @ lp-offset, POSTPONE d! ENDOF
+     [ ' flocal >definer ] literal
+     OF POSTPONE laddr# >body @ lp-offset, POSTPONE f! ENDOF
+     abort" can only store TO value or local value"
+   endcase
+ else
+   [ ' locals-wordlist >definer ] literal =
+   if
+     >body !
+   else
+     abort" can only store TO value"
+   endif
+ endif ; immediate
 
 \ : locals|
 \ !! should lie around somewhere

io.c

@@ -19,6 +19,9 @@
 #endif
 #include <fcntl.h>
 #include <sys/file.h>
+#include <setjmp.h>
+#include "forth.h"
+#include "io.h"
 
 #if defined (__GNUC__)
 #  define alloca __builtin_alloca
@@ -706,7 +709,35 @@ graceful_exit (int sig)
     fprintf (stderr, "\n\n%s.\n", sigmsg (sig));
   else
     fprintf (stderr, "\n\nSignal %d received, terminated.\n", sig);
-  exit (sig);
+  exit (0x80|sig);
+}
+
+jmp_buf throw_jmp_buf;
+
+static void 
+signal_throw(int sig)
+{
+  static int throw_codes[] = {
+    -256,
+    -28,
+    -257,
+    -258,
+    -259,
+    -260,
+    -261,
+    -55,
+    -262,
+    -23,
+    -9,
+    -263,
+    -264,
+    -265,
+    -266,
+    -267,
+    -268,
+  };
+  signal(sig,signal_throw);
+  longjmp(throw_jmp_buf,throw_codes[sig-1]); /* or use siglongjmp ? */
 }
 
 void
@@ -731,7 +762,7 @@ install_signal_handlers (void)
     if (sigs_to_ignore [i])
       signal (sigs_to_ignore [i], SIG_IGN);
   for (i = 0; i < DIM (sigs_to_abort); i++)
-    signal (sigs_to_abort [i], graceful_exit); /* !! change to throw */
+    signal (sigs_to_abort [i], signal_throw); /* !! change to throw */
   for (i = 0; i < DIM (sigs_to_quit); i++)
     signal (sigs_to_quit [i], graceful_exit);
 }

io.h

 /* Input driver header */
 
+#include <setjmp.h>
+
 unsigned char getkey(FILE *);
-int key_avail(FILE *);
+long key_avail(FILE *);
 void prep_terminal();
 void deprep_terminal();
 void install_signal_handlers(void);
 
+extern jmp_buf throw_jmp_buf;
+
 #define key()		getkey(stdin)
 #define key_query	-(!!key_avail(stdin)) /* !! FLAG(...)? - anton */
          		/* flag was originally wrong -- lennart */

kernal.fs

@@ -271,13 +271,14 @@ hex
   r> handler ! rdrop rdrop rdrop 0 ;
 
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
-  ?DUP IF
-    handler @ rp!
-    r> handler !
-    r> lp!
-    r> fp!
-    r> swap >r sp! r>
-  THEN ;
+    ?DUP IF
+	[ here 4 cells ! ]
+	handler @ rp!
+	r> handler !
+	r> lp!
+	r> fp!
+	r> swap >r sp! r>
+    THEN ;
 
 \ Bouncing is very fine,
 \ programming without wasting time...   jaw
@@ -327,9 +328,6 @@ Defer notfound
 
 \ locals stuff needed for control structures
 
-variable locals-size \ this is the current size of the locals stack
-		     \ frame of the current word
-
 : compile-lp+! ( n -- )
     dup negate locals-size +!
     0 over = if
@@ -346,7 +344,7 @@ variable locals-size \ this is the current size of the locals stack
 
 here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs
 AConstant locals-list \ acts like a variable that contains
-		     \ a linear list of locals names
+		      \ a linear list of locals names
 
 
 variable dead-code \ true if normal code at "here" would be dead
@@ -715,7 +713,9 @@ Avariable leave-sp  leave-stack 3 cells + leave-sp !
 
 \ Header states                                        23feb93py
 
-: flag! ( 8b -- )   last @ cell+ tuck c@ xor swap c! ;
+: flag! ( 8b -- )
+    last @ dup 0= abort" last word was headerless"
+    cell+ tuck c@ xor swap c! ;
 : immediate     $20 flag! ;
 : restrict      $40 flag! ;
 \ ' noop alias restrict
@@ -729,7 +729,9 @@ Avariable leave-sp  leave-stack 3 cells + leave-sp !
 defer header
 
 : name,  ( "name" -- )
-    name c@ 1+ chars allot align ;
+    name c@
+    dup $1F u> &-19 and throw ( is name too long? )
+    1+ chars allot align ;
 : input-stream-header ( "name" -- )
     \ !! this is f83-implementation-dependent
     align here last !  -1 A,
@@ -754,7 +756,7 @@ create nextname-buffer 32 chars allot
 
 \ the next name is given in the string
 : nextname ( c-addr u -- ) \ general
-    dup 31 u> -19 and throw ( is name too long? )
+    dup $1F u> &-19 and throw ( is name too long? )
     nextname-buffer c! ( c-addr )
     nextname-buffer count move
     ['] nextname-header IS header ;
@@ -863,7 +865,9 @@ defer ;-hook ( sys2 -- sys1 )
 : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;
   immediate restrict
 
-: :noname ( -- xt colon-sys )  here [ :docol ] Literal cfa, 0 ] :-hook ;
+: :noname ( -- xt colon-sys )
+    0 last !
+    here [ :docol ] Literal cfa, 0 ] :-hook ;
 
 \ Search list handling                                 23feb93py
 
@@ -1026,9 +1030,9 @@ DEFER Emit
         accept true
   THEN
   1 loadline +!
-  swap #tib ! >in off ;
+  swap #tib ! 0 >in ! ;
 
-: Query  ( -- )  loadfile off refill drop ;
+: Query  ( -- )  0 loadfile ! refill drop ;
 
 \ File specifiers                                       11jun93jaw
 
@@ -1069,7 +1073,13 @@ create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
   r> loadfile ! r> loadline ! r> linestart ! ;
 
 : included ( i*x addr u -- j*x )
-  r/o open-file throw include-file ;
+    loadfilename 2@ >r >r
+    dup allocate throw over loadfilename 2!
+    over loadfilename 2@ move
+    r/o open-file throw include-file
+    \ don't free filenames; they don't take much space
+    \ and are used for debugging
+    r> r> loadfilename 2! ;
 
 \ HEX DECIMAL                                           2may93jaw
 
@@ -1087,8 +1097,10 @@ create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
 
 \ RECURSE                                               17may93jaw
 
-: recurse  last @ ( cell+ ) name> a, ; immediate restrict
-\ !! does not work with anonymous words; use lastxt compile,
+: recurse ( -- )
+    lastxt compile, ; immediate restrict
+: recursive ( -- )
+    reveal ; immediate
 
 \ */MOD */                                              17may93jaw
 
@@ -1126,35 +1138,47 @@ Defer .status
 
 \ DOERROR (DOERROR)                                     13jun93jaw
 
+: dec. ( n -- )
+    \ print value in decimal representation
+    base @ decimal swap . base ! ;
+
+: typewhite ( addr u -- )
+    \ like type, but white space is printed instead of the characters
+    0 ?do
+	dup i + c@ 9 = if \ check for tab
+	    9
+	else
+	    bl
+	then
+	emit
+    loop
+    drop ;
+
 DEFER DOERROR
 
 : (DoError) ( throw-code -- )
-         LoadFile @
-         IF
-         	." Error in line: " Loadline @ . cr
-         THEN
-         cr source type cr
-         source drop >in @ -trailing
-         here c@ 1F min dup >r - 1- 0 max nip
-         dup spaces 
-	 IF
-		." ^"
-	 THEN
-	 r> 0 ?DO
-		." -" 
-	 LOOP
-	 ." ^"
-         dup -2 =
-         IF 
-		"error @ ?dup
-		IF
-			cr count type 
-		THEN
-		drop
-         ELSE
-		.error
-	 THEN
-         normal-dp dpp ! ;
+    LoadFile @
+    IF
+	cr loadfilename 2@ type ." :" Loadline @ dec.
+    THEN
+    cr source type cr
+    source drop >in @ -trailing ( throw-code line-start index2 )
+    here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )
+    typewhite
+    r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
+	." ^"
+    loop
+    dup -2 =
+    IF 
+	"error @ ?dup
+	IF
+	    cr count type 
+	THEN
+	drop
+    ELSE
+	.error
+    THEN
+    normal-dp dpp ! ;
 
 ' (DoError) IS DoError
 
@@ -1189,11 +1213,21 @@ Variable argc
 : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;
 
 : cold ( -- )  
-  argc @ 1 >
-  IF  script?
-      IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN
-      catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN
-  ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;
+    argc @ 1 >
+    IF  script?
+	IF
+	    1 arg ['] included
+	ELSE
+	    get-args ['] interpret
+	THEN
+	catch ?dup
+	IF
+	    dup >r DoError cr r> (bye)
+	THEN
+    THEN
+    cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation"
+    cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" 
+    cr quit ;
 
 : boot ( **env **argv argc -- )
   argc ! argv ! env !  main-task up!

locals-test.fs

 include glocals.fs
+include debugging.fs
 
 : localsinfo \ !! only debugging
  ." stack: " .s ." locals-size: " locals-size ? ." locals-list"
@@ -28,20 +29,20 @@ depth . cr
 ." testing part 2" cr
 
 : xxxx
-    [ ." starting xxxx" .s cr ]
+   [ ." starting xxxx" .s cr ]
 { f } f
 if
-  { a b }
-  b a
+ { a b }
+ b a
 [ ." before else" .s cr ]
 else
 [ ." after else" .s cr ]
-  { c d }
-  c d
+ { c d }
+ c d
 then
 [ ." locals-size after then:" locals-size @ . cr ]
-f drop
-    [ ." ending xxxx" .s cr ]
+~~ f ~~ drop
+[ ." ending xxxx" .s cr ]
 ;
 
 2 3 1 xxxx . . cr
@@ -64,8 +65,8 @@ begin
 [ ." after { a }" .s cr ]
 1 while
 [ ." after while" .s cr ]
-  { b }
-  a b
+ { b }
+ a b