Commit 1a3e0b2b authored by pazsan's avatar pazsan

Further fixes for Gforth EC

parent e2d39029
...@@ -454,11 +454,13 @@ Create lits 0. 2, 0. 2, 0. 2, 0. 2, 0. 2, 0. 2, ...@@ -454,11 +454,13 @@ Create lits 0. 2, 0. 2, 0. 2, 0. 2, 0. 2, 0. 2,
dup 2 = IF hih 2drop 0 0 rot 2! EXIT THEN THEN dup 2 = IF hih 2drop 0 0 rot 2! EXIT THEN THEN
1- >r $100 um* #< r> rot 2! 1- >r $100 um* #< r> rot 2!
ELSE 2drop drop alu? IF nop ELSE 0 # THEN THEN ; ELSE 2drop drop alu? IF nop ELSE 0 # THEN THEN ;
:D
: >sym ( "symbol" -- addr )
bl word count sym-lookup? dup 0= abort" No symbol!"
>body cell+ @ @ ;
:D
: >ip.b ( -- ) : >ip.b ( -- )
bl word count sym-lookup? dup 0= abort" No symbol!" >sym 4here 2 cells + - ;
>body cell+ @ @ 4here 2 cells + - ;
:A :A
: .ip.b# ( -- ) >ip.b [A] # [F] ; : .ip.b# ( -- ) >ip.b [A] # [F] ;
: .ip.h# ( -- ) >ip.b 2/ [A] # [F] ; : .ip.h# ( -- ) >ip.b 2/ [A] # [F] ;
...@@ -472,11 +474,10 @@ Create lits 0. 2, 0. 2, 0. 2, 0. 2, 0. 2, 0. 2, ...@@ -472,11 +474,10 @@ Create lits 0. 2, 0. 2, 0. 2, 0. 2, 0. 2, 0. 2,
:D :D
Variable procstart Variable procstart
: >p.b ( -- ) : >p.b ( -- )
bl word count sym-lookup? dup 0= abort" No symbol!" >sym procstart @ - ;
>body cell+ @ @ procstart @ - ;
:A :A
: .proc finish? 4here procstart ! ; : .proc finish? 4here procstart ! ;
: .p ( -- n ) >p.b ; : .p# ( -- n ) >p.b ;
: .p.b# ( -- ) >p.b [A] # [F] ; : .p.b# ( -- ) >p.b [A] # [F] ;
: .p.h# ( -- ) >p.b 2/ [A] # [F] ; : .p.h# ( -- ) >p.b 2/ [A] # [F] ;
: .p.w# ( -- ) >p.b 2/ 2/ [A] # [F] ; : .p.w# ( -- ) >p.b 2/ 2/ [A] # [F] ;
......
...@@ -410,54 +410,69 @@ end-code ...@@ -410,54 +410,69 @@ end-code
: code-address! ( addr xt -- ) >r 3 or $808 @ r> 2! ; : code-address! ( addr xt -- ) >r 3 or $808 @ r> 2! ;
: does-code! ( a_addr xt -- ) >r 5 - $808 @ r> 2! ; : does-code! ( a_addr xt -- ) >r 5 - $808 @ r> 2! ;
: does-handler! ( a_addr -- ) >r $810 2@ r> 2! ; : does-handler! ( a_addr -- ) >r $810 2@ r> 2! ;
: finish-code ;
: bye 0 execute ; : bye 0 execute ;
: (bye) 0 execute ; : (bye) 0 execute ;
: float+ 8 + ; : float+ 8 + ;
: sgn ( n -- -1/0/1 ) : sgn ( n -- -1/0/1 )
dup 0= IF EXIT THEN 0< 2* 1+ ; dup 0= IF EXIT THEN 0< 2* 1+ ;
: -text : -text ( c_addr1 u c_addr2 -- n )
swap bounds swap bounds
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
ELSE c@ I c@ - unloop THEN sgn ; ELSE c@ I c@ - unloop THEN sgn ;
: finish-code ; : capscomp ( c_addr1 u c_addr2 -- n )
: capscomp ( c_addr1 u c_addr2 -- n ) swap bounds
swap bounds ?DO dup c@ I c@ <>
?DO dup c@ I c@ <> IF dup c@ toupper I c@ toupper =
IF dup c@ toupper I c@ toupper = ELSE true THEN WHILE 1+ LOOP drop 0
ELSE true THEN WHILE 1+ LOOP drop 0 ELSE c@ toupper I c@ toupper - unloop THEN sgn ;
ELSE c@ toupper I c@ toupper - unloop THEN sgn ;
\ division a/b \ division a/b
\ x:=a, y:=b, r:=est; iterate(x:=x*r, y:=y*r, r:=2-y*r); \ x:=a, y:=b, r:=est; iterate(x:=x*r, y:=y*r, r:=2-y*r);
\ result: x=a/b; y=1; r=1 \ result: x=a/b; y=1; r=1
\ Label idiv-table Code u/mod ( u1 u2 -- q r )
\ idiv-tab: drop nop pick 0s0 call $43 +IP ;;
\ .macro .idiv-table [F] pick 1s0 drop nop nop ;;
\ $100 $80 DO 0 $100 I 2* 1+ um/mod long, drop LOOP swap ip! nop nop 0 # ld 1: R1 N+ ;;
\ .end-macro nop nop nop nop ;;
\ .idiv-table .macro .idiv-table [F]
\ end-code $100 $80 DO 0 $100 I 2* 1+ um/mod long, drop LOOP
\ .end-macro
\ Code um/mod1 ( u -- 1/u ) approx:
\ ;; b -- -- -- -- -- ;; .idiv-table
\ ff1 -$1F # nop nop br 0 :0= div0 idiv:
\ bfu add 0s0 ip@ nop set 2: R2 ;; ;; a -- b --
\ ;; b' -- -- -- -- -- ;; nop pick 2s0 ff1 1 # br 1 :0= ;;
\ lob $0FF ## pick 0s0 pick 0s0 0 # -$108 ## ;; ip@ pick 2s0 bfu cm! set 0: R2 ;;
\ 1 # #, sub #min 1 # ld 0: R2 +s0 #, ;; ;; a n b' --
\ cm! and nop cm! br 2 ?0= by2 nop -$1D # lob pick 2s0 0 # -$104 ## ;;
\ ;; est -- -- b' -- -- ;; nop add pick 3s0 drop ld 2: R2 +s0 #, ;;
\ umul 3s0 pick 0s0 nop umul 0s0 0 # 0 # ;; nop cm! nip nop ;;
\ mulr<@ nop nop -mulr@ ;; ;; a n b' r --
\ drop umul 3s0 nop umul 0s0 ;; umul 2s0 pick 0s0 umul nop ;;
\ mulr<@ cm! nop -mulr@ ;; mulr@ 0 # mulr@ -mulr@ ;; first iteration
\ umul 3s0 drop pick 1s0 drop ;; umul 3s0 pick s2 umul 3s0 drop ;;
\ drop mulr<@ ip! nop 0 # ld 1: R1 N+ ;; mulr@ nop nop -mulr<@ ;; second iteration
\ pick 1s0 drop nop nop ;; umul 3s0 nop nop drop ;;
\ by2: nop mulr<@ nop nop ;; final iteration+shift
\ div0: pick 1s0 umul nop nop ;;
\ -1 # ip! nop nop 0 # ld 1: R1 N+ ;; nop -mul@+ nop ret br 1 ?0< ;;
\ nop nop nop nop ;; nop nip nop nop ;;
\ end-code .endif
dec add nop nop ;;
;; q r
.endif
nop drop drop drop ;;
dec 0 # drop ret ;;
nop ;;
end-code
: /mod ( d1 n1 -- n2 n3 )
dup >r dup 0< IF negate >r negate r> THEN
over 0< IF tuck + swap THEN
u/mod
r> 0< IF swap negate swap THEN ;
...@@ -59,7 +59,7 @@ false SetValue xconds \ used together with glocals, ...@@ -59,7 +59,7 @@ false SetValue xconds \ used together with glocals,
\ local variables \ local variables
false SetValue header \ save a header information false SetValue header \ save a header information
false SetValue ec true SetValue ec
false SetValue crlf false SetValue crlf
true SetValue ITC true SetValue ITC
false SetValue new-input false SetValue new-input
......
...@@ -830,16 +830,4 @@ include ./optcmove.fs ...@@ -830,16 +830,4 @@ include ./optcmove.fs
: (bye) 0 execute ; : (bye) 0 execute ;
: float+ 8 + ; : float+ 8 + ;
: sgn ( n -- -1/0/1 )
dup 0= IF EXIT THEN 0< 2* 1+ ;
: -text
swap bounds
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
ELSE c@ I c@ - unloop THEN sgn ;
: finish-code ; : finish-code ;
: capscomp ( c_addr1 u c_addr2 -- n )
swap bounds
?DO dup c@ I c@ <>
IF dup c@ toupper I c@ toupper =
ELSE true THEN WHILE 1+ LOOP drop 0
ELSE c@ toupper I c@ toupper - unloop THEN sgn ;
...@@ -1177,7 +1177,7 @@ false DefaultValue new-input ...@@ -1177,7 +1177,7 @@ false DefaultValue new-input
false DefaultValue peephole false DefaultValue peephole
false DefaultValue abranch false DefaultValue abranch
true DefaultValue f83headerstring true DefaultValue f83headerstring
true DefaultValue control-rack true DefaultValue control-rack
[THEN] [THEN]
true DefaultValue gforthcross true DefaultValue gforthcross
......
...@@ -62,8 +62,7 @@ hex ...@@ -62,8 +62,7 @@ hex
\ UNUSED 17may93jaw \ UNUSED 17may93jaw
has? ec has? ec [IF]
[IF]
unlock ram-dictionary borders nip lock unlock ram-dictionary borders nip lock
AConstant dictionary-end AConstant dictionary-end
[ELSE] [ELSE]
...@@ -87,7 +86,7 @@ AConstant dictionary-end ...@@ -87,7 +86,7 @@ AConstant dictionary-end
has? ec [IF] has? ec [IF]
: in-dictionary? ( x -- f ) : in-dictionary? ( x -- f )
dictionary-end < ; dictionary-end u< ;
[ELSE] [ELSE]
: in-dictionary? ( x -- f ) : in-dictionary? ( x -- f )
forthstart dictionary-end within ; forthstart dictionary-end within ;
......
...@@ -58,5 +58,5 @@ doer? :dofield [IF] ...@@ -58,5 +58,5 @@ doer? :dofield [IF]
true [IF] \ !! don't know what to put here true [IF] \ !! don't know what to put here
: dodoes: ( -- addr ) \ gforth : dodoes: ( -- addr ) \ gforth
\G The code address of a @code{field}??? \G The code address of a @code{field}???
['] spaces >code-address ; ['] DOES> >code-address ;
[THEN] [THEN]
...@@ -229,8 +229,13 @@ struct ...@@ -229,8 +229,13 @@ struct
cell% field wordlist-extend \ wordlist extensions (eg bucket offset) cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
end-struct wordlist-struct end-struct wordlist-struct
has? f83headerstring [IF]
: f83find ( addr len wordlist -- nt / false )
wordlist-id @ (f83find) ;
[ELSE]
: f83find ( addr len wordlist -- nt / false ) : f83find ( addr len wordlist -- nt / false )
wordlist-id @ (listlfind) ; wordlist-id @ (listlfind) ;
[THEN]
: initvoc ( wid -- ) : initvoc ( wid -- )
dup wordlist-map @ hash-method perform ; dup wordlist-map @ hash-method perform ;
...@@ -260,6 +265,13 @@ forth-wordlist current ! ...@@ -260,6 +265,13 @@ forth-wordlist current !
\ The constants are defined as 32 bits, but then erased \ The constants are defined as 32 bits, but then erased
\ and overwritten by the right ones \ and overwritten by the right ones
has? f83headerstring [IF]
\ to save space, Gforth EC limits words to 31 characters
$80 constant alias-mask
$40 constant immediate-mask
$20 constant restrict-mask
$1f constant lcount-mask
[ELSE]
$80000000 constant alias-mask $80000000 constant alias-mask
1 bits/char 1 - lshift 1 bits/char 1 - lshift
-1 cells allot bigendian [IF] c, 0 1 cells 1- times -1 cells allot bigendian [IF] c, 0 1 cells 1- times
...@@ -276,6 +288,7 @@ $1fffffff constant lcount-mask ...@@ -276,6 +288,7 @@ $1fffffff constant lcount-mask
1 bits/char 3 - lshift 1 - 1 bits/char 3 - lshift 1 -
-1 cells allot bigendian [IF] c, -1 1 cells 1- times -1 cells allot bigendian [IF] c, -1 1 cells 1- times
[ELSE] -1 1 cells 1- times c, [THEN] [ELSE] -1 1 cells 1- times c, [THEN]
[THEN]
\ higher level parts of find \ higher level parts of find
...@@ -306,6 +319,22 @@ $1fffffff constant lcount-mask ...@@ -306,6 +319,22 @@ $1fffffff constant lcount-mask
(cfa>int) (cfa>int)
then ; then ;
has? f83headerstring [IF]
: name>string ( nt -- addr count ) \ gforth head-to-string
\g @i{addr count} is the name of the word represented by @i{nt}.
cell+ count lcount-mask and ;
: ((name>)) ( nfa -- cfa )
name>string + cfaligned ;
: (name>x) ( nfa -- cfa w )
\ cfa is an intermediate cfa and w is the flags cell of nfa
dup ((name>))
swap cell+ c@ dup alias-mask and 0=
IF
swap @ swap
THEN ;
[ELSE]
: name>string ( nt -- addr count ) \ gforth head-to-string : name>string ( nt -- addr count ) \ gforth head-to-string
\g @i{addr count} is the name of the word represented by @i{nt}. \g @i{addr count} is the name of the word represented by @i{nt}.
cell+ dup cell+ swap @ lcount-mask and ; cell+ dup cell+ swap @ lcount-mask and ;
...@@ -320,6 +349,7 @@ $1fffffff constant lcount-mask ...@@ -320,6 +349,7 @@ $1fffffff constant lcount-mask
IF IF
swap @ swap swap @ swap
THEN ; THEN ;
[THEN]
: name>int ( nt -- xt ) \ gforth : name>int ( nt -- xt ) \ gforth
\G @i{xt} represents the interpretation semantics of the word \G @i{xt} represents the interpretation semantics of the word
......
...@@ -107,8 +107,10 @@ has? compiler [IF] ...@@ -107,8 +107,10 @@ has? compiler [IF]
[THEN] [THEN]
\ these two games can be added to provide complex examples for the 4stack \ these two games can be added to provide complex examples for the 4stack
\ and misc simulators (see arch/4stack/README and arch/misc/README). \ and misc simulators (see arch/4stack/README and arch/misc/README).
\ include arch/misc/tt.fs has? games [IF]
\ include arch/misc/sokoban.fs include arch/misc/tt.fs
include arch/misc/sokoban.fs
[THEN]
[THEN] [THEN]
include ./quotes.fs include ./quotes.fs
include ./toolsext.fs include ./toolsext.fs
......
...@@ -1315,6 +1315,33 @@ c_addr2 = c_addr1+1; ...@@ -1315,6 +1315,33 @@ c_addr2 = c_addr1+1;
\g compiler \g compiler
\+f83headerstring
(f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find
for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
if ((UCell)F83NAME_COUNT(f83name1)==u &&
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;
f83name2=f83name1;
:
BEGIN dup WHILE (find-samelen) dup WHILE
>r 2dup r@ cell+ char+ capscomp 0=
IF 2drop r> EXIT THEN
r> @
REPEAT THEN nip nip ;
: (find-samelen) ( u f83name1 -- u f83name2/0 )
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
: capscomp ( c_addr1 u c_addr2 -- n )
swap bounds
?DO dup c@ I c@ <>
IF dup c@ toupper I c@ toupper =
ELSE true THEN WHILE 1+ LOOP drop 0
ELSE c@ toupper I c@ toupper - unloop THEN sgn ;
: sgn ( n -- -1/0/1 )
dup 0= IF EXIT THEN 0< 2* 1+ ;
\-
(listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind (listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind
longname2=listlfind(c_addr, u, longname1); longname2=listlfind(c_addr, u, longname1);
: :
...@@ -1348,6 +1375,12 @@ longname2 = tablelfind(c_addr, u, a_addr); ...@@ -1348,6 +1375,12 @@ longname2 = tablelfind(c_addr, u, a_addr);
IF 2drop r> rdrop EXIT THEN THEN IF 2drop r> rdrop EXIT THEN THEN
rdrop r> rdrop r>
REPEAT nip nip ; REPEAT nip nip ;
: -text ( c_addr1 u c_addr2 -- n )
swap bounds
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0
ELSE c@ I c@ - unloop THEN sgn ;
: sgn ( n -- -1/0/1 )
dup 0= IF EXIT THEN 0< 2* 1+ ;
(hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1 (hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1
""ukey is the hash key for the string c_addr u fitting in ubits bits"" ""ukey is the hash key for the string c_addr u fitting in ubits bits""
...@@ -1367,6 +1400,8 @@ Create rot-values ...@@ -1367,6 +1400,8 @@ Create rot-values
\+ \+
\+
(parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white (parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white
struct Cellpair r=parse_white(c_addr1, u1); struct Cellpair r=parse_white(c_addr1, u1);
c_addr2 = (Char *)(r.n1); c_addr2 = (Char *)(r.n1);
......
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