version 1.4, 1994/05/05 15:46:46
|
version 1.18, 1994/09/02 15:23:36
|
Line 45 DOES> ( n -- ) + c@ ;
|
Line 45 DOES> ( n -- ) + c@ ;
|
|
|
\ here allot , c, A, 17dec92py |
\ here allot , c, A, 17dec92py |
|
|
|
: dp ( -- addr ) dpp @ ; |
: here ( -- here ) dp @ ; |
: here ( -- here ) dp @ ; |
: allot ( n -- ) dp +! ; |
: allot ( n -- ) dp +! ; |
: c, ( c -- ) here 1 chars allot c! ; |
: c, ( c -- ) here 1 chars allot c! ; |
Line 56 DOES> ( n -- ) + c@ ;
|
Line 57 DOES> ( n -- ) + c@ ;
|
[ cell 1- ] Literal + [ -1 cells ] Literal and ; |
[ cell 1- ] Literal + [ -1 cells ] Literal and ; |
: align ( -- ) here dup aligned swap ?DO bl c, LOOP ; |
: align ( -- ) here dup aligned swap ?DO bl c, LOOP ; |
|
|
|
: faligned ( addr -- f-addr ) |
|
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
|
|
|
: falign ( -- ) |
|
here dup faligned swap |
|
?DO |
|
bl c, |
|
LOOP ; |
|
|
|
|
|
|
: A! ( addr1 addr2 -- ) dup relon ! ; |
: A! ( addr1 addr2 -- ) dup relon ! ; |
: A, ( addr -- ) here cell allot A! ; |
: A, ( addr -- ) here cell allot A! ; |
|
|
Line 67 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 130 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 ; |
|
: sname ( -- c-addr count ) |
|
source 2dup >r >r >in @ /string (parse-white) |
|
2dup + r> - 1+ r> min >in ! ; |
|
\ name count ; |
|
|
\ Literal 17dec92py |
\ Literal 17dec92py |
|
|
: Literal ( n -- ) state @ 0= ?EXIT postpone lit , ; |
: Literal ( n -- ) state @ IF postpone lit , THEN ; |
immediate |
immediate |
: ALiteral ( n -- ) state @ 0= ?EXIT postpone lit A, ; |
: ALiteral ( n -- ) state @ IF postpone lit A, THEN ; |
immediate |
immediate |
|
|
: char ( 'char' -- n ) bl word char+ c@ ; |
: char ( 'char' -- n ) bl word char+ c@ ; |
Line 153 Defer source
|
Line 169 Defer source
|
\ digit? 17dec92py |
\ digit? 17dec92py |
|
|
: digit? ( char -- digit true/ false ) |
: digit? ( char -- digit true/ false ) |
base @ $100 = ?dup ?EXIT |
base @ $100 = |
|
IF |
|
true EXIT |
|
THEN |
toupper [char] 0 - dup 9 u> IF |
toupper [char] 0 - dup 9 u> IF |
[ 'A '9 1 + - ] literal - |
[ 'A '9 1 + - ] literal - |
dup 9 u<= IF |
dup 9 u<= IF |
Line 178 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 239 hex
|
Line 272 hex
|
\ catch throw 23feb93py |
\ catch throw 23feb93py |
\ bounce 08jun93jaw |
\ bounce 08jun93jaw |
|
|
\ !! what about the other stacks (FP, locals) anton |
|
\ !! allow the user to add rollback actions anton |
\ !! allow the user to add rollback actions anton |
\ !! use a separate exception stack? anton |
\ !! use a separate exception stack? anton |
|
|
|
: lp@ ( -- addr ) |
|
laddr# [ 0 , ] ; |
|
|
: catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) |
: catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) |
>r sp@ r> swap \ don't count xt! jaw |
>r sp@ r> swap >r \ don't count xt! jaw |
>r handler @ >r rp@ handler ! execute |
fp@ >r |
r> handler ! rdrop 0 ; |
lp@ >r |
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn ) |
handler @ >r |
dup 0= IF drop EXIT THEN |
rp@ handler ! |
handler @ rp! r> handler ! r> swap >r sp! r> ; |
execute |
|
r> handler ! rdrop rdrop rdrop 0 ; |
|
|
|
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) |
|
?DUP IF |
|
[ here 4 cells ! ] |
|
handler @ rp! |
|
r> handler ! |
|
r> lp! |
|
r> fp! |
|
r> swap >r sp! r> |
|
THEN ; |
|
|
\ Bouncing is very fine, |
\ Bouncing is very fine, |
\ programming without wasting time... jaw |
\ programming without wasting time... jaw |
: bounce ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn ) |
: bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) |
\ a throw without data stack restauration? anton !! stack diagram bad |
\ a throw without data or fp stack restauration |
dup 0= IF drop EXIT THEN |
?DUP IF |
handler @ rp! r> handler ! r> drop ; |
handler @ rp! |
|
r> handler ! |
|
r> lp! |
|
rdrop |
|
rdrop |
|
THEN ; |
|
|
\ ?stack 23feb93py |
\ ?stack 23feb93py |
|
|
Line 266 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 |
' interpreter IS parser |
|
|
: sinterpreter ( c-addr u -- ) |
: compiler ( name -- ) find ?dup |
\ interpretation semantics for the name/number c-addr u |
IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup |
2dup sfind dup |
IF 0> IF swap postpone Literal THEN postpone Literal |
IF |
ELSE drop notfound THEN ; |
1 and |
|
IF \ not restricted to compile state? |
: [ ['] interpreter IS parser state off ; immediate |
nip nip execute EXIT |
: ] ['] compiler IS parser state on ; |
THEN |
|
-&14 throw |
|
THEN |
|
drop |
|
2dup 2>r snumber? |
|
IF |
|
2rdrop |
|
ELSE |
|
2r> notfound |
|
THEN ; |
|
|
|
' sinterpreter IS parser |
|
|
|
: scompiler ( c-addr u -- ) |
|
\ compilation semantics for the name/number c-addr u |
|
2dup sfind dup |
|
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 ; |
|
|
|
: [ ['] sinterpreter IS parser state off ; immediate |
|
: ] ['] scompiler IS parser state on ; |
|
|
|
\ locals stuff needed for control structures |
|
|
|
: compile-lp+! ( n -- ) |
|
dup negate locals-size +! |
|
0 over = if |
|
else -4 over = if postpone -4lp+! |
|
else 8 over = if postpone 8lp+! |
|
else 16 over = if postpone 16lp+! |
|
else postpone lp+!# dup , |
|
then then then then drop ; |
|
|
|
: adjust-locals-size ( n -- ) |
|
\ sets locals-size to n and generates an appropriate lp+! |
|
locals-size @ swap - compile-lp+! ; |
|
|
|
|
|
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 |
|
\ a linear list of locals names |
|
|
|
|
|
variable dead-code \ true if normal code at "here" would be dead |
|
|
|
: unreachable ( -- ) |
|
\ declares the current point of execution as unreachable |
|
dead-code on ; |
|
|
|
\ locals list operations |
|
|
|
: common-list ( list1 list2 -- list3 ) |
|
\ list1 and list2 are lists, where the heads are at higher addresses than |
|
\ the tail. list3 is the largest sublist of both lists. |
|
begin |
|
2dup u<> |
|
while |
|
2dup u> |
|
if |
|
swap |
|
then |
|
@ |
|
repeat |
|
drop ; |
|
|
|
: sub-list? ( list1 list2 -- f ) |
|
\ true iff list1 is a sublist of list2 |
|
begin |
|
2dup u< |
|
while |
|
@ |
|
repeat |
|
= ; |
|
|
|
: list-size ( list -- u ) |
|
\ size of the locals frame represented by list |
|
0 ( list n ) |
|
begin |
|
over 0<> |
|
while |
|
over |
|
name> >body @ max |
|
swap @ swap ( get next ) |
|
repeat |
|
faligned nip ; |
|
|
|
: set-locals-size-list ( list -- ) |
|
dup locals-list ! |
|
list-size locals-size ! ; |
|
|
|
: check-begin ( list -- ) |
|
\ warn if list is not a sublist of locals-list |
|
locals-list @ sub-list? 0= if |
|
\ !! print current position |
|
." compiler was overly optimistic about locals at a BEGIN" cr |
|
\ !! print assumption and reality |
|
then ; |
|
|
|
\ Control Flow Stack |
|
\ orig, etc. have the following structure: |
|
\ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS ) |
|
\ address (of the branch or the instruction to be branched to) (second) |
|
\ locals-list (valid at address) (third) |
|
|
|
\ types |
|
0 constant defstart |
|
1 constant live-orig |
|
2 constant dead-orig |
|
3 constant dest \ the loopback branch is always assumed live |
|
4 constant do-dest |
|
5 constant scopestart |
|
|
|
: def? ( n -- ) |
|
defstart <> abort" unstructured " ; |
|
|
|
: orig? ( n -- ) |
|
dup live-orig <> swap dead-orig <> and abort" expected orig " ; |
|
|
|
: dest? ( n -- ) |
|
dest <> abort" expected dest " ; |
|
|
|
: do-dest? ( n -- ) |
|
do-dest <> abort" expected do-dest " ; |
|
|
|
: scope? ( n -- ) |
|
scopestart <> abort" expected scope " ; |
|
|
|
: non-orig? ( n -- ) |
|
dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ; |
|
|
|
: cs-item? ( n -- ) |
|
live-orig scopestart 1+ within 0= abort" expected control flow stack item" ; |
|
|
|
3 constant cs-item-size |
|
|
|
: CS-PICK ( ... u -- ... destu ) |
|
1+ cs-item-size * 1- >r |
|
r@ pick r@ pick r@ pick |
|
rdrop |
|
dup non-orig? ; |
|
|
|
: CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) |
|
1+ cs-item-size * 1- >r |
|
r@ roll r@ roll r@ roll |
|
rdrop |
|
dup cs-item? ; |
|
|
|
: cs-push-part ( -- list addr ) |
|
locals-list @ here ; |
|
|
|
: cs-push-orig ( -- orig ) |
|
cs-push-part dead-code @ |
|
if |
|
dead-orig |
|
else |
|
live-orig |
|
then ; |
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
: ?struc ( flag -- ) abort" unstructured " ; |
: ?struc ( flag -- ) abort" unstructured " ; |
: sys? ( sys -- ) dup 0= ?struc ; |
: sys? ( sys -- ) dup 0= ?struc ; |
: >mark ( -- sys ) here 0 , ; |
: >mark ( -- orig ) |
: >resolve ( sys -- ) here over - swap ! ; |
cs-push-orig 0 , ; |
: <resolve ( sys -- ) here - , ; |
: >resolve ( addr -- ) here over - swap ! ; |
|
: <resolve ( addr -- ) here - , ; |
|
|
: BUT sys? swap ; immediate restrict |
: BUT 1 cs-roll ; immediate restrict |
: YET sys? dup ; immediate restrict |
: YET 0 cs-pick ; immediate restrict |
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
: AHEAD postpone branch >mark ; immediate restrict |
: AHEAD ( -- orig ) |
: IF postpone ?branch >mark ; immediate restrict |
POSTPONE branch >mark unreachable ; immediate restrict |
|
|
|
: IF ( -- orig ) |
|
POSTPONE ?branch >mark ; immediate restrict |
|
|
: ?DUP-IF \ general |
: ?DUP-IF \ general |
\ 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 sys? dup @ ?struc >resolve ; immediate restrict |
|
|
: THEN ( orig -- ) |
|
dup orig? |
|
dead-code @ |
|
if |
|
dead-orig = |
|
if |
|
>resolve drop |
|
else |
|
>resolve set-locals-size-list dead-code off |
|
then |
|
else |
|
dead-orig = |
|
if |
|
>resolve drop |
|
else \ both live |
|
over list-size adjust-locals-size |
|
>resolve |
|
locals-list @ common-list dup list-size adjust-locals-size |
|
locals-list ! |
|
then |
|
then ; immediate restrict |
|
|
' THEN alias ENDIF immediate restrict \ general |
' THEN alias ENDIF immediate restrict \ general |
\ Same as "THEN". This is what you use if your program will be seen by |
\ Same as "THEN". This is what you use if your program will be seen by |
\ people who have not been brought up with Forth (or who have been |
\ people who have not been brought up with Forth (or who have been |
\ brought up with fig-Forth). |
\ brought up with fig-Forth). |
|
|
: ELSE sys? postpone AHEAD swap postpone THEN ; |
: ELSE ( orig1 -- orig2 ) |
immediate restrict |
POSTPONE ahead |
|
1 cs-roll |
: BEGIN here ; immediate restrict |
POSTPONE then ; immediate restrict |
: WHILE sys? postpone IF swap ; immediate restrict |
|
: AGAIN sys? postpone branch <resolve ; immediate restrict |
|
: UNTIL sys? postpone ?branch <resolve ; immediate restrict |
: BEGIN ( -- dest ) |
: REPEAT over 0= ?struc postpone AGAIN postpone THEN ; |
dead-code @ if |
immediate restrict |
\ set up an assumption of the locals visible here |
|
\ currently we just take the top cs-item |
\ Structural Conditionals 12dec92py |
\ it would be more intelligent to take the top orig |
|
\ but that can be arranged by the user |
Variable leavings |
dup defstart <> if |
|
dup cs-item? |
: (leave) here leavings @ , leavings ! ; |
2 pick |
: LEAVE postpone branch (leave) ; immediate restrict |
else |
: ?LEAVE postpone 0= postpone ?branch (leave) ; |
0 |
immediate restrict |
then |
|
set-locals-size-list |
|
then |
|
cs-push-part dest |
|
dead-code off ; immediate restrict |
|
|
|
\ AGAIN (the current control flow joins another, earlier one): |
|
\ If the dest-locals-list is not a subset of the current locals-list, |
|
\ issue a warning (see below). The following code is generated: |
|
\ lp+!# (current-local-size - dest-locals-size) |
|
\ branch <begin> |
|
: AGAIN ( dest -- ) |
|
dest? |
|
over list-size adjust-locals-size |
|
POSTPONE branch |
|
<resolve |
|
check-begin |
|
unreachable ; immediate restrict |
|
|
|
\ UNTIL (the current control flow may join an earlier one or continue): |
|
\ Similar to AGAIN. The new locals-list and locals-size are the current |
|
\ ones. The following code is generated: |
|
\ ?branch-lp+!# <begin> (current-local-size - dest-locals-size) |
|
: until-like ( list addr xt1 xt2 -- ) |
|
\ list and addr are a fragment of a cs-item |
|
\ xt1 is the conditional branch without lp adjustment, xt2 is with |
|
>r >r |
|
locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment ) |
|
r> drop r> compile, |
|
swap <resolve ( list adjustment ) , |
|
else ( list dest-addr adjustment ) |
|
drop |
|
r> compile, <resolve |
|
r> drop |
|
then ( list ) |
|
check-begin ; |
|
|
|
: UNTIL ( dest -- ) |
|
dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict |
|
|
|
: WHILE ( dest -- orig dest ) |
|
POSTPONE if |
|
1 cs-roll ; immediate restrict |
|
|
|
: REPEAT ( orig dest -- ) |
|
POSTPONE again |
|
POSTPONE then ; immediate restrict |
|
|
|
|
|
\ counted loops |
|
|
|
\ leave poses a little problem here |
|
\ we have to store more than just the address of the branch, so the |
|
\ traditional linked list approach is no longer viable. |
|
\ This is solved by storing the information about the leavings in a |
|
\ special stack. |
|
|
|
\ !! remove the fixed size limit. 'Tis not hard. |
|
20 constant leave-stack-size |
|
create leave-stack 60 cells allot |
|
Avariable leave-sp leave-stack 3 cells + leave-sp ! |
|
|
|
: clear-leave-stack ( -- ) |
|
leave-stack leave-sp ! ; |
|
|
|
\ : leave-empty? ( -- f ) |
|
\ leave-sp @ leave-stack = ; |
|
|
|
: >leave ( orig -- ) |
|
\ push on leave-stack |
|
leave-sp @ |
|
dup [ leave-stack 60 cells + ] Aliteral |
|
>= abort" leave-stack full" |
|
tuck ! cell+ |
|
tuck ! cell+ |
|
tuck ! cell+ |
|
leave-sp ! ; |
|
|
|
: leave> ( -- orig ) |
|
\ pop from leave-stack |
|
leave-sp @ |
|
dup leave-stack <= IF |
|
drop 0 0 0 EXIT THEN |
|
cell - dup @ swap |
|
cell - dup @ swap |
|
cell - dup @ swap |
|
leave-sp ! ; |
|
|
|
: DONE ( orig -- ) drop >r drop |
|
\ !! the original done had ( addr -- ) |
|
begin |
|
leave> |
|
over r@ u>= |
|
while |
|
POSTPONE then |
|
repeat |
|
>leave rdrop ; immediate restrict |
|
|
|
: LEAVE ( -- ) |
|
POSTPONE ahead |
|
>leave ; immediate restrict |
|
|
|
: ?LEAVE ( -- ) |
|
POSTPONE 0= POSTPONE if |
|
>leave ; immediate restrict |
|
|
|
: DO ( -- do-sys ) |
|
POSTPONE (do) |
|
POSTPONE begin drop do-dest |
|
( 0 0 0 >leave ) ; immediate restrict |
|
|
|
: ?DO ( -- do-sys ) |
|
( 0 0 0 >leave ) |
|
POSTPONE (?do) |
|
>mark >leave |
|
POSTPONE begin drop do-dest ; immediate restrict |
|
|
|
: FOR ( -- do-sys ) |
|
POSTPONE (for) |
|
POSTPONE begin drop do-dest |
|
( 0 0 0 >leave ) ; immediate restrict |
|
|
|
\ LOOP etc. are just like UNTIL |
|
|
|
: loop-like ( do-sys xt1 xt2 -- ) |
|
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
|
until-like POSTPONE done POSTPONE unloop ; |
|
|
|
: LOOP ( do-sys -- ) |
|
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
|
|
|
: +LOOP ( do-sys -- ) |
|
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
|
|
|
\ 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 |
|
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
|
\ negative increments. |
|
: S+LOOP ( do-sys -- ) |
|
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
|
|
: DONE ( addr -- ) leavings @ |
: NEXT ( do-sys -- ) |
BEGIN 2dup u<= WHILE dup @ swap >resolve REPEAT |
['] (next) ['] (next)-lp+!# loop-like ; immediate restrict |
leavings ! drop ; immediate restrict |
|
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
: DO postpone (do) here ; immediate restrict |
: EXIT ( -- ) |
|
0 adjust-locals-size |
|
POSTPONE ;s |
|
unreachable ; immediate restrict |
|
|
: ?DO postpone (?do) (leave) here ; |
: ?EXIT ( -- ) |
immediate restrict |
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict |
: FOR postpone (for) here ; immediate restrict |
|
|
|
: loop] dup <resolve 2 cells - postpone done postpone unloop ; |
|
|
|
: LOOP sys? postpone (loop) loop] ; immediate restrict |
|
: +LOOP sys? postpone (+loop) loop] ; immediate restrict |
|
: S+LOOP \ general |
|
\ 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 increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for negative increments. |
|
sys? postpone (s+loop) loop] ; immediate restrict |
|
: NEXT sys? postpone (next) loop] ; immediate restrict |
|
|
|
\ Strings 22feb93py |
\ Strings 22feb93py |
|
|
Line 373 Variable leavings
|
Line 756 Variable leavings
|
: ." 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 384 Variable leavings
|
Line 768 Variable leavings
|
|
|
\ 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 398 Variable leavings
|
Line 784 Variable leavings
|
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 411 defer header
|
Line 799 defer header
|
' input-stream-header IS header |
' input-stream-header IS header |
|
|
\ !! make that a 2variable |
\ !! make that a 2variable |
create nextname-string 2 cells allot \ should we use a buffer that keeps the name? |
create nextname-buffer 32 chars allot |
|
|
: nextname-header ( -- ) |
: nextname-header ( -- ) |
\ !! f83-implementation-dependent |
\ !! f83-implementation-dependent |
nextname-string 2@ |
nextname-buffer count |
align here last ! -1 A, |
align here last ! -1 A, |
dup c, here swap chars dup allot move align |
dup c, here swap chars dup allot move align |
$80 flag! |
$80 flag! |
Line 423 create nextname-string 2 cells allot \ s
|
Line 811 create nextname-string 2 cells allot \ s
|
|
|
\ 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 |
nextname-string 2! |
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 ( -- ) |
: noname-header ( -- ) |
Line 444 create nextname-string 2 cells allot \ s
|
Line 834 create nextname-string 2 cells allot \ s
|
: 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 470 Create ??? ," ???"
|
Line 860 Create ??? ," ???"
|
|
|
\ DOES> 17mar93py |
\ DOES> 17mar93py |
|
|
: DOES> state @ IF postpone (;code) dodoes, |
: DOES> ( compilation: -- ) |
ELSE dodoes, here !does 0 ] THEN ; immediate |
state @ |
|
IF |
|
;-hook postpone (;code) dodoes, |
|
ELSE |
|
dodoes, here !does 0 ] |
|
THEN |
|
:-hook ; immediate |
|
|
\ Create Variable User Constant 17mar93py |
\ Create Variable User Constant 17mar93py |
|
|
Line 486 Create ??? ," ???"
|
Line 882 Create ??? ," ???"
|
: (Constant) Header reveal [ :docon ] Literal cfa, ; |
: (Constant) Header reveal [ :docon ] Literal cfa, ; |
: Constant (Constant) , ; |
: Constant (Constant) , ; |
: AConstant (Constant) A, ; |
: AConstant (Constant) A, ; |
: 2Constant ( w1 w2 "name" -- ) \ double |
|
Create 2, DOES> 2@ ; |
: 2CONSTANT |
|
create ( w1 w2 "name" -- ) |
|
2, |
|
does> ( -- w1 w2 ) |
|
2@ ; |
|
|
\ IS Defer What's Defers TO 24feb93py |
\ IS Defer What's Defers TO 24feb93py |
|
|
: Defer Create ['] noop A, DOES> @ execute ; |
: Defer ( -- ) |
|
\ !! shouldn't it be initialized with abort or something similar? |
|
Header Reveal [ :dodefer ] Literal cfa, |
|
['] noop A, ; |
|
\ Create ( -- ) |
|
\ ['] noop A, |
|
\ DOES> ( ??? ) |
|
\ @ execute ; |
|
|
: IS ( addr "name" -- ) |
: IS ( addr "name" -- ) |
' >body |
' >body |
Line 505 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 |
|
|
: EXIT ( -- ) postpone ;s ; immediate |
defer :-hook ( sys1 -- sys2 ) |
|
defer ;-hook ( sys2 -- sys1 ) |
|
|
: : ( -- colon-sys ) Header [ :docol ] Literal cfa, 0 ] ; |
: : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ; |
: ; ( colon-sys -- ) ?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 ] ; |
|
|
: :noname ( -- xt colon-sys ) |
|
0 last ! |
|
here [ :docol ] Literal cfa, 0 ] :-hook ; |
|
|
\ Search list handling 23feb93py |
\ Search list handling 23feb93py |
|
|
AVariable current |
AVariable current |
|
|
: last? ( -- false / nfa nfa ) last @ ?dup ; |
: last? ( -- false / nfa nfa ) last @ ?dup ; |
: (reveal) ( -- ) last? |
: (reveal) ( -- ) |
IF dup @ 0< |
last? |
IF current @ @ over ! current @ ! |
IF |
ELSE drop THEN THEN ; |
dup @ 0< |
|
IF |
|
current @ @ over ! current @ ! |
|
ELSE |
|
drop |
|
THEN |
|
THEN ; |
|
|
\ object oriented search list 17mar93py |
\ object oriented search list 17mar93py |
|
|
|
\ word list structure: |
|
\ struct |
|
\ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
|
\ 1 cells: field reveal-method \ xt: ( -- ) |
|
\ 1 cells: field rehash-method \ xt: ( wid -- ) |
|
\ \ !! what else |
|
\ end-struct wordlist-map-struct |
|
|
|
\ struct |
|
\ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation |
|
\ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct |
|
\ 1 cells: field wordlist-link \ link field to other wordlists |
|
\ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
|
\ end-struct wordlist-struct |
|
|
|
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
|
|
\ Search list table: find reveal |
\ Search list table: find reveal |
|
Create f83search ' f83find A, ' (reveal) A, ' drop A, |
|
|
Create f83search ' (f83find) A, ' (reveal) 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 557 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 566 Variable warnings G -1 warnings T !
|
Line 1006 Variable warnings G -1 warnings T !
|
then |
then |
current @ cell+ @ cell+ @ execute ; |
current @ cell+ @ cell+ @ execute ; |
|
|
: ' ( "name" -- addr ) name find 0= no.extensions ; |
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
|
|
|
: ' ( "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 619 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 639 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 677 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 703 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1171 create nl$ 1 c, A c, 0 c, \ gnu includes
|
|
|
\ INCLUDE 9may93jaw |
\ INCLUDE 9may93jaw |
|
|
: include |
: include ( "file" -- ) |
bl word count included ; |
bl word count included ; |
|
|
\ 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 720 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 747 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 @ IF ." Error in line: " Loadline @ . cr THEN |
loadline @ IF |
cr source type cr |
source >in @ loadline @ 0 0 .error-frame |
source drop >in @ -trailing |
THEN |
here c@ 1F min dup >r - 1- 0 max nip |
error-stack @ 0 ?DO |
dup spaces IF ." ^" THEN r> 0 ?DO ." -" LOOP ." ^" |
-1 error-stack +! |
dup -2 = |
error-stack dup @ 6 * cells + cell+ |
IF "error @ ?dup IF cr count type THEN drop |
6 cells bounds DO |
ELSE .error THEN ; |
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 |
' (DoError) IS DoError |
|
|
: quit r0 @ rp! handler off >tib @ >r |
: quit r0 @ rp! handler off >tib @ >r |
BEGIN postpone [ ['] 'quit catch dup WHILE |
BEGIN |
DoError r@ >tib ! |
postpone [ |
REPEAT drop r> >tib ! ; |
['] 'quit CATCH dup |
|
WHILE |
|
DoError r@ >tib ! |
|
REPEAT |
|
drop r> >tib ! ; |
|
|
\ Cold 13feb93py |
\ Cold 13feb93py |
|
|
Line 780 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 +! ; |
|
|
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
: script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; |
2dup s" -e" compare 0= >r |
|
2dup s" -evaluate" compare 0= r> or |
: cold ( -- ) argc @ 1 > |
IF 2drop ">tib interpret 2 EXIT THEN |
IF script? |
." Unknown option: " type cr 2drop 1 ; |
IF 1 arg ['] included ELSE get-args ['] interpret THEN |
|
catch ?dup IF dup >r DoError cr r> (bye) THEN THEN |
: process-args ( -- ) argc @ 1 |
." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ; |
?DO I arg over c@ [char] - <> |
|
IF true to script? included false to script? 1 |
|
ELSE I 1+ arg do-option |
|
THEN |
|
+LOOP ; |
|
|
|
: cold ( -- ) |
|
argc @ 1 > |
|
IF |
|
['] process-args catch ?dup |
|
IF |
|
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 |