version 1.22, 1994/10/24 19:16:00
|
version 1.35, 1995/04/20 09:42:55
|
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 |
: chars ; immediate |
|
|
: A! ( addr1 addr2 -- ) dup relon ! ; |
: A! ( addr1 addr2 -- ) dup relon ! ; |
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 142 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 |
Line 162 Defer source
|
Line 173 Defer source
|
2dup + r> - 1+ r> min >in ! ; |
2dup + r> - 1+ r> min >in ! ; |
\ name count ; |
\ 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 |
|
|
: Literal ( n -- ) state @ IF postpone lit , THEN ; |
: Literal ( n -- ) state @ IF postpone lit , THEN ; |
Line 244 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 355 Defer notfound ( c-addr count -- )
|
Line 375 Defer notfound ( c-addr count -- )
|
IF |
IF |
1 and |
1 and |
IF \ not restricted to compile state? |
IF \ not restricted to compile state? |
nip nip execute EXIT |
nip nip execute EXIT |
THEN |
THEN |
-&14 throw |
-&14 throw |
THEN |
THEN |
Line 690 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 766 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 |
: \ blk @ IF >in @ c/l / 1+ c/l * >in ! EXIT THEN |
: \ ( -- ) \ core-ext backslash |
source >in ! drop ; immediate |
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 799 Avariable leave-sp leave-stack 3 cells
|
Line 837 Avariable leave-sp leave-stack 3 cells
|
defer (header) |
defer (header) |
defer header ' (header) IS 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 |
name name-too-short? name-too-long? |
dup $1F u> -&19 and throw ( is name too long? ) |
string, cfalign ; |
dup c, here swap chars dup allot move 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 821 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 |
Line 853 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 899 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 |
Line 962 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) ; |
|
|
Line 986 AVariable lookup G forth-wordlist
|
Line 1028 AVariable lookup G forth-wordlist
|
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 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 1020 Variable warnings G -1 warnings T !
|
Line 1062 Variable warnings G -1 warnings T !
|
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 sfind 0= if -&13 bounce then ; |
: ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ; |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
Line 1038 Variable warnings G -1 warnings T !
|
Line 1080 Variable warnings G -1 warnings T !
|
|
|
: 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 1133 Defer key
|
Line 1175 Defer key
|
\ : 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 1194 create pathfilenamebuf 256 chars allot \
|
Line 1236 create pathfilenamebuf 256 chars allot \
|
0<> -&38 and throw ( file-id u2 ) |
0<> -&38 and throw ( file-id u2 ) |
pathfilenamebuf swap ; |
pathfilenamebuf swap ; |
|
|
: included ( i*x addr u -- j*x ) |
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 ; |
|
|
|
: 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 |
open-path-file ( file-id c-addr2 u2 ) |
save-string 2dup loadfilename 2! add-included-file ( file-id ) |
dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 ) |
|
drop loadfilename 2@ move |
|
['] include-file catch |
['] include-file catch |
\ don't free filenames; they don't take much space |
|
\ and are used for debugging |
|
r> r> loadfilename 2! throw ; |
r> r> loadfilename 2! throw ; |
|
|
|
: included ( i*x addr u -- j*x ) |
|
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 1219 create pathfilenamebuf 256 chars allot \
|
Line 1303 create pathfilenamebuf 256 chars allot \
|
: include ( "file" -- ) |
: include ( "file" -- ) |
name included ; |
name included ; |
|
|
|
: require ( "file" -- ) |
|
name required ; |
|
|
\ RECURSE 17may93jaw |
\ RECURSE 17may93jaw |
|
|
: recurse ( -- ) |
: recurse ( -- ) |
Line 1382 Variable argc
|
Line 1469 Variable argc
|
2drop |
2drop |
here r> tuck - 2 cells / ; |
here r> tuck - 2 cells / ; |
|
|
: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; |
: do-option ( addr1 len1 addr2 len2 -- n ) |
|
2swap |
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
2dup s" -e" compare 0= >r |
2dup s" -e" compare 0= >r |
2dup s" --evaluate" compare 0= r> or |
2dup s" -evaluate" compare 0= r> or |
IF 2drop dup >r ['] evaluate catch |
IF 2drop ">tib interpret 2 EXIT THEN |
?dup IF dup >r DoError r> negate (bye) THEN |
." Unknown option: " type cr 2drop 1 ; |
r> >tib +! 2 EXIT THEN |
|
." Unknown option: " type cr 2drop 1 ; |
|
|
: process-args ( -- ) |
: process-args ( -- ) |
|
>tib @ >r |
|
true to script? |
argc @ 1 |
argc @ 1 |
?DO |
?DO |
I arg over c@ [char] - <> |
I arg over c@ [char] - <> |
IF |
IF |
true to script? included false to script? 1 |
required 1 |
ELSE |
ELSE |
I 1+ arg do-option |
I 1+ arg do-option |
THEN |
THEN |
+LOOP ; |
+LOOP |
|
false to script? |
|
r> >tib ! ; |
|
|
|
Defer 'cold ' noop IS 'cold |
|
|
: cold ( -- ) |
: cold ( -- ) |
pathstring 2@ process-path pathdirs 2! |
pathstring 2@ process-path pathdirs 2! |
|
0 0 included-files 2! |
|
'cold |
argc @ 1 > |
argc @ 1 > |
IF |
IF |
['] process-args catch ?dup |
['] process-args catch ?dup |
Line 1414 Variable argc
|
Line 1510 Variable argc
|
." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." 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 |
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
." Type `bye' to exit" |
." Type `bye' to exit" |
quit ; |
loadline off quit ; |
|
|
: license ( -- ) cr |
: license ( -- ) cr |
." This program is free software; you can redistribute it and/or modify" cr |
." This program is free software; you can redistribute it and/or modify" cr |
Line 1433 Variable argc
|
Line 1529 Variable argc
|
|
|
: boot ( path **argv argc -- ) |
: boot ( path **argv argc -- ) |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
sp@ dup s0 ! $10 + >tib ! #tib off >in off |
|
rp@ r0 ! fp@ f0 ! cold ; |
|
|
: bye script? 0= IF cr THEN 0 (bye) ; |
: bye script? 0= IF cr THEN 0 (bye) ; |
|
|