Commit 0fc60945 authored by pazsan's avatar pazsan

Corrected bug in error reporting due to input stream restoration

Corrected bug in cross compiler du to later defined constants
renamed search into lookup and implemented the correct "search"
UPS: removed double deferred header and (header) - if problems tell
me why double deferred?
parent 7c037c49
......@@ -4,10 +4,10 @@ RM = echo 'Trying to remove'
GCC = gcc
FORTH = gforth
CC = gcc
SWITCHES = -fforce-addr -fforce-mem -fomit-frame-pointer \
SWITCHES = \
-fno-defer-pop -fcaller-saves \
-D_POSIX_VERSION -DUSE_TOS -DUSE_FTOS -DDEFAULTBIN='"'`pwd`'"' \
-DDIRECT_THREADED #-DNDEBUG #turn off assertions
#-DDIRECT_THREADED #-DNDEBUG #turn off assertions
CFLAGS = -O4 -Wall -g $(SWITCHES)
#-Xlinker -n puts text and data into the same 256M region
......@@ -65,19 +65,19 @@ realclean: distclean
current: $(RCS_FILES)
gforth: $(OBJECTS) $(FORTH_GEN)
-cp gforth gforth.old
-cp gforth gforth~
$(GCC) $(LDFLAGS) $(OBJECTS) $(LDLIBS) -o $@
kernl32l.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach32l.fs $(FORTH_GEN)
-cp kernl32l.fi kernl32l.fi.old
-cp kernl32l.fi kernl32l.fi~
$(FORTH) -e 's" mach32l.fs" r/o open-file throw' main.fs
kernl32b.fi: main.fs search-order.fs cross.fs aliases.fs vars.fs add.fs \
errore.fs kernal.fs extend.fs tools.fs toolsext.fs \
mach32b.fs $(FORTH_GEN)
-cp kernl32b.fi kernl32b.fi.old
-cp kernl32b.fi kernl32b.fi~
$(FORTH) -e 's" mach32b.fs" r/o open-file throw' main.fs
engine.s: engine.c primitives.i prim_labels.i machine.h $(INCLUDES)
......
\ CROSS.FS The Cross-Compiler 06oct92py
\ $Id: cross.fs,v 1.10 1994-08-25 15:25:20 anton Exp $
\ $Id: cross.fs,v 1.11 1994-09-02 15:23:33 pazsan Exp $
\ Idea and implementation: Bernd Paysan (py)
\ Copyright 1992 by the ANSI figForth Development Group
......@@ -220,11 +220,12 @@ Variable atonce atonce off
: >magic ; : >link cell+ ; : >exec cell+ cell+ ;
: >end 3 cells + ;
Variable last-ghost
: Make-Ghost ( "name" -- ghost )
>in @ GhostName swap >in !
<T Create atonce @ IF immediate atonce off THEN
here tuck swap ! ghostheader T>
DOES> >exec @ execute ;
DOES> dup last-ghost ! >exec @ execute ;
\ ghost words 14oct92py
\ changed: 10may93py/jaw
......@@ -298,7 +299,7 @@ variable ResolveFlag
WHILE dup ?resolved
REPEAT drop ResolveFlag @
IF
1 (bye)
abort" Unresolved words!"
ELSE
." Nothing!"
THEN
......@@ -350,7 +351,8 @@ VARIABLE CreateFlag CreateFlag off
VARIABLE ;Resolve 1 cells allot
: Theader ( "name" -- ) (THeader there resolve 0 ;Resolve ! ;
: Theader ( "name" -- ghost )
(THeader dup there resolve 0 ;Resolve ! ;
>TARGET
: Alias ( cfa -- ) \ name
......@@ -487,34 +489,33 @@ Cond: DOES> restrict?
>in @ alias2 swap dup >in ! >r >r
Make-Ghost rot swap >exec ! ,
r> r> >in !
also ghosts ' previous swap !
DOES> dup >exec @ execute ;
also ghosts ' previous swap ! ;
\ DOES> dup >exec @ execute ;
: gdoes, ( ghost -- ) >end @ dup >magic @ <fwd> <>
IF dup >link @ dup 0< IF T A, 0 , H drop EXIT THEN drop THEN
:dodoes T A, H gexecute T here H cell - reloff ;
: TCreate ( ghost -- )
: TCreate ( -- )
last-ghost @
CreateFlag on
Theader dup gdoes,
>end @ >exec @ execute ;
Theader >r dup gdoes,
>end @ >exec @ r> >exec ! ;
: Build: ( -- [xt] [colon-sys] )
:noname postpone TCreate ;
: gdoes> ( ghost -- addr flag )
last-ghost @
state @ IF gexecute true EXIT THEN
cell+ @ T >body H false ;
\ DO: ;DO 11may93jaw
\ changed to ?EXIT 10may93jaw
: (does>) postpone does> ; immediate \ second level does>
: DO: ( -- addr [xt] [colon-sys] )
here ghostheader
:noname
postpone (does>) postpone gdoes> postpone ?EXIT ;
:noname postpone gdoes> postpone ?EXIT ;
: ;DO ( addr [xt] [colon-sys] -- )
postpone ; ( S addr xt )
......@@ -745,6 +746,7 @@ endian Constant endian
: + + ; : 1- 1- ;
: - - ; : 2* 2* ;
: * * ; : / / ;
: dup dup ; : over over ;
: swap swap ; : rot rot ;
......
......@@ -72,6 +72,16 @@ decimal
: erase ( 0 1 chars um/mod nip ) 0 fill ;
: blank ( 0 1 chars um/mod nip ) bl fill ;
\ SEARCH 02sep94py
: search ( buf buflen text textlen -- restbuf restlen flag )
2over 2 pick - 1+ 3 pick c@ >r
BEGIN r@ scan dup WHILE
>r >r 2dup r@ -text
0= IF >r drop 2drop r> r> r> rot + 1- rdrop true EXIT THEN
r> r> 1 /string REPEAT
2drop 2drop rdrop false ;
\ ROLL 17may93jaw
: roll dup 1+ pick >r
......
......@@ -781,8 +781,7 @@ Avariable leave-sp leave-stack 3 cells + leave-sp !
\ information through global variables), but they are useful for dealing
\ with existing/independent defining words
defer (header)
defer header ' (header) IS header
defer header
: name, ( "name" -- )
name c@
......@@ -795,9 +794,9 @@ defer header ' (header) IS header
: input-stream ( -- ) \ general
\ switches back to getting the name from the input stream ;
['] input-stream-header IS (header) ;
['] input-stream-header IS header ;
' input-stream-header IS (header)
' input-stream-header IS header
\ !! make that a 2variable
create nextname-buffer 32 chars allot
......@@ -815,7 +814,7 @@ create nextname-buffer 32 chars allot
dup $1F u> -&19 and throw ( is name too long? )
nextname-buffer c! ( c-addr )
nextname-buffer count move
['] nextname-header IS (header) ;
['] nextname-header IS header ;
: noname-header ( -- )
0 last !
......@@ -823,7 +822,7 @@ create nextname-buffer 32 chars allot
: noname ( -- ) \ general
\ the next defined word remains anonymous. The xt of that word is given by lastxt
['] noname-header IS (header) ;
['] noname-header IS header ;
: lastxt ( -- xt ) \ general
\ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
......@@ -967,11 +966,11 @@ AVariable current
Create f83search ' f83find A, ' (reveal) A, ' drop A,
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
AVariable search G forth-wordlist search T !
AVariable lookup G forth-wordlist lookup T !
G forth-wordlist current T !
: (search-wordlist) ( addr count wid -- nfa / false )
dup ( @ swap ) cell+ @ @ execute ;
dup cell+ @ @ execute ;
: search-wordlist ( addr count wid -- 0 / xt +-1 )
(search-wordlist) dup IF found THEN ;
......@@ -993,7 +992,7 @@ Variable warnings G -1 warnings T !
2drop 2drop ;
: sfind ( c-addr u -- xt n / 0 )
search @ search-wordlist ;
lookup @ search-wordlist ;
: find ( addr -- cfa +-1 / string false )
\ !! not ANS conformant: returns +-2 for restricted words
......@@ -1017,8 +1016,8 @@ Variable warnings G -1 warnings T !
08 constant #bs
09 constant #tab
7F constant #del
0C constant #ff
0D constant #cr \ the newline key code
0C constant #ff
0A constant #lf
: bell #bell emit ;
......@@ -1129,7 +1128,17 @@ create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
loadline @ >r loadfile @ >r
blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ;
: pop-file ( -- ) r>
: pop-file ( throw-code -- throw-code )
dup IF
source >in @ loadline @ loadfilename 2@
error-stack dup @ dup 1+
max-errors 1- min error-stack !
6 * cells + cell+
5 cells bounds swap DO
I !
-1 cells +LOOP
THEN
r>
r> >in ! r> #tib ! r> >tib ! r> blk !
r> loadfile ! r> loadline ! >r ;
......@@ -1139,7 +1148,7 @@ create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
: include-file ( i*x fid -- j*x )
push-file loadfile !
0 loadline ! blk off ['] read-loop catch
loadfile @ close-file
loadfile @ close-file swap
pop-file throw throw ;
: included ( i*x addr u -- j*x )
......@@ -1205,47 +1214,76 @@ Defer .status
\ DOERROR (DOERROR) 13jun93jaw
8 Constant max-errors
Variable error-stack 0 error-stack !
max-errors 6 * cells allot
\ format of one cell:
\ source ( addr u )
\ >in
\ line-number
\ Loadfilename ( addr u )
: 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
bounds ?do
i c@ 9 = if \ check for tab
9
else
bl
then
emit
loop
drop ;
;
DEFER DOERROR
: .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
cr error-stack @
IF
." in file included from "
type ." :" dec. drop 2drop
ELSE
type ." :" dec.
cr dup 2over type cr drop
nip -trailing ( line-start index2 )
0 >r BEGIN
1- 2dup + c@ bl > WHILE
r> 1+ >r dup 0< UNTIL THEN 1+
( line-start index1 )
typewhite
r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
[char] ^ emit
loop
THEN
;
: (DoError) ( throw-code -- )
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 ! ;
loadline @ IF
source >in @ loadline @ 0 0 .error-frame
THEN
error-stack @ 0 ?DO
-1 error-stack +!
error-stack dup @ 6 * cells + cell+
6 cells bounds DO
I @
cell +LOOP
.error-frame
LOOP
dup -2 =
IF
"error @ ?dup
IF
cr count type
THEN
drop
ELSE
.error
THEN
normal-dp dpp ! ;
' (DoError) IS DoError
......
......@@ -80,7 +80,7 @@ Forth-wordlist @ ' Forth >body A!
Only Forth also definitions
search A! \ our dictionary search order becomes the law
lookup A! \ our dictionary search order becomes the law
\ get-order set-order 14may93py
......
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