version 1.16, 1994/08/31 16:37:48
|
version 1.17, 1994/08/31 19:42:48
|
Line 756 Avariable leave-sp leave-stack 3 cells
|
Line 756 Avariable leave-sp leave-stack 3 cells
|
: ." state @ IF postpone (.") ," align |
: ." state @ IF postpone (.") ," align |
ELSE [char] " parse type THEN ; immediate |
ELSE [char] " parse type THEN ; immediate |
: ( [char] ) parse 2drop ; immediate |
: ( [char] ) parse 2drop ; immediate |
: \ source >in ! drop ; immediate |
: \ blk @ IF >in @ c/l / 1+ c/l * >in ! EXIT THEN |
|
source >in ! drop ; immediate |
|
|
\ error handling 22feb93py |
\ error handling 22feb93py |
\ 'abort thrown out! 11may93jaw |
\ 'abort thrown out! 11may93jaw |
Line 787 defer header ' (header) IS header
|
Line 788 defer header ' (header) IS header
|
name c@ |
name c@ |
dup $1F u> -&19 and throw ( is name too long? ) |
dup $1F u> -&19 and throw ( is name too long? ) |
1+ chars allot align ; |
1+ chars allot align ; |
|
|
: input-stream-header ( "name" -- ) |
: input-stream-header ( "name" -- ) |
\ !! this is f83-implementation-dependent |
\ !! this is f83-implementation-dependent |
align here last ! -1 A, |
align here last ! -1 A, |
Line 1017 Variable warnings G -1 warnings T !
|
Line 1017 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 |
0A constant #lf |
0A constant #lf |
0C constant #ff |
|
|
|
: bell #bell emit ; |
: bell #bell emit ; |
|
|
Line 1064 Create crtlkeys
|
Line 1064 Create crtlkeys
|
|
|
\ Output 13feb93py |
\ Output 13feb93py |
|
|
DEFER type \ defer type for a output buffer or fast |
Defer type \ defer type for a output buffer or fast |
\ screen write |
\ screen write |
|
|
\ : (type) ( addr len -- ) |
\ : (type) ( addr len -- ) |
\ bounds ?DO I c@ emit LOOP ; |
\ bounds ?DO I c@ emit LOOP ; |
|
|
' (TYPE) IS Type |
' (type) IS Type |
|
|
DEFER Emit |
Defer emit |
|
|
' (Emit) IS Emit |
' (Emit) IS Emit |
|
|
|
Defer key |
|
' (key) IS key |
|
|
\ : form ( -- rows cols ) &24 &80 ; |
\ : form ( -- rows cols ) &24 &80 ; |
\ form should be implemented using TERMCAPS or CURSES |
\ form should be implemented using TERMCAPS or CURSES |
\ : rows form drop ; |
\ : rows form drop ; |
Line 1084 DEFER Emit
|
Line 1087 DEFER Emit
|
\ Query 07apr93py |
\ Query 07apr93py |
|
|
: refill ( -- flag ) |
: refill ( -- flag ) |
|
blk @ IF 1 blk +! true EXIT THEN |
tib /line |
tib /line |
loadfile @ ?dup |
loadfile @ ?dup |
IF \ dup file-position throw linestart 2! |
IF read-line throw |
read-line throw |
|
ELSE loadline @ 0< IF 2drop false EXIT THEN |
ELSE loadline @ 0< IF 2drop false EXIT THEN |
accept true |
accept true |
THEN |
THEN |
1 loadline +! |
1 loadline +! |
swap #tib ! 0 >in ! ; |
swap #tib ! 0 >in ! ; |
|
|
: Query ( -- ) 0 loadfile ! refill drop ; |
: Query ( -- ) loadfile off blk off refill drop ; |
|
|
\ File specifiers 11jun93jaw |
\ File specifiers 11jun93jaw |
|
|
Line 1123 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1126 create nl$ 1 c, A c, 0 c, \ gnu includes
|
\ include-file 07apr93py |
\ include-file 07apr93py |
|
|
: push-file ( -- ) r> |
: push-file ( -- ) r> |
( linestart 2@ >r >r ) 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 ( -- ) r> |
r> >in ! r> #tib ! r> >tib ! r> blk ! |
r> >in ! r> #tib ! r> >tib ! r> blk ! |
r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ; |
r> loadfile ! r> loadline ! >r ; |
|
|
|
: read-loop ( i*x -- j*x ) |
|
BEGIN refill WHILE interpret REPEAT ; |
|
|
: include-file ( i*x fid -- j*x ) |
: include-file ( i*x fid -- j*x ) |
push-file loadfile ! |
push-file loadfile ! |
0 loadline ! blk off |
0 loadline ! blk off ['] read-loop catch |
BEGIN refill WHILE interpret REPEAT |
loadfile @ close-file |
loadfile @ close-file throw |
pop-file throw throw ; |
pop-file ; |
|
|
|
: included ( i*x addr u -- j*x ) |
: included ( i*x addr u -- j*x ) |
loadfilename 2@ >r >r |
loadfilename 2@ >r >r |
Line 1180 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1185 create nl$ 1 c, A c, 0 c, \ gnu includes
|
push-file dup #tib ! >tib @ swap move |
push-file dup #tib ! >tib @ swap move |
>in off blk off loadfile off -1 loadline ! |
>in off blk off loadfile off -1 loadline ! |
|
|
BEGIN interpret >in @ #tib @ u>= UNTIL |
\ BEGIN interpret >in @ #tib @ u>= UNTIL |
|
['] interpret catch |
pop-file ; |
pop-file throw ; |
|
|
|
|
: abort -1 throw ; |
: abort -1 throw ; |