version 1.17, 1994/08/31 19:42:48
|
version 1.18, 1994/09/02 15:23:36
|
Line 781 Avariable leave-sp leave-stack 3 cells
|
Line 781 Avariable leave-sp leave-stack 3 cells
|
\ information through global variables), but they are useful for dealing |
\ information through global variables), but they are useful for dealing |
\ with existing/independent defining words |
\ with existing/independent defining words |
|
|
defer (header) |
defer header |
defer header ' (header) IS header |
|
|
|
: name, ( "name" -- ) |
: name, ( "name" -- ) |
name c@ |
name c@ |
Line 795 defer header ' (header) IS header
|
Line 794 defer header ' (header) IS header
|
|
|
: input-stream ( -- ) \ general |
: input-stream ( -- ) \ general |
\ switches back to getting the name from the input stream ; |
\ 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 |
\ !! make that a 2variable |
create nextname-buffer 32 chars allot |
create nextname-buffer 32 chars allot |
Line 815 create nextname-buffer 32 chars allot
|
Line 814 create nextname-buffer 32 chars allot
|
dup $1F 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 c! ( c-addr ) |
nextname-buffer count move |
nextname-buffer count move |
['] nextname-header IS (header) ; |
['] nextname-header IS header ; |
|
|
: noname-header ( -- ) |
: noname-header ( -- ) |
0 last ! |
0 last ! |
Line 823 create nextname-buffer 32 chars allot
|
Line 822 create nextname-buffer 32 chars allot
|
|
|
: noname ( -- ) \ general |
: noname ( -- ) \ general |
\ the next defined word remains anonymous. The xt of that word is given by lastxt |
\ 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 |
: 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 |
\ 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 |
Line 967 AVariable current
|
Line 966 AVariable current
|
Create f83search ' f83find A, ' (reveal) A, ' drop A, |
Create f83search ' f83find A, ' (reveal) A, ' drop A, |
|
|
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL 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 ! |
G forth-wordlist current T ! |
|
|
: (search-wordlist) ( addr count wid -- nfa / false ) |
: (search-wordlist) ( addr count wid -- nfa / false ) |
dup ( @ swap ) cell+ @ @ execute ; |
dup cell+ @ @ execute ; |
|
|
: search-wordlist ( addr count wid -- 0 / xt +-1 ) |
: search-wordlist ( addr count wid -- 0 / xt +-1 ) |
(search-wordlist) dup IF found THEN ; |
(search-wordlist) dup IF found THEN ; |
Line 993 Variable warnings G -1 warnings T !
|
Line 992 Variable warnings G -1 warnings T !
|
2drop 2drop ; |
2drop 2drop ; |
|
|
: sfind ( c-addr u -- xt n / 0 ) |
: sfind ( c-addr u -- xt n / 0 ) |
search @ search-wordlist ; |
lookup @ search-wordlist ; |
|
|
: find ( addr -- cfa +-1 / string false ) |
: find ( addr -- cfa +-1 / string false ) |
\ !! not ANS conformant: returns +-2 for restricted words |
\ !! not ANS conformant: returns +-2 for restricted words |
Line 1017 Variable warnings G -1 warnings T !
|
Line 1016 Variable warnings G -1 warnings T !
|
08 constant #bs |
08 constant #bs |
09 constant #tab |
09 constant #tab |
7F constant #del |
7F constant #del |
0C constant #ff |
|
0D constant #cr \ the newline key code |
0D constant #cr \ the newline key code |
|
0C constant #ff |
0A constant #lf |
0A constant #lf |
|
|
: bell #bell emit ; |
: bell #bell emit ; |
Line 1129 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1128 create nl$ 1 c, A c, 0 c, \ gnu includes
|
loadline @ >r loadfile @ >r |
loadline @ >r loadfile @ >r |
blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >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> >in ! r> #tib ! r> >tib ! r> blk ! |
r> loadfile ! r> loadline ! >r ; |
r> loadfile ! r> loadline ! >r ; |
|
|
Line 1139 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1148 create nl$ 1 c, A c, 0 c, \ gnu includes
|
: include-file ( i*x fid -- j*x ) |
: include-file ( i*x fid -- j*x ) |
push-file loadfile ! |
push-file loadfile ! |
0 loadline ! blk off ['] read-loop catch |
0 loadline ! blk off ['] read-loop catch |
loadfile @ close-file |
loadfile @ close-file swap |
pop-file throw throw ; |
pop-file throw throw ; |
|
|
: included ( i*x addr u -- j*x ) |
: included ( i*x addr u -- j*x ) |
Line 1205 Defer .status
|
Line 1214 Defer .status
|
|
|
\ DOERROR (DOERROR) 13jun93jaw |
\ 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 -- ) |
: dec. ( n -- ) |
\ print value in decimal representation |
\ print value in decimal representation |
base @ decimal swap . base ! ; |
base @ decimal swap . base ! ; |
|
|
: typewhite ( addr u -- ) |
: typewhite ( addr u -- ) |
\ like type, but white space is printed instead of the characters |
\ like type, but white space is printed instead of the characters |
0 ?do |
bounds ?do |
dup i + c@ 9 = if \ check for tab |
i c@ 9 = if \ check for tab |
9 |
9 |
else |
else |
bl |
bl |
then |
then |
emit |
emit |
loop |
loop |
drop ; |
; |
|
|
DEFER DOERROR |
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 -- ) |
: (DoError) ( throw-code -- ) |
LoadFile @ |
loadline @ IF |
IF |
source >in @ loadline @ 0 0 .error-frame |
cr loadfilename 2@ type ." :" Loadline @ dec. |
THEN |
THEN |
error-stack @ 0 ?DO |
cr source type cr |
-1 error-stack +! |
source drop >in @ -trailing ( throw-code line-start index2 ) |
error-stack dup @ 6 * cells + cell+ |
here c@ 1F min dup >r - 0 max ( throw-code line-start index1 ) |
6 cells bounds DO |
typewhite |
I @ |
r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 |
cell +LOOP |
." ^" |
.error-frame |
loop |
LOOP |
dup -2 = |
dup -2 = |
IF |
IF |
"error @ ?dup |
"error @ ?dup |
IF |
IF |
cr count type |
cr count type |
THEN |
THEN |
drop |
drop |
ELSE |
ELSE |
.error |
.error |
THEN |
THEN |
normal-dp dpp ! ; |
normal-dp dpp ! ; |
|
|
' (DoError) IS DoError |
' (DoError) IS DoError |
|
|