version 1.129, 2002/09/26 11:36:42
|
version 1.136, 2003/01/20 17:07:37
|
Line 1175 false DefaultValue backtrace
|
Line 1175 false DefaultValue backtrace
|
false DefaultValue new-input |
false DefaultValue new-input |
false DefaultValue peephole |
false DefaultValue peephole |
false DefaultValue abranch |
false DefaultValue abranch |
|
true DefaultValue control-rack |
[THEN] |
[THEN] |
|
|
true DefaultValue interpreter |
true DefaultValue interpreter |
Line 1411 T has? rom H
|
Line 1412 T has? rom H
|
|
|
\ MakeKernel 22feb99jaw |
\ MakeKernel 22feb99jaw |
|
|
: makekernel ( targetsize -- ) |
: makekernel ( start targetsize -- ) |
\G convenience word to setup the memory of the target |
\G convenience word to setup the memory of the target |
\G used by main.fs of the c-engine based systems |
\G used by main.fs of the c-engine based systems |
100 swap dictionary (region) |
dictionary (region) setup-target ; |
setup-target ; |
|
|
|
>MINIMAL |
>MINIMAL |
: makekernel makekernel ; |
: makekernel makekernel ; |
Line 1703 Ghost (loop) Ghost (+loop)
|
Line 1703 Ghost (loop) Ghost (+loop)
|
Ghost (next) drop |
Ghost (next) drop |
Ghost (does>) Ghost (compile) 2drop |
Ghost (does>) Ghost (compile) 2drop |
Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop |
Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop |
Ghost (C") drop |
Ghost (C") Ghost c(abort") Ghost type 2drop drop |
Ghost ' drop |
Ghost ' drop |
|
|
\ user ghosts |
\ user ghosts |
Line 1732 Ghost state drop
|
Line 1732 Ghost state drop
|
|
|
: ht-string, ( addr count -- ) |
: ht-string, ( addr count -- ) |
dup there swap last-string 2! |
dup there swap last-string 2! |
dup T c, H bounds ?DO I c@ T c, H LOOP ; |
dup T c, H bounds ?DO I c@ T c, H LOOP ; |
|
: ht-mem, ( addr count ) |
|
bounds ?DO I c@ T c, H LOOP ; |
|
|
>TARGET |
>TARGET |
|
|
Line 2267 Defer setup-prim-semantics
|
Line 2269 Defer setup-prim-semantics
|
|
|
Variable prim# |
Variable prim# |
: first-primitive ( n -- ) prim# ! ; |
: first-primitive ( n -- ) prim# ! ; |
|
: group 0 word drop prim# @ 1- -$200 and prim# ! ; |
: Primitive ( -- ) \ name |
: Primitive ( -- ) \ name |
>in @ skip? IF drop EXIT THEN >in ! |
>in @ skip? IF drop EXIT THEN >in ! |
s" prims" T $has? H 0= |
s" prims" T $has? H 0= |
Line 2577 Cond: [ ( -- ) interpreting-state ;Cond
|
Line 2580 Cond: [ ( -- ) interpreting-state ;Cond
|
|
|
Defer instant-interpret-does>-hook |
Defer instant-interpret-does>-hook |
|
|
|
T has? peephole H [IF] |
: does-resolved ( ghost -- ) |
: does-resolved ( ghost -- ) |
compile does-exec g>xt T a, H ; |
compile does-exec g>xt T a, H ; |
|
[ELSE] |
|
: does-resolved ( ghost -- ) |
|
g>xt T a, H ; |
|
[THEN] |
|
|
: resolve-does>-part ( -- ) |
: resolve-does>-part ( -- ) |
\ resolve words made by builders |
\ resolve words made by builders |
Line 2926 compile: does-resolved ;compile
|
Line 2934 compile: does-resolved ;compile
|
|
|
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
: >mark ( -- sys ) T here ( dup ." M" hex. ) 0 , H ; |
|
|
: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw |
X has? abranch [IF] |
|
: branchoffset ( src dest -- ) drop ; |
|
: offset, ( n -- ) X A, ; |
|
[ELSE] |
|
: branchoffset ( src dest -- ) - tchar / ; \ ?? jaw |
|
: offset, ( n -- ) X , ; |
|
[THEN] |
|
|
:noname compile branch X here branchoffset X , ; |
:noname compile branch X here branchoffset offset, ; |
IS branch, ( target-addr -- ) |
IS branch, ( target-addr -- ) |
:noname compile ?branch X here branchoffset X , ; |
:noname compile ?branch X here branchoffset offset, ; |
IS ?branch, ( target-addr -- ) |
IS ?branch, ( target-addr -- ) |
:noname compile branch T here 0 , H ; |
:noname compile branch T here 0 H offset, ; |
IS branchmark, ( -- branchtoken ) |
IS branchmark, ( -- branchtoken ) |
:noname compile ?branch T here 0 , H ; |
:noname compile ?branch T here 0 H offset, ; |
IS ?branchmark, ( -- branchtoken ) |
IS ?branchmark, ( -- branchtoken ) |
:noname T here 0 , H ; |
:noname T here 0 H offset, ; |
IS ?domark, ( -- branchtoken ) |
IS ?domark, ( -- branchtoken ) |
:noname dup X @ ?struc X here over branchoffset swap X ! ; |
:noname dup X @ ?struc X here over branchoffset swap X ! ; |
IS branchtoresolve, ( branchtoken -- ) |
IS branchtoresolve, ( branchtoken -- ) |
Line 3009 Cond: ?LEAVE ?leave, ;Cond
|
Line 3023 Cond: ?LEAVE ?leave, ;Cond
|
|
|
: loop] ( target-addr -- ) |
: loop] ( target-addr -- ) |
branchto, |
branchto, |
dup X here branchoffset X , |
dup X here branchoffset offset, |
tcell - (done) ; |
tcell - (done) ; |
|
|
: skiploop] ?dup IF branchto, branchtoresolve, THEN ; |
: skiploop] ?dup IF branchto, branchtoresolve, THEN ; |
Line 3114 Cond: LOOP 1 ncontrols? loop, ;Cond
|
Line 3128 Cond: LOOP 1 ncontrols? loop, ;Cond
|
Cond: +LOOP 1 ncontrols? +loop, ;Cond |
Cond: +LOOP 1 ncontrols? +loop, ;Cond |
Cond: NEXT 1 ncontrols? next, ;Cond |
Cond: NEXT 1 ncontrols? next, ;Cond |
|
|
\ Absoulte branches 26sep02jaw |
|
|
|
\ This section defined different semantics for |
|
\ conditionals, using and compiling absolute branches |
|
|
|
X has? abranch [IF] |
|
|
|
Ghost abranch drop |
|
Ghost a?branch drop |
|
Ghost a(?do) drop |
|
Ghost a(do) drop |
|
Ghost a(next) drop |
|
Ghost a(+loop) drop |
|
Ghost a(loop) drop |
|
|
|
:noname compile abranch X a, ; plugin-of branch, |
|
|
|
:noname compile a?branch X a, ; plugin-of ?branch, |
|
|
|
:noname compile abranch T here 0 a, H ; plugin-of branchmark, |
|
|
|
:noname compile a?branch T here 0 a, H ; plugin-of ?branchmark, |
|
|
|
:noname |
|
dup X @ ABORT" CROSS: branch already resolved" |
|
X here swap X a! ; plugin-of branchtoresolve, |
|
|
|
:noname |
|
0 compile a(?do) ?domark, (leave) |
|
branchtomark, 2 to1 ; plugin-of ?do, |
|
|
|
: aloop] ( target-addr -- ) |
|
branchto, |
|
dup X a, |
|
tcell - (done) ; |
|
|
|
:noname |
|
1to compile a(loop) aloop] |
|
compile unloop skiploop] ; plugin-of loop, |
|
|
|
:noname |
|
1to compile a(+loop) aloop] |
|
compile unloop skiploop] ; plugin-of +loop, |
|
|
|
:noname |
|
compile a(next) aloop] compile unloop ; plugin-of next, |
|
|
|
[THEN] |
|
|
|
\ String words 23feb93py |
\ String words 23feb93py |
|
|
: ," [char] " parse ht-string, X align ; |
: ," [char] " parse ht-string, X align ; |
|
|
|
X has? control-rack [IF] |
Cond: ." compile (.") T ," H ;Cond |
Cond: ." compile (.") T ," H ;Cond |
Cond: S" compile (S") T ," H ;Cond |
Cond: S" compile (S") T ," H ;Cond |
Cond: C" compile (C") T ," H ;Cond |
Cond: C" compile (C") T ," H ;Cond |
Cond: ABORT" compile (ABORT") T ," H ;Cond |
Cond: ABORT" compile (ABORT") T ," H ;Cond |
|
[ELSE] |
|
Cond: ." '" parse tuck 2>r ahead, there 2r> ht-mem, X align |
|
>r then, r> compile ALiteral compile Literal compile type ;Cond |
|
Cond: S" '" parse tuck 2>r ahead, there 2r> ht-mem, X align |
|
>r then, r> compile ALiteral compile Literal ;Cond |
|
Cond: C" ahead, there [char] " parse ht-string, X align |
|
>r then, r> compile ALiteral ;Cond |
|
Cond: ABORT" if, ahead, there [char] " parse ht-string, X align |
|
>r then, r> compile ALiteral compile c(abort") then, ;Cond |
|
[THEN] |
|
|
Cond: IS T ' >body H compile ALiteral compile ! ;Cond |
Cond: IS T ' >body H compile ALiteral compile ! ;Cond |
: IS T >address ' >body ! H ; |
: IS T >address ' >body ! H ; |
Line 3215 Cond: postpone ( -- ) \ name
|
Line 3191 Cond: postpone ( -- ) \ name
|
hex |
hex |
|
|
>CROSS |
>CROSS |
Create magic s" Gforth2x" here over allot swap move |
Create magic s" Gforth3x" here over allot swap move |
|
|
bigendian 1+ \ strangely, in magic big=0, little=1 |
bigendian 1+ \ strangely, in magic big=0, little=1 |
tcell 1 = 0 and or |
tcell 1 = 0 and or |
Line 3704 previous
|
Line 3680 previous
|
: bye bye ; |
: bye bye ; |
|
|
\ dummy |
\ dummy |
: group 0 word drop ; |
|
|
|
\ turnkey direction |
\ turnkey direction |
: H forth ; immediate |
: H forth ; immediate |