Commit 58d3846d authored by anton's avatar anton

Integrated locals (in particular automatic scoping) into the system.

parent 2eacd44a
......@@ -3,7 +3,7 @@
RM = echo 'Trying to remove'
GCC = gcc
CC = gcc
SWITCHES = -DUSE_TOS -DUSE_FTOS -DDEFAULTBIN='"'$(PWD)'"' # -DDIRECT_THREADED
SWITCHES = -D_POSIX_VERSION #-DUSE_TOS -DUSE_FTOS -DDEFAULTBIN='"'$(PWD)'"' # -DDIRECT_THREADED
CFLAGS = -O4 -Wall -g $(SWITCHES)
#-Xlinker -n puts text and data into the same 256M region
......
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.5 1994-06-01 10:05:14 pazsan Exp $
\ $Id: cross.fs,v 1.6 1994-06-17 12:34:58 anton Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -134,7 +134,8 @@ include machine.fs
: cell+ cell + ;
: cells cell<< lshift ;
: chars ;
: floats float * ;
>CROSS
: cell/ cell<< rshift ;
>TARGET
......@@ -488,6 +489,8 @@ Cond: [Char] ( "<char>" -- ) restrict? Char lit, ;Cond
Cond: EXIT ( -- ) restrict? compile ;S ;Cond
Cond: ?EXIT ( -- ) 1 abort" CROSS: using ?exit" ;Cond
Cond: ; ( -- ) restrict?
depth ?dup IF 1- <> ABORT" CROSS: Stack changed"
ELSE true ABORT" CROSS: Stack empty" THEN
......
\ High level floating point 14jan94py
: faligned ( addr -- f-addr )
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
: falign ( -- )
here dup faligned swap
?DO bl c, LOOP ;
: f, ( f -- ) here 1 floats allot f! ;
\ !! have create produce faligned pfas
......
......@@ -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.1 1994-05-07 14:55:53 anton Exp $
;;; $Header: /usr/local/lib/cvs-repository/src-master/gforth/gforth.el,v 1.2 1994-06-17 12:35:01 anton Exp $
;;-------------------------------------------------------------------
;; A Forth indentation, documentation search and interaction library
......@@ -121,6 +121,7 @@ OBS! All words in forth-negatives must be surrounded by spaces.")
(make-local-variable 'parse-sexp-ignore-comments)
(setq parse-sexp-ignore-comments t))
;;;###autoload
(defun forth-mode ()
"
Major mode for editing Forth code. Tab indents for Forth code. Comments
......
......@@ -177,7 +177,7 @@ variable @code{GFORTHPATH}; if this does not exist, in
@node Notation, Arithmetic, Words, Words
@section Notation
The Forth words are describes in this section in the glossary notation
The Forth words are described in this section in the glossary notation
that has become a de-facto standard for Forth texts, i.e.
@quotation
......@@ -320,10 +320,10 @@ theoretically keep floating point numbers on the data stack. As an
additional difficulty, you don't know how many cells a floating point
numkber takes. It is reportedly possible to write words in a way that
they work also for a unified stack model, but we do not recommend trying
it. Also, a Forth system to keep the local variables on the return
stack. This is reasonable, as local variables usually eliminate the need
to use the return stack explicitely. So, if you want to produce a
standard complying program and if you are using local variables in a
it. Also, a Forth system is allowed to keep the local variables on the
return stack. This is reasonable, as local variables usually eliminate
the need to use the return stack explicitely. So, if you want to produce
a standard complying program and if you are using local variables in a
word, forget about return stack manipulations in that word (see the
standard document for the exact rules).
......@@ -417,7 +417,7 @@ IF
@var{code}
ENDIF
@end example
or
@example
@var{flag}
IF
......@@ -527,11 +527,13 @@ index by @var{n} instead of by 1. The loop is terminated when the border
between @var{limit-1} and @var{limit} is crossed. E.g.:
4 0 ?DO i . 2 +LOOP prints 0 2
4 1 ?DO i . 2 +LOOP prints 1 3
The behaviour of @code{@var{n} +LOOP} is peculiar when @var{n} is negative:
-1 0 ?DO i . -1 +LOOP prints 0 -1
0 0 ?DO i . -1 +LOOP prints nothing
Therefore we recommend avoiding using @code{@var{n} +LOOP} with negative
......@@ -539,7 +541,9 @@ Therefore we recommend avoiding using @code{@var{n} +LOOP} with negative
case behaves symmetrical to the positive case:
-2 0 ?DO i . -1 +LOOP prints 0 -1
-1 0 ?DO i . -1 +LOOP prints 0
0 0 ?DO i . -1 +LOOP prints nothing
The loop is terminated when the border between @var{limit-sgn(n)} and
......
This diff is collapsed.
......@@ -717,7 +717,7 @@ install_signal_handlers (void)
but I would like something more automatic - anton */
#define SIGS_TO_IGNORE SIGCHLD
#define SIGS_TO_ABORT SIGINT, SIGILL, SIGFPE, SIGUSR1, SIGSEGV, SIGUSR2, \
SIGALRM, SIGEMT, SIGBUS, SIGSYS
SIGALRM, SIGBUS
#define SIGS_TO_QUIT SIGHUP, SIGQUIT, SIGABRT, SIGPIPE, \
SIGTERM
......
This diff is collapsed.
......@@ -28,18 +28,20 @@ depth . cr
." testing part 2" cr
: xxxx
[ ." starting xxxx" .s cr ]
{ f } f
xif
if
{ a b }
b a
[ ." before else" .s cr ]
xelse
else
[ ." after else" .s cr ]
{ c d }
c d
xthen
then
[ ." locals-size after then:" locals-size @ . cr ]
f drop
[ ." ending xxxx" .s cr ]
;
2 3 1 xxxx . . cr
......@@ -47,25 +49,25 @@ f drop
cr cr cr
: xxx3
xbegin
begin
{ a }
xuntil
until
a
;
." after xxx3" .s cr cr cr
: xxx2
[ ." start of xxx2" .s cr ]
xbegin
begin
[ ." after begin" .s cr ]
{ a }
[ ." after { a }" .s cr ]
1 xwhile
1 while
[ ." after while" .s cr ]
{ b }
a b
[ ." after a" .s cr ]
xrepeat
repeat
[ ." after repeat" .s cr
also locals words previous cr
]
......@@ -75,52 +77,56 @@ a
: xxx4
[ ." before if" localsinfo ]
xif
if
[ ." after if" localsinfo ]
{ a }
[ ." before begin" localsinfo ]
xbegin
begin
[ ." after begin" localsinfo ]
[ 1 cs-roll ]
[ ." before then" localsinfo ]
xthen
then
{ b }
xuntil
until
[ ." after until" localsinfo ]
;
: xxx5
{ a }
xahead
xbegin
ahead
begin
[ ." after begin" localsinfo ]
[ 1 cs-roll ]
xthen
then
[ ." after then" localsinfo ]
xuntil
until
[ ." after until" localsinfo ]
;
." xxx6 coming up" cr
: xxx6
xif
[ ." starting xxx6" localsinfo ]
if
{ x }
xelse
else
[ ." after else" localsinfo ]
xahead
xbegin
ahead
begin
[ ." after begin" localsinfo ]
[ 2 CS-ROLL ] xthen
[ 2 CS-ROLL ] then
[ ." after then" localsinfo ]
xuntil
until
then
[ ." ending xxx6" localsinfo ]
;
." xxx7 coming up" cr
: xxx7
{ b }
xdo
do
{ a }
[ ." before loop" localsinfo ]
xloop
loop
[ ." after loop" localsinfo ]
;
......@@ -128,36 +134,36 @@ xloop
: xxx8
{ b }
x?do
?do
{ a }
[ ." before loop" localsinfo ]
xloop
loop
[ ." after loop" localsinfo ]
;
." xxx9 coming up" cr
: xxx9
{ b }
xdo
do
{ c }
[ ." before ?leave" leave-sp ? leave-stack . cr ]
x?leave
?leave
[ ." after ?leave" leave-sp ? cr ]
{ a }
[ ." before loop" localsinfo ]
xloop
loop
[ ." after loop" localsinfo ]
;
." strcmp coming up" cr
: strcmp { addr1 u1 addr2 u2 -- n }
addr1 addr2 u1 u2 min 0 x?do
addr1 addr2 u1 u2 min 0 ?do
{ s1 s2 }
s1 c@ s2 c@ - ?dup xif
unloop xexit
xthen
s1 c@ s2 c@ - ?dup if
unloop exit
then
s1 char+ s2 char+
xloop
loop
2drop
u1 u2 - ;
......@@ -178,13 +184,13 @@ s" " s" " strcmp . cr
;
: findchar { c addr u -- i }
addr u 0 x?do
addr u 0 ?do
{ p }
p c@ c = xif
p xleave
xthen
p c@ c = if
p leave
then
p char+
xloop
loop
addr - ;
......@@ -213,7 +219,7 @@ testfindchar
: xxx10
[ ." before if" localsinfo ]
xif
if
[ ." after if" localsinfo ]
scope
[ ." after scope" localsinfo ]
......@@ -221,13 +227,27 @@ scope
[ ." before endscope" localsinfo ]
endscope
[ ." before begin" localsinfo ]
xbegin
begin
[ ." after begin" localsinfo ]
[ 1 cs-roll ]
[ ." before then" localsinfo ]
xthen
then
{ b }
xuntil
until
[ ." after until" localsinfo ]
;
: xxx11
if
{ a }
exit
[ ." after xexit" localsinfo ]
else
{ b }
[ ." before xthen" localsinfo
then
[ ." after xthen" localsinfo ]
;
bye
......@@ -4,5 +4,6 @@
2 Constant cell<<
5 Constant cell>bit
8 Constant bits/byte
8 Constant float
true Constant endian
( true=big, false=little )
......@@ -4,5 +4,6 @@
2 Constant cell<<
5 Constant cell>bit
8 Constant bits/byte
8 Constant float
false Constant endian
( true=big, false=little )
/*
$Id: main.c,v 1.5 1994-05-18 17:29:56 pazsan Exp $
$Id: main.c,v 1.6 1994-06-17 12:35:13 anton Exp $
Copyright 1993 by the ANSI figForth Development Group
*/
......@@ -123,6 +123,11 @@ int main(int argc, char **argv, char **env)
Cell environ[3] = {(Cell)argc, (Cell)argv, (Cell)env};
char* imagepath;
#if defined(i386) && defined(ALIGNMENT_CHECK)
/* turn on alignment checks on the 486.
* on the 386 this should have no effect. */
__asm__("pushfl; popl %eax; orl $0x40000, %eax; pushl %eax; popfl;");
#endif
if((int)(imagepath=getenv("FORTHBIN")))
{
strcpy(imagefile,imagepath);
......
......@@ -79,54 +79,62 @@ cfa = xt;
IF_TOS(TOS = sp[0]);
NEXT1;
branch-lp+!# -- new branch_lp_plus_store_number
/* this will probably not be used */
branch_adjust_lp:
lp += (int)(ip[1]);
goto branch;
branch -- fig
branch:
ip = (Xt *)(((int)ip)+(int)*ip);
?branch f -- f83 question_branch
""also known as 0branch""
if (f==0) {
IF_TOS(TOS = sp[0]);
goto branch;
}
\ condbranch(forthname,restline,code)
\ this is non-syntactical: code must open a brace that is close by the macro
define(condbranch,
$1 $2
$3 goto branch;
}
else
ip++;
(next) -- cmFORTH paren_next
if ((*rp)--) {
goto branch;
} else {
ip++;
$1-lp+!# $2_lp_plus_store_number
$3 goto branch_adjust_lp;
}
else
ip+=2;
(loop) -- fig paren_loop
)
condbranch(?branch,f -- f83 question_branch,
if (f==0) {
IF_TOS(TOS = sp[0]);
)
condbranch((next),-- cmFORTH paren_next,
if ((*rp)--) {
)
condbranch((loop),-- fig paren_loop,
int index = *rp+1;
int limit = rp[1];
if (index != limit) {
*rp = index;
goto branch;
} else {
ip++;
}
)
(+loop) n -- fig paren_plus_loop
condbranch((+loop),n -- fig paren_plus_loop,
/* !! check this thoroughly */
int index = *rp;
int olddiff = index-rp[1];
/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
/* dependent upon two's complement arithmetic */
if ((olddiff^(olddiff+n))<0 /* the limit is crossed */
&& (olddiff^n)<0 /* it is not a wrap-around effect */) {
/* break */
ip++;
} else {
/* continue */
if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */
|| (olddiff^n)>=0 /* it is a wrap-around effect */) {
*rp = index+n;
IF_TOS(TOS = sp[0]);
goto branch;
}
)
(s+loop) n -- new paren_symmetric_plus_loop
condbranch((s+loop),n -- new paren_symmetric_plus_loop,
""The run-time procedure compiled by S+LOOP. It loops until the index
crosses the boundary between limit and limit-sign(n). I.e. a symmetric
version of (+LOOP).""
......@@ -141,10 +149,7 @@ if (n<0) {
if (diff>=0 || newdiff<0) {
*rp = oldindex+n;
IF_TOS(TOS = sp[0]);
goto branch;
} else {
ip++;
}
)
unloop -- core
rp += 2;
......@@ -460,14 +465,8 @@ fp! f_addr -- new fp_store
fp = f_addr;
;s -- core exit
/* use ;s as alias */
ip = (Xt *)(*rp++);
?exit w -- core question_exit
/* use ;s as alias */
if(w)
ip = (Xt *)(*rp++);
>r w -- core,fig to_r
*--rp = w;
......@@ -824,7 +823,9 @@ else
represent r c_addr u -- n f1 f2 float
char *sig;
int flag;
sig=ecvt(r, u, (int *)&n, &flag);
int decpt;
sig=ecvt(r, u, &decpt, &flag);
n=decpt;
f1=FLAG(flag!=0);
f2=FLAG(isdigit(sig[0])!=0);
memmove(c_addr,sig,u);
......@@ -960,9 +961,27 @@ c2 = toupper(c1);
@local# -- w new fetch_local_number
w = *(Cell *)(lp+(int)(*ip++));
@local0 -- w new fetch_local_zero
w = *(Cell *)(lp+0);
@local4 -- w new fetch_local_four
w = *(Cell *)(lp+4);
@local8 -- w new fetch_local_eight
w = *(Cell *)(lp+8);
@local12 -- w new fetch_local_twelve
w = *(Cell *)(lp+12);
f@local# -- r new f_fetch_local_number
r = *(Float *)(lp+(int)(*ip++));
f@local0 -- r new f_fetch_local_zero
r = *(Float *)(lp+0);
f@local8 -- r new f_fetch_local_eight
r = *(Float *)(lp+8);
laddr# -- c_addr new laddr_number
/* this can also be used to implement lp@ */
c_addr = (Char *)(lp+(int)(*ip++));
......@@ -973,6 +992,15 @@ local stack, a positive immediate argument drops memory from the local
stack""
lp += (int)(*ip++);
-4lp+! -- new minus_four_lp_plus_store
lp += -4;
8lp+! -- new eight_lp_plus_store
lp += 8;
16lp+! -- new sixteen_lp_plus_store
lp += 16;
lp! c_addr -- new lp_store
lp = (Address)c_addr;
......
......@@ -19,7 +19,7 @@ CREATE Closenest 7 chars allot
IF 2drop 1+
ELSE Closenest count compare 0= IF 1- THEN
THEN
?dup 0= ?EXIT
?dup 0= IF EXIT THEN
REPEAT
2drop refill 0=
UNTIL drop ;
......@@ -45,7 +45,7 @@ CREATE Closenest 7 chars allot
ELSE s" [THEN]" compare 0= IF 1- THEN
THEN
THEN
?dup 0= ?EXIT
?dup 0= IF EXIT THEN
REPEAT
2drop refill 0=
UNTIL drop ; immediate
......
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