Commit 66973606 authored by anton's avatar anton

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
parent b87c1393
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
......
......@@ -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
......
\ 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 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
......
\ 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
/*
$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();
......
......@@ -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: "
......
/*
$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 */
......
......@@ -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)
......
......@@ -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
......@@ -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);
}
......
/* 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 */
......
......@@ -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!
......
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
[ ." after a" .s cr ]
repeat
[ ." after repeat" .s cr
......@@ -249,5 +250,33 @@ until
[ ." after xthen" localsinfo ]
;
." strcmp1 coming up" cr
: strcmp1 { addr1 u1 addr2 u2 -- n }
u1 u2 min 0 ?do
addr1 c@ addr2 c@ - ?dup if
unloop exit
then
addr1 char+ TO addr1
addr2 char+ TO addr2
loop
u1 u2 - ;
: teststrcmp1
." lp@:" lp@ . cr
s" xxx" s" yyy" strcmp1 . cr
." lp@:" lp@ . cr
s" xxx" s" xxx" strcmp1 . cr
." lp@:" lp@ . cr
s" xxx" s" xxxx" strcmp1 . cr
." lp@:" lp@ . cr
s" xxx3" s" xxx2" strcmp1 . cr
." lp@:" lp@ . cr
s" " s" " strcmp1 . cr
." lp@:" lp@ . cr
." lp@:" lp@ . cr
." stack:" .s cr
;
teststrcmp1
bye
/*
$Id: main.c,v 1.6 1994-06-17 12:35:13 anton Exp $
$Id: main.c,v 1.7 1994-07-08 15:00:55 anton Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
......@@ -15,6 +15,9 @@
#include "forth.h"
#include "io.h"
Xt *throw_ip;
#ifndef DEFAULTBIN
# define DEFAULTBIN ""
#endif
......@@ -30,6 +33,7 @@
* size of image without stacks and tags (in bytes)
* size of data and FP stack (in bytes)
* pointer to start of code
* pointer into throw (for signal handling)
* data (size in image[1])
* tags (1 bit/data cell)
*
......@@ -108,7 +112,8 @@ int go_forth(int *image, int stack, Cell *entries)
Address lp=(Address)((void *)fp-image[2]);
Cell* sp=(Cell*)((void *)lp-image[2]);
Cell* ip=(Cell*)(image[3]);
throw_ip = (Xt *)(image[4]);
for(;stack>0;stack--)
*--sp=entries[stack-1];
......
......@@ -13,7 +13,7 @@ include cross.fs \ include cross-compiler
decimal
128 KB makekernal , 0 , 0 , 0 A,
128 KB makekernal , 0 , 0 , 0 A, 0 A,
UNLOCK ghost - drop \ ghost must exist because - would be treated as number
LOCK
......@@ -46,7 +46,7 @@ decimal
\ 64 KB 0 cells ! \ total Space... defined above!
here 1 cells ! \ Size of the system
2 KB 2 cells ! \ Return and fp stack size
' boot >body 3 cells ! \ Entry point
' boot >body 3 cells ! \ Entry point