|
version 1.8, 1994/06/17 12:35:07
|
version 1.18, 1994/09/02 15:23:36
|
|
Line 79 DOES> ( n -- ) + c@ ;
|
Line 79 DOES> ( n -- ) + c@ ;
|
| \ name> found 17dec92py |
\ name> found 17dec92py |
| |
|
| : (name>) ( nfa -- cfa ) count $1F and + aligned ; |
: (name>) ( nfa -- cfa ) count $1F and + aligned ; |
| : name> ( nfa -- cfa ) |
: name> ( nfa -- cfa ) cell+ |
| dup (name>) swap c@ $80 and 0= IF @ THEN ; |
dup (name>) swap c@ $80 and 0= IF @ THEN ; |
| |
|
| : found ( nfa -- cfa n ) cell+ |
: found ( nfa -- cfa n ) cell+ |
| dup c@ >r (name>) r@ $80 and 0= IF @ THEN |
dup c@ >r (name>) r@ $80 and 0= IF @ THEN |
| \ -1 r@ $40 and IF 1- THEN |
-1 r@ $40 and IF 1- THEN |
| -1 r> $20 and IF negate THEN ; |
r> $20 and IF negate THEN ; |
| |
|
| \ (find) 17dec92py |
\ (find) 17dec92py |
| |
|
|
Line 142 Defer source
|
Line 142 Defer source
|
| dup count chars bounds |
dup count chars bounds |
| ?DO I c@ toupper I c! 1 chars +LOOP ; |
?DO I c@ toupper I c! 1 chars +LOOP ; |
| : (name) ( -- addr ) bl word ; |
: (name) ( -- addr ) bl word ; |
| : (cname) ( -- addr ) bl word capitalize ; |
: sname ( -- c-addr count ) |
| |
source 2dup >r >r >in @ /string (parse-white) |
| |
2dup + r> - 1+ r> min >in ! ; |
| |
\ name count ; |
| |
|
| \ Literal 17dec92py |
\ Literal 17dec92py |
| |
|
|
Line 194 Create bases 10 , 2 , A , 100 ,
|
Line 197 Create bases 10 , 2 , A , 100 ,
|
| \ !! this saving and restoring base is an abomination! - anton |
\ !! this saving and restoring base is an abomination! - anton |
| : getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u< |
: getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u< |
| IF cells bases + @ base ! 1 /string ELSE drop THEN ; |
IF cells bases + @ base ! 1 /string ELSE drop THEN ; |
| : number? ( string -- string 0 / n -1 ) base @ >r |
: s>number ( addr len -- d ) base @ >r dpl on |
| dup count over c@ [char] - = dup >r IF 1 /string THEN |
over c@ '- = dup >r IF 1 /string THEN |
| getbase dpl on 0 0 2swap |
getbase dpl on 0 0 2swap |
| BEGIN dup >r >number dup WHILE dup r> - WHILE |
BEGIN dup >r >number dup WHILE dup r> - WHILE |
| dup dpl ! over c@ [char] . = WHILE |
dup dpl ! over c@ [char] . = WHILE |
| 1 /string |
1 /string |
| REPEAT THEN 2drop 2drop rdrop false r> base ! EXIT THEN |
REPEAT THEN 2drop rdrop dpl off ELSE |
| 2drop rot drop rdrop r> IF dnegate THEN |
2drop rdrop r> IF dnegate THEN |
| dpl @ dup 0< IF nip THEN r> base ! ; |
THEN r> base ! ; |
| |
: snumber? ( c-addr u -- 0 / n -1 / d 0> ) |
| |
s>number dpl @ 0= |
| |
IF |
| |
2drop false EXIT |
| |
THEN |
| |
dpl @ dup 0> 0= IF |
| |
nip |
| |
THEN ; |
| |
: number? ( string -- string 0 / n -1 / d 0> ) |
| |
dup >r count snumber? dup if |
| |
rdrop |
| |
else |
| |
r> swap |
| |
then ; |
| : s>d ( n -- d ) dup 0< ; |
: s>d ( n -- d ) dup 0< ; |
| : number ( string -- d ) |
: number ( string -- d ) |
| number? ?dup 0= abort" ?" 0< IF s>d THEN ; |
number? ?dup 0= abort" ?" 0< IF s>d THEN ; |
|
Line 271 hex
|
Line 288 hex
|
| r> handler ! rdrop rdrop rdrop 0 ; |
r> handler ! rdrop rdrop rdrop 0 ; |
| |
|
| : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) |
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) |
| ?DUP IF |
?DUP IF |
| handler @ rp! |
[ here 4 cells ! ] |
| r> handler ! |
handler @ rp! |
| r> lp! |
r> handler ! |
| r> fp! |
r> lp! |
| r> swap >r sp! r> |
r> fp! |
| THEN ; |
r> swap >r sp! r> |
| |
THEN ; |
| |
|
| \ Bouncing is very fine, |
\ Bouncing is very fine, |
| \ programming without wasting time... jaw |
\ programming without wasting time... jaw |
|
Line 300 hex
|
Line 318 hex
|
| |
|
| Defer parser |
Defer parser |
| Defer name ' (name) IS name |
Defer name ' (name) IS name |
| Defer notfound |
Defer notfound ( c-addr count -- ) |
| |
|
| : no.extensions ( string -- ) IF &-13 bounce THEN ; |
: no.extensions ( addr u -- ) 2drop -&13 bounce ; |
| |
|
| ' no.extensions IS notfound |
' no.extensions IS notfound |
| |
|
| : interpret |
: interpret |
| BEGIN ?stack name dup c@ WHILE parser REPEAT drop ; |
BEGIN |
| |
?stack sname dup |
| \ interpreter compiler 30apr92py |
WHILE |
| |
parser |
| : interpreter ( name -- ) find ?dup |
REPEAT |
| IF 1 and IF execute EXIT THEN -&14 throw THEN |
2drop ; |
| number? 0= IF notfound THEN ; |
|
| |
\ sinterpreter scompiler 30apr92py |
| |
|
| |
: sinterpreter ( c-addr u -- ) |
| |
\ interpretation semantics for the name/number c-addr u |
| |
2dup sfind dup |
| |
IF |
| |
1 and |
| |
IF \ not restricted to compile state? |
| |
nip nip execute EXIT |
| |
THEN |
| |
-&14 throw |
| |
THEN |
| |
drop |
| |
2dup 2>r snumber? |
| |
IF |
| |
2rdrop |
| |
ELSE |
| |
2r> notfound |
| |
THEN ; |
| |
|
| ' interpreter IS parser |
' sinterpreter IS parser |
| |
|
| : compiler ( name -- ) find ?dup |
: scompiler ( c-addr u -- ) |
| IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup |
\ compilation semantics for the name/number c-addr u |
| IF 0> IF swap postpone Literal THEN postpone Literal |
2dup sfind dup |
| ELSE drop notfound THEN ; |
IF |
| |
0> |
| |
IF |
| |
nip nip execute EXIT |
| |
THEN |
| |
compile, 2drop EXIT |
| |
THEN |
| |
drop |
| |
2dup snumber? dup |
| |
IF |
| |
0> |
| |
IF |
| |
swap postpone Literal |
| |
THEN |
| |
postpone Literal |
| |
2drop |
| |
ELSE |
| |
drop notfound |
| |
THEN ; |
| |
|
| : [ ['] interpreter IS parser state off ; immediate |
: [ ['] sinterpreter IS parser state off ; immediate |
| : ] ['] compiler IS parser state on ; |
: ] ['] scompiler IS parser state on ; |
| |
|
| \ locals stuff needed for control structures |
\ locals stuff needed for control structures |
| |
|
| variable locals-size \ this is the current size of the locals stack |
|
| \ frame of the current word |
|
| |
|
| : compile-lp+! ( n -- ) |
: compile-lp+! ( n -- ) |
| dup negate locals-size +! |
dup negate locals-size +! |
| 0 over = if |
0 over = if |
|
Line 346 variable locals-size \ this is the curre
|
Line 398 variable locals-size \ this is the curre
|
| |
|
| here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs |
here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs |
| AConstant locals-list \ acts like a variable that contains |
AConstant locals-list \ acts like a variable that contains |
| \ a linear list of locals names |
\ a linear list of locals names |
| |
|
| |
|
| variable dead-code \ true if normal code at "here" would be dead |
variable dead-code \ true if normal code at "here" would be dead |
|
Line 387 variable dead-code \ true if normal code
|
Line 439 variable dead-code \ true if normal code
|
| over 0<> |
over 0<> |
| while |
while |
| over |
over |
| cell+ name> >body @ max |
name> >body @ max |
| swap @ swap ( get next ) |
swap @ swap ( get next ) |
| repeat |
repeat |
| faligned nip ; |
faligned nip ; |
|
Line 488 variable dead-code \ true if normal code
|
Line 540 variable dead-code \ true if normal code
|
| \ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
| \ better handled by tools like stack checkers |
\ better handled by tools like stack checkers |
| POSTPONE ?dup POSTPONE if ; immediate restrict |
POSTPONE ?dup POSTPONE if ; immediate restrict |
| : ?DUP-NOT-IF \ general |
: ?DUP-0=-IF \ general |
| POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
| |
|
| : THEN ( orig -- ) |
: THEN ( orig -- ) |
|
Line 590 variable dead-code \ true if normal code
|
Line 642 variable dead-code \ true if normal code
|
| \ we have to store more than just the address of the branch, so the |
\ we have to store more than just the address of the branch, so the |
| \ traditional linked list approach is no longer viable. |
\ traditional linked list approach is no longer viable. |
| \ This is solved by storing the information about the leavings in a |
\ This is solved by storing the information about the leavings in a |
| \ special stack. The leavings of different DO-LOOPs are separated |
\ special stack. |
| \ by a 0 entry |
|
| |
|
| \ !! remove the fixed size limit. 'Tis not hard. |
\ !! remove the fixed size limit. 'Tis not hard. |
| 20 constant leave-stack-size |
20 constant leave-stack-size |
| create leave-stack 60 cells allot |
create leave-stack 60 cells allot |
| Avariable leave-sp leave-stack leave-sp ! |
Avariable leave-sp leave-stack 3 cells + leave-sp ! |
| |
|
| : clear-leave-stack ( -- ) |
: clear-leave-stack ( -- ) |
| leave-stack leave-sp ! ; |
leave-stack leave-sp ! ; |
|
Line 617 Avariable leave-sp leave-stack leave-sp
|
Line 668 Avariable leave-sp leave-stack leave-sp
|
| : leave> ( -- orig ) |
: leave> ( -- orig ) |
| \ pop from leave-stack |
\ pop from leave-stack |
| leave-sp @ |
leave-sp @ |
| dup leave-stack <= abort" leave-stack empty" |
dup leave-stack <= IF |
| |
drop 0 0 0 EXIT THEN |
| cell - dup @ swap |
cell - dup @ swap |
| cell - dup @ swap |
cell - dup @ swap |
| cell - dup @ swap |
cell - dup @ swap |
| leave-sp ! ; |
leave-sp ! ; |
| |
|
| : done ( -- ) |
: DONE ( orig -- ) drop >r drop |
| \ !! the original done had ( addr -- ) |
\ !! the original done had ( addr -- ) |
| begin |
begin |
| leave> |
leave> |
| dup |
over r@ u>= |
| while |
while |
| POSTPONE then |
POSTPONE then |
| repeat |
repeat |
| 2drop drop ; immediate |
>leave rdrop ; immediate restrict |
| |
|
| : LEAVE ( -- ) |
: LEAVE ( -- ) |
| POSTPONE ahead |
POSTPONE ahead |
| >leave ; immediate |
>leave ; immediate restrict |
| |
|
| : ?LEAVE ( -- ) |
: ?LEAVE ( -- ) |
| POSTPONE 0= POSTPONE if |
POSTPONE 0= POSTPONE if |
| >leave ; immediate |
>leave ; immediate restrict |
| |
|
| : DO ( -- do-sys ) |
: DO ( -- do-sys ) |
| POSTPONE (do) |
POSTPONE (do) |
| POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
| 0 0 0 >leave ; immediate |
( 0 0 0 >leave ) ; immediate restrict |
| |
|
| : ?DO ( -- do-sys ) |
: ?DO ( -- do-sys ) |
| 0 0 0 >leave |
( 0 0 0 >leave ) |
| POSTPONE (?do) |
POSTPONE (?do) |
| >mark >leave |
>mark >leave |
| POSTPONE begin drop do-dest ; immediate |
POSTPONE begin drop do-dest ; immediate restrict |
| |
|
| : FOR ( -- do-sys ) |
: FOR ( -- do-sys ) |
| POSTPONE (for) |
POSTPONE (for) |
| POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
| 0 0 0 >leave ; immediate |
( 0 0 0 >leave ) ; immediate restrict |
| |
|
| \ LOOP etc. are just like UNTIL |
\ LOOP etc. are just like UNTIL |
| |
|
| : loop-like ( do-sys xt1 xt2 -- ) |
: loop-like ( do-sys xt1 xt2 -- ) |
| rot do-dest? |
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
| until-like POSTPONE done POSTPONE unloop ; |
until-like POSTPONE done POSTPONE unloop ; |
| |
|
| : LOOP ( do-sys -- ) |
: LOOP ( do-sys -- ) |
| ['] (loop) ['] (loop)-lp+!# loop-like ; immediate |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
| |
|
| : +LOOP ( do-sys -- ) |
: +LOOP ( do-sys -- ) |
| ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
| |
|
| \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
| \ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
| \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
| \ negative increments. |
\ negative increments. |
| : S+LOOP ( do-sys -- ) |
: S+LOOP ( do-sys -- ) |
| ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
| |
|
| : NEXT ( do-sys -- ) |
: NEXT ( do-sys -- ) |
| ['] (next) ['] (next)-lp+!# loop-like ; immediate |
['] (next) ['] (next)-lp+!# loop-like ; immediate restrict |
| |
|
| \ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
| |
|
|
Line 704 Avariable leave-sp leave-stack leave-sp
|
Line 756 Avariable leave-sp leave-stack leave-sp
|
| : ." 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 715 Avariable leave-sp leave-stack leave-sp
|
Line 768 Avariable leave-sp leave-stack leave-sp
|
| |
|
| \ Header states 23feb93py |
\ Header states 23feb93py |
| |
|
| : flag! ( 8b -- ) last @ cell+ tuck c@ xor swap c! ; |
: flag! ( 8b -- ) |
| |
last @ dup 0= abort" last word was headerless" |
| |
cell+ tuck c@ xor swap c! ; |
| : immediate $20 flag! ; |
: immediate $20 flag! ; |
| \ : restrict $40 flag! ; |
: restrict $40 flag! ; |
| ' noop alias restrict |
\ ' noop alias restrict |
| |
|
| \ Header 23feb93py |
\ Header 23feb93py |
| |
|
|
Line 729 Avariable leave-sp leave-stack leave-sp
|
Line 784 Avariable leave-sp leave-stack leave-sp
|
| defer header |
defer header |
| |
|
| : name, ( "name" -- ) |
: name, ( "name" -- ) |
| name c@ 1+ chars allot align ; |
name c@ |
| |
dup $1F u> -&19 and throw ( is name too long? ) |
| |
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 754 create nextname-buffer 32 chars allot
|
Line 811 create nextname-buffer 32 chars allot
|
| |
|
| \ the next name is given in the string |
\ the next name is given in the string |
| : nextname ( c-addr u -- ) \ general |
: nextname ( c-addr u -- ) \ general |
| dup 31 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 ; |
|
Line 777 create nextname-buffer 32 chars allot
|
Line 834 create nextname-buffer 32 chars allot
|
| : name>string ( nfa -- addr count ) |
: name>string ( nfa -- addr count ) |
| cell+ count $1F and ; |
cell+ count $1F and ; |
| |
|
| Create ??? ," ???" |
Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
| : >name ( cfa -- nfa ) |
: >name ( cfa -- nfa ) |
| $21 cell do |
$21 cell do |
| dup i - count $9F and + aligned over $80 + = if |
dup i - count $9F and + aligned over $80 + = if |
|
Line 834 Create ??? ," ???"
|
Line 891 Create ??? ," ???"
|
| |
|
| \ IS Defer What's Defers TO 24feb93py |
\ IS Defer What's Defers TO 24feb93py |
| |
|
| : Defer |
: Defer ( -- ) |
| Create ( -- ) |
\ !! shouldn't it be initialized with abort or something similar? |
| ['] noop A, |
Header Reveal [ :dodefer ] Literal cfa, |
| DOES> ( ??? ) |
['] noop A, ; |
| @ execute ; |
\ Create ( -- ) |
| |
\ ['] noop A, |
| |
\ DOES> ( ??? ) |
| |
\ @ execute ; |
| |
|
| : IS ( addr "name" -- ) |
: IS ( addr "name" -- ) |
| ' >body |
' >body |
|
Line 852 Create ??? ," ???"
|
Line 912 Create ??? ," ???"
|
| state @ IF postpone ALiteral postpone @ ELSE @ THEN ; |
state @ IF postpone ALiteral postpone @ ELSE @ THEN ; |
| immediate |
immediate |
| : Defers ( "name" -- ) ' >body @ compile, ; |
: Defers ( "name" -- ) ' >body @ compile, ; |
| immediate restrict |
immediate |
| |
|
| \ : ; 24feb93py |
\ : ; 24feb93py |
| |
|
|
Line 863 defer ;-hook ( sys2 -- sys1 )
|
Line 923 defer ;-hook ( sys2 -- sys1 )
|
| : ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
| immediate restrict |
immediate restrict |
| |
|
| : :noname ( -- xt colon-sys ) here [ :docol ] Literal cfa, 0 ] :-hook ; |
: :noname ( -- xt colon-sys ) |
| |
0 last ! |
| |
here [ :docol ] Literal cfa, 0 ] :-hook ; |
| |
|
| \ Search list handling 23feb93py |
\ Search list handling 23feb93py |
| |
|
|
Line 899 AVariable current
|
Line 961 AVariable current
|
| \ end-struct wordlist-struct |
\ end-struct wordlist-struct |
| |
|
| : f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
| : f83casefind ( addr len wordlist -- nfa / false ) @ (f83casefind) ; |
|
| |
|
| \ Search list table: find reveal |
\ Search list table: find reveal |
| Create f83search ' f83casefind A, ' (reveal) A, ' drop A, |
Create f83search ' f83find A, ' (reveal) A, ' drop A, |
| |
|
| : caps-name ['] (cname) IS name ['] f83find f83search ! ; |
|
| : case-name ['] (name) IS name ['] f83casefind f83search ! ; |
|
| : case-sensitive ['] (name) IS name ['] f83find f83search ! ; |
|
| |
|
| 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 934 Variable warnings G -1 warnings T !
|
Line 991 Variable warnings G -1 warnings T !
|
| then |
then |
| 2drop 2drop ; |
2drop 2drop ; |
| |
|
| : find ( addr -- cfa +-1 / string false ) dup |
: sfind ( c-addr u -- xt n / 0 ) |
| count search @ search-wordlist dup IF rot drop THEN ; |
lookup @ search-wordlist ; |
| |
|
| |
: find ( addr -- cfa +-1 / string false ) |
| |
\ !! not ANS conformant: returns +-2 for restricted words |
| |
dup count sfind dup if |
| |
rot drop |
| |
then ; |
| |
|
| : reveal ( -- ) |
: reveal ( -- ) |
| last? if |
last? if |
|
Line 945 Variable warnings G -1 warnings T !
|
Line 1008 Variable warnings G -1 warnings T !
|
| |
|
| : rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
| |
|
| : ' ( "name" -- addr ) name find 0= no.extensions ; |
: ' ( "name" -- addr ) name find 0= if drop -&13 bounce then ; |
| : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
| \ Input 13feb93py |
\ Input 13feb93py |
| |
|
| 07 constant #bell |
07 constant #bell |
| 08 constant #bs |
08 constant #bs |
| |
09 constant #tab |
| 7F constant #del |
7F constant #del |
| 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 998 Create crtlkeys
|
Line 1063 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 |
|
Line 1018 DEFER type \ defer type for a outpu
|
Line 1086 DEFER type \ defer type for a outpu
|
| \ 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 linestart @ IF 2drop false EXIT THEN |
|
| accept true |
accept true |
| THEN |
THEN |
| 1 loadline +! |
1 loadline +! |
| swap #tib ! >in off ; |
swap #tib ! 0 >in ! ; |
| |
|
| : Query ( -- ) loadfile off refill drop ; |
: Query ( -- ) loadfile off blk off refill drop ; |
| |
|
| \ File specifiers 11jun93jaw |
\ File specifiers 11jun93jaw |
| |
|
|
Line 1056 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1124 create nl$ 1 c, A c, 0 c, \ gnu includes
|
| |
|
| \ include-file 07apr93py |
\ include-file 07apr93py |
| |
|
| : include-file ( i*x fid -- j*x ) |
: push-file ( -- ) r> |
| linestart @ >r loadline @ >r loadfile @ >r |
loadline @ >r loadfile @ >r |
| blk @ >r >tib @ >r #tib @ dup >r >in @ >r |
blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >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 ; |
| |
|
| >tib +! loadfile ! |
: read-loop ( i*x -- j*x ) |
| 0 loadline ! blk off |
BEGIN refill WHILE interpret REPEAT ; |
| BEGIN refill WHILE interpret REPEAT |
|
| loadfile @ close-file throw |
|
| |
|
| r> >in ! r> #tib ! r> >tib ! r> blk ! |
: include-file ( i*x fid -- j*x ) |
| r> loadfile ! r> loadline ! r> linestart ! ; |
push-file loadfile ! |
| |
0 loadline ! blk off ['] read-loop catch |
| |
loadfile @ close-file swap |
| |
pop-file throw throw ; |
| |
|
| : included ( i*x addr u -- j*x ) |
: included ( i*x addr u -- j*x ) |
| r/o open-file throw include-file ; |
loadfilename 2@ >r >r |
| |
dup allocate throw over loadfilename 2! |
| |
over loadfilename 2@ move |
| |
r/o open-file throw include-file |
| |
\ don't free filenames; they don't take much space |
| |
\ and are used for debugging |
| |
r> r> loadfilename 2! ; |
| |
|
| \ HEX DECIMAL 2may93jaw |
\ HEX DECIMAL 2may93jaw |
| |
|
|
Line 1087 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1176 create nl$ 1 c, A c, 0 c, \ gnu includes
|
| |
|
| \ RECURSE 17may93jaw |
\ RECURSE 17may93jaw |
| |
|
| : recurse last @ cell+ name> a, ; immediate restrict |
: recurse ( -- ) |
| \ !! does not work with anonymous words; use lastxt compile, |
lastxt compile, ; immediate restrict |
| |
: recursive ( -- ) |
| |
reveal ; immediate |
| |
|
| \ */MOD */ 17may93jaw |
\ */MOD */ 17may93jaw |
| |
|
| |
\ !! I think */mod should have the same rounding behaviour as / - anton |
| : */mod >r m* r> sm/rem ; |
: */mod >r m* r> sm/rem ; |
| |
|
| : */ */mod nip ; |
: */ */mod nip ; |
|
Line 1099 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1191 create nl$ 1 c, A c, 0 c, \ gnu includes
|
| \ EVALUATE 17may93jaw |
\ EVALUATE 17may93jaw |
| |
|
| : evaluate ( c-addr len -- ) |
: evaluate ( c-addr len -- ) |
| linestart @ >r loadline @ >r loadfile @ >r |
push-file dup #tib ! >tib @ swap move |
| blk @ >r >tib @ >r #tib @ dup >r >in @ >r |
>in off blk off loadfile off -1 loadline ! |
| |
|
| >tib +! dup #tib ! >tib @ swap move |
|
| >in off blk off loadfile off -1 linestart ! |
|
| |
|
| BEGIN interpret >in @ #tib @ u>= UNTIL |
\ BEGIN interpret >in @ #tib @ u>= UNTIL |
| |
['] interpret catch |
| r> >in ! r> #tib ! r> >tib ! r> blk ! |
pop-file throw ; |
| r> loadfile ! r> loadline ! r> linestart ! ; |
|
| |
|
| |
|
| : abort -1 throw ; |
: abort -1 throw ; |
|
Line 1126 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 -- ) |
| |
\ print value in decimal representation |
| |
base @ decimal swap . base ! ; |
| |
|
| |
: typewhite ( addr u -- ) |
| |
\ like type, but white space is printed instead of the characters |
| |
bounds ?do |
| |
i c@ 9 = if \ check for tab |
| |
9 |
| |
else |
| |
bl |
| |
then |
| |
emit |
| |
loop |
| |
; |
| |
|
| 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 |
| ." Error in line: " Loadline @ . cr |
THEN |
| THEN |
error-stack @ 0 ?DO |
| cr source type cr |
-1 error-stack +! |
| source drop >in @ -trailing |
error-stack dup @ 6 * cells + cell+ |
| here c@ 1F min dup >r - 1- 0 max nip |
6 cells bounds DO |
| dup spaces |
I @ |
| IF |
cell +LOOP |
| ." ^" |
.error-frame |
| THEN |
LOOP |
| r> 0 ?DO |
dup -2 = |
| ." -" |
IF |
| LOOP |
"error @ ?dup |
| ." ^" |
IF |
| dup -2 = |
cr count type |
| IF |
THEN |
| "error @ ?dup |
drop |
| IF |
ELSE |
| cr count type |
.error |
| THEN |
THEN |
| drop |
normal-dp dpp ! ; |
| ELSE |
|
| .error |
|
| THEN |
|
| normal-dp dpp ! ; |
|
| |
|
| ' (DoError) IS DoError |
' (DoError) IS DoError |
| |
|
|
Line 1181 Variable env
|
Line 1310 Variable env
|
| Variable argv |
Variable argv |
| Variable argc |
Variable argc |
| |
|
| : get-args ( -- ) #tib off |
0 Value script? ( -- flag ) |
| argc @ 1 ?DO I arg 2dup source + swap move |
|
| #tib +! drop bl source + c! 1 #tib +! LOOP |
: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; |
| >in off #tib @ 0<> #tib +! ; |
|
| |
|
| : script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; |
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
| |
2dup s" -e" compare 0= >r |
| |
2dup s" -evaluate" compare 0= r> or |
| |
IF 2drop ">tib interpret 2 EXIT THEN |
| |
." Unknown option: " type cr 2drop 1 ; |
| |
|
| |
: process-args ( -- ) argc @ 1 |
| |
?DO I arg over c@ [char] - <> |
| |
IF true to script? included false to script? 1 |
| |
ELSE I 1+ arg do-option |
| |
THEN |
| |
+LOOP ; |
| |
|
| : cold ( -- ) |
: cold ( -- ) |
| argc @ 1 > |
argc @ 1 > |
| IF script? |
IF |
| IF 1 arg ['] included ELSE get-args ['] interpret THEN |
['] process-args catch ?dup |
| catch ?dup IF dup >r DoError cr r> (bye) THEN THEN |
IF |
| ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ; |
dup >r DoError cr r> negate (bye) |
| |
THEN |
| |
THEN |
| |
cr |
| |
." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr |
| |
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
| |
." Type `bye' to exit" |
| |
quit ; |
| |
|
| |
: license ( -- ) cr |
| |
." This program is free software; you can redistribute it and/or modify" cr |
| |
." it under the terms of the GNU General Public License as published by" cr |
| |
." the Free Software Foundation; either version 2 of the License, or" cr |
| |
." (at your option) any later version." cr cr |
| |
|
| |
." This program is distributed in the hope that it will be useful," cr |
| |
." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr |
| |
." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr |
| |
." GNU General Public License for more details." cr cr |
| |
|
| |
." You should have received a copy of the GNU General Public License" cr |
| |
." along with this program; if not, write to the Free Software" cr |
| |
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; |
| |
|
| : boot ( **env **argv argc -- ) |
: boot ( **env **argv argc -- ) |
| argc ! argv ! env ! main-task up! |
argc ! argv ! env ! main-task up! |
| sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
| |
|
| : bye cr 0 (bye) ; |
: bye script? 0= IF cr THEN 0 (bye) ; |
| |
|
| \ **argv may be scanned by the C starter to get some important |
\ **argv may be scanned by the C starter to get some important |
| \ information, as -display and -geometry for an X client FORTH |
\ information, as -display and -geometry for an X client FORTH |
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to kernal.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth