Commit 5e542775 authored by pazsan's avatar pazsan

A few additional fixes. gforth EC should run now with only three

doers: docol, dovar and dodoes. Tried without dovar, failed (strange).
parent 0c1b61d3
......@@ -92,6 +92,7 @@ KERN_SRC = \
files.fs \
kernel.fs \
main.fs \
primitives0.fs \
search-order.fs \
special.fs \
tools.fs \
......@@ -403,8 +404,8 @@ aliases.fs: primitives.b prims2x.fs aliases0.fs
$(CP) aliases0.fs aliases.fs
$(FORTHK) prims2x.fs -e "s\" primitives.b\" ' output-alias process-file bye" >>$@
primitives.fs: primitives.b prims2x.fs aliases0.fs
$(CP) aliases0.fs primitives.fs
primitives.fs: primitives.b prims2x.fs primitives0.fs
$(CP) primitives0.fs primitives.fs
$(FORTHK) prims2x.fs -e "s\" primitives.b\" ' output-forth process-file bye" >>$@
primitives.TAGS: primitives.b prims2x.fs
......
......@@ -444,6 +444,9 @@ Defer skip? ' false IS skip?
ghost dup >magic @ <fwd> =
IF >link @ 0<> ELSE drop false THEN ;
: doer? ( -- flag ) \ name
ghost >magic @ <do:> = ;
: skip-defs ( -- )
BEGIN refill WHILE source -trailing nip 0= UNTIL THEN ;
......@@ -760,12 +763,16 @@ Build: T 0 au, , H ;
by User
Builder AUser
Build: ( n -- ) T , H ;
Build: ( n -- ) ;
by: :docon ( ghost -- n ) T @ H ;DO
Builder (Constant)
Build: ( n -- ) T , H ;
by (Constant)
Builder Constant
Build: ( n -- ) T A, H ;
by Constant
by (Constant)
Builder AConstant
Build: ( d -- ) T , , H ;
......@@ -773,11 +780,11 @@ DO: ( ghost -- d ) T dup cell+ @ swap @ H ;DO
Builder 2Constant
Build: T 0 , H ;
by Constant
by (Constant)
Builder Value
Build: T 0 A, H ;
by Constant
by (Constant)
Builder AValue
Build: ( -- ) compile noop ;
......@@ -796,9 +803,13 @@ Builder interpret/compile:
1- tuck + swap invert and ;
>TARGET
Build: ;
by: :dofield T @ H + ;DO
Builder (Field)
Build: >r rot r@ nalign dup T , H ( align1 size offset )
+ swap r> nalign ;
by: :dofield T @ H + ;DO
by (Field)
Builder Field
: struct T 0 1 chars H ;
......@@ -920,6 +931,8 @@ also minimal
\ define new [IFDEF] and [IFUNDEF] 20may93jaw
: defined? defined? ;
: needed? needed? ;
: doer? doer? ;
: [IFDEF] defined? postpone [IF] ;
: [IFUNDEF] defined? 0= postpone [IF] ;
......
......@@ -30,8 +30,6 @@ decimal
\ VALUE 2>R 2R> 2R@ 17may93jaw
: value ( w "name" -- ) \ core-ext
(constant) , ;
\ !! 2value
: 2Literal ( compilation w1 w2 -- ; run-time -- w1 w2 ) \ double two-literal
......
......@@ -24,29 +24,45 @@ HEX
\ labels for some code addresses
doer? :docon [IF]
: docon: ( -- addr ) \ gforth
\G the code address of a @code{CONSTANT}
['] bl >code-address ;
[THEN]
: docol: ( -- addr ) \ gforth
\G the code address of a colon definition
['] docon: >code-address ;
['] docol: >code-address ;
doer? :dovar [IF]
: dovar: ( -- addr ) \ gforth
\G the code address of a @code{CREATE}d word
['] udp >code-address ;
[THEN]
doer? :douser [IF]
: douser: ( -- addr ) \ gforth
\G the code address of a @code{USER} variable
['] s0 >code-address ;
[THEN]
doer? :dodefer [IF]
: dodefer: ( -- addr ) \ gforth
\G the code address of a @code{defer}ed word
['] source >code-address ;
[THEN]
doer? :dofield [IF]
: dofield: ( -- addr ) \ gforth
\G the code address of a @code{field}
['] reveal-method >code-address ;
[THEN]
has-prims 0= [IF]
: dodoes: ( -- addr ) \ gforth
\G the code address of a @code{field}
['] spaces >code-address ;
[THEN]
NIL AConstant NIL \ gforth
......@@ -735,8 +751,13 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
: dodoes, ( -- )
here /does-handler allot does-handler! ;
doer? :dovar [IF]
: Create ( "name" -- ) \ core
Header reveal dovar: cfa, ;
[ELSE]
: Create ( "name" -- ) \ core
Header reveal here lastcfa ! 0 A, 0 , DOES> ;
[THEN]
\ Create Variable User Constant 17mar93py
......@@ -744,15 +765,26 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
Create 0 , ;
: AVariable ( "name" -- ) \ gforth
Create 0 A, ;
: 2VARIABLE ( "name" -- ) \ double
: 2Variable ( "name" -- ) \ double
create 0 , 0 , ;
: uallot ( n -- ) udp @ swap udp +! ;
doer? :douser [IF]
: User ( "name" -- ) \ gforth
Variable ;
Header reveal douser: cfa, cell uallot , ;
: AUser ( "name" -- ) \ gforth
AVariable ;
User ;
[ELSE]
: User Create uallot , DOES> @ up @ + ;
: AUser User ;
[THEN]
: (Constant) Header reveal docon: cfa, ;
doer? :docon [IF]
: (Constant) Header reveal docon: cfa, ;
[ELSE]
: (Constant) Create DOES> @ ;
[THEN]
: Constant ( w "name" -- ) \ core
\G Defines constant @var{name}
\G
......@@ -760,6 +792,8 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
(Constant) , ;
: AConstant ( addr "name" -- ) \ gforth
(Constant) A, ;
: Value ( w "name" -- ) \ core-ext
(Constant) , ;
: 2Constant ( w1 w2 "name" -- ) \ double
Create ( w1 w2 "name" -- )
......@@ -767,16 +801,23 @@ Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
DOES> ( -- w1 w2 )
2@ ;
doer? :dofield [IF]
: (Field) Header reveal dofield: cfa, ;
[ELSE]
: (Field) Create DOES> @ + ;
[THEN]
\ IS Defer What's Defers TO 24feb93py
doer? :dodefer [IF]
: Defer ( "name" -- ) \ gforth
\ !! shouldn't it be initialized with abort or something similar?
Header Reveal dodefer: cfa,
['] noop A, ;
\ Create ( -- )
\ ['] noop A,
\ DOES> ( ??? )
\ perform ;
[ELSE]
: Defer ( "name" -- ) \ gforth
Create ['] noop A,
DOES> @ execute ;
[THEN]
: Defers ( "name" -- ) \ gforth
' >body @ compile, ; immediate
......@@ -1263,9 +1304,6 @@ DEFER DOERROR
Defer 'cold ' noop IS 'cold
: cold ( -- ) \ gforth
[ has-os [IF] ]
stdout TO outfile-id
[ [THEN] ]
[ has-files [IF] ]
pathstring 2@ process-path pathdirs 2!
init-included-files
......@@ -1305,10 +1343,13 @@ Defer 'cold ' noop IS 'cold
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
: boot ( path **argv argc -- )
main-task up!
[ has-os [IF] ]
stdout TO outfile-id
[ [THEN] ]
[ has-files [IF] ]
argc ! argv ! pathstring 2!
[ [THEN] ]
main-task up!
sp@ s0 !
[ has-locals [IF] ]
lp@ forthstart 7 cells + @ -
......
......@@ -300,7 +300,7 @@ rp += 2;
*--rp = nlimit;
*--rp = nstart;
:
r> -rot swap >r >r >r ;
r> swap rot >r >r >r ;
(?do) nlimit nstart -- gforth paren_question_do
*--rp = nlimit;
......@@ -320,6 +320,8 @@ else {
cell+ >r
THEN ; \ --> CORE-EXT
\+has-xconds [IF]
(+do) nlimit nstart -- gforth paren_plus_do
*--rp = nlimit;
*--rp = nstart;
......@@ -400,6 +402,8 @@ else {
cell+
THEN >r ;
\+[THEN]
i -- n core
n = *rp;
:
......@@ -665,8 +669,8 @@ ud = (UDCell)u1 * (UDCell)u2;
r> 2* r> swap
LOOP 2drop ;
: d2*+ ( ud n -- ud+n c )
over MINI
and >r >r 2dup d+ swap r> + swap r> ;
over MINI
and >r >r 2dup d+ swap r> + swap r> ;
um/mod ud u1 -- u2 u3 core u_m_slash_mod
#ifdef BUGGY_LONG_LONG
......@@ -683,6 +687,9 @@ u2 = ud%u1;
LOOP drop swap 1 rshift or swap ;
: /modstep ( ud c R: u -- ud-?u c R: u )
over I' u< 0= or IF I' - 1 ELSE 0 THEN d2*+ ;
: d2*+ ( ud n -- ud+n c )
over MINI
and >r >r 2dup d+ swap r> + swap r> ;
m+ d1 n -- d2 double m_plus
#ifdef BUGGY_LONG_LONG
......@@ -912,9 +919,15 @@ NEXT_P0;
>r w -- core to_r
*--rp = w;
:
(>r) ;
: (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ;
r> -- w core r_from
w = *rp++;
:
rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
Create (rdrop) ' ;s A,
rdrop -- gforth
rp++;
......@@ -1069,26 +1082,27 @@ c! c c_addr -- core cstore
[ bigendian [IF] ]
[ cell>bit 4 = [IF] ]
tuck 1 and IF $FF and ELSE 8<< THEN >r
dup -2 and @ over 1 and
IF $FF00 ELSE $FF THEN and r> or swap -2 and !
[ [ELSE] ]
dup -2 and @ over 1 and cells masks + @ and
r> or swap -2 and ! ;
Create masks $00FF , $FF00 ,
[ELSE] ]
dup [ cell 1- ] literal and dup
[ cell 1- ] literal xor >r
- dup @ $FF r@ 0 ?DO 8<< LOOP invert and
rot $FF and r> 0 ?DO 8<< LOOP or swap !
[ [THEN] ]
[ [ELSE] ]
rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
[THEN]
[ELSE] ]
[ cell>bit 4 = [IF] ]
tuck 1 and IF 8<< ELSE $FF and THEN >r
dup -2 and @ over 1 and
IF $FF ELSE $FF00 THEN and r> or swap -2 and !
[ [ELSE] ]
dup -2 and @ over 1 and cells masks + @ and
r> or swap -2 and ! ;
Create masks $FF00 , $00FF ,
[ELSE] ]
dup [ cell 1- ] literal and dup >r
- dup @ $FF r@ 0 ?DO 8<< LOOP invert and
rot $FF and r> 0 ?DO 8<< LOOP or swap !
[ [THEN] ]
[ [THEN] ]
;
rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
[THEN]
[THEN]
: 8<< 2* 2* 2* 2* 2* 2* 2* 2* ;
2! w1 w2 a_addr -- core two_store
......@@ -1141,12 +1155,13 @@ for (; f83name1 != NULL; f83name1 = f83name1->next)
break;
f83name2=f83name1;
:
BEGIN dup WHILE
>r dup r@ cell+ c@ $1F and =
IF 2dup r@ cell+ char+ capscomp 0=
IF 2drop r> EXIT THEN THEN
BEGIN dup WHILE (find-samelen) dup WHILE
>r 2dup r@ cell+ char+ capscomp 0=
IF 2drop r> EXIT THEN
r> @
REPEAT nip nip ;
REPEAT THEN nip nip ;
: (find-samelen) ( u f83name1 -- u f83name2/0 )
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
\+has-hash [IF]
......@@ -1294,7 +1309,7 @@ is the start of the Forth code after DOES>""
MAKE_DOES_CF(xt, a_addr);
CACHE_FLUSH(xt,PFA(0));
:
['] :dodoes over ! cell+ ! ;
dodoes: over ! cell+ ! ;
does-handler! a_addr -- gforth does_handler_store
""creates a DOES>-handler at address a_addr. a_addr usually points
......@@ -1927,3 +1942,6 @@ lp -= sizeof(Float);
up! a_addr -- gforth up_store
up0=up=(char *)a_addr;
:
up ! ;
Variable UP
-2 Alias: :docol
\ -3 Alias: :docon
-4 Alias: :dovar
\ -5 Alias: :douser
\ -6 Alias: :dodefer
\ -7 Alias: :dofield
-8 Alias: :dodoes
-9 Alias: :doesjump
......@@ -37,7 +37,7 @@
: field ( offset1 align1 size align -- offset2 align2 )
\ note: this version uses local variables
Header reveal dofield: cfa,
(Field) \ Header reveal dofield: cfa,
>r rot r@ nalign dup , ( align1 size offset )
+ swap r> nalign ;
......
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