Further fixes for Gforth EC (1a3e0b2b) · Commits · Bernd Paysan / gforth

arch/4stack/asm.fs

+7 −6

Original line number	Diff line number	Diff line
		@@ -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

		: >ip.b ( -- )
		: >sym ( "symbol" -- addr )
		bl word count sym-lookup? dup 0= abort" No symbol!"
		>body cell+ @ @ 4here 2 cells + - ;
		>body cell+ @ @ ;
		:D
		: >ip.b ( -- )
		>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

+56 −41

Original line number	Diff line number	Diff line
		@@ -410,17 +410,18 @@ 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
		: -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 ;
		: finish-code ;
		: capscomp ( c_addr1 u c_addr2 -- n )
		swap bounds
		?DO dup c@ I c@ <>
		@@ -432,32 +433,46 @@ end-code
		\ x:=a, y:=b, r:=est; iterate(x:=xr, y:=yr, 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

+1 −1

Original line number	Diff line number	Diff line
		@@ -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

+0 −12

Original line number	Diff line number	Diff line
		@@ -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 ;

kernel/basics.fs

+2 −3

Original line number	Diff line number	Diff line
		@@ -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 ;