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] ...@@ -662,6 +662,7 @@ 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
...@@ -1175,14 +1176,21 @@ false DefaultValue backtrace ...@@ -1175,14 +1176,21 @@ 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 f83headerstring
true DefaultValue control-rack 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
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?!
...@@ -1237,11 +1245,9 @@ tbits/char bits/byte / Constant tbyte ...@@ -1237,11 +1245,9 @@ tbits/char bits/byte / Constant tbyte
\ 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
...@@ -1263,7 +1269,8 @@ Variable region-link \ linked list with all regions ...@@ -1263,7 +1269,8 @@ Variable region-link \ linked list with all regions
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
...@@ -1278,6 +1285,8 @@ Variable mirrored-link \ linked list for mirrored regions ...@@ -1278,6 +1285,8 @@ Variable mirrored-link \ linked list for mirrored regions
>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
...@@ -1287,7 +1296,9 @@ Variable mirrored-link \ linked list for mirrored regions ...@@ -1287,7 +1296,9 @@ Variable mirrored-link \ linked list for mirrored regions
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)
...@@ -1305,6 +1316,9 @@ Variable mirrored-link \ linked list for mirrored regions ...@@ -1305,6 +1316,9 @@ Variable mirrored-link \ linked list for mirrored regions
\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
...@@ -1350,6 +1364,10 @@ Variable mirrored-link \ linked list for mirrored regions ...@@ -1350,6 +1364,10 @@ Variable mirrored-link \ linked list for mirrored regions
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
...@@ -1369,6 +1387,21 @@ T has? rom H ...@@ -1369,6 +1387,21 @@ 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
...@@ -1394,20 +1427,8 @@ T has? rom H ...@@ -1394,20 +1427,8 @@ 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
...@@ -1543,7 +1564,9 @@ bigendian ...@@ -1543,7 +1564,9 @@ 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>
...@@ -1625,8 +1648,6 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, ...@@ -1625,8 +1648,6 @@ CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 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
...@@ -2034,7 +2055,11 @@ $20 constant restrict-mask ...@@ -2034,7 +2055,11 @@ $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-string, 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
...@@ -2152,8 +2177,9 @@ Defer skip? ' false IS skip? ...@@ -2152,8 +2177,9 @@ 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 ;
...@@ -2438,6 +2464,15 @@ Cond: ALiteral ( n -- ) alit, ;Cond ...@@ -2438,6 +2464,15 @@ 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]
...@@ -2778,20 +2813,43 @@ by Create ...@@ -2778,20 +2813,43 @@ 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
...@@ -2801,6 +2859,8 @@ Builder AUser ...@@ -2801,6 +2859,8 @@ Builder AUser
Build: 0 au, X , ;Build Build: 0 au, X , ;Build
by User by User
[THEN]
Builder (Value) Builder (Value)
Build: ( n -- ) ;Build Build: ( n -- ) ;Build
by: :docon ( target-body-addr -- n ) T @ H ;DO by: :docon ( target-body-addr -- n ) T @ H ;DO
...@@ -2872,6 +2932,8 @@ DO: abort" Not in cross mode" ;DO ...@@ -2872,6 +2932,8 @@ DO: abort" Not in cross mode" ;DO
T has? peephole H [IF] T has? peephole H [IF]
\ .( loading peephole optimization) cr
>CROSS >CROSS
: (callc) compile call T >body a, H ; ' (callc) plugin-of colon, : (callc) compile call T >body a, H ; ' (callc) plugin-of colon,
...@@ -3221,10 +3283,10 @@ magic 7 + c! ...@@ -3221,10 +3283,10 @@ magic 7 + c!
ELSE ELSE
bl parse 2drop bl parse 2drop
THEN THEN
image @ there dictionary >rmem @ there
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 ;
...@@ -3616,15 +3678,19 @@ previous ...@@ -3616,15 +3678,19 @@ 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 ;
\ : . . ; \ : . . ;
: all-words ['] forced? IS skip? ; : all-words ['] forced? IS skip? ;
...@@ -3640,6 +3706,11 @@ previous ...@@ -3640,6 +3706,11 @@ 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 ;
......
...@@ -21,7 +21,9 @@ ...@@ -21,7 +21,9 @@
\ Set up dictionary pointer \ Set up dictionary pointer
>ram here normal-dp ! >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 \ Set up last and forth-wordlist with the address of the last word's
\ link field \ link field
......
...@@ -69,11 +69,11 @@ $400 Value def#tib ...@@ -69,11 +69,11 @@ $400 Value def#tib
\ initialized by COLD \ 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 \ set user-pointer from cross-compiler right
main-task main-task
UNLOCK tup ! LOCK UNLOCK swap region user-region user-region setup-region LOCK
Variable udp ( -- a-addr ) \ gforth Variable udp ( -- a-addr ) \ gforth
\G user area size \G user area size
......
\ machpc.fs is generated; source: machpc.fs.in \ machpc.fs is generated; source: machpc.fs.in
\ generic mach file for pc gforth 03sep97jaw \ 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. \ This file is part of Gforth.
......
...@@ -51,6 +51,9 @@ ...@@ -51,6 +51,9 @@
\ (stack-in-index-xt and a test for stack==instruction-stream); there \ (stack-in-index-xt and a test for stack==instruction-stream); there
\ should be only one. \ should be only one.
\ for backwards compatibility, jaw
require compat/strcomp.fs
warnings off warnings off
\ redefinitions of kernel words not present in gforth-0.6.1 \ 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