Commit b727d802 authored by pazsan's avatar pazsan

Mega-Patch; lots of changes

parent 1a243cc2
......@@ -31,8 +31,8 @@
# ------------- gforth version
VERSION_MAJOR=0
VERSION_MINOR=3
VERSION_RELEASE=1
VERSION_MINOR=4
VERSION_RELEASE=0
VERSION =$(VERSION_MAJOR).$(VERSION_MINOR).$(VERSION_RELEASE)
DOSVERSION=$(VERSION_MAJOR)$(VERSION_MINOR)$(VERSION_RELEASE)
......@@ -131,12 +131,30 @@ KERN_SRC = \
kernel/vars.fs \
kernel/accept.fs \
kernel/basics.fs \
kernel/interp.fs \
kernel/int.fs \
kernel/comp.fs \
kernel/io.fs \
kernel/license.fs \
kernel/nio.fs \
kernel/saccept.fs
EC_SRC = \
asm/00-readme \
asm/bitmask.fs \
asm/numref.fs \
asm/basic.fs \
asm/generic.fs \
asm/target.fs \
ec/00-readme \
ec/crossdoc.fd \
ec/mirror.fs \
ec/mirrors.fs \
ec/shex.fs \
ec/builttag.fs \
ec/dotx.fs \
ec/mirrored.fs \
ec/nesting.fs
GFORTH_FI_SRC = \
assert.fs \
blocked.fb \
......@@ -171,7 +189,7 @@ GFORTH_FI_SRC = \
sieve.fs \
add.fs
FORTH_SRC = $(KERN_SRC) $(GFORTH_FI_SRC) \
FORTH_SRC = $(KERN_SRC) $(GFORTH_FI_SRC) $(EC_SRC) \
ans-report.fs ansi.fs answords.fs \
code.fs colorize.fs comp-i.fs \
doskey.fs ds2texi.fs \
......@@ -213,7 +231,30 @@ ARCHS = arch/generic/machine.h \
arch/misc/prim.fs \
arch/misc/sim.fs \
arch/misc/sokoban.fs \
arch/misc/tt.fs
arch/misc/tt.fs \
arch/6502/asm.fs \
arch/6502/prim.fs \
arch/6502/mach.fs \
arch/6502/zero.fs \
arch/6502/softuart.fs \
arch/6502/cold.fs \
arch/8086/asm.fs \
arch/8086/mach.fs \
arch/8086/mach.sh \
arch/8086/prim.fs \
arch/avr/asm.fs \
arch/c165/asm.fs \
arch/c165/mach.fs \
arch/c165/prim.fs \
arch/h8/asm.fs \
arch/shboom/asm.fs \
arch/shboom/compiler.fs \
arch/shboom/dis.fs \
arch/shboom/mach.fs \
arch/shboom/prim.fs \
arch/shboom/dis2.fs \
arch/shboom/sh.p \
arch/shboom/doers.fs
SOURCES = CVS compat Makefile.in engine/Makefile.in gforthmi \
configure.in configure config.sub config.guess \
......@@ -445,7 +486,7 @@ check test: gforth gforth.fi
$(FORTH) test/other.fs -e bye
$(FORTH) code.fs test/checkans.fs -e bye
@echo 'Expect no differences'
$(FORTH) -m 100000 prims2x.fs -e "s\" $(srcdir)/prim.b\"' output-c process-file bye"| diff -c - $(srcdir)/engine/prim.i
$(FORTHK) -m 100000 prims2x.fs -e "s\" $(srcdir)/prim.b\"' output-c process-file bye"| diff -c - $(srcdir)/engine/prim.i
bench: gforth gforth.fi
@echo 'Each benchmark takes about 30s on a 486-66 (gcc-2.6.3 -DFORCE_REG)'
......@@ -556,10 +597,10 @@ kernel/prim.fs: prim.b prims2x.fs kernel/prim0.fs
$(RM) $@-
engine: engine/prim_lab.i engine/prim.i engine/version.h FORCE
bash makein.bsh engine engine
$(MAKE) -C engine engine
engine_ditc: engine/prim_lab.i engine/prim.i engine/version.h FORCE
bash makein.bsh engine engine_ditc
$(MAKE) -C engine engine_ditc
gforth: engine
-$(CP) gforth gforth~
......@@ -570,6 +611,14 @@ gforth-ditc: engine_ditc
$(GCC) $(LDFLAGS) $(OBJECTS_DITC) $(OBJECTS0) $(LDLIBS) -o $@
@GFORTHDITC_EXE@
# ------------- additional C primitives
%.c: %.pri prim2cl.fs
$(FORTHK) prim2cl.fs -e "file $< altogether bye" >$@
%.so: %.c
$(GCC) -shared $(CFLAGS) $< -o $@
# ------------- Make Documentation
#TAGS is a GNU standard target
......
......@@ -31,19 +31,33 @@
true Constant NIL \ relocating
false Constant has-files
false Constant has-OS
false Constant has-prims
false Constant has-floats
false Constant has-locals
false Constant has-dcomps
false Constant has-hash
false Constant has-xconds
false Constant has-header
false Constant ITC
: prims-include ." Include primitives" cr s" arch/4stack/prim.fs" included ;
: asm-include ." Include assembler" cr s" arch/4stack/asm.fs" included ;
: >boot
S" ' boot >body $800 ! here $804 !" evaluate ;
>ENVIRON
false Constant file \ controls the presence of the
\ file access wordset
false Constant OS \ flag to indicate a operating system
false Constant prims \ true: primitives are c-code
false Constant floating \ floating point wordset is present
false Constant glocals \ gforth locals are present
\ will be loaded
false Constant dcomps \ double number comparisons
false Constant hash \ hashing primitives are loaded/present
false Constant xconds \ used together with glocals,
\ special conditionals supporting gforths'
\ local variables
false Constant header \ save a header information
false Constant ec
false Constant crlf
false Constant ITC
......@@ -45,7 +45,7 @@
#define FLUSH_ICACHE(addr,size) \
cacheflush((char *)(addr), (int)(size), BCACHE)
#include "../../engine/32bit.h"
#include "../../machine/32bit.h"
#ifdef DIRECT_THREADED
/* some definitions for composing opcodes */
......
......@@ -8,7 +8,6 @@ also assembler also definitions forth
$0 Constant PC $1 Constant PC+2
$2 Constant PC+4 $3 Constant PC+6
$7 Constant *ACCU
$8 Constant ACCU $9 Constant SF
$A Constant ZF $C Constant CF
......@@ -17,6 +16,7 @@ $A Constant ZF $C Constant CF
$0 Constant JMP $1 Constant JS
$2 Constant JZ $4 Constant JC
$7 Constant *ACCU
( $8 Constant ACCU ) $9 Constant SUB
( $A Constant SUBR ) $B Constant ADD
$C Constant XOR $D Constant OR
......
......@@ -40,16 +40,24 @@ false Constant NIL \ relocating
>ENVIRON
false Constant file
false Constant OS
false Constant prims
false Constant floating
false Constant glocals
false Constant dcomps
false Constant hash
false Constant xconds
false Constant header
true Constant ec
true Constant crlf
true Constant ITC
false Constant file \ controls the presence of the
\ file access wordset
false Constant OS \ flag to indicate a operating system
false Constant prims \ true: primitives are c-code
false Constant floating \ floating point wordset is present
false Constant glocals \ gforth locals are present
\ will be loaded
false Constant dcomps \ double number comparisons
false Constant hash \ hashing primitives are loaded/present
false Constant xconds \ used together with glocals,
\ special conditionals supporting gforths'
\ local variables
false Constant header \ save a header information
true Constant ec
false Constant crlf
......@@ -12,7 +12,10 @@
decimal
: ms 0 ?DO ( $3000 0 DO LOOP ) LOOP ;
variable loops/ms
0 loops/ms !
: ms 0 ?DO loops/ms @ 0 ?DO LOOP LOOP ;
: blank bl fill ;
Create pn-tab ," 000102030405060708091011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980"
......
......@@ -41,6 +41,10 @@
\ mach file is only loaded into target
\ cell corrected
\ romable extansions 27apr97-5jun97jaw
\ environmental query support 01sep97jaw
\ added own [IF] ... [ELSE] ... [THEN] 14sep97jaw
\ extra resolver for doers 20sep97jaw
\ added killref for DOES> 20sep97jaw
hex \ the defualt base for the cross-compiler is hex !!
......@@ -59,16 +63,16 @@ Warnings off
dup c, here swap chars dup allot move ;
: SetValue ( n -- <name> )
\G Same behaviour as "Value" when the <name> is not defined
\G Same behaviour as "to" when <name> is defined
\G Same behaviour as "Value" if the <name> is not defined
\G Same behaviour as "to" if <name> is defined
\G SetValue searches in the current vocabulary
save-input bl word >r restore-input throw r> count
get-current search-wordlist
IF bl word drop >body ! ELSE Value THEN ;
: DefaultValue ( n -- <name> )
\G Same behaviour as "Value" when the <name> is not defined
\G SetValue searches in the current vocabulary
\G Same behaviour as "Value" if the <name> is not defined
\G DefaultValue searches in the current vocabulary
save-input bl word >r restore-input throw r> count
get-current search-wordlist
IF bl word drop drop drop ELSE Value THEN ;
......@@ -149,6 +153,7 @@ stack-warn [IF]
[THEN]
\ \ GhostNames Ghosts 9may93jaw
\ second name source to search trough list
......@@ -234,7 +239,9 @@ VARIABLE Already
BEGIN @ dup
WHILE 2dup cell+ @ =
UNTIL nip 2 cells + count
ELSE 2drop true abort" CROSS: Ghostnames inconsistent"
ELSE 2drop
\ true abort" CROSS: Ghostnames inconsistent"
s" ?!?!?!"
THEN ;
' >ghostname ALIAS @name
......@@ -256,8 +263,11 @@ ghost (does>) ghost noop 2drop
ghost (.") ghost (S") ghost (ABORT") 2drop drop
ghost ' drop
ghost :docol ghost :doesjump ghost :dodoes 2drop drop
ghost :dovar drop
ghost over ghost = ghost drop 2drop drop
ghost - drop
ghost 2drop drop
ghost 2dup drop
\ \ Parameter for target systems 06oct92py
......@@ -286,18 +296,33 @@ VARIABLE env-current \ save information of current dictionary to restore with en
: $has? T environment? H IF ELSE false THEN ;
>ENVIRON
false SetValue ionly
>ENVIRON get-order get-current swap 1+ set-order
true SetValue compiler
true SetValue cross
>TARGET
true SetValue standard-threading
>TARGET previous
mach-file count included hex
>ENVIRON
s" interpreter" T environment? H 0= ?dup nip [IF] true Value interpreter [THEN]
s" ITC" T environment? H 0= ?dup nip [IF] true SetValue ITC [THEN]
s" rom" T environment? H 0= ?dup nip [IF] false Value rom [THEN]
T has? ec H
[IF]
false DefaultValue relocate
false DefaultValue file
false DefaultValue OS
false DefaultValue prims
false DefaultValue floating
false DefaultValue glocals
false DefaultValue dcomps
false DefaultValue hash
false DefaultValue xconds
false DefaultValue header
[THEN]
true DefaultValue interpreter
true DefaultValue ITC
false DefaultValue rom
>TARGET
s" relocate" T environment? H
......@@ -358,7 +383,7 @@ Variable user-vars 0 user-vars !
>CROSS
\ memregion.fs
\ \ memregion.fs
Variable last-defined-region \ pointer to last defined region
......@@ -473,7 +498,7 @@ T has? rom H
ABORT" CROSS: define at least address-space or dictionary!!"
+ makekernel drop ;
\ switched tdp for rom support 03jun97jaw
\ \ switched tdp for rom support 03jun97jaw
\ second value is here to store some maximal value for statistics
\ tempdp is also embedded here but has nothing to do with rom support
......@@ -648,19 +673,40 @@ previous
\ \ -------------------- Compiler Plug Ins 01aug97jaw
\ Compiler States
Variable comp-state
0 Constant interpreting
1 Constant compiling
2 Constant resolving
3 Constant assembling
Defer lit, ( n -- )
Defer alit, ( n -- )
Defer branch, ( target-addr -- )
Defer ?branch, ( target-addr -- )
Defer branchmark, ( -- branch-addr )
Defer ?branchmark, ( -- branch-addr )
Defer branchto,
Defer branchtoresolve, ( branch-addr -- )
Defer branchfrom, ( -- )
Defer branchtomark, ( -- target-addr )
Defer branch, ( target-addr -- ) \ compiles a branch
Defer ?branch, ( target-addr -- ) \ compiles a ?branch
Defer branchmark, ( -- branch-addr ) \ reserves room for a branch
Defer ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch
Defer ?domark, ( -- branch-addr ) \ reserves room for a ?do branch
Defer branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment)
Defer branchtoresolve, ( branch-addr -- ) \ resolves a forward reference from branchmark
Defer branchfrom, ( -- ) \ ?!
Defer branchtomark, ( -- target-addr ) \ marks a branch destination
Defer colon, ( tcfa -- ) \ compiles call to tcfa at current position
Defer colonmark, ( -- addr ) \ marks a colon call
Defer colon-resolve ( tcfa addr -- )
Defer addr-resolve ( target-addr addr -- )
Defer doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
Defer do, ( -- do-token )
Defer ?do, ( -- ?do-token )
Defer for, ( -- for-token )
Defer loop, ( do-token / ?do-token -- )
Defer +loop, ( do-token / ?do-token -- )
Defer next, ( for-token )
[IFUNDEF] ca>native
defer ca>native
......@@ -671,8 +717,8 @@ DEFER >body \ we need the system >body
\ and the target >body
>CROSS
T 2 cells H VALUE xt>body
DEFER doprim,
DEFER docol, \ compiles start of definition and doer
DEFER doprim, \ compiles start of a primitive
DEFER docol, \ compiles start of a colon definition
DEFER doer,
DEFER fini, \ compiles end of definition ;s
DEFER doeshandler,
......@@ -681,9 +727,21 @@ DEFER dodoes,
DEFER ]comp \ starts compilation
DEFER comp[ \ ends compilation
: (cc) T a, H ; ' (cc) IS colon,
: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve
: (ar) T ! H ; ' (ar) IS addr-resolve
: (cc) T a, H ; ' (cc) IS colon,
: (cr) >tempdp ]comp colon, comp[ tempdp> ; ' (cr) IS colon-resolve
: (ar) T ! H ; ' (ar) IS addr-resolve
: (dr) ( ghost res-pnt target-addr addr )
>tempdp drop over
dup >magic @ <do:> =
IF doer,
ELSE dodoes,
THEN
tempdp> ; ' (dr) IS doer-resolve
: (cm) ( -- addr )
T here align H
-1 colon, ; ' (cm) IS colonmark,
>TARGET
: compile, colon, ;
......@@ -691,16 +749,21 @@ DEFER comp[ \ ends compilation
\ file loading
: >fl-id 1 cells + ;
: >fl-name 2 cells + ;
Variable filelist 0 filelist !
0 Value loadfile
0 Value filemem
: loadfile filemem >fl-name ;
0 [IF] \ !! JAW WIP
1 [IF] \ !! JAW WIP
: add-included-file ( adr len -- )
dup 2 cells + allocate throw >r
r@ 1 cells + dup TO loadfile place
dup char+ >fl-name allocate throw >r
r@ >fl-name place
filelist @ r@ !
r> filelist ! ;
r> dup filelist ! to FileMem
;
: included? ( c-addr u -- f )
filelist
......@@ -712,8 +775,10 @@ Variable filelist 0 filelist !
2drop drop false ;
: included
cr ." Including: " 2dup type ." ..."
2dup add-included-file included ;
\ cr ." Including: " 2dup type ." ..."
FileMem >r
2dup add-included-file included
r> to FileMem ;
: include bl word count included ;
......@@ -724,17 +789,37 @@ Variable filelist 0 filelist !
\ resolve structure
: >next ; \ link to next field
: >tag cell+ ; \ indecates type of reference: 0: call, 1: address
: >tag cell+ ; \ indecates type of reference: 0: call, 1: address, 2: doer
: >taddr cell+ cell+ ;
: >ghost 3 cells + ;
: >file 4 cells + ;
: >line 5 cells + ;
: (refered) ( ghost addr tag -- )
\G creates a reference to ghost at address taddr
rot >r here r@ >link @ , r> >link !
( taddr tag ) ,
( taddr ) ,
last-header-ghost @ ,
loadfile ,
sourceline# ,
;
: refered ( ghost tag -- )
\G creates a resolve structure
swap >r here r@ >link @ , r@ >link ! ( tag ) ,
T here aligned H , r> drop last-header-ghost @ ,
loadfile , sourceline# ,
T here aligned H swap (refered)
;
: killref ( addr ghost -- )
\G kills a forward reference to ghost at position addr
\G this is used to eleminate a :dovar refence after making a DOES>
dup >magic @ <fwd> <> IF 2drop EXIT THEN
swap >r >link
BEGIN dup @ dup ( addr last this )
WHILE dup >taddr @ r@ =
IF @ over !
ELSE nip THEN
REPEAT rdrop 2drop
;
Defer resolve-warning
......@@ -750,16 +835,20 @@ Defer resolve-warning
\ resolve 14oct92py
: resolve-loop ( ghost tcfa -- ghost tcfa )
>r dup >link
BEGIN @ dup WHILE
resolve-warning
r@ over >taddr @
2 pick >tag @
IF addr-resolve
ELSE colon-resolve
THEN
REPEAT drop r> ;
: resolve-loop ( ghost resolve-list tcfa -- )
>r
BEGIN dup WHILE
\ dup >tag @ 2 = IF reswarn-forward THEN
resolve-warning
r@ over >taddr @
2 pick >tag @
CASE 0 OF colon-resolve ENDOF
1 OF addr-resolve ENDOF
2 OF doer-resolve ENDOF
ENDCASE
@ \ next list element
REPEAT 2drop rdrop
;
\ : resolve-loop ( ghost tcfa -- ghost tcfa )
\ >r dup >link @
......@@ -786,17 +875,27 @@ Exists-Warnings on
THEN ;
: resolve ( ghost tcfa -- )
\ resolve referencies to ghost with tcfa
over forward? 0= IF exists EXIT THEN
resolve-loop over >link ! <res> swap >magic !
['] noop IS resolve-warning
\G resolve referencies to ghost with tcfa
\ is ghost resolved?, second resolve means another definition with the
\ same name
over forward? 0= IF exists EXIT THEN
\ get linked-list
swap >r r@ >link @ swap \ ( list tcfa R: ghost )
\ mark ghost as resolved
dup r@ >link ! <res> r@ >magic !
\ loop through forward referencies
r> -rot
comp-state @ >r Resolving comp-state !
resolve-loop
r> comp-state !
['] noop IS resolve-warning
;
\ gexecute ghost, 01nov92py
: is-forward ( ghost -- )
\ >link dup @ there rot ! T A, H ;
0 refered -1 colon, ;
colonmark, 0 (refered) ; \ compile space for call
: is-resolved ( ghost -- )
>link @ colon, ; \ compile-call
......@@ -870,7 +969,10 @@ VARIABLE ^imm
<imm> ^imm @ ! ;
: restrict 20 flag! ;
: isdoer <do:> last-header-ghost @ >magic ! ;
: isdoer
\G define a forth word as doer, this makes obviously only sence on
\G forth processors such as the PSC1000
<do:> last-header-ghost @ >magic ! ;
>CROSS
\ ALIAS2 ansforth conform alias 9may93jaw
......@@ -975,10 +1077,16 @@ Defer skip? ' false IS skip?
\ Target header creation
Variable CreateFlag
CreateFlag off
VARIABLE CreateFlag CreateFlag off
Variable NoHeaderFlag
NoHeaderFlag off
: 0.r ( n1 n2 -- ) 0 swap <# 0 ?DO # LOOP #> type ;
: 0.r ( n1 n2 -- )
base @ >r hex
0 swap <# 0 ?DO # LOOP #> type
r> base ! ;
: .sym
bounds
DO I c@ dup
......@@ -986,30 +1094,40 @@ VARIABLE CreateFlag CreateFlag off
'\ OF drop ." \\" ENDOF
dup OF emit ENDOF
ENDCASE
LOOP ;
LOOP ;
: (Theader ( "name" -- ghost )
\ >in @ bl word count type 2 spaces >in !
\ wordheaders will always be compiled to rom
switchrom
T align H view,
tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
1 headers-named +! \ Statistic
>in @ T name, H >in ! T here H tlastcfa !
\ Symbol table
\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in !
CreateFlag @ IF
>in @ alias2 swap >in ! \ create alias in target
>in @ ghost swap >in !
swap also ghosts ' previous swap ! \ tick ghost and store in alias
CreateFlag off
ELSE ghost THEN
dup Last-Header-Ghost !
dup >magic ^imm ! \ a pointer for immediate
Already @ IF dup >end tdoes !
ELSE 0 tdoes ! THEN
80 flag!
cross-doc-entry cross-tag-entry ;
\ >in @ bl word count type 2 spaces >in !
\ wordheaders will always be compiled to rom
switchrom
\ build header in target
NoHeaderFlag @
IF NoHeaderFlag off
ELSE
T align H view,
tlast @ dup 0> IF T 1 cells - THEN A, H there tlast !
1 headers-named +! \ Statistic
>in @ T name, H >in !
THEN
T cfalign here H tlastcfa !
\ Symbol table
\ >in @ cr ." sym:s/CFA=" there 4 0.r ." /" bl word count .sym ." /g" cr >in !
CreateFlag @
IF
>in @ alias2 swap >in ! \ create alias in target
>in @ ghost swap >in !
swap also ghosts ' previous swap ! \ tick ghost and store in alias
CreateFlag off
ELSE ghost
THEN
dup Last-Header-Ghost !
dup >magic ^imm ! \ a pointer for immediate
Already @
IF dup >end tdoes !
ELSE 0 tdoes !
THEN
80 flag!
cross-doc-entry cross-tag-entry ;
VARIABLE ;Resolve 1 cells allot
\ this is the resolver information from ":"
......@@ -1210,6 +1328,7 @@ Cond: MAXI
\ ] 9may93py/jaw
: ] state on
Compiling comp-state !
BEGIN
BEGIN >in @ bl word
dup c@ 0= WHILE 2drop refill 0=
......@@ -1254,15 +1373,22 @@ Cond: ; ( -- ) restrict?
state off
;Resolve @
IF ;Resolve @ ;Resolve cell+ @ resolve THEN
Interpreting comp-state !
;Cond
Cond: [ restrict? state off ;Cond
Cond: [ restrict? state off Interpreting comp-state ! ;Cond
>CROSS
Create GhostDummy ghostheader
<res> GhostDummy >magic !
: !does ( does-action -- )
\ !! zusammenziehen und dodoes, machen!
tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
tlastcfa @ [G'] :dovar killref
\ tlastcfa @ dup there >r tdp ! compile :dodoes r> tdp ! T cell+ ! H ;
\ !! geht so nicht, da dodoes, ghost will!
\ tlastcfa @ >tempdp dodoes, tempdp> ;
GhostDummy >link ! GhostDummy
tlastcfa @ >tempdp dodoes, tempdp> ;
>TARGET
Cond: DOES> restrict?
......@@ -1284,7 +1410,10 @@ Cond: DOES> restrict?
\ for do:-xt an additional entry after the normal ghost-enrys is used
>in @ alias2 swap dup >in ! >r >r
Make-Ghost rot swap >exec ! ,
Make-Ghost
rot swap >exec dup @ ['] NoExec <>
IF 2drop ELSE ! THEN
,
r> r> >in !
also ghosts ' previous swap ! ;
\ DOES> dup >exec @ execute ;
......@@ -1294,12 +1423,16 @@ Cond: DOES> restrict?
>end @ dup forward? 0=