Commit 4116ad58 authored by jwilke's avatar jwilke

cross: use sperate region for user-space

cross: allow no user-space at all
parent f2d97b51
......@@ -662,6 +662,7 @@ stack-warn [IF]
: defempty? empty? ;
[ELSE]
: defempty? ; immediate
\ : defempty? .sourcepos ;
[THEN]
\ \ -------------------- Compiler Plug Ins 01aug97jaw
......@@ -1175,14 +1176,21 @@ false DefaultValue backtrace
false DefaultValue new-input
false DefaultValue peephole
false DefaultValue abranch
true DefaultValue f83headerstring
true DefaultValue control-rack
[THEN]
true DefaultValue gforthcross
true DefaultValue interpreter
true DefaultValue ITC
false DefaultValue rom
true DefaultValue standardthreading
\ ANSForth environment stuff
8 DefaultValue ADDRESS-UNIT-BITS
255 DefaultValue MAX-CHAR
255 DefaultValue /COUNTED-STRING
>TARGET
s" relocate" T environment? H
\ JAW why set NIL to this?!
......@@ -1237,11 +1245,9 @@ tbits/char bits/byte / Constant tbyte
\ Variables 06oct92py
Variable image
Variable (tlast)
(tlast) Value tlast TNIL tlast ! \ Last name field
Variable tlastcfa \ Last code field
Variable bit$
\ statistics 10jun97jaw
......@@ -1263,7 +1269,8 @@ Variable region-link \ linked list with all regions
Variable mirrored-link \ linked list for mirrored regions
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
: >rmem 5 cells + ;
: >rtype 6 cells + ; \ field per cell witch points to a type struct
......@@ -1278,6 +1285,8 @@ Variable mirrored-link \ linked list for mirrored regions
>r r@ last-defined-region !
r@ >rlen ! dup r@ >rstart ! r> >rdp ! ;
: uninitialized -1 ABORT" CROSS: Region is uninitialized" ;
: region ( addr len -- "name" )
\G create a new region
\ check whether predefined region exists
......@@ -1287,7 +1296,9 @@ Variable mirrored-link \ linked list for mirrored regions
save-input create restore-input throw
here last-defined-region !
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
bl word drop
>body (region)
......@@ -1305,6 +1316,9 @@ Variable mirrored-link \ linked list for mirrored regions
\G returns the total area
dup >rstart @ swap >rlen @ ;
: dp@ ( region -- dp )
>rdp @ ;
: mirrored ( -- )
\G mark last defined region as mirrored
mirrored-link
......@@ -1350,6 +1364,10 @@ Variable mirrored-link \ linked list for mirrored regions
0 0 region address-space
\ 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
\ rom area for the compiler
......@@ -1369,6 +1387,21 @@ T has? rom H
' 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
s" rom" T $has? H
......@@ -1394,20 +1427,8 @@ T has? rom H
WHILE dup
0 >rlink - >r
r@ >rlen @
IF \ allocate mem
r@ >rlen @ allocatetarget dup image !
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
IF r@ setup-region
THEN rdrop
REPEAT drop ;
\ MakeKernel 22feb99jaw
......@@ -1543,7 +1564,9 @@ bigendian
0 >rlink - >r
r@ >rlen @
IF dup r@ borders within
IF r> r> drop nip EXIT THEN
IF r> r> drop nip
dup >rtouch @ EXECUTE EXIT
THEN
THEN
r> drop
r>
......@@ -1625,8 +1648,6 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
[ [THEN] ]
(>regionbm) swap cell/ -bit ;
: (>image) ( taddr -- absaddr ) image @ + ;
DEFER >image
DEFER >ramimage
DEFER relon
......@@ -2034,7 +2055,11 @@ $20 constant restrict-mask
dup T , H bounds ?DO I c@ T c, H LOOP ;
>TARGET
X has? f83headerstring [IF]
: name, ( "name" -- ) bl word count ht-string, X cfalign ;
[ELSE]
: name, ( "name" -- ) bl word count ht-lstring, X cfalign ;
[THEN]
: view, ( -- ) ( dummy ) ;
>CROSS
......@@ -2152,8 +2177,9 @@ Defer skip? ' false IS skip?
0=
ELSE drop true THEN ;
: doer? ( -- flag ) \ name
Ghost >magic @ <do:> = ;
: doer? ( "name" -- 0 | addr ) \ name
Ghost dup >magic @ <do:> =
IF >link @ ELSE drop 0 THEN ;
: skip-defs ( -- )
BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ;
......@@ -2438,6 +2464,15 @@ Cond: ALiteral ( n -- ) alit, ;Cond
: Char ( "<char>" -- ) bl word char+ c@ ;
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]
Cond: chars ;Cond
[THEN]
......@@ -2778,20 +2813,43 @@ by Create
\ User variables 04may94py
Variable tup 0 tup !
Variable tudp 0 tudp !
: tup@ user-region >rstart @ ;
\ Variable tup 0 tup !
\ Variable tudp 0 tudp !
: u, ( n -- udp )
tup @ tudp @ + T ! H
tudp @ dup T cell+ H tudp ! ;
current-region >r user-region activate
X here swap X , tup@ -
r> activate ;
: au, ( n -- udp )
tup @ tudp @ + T A! H
tudp @ dup T cell+ H tudp ! ;
current-region >r user-region activate
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
Build: 0 u, X , ;Build
by: :douser ( ghost -- up-addr ) X @ tup @ + ;DO
by: :douser ( ghost -- up-addr ) X @ tup@ + ;DO
Builder 2User
Build: 0 u, X , 0 u, drop ;Build
......@@ -2801,6 +2859,8 @@ Builder AUser
Build: 0 au, X , ;Build
by User
[THEN]
Builder (Value)
Build: ( n -- ) ;Build
by: :docon ( target-body-addr -- n ) T @ H ;DO
......@@ -2872,6 +2932,8 @@ DO: abort" Not in cross mode" ;DO
T has? peephole H [IF]
\ .( loading peephole optimization) cr
>CROSS
: (callc) compile call T >body a, H ; ' (callc) plugin-of colon,
......@@ -3221,10 +3283,10 @@ magic 7 + c!
ELSE
bl parse 2drop
THEN
image @ there
dictionary >rmem @ there
r@ write-file throw \ write image
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
THEN
r> close-file throw ;
......@@ -3616,15 +3678,19 @@ previous
: * * ;
: / / ;
: dup dup ;
: ?dup ?dup ;
: over over ;
: swap swap ;
: rot rot ;
: drop drop ;
: 2drop 2drop ;
: = = ;
: <> <> ;
: 0= 0= ;
: lshift lshift ;
: 2/ 2/ ;
: hex. base @ $10 base ! swap . base ! ;
: invert invert ;
\ : . . ;
: all-words ['] forced? IS skip? ;
......@@ -3640,6 +3706,11 @@ previous
: require require ;
: needs require ;
: .( [char] ) parse type ;
: ERROR" [char] " parse
rot
IF cr ." *** " type ." ***" -1 ABORT" CROSS: Target error, see text above"
ELSE 2drop
THEN ;
: ." [char] " parse type ;
: cr cr ;
......
......@@ -21,7 +21,9 @@
\ Set up dictionary pointer
>ram here normal-dp !
UNLOCK tudp @ LOCK udp !
\ set udp
UNLOCK user-region extent nip LOCK udp !
\ Set up last and forth-wordlist with the address of the last word's
\ link field
......
......@@ -69,11 +69,11 @@ $400 Value def#tib
\ initialized by COLD
Create main-task has? OS [IF] 100 [ELSE] 40 [THEN] cells allot
Create main-task has? OS [IF] 100 [ELSE] 40 [THEN] cells dup allot
\ set user-pointer from cross-compiler right
main-task
UNLOCK tup ! LOCK
UNLOCK swap region user-region user-region setup-region LOCK
Variable udp ( -- a-addr ) \ gforth
\G user area size
......
\ machpc.fs is generated; source: machpc.fs.in
\ generic mach file for pc gforth 03sep97jaw
\ Copyright (C) 1995-2003 Free Software Foundation, Inc.
\ Copyright (C) 1995,1996,1997,2000,2003 Free Software Foundation, Inc.
\ This file is part of Gforth.
......
......@@ -51,6 +51,9 @@
\ (stack-in-index-xt and a test for stack==instruction-stream); there
\ should be only one.
\ for backwards compatibility, jaw
require compat/strcomp.fs
warnings off
\ redefinitions of kernel words not present in gforth-0.6.1
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment