version 1.3, 1996/09/24 19:15:03
|
version 1.5, 1996/10/01 16:25:59
|
Line 179 $20 constant restrict-mask
|
Line 179 $20 constant restrict-mask
|
over + swap ; |
over + swap ; |
|
|
: save-mem ( addr1 u -- addr2 u ) \ gforth |
: save-mem ( addr1 u -- addr2 u ) \ gforth |
\ copy a memory block into a newly allocated region in the heap |
\g copy a memory block into a newly allocated region in the heap |
swap >r |
swap >r |
dup allocate throw |
dup allocate throw |
swap 2dup r> -rot move ; |
swap 2dup r> -rot move ; |
Line 276 Defer source ( -- addr count ) \ core
|
Line 276 Defer source ( -- addr count ) \ core
|
: (compile) ( -- ) \ gforth |
: (compile) ( -- ) \ gforth |
r> dup cell+ >r @ compile, ; |
r> dup cell+ >r @ compile, ; |
|
|
\ not the most efficient implementation of POSTPONE, but simple |
: postpone, ( w xt -- ) |
: POSTPONE ( -- ) \ core |
\g Compiles the compilation semantics represented by @var{w xt}. |
COMP' swap POSTPONE aliteral compile, ; immediate restrict |
dup ['] execute = |
|
if |
|
drop compile, |
|
else |
|
dup ['] compile, = |
|
if |
|
drop POSTPONE (compile) compile, |
|
else |
|
swap POSTPONE aliteral compile, |
|
then |
|
then ; |
|
|
|
: POSTPONE ( "name" -- ) \ core |
|
\g Compiles the compilation semantics of @var{name}. |
|
COMP' postpone, ; immediate restrict |
|
|
: interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth |
: interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth |
Create immediate swap A, A, |
Create immediate swap A, A, |
Line 549 Defer interpreter-notfound ( c-addr coun
|
Line 563 Defer interpreter-notfound ( c-addr coun
|
|
|
: compiler ( c-addr u -- ) |
: compiler ( c-addr u -- ) |
2dup find-name dup |
2dup find-name dup |
if ( c-addr u nfa ) |
if ( c-addr u nt ) |
nip nip name>comp execute |
nip nip name>comp execute |
else |
else |
drop |
drop |
Line 981 create nextname-buffer 32 chars allot
|
Line 995 create nextname-buffer 32 chars allot
|
alias-mask lastflags creset |
alias-mask lastflags creset |
dup A, lastcfa ! ; |
dup A, lastcfa ! ; |
|
|
: name>string ( nfa -- addr count ) \ gforth name-to-string |
: name>string ( nt -- addr count ) \ gforth name-to-string |
cell+ count $1F and ; |
\g @var{addr count} is the name of the word represented by @var{nt}. |
|
cell+ count $1F and ; |
|
|
Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
: >name ( cfa -- nfa ) \ gforth to-name |
: >name ( cfa -- nt ) \ gforth to-name |
$21 cell do |
$21 cell do |
dup i - count $9F and + cfaligned over alias-mask + = if |
dup i - count $9F and + cfaligned over alias-mask + = if |
i - cell - unloop exit |
i - cell - unloop exit |
Line 1074 AVariable current ( -- addr ) \ gforth
|
Line 1089 AVariable current ( -- addr ) \ gforth
|
|
|
: last? ( -- false / nfa nfa ) |
: last? ( -- false / nfa nfa ) |
last @ ?dup ; |
last @ ?dup ; |
: (reveal) ( nfa wid -- ) |
: (reveal) ( nt wid -- ) |
( wid>wordlist-id ) dup >r |
( wid>wordlist-id ) dup >r |
@ over ( name>link ) ! |
@ over ( name>link ) ! |
r> ! ; |
r> ! ; |
Line 1084 AVariable current ( -- addr ) \ gforth
|
Line 1099 AVariable current ( -- addr ) \ gforth
|
\ word list structure: |
\ word list structure: |
|
|
struct |
struct |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
1 cells: field find-method \ xt: ( c_addr u wid -- nt ) |
1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field |
1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field |
1 cells: field rehash-method \ xt: ( wid -- ) |
1 cells: field rehash-method \ xt: ( wid -- ) |
\ \ !! what else |
\ \ !! what else |
end-struct wordlist-map-struct |
end-struct wordlist-map-struct |
Line 1097 struct
|
Line 1112 struct
|
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 ( addr len wordlist -- nt / false ) |
( wid>wordlist-id ) @ (f83find) ; |
( wid>wordlist-id ) @ (f83find) ; |
|
|
\ Search list table: find reveal |
\ Search list table: find reveal |
Line 1134 end-struct interpret/compile-struct
|
Line 1149 end-struct interpret/compile-struct
|
(cfa>int) |
(cfa>int) |
then ; |
then ; |
|
|
: name>int ( nfa -- xt ) \ gforth |
: name>int ( nt -- xt ) \ gforth |
|
\G @var{xt} represents the interpretation semantics of the word |
|
\G @var{nt}. Produces @code{' compile-only-error} if |
|
\G @var{nt} is compile-only. |
(name>x) (x>int) ; |
(name>x) (x>int) ; |
|
|
: name?int ( nfa -- xt ) \ gforth |
: name?int ( nt -- xt ) \ gforth |
\G like name>int, but throws an error if compile-only |
\G Like name>int, but throws an error if compile-only. |
(name>x) restrict-mask and |
(name>x) restrict-mask and |
if |
if |
compile-only-error \ does not return |
compile-only-error \ does not return |
then |
then |
(cfa>int) ; |
(cfa>int) ; |
|
|
: name>comp ( nfa -- w xt ) \ gforth |
: name>comp ( nt -- w xt ) \ gforth |
\G get compilation semantics of name |
\G @var{w xt} is the compilation token wor the word @var{nt}. |
(name>x) >r dup interpret/compile? |
(name>x) >r dup interpret/compile? |
if |
if |
interpret/compile-comp @ |
interpret/compile-comp @ |
Line 1157 end-struct interpret/compile-struct
|
Line 1175 end-struct interpret/compile-struct
|
['] compile, |
['] compile, |
then ; |
then ; |
|
|
: (search-wordlist) ( addr count wid -- nfa / false ) |
: (search-wordlist) ( addr count wid -- nt / false ) |
dup wordlist-map @ find-method perform ; |
dup wordlist-map @ find-method perform ; |
|
|
: flag-sign ( f -- 1|-1 ) |
: flag-sign ( f -- 1|-1 ) |
Line 1174 end-struct interpret/compile-struct
|
Line 1192 end-struct interpret/compile-struct
|
(name>intn) |
(name>intn) |
then ; |
then ; |
|
|
: find-name ( c-addr u -- nfa/0 ) |
: find-name ( c-addr u -- nt/0 ) \ gforth |
|
\g Find the name @var{c-addr u} in the current search |
|
\g order. Return its nt, if found, otherwise 0. |
lookup @ (search-wordlist) ; |
lookup @ (search-wordlist) ; |
|
|
: sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete |
: sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete |
find-name dup |
find-name dup |
if ( nfa ) |
if ( nt ) |
state @ |
state @ |
if |
if |
name>comp ['] execute = flag-sign |
name>comp ['] execute = flag-sign |
Line 1194 end-struct interpret/compile-struct
|
Line 1214 end-struct interpret/compile-struct
|
rot drop |
rot drop |
then ; |
then ; |
|
|
: (') ( "name" -- nfa ) \ gforth |
: (') ( "name" -- nt ) \ gforth |
name find-name dup 0= |
name find-name dup 0= |
IF |
IF |
drop -&13 bounce |
drop -&13 bounce |
THEN ; |
THEN ; |
|
|
: [(')] ( compilation "name" -- ; run-time -- nfa ) \ gforth bracket-paren-tick |
: [(')] ( compilation "name" -- ; run-time -- nt ) \ gforth bracket-paren-tick |
(') postpone ALiteral ; immediate restrict |
(') postpone ALiteral ; immediate restrict |
|
|
: ' ( "name" -- xt ) \ core tick |
: ' ( "name" -- xt ) \ core tick |
|
\g @var{xt} represents @var{name}'s interpretation |
|
\g semantics. Performs @code{-14 throw} if the word has no |
|
\g interpretation semantics. |
(') name?int ; |
(') name?int ; |
: ['] ( compilation "name" -- ; run-time -- xt ) \ core bracket-tick |
: ['] ( compilation. "name" -- ; run-time. -- xt ) \ core bracket-tick |
|
\g @var{xt} represents @var{name}'s interpretation |
|
\g semantics. Performs @code{-14 throw} if the word has no |
|
\g interpretation semantics. |
' postpone ALiteral ; immediate restrict |
' postpone ALiteral ; immediate restrict |
|
|
: COMP' ( "name" -- w xt ) \ gforth c-tick |
: COMP' ( "name" -- w xt ) \ gforth c-tick |
|
\g @var{w xt} represents @var{name}'s compilation semantics. |
(') name>comp ; |
(') name>comp ; |
: [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick |
: [COMP'] ( compilation "name" -- ; run-time -- w xt ) \ gforth bracket-comp-tick |
|
\g @var{w xt} represents @var{name}'s compilation semantics. |
COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict |
COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict |
|
|
\ reveal words |
\ reveal words |
Line 1236 G -1 warnings T !
|
Line 1264 G -1 warnings T !
|
if \ the last word has a header |
if \ the last word has a header |
dup ( name>link ) @ 1 and |
dup ( name>link ) @ 1 and |
if \ it is still hidden |
if \ it is still hidden |
dup ( name>link ) @ 1 xor ( nfa wid ) |
dup ( name>link ) @ 1 xor ( nt wid ) |
2dup >r name>string r> check-shadow ( nfa wid ) |
2dup >r name>string r> check-shadow ( nt wid ) |
dup wordlist-map @ reveal-method perform |
dup wordlist-map @ reveal-method perform |
then |
then |
then ; |
then ; |
Line 1783 Defer 'cold ' noop IS 'cold
|
Line 1811 Defer 'cold ' noop IS 'cold
|
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; |
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; |
|
|
: boot ( path **argv argc -- ) |
: boot ( path **argv argc -- ) |
argc ! argv ! cstring>sstring pathstring 2! main-task up! |
argc ! argv ! cstring>sstring save-mem pathstring 2! main-task up! |
sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off |
sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off |
rp@ r0 ! fp@ f0 ! ['] cold catch DoError bye ; |
rp@ r0 ! fp@ f0 ! ['] cold catch DoError bye ; |
|
|