version 1.134, 2003/01/03 17:28:12
|
version 1.170, 2010/04/18 06:18:36
|
Line 1
|
Line 1
|
\ CROSS.FS The Cross-Compiler 06oct92py |
\ CROSS.FS The Cross-Compiler 06oct92py |
\ Idea and implementation: Bernd Paysan (py) |
\ Idea and implementation: Bernd Paysan (py) |
|
|
\ Copyright (C) 1995,1996,1997,1998,1999,2000 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,1999,2000,2003,2004,2005,2006,2007,2009 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
\ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
\ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
\ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
\ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
|
|
\ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
Line 16
|
Line 16
|
\ GNU General Public License for more details. |
\ GNU General Public License for more details. |
|
|
\ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
\ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA. |
|
|
|
0 |
0 |
[IF] |
[IF] |
Line 192 Create bases 10 , 2 , A , 100 ,
|
Line 191 Create bases 10 , 2 , A , 100 ,
|
1+ |
1+ |
THEN ; |
THEN ; |
|
|
: number? ( string -- string 0 / n -1 / d 0> ) |
: (number?) ( string -- string 0 / n -1 / d 0> ) |
dup >r count snumber? dup if |
dup >r count snumber? dup if |
rdrop |
rdrop |
else |
else |
Line 200 Create bases 10 , 2 , A , 100 ,
|
Line 199 Create bases 10 , 2 , A , 100 ,
|
then ; |
then ; |
|
|
: number ( string -- d ) |
: number ( string -- d ) |
number? ?dup 0= abort" ?" 0< |
(number?) ?dup 0= abort" ?" 0< |
IF |
IF |
s>d |
s>d |
THEN ; |
THEN ; |
|
|
[THEN] |
[THEN] |
|
|
|
[IFUNDEF] (number?) : (number?) number? ; [THEN] |
|
|
\ this provides assert( and struct stuff |
\ this provides assert( and struct stuff |
\GFORTH [IFUNDEF] assert1( |
\GFORTH [IFUNDEF] assert1( |
\GFORTH also forth definitions require assert.fs previous |
\GFORTH also forth definitions require assert.fs previous |
Line 447 sourcepath value fpath
|
Line 448 sourcepath value fpath
|
\G Make a complete new Forth search path; the path separator is |. |
\G Make a complete new Forth search path; the path separator is |. |
fpath path= ; |
fpath path= ; |
|
|
: path>counted cell+ dup cell+ swap @ ; |
: path>string cell+ dup cell+ swap @ ; |
|
|
: next-path ( adr len -- adr2 len2 ) |
: next-path ( adr len -- adr2 len2 ) |
2dup 0 scan |
2dup 0 scan |
Line 456 sourcepath value fpath
|
Line 457 sourcepath value fpath
|
r> - ; |
r> - ; |
|
|
: previous-path ( path^ -- ) |
: previous-path ( path^ -- ) |
dup path>counted |
dup path>string |
BEGIN tuck dup WHILE repeat ; |
BEGIN tuck dup WHILE repeat ; |
|
|
: .path ( path-addr -- ) \ gforth |
: .path ( path-addr -- ) \ gforth |
\G Display the contents of the search path @var{path-addr}. |
\G Display the contents of the search path @var{path-addr}. |
path>counted |
path>string |
BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ; |
BEGIN next-path dup WHILE type space REPEAT 2drop 2drop ; |
|
|
: .fpath ( -- ) \ gforth |
: .fpath ( -- ) \ gforth |
Line 546 Create tfile 0 c, 255 chars allot
|
Line 547 Create tfile 0 c, 255 chars allot
|
IF rdrop |
IF rdrop |
ofile place open-ofile |
ofile place open-ofile |
dup 0= IF >r ofile count r> THEN EXIT |
dup 0= IF >r ofile count r> THEN EXIT |
ELSE r> path>counted |
ELSE r> path>string |
BEGIN next-path dup |
BEGIN next-path dup |
WHILE 5 pick 5 pick check-path |
WHILE 5 pick 5 pick check-path |
0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN |
0= IF >r 2drop 2drop r> ofile count 0 EXIT ELSE drop THEN |
Line 662 stack-warn [IF]
|
Line 663 stack-warn [IF]
|
: defempty? empty? ; |
: defempty? empty? ; |
[ELSE] |
[ELSE] |
: defempty? ; immediate |
: defempty? ; immediate |
|
\ : defempty? .sourcepos ; |
[THEN] |
[THEN] |
|
|
\ \ -------------------- Compiler Plug Ins 01aug97jaw |
\ \ -------------------- Compiler Plug Ins 01aug97jaw |
Line 1174 false DefaultValue header
|
Line 1176 false DefaultValue header
|
false DefaultValue backtrace |
false DefaultValue backtrace |
false DefaultValue new-input |
false DefaultValue new-input |
false DefaultValue peephole |
false DefaultValue peephole |
|
false DefaultValue primcentric |
false DefaultValue abranch |
false DefaultValue abranch |
true DefaultValue control-rack |
true DefaultValue f83headerstring |
|
true DefaultValue control-rack |
[THEN] |
[THEN] |
|
|
|
true DefaultValue gforthcross |
true DefaultValue interpreter |
true DefaultValue interpreter |
true DefaultValue ITC |
true DefaultValue ITC |
false DefaultValue rom |
false DefaultValue rom |
|
false DefaultValue flash |
true DefaultValue standardthreading |
true DefaultValue standardthreading |
|
|
|
\ ANSForth environment stuff |
|
8 DefaultValue ADDRESS-UNIT-BITS |
|
255 DefaultValue MAX-CHAR |
|
255 DefaultValue /COUNTED-STRING |
|
|
>TARGET |
>TARGET |
s" relocate" T environment? H |
s" relocate" T environment? H |
\ JAW why set NIL to this?! |
\ JAW why set NIL to this?! |
Line 1234 bits/byte Constant tbits/byte
|
Line 1245 bits/byte Constant tbits/byte
|
H |
H |
tbits/char bits/byte / Constant tbyte |
tbits/char bits/byte / Constant tbyte |
|
|
|
: >signed ( u -- n ) |
|
1 tbits/char tcell * 1- lshift 2dup and |
|
IF negate or ELSE drop THEN ; |
|
|
\ Variables 06oct92py |
\ Variables 06oct92py |
|
|
Variable image |
|
Variable (tlast) |
Variable (tlast) |
(tlast) Value tlast TNIL tlast ! \ Last name field |
(tlast) Value tlast TNIL tlast ! \ Last name field |
Variable tlastcfa \ Last code field |
Variable tlastcfa \ Last code field |
Variable bit$ |
|
|
|
\ statistics 10jun97jaw |
\ statistics 10jun97jaw |
|
|
Line 1263 Variable region-link \ linked
|
Line 1275 Variable region-link \ linked
|
Variable mirrored-link \ linked list for mirrored regions |
Variable mirrored-link \ linked list for mirrored regions |
0 dup mirrored-link ! region-link ! |
0 dup mirrored-link ! region-link ! |
|
|
: >rname 8 cells + ; |
: >rname 9 cells + ; |
|
: >rtouch 8 cells + ; \ executed when region is accessed |
: >rbm 4 cells + ; \ bitfield per cell witch indicates relocation |
: >rbm 4 cells + ; \ bitfield per cell witch indicates relocation |
: >rmem 5 cells + ; |
: >rmem 5 cells + ; |
: >rtype 6 cells + ; \ field per cell witch points to a type struct |
: >rtype 6 cells + ; \ field per cell witch points to a type struct |
Line 1278 Variable mirrored-link \ linked
|
Line 1291 Variable mirrored-link \ linked
|
>r r@ last-defined-region ! |
>r r@ last-defined-region ! |
r@ >rlen ! dup r@ >rstart ! r> >rdp ! ; |
r@ >rlen ! dup r@ >rstart ! r> >rdp ! ; |
|
|
|
: uninitialized -1 ABORT" CROSS: Region is uninitialized" ; |
|
|
: region ( addr len -- "name" ) |
: region ( addr len -- "name" ) |
\G create a new region |
\G create a new region |
\ check whether predefined region exists |
\ check whether predefined region exists |
Line 1287 Variable mirrored-link \ linked
|
Line 1302 Variable mirrored-link \ linked
|
save-input create restore-input throw |
save-input create restore-input throw |
here last-defined-region ! |
here last-defined-region ! |
over ( startaddr ) , ( length ) , ( dp ) , |
over ( startaddr ) , ( length ) , ( dp ) , |
region-link linked 0 , 0 , 0 , 0 , bl word count string, |
region-link linked 0 , 0 , 0 , 0 , |
|
['] uninitialized , |
|
bl word count string, |
ELSE \ store new parameters in region |
ELSE \ store new parameters in region |
bl word drop |
bl word drop |
>body (region) |
>body (region) |
Line 1305 Variable mirrored-link \ linked
|
Line 1322 Variable mirrored-link \ linked
|
\G returns the total area |
\G returns the total area |
dup >rstart @ swap >rlen @ ; |
dup >rstart @ swap >rlen @ ; |
|
|
|
: dp@ ( region -- dp ) |
|
>rdp @ ; |
|
|
: mirrored ( -- ) |
: mirrored ( -- ) |
\G mark last defined region as mirrored |
\G mark last defined region as mirrored |
mirrored-link |
mirrored-link |
Line 1350 Variable mirrored-link \ linked
|
Line 1370 Variable mirrored-link \ linked
|
0 0 region address-space |
0 0 region address-space |
\ total memory addressed and used by the target system |
\ total memory addressed and used by the target system |
|
|
|
0 0 region user-region |
|
\ data for user variables goes here |
|
\ this has to be defined before dictionary or ram-dictionary |
|
|
0 0 region dictionary |
0 0 region dictionary |
\ rom area for the compiler |
\ rom area for the compiler |
|
|
Line 1369 T has? rom H
|
Line 1393 T has? rom H
|
|
|
' dictionary ALIAS rom-dictionary |
' dictionary ALIAS rom-dictionary |
|
|
|
: setup-region ( region -- ) |
|
>r |
|
\ allocate mem |
|
r@ >rlen @ allocatetarget |
|
r@ >rmem ! |
|
|
|
r@ >rlen @ |
|
target>bitmask-size allocatetarget |
|
r@ >rbm ! |
|
|
|
r@ >rlen @ |
|
tcell / 1+ cells allocatetarget r@ >rtype ! |
|
|
|
['] noop r@ >rtouch ! |
|
rdrop ; |
|
|
: setup-target ( -- ) \G initialize target's memory space |
: setup-target ( -- ) \G initialize target's memory space |
s" rom" T $has? H |
s" rom" T $has? H |
Line 1394 T has? rom H
|
Line 1433 T has? rom H
|
WHILE dup |
WHILE dup |
0 >rlink - >r |
0 >rlink - >r |
r@ >rlen @ |
r@ >rlen @ |
IF \ allocate mem |
IF r@ setup-region |
r@ >rlen @ allocatetarget dup image ! |
THEN rdrop |
r@ >rmem ! |
|
|
|
r@ >rlen @ |
|
target>bitmask-size allocatetarget |
|
dup bit$ ! |
|
r@ >rbm ! |
|
|
|
r@ >rlen @ |
|
tcell / 1+ cells allocatetarget r@ >rtype ! |
|
|
|
rdrop |
|
ELSE r> drop THEN |
|
REPEAT drop ; |
REPEAT drop ; |
|
|
\ MakeKernel 22feb99jaw |
\ MakeKernel 22feb99jaw |
Line 1543 bigendian
|
Line 1570 bigendian
|
0 >rlink - >r |
0 >rlink - >r |
r@ >rlen @ |
r@ >rlen @ |
IF dup r@ borders within |
IF dup r@ borders within |
IF r> r> drop nip EXIT THEN |
IF r> r> drop nip |
|
dup >rtouch @ EXECUTE EXIT |
|
THEN |
THEN |
THEN |
r> drop |
r> drop |
r> |
r> |
Line 1625 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
Line 1654 CREATE Bittable 80 c, 40 c, 20 c, 10 c,
|
[ [THEN] ] |
[ [THEN] ] |
(>regionbm) swap cell/ -bit ; |
(>regionbm) swap cell/ -bit ; |
|
|
: (>image) ( taddr -- absaddr ) image @ + ; |
|
|
|
DEFER >image |
DEFER >image |
DEFER >ramimage |
DEFER >ramimage |
DEFER relon |
DEFER relon |
Line 1701 Ghost (do) Ghost (?do)
|
Line 1728 Ghost (do) Ghost (?do)
|
Ghost (for) drop |
Ghost (for) drop |
Ghost (loop) Ghost (+loop) 2drop |
Ghost (loop) Ghost (+loop) 2drop |
Ghost (next) drop |
Ghost (next) drop |
Ghost (does>) Ghost (compile) 2drop |
Ghost !does drop |
|
Ghost compile, drop |
Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop |
Ghost (.") Ghost (S") Ghost (ABORT") 2drop drop |
Ghost (C") Ghost c(abort") Ghost type 2drop drop |
Ghost (C") Ghost c(abort") Ghost type 2drop drop |
Ghost ' drop |
Ghost ' drop |
Line 1729 Ghost state drop
|
Line 1757 Ghost state drop
|
swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ; |
swap -rot bounds ?DO I c@ over X c! X char+ LOOP drop ; |
|
|
2Variable last-string |
2Variable last-string |
|
X has? rom [IF] $60 [ELSE] $00 [THEN] Constant header-masks |
|
|
|
: ht-header, ( addr count -- ) |
|
dup there swap last-string 2! |
|
dup header-masks or T c, H bounds ?DO I c@ T c, H LOOP ; |
: 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 ; |
Line 1740 Ghost state drop
|
Line 1772 Ghost state drop
|
|
|
: count dup X c@ swap X char+ swap ; |
: count dup X c@ swap X char+ swap ; |
|
|
: on -1 -1 rot TD! ; |
: on >r -1 -1 r> TD! ; |
: off T 0 swap ! H ; |
: off T 0 swap ! H ; |
|
|
: tcmove ( source dest len -- ) |
: tcmove ( source dest len -- ) |
Line 1749 Ghost state drop
|
Line 1781 Ghost state drop
|
?DO dup T c@ H I T c! H 1+ |
?DO dup T c@ H I T c! H 1+ |
tchar +LOOP drop ; |
tchar +LOOP drop ; |
|
|
|
: tcallot ( char size -- ) |
|
0 ?DO dup T c, H tchar +LOOP drop ; |
|
|
: td, ( d -- ) |
: td, ( d -- ) |
\G Store a host value as one cell into the target |
\G Store a host value as one cell into the target |
there tcell X allot TD! ; |
there tcell X allot TD! ; |
Line 2005 variable ResolveFlag
|
Line 2040 variable ResolveFlag
|
\ Header states 12dec92py |
\ Header states 12dec92py |
|
|
\ : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; |
\ : flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ; |
bigendian [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ |
X has? f83headerstring bigendian or [IF] 0 [ELSE] tcell 1- [THEN] Constant flag+ |
: flag! ( w -- ) tlast @ flag+ + dup >r T c@ xor r> c! H ; |
: flag! ( w -- ) tlast @ flag+ + dup >r T c@ xor r> c! H ; |
|
|
VARIABLE ^imm |
VARIABLE ^imm |
Line 2034 $20 constant restrict-mask
|
Line 2069 $20 constant restrict-mask
|
dup T , H bounds ?DO I c@ T c, H LOOP ; |
dup T , H bounds ?DO I c@ T c, H LOOP ; |
|
|
>TARGET |
>TARGET |
|
X has? f83headerstring [IF] |
|
: name, ( "name" -- ) bl word count ht-header, X cfalign ; |
|
[ELSE] |
: name, ( "name" -- ) bl word count ht-lstring, X cfalign ; |
: name, ( "name" -- ) bl word count ht-lstring, X cfalign ; |
|
[THEN] |
: view, ( -- ) ( dummy ) ; |
: view, ( -- ) ( dummy ) ; |
>CROSS |
>CROSS |
|
|
Line 2071 s" kernel.TAGS" r/w create-file throw va
|
Line 2110 s" kernel.TAGS" r/w create-file throw va
|
s" kernel.tags" r/w create-file throw value vi-tag-file-id |
s" kernel.tags" r/w create-file throw value vi-tag-file-id |
\ contains the file-id of the tags file |
\ contains the file-id of the tags file |
|
|
Create tag-beg 2 c, 7F c, bl c, |
Create tag-beg 1 c, 7F c, |
Create tag-end 2 c, bl c, 01 c, |
Create tag-end 1 c, 01 c, |
Create tag-bof 1 c, 0C c, |
Create tag-bof 1 c, 0C c, |
Create tag-tab 1 c, 09 c, |
Create tag-tab 1 c, 09 c, |
|
|
Line 2152 Defer skip? ' false IS skip?
|
Line 2191 Defer skip? ' false IS skip?
|
0= |
0= |
ELSE drop true THEN ; |
ELSE drop true THEN ; |
|
|
: doer? ( -- flag ) \ name |
: doer? ( "name" -- 0 | addr ) \ name |
Ghost >magic @ <do:> = ; |
Ghost dup >magic @ <do:> = |
|
IF >link @ ELSE drop 0 THEN ; |
|
|
: skip-defs ( -- ) |
: skip-defs ( -- ) |
BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ; |
BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ; |
Line 2178 NoHeaderFlag off
|
Line 2218 NoHeaderFlag off
|
ENDCASE |
ENDCASE |
LOOP ; |
LOOP ; |
|
|
Defer setup-execution-semantics |
Defer setup-execution-semantics ' noop IS setup-execution-semantics |
0 Value lastghost |
0 Value lastghost |
|
|
: (THeader ( "name" -- ghost ) |
: (THeader ( "name" -- ghost ) |
Line 2270 Defer setup-prim-semantics
|
Line 2310 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# ! ; |
: group 0 word drop prim# @ 1- -$200 and prim# ! ; |
|
: groupadd ( n -- ) drop ; |
: 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 2279 Variable prim#
|
Line 2320 Variable prim#
|
prim# @ (THeader ( S xt ghost ) |
prim# @ (THeader ( S xt ghost ) |
['] prim-resolved over >comp ! |
['] prim-resolved over >comp ! |
dup >ghost-flags <primitive> set-flag |
dup >ghost-flags <primitive> set-flag |
over resolve-noforwards T A, H alias-mask flag! |
s" EC" T $has? H 0= |
|
IF |
|
over resolve-noforwards T A, H |
|
alias-mask flag! |
|
ELSE |
|
T here H resolve-noforwards T A, H |
|
THEN |
-1 prim# +! ; |
-1 prim# +! ; |
>CROSS |
>CROSS |
|
|
Line 2365 T 2 cells H Value xt>body
|
Line 2412 T 2 cells H Value xt>body
|
there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim, |
there xt>body + ca>native T a, H 1 fillcfa ; ' (doprim,) plugin-of doprim, |
|
|
: (doeshandler,) ( -- ) |
: (doeshandler,) ( -- ) |
T cfalign H [G'] :doesjump addr, T 0 , H ; ' (doeshandler,) plugin-of doeshandler, |
T cfalign H ; ' (doeshandler,) plugin-of doeshandler, |
|
|
: (dodoes,) ( does-action-ghost -- ) |
: (dodoes,) ( does-action-ghost -- ) |
]comp [G'] :dodoes addr, comp[ |
]comp [G'] :dodoes addr, comp[ |
Line 2438 Cond: ALiteral ( n -- ) alit, ;Cond
|
Line 2485 Cond: ALiteral ( n -- ) alit, ;Cond
|
: Char ( "<char>" -- ) bl word char+ c@ ; |
: Char ( "<char>" -- ) bl word char+ c@ ; |
Cond: [Char] ( "<char>" -- ) Char lit, ;Cond |
Cond: [Char] ( "<char>" -- ) Char lit, ;Cond |
|
|
|
: (x#) ( adr len base -- ) |
|
base @ >r base ! 0 0 name >number 2drop drop r> base ! ; |
|
|
|
: d# $0a (x#) ; |
|
: h# $010 (x#) ; |
|
|
|
Cond: d# $0a (x#) lit, ;Cond |
|
Cond: h# $010 (x#) lit, ;Cond |
|
|
tchar 1 = [IF] |
tchar 1 = [IF] |
Cond: chars ;Cond |
Cond: chars ;Cond |
[THEN] |
[THEN] |
Line 2481 Cond: MAXI
|
Line 2537 Cond: MAXI
|
IF nip execute-exec-compile ELSE gexecute THEN |
IF nip execute-exec-compile ELSE gexecute THEN |
EXIT |
EXIT |
THEN |
THEN |
number? dup |
(number?) dup |
IF 0> IF swap lit, THEN lit, discard |
IF 0> IF swap lit, THEN lit, discard |
ELSE 2drop restore-input throw Ghost gexecute THEN ; |
ELSE 2drop restore-input throw Ghost gexecute THEN ; |
|
|
Line 2533 Cond: MAXI
|
Line 2589 Cond: MAXI
|
(THeader (:) ; |
(THeader (:) ; |
|
|
: :noname ( -- colon-sys ) |
: :noname ( -- colon-sys ) |
X cfalign there |
switchrom X cfalign there |
\ define a nameless ghost |
\ define a nameless ghost |
here ghostheader dup last-header-ghost ! dup to lastghost |
here ghostheader dup last-header-ghost ! dup to lastghost |
(:) ; |
(:) ; |
Line 2578 Cond: [ ( -- ) interpreting-state ;Cond
|
Line 2634 Cond: [ ( -- ) interpreting-state ;Cond
|
r@ created >do:ghost ! r@ swap resolve |
r@ created >do:ghost ! r@ swap resolve |
r> tlastcfa @ >tempdp dodoes, tempdp> ; |
r> tlastcfa @ >tempdp dodoes, tempdp> ; |
|
|
Defer instant-interpret-does>-hook |
Defer instant-interpret-does>-hook ' noop IS instant-interpret-does>-hook |
|
|
T has? peephole H [IF] |
T has? primcentric 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] |
[ELSE] |
Line 2595 T has? peephole H [IF]
|
Line 2651 T has? peephole H [IF]
|
|
|
>TARGET |
>TARGET |
Cond: DOES> |
Cond: DOES> |
compile (does>) doeshandler, |
T here H [ T has? primcentric H [IF] ] 5 [ [ELSE] ] 4 [ [THEN] ] T cells |
resolve-does>-part |
H + alit, compile !does compile ;s |
|
doeshandler, resolve-does>-part |
;Cond |
;Cond |
|
|
: DOES> |
: DOES> |
Line 2778 by Create
|
Line 2835 by Create
|
|
|
\ User variables 04may94py |
\ User variables 04may94py |
|
|
Variable tup 0 tup ! |
: tup@ user-region >rstart @ ; |
Variable tudp 0 tudp ! |
|
|
\ Variable tup 0 tup ! |
|
\ Variable tudp 0 tudp ! |
|
|
: u, ( n -- udp ) |
: u, ( n -- udp ) |
tup @ tudp @ + T ! H |
current-region >r user-region activate |
tudp @ dup T cell+ H tudp ! ; |
X here swap X , tup@ - |
|
r> activate ; |
|
|
: au, ( n -- udp ) |
: au, ( n -- udp ) |
tup @ tudp @ + T A! H |
current-region >r user-region activate |
tudp @ dup T cell+ H tudp ! ; |
X here swap X a, tup@ - |
|
r> activate ; |
|
|
|
T has? no-userspace H [IF] |
|
|
|
: buildby |
|
ghost >exec @ built >exec ! ; |
|
|
|
Builder User |
|
buildby Variable |
|
by Variable |
|
|
|
Builder 2User |
|
buildby 2Variable |
|
by 2Variable |
|
|
|
Builder AUser |
|
buildby AVariable |
|
by AVariable |
|
|
|
[ELSE] |
|
|
Builder User |
Builder User |
Build: 0 u, X , ;Build |
Build: 0 u, X , ;Build |
by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO |
by: :douser ( ghost -- up-addr ) X @ tup@ + ;DO |
|
|
Builder 2User |
Builder 2User |
Build: 0 u, X , 0 u, drop ;Build |
Build: 0 u, X , 0 u, drop ;Build |
Line 2801 Builder AUser
|
Line 2881 Builder AUser
|
Build: 0 au, X , ;Build |
Build: 0 au, X , ;Build |
by User |
by User |
|
|
|
[THEN] |
|
|
|
T has? rom H [IF] |
Builder (Value) |
Builder (Value) |
Build: ( n -- ) ;Build |
Build: ( n -- ) ;Build |
by: :docon ( target-body-addr -- n ) T @ H ;DO |
by: :dovalue ( target-body-addr -- n ) T @ @ H ;DO |
|
|
|
Builder Value |
|
Build: T here 0 A, H switchram T align here swap ! , H ;Build |
|
by (Value) |
|
|
|
Builder AValue |
|
Build: T here 0 A, H switchram T align here swap ! A, H ;Build |
|
by (Value) |
|
[ELSE] |
|
Builder (Value) |
|
Build: ( n -- ) ;Build |
|
by: :dovalue ( target-body-addr -- n ) T @ H ;DO |
|
|
Builder Value |
Builder Value |
BuildSmart: T , H ;Build |
BuildSmart: T , H ;Build |
Line 2812 by (Value)
|
Line 2907 by (Value)
|
Builder AValue |
Builder AValue |
BuildSmart: T A, H ;Build |
BuildSmart: T A, H ;Build |
by (Value) |
by (Value) |
|
[THEN] |
|
|
Defer texecute |
Defer texecute |
|
|
Builder Defer |
Builder Defer |
BuildSmart: ( -- ) [T'] noop T A, H ;Build |
T has? rom H [IF] |
by: :dodefer ( ghost -- ) X @ texecute ;DO |
Build: ( -- ) T here 0 A, H switchram T align here swap ! H [T'] noop T A, H ( switchrom ) ;Build |
|
by: :dodefer ( ghost -- ) X @ X @ texecute ;DO |
|
[ELSE] |
|
BuildSmart: ( -- ) [T'] noop T A, H ;Build |
|
by: :dodefer ( ghost -- ) X @ texecute ;DO |
|
[THEN] |
|
|
Builder interpret/compile: |
Builder interpret/compile: |
Build: ( inter comp -- ) swap T A, A, H ;Build-immediate |
Build: ( inter comp -- ) swap T A, A, H ;Build-immediate |
Line 2848 by (Field)
|
Line 2949 by (Field)
|
T 1 cells H dup ; |
T 1 cells H dup ; |
>CROSS |
>CROSS |
|
|
|
\ ABI-CODE support |
|
Builder (ABI-CODE) |
|
Build: ;Build |
|
by: :doabicode noop ;DO |
|
|
\ Input-Methods 01py |
\ Input-Methods 01py |
|
|
Builder input-method |
Builder input-method |
Line 2870 DO: abort" Not in cross mode" ;DO
|
Line 2976 DO: abort" Not in cross mode" ;DO
|
\ optimizer for cross |
\ optimizer for cross |
|
|
|
|
T has? peephole H [IF] |
T has? primcentric H [IF] |
|
|
|
\ .( loading peephole optimization) cr |
|
|
>CROSS |
>CROSS |
|
|
Line 2878 T has? peephole H [IF]
|
Line 2986 T has? peephole H [IF]
|
: (callcm) T here 0 a, 0 a, H ; ' (callcm) plugin-of colonmark, |
: (callcm) T here 0 a, 0 a, H ; ' (callcm) plugin-of colonmark, |
: (call-res) >tempdp resolved gexecute tempdp> drop ; |
: (call-res) >tempdp resolved gexecute tempdp> drop ; |
' (call-res) plugin-of colon-resolve |
' (call-res) plugin-of colon-resolve |
|
T has? ec H [IF] |
|
: (pprim) T @ H >signed dup 0< IF $4000 - ELSE |
|
cr ." wrong usage of (prim) " |
|
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
|
T a, H ; ' (pprim) plugin-of prim, |
|
[ELSE] |
: (pprim) dup 0< IF $4000 - ELSE |
: (pprim) dup 0< IF $4000 - ELSE |
cr ." wrong usage of (prim) " |
cr ." wrong usage of (prim) " |
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
dup gdiscover IF .ghost ELSE . THEN cr -1 throw THEN |
T a, H ; ' (pprim) plugin-of prim, |
T a, H ; ' (pprim) plugin-of prim, |
|
[THEN] |
|
|
\ if we want this, we have to spilt aconstant |
\ if we want this, we have to spilt aconstant |
\ and constant!! |
\ and constant!! |
Line 2905 Builder Defer
|
Line 3020 Builder Defer
|
compile: g>body compile lit-perform T A, H ;compile |
compile: g>body compile lit-perform T A, H ;compile |
|
|
Builder (Field) |
Builder (Field) |
compile: g>body T @ H compile lit+ T , H ;compile |
compile: g>body T @ H compile lit+ T here H reloff T , H ;compile |
|
|
Builder interpret/compile: |
Builder interpret/compile: |
compile: does-resolved ;compile |
compile: does-resolved ;compile |
Line 3148 Cond: ABORT" if, ahead, there [char]
|
Line 3263 Cond: ABORT" if, ahead, there [char]
|
>r then, r> compile ALiteral compile c(abort") then, ;Cond |
>r then, r> compile ALiteral compile c(abort") then, ;Cond |
[THEN] |
[THEN] |
|
|
|
X has? rom [IF] |
|
Cond: IS T ' >body @ H compile ALiteral compile ! ;Cond |
|
: IS T >address ' >body @ ! H ; |
|
Cond: TO T ' >body @ H compile ALiteral compile ! ;Cond |
|
: TO T ' >body @ ! H ; |
|
Cond: CTO T ' >body H compile ALiteral compile ! ;Cond |
|
: CTO T ' >body ! H ; |
|
[ELSE] |
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 ; |
Cond: TO T ' >body H compile ALiteral compile ! ;Cond |
Cond: TO T ' >body H compile ALiteral compile ! ;Cond |
: TO T ' >body ! H ; |
: TO T ' >body ! H ; |
|
[THEN] |
|
|
Cond: defers T ' >body @ compile, H ;Cond |
Cond: defers T ' >body @ compile, H ;Cond |
|
|
Line 3184 Cond: postpone ( -- ) \ name
|
Line 3308 Cond: postpone ( -- ) \ name
|
ABORT" CROSS: Can't postpone on forward declaration" |
ABORT" CROSS: Can't postpone on forward declaration" |
dup >magic @ <imm> = |
dup >magic @ <imm> = |
IF (gexecute) |
IF (gexecute) |
ELSE compile (compile) addr, THEN ;Cond |
ELSE >link @ alit, compile compile, THEN ;Cond |
|
|
\ save-cross 17mar93py |
\ save-cross 17mar93py |
|
|
Line 3205 tchar 8 = 78 and or
|
Line 3329 tchar 8 = 78 and or
|
magic 7 + c! |
magic 7 + c! |
|
|
: save-cross ( "image-name" "binary-name" -- ) |
: save-cross ( "image-name" "binary-name" -- ) |
|
.regions \ s" ec" X $has? IF .regions THEN |
bl parse ." Saving to " 2dup type cr |
bl parse ." Saving to " 2dup type cr |
w/o bin create-file throw >r |
w/o bin create-file throw >r |
s" header" X $has? IF |
s" header" X $has? IF |
Line 3221 magic 7 + c!
|
Line 3346 magic 7 + c!
|
ELSE |
ELSE |
bl parse 2drop |
bl parse 2drop |
THEN |
THEN |
image @ there |
>rom dictionary >rmem @ there |
|
s" rom" X $has? IF dictionary >rstart @ - THEN |
r@ write-file throw \ write image |
r@ write-file throw \ write image |
s" relocate" X $has? IF |
s" relocate" X $has? IF |
bit$ @ there 1- tcell>bit rshift 1+ |
dictionary >rbm @ there 1- tcell>bit rshift 1+ |
r@ write-file throw \ write tags |
r@ write-file throw \ write tags |
THEN |
THEN |
r> close-file throw ; |
r> close-file throw ; |
Line 3616 previous
|
Line 3742 previous
|
: * * ; |
: * * ; |
: / / ; |
: / / ; |
: dup dup ; |
: dup dup ; |
|
: ?dup ?dup ; |
: over over ; |
: over over ; |
: swap swap ; |
: swap swap ; |
: rot rot ; |
: rot rot ; |
: drop drop ; |
: drop drop ; |
|
: 2drop 2drop ; |
: = = ; |
: = = ; |
: <> <> ; |
: <> <> ; |
: 0= 0= ; |
: 0= 0= ; |
: lshift lshift ; |
: lshift lshift ; |
: 2/ 2/ ; |
: 2/ 2/ ; |
|
: hex. base @ $10 base ! swap . base ! ; |
|
: invert invert ; |
|
: linkstring ( addr u n addr -- ) |
|
X here over X @ X , swap X ! X , ht-string, X align ; |
\ : . . ; |
\ : . . ; |
|
|
: all-words ['] forced? IS skip? ; |
: all-words ['] forced? IS skip? ; |
Line 3640 previous
|
Line 3772 previous
|
: require require ; |
: require require ; |
: needs require ; |
: needs require ; |
: .( [char] ) parse type ; |
: .( [char] ) parse type ; |
|
: ERROR" [char] " parse |
|
rot |
|
IF cr ." *** " type ." ***" -1 ABORT" CROSS: Target error, see text above" |
|
ELSE 2drop |
|
THEN ; |
: ." [char] " parse type ; |
: ." [char] " parse type ; |
: cr cr ; |
: cr cr ; |
|
|