version 1.11, 1994/07/13 19:21:03
|
version 1.37, 1995/06/03 14:24:44
|
Line 1
|
Line 1
|
\ KERNAL.FS ANS figFORTH kernal 17dec92py |
\ KERNAL.FS GNU FORTH kernal 17dec92py |
\ $ID: |
\ $ID: |
\ Idea and implementation: Bernd Paysan (py) |
\ Idea and implementation: Bernd Paysan (py) |
\ Copyright 1992 by the ANSI figForth Development Group |
\ Copyright 1992 by the ANSI figForth Development Group |
Line 66 DOES> ( n -- ) + c@ ;
|
Line 66 DOES> ( n -- ) + c@ ;
|
bl c, |
bl c, |
LOOP ; |
LOOP ; |
|
|
|
\ !! this is machine-dependent, but works on all but the strangest machines |
|
' faligned Alias maxaligned |
|
' falign Alias maxalign |
|
|
|
\ the code field is aligned if its body is maxaligned |
|
\ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned" |
|
' maxaligned Alias cfaligned |
|
' maxalign Alias cfalign |
|
|
|
: chars ; immediate |
|
|
: A! ( addr1 addr2 -- ) dup relon ! ; |
: A! ( addr1 addr2 -- ) dup relon ! ; |
: A, ( addr -- ) here cell allot A! ; |
: A, ( addr -- ) here cell allot A! ; |
Line 78 DOES> ( n -- ) + c@ ;
|
Line 87 DOES> ( n -- ) + c@ ;
|
|
|
\ name> found 17dec92py |
\ name> found 17dec92py |
|
|
: (name>) ( nfa -- cfa ) count $1F and + aligned ; |
: (name>) ( nfa -- cfa ) |
: name> ( nfa -- cfa ) cell+ |
count $1F and + cfaligned ; |
dup (name>) swap c@ $80 and 0= IF @ THEN ; |
: name> ( nfa -- cfa ) |
|
cell+ |
|
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 |
Line 110 Defer source
|
Line 121 Defer source
|
|
|
\ (word) 22feb93py |
\ (word) 22feb93py |
|
|
: scan ( addr1 n1 char -- addr2 n2 ) >r |
: scan ( addr1 n1 char -- addr2 n2 ) |
BEGIN dup WHILE over c@ r@ <> WHILE 1 /string |
\ skip all characters not equal to char |
REPEAT THEN rdrop ; |
>r |
: skip ( addr1 n1 char -- addr2 n2 ) >r |
BEGIN |
BEGIN dup WHILE over c@ r@ = WHILE 1 /string |
dup |
REPEAT THEN rdrop ; |
WHILE |
|
over c@ r@ <> |
|
WHILE |
|
1 /string |
|
REPEAT THEN |
|
rdrop ; |
|
: skip ( addr1 n1 char -- addr2 n2 ) |
|
\ skip all characters equal to char |
|
>r |
|
BEGIN |
|
dup |
|
WHILE |
|
over c@ r@ = |
|
WHILE |
|
1 /string |
|
REPEAT THEN |
|
rdrop ; |
|
|
: (word) ( addr1 n1 char -- addr2 n2 ) |
: (word) ( addr1 n1 char -- addr2 n2 ) |
dup >r skip 2dup r> scan nip - ; |
dup >r skip 2dup r> scan nip - ; |
Line 126 Defer source
|
Line 153 Defer source
|
\ word parse 23feb93py |
\ word parse 23feb93py |
|
|
: parse-word ( char -- addr len ) |
: parse-word ( char -- addr len ) |
source 2dup >r >r >in @ /string |
source 2dup >r >r >in @ over min /string |
rot dup bl = IF drop (parse-white) ELSE (word) THEN |
rot dup bl = IF drop (parse-white) ELSE (word) THEN |
2dup + r> - 1+ r> min >in ! ; |
2dup + r> - 1+ r> min >in ! ; |
: word ( char -- addr ) |
: word ( char -- addr ) |
parse-word here place bl here count + c! here ; |
parse-word here place bl here count + c! here ; |
|
|
: parse ( char -- addr len ) |
: parse ( char -- addr len ) |
>r source >in @ /string over swap r> scan >r |
>r source >in @ over min /string over swap r> scan >r |
over - dup r> IF 1+ THEN >in +! ; |
over - dup r> IF 1+ THEN >in +! ; |
|
|
\ name 13feb93py |
\ name 13feb93py |
|
|
: capitalize ( addr -- addr ) |
: capitalize ( addr len -- addr len ) |
dup count chars bounds |
2dup chars 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) ( -- c-addr count ) |
: (cname) ( -- addr ) bl word capitalize ; |
source 2dup >r >r >in @ /string (parse-white) |
|
2dup + r> - 1+ r> min >in ! ; |
|
\ name count ; |
|
|
|
: name-too-short? ( c-addr u -- c-addr u ) |
|
dup 0= -&16 and throw ; |
|
|
|
: name-too-long? ( c-addr u -- c-addr u ) |
|
dup $1F u> -&19 and throw ; |
|
|
\ Literal 17dec92py |
\ Literal 17dec92py |
|
|
Line 155 Defer source
|
Line 190 Defer source
|
: [char] ( 'char' -- n ) char postpone Literal ; immediate |
: [char] ( 'char' -- n ) char postpone Literal ; immediate |
' [char] Alias Ascii immediate |
' [char] Alias Ascii immediate |
|
|
: (compile) ( -- ) r> dup cell+ >r @ A, ; |
: (compile) ( -- ) r> dup cell+ >r @ compile, ; |
: postpone ( "name" -- ) |
: postpone ( "name" -- ) |
name find dup 0= abort" Can't compile " |
name sfind dup 0= abort" Can't compile " |
0> IF A, ELSE postpone (compile) A, THEN ; |
0> IF compile, ELSE postpone (compile) A, THEN ; |
immediate restrict |
immediate restrict |
|
|
\ Use (compile) for the old behavior of compile! |
\ Use (compile) for the old behavior of compile! |
Line 194 Create bases 10 , 2 , A , 100 ,
|
Line 229 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 212 decimal
|
Line 261 decimal
|
Create spaces bl 80 times \ times from target compiler! 11may93jaw |
Create spaces bl 80 times \ times from target compiler! 11may93jaw |
DOES> ( u -- ) swap |
DOES> ( u -- ) swap |
0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; |
0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; |
|
Create backspaces 08 80 times \ times from target compiler! 11may93jaw |
|
DOES> ( u -- ) swap |
|
0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; |
hex |
hex |
: space 1 spaces ; |
: space 1 spaces ; |
|
|
Line 301 hex
|
Line 353 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 name dup |
|
WHILE |
|
parser |
|
REPEAT |
|
2drop ; |
|
|
\ interpreter compiler 30apr92py |
\ interpreter compiler 30apr92py |
|
|
: interpreter ( name -- ) find ?dup |
: interpreter ( c-addr u -- ) |
IF 1 and IF execute EXIT THEN -&14 throw THEN |
\ interpretation semantics for the name/number c-addr u |
number? 0= IF notfound THEN ; |
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 |
' interpreter IS parser |
|
|
: compiler ( name -- ) find ?dup |
: compiler ( 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 |
: [ ['] interpreter IS parser state off ; immediate |
: ] ['] compiler IS parser state on ; |
: ] ['] compiler IS parser state on ; |
Line 331 Defer notfound
|
Line 420 Defer notfound
|
: compile-lp+! ( n -- ) |
: compile-lp+! ( n -- ) |
dup negate locals-size +! |
dup negate locals-size +! |
0 over = if |
0 over = if |
else -4 over = if postpone -4lp+! |
else -1 cells over = if postpone lp- |
else 8 over = if postpone 8lp+! |
else 1 floats over = if postpone lp+ |
else 16 over = if postpone 16lp+! |
else 2 floats over = if postpone lp+2 |
else postpone lp+!# dup , |
else postpone lp+!# dup , |
then then then then drop ; |
then then then then drop ; |
|
|
Line 348 AConstant locals-list \ acts like a vari
|
Line 437 AConstant locals-list \ acts like a vari
|
|
|
|
|
variable dead-code \ true if normal code at "here" would be dead |
variable dead-code \ true if normal code at "here" would be dead |
|
variable backedge-locals |
: unreachable ( -- ) |
\ contains the locals list that BEGIN will assume to be live on |
\ declares the current point of execution as unreachable |
\ the back edge if the BEGIN is unreachable from above. Set by |
dead-code on ; |
\ ASSUME-LIVE, reset by UNREACHABLE. |
|
|
|
: UNREACHABLE ( -- ) |
|
\ declares the current point of execution as unreachable |
|
dead-code on |
|
0 backedge-locals ! ; immediate |
|
|
|
: ASSUME-LIVE ( orig -- orig ) |
|
\ used immediateliy before a BEGIN that is not reachable from |
|
\ above. causes the BEGIN to assume that the same locals are live |
|
\ as at the orig point |
|
dup orig? |
|
2 pick backedge-locals ! ; immediate |
|
|
\ locals list operations |
\ locals list operations |
|
|
: common-list ( list1 list2 -- list3 ) |
: common-list ( list1 list2 -- list3 ) |
Line 477 variable dead-code \ true if normal code
|
Line 578 variable dead-code \ true if normal code
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
: AHEAD ( -- orig ) |
: AHEAD ( -- orig ) |
POSTPONE branch >mark unreachable ; immediate restrict |
POSTPONE branch >mark POSTPONE unreachable ; immediate restrict |
|
|
: IF ( -- orig ) |
: IF ( -- orig ) |
POSTPONE ?branch >mark ; immediate restrict |
POSTPONE ?branch >mark ; immediate restrict |
Line 486 variable dead-code \ true if normal code
|
Line 587 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 -- ) |
dup orig? |
dup orig? |
dead-code @ |
dead-orig = |
if |
if |
dead-orig = |
>resolve drop |
if |
|
>resolve drop |
|
else |
|
>resolve set-locals-size-list dead-code off |
|
then |
|
else |
else |
dead-orig = |
dead-code @ |
if |
if |
>resolve drop |
>resolve set-locals-size-list dead-code off |
else \ both live |
else \ both live |
over list-size adjust-locals-size |
over list-size adjust-locals-size |
>resolve |
>resolve |
Line 524 variable dead-code \ true if normal code
|
Line 620 variable dead-code \ true if normal code
|
|
|
: BEGIN ( -- dest ) |
: BEGIN ( -- dest ) |
dead-code @ if |
dead-code @ if |
\ set up an assumption of the locals visible here |
\ set up an assumption of the locals visible here. if the |
\ currently we just take the top cs-item |
\ users want something to be visible, they have to declare |
\ it would be more intelligent to take the top orig |
\ that using ASSUME-LIVE |
\ but that can be arranged by the user |
backedge-locals @ set-locals-size-list |
dup defstart <> if |
|
dup cs-item? |
|
2 pick |
|
else |
|
0 |
|
then |
|
set-locals-size-list |
|
then |
then |
cs-push-part dest |
cs-push-part dest |
dead-code off ; immediate restrict |
dead-code off ; immediate restrict |
Line 550 variable dead-code \ true if normal code
|
Line 639 variable dead-code \ true if normal code
|
POSTPONE branch |
POSTPONE branch |
<resolve |
<resolve |
check-begin |
check-begin |
unreachable ; immediate restrict |
POSTPONE unreachable ; immediate restrict |
|
|
\ UNTIL (the current control flow may join an earlier one or continue): |
\ 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 |
\ Similar to AGAIN. The new locals-list and locals-size are the current |
Line 621 Avariable leave-sp leave-stack 3 cells
|
Line 710 Avariable leave-sp leave-stack 3 cells
|
cell - dup @ swap |
cell - dup @ swap |
leave-sp ! ; |
leave-sp ! ; |
|
|
: DONE ( orig -- ) drop >r drop |
: DONE ( orig -- ) |
\ !! the original done had ( addr -- ) |
\ !! the original done had ( addr -- ) |
|
drop >r drop |
begin |
begin |
leave> |
leave> |
over r@ u>= |
over r@ u>= |
Line 682 Avariable leave-sp leave-stack 3 cells
|
Line 772 Avariable leave-sp leave-stack 3 cells
|
: EXIT ( -- ) |
: EXIT ( -- ) |
0 adjust-locals-size |
0 adjust-locals-size |
POSTPONE ;s |
POSTPONE ;s |
unreachable ; immediate restrict |
POSTPONE unreachable ; immediate restrict |
|
|
: ?EXIT ( -- ) |
: ?EXIT ( -- ) |
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict |
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict |
Line 697 Avariable leave-sp leave-stack 3 cells
|
Line 787 Avariable leave-sp leave-stack 3 cells
|
: (S") "lit count ; restrict |
: (S") "lit count ; restrict |
: SLiteral postpone (S") here over char+ allot place align ; |
: SLiteral postpone (S") here over char+ allot place align ; |
immediate restrict |
immediate restrict |
: S" [char] " parse state @ IF postpone SLiteral THEN ; |
create s"-buffer /line chars allot |
|
: S" ( run-time: -- c-addr u ) |
|
[char] " parse |
|
state @ |
|
IF |
|
postpone SLiteral |
|
ELSE |
|
/line min >r s"-buffer r@ cmove |
|
s"-buffer r> |
|
THEN ; |
immediate |
immediate |
: ." 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 |
: \ ( -- ) \ core-ext backslash |
|
blk @ |
|
IF |
|
>in @ c/l / 1+ c/l * >in ! |
|
EXIT |
|
THEN |
|
source >in ! drop ; immediate |
|
|
|
: \G ( -- ) \ new backslash |
|
POSTPONE \ ; immediate |
|
|
\ error handling 22feb93py |
\ error handling 22feb93py |
\ 'abort thrown out! 11may93jaw |
\ 'abort thrown out! 11may93jaw |
Line 726 Avariable leave-sp leave-stack 3 cells
|
Line 834 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 |
|
|
|
: string, ( c-addr u -- ) |
|
\ puts down string as cstring |
|
dup c, here swap chars dup allot move ; |
|
|
: name, ( "name" -- ) |
: name, ( "name" -- ) |
name c@ |
name name-too-short? name-too-long? |
dup $1F u> &-19 and throw ( is name too long? ) |
string, cfalign ; |
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 739 defer header
|
Line 851 defer 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 750 create nextname-buffer 32 chars allot
|
Line 862 create nextname-buffer 32 chars allot
|
\ !! f83-implementation-dependent |
\ !! f83-implementation-dependent |
nextname-buffer count |
nextname-buffer count |
align here last ! -1 A, |
align here last ! -1 A, |
dup c, here swap chars dup allot move align |
string, cfalign |
$80 flag! |
$80 flag! |
input-stream ; |
input-stream ; |
|
|
\ 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 $1F u> &-19 and throw ( is name too long? ) |
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 ! cfalign |
input-stream ; |
input-stream ; |
|
|
: 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 782 create nextname-buffer 32 chars allot
|
Line 894 create nextname-buffer 32 chars allot
|
Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
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 + cfaligned over $80 + = if |
i - cell - unloop exit |
i - cell - unloop exit |
then |
then |
cell +loop |
cell +loop |
Line 828 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 940 Create ??? 0 , 3 c, char ? c, char ? c,
|
: Constant (Constant) , ; |
: Constant (Constant) , ; |
: AConstant (Constant) A, ; |
: AConstant (Constant) A, ; |
|
|
: 2CONSTANT |
: 2Constant |
create ( w1 w2 "name" -- ) |
Create ( w1 w2 "name" -- ) |
2, |
2, |
does> ( -- w1 w2 ) |
DOES> ( -- w1 w2 ) |
2@ ; |
2@ ; |
|
|
\ 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 854 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 969 Create ??? 0 , 3 c, char ? c, char ? c,
|
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 888 AVariable current
|
Line 1003 AVariable current
|
\ object oriented search list 17mar93py |
\ object oriented search list 17mar93py |
|
|
\ word list structure: |
\ word list structure: |
\ struct |
|
\ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
struct |
\ 1 cells: field reveal-method \ xt: ( -- ) |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
\ 1 cells: field rehash-method \ xt: ( wid -- ) |
1 cells: field reveal-method \ xt: ( -- ) |
|
1 cells: field rehash-method \ xt: ( wid -- ) |
\ \ !! what else |
\ \ !! what else |
\ end-struct wordlist-map-struct |
end-struct wordlist-map-struct |
|
|
\ struct |
struct |
\ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation |
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-map \ pointer to a wordlist-map-struct |
\ 1 cells: field wordlist-link \ link field to other wordlists |
1 cells: field wordlist-link \ link field to other wordlists |
\ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
\ 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 wordlist-map @ find-method @ 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 ; |
|
|
Variable warnings G -1 warnings T ! |
Variable warnings G -1 warnings T ! |
|
|
Line 938 Variable warnings G -1 warnings T !
|
Line 1049 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 |
name>string current @ check-shadow |
name>string current @ check-shadow |
then |
then |
current @ cell+ @ cell+ @ execute ; |
current @ wordlist-map @ reveal-method @ execute ; |
|
|
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
: rehash ( wid -- ) dup wordlist-map @ rehash-method @ execute ; |
|
|
: ' ( "name" -- addr ) name find 0= no.extensions ; |
: ' ( "name" -- addr ) name sfind 0= if -&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 ; |
|
|
: backspaces 0 ?DO #bs emit LOOP ; |
\ : backspaces 0 ?DO #bs emit LOOP ; |
: >string ( span addr pos1 -- span addr pos1 addr2 len ) |
: >string ( span addr pos1 -- span addr pos1 addr2 len ) |
over 3 pick 2 pick chars /string ; |
over 3 pick 2 pick chars /string ; |
: type-rest ( span addr pos1 -- span addr pos1 back ) |
: type-rest ( span addr pos1 -- span addr pos1 back ) |
Line 978 Variable warnings G -1 warnings T !
|
Line 1097 Variable warnings G -1 warnings T !
|
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
|
|
Create crtlkeys |
Create ctrlkeys |
] false false back false false false forw false |
] false false back false false false forw false |
?del false (ret) false false (ret) false false |
?del false (ret) false false (ret) false false |
false false false false false false false false |
false false false false false false false false |
false false false false false false false false [ |
false false false false false false false false [ |
|
|
|
defer everychar |
|
' noop IS everychar |
|
|
: decode ( max span addr pos1 key -- max span addr pos2 flag ) |
: decode ( max span addr pos1 key -- max span addr pos2 flag ) |
|
everychar |
dup #del = IF drop #bs THEN \ del is rubout |
dup #del = IF drop #bs THEN \ del is rubout |
dup bl < IF cells crtlkeys + @ execute EXIT THEN |
dup bl < IF cells ctrlkeys + @ execute EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
r> (ins) 0 ; |
r> (ins) 0 ; |
|
|
Line 1002 Create crtlkeys
|
Line 1125 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 1022 DEFER Emit
|
Line 1148 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 linestart @ 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 1049 DEFER Emit
|
Line 1175 DEFER Emit
|
\ : bin dup 1 chars - c@ |
\ : bin dup 1 chars - c@ |
\ r/o 4 chars + over - dup >r swap move r> ; |
\ r/o 4 chars + over - dup >r swap move r> ; |
|
|
: bin 1+ ; |
: bin 1 or ; |
|
|
create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos |
create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos |
\ or not unix environments if |
\ or not unix environments if |
Line 1060 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1186 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 2dup or |
|
pop-file drop throw throw ; |
|
|
|
create pathfilenamebuf 256 chars allot \ !! make this grow on demand |
|
|
|
\ : check-file-prefix ( addr len -- addr' len' flag ) |
|
\ dup 0= IF true EXIT THEN |
|
\ over c@ '/ = IF true EXIT THEN |
|
\ over 2 S" ./" compare 0= IF true EXIT THEN |
|
\ over 3 S" ../" compare 0= IF true EXIT THEN |
|
\ over 2 S" ~/" compare 0= |
|
\ IF 1 /string |
|
\ S" HOME" getenv tuck pathfilenamebuf swap move |
|
\ 2dup + >r pathfilenamebuf + swap move |
|
\ pathfilenamebuf r> true |
|
\ ELSE false |
|
\ THEN ; |
|
|
|
: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) |
|
\ opens a file for reading, searching in the path for it (unless |
|
\ the filename contains a slash); c-addr2 u2 is the full filename |
|
\ (valid until the next call); if the file is not found (or in |
|
\ case of other errors for each try), -38 (non-existant file) is |
|
\ thrown. Opening for other access modes makes little sense, as |
|
\ the path will usually contain dirs that are only readable for |
|
\ the user |
|
\ !! use file-status to determine access mode? |
|
2dup [char] / scan nip ( 0<> ) |
|
if \ the filename contains a slash |
|
2dup r/o open-file throw ( c-addr1 u1 file-id ) |
|
-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 ) |
|
pathfilenamebuf r> EXIT |
|
then |
|
pathdirs 2@ 0 |
|
\ check-file-prefix 0= |
|
\ IF pathdirs 2@ 0 |
|
?DO ( c-addr1 u1 dirnamep ) |
|
dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u ) |
|
2dup pathfilenamebuf r@ chars + swap cmove ( addr u ) |
|
pathfilenamebuf over r> + dup >r r/o open-file 0= |
|
IF ( addr u file-id ) |
|
nip nip r> rdrop 0 LEAVE |
|
THEN |
|
rdrop drop r> cell+ cell+ |
|
LOOP |
|
\ ELSE 2dup open-file throw -rot THEN |
|
0<> -&38 and throw ( file-id u2 ) |
|
pathfilenamebuf swap ; |
|
|
|
create included-files 0 , 0 , ( pointer to and count of included files ) |
|
|
|
: included? ( c-addr u -- f ) |
|
\ true, iff filename c-addr u is in included-files |
|
included-files 2@ 0 |
|
?do ( c-addr u addr ) |
|
dup >r 2@ 2over compare 0= |
|
if |
|
2drop rdrop unloop |
|
true EXIT |
|
then |
|
r> cell+ cell+ |
|
loop |
|
2drop drop false ; |
|
|
: included ( i*x addr u -- j*x ) |
: add-included-file ( c-addr u -- ) |
|
\ add name c-addr u to included-files |
|
included-files 2@ tuck 1+ 2* cells resize throw |
|
swap 2dup 1+ included-files 2! |
|
2* cells + 2! ; |
|
|
|
: save-string ( addr1 u -- addr2 u ) |
|
swap >r |
|
dup allocate throw |
|
swap 2dup r> -rot move ; |
|
|
|
: included1 ( i*x file-id c-addr u -- j*x ) |
|
\ include the file file-id with the name given by c-addr u |
loadfilename 2@ >r >r |
loadfilename 2@ >r >r |
dup allocate throw over loadfilename 2! |
save-string 2dup loadfilename 2! add-included-file ( file-id ) |
over loadfilename 2@ move |
['] include-file catch |
r/o open-file throw include-file |
r> r> loadfilename 2! throw ; |
\ don't free filenames; they don't take much space |
|
\ and are used for debugging |
: included ( i*x addr u -- j*x ) |
r> r> loadfilename 2! ; |
open-path-file included1 ; |
|
|
|
: required ( i*x addr u -- j*x ) |
|
\ include the file with the name given by addr u, if it is not |
|
\ included already. Currently this works by comparing the name of |
|
\ the file (with path) against the names of earlier included |
|
\ files; however, it would probably be better to fstat the file, |
|
\ and compare the device and inode. The advantages would be: no |
|
\ problems with several paths to the same file (e.g., due to |
|
\ links) and we would catch files included with include-file and |
|
\ write a require-file. |
|
open-path-file 2dup included? |
|
if |
|
2drop close-file throw |
|
else |
|
included1 |
|
then ; |
|
|
\ HEX DECIMAL 2may93jaw |
\ HEX DECIMAL 2may93jaw |
|
|
Line 1089 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1319 create nl$ 1 c, A c, 0 c, \ gnu includes
|
\ DEPTH 9may93jaw |
\ DEPTH 9may93jaw |
|
|
: depth ( -- +n ) sp@ s0 @ swap - cell / ; |
: depth ( -- +n ) sp@ s0 @ swap - cell / ; |
|
: clearstack ( ... -- ) s0 @ sp! ; |
|
|
\ INCLUDE 9may93jaw |
\ INCLUDE 9may93jaw |
|
|
: include ( "file" -- ) |
: include ( "file" -- ) |
bl word count included ; |
name included ; |
|
|
|
: require ( "file" -- ) |
|
name required ; |
|
|
\ RECURSE 17may93jaw |
\ RECURSE 17may93jaw |
|
|
Line 1104 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1338 create nl$ 1 c, A c, 0 c, \ gnu includes
|
|
|
\ */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 1111 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1346 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 1138 Defer .status
|
Line 1369 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 1- ( line-start index2 ) |
|
0 >r BEGIN |
|
2dup + c@ bl > WHILE |
|
r> 1+ >r 1- 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 |
|
|
Line 1197 DEFER DOERROR
|
Line 1457 DEFER DOERROR
|
\ : words listwords @ |
\ : words listwords @ |
\ BEGIN @ dup WHILE dup .name REPEAT drop ; |
\ BEGIN @ dup WHILE dup .name REPEAT drop ; |
|
|
: >len ( cstring -- addr n ) 100 0 scan 0 swap 100 - /string ; |
: cstring>sstring ( cstring -- addr n ) -1 0 scan 0 swap 1+ /string ; |
: arg ( n -- addr count ) cells argv @ + @ >len ; |
: arg ( n -- addr count ) cells argv @ + @ cstring>sstring ; |
: #! postpone \ ; immediate |
: #! postpone \ ; immediate |
|
|
Variable env |
Create pathstring 2 cells allot \ string |
|
Create pathdirs 2 cells allot \ dir string array, pointer and count |
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 |
|
>in off #tib @ 0<> #tib +! ; |
|
|
|
: script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; |
|
|
|
: cold ( -- ) |
: process-path ( addr1 u1 -- addr2 u2 ) |
argc @ 1 > |
\ addr1 u1 is a path string, addr2 u2 is an array of dir strings |
IF script? |
here >r |
|
BEGIN |
|
over >r [char] : scan |
|
over r> tuck - ( rest-str this-str ) |
|
dup |
IF |
IF |
1 arg ['] included |
2dup 1- chars + c@ [char] / <> |
|
IF |
|
2dup chars + [char] / swap c! |
|
1+ |
|
THEN |
|
2, |
ELSE |
ELSE |
get-args ['] interpret |
2drop |
THEN |
THEN |
catch ?dup |
dup |
|
WHILE |
|
1 /string |
|
REPEAT |
|
2drop |
|
here r> tuck - 2 cells / ; |
|
|
|
: do-option ( addr1 len1 addr2 len2 -- n ) |
|
2swap |
|
2dup s" -e" compare 0= >r |
|
2dup s" --evaluate" compare 0= r> or |
|
IF 2drop dup >r ['] evaluate catch |
|
?dup IF dup >r DoError r> negate (bye) THEN |
|
r> >tib +! 2 EXIT THEN |
|
." Unknown option: " type cr 2drop 1 ; |
|
|
|
: process-args ( -- ) |
|
>tib @ >r |
|
true to script? |
|
argc @ 1 |
|
?DO |
|
I arg over c@ [char] - <> |
|
IF |
|
required 1 |
|
ELSE |
|
I 1+ arg do-option |
|
THEN |
|
+LOOP |
|
false to script? |
|
r> >tib ! ; |
|
|
|
Defer 'cold ' noop IS 'cold |
|
|
|
: cold ( -- ) |
|
pathstring 2@ process-path pathdirs 2! |
|
0 0 included-files 2! |
|
'cold |
|
argc @ 1 > |
|
IF |
|
['] process-args catch ?dup |
IF |
IF |
dup >r DoError cr r> (bye) |
dup >r DoError cr r> negate (bye) |
THEN |
THEN |
THEN |
THEN |
cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation" |
cr |
cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" |
." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr |
cr quit ; |
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
|
." Type `bye' to exit" |
: boot ( **env **argv argc -- ) |
loadline off quit ; |
argc ! argv ! env ! main-task up! |
|
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
: 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 ( path **argv argc -- ) |
|
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
|
sp@ dup s0 ! $10 + >tib ! #tib off >in off |
|
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 |