Commit 0b40d56d authored by pazsan's avatar pazsan

Made 4stack port of Gforth EC work again

parent a3b84288
......@@ -622,7 +622,7 @@ kernl64l.fi-: $(KERN_DEPS) mach64l.fs
kernl64b.fi-: $(KERN_DEPS) mach64b.fs
$(FORTHB) -e 's" mach64b.fs"' $(srcdir)/kernel/main.fs -e "save-cross kernl64b.fi- $(bindir)/gforth-$(VERSION) bye"
kernl-%.fi: arch/%/mach.fs $(KERN_SRC) kernel/version.fs $(FORTH_GEN0)
kernl-%.fi: arch/%/mach.fs arch/%/prim.fs arch/%/asm.fs $(KERN_SRC) kernel/version.fs $(FORTH_GEN0)
$(FORTHB) -e 's" $<"' $(srcdir)/kernel/main.fs -e "save-cross $@- $(bindir)/gforth-$(VERSION) bye"
if [ -f `echo $< | sed s/fs/sh/` ]; \
then sh `echo $< | sed s/fs/sh/` $@; \
......
......@@ -39,32 +39,34 @@ true Constant NIL \ relocating
>ENVIRON
false Constant file \ controls the presence of the
false SetValue file \ controls the presence of the
\ file access wordset
false Constant OS \ flag to indicate a operating system
false SetValue OS \ flag to indicate a operating system
false Constant prims \ true: primitives are c-code
false SetValue prims \ true: primitives are c-code
false Constant floating \ floating point wordset is present
false SetValue floating \ floating point wordset is present
false Constant glocals \ gforth locals are present
false SetValue glocals \ gforth locals are present
\ will be loaded
false Constant dcomps \ double number comparisons
false SetValue dcomps \ double number comparisons
false Constant hash \ hashing primitives are loaded/present
false SetValue hash \ hashing primitives are loaded/present
false Constant xconds \ used together with glocals,
false SetValue xconds \ used together with glocals,
\ special conditionals supporting gforths'
\ local variables
false Constant header \ save a header information
false SetValue header \ save a header information
false Constant ec
false Constant crlf
false Constant ITC
false SetValue ec
false SetValue crlf
false SetValue ITC
false SetValue new-input
false SetValue peephole
true SetValue abranch \ enables absolute branches
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
0 SetValue kernel-start
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB SetValue kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
......
......@@ -19,7 +19,7 @@
\ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
Label start
nop ;; first opcode must be a nop!
nop ;; first opcode must be a nop!
$80000000 ## ;;
#, ;;
sr! jmpa $818 >IP ;;
......@@ -66,11 +66,11 @@ docon: ;;
drop nop nop nop ;;
end-code
-2 Alias: :docol
-3 Alias: :docon
-4 Alias: :dovar
-8 Alias: :dodoes
-9 Alias: :doesjump
-2 Doer: :docol
-3 Doer: :docon
-4 Doer: :dovar
-8 Doer: :dodoes
-9 Doer: :doesjump
Code execute ( xt -- )
ip! nop nop nop ;;
......@@ -79,7 +79,7 @@ end-code
Code ?branch
nop nop nop nop br 0 ?0<>
nop nop nop nop -4 # R1= R1 1: +s0 ;;
nop dup nop nop 0 # set 1: R1 ;;
.endif
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop ;;
......@@ -164,21 +164,6 @@ Code (emit)
nop nop nop nop ;;
end-code
: (type)
bounds ?DO I c@ (emit) LOOP ;
\ BEGIN dup WHILE
\ >r dup c@ (emit) 1+ r> 1- REPEAT 2drop ;
\ obligatory code address manipulations
: >code-address ( xt -- addr ) cell+ @ -8 and ;
: >does-code ( xt -- addr )
cell+ @ -8 and \ dup 3 and 3 <> IF drop 0 EXIT THEN
8 + dup cell - @ 3 and 0<> and ;
: code-address! ( addr xt -- ) >r 3 or $808 @ r> 2! ;
: does-code! ( a_addr xt -- ) >r 5 - $808 @ r> 2! ;
: does-handler! ( a_addr -- ) >r $810 2@ r> 2! ;
\ this was obligatory, now some things to speed it up
Code 2/
......@@ -187,8 +172,8 @@ Code 2/
end-code
Code branch
nop nop nop nop -4 # R1= R1 1: +s0 ;;
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop 0 # set 1: R1 ;;
nop nop nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop ;;
nop ip! nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop ;;
......@@ -197,7 +182,7 @@ end-code
Code (loop)
pick 3s1 nop nop inc ;;
sub 3s0 nop nop nop br 0 ?0=
nop nop nop nop -4 # R1= R1 1: +s0 ;;
nop dup nop nop 0 # set 1: R1 ;;
.endif
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop ;;
......@@ -210,7 +195,7 @@ Code (+loop)
subr 3s0 nop nop nop ;;
xor #min nop nop nop ;;
add s1 nop nop nop br 0 ?ov
nop nop nop nop -4 # R1= R1 1: +s0 ;;
nop dup nop nop 0 # set 1: R1 ;;
.endif
nop drop nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop
......@@ -223,6 +208,11 @@ Code (do)
drop nop nop pick 0s0 ;;
end-code
Code unloop
nop ip! nop drop 0 # ld 1: R1 N+ ;;
nop nop nop drop ;;
end-code
Code -
subr ip! nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop ;;
......@@ -385,24 +375,42 @@ Code <>
0<> nop nop nop ;;
end-code
\ : (find-samelen) ( u f83name1 -- u f83name2/0 )
\ BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
Code (find-samelen)
nop 0 # 0 # nop ;;
nop nop pick 0s0 nop ;;
\ : (findl-samelen) ( u name1 -- u name2/0 )
\ BEGIN 2dup cell+ @ $1FFFFFFF and <> WHILE @ dup 0= UNTIL THEN ;
Code (findl-samelen)
nop 0 # 0 # $20 # ;;
nop nop pick 0s0 hib ;;
nop nop nop dec ;;
.begin
drop drop nop nop ldb 0: s0b 4 # ;;
nop $1F # nip nop ld 2: s0b 0 # ;;
drop drop nop nop ld 0: s0b 1 # ;;
nop pick 3s0 nip nop ld 2: s0b 0 # ;;
drop and 0s0 nop nop ;;
pick 2s0 sub 0s0 nop nop br 1&2 :0<> .until ;;
nop nop nop nop br 1 ?0= ;;
nop ip! drop nip 0 # ld 1: R1 N+ ;;
nop ip! drop drop 0 # ld 1: R1 N+ ;;
nop nop drop nop ;;
.endif
pick 2s1 ip! drop nop 0 # ld 1: R1 N+ ;;
pick 2s1 ip! drop drop 0 # ld 1: R1 N+ ;;
nip nop drop nop ;;
end-code
\ necessary high-level code
: (type)
bounds ?DO I c@ (emit) LOOP ;
\ BEGIN dup WHILE
\ >r dup c@ (emit) 1+ r> 1- REPEAT 2drop ;
\ obligatory code address manipulations
: >code-address ( xt -- addr ) cell+ @ -8 and ;
: >does-code ( xt -- addr )
cell+ @ -8 and \ dup 3 and 3 <> IF drop 0 EXIT THEN
8 + dup cell - @ 3 and 0<> and ;
: code-address! ( addr xt -- ) >r 3 or $808 @ r> 2! ;
: does-code! ( a_addr xt -- ) >r 5 - $808 @ r> 2! ;
: does-handler! ( a_addr -- ) >r $810 2@ r> 2! ;
: bye 0 execute ;
\ division a/b
......
......@@ -29,7 +29,7 @@ Variable imagesize
BEGIN
8 +
magic 8 r@ read-file throw 8 = WHILE
magic 8 s" Gforth2" compare 0= UNTIL
magic 8 s" Gforth3" compare 0= UNTIL
ELSE true abort" Magic not found!" THEN rdrop ;
Create bits $80 c, $40 c, $20 c, $10 c, $08 c, $04 c, $02 c, $01 c,
......@@ -78,7 +78,7 @@ Create bits $80 c, $40 c, $20 c, $10 c, $08 c, $04 c, $02 c, $01 c,
: read-gforth ( addr u -- ) r/o bin open-file throw
>r r@ file-size throw drop
r@ scan-header - dup allocate throw image !
( r@ scan-header - ) dup allocate throw image !
image @ swap r@ read-file throw drop
image @ dup $804 ( 8 ) + be@ dup imagesize ! + relinfo !
r> close-file throw
......
......@@ -40,35 +40,36 @@ false Constant NIL \ relocating
>ENVIRON
false Constant file \ controls the presence of the
false DefaultValue file \ controls the presence of the
\ file access wordset
false Constant OS \ flag to indicate a operating system
false DefaultValue OS \ flag to indicate a operating system
false Constant prims \ true: primitives are c-code
false DefaultValue prims \ true: primitives are c-code
false Constant floating \ floating point wordset is present
false DefaultValue floating \ floating point wordset is present
false Constant glocals \ gforth locals are present
false DefaultValue glocals \ gforth locals are present
\ will be loaded
false Constant dcomps \ double number comparisons
false DefaultValue dcomps \ double number comparisons
false Constant hash \ hashing primitives are loaded/present
false DefaultValue hash \ hashing primitives are loaded/present
false Constant xconds \ used together with glocals,
false DefaultValue xconds \ used together with glocals,
\ special conditionals supporting gforths'
\ local variables
false Constant header \ save a header information
false DefaultValue header \ save a header information
true Constant ec
false Constant crlf
true DefaultValue ec
false DefaultValue crlf
false SetValue new-input
false SetValue peephole
true SetValue abranch \ enables absolute branches
true Constant rom
false DefaultValue rom
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB Constant kernel-size
cell 2 = [IF] 32 [ELSE] 256 [THEN] KB DefaultValue kernel-size
16 KB Constant stack-size
15 KB 512 + Constant fstack-size
15 KB Constant rstack-size
14 KB 512 + Constant lstack-size
16 KB DefaultValue stack-size
15 KB 512 + DefaultValue fstack-size
15 KB DefaultValue rstack-size
14 KB 512 + DefaultValue lstack-size
......@@ -53,9 +53,9 @@ End-Label
\ The virtual machine registers an data (stacks) go
\ to a seperate memory region (hopefully ram)
UNLOCK
current-region vm-memory activate ( saved-region )
LOCK
\ UNLOCK
\ current-region vm-memory activate ( saved-region )
\ LOCK
Label RP 0 ,
Label SP 0 ,
......@@ -304,22 +304,15 @@ Code ?branch
"Next" , jmp ,
'~ dout
t0 , accu ,
*accu , accu ,
Label >branch
IP , add ,
#2 , sub ,
accu , IP ,
*accu , IP ,
"Next" , jmp ,
Label "branch" >branch ,
end-code
Code branch
'b dout
#0 , add ,
IP , shr ,
*accu , accu ,
IP , add ,
accu , IP ,
*accu , IP ,
"Next" , jmp ,
end-code
......@@ -344,7 +337,8 @@ Code (loop)
t3 , sub ,
"Next" , jz ,
t0 , accu ,
"branch" , jmp ,
*accu , IP ,
"Next" , jmp ,
end-code
Code xor
......
......@@ -1412,11 +1412,10 @@ T has? rom H
\ MakeKernel 22feb99jaw
: makekernel ( targetsize -- )
: makekernel ( start targetsize -- )
\G convenience word to setup the memory of the target
\G used by main.fs of the c-engine based systems
100 swap dictionary (region)
setup-target ;
dictionary (region) setup-target ;
>MINIMAL
: makekernel makekernel ;
......@@ -2581,8 +2580,13 @@ Cond: [ ( -- ) interpreting-state ;Cond
Defer instant-interpret-does>-hook
T has? peephole H [IF]
: does-resolved ( ghost -- )
compile does-exec g>xt T a, H ;
[ELSE]
: does-resolved ( ghost -- )
g>xt T a, H ;
[THEN]
: resolve-does>-part ( -- )
\ resolve words made by builders
......
......@@ -19,6 +19,10 @@
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
*/
#define _FILE_OFFSET_BITS 64
#define _LARGEFILE_SOURCE
#define _GNU_SOURCE
#include "config.h"
#include <stdio.h>
#include <sys/time.h>
......
......@@ -67,8 +67,14 @@ has? ec
unlock ram-dictionary borders nip lock
AConstant dictionary-end
[ELSE]
: dictionary-end ( -- addr )
forthstart [ 3 cells image-header + ] Aliteral @ + ;
has? header [IF]
: dictionary-end ( -- addr )
forthstart [ 3 cells image-header + ] Aliteral @ + ;
[ELSE]
: forthstart 0 ;
: dictionary-end ( -- addr )
forthstart [ has? kernel-size ] Literal + ;
[THEN]
[THEN]
: usable-dictionary-end ( -- addr )
......@@ -225,7 +231,7 @@ defer throw ( y1 .. ym nerror -- y1 .. ym / z1 .. zn error ) \ exception
:noname ( y1 .. ym error -- y1 .. ym / z1 .. zn error )
?dup if
[ has? ec 0= [IF] here image-header 9 cells + ! [THEN] ]
[ has? header [IF] here image-header 9 cells + ! [THEN] ]
cr .error cr
[ has? file [IF] ] script? IF 1 (bye) ELSE quit THEN
[ [ELSE] ] quit [ [THEN] ]
......
......@@ -45,7 +45,7 @@ include ./../cross.fs \ cross-compiler
decimal
has? kernel-size makekernel
has? kernel-start has? kernel-size makekernel
\ create image-header
has? header [IF]
here 1802 over
......
......@@ -55,6 +55,7 @@ false DefaultValue control-rack \ disable return stack use for control flow
false DefaultValue ec
false DefaultValue crlf
$100 DefaultValue kernel-start
cell 2 = [IF] &32 KB [ELSE] $100000 cells [THEN] DefaultValue kernel-size
&16 KB DefaultValue stack-size
......
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