version 1.12, 1994/07/21 10:52:44
|
version 1.16, 1994/08/31 16:37:48
|
Line 142 Defer source
|
Line 142 Defer source
|
dup count chars bounds |
dup count chars bounds |
?DO I c@ toupper I c! 1 chars +LOOP ; |
?DO I c@ toupper I c! 1 chars +LOOP ; |
: (name) ( -- addr ) bl word ; |
: (name) ( -- addr ) bl word ; |
\ : (cname) ( -- addr ) bl word capitalize ; |
: sname ( -- c-addr count ) |
|
source 2dup >r >r >in @ /string (parse-white) |
|
2dup + r> - 1+ r> min >in ! ; |
|
\ name count ; |
|
|
\ Literal 17dec92py |
\ Literal 17dec92py |
|
|
Line 203 Create bases 10 , 2 , A , 100 ,
|
Line 206 Create bases 10 , 2 , A , 100 ,
|
REPEAT THEN 2drop rdrop dpl off ELSE |
REPEAT THEN 2drop rdrop dpl off ELSE |
2drop rdrop r> IF dnegate THEN |
2drop rdrop r> IF dnegate THEN |
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> ) |
: number? ( string -- string 0 / n -1 / d 0> ) |
dup count s>number dpl @ 0= IF 2drop false EXIT THEN |
dup >r count snumber? dup if |
rot drop dpl @ dup 0> 0= IF nip THEN ; |
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 304 hex
|
Line 318 hex
|
|
|
Defer parser |
Defer parser |
Defer name ' (name) IS name |
Defer name ' (name) IS name |
Defer notfound |
Defer notfound ( c-addr count -- ) |
|
|
: no.extensions ( string -- ) IF -&13 bounce THEN ; |
: no.extensions ( addr u -- ) 2drop -&13 bounce ; |
|
|
' no.extensions IS notfound |
' no.extensions IS notfound |
|
|
: interpret |
: interpret |
BEGIN ?stack name dup c@ WHILE parser REPEAT drop ; |
BEGIN |
|
?stack sname dup |
\ interpreter compiler 30apr92py |
WHILE |
|
parser |
: interpreter ( name -- ) find ?dup |
REPEAT |
IF 1 and IF execute EXIT THEN -&14 throw THEN |
2drop ; |
number? 0= IF notfound THEN ; |
|
|
\ sinterpreter scompiler 30apr92py |
|
|
|
: sinterpreter ( c-addr u -- ) |
|
\ interpretation semantics for the name/number c-addr u |
|
2dup sfind dup |
|
IF |
|
1 and |
|
IF \ not restricted to compile state? |
|
nip nip execute EXIT |
|
THEN |
|
-&14 throw |
|
THEN |
|
drop |
|
2dup 2>r snumber? |
|
IF |
|
2rdrop |
|
ELSE |
|
2r> notfound |
|
THEN ; |
|
|
' interpreter IS parser |
' sinterpreter IS parser |
|
|
: compiler ( name -- ) find ?dup |
: scompiler ( c-addr u -- ) |
IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup |
\ compilation semantics for the name/number c-addr u |
IF 0> IF swap postpone Literal THEN postpone Literal |
2dup sfind dup |
ELSE drop notfound THEN ; |
IF |
|
0> |
|
IF |
|
nip nip execute EXIT |
|
THEN |
|
compile, 2drop EXIT |
|
THEN |
|
drop |
|
2dup snumber? dup |
|
IF |
|
0> |
|
IF |
|
swap postpone Literal |
|
THEN |
|
postpone Literal |
|
2drop |
|
ELSE |
|
drop notfound |
|
THEN ; |
|
|
: [ ['] interpreter IS parser state off ; immediate |
: [ ['] sinterpreter IS parser state off ; immediate |
: ] ['] compiler IS parser state on ; |
: ] ['] scompiler IS parser state on ; |
|
|
\ locals stuff needed for control structures |
\ locals stuff needed for control structures |
|
|
Line 489 variable dead-code \ true if normal code
|
Line 540 variable dead-code \ true if normal code
|
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ better handled by tools like stack checkers |
\ better handled by tools like stack checkers |
POSTPONE ?dup POSTPONE if ; immediate restrict |
POSTPONE ?dup POSTPONE if ; immediate restrict |
: ?DUP-NOT-IF \ general |
: ?DUP-0=-IF \ general |
POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
|
|
: THEN ( orig -- ) |
: THEN ( orig -- ) |
Line 729 Avariable leave-sp leave-stack 3 cells
|
Line 780 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 |
|
|
: name, ( "name" -- ) |
: name, ( "name" -- ) |
name c@ |
name c@ |
dup $1F u> -&19 and throw ( is name too long? ) |
dup $1F u> -&19 and throw ( is name too long? ) |
1+ chars allot align ; |
1+ chars allot align ; |
|
|
: input-stream-header ( "name" -- ) |
: input-stream-header ( "name" -- ) |
\ !! this is f83-implementation-dependent |
\ !! this is f83-implementation-dependent |
align here last ! -1 A, |
align here last ! -1 A, |
Line 742 defer header
|
Line 795 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 762 create nextname-buffer 32 chars allot
|
Line 815 create nextname-buffer 32 chars allot
|
dup $1F u> -&19 and throw ( is name too long? ) |
dup $1F u> -&19 and throw ( is name too long? ) |
nextname-buffer c! ( c-addr ) |
nextname-buffer c! ( c-addr ) |
nextname-buffer count move |
nextname-buffer count move |
['] nextname-header IS header ; |
['] nextname-header IS (header) ; |
|
|
: noname-header ( -- ) |
: noname-header ( -- ) |
0 last ! |
0 last ! |
Line 770 create nextname-buffer 32 chars allot
|
Line 823 create nextname-buffer 32 chars allot
|
|
|
: 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 839 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 892 Create ??? 0 , 3 c, char ? c, char ? c,
|
|
|
\ 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 936 Variable warnings G -1 warnings T !
|
Line 992 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 ; |
search @ 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 947 Variable warnings G -1 warnings T !
|
Line 1009 Variable warnings G -1 warnings T !
|
|
|
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
|
|
: ' ( "name" -- addr ) name find 0= no.extensions ; |
: ' ( "name" -- addr ) name find 0= if drop -&13 bounce then ; |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
\ Input 13feb93py |
\ Input 13feb93py |
|
|
07 constant #bell |
07 constant #bell |
08 constant #bs |
08 constant #bs |
|
09 constant #tab |
7F constant #del |
7F constant #del |
0D constant #cr \ the newline key code |
0D constant #cr \ the newline key code |
0A constant #lf |
0A constant #lf |
|
0C constant #ff |
|
|
: bell #bell emit ; |
: bell #bell emit ; |
|
|
Line 1105 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1169 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 1227 Variable argc
|
Line 1292 Variable argc
|
dup >r DoError cr r> negate (bye) |
dup >r DoError cr r> negate (bye) |
THEN |
THEN |
THEN |
THEN |
." 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" |
|
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 |
." it under the terms of the GNU General Public License as published by" cr |
." it under the terms of the GNU General Public License as published by" cr |
." the Free Software Foundation; either version 1, or (at your option)" cr |
." the Free Software Foundation; either version 2 of the License, or" cr |
." any later version." cr cr |
." (at your option) any later version." cr cr |
|
|
." This program is distributed in the hope that it will be useful," 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 |
." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr |