version 1.61, 1996/08/21 14:58:42
|
version 1.62, 1996/08/26 10:07:20
|
Line 517 Defer interpreter-notfound ( c-addr coun
|
Line 517 Defer interpreter-notfound ( c-addr coun
|
|
|
: compile-only-error ( ... -- ) |
: compile-only-error ( ... -- ) |
-&14 throw ; |
-&14 throw ; |
Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt? |
|
' compile-only-error IS interpret-special |
|
|
|
: interpret ( ?? -- ?? ) \ gforth |
: interpret ( ?? -- ?? ) \ gforth |
\ interpret/compile the (rest of the) input buffer |
\ interpret/compile the (rest of the) input buffer |
Line 605 variable backedge-locals
|
Line 603 variable backedge-locals
|
0 backedge-locals ! ; immediate |
0 backedge-locals ! ; immediate |
|
|
: ASSUME-LIVE ( orig -- orig ) \ gforth |
: ASSUME-LIVE ( orig -- orig ) \ gforth |
\ used immediateliy before a BEGIN that is not reachable from |
\ used immediatly before a BEGIN that is not reachable from |
\ above. causes the BEGIN to assume that the same locals are live |
\ above. causes the BEGIN to assume that the same locals are live |
\ as at the orig point |
\ as at the orig point |
dup orig? |
dup orig? |
Line 962 Avariable leave-sp leave-stack 3 cells
|
Line 960 Avariable leave-sp leave-stack 3 cells
|
: ," ( "string"<"> -- ) [char] " parse |
: ," ( "string"<"> -- ) [char] " parse |
here over char+ allot place align ; |
here over char+ allot place align ; |
: "lit ( -- addr ) |
: "lit ( -- addr ) |
r> r> dup count + aligned >r swap >r ; restrict |
r> r> dup count + aligned >r swap >r ; |
: (.") "lit count type ; restrict |
: (.") "lit count type ; |
: (S") "lit count ; restrict |
: (S") "lit count ; |
: SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string |
: SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string |
postpone (S") here over char+ allot place align ; |
postpone (S") here over char+ allot place align ; |
immediate restrict |
immediate restrict |
Line 1205 G forth-wordlist current T !
|
Line 1203 G forth-wordlist current T !
|
|
|
( struct ) |
( struct ) |
0 >body cell |
0 >body cell |
1 cells: field special-interpretation |
1 cells: field interpret/compile-int |
1 cells: field special-compilation |
1 cells: field interpret/compile-comp |
end-struct special-struct |
end-struct interpret/compile-struct |
|
|
: interpret/compile? ( xt -- flag ) |
: interpret/compile? ( xt -- flag ) |
>does-code ['] S" >does-code = ; |
>does-code ['] S" >does-code = ; |
|
|
|
: (cfa>int) ( cfa -- xt ) |
|
dup interpret/compile? |
|
if |
|
interpret/compile-int @ |
|
then ; |
|
|
: (x>int) ( cfa b -- xt ) |
: (x>int) ( cfa b -- xt ) |
\ get interpretation semantics of name |
\ get interpretation semantics of name |
restrict-mask and |
restrict-mask and |
if |
if |
drop ['] compile-only-error |
drop ['] compile-only-error |
else |
else |
dup interpret/compile? |
(cfa>int) |
if |
|
special-interpretation @ |
|
then |
|
then ; |
then ; |
|
|
: name>int ( nfa -- xt ) \ gforth |
: name>int ( nfa -- xt ) \ gforth |
(name>x) (x>int) ; |
(name>x) (x>int) ; |
|
|
|
: name?int ( nfa -- xt ) \ gforth |
|
\ like name>int, but throws an error if compile-only |
|
(name>x) restrict-mask and |
|
if |
|
compile-only-error \ does not return |
|
then |
|
(cfa>int) ; |
|
|
: name>comp ( nfa -- w xt ) \ gforth |
: name>comp ( nfa -- w xt ) \ gforth |
\ get compilation semantics of name |
\ get compilation semantics of name |
(name>x) >r dup interpret/compile? |
(name>x) >r dup interpret/compile? |
if |
if |
special-compilation @ |
interpret/compile-comp @ |
then |
then |
r> immediate-mask and if |
r> immediate-mask and if |
['] execute |
['] execute |
Line 1246 end-struct special-struct
|
Line 1255 end-struct special-struct
|
\ true becomes 1, false -1 |
\ true becomes 1, false -1 |
0= 2* 1+ ; |
0= 2* 1+ ; |
|
|
|
: (name>intn) ( nfa -- xt +-1 ) |
|
(name>x) tuck (x>int) ( b xt ) |
|
swap immediate-mask and flag-sign ; |
|
|
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
: search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search |
\ xt is the interpretation semantics |
\ xt is the interpretation semantics |
(search-wordlist) dup if |
(search-wordlist) dup if |
(name>x) tuck (x>int) ( b xt ) |
(name>intn) |
swap immediate-mask and flag-sign |
|
then ; |
then ; |
|
|
: find-name ( c-addr u -- nfa/0 ) |
: find-name ( c-addr u -- nfa/0 ) |
Line 1261 end-struct special-struct
|
Line 1273 end-struct special-struct
|
if ( nfa ) |
if ( nfa ) |
state @ |
state @ |
if |
if |
name>comp ['] execute = |
name>comp ['] execute = flag-sign |
else |
else |
(name>x) tuck (x>int) |
(name>intn) |
swap immediate-mask and |
|
then |
then |
flag-sign |
|
then ; |
then ; |
|
|
: find ( c-addr -- xt +-1 / c-addr 0 ) \ core |
: find ( c-addr -- xt +-1 / c-addr 0 ) \ core |
Line 1285 end-struct special-struct
|
Line 1295 end-struct special-struct
|
(') postpone ALiteral ; immediate restrict |
(') postpone ALiteral ; immediate restrict |
|
|
: ' ( "name" -- xt ) \ core tick |
: ' ( "name" -- xt ) \ core tick |
(') name>int ; |
(') name?int ; |
: ['] ( compilation "name" -- ; run-time -- xt ) \ core bracket-tick |
: ['] ( compilation "name" -- ; run-time -- xt ) \ core bracket-tick |
' postpone ALiteral ; immediate restrict |
' postpone ALiteral ; immediate restrict |
|
|