Commit 94db3dc0 authored by pazsan's avatar pazsan

Moved setjmp from engine to go_forth, because the socalled "globbered"

variables where saved in memory (and this slows down everything).
Added global up0 for security (up is globbered).

Added restrict's functionalitz to cross.fs

removed all occurency of cell+ name>, because the bug in name> is
fixed.

Added a dusty workaround at the end of prims2x.fs, because of
strange exceptions.
parent a1e49c02
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.7 1994-07-08 15:00:30 anton Exp $
\ $Id: cross.fs,v 1.8 1994-07-13 19:20:59 pazsan Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -350,7 +350,7 @@ VARIABLE ^imm
^imm @ @ dup <imm> = ?EXIT
<res> <> ABORT" CROSS: Cannot immediate a unresolved word"
<imm> ^imm @ ! ;
: restrict ;
: restrict 40 flag! ;
>CROSS
\ ALIAS2 ansforth conform alias 9may93jaw
......
......@@ -264,4 +264,4 @@ VARIABLE Unnest
: dbg ' NestXT ?EXIT (debug) ;
: test 1 2 4 swap dup . ;
\ : test 1 2 4 swap dup . ;
/*
$Id: engine.c,v 1.10 1994-07-08 15:00:35 anton Exp $
$Id: engine.c,v 1.11 1994-07-13 19:21:02 pazsan Exp $
Copyright 1992 by the ANSI figForth Development Group
*/
......@@ -80,13 +80,15 @@ int emitcounter;
static char* fileattr[6]={"r","rb","r+","r+b","w+","w+b"};
static Address up0=NULL;
Label *engine(Xt *ip, Cell *sp, Cell *rp, Float *fp, Address lp)
/* executes code at ip, if ip!=NULL
returns array of machine code labels (for use in a loader), if ip==NULL
*/
{
Xt cfa;
Address up=NULL;
Address up=up0;
static Label symbols[]= {
&&docol,
&&docon,
......@@ -96,7 +98,6 @@ 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,19 +106,6 @@ 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]);
......
......@@ -385,7 +385,7 @@ variable dead-code \ true if normal code at "here" would be dead
over 0<>
while
over
cell+ name> >body @ max
name> >body @ max
swap @ swap ( get next )
repeat
faligned nip ;
......
/*
$Id: main.c,v 1.7 1994-07-08 15:00:55 anton Exp $
$Id: main.c,v 1.8 1994-07-13 19:21:04 pazsan Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
......@@ -112,6 +112,7 @@ 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]);
int throw_code;
throw_ip = (Xt *)(image[4]);
for(;stack>0;stack--)
......@@ -119,6 +120,16 @@ int go_forth(int *image, int stack, Cell *entries)
install_signal_handlers(); /* right place? */
if ((throw_code=setjmp(throw_jmp_buf))) {
static Cell signal_data_stack[8];
static Cell signal_return_stack[8];
signal_data_stack[7]=throw_code;
return((int)engine(image[4],signal_data_stack+7,
signal_return_stack+8,0,0));
}
return((int)engine(ip,sp,rp,fp,lp));
}
......
......@@ -1023,3 +1023,4 @@ lp -= sizeof(Float);
up! a_addr -- new up_store
up=(char *)a_addr;
up0=(char *)a_addr;
......@@ -543,4 +543,4 @@ set-current
endif
warnings @ if
." ------------ CUT HERE -------------" cr endif
r> primfilter ;
r> [ ] primfilter [ 0 ] ;
......@@ -427,8 +427,8 @@ CREATE C-Table
dup cell+ swap @
dup >r DoTable r> swap IF drop EXIT THEN
Display?
IF look 0= ABORT" SEE: Bua!"
cell+ dup count 31 and rot wordinfo .string bl cemit
IF look 0= IF drop dup 1 cells - @ . \ ABORT" SEE: Bua!"
ELSE dup cell+ count 31 and rot wordinfo .string THEN bl cemit
ELSE drop
THEN ;
......@@ -465,7 +465,7 @@ DEFER dosee
here @ .name cr
here @ dosee ;
: docol S" : " Com# .string
cell+ dup count $1F and 2 pick wordinfo .string bl cemit bl cemit
dup cell+ count $1F and 2 pick wordinfo .string bl cemit bl cemit
( XPos @ ) 2 Level !
name> >body
C-Pass @ DebugMode = IF ScanMode c-pass ! EXIT THEN
......@@ -484,7 +484,7 @@ create wordtypes
0 ,
: (dosee) ( lfa -- )
dup cell+ dup c@ 32 and IF over .name ." is an immediate word" cr THEN
dup dup cell+ c@ 32 and IF over .name ." is an immediate word" cr THEN
wordinfo
wordtypes
BEGIN dup @ dup
......@@ -496,15 +496,14 @@ create wordtypes
' (dosee) IS dosee
: see name find cr 0= IF ." Word unknown" cr drop exit THEN
>name c-init
dosee ;
: xtc ( xt -- ) \ do see at xt
Look 0= ABORT" SEE: No valid XT"
cr c-init
dosee ;
: see name find 0= IF ." Word unknown" cr drop exit THEN
xtc ;
: lfc cr c-init cell+ dosee ;
: nfc cr c-init dosee ;
......
......@@ -13,33 +13,33 @@ INCLUDE look.fs
: alias? ( nfa -- flag )
dup name> look
0= ABORT" WINFO: CFA not found"
cell+
\ cell+
2dup <>
IF nip dup 1 cells - here !
count $1f and here cell+ place true
ELSE 2drop false THEN ;
: var? ( nfa -- flag )
(name>)
cell+ (name>)
>code-address ['] udp >code-address = ;
: con? ( nfa -- flag )
(name>)
cell+ (name>)
>code-address ['] bl >code-address = ;
: does? ( nfa -- flag )
dup (name>)
cell+ dup (name>)
>code-address ['] source >code-address =
dup IF swap (name>) cell+ @ here ! ELSE nip THEN ;
: defered? ( nfa -- flag )
dup does?
IF here @ ['] source cell+ @ =
dup IF swap (name>) >body @ here ! ELSE nip THEN
dup IF swap cell+ (name>) >body @ here ! ELSE nip THEN
ELSE drop false THEN ;
: colon? ( nfa -- flag )
(name>)
cell+ (name>)
>code-address ['] does? >code-address = ;
\ VALUE VCheck
......@@ -76,6 +76,7 @@ INCLUDE look.fs
10 CONSTANT Com# \ Compiler directives : ; POSTPONE
CREATE InfoTable
' Prim? A, Pri# ,
' Alias? A, Ali# ,
' Con? A, Con# ,
' Var? A, Var# ,
......@@ -83,7 +84,6 @@ CREATE InfoTable
' Defered? A, Def# ,
' Does? A, Doe# ,
' Colon? A, Col# ,
' Prim? A, Pri# ,
0 ,
: WordInfo ( nfa --- code )
......
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