Skip to content

gforth
gforth
Commit 1a3e0b2b authored by pazsan's avatar pazsan
Browse files
Options

Further fixes for Gforth EC

parent e2d39029
Hide whitespace changes
Inline Side-by-side
Showing with 137 additions and 67 deletions
arch/4stack/asm.fs
View file @ 1a3e0b2b
......@@ -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
1- >r $100 um* #< r> rot 2!
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 ( -- )
bl word count sym-lookup? dup 0= abort" No symbol!"
>body cell+ @ @ 4here 2 cells + - ;
>sym 4here 2 cells + - ;
:A
: .ip.b# ( -- ) >ip.b [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,
:D
Variable procstart
: >p.b ( -- )
bl word count sym-lookup? dup 0= abort" No symbol!"
>body cell+ @ @ procstart @ - ;
>sym procstart @ - ;
:A
: .proc finish? 4here procstart ! ;
: .p ( -- n ) >p.b ;
: .p# ( -- n ) >p.b ;
: .p.b# ( -- ) >p.b [A] # [F] ;
: .p.h# ( -- ) >p.b 2/ [A] # [F] ;
: .p.w# ( -- ) >p.b 2/ 2/ [A] # [F] ;
......
arch/4stack/prim.fs
View file @ 1a3e0b2b
......@@ -410,54 +410,69 @@ end-code
: 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! ;
: finish-code ;
: bye 0 execute ;
: (bye) 0 execute ;
: 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 ;
: 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 ;
dup 0= IF EXIT THEN 0< 2* 1+ ;
: -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 ;
: 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 ;
\ division a/b
\ 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
\ Label idiv-table
\ idiv-tab:
\ .macro .idiv-table [F]
\ $100 $80 DO 0 $100 I 2* 1+ um/mod long, drop LOOP
\ .end-macro
\ .idiv-table
\ end-code
\
\ Code um/mod1 ( u -- 1/u )
\ ;; b -- -- -- -- -- ;;
\ ff1 -$1F # nop nop br 0 :0= div0
\ bfu add 0s0 ip@ nop set 2: R2 ;;
\ ;; b' -- -- -- -- -- ;;
\ lob $0FF ## pick 0s0 pick 0s0 0 # -$108 ## ;;
\ 1 # #, sub #min 1 # ld 0: R2 +s0 #, ;;
\ cm! and nop cm! br 2 ?0= by2
\ ;; est -- -- b' -- -- ;;
\ umul 3s0 pick 0s0 nop umul 0s0 0 # 0 # ;;
\ mulr<@ nop nop -mulr@ ;;
\ drop umul 3s0 nop umul 0s0 ;;
\ mulr<@ cm! nop -mulr@ ;;
\ umul 3s0 drop pick 1s0 drop ;;
\ drop mulr<@ ip! nop 0 # ld 1: R1 N+ ;;
\ pick 1s0 drop nop nop ;;
\ by2:
\ div0:
\ -1 # ip! nop nop 0 # ld 1: R1 N+ ;;
\ nop nop nop nop ;;
\ end-code
Code u/mod ( u1 u2 -- q r )
drop nop pick 0s0 call $43 +IP ;;
pick 1s0 drop nop nop ;;
swap ip! nop nop 0 # ld 1: R1 N+ ;;
nop nop nop nop ;;
.macro .idiv-table [F]
$100 $80 DO 0 $100 I 2* 1+ um/mod long, drop LOOP
.end-macro
approx:
.idiv-table
idiv:
;; a -- b --
nop pick 2s0 ff1 1 # br 1 :0= ;;
ip@ pick 2s0 bfu cm! set 0: R2 ;;
;; a n b' --
nop -$1D # lob pick 2s0 0 # -$104 ## ;;
nop add pick 3s0 drop ld 2: R2 +s0 #, ;;
nop cm! nip nop ;;
;; a n b' r --
umul 2s0 pick 0s0 umul nop ;;
mulr@ 0 # mulr@ -mulr@ ;; first iteration
umul 3s0 pick s2 umul 3s0 drop ;;
mulr@ nop nop -mulr<@ ;; second iteration
umul 3s0 nop nop drop ;;
nop mulr<@ nop nop ;; final iteration+shift
pick 1s0 umul nop nop ;;
nop -mul@+ nop ret br 1 ?0< ;;
nop nip nop nop ;;
.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 ;
arch/misc/mach.fs
View file @ 1a3e0b2b
......@@ -59,7 +59,7 @@ false SetValue xconds \ used together with glocals,
\ local variables
false SetValue header \ save a header information
false SetValue ec
true SetValue ec
false SetValue crlf
true SetValue ITC
false SetValue new-input
......
arch/misc/prim.fs
View file @ 1a3e0b2b
......@@ -830,16 +830,4 @@ include ./optcmove.fs
: (bye) 0 execute ;
: 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 ;
: 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 ;
cross.fs
View file @ 1a3e0b2b
......@@ -1177,7 +1177,7 @@ false DefaultValue new-input
false DefaultValue peephole
false DefaultValue abranch
true DefaultValue f83headerstring
true DefaultValue control-rack
true DefaultValue control-rack
[THEN]
true DefaultValue gforthcross
......
kernel/basics.fs
View file @ 1a3e0b2b
......@@ -62,8 +62,7 @@ hex
\ UNUSED 17may93jaw
has? ec
[IF]
has? ec [IF]
unlock ram-dictionary borders nip lock
AConstant dictionary-end
[ELSE]
......@@ -87,7 +86,7 @@ AConstant dictionary-end
has? ec [IF]
: in-dictionary? ( x -- f )
dictionary-end < ;
dictionary-end u< ;
[ELSE]
: in-dictionary? ( x -- f )
forthstart dictionary-end within ;
......
kernel/getdoers.fs
View file @ 1a3e0b2b
......@@ -58,5 +58,5 @@ doer? :dofield [IF]
true [IF] \ !! don't know what to put here
: dodoes: ( -- addr ) \ gforth
\G The code address of a @code{field}???
['] spaces >code-address ;
['] DOES> >code-address ;
[THEN]
kernel/int.fs
View file @ 1a3e0b2b
......@@ -229,8 +229,13 @@ struct
cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
end-struct wordlist-struct
has? f83headerstring [IF]
: f83find ( addr len wordlist -- nt / false )
wordlist-id @ (f83find) ;
[ELSE]
: f83find ( addr len wordlist -- nt / false )
wordlist-id @ (listlfind) ;
[THEN]
: initvoc ( wid -- )
dup wordlist-map @ hash-method perform ;
......@@ -260,6 +265,13 @@ forth-wordlist current !
\ The constants are defined as 32 bits, but then erased
\ 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
1 bits/char 1 - lshift
-1 cells allot bigendian [IF] c, 0 1 cells 1- times
......@@ -276,6 +288,7 @@ $1fffffff constant lcount-mask
1 bits/char 3 - lshift 1 -
-1 cells allot bigendian [IF] c, -1 1 cells 1- times
[ELSE] -1 1 cells 1- times c, [THEN]
[THEN]
\ higher level parts of find
......@@ -306,6 +319,22 @@ $1fffffff constant lcount-mask
(cfa>int)
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
\g @i{addr count} is the name of the word represented by @i{nt}.
cell+ dup cell+ swap @ lcount-mask and ;
......@@ -320,6 +349,7 @@ $1fffffff constant lcount-mask
IF
swap @ swap
THEN ;
[THEN]
: name>int ( nt -- xt ) \ gforth
\G @i{xt} represents the interpretation semantics of the word
......
kernel/main.fs
View file @ 1a3e0b2b
......@@ -107,8 +107,10 @@ has? compiler [IF]
[THEN]
\ these two games can be added to provide complex examples for the 4stack
\ and misc simulators (see arch/4stack/README and arch/misc/README).
\ include arch/misc/tt.fs
\ include arch/misc/sokoban.fs
has? games [IF]
include arch/misc/tt.fs
include arch/misc/sokoban.fs
[THEN]
[THEN]
include ./quotes.fs
include ./toolsext.fs
......
prim
View file @ 1a3e0b2b
......@@ -1315,6 +1315,33 @@ c_addr2 = c_addr1+1;
\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
longname2=listlfind(c_addr, u, longname1);
:
......@@ -1348,6 +1375,12 @@ longname2 = tablelfind(c_addr, u, a_addr);
IF 2drop r> rdrop EXIT THEN THEN
rdrop r>
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
""ukey is the hash key for the string c_addr u fitting in ubits bits""
......@@ -1367,6 +1400,8 @@ Create rot-values
\+
\+
(parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white
struct Cellpair r=parse_white(c_addr1, u1);
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