2024年9月3日 星期二

一百個例題 (35 ~ 36)

一百個例題 (35 ~ 36)


Ching-Tang Tseng
Hamilton, New Zealand
4 September 2024

第(35)個範例，介紹另一套解決局部變數問題的方法。

大家喜歡使用局部變數之主要目的為何？就是希望到處都能使用同樣的變數名稱來寫程式。

那麼，只要我另有辦法允許您這樣做，何必非用局部變數不可？ 最精簡的設計，就是最好的設計。我熟悉 Forth 系統內部的運作原理，所以能設計得出這樣的處理方法。

此前，所有具有局部變數功能的 Forth 系統，都以安排出一大塊記憶體緩衝區的方式來處理局部變數的值，運轉機制上則需要再設計複雜的局部變數名稱對應關係，才有健全的局部變數運作功能。這樣設計，太複雜了，不用這樣設計。前一個範例中就有這樣的設計，雖只安排 8 個存放單元，也很浪費。很多系統都設計成需要幾 KB 的記憶體容量來放局部變數，實在是太誇張了，更何況局部變數根本就不常用，大可不必如此誇張的強調局部變數。

我設計的方法很簡單，也是古時候 Forth 原始發明人的設計觀念。當時，採用一種被稱為塗污位元(smudge bit)的設定方法來處裡這種事情，一旦某個指令的塗污位元被設定為 1，系統在編譯狀態時，就會對這個指令視若無睹，等於是它不存在，就如同局部變數名稱的要求，前面已用過的名稱，後面若還想再用，就可以再用，系統不會被搞亂。後來若又想用到較舊的名稱時，只要把這個塗污位元設定為 0，狀況就恢復了。但系統會亂掉，因為系統編譯時，可能會先找到最後新的這一個而不是較舊的這一個名稱。塗污位元的觀念用起來確實是很好用，拿來解決局部變數的需求也很理想，問題是這麼一來，系統的編譯速度必然變慢，因為編譯過程內就必須將識別塗污位元內容之事包括進去，而且對每個被編譯的指令都需要進行識別。為此，後來的 Forth 系統，取消了這種會令編譯速度變慢的工作，不再採用讓所有指令都具有塗污位元的設計。

我的作法很簡單，想要讓指令局部化時，就把該指令的名稱從此之後在編譯搜尋過程中永久剔除，剔除單一個時，用局部化(localize)指令，剔除多個時，用局部化複數(localizes，不是正式英文)指令，這個範例中有它們的直接用法，以及精簡的測試程式，保證系統絕對不會搞亂。兩個測試指令都使用三個相同的變數名稱 i , a , b 。跑起來則是各跑各的。

我已將兩個關鍵指令固定的納入系統，所以您重新載入此範例程式時，系統會出現指令用名重複的警告，但不影響運作。其中局部變數觀念上的哲理，請自行體會。
:

 
\ (35)萬用局部變數.f
\ postfix style local variables

: EraseName ( cfa -- )
  dup ['] empty u<
  if cr abort" is a system word can not to be localize!" then
  >name dup c@ 1+ 0 fill ;

: localize ( -- )
  [compile] ' EraseName ;

localize EraseName  

: localizes ( n -- )
  0 ?do localize loop ;

\ *************************************
4 integers i a b c

: tt1 basic
10 let a = 1 :: b = 2 :: c = 3
20 for i = 1 to 2
30 print a , b , c
40 next i
50 end ;

localize i
2 localizes a b

\ *************************************

3 integers i a b

: tt2 basic
10 let a = 7 :: b = 8
20 for i = 1 to 3
30 run tt1
40 print a , b , c
50 next i
60 end ;

第(36)個範例是一個大數四則運算的設計範例程式。很不幸，這個程式已經無法執行，展示失效的範例程式，可以告訴大家發展 Forth 系統時必須考慮那些問題。

我在 XP 作業系統流行的年代，就收集到了這個程式，它只能使用商售系統 iForth 來執行，這個系統要花 100 歐元才買得到，推出當時，還有試用版可以下載來用。後來，因為這種系統無法適應於各種軟硬體雜處的環境，系統提供人，為了必須修改出許多不同的安裝設定，煩不勝煩，搞到後來，乾脆取消免費提供給大家的試用版，就沒下文了。

我在 XP 電腦上，曾下載過可用的試用版 iForth 系統，能跑這個程式，但最好不要跑，因為一旦跑起來，系統就會透過我的 Outlook 私人信箱，自動傳送訊息上網，到 iForth 系統的德國發行地去，而且信箱還不能關閉，等於是線上一直開著信箱，以與該公司聯絡中的方式執行系統，才能使用。當年，上網時間是要計費的，我一天就把整個月可用的 20 小時上網限制時間用完了，真是不可理喻。從那次事件以後，我就不敢再用免費的 iForth 系統，我的 XP ，也得重新安裝，信箱才能歸原到不受 iForth 系統公司控制的狀態。這件事情，我在個人網頁中貼文披露過。

我有能力把這個大數程式改寫成其他 Forth 系統能跑得起來的程式，問題在值不值得。我看得懂程式中大部分指令都在幹什麼，也能搞得出欠缺指令時大致的追加設計方法，想做完此事，卻必須耗費大量的時間，除非我沒有這種系統可用，否則我不願浪費時間做這件事情。

留下這個程式當範例的主要目的，是把它當對照來體會 iForth 的指令與一般 Forth 系統的指令有何不同？

我的 XP 原裝硬碟已經壞了，好幾年前，台灣的朋友鄧淵元送過我舊的回收品，我重裝了 XP 系統，維持萬一需要時還能使用，但原已安裝的試用版 iForth 系統已經不見了，想找出此系統的舊有資源已不可能，若要修改這個範例就必須用到。

取這種程式當範例，具有另種重要意義。就像科學論文，以實驗證明是失敗的結論，可以讓後人少走冤枉的路。我只對這個範例中的程式寫法做簡介：

在程式前面，有一列編譯命令：

NEEDS -miscutil

意思是這個程式必須先行載入 iForth 系統作者 Marcel Hendrix 於 November 17, 1991 以前設計的專用雜項應用(miscellaneous utilities)指令收集檔案。 1994 年以後發行的 Forth 系統內，通常都附有這種檔案， Win32Forth 系統內也有，檔案都很大。系統就是因為彼此不能共容才需要加載這種檔案，這個檔案自身當然就更不能與別的系統共容了。

在 iForth 中，好幾列的註解時，使用(* ----- *) 來包括。
在一般 Forth 中，使用 (( ----- ))來包括。

在 iForth 中的單列註解，使用兩個減號『 -- 』作開頭。
在 Win32Forth 中，使用單個背斜線『 \ 』作起首。

在 iForth 中把很多指令當字串處理出後造先用的設計格式時，使用 EVAL” ----- “ 的方式來設計。
在 Win32Forth 中，使用 S” ----- “ EVALUATE 來設計。

在 iForth 中，局部變數的宣告格式是一個一個的宣告，如：
LOCAL x
LOCAL y
LOCAL z
在 Win32Forth 中，使用一列就能包括所有局部變數的方式來宣告，如： LOCALS| x y z |

還有許多其他不常用的指令， iForth 的使用格式都與一般 Forth 系統不同，我就不再詳細解釋。

至於大數四則運算程式方面，公開場合能順利下載的公益資源有三個，除這個範例外，另有一個瑞典作者 Lehs 貢獻的公益程式，第三個就是 Forth 科學程式庫(FSL)於 1996年由 Leonard Francis Zettel. Jr. 貢獻之品質最佳的公益程式。這三套大數計算程式都各有特點，我都下載控存，簡單介紹一下它們在系統規劃上的不同點：

iForth 的這個範例，是將大數當字串來就地處理(deal with it in site)，幾位數就用幾個位元組來存數字之字，不存數字之值。原能存 16 個值的一個位元組，只能存 10 個字的數。此程式設定的宣告上限是 1500 個字，也就是 1500 位數。

瑞典的 Lehs 捐獻的系統，則利用作業系統能配置出 Forth 系統外部另開檔案的記憶體，供作大數計算時所需的記憶體緩衝區，因此，這種用法不能用在獨立封閉式的 Forth 系統內，而且，隨作業系統的不同，如果 Forth 系統內沒有設計 ALLOCATE 額外配置系統外之記憶體的指令，這個程式就不能使用。

FSL 提供的大數計算程式，最為完整，我的系統就只採用這一套公益程式。但，系統把大數計算處理成不斷地耗用從 HERE 開始以上之系統的空置區記憶體來放暫態計算數字，所以，直接應用時，系統會一直耗掉大量的記憶體。我應用時，利用先控存起始點記憶體位址的技巧來搶回被耗掉的記憶體，因此，只有單次的大數計算會涉及記憶體夠不夠用的問題，下次再算就可以又是一條好漢，不怕暫態耗用。不管怎麼說，我完成了這樣的設計，給各位的系統，就是證明。

現在幾乎所有的程式語言都提供大數計算功能了，我在 Perl , Python 以及許多套裝軟體內都跑過，網上也有很多網頁，直接讓您使用大數計算得到答案。

我設計之系統內的大數計算功能與別人不同的地方，是大數計算能『程式化』，也就是能寫大數計算的程式。如果沒有源程式，或只是呼叫 C 的程式庫來達到目的，就無法為所有的 Forth 系統加裝大數計算能程式化的功能。

這個範例比較淺顯，算法很容易了解，加減法不用解釋，乘法用的是 Knuth formula ，別處很難找到，但很容易看懂，也到處被人使用，沒這個程式，就得自己去看長文。

除法，更有意思，我用實際簡單數字解釋從最高位數開始，獲得商與餘數的方法，就能對應到註釋說明：例如您算一個 177xxxxxxx 很多位數的被除數，除以一個 4xxxxxx 也是很多位數的除數，得商的方法，就是只用單整數，乘上除數，看看到多少後會超過被除數？如 4 乘上 5 得 20 就會超過 17，因此，第一個商的最高位數，就是 4。接著， 17 減 4 乘以 4 為減掉 16 得 1 ，再與下一位數 7 形成下一個被除數，再除以仍只是單整數的 4 測試新的次位數商，結果，仍得 4。依此類推，就能只用單整數的簡單乘法測試運算來得到大數計算的除法結果。這個方法比一般靠移位很多位數然後相減得結果商數的方法必定要快很多，程序是用英文寫的，很清楚。
:

 
\ (36) iForth版大數四則運算程式

(*
 * LANGUAGE    : ANS Forth
 * PROJECT     : Forth Environments
 * DESCRIPTION : Big number package
 * CATEGORY    : Utility
 * AUTHOR      : Marcel Hendrix November 17, 1991
 * LAST CHANGE : October 10th, MHX: some old names updated. Retested (some).
 * LAST CHANGE : Jan 5th, 1992, MHX : bugs in .VNUM if remainder = 0 (?)
 * LAST CHANGE : November 18, 1991, Ideas of Albert van der Horst: I/O.
 * LAST CHANGE : November 10, 1991, Ideas of Albert van der Horst: Vsqrt.
 * LAST CHANGE : November 2, 1991, Marcel Hendrix, changed order
 * LAST CHANGE : AH 911231: assembler codes/macros cleanup
 * LAST CHANGE : November 18, 1991, Marcel Hendrix
 * LAST CHANGE : March 18, 2001, Marcel Hendrix, adapted to iForth 1.11e. NEEDS TESTING
 * LAST CHANGE : March 24, 2001, Marcel Hendrix, removed bugs in .VNUM V<< and V>> , removed UM-
 *)




	NEEDS -miscutil

        REVISION -bignum "?? BigNumber Toolkit   Version 2.00 ??"

	PRIVATES




DOC BIGNUM
(*
 A bignum is like an ARRAY, but the parameter field is allocated dynamically,
 so we have to keep pointers to it. Furthermore, the digit string does NOT
 start at the beginning of the allocated area, but is right-aligned.
 Carefully note that a `digit' takes a full cell!

 In the administration field of a BIGNUM the following can be found:

  offset (cells)     comment
 --------------------------------------------------------------------
	0	     the maximum string size in bytes
	1	     pointer to the first digit of the number string
	2	     pointer to the last digit of the number string
	3	     the start address of the allocated area

 BIGNUM BODY : [#size][^head][^tail][^begin]
			 |	  |	|
	  +-----------------------------+
	  |		 |	  |		
	  |		 |	  +---------------------+
	  |		 |				|
	  v		 v				v
	  [ ][ ][ ][ ][ ][ ][ ][ ][*][ ][ ... ][*][ ][ ][ ]
 	                  0  1  2  3  4   ...   -3 -2 -1 0
	  <-------------------[ size ]-------------------->

In the algorithms needed to process bignums, it is convenient to be able
to address relative to both the head and the tail of the digit string.
This can be accomplished using the TO concept and three additional modifiers;
#DIGITS, HEAD and TAIL .

   { 3 TO  4 HEAD number }	means:  3  head_of_number @  4 CELLS +  !
   { CLEAR  6 TAIL number }	means:  tail_of_number @  6 CELLS -  0!
   { 'OF number }		means:  begin_of_number
   { 1 +TO #DIGITS number }	means:  -1 head_of_number +! 
*)
ENDDOC


				-- Utility --



-- Normalize a number, how many left shifts are needed to make the msb = '1'
: FRONT.ZEROES	     ( n -- 31-log2 )
	#31 -1 ROT   ( log2 n)
	DUP $FFFF0000 AND IF  #16  UNDER+ #16 RSHIFT   ENDIF
	DUP $0000FF00 AND IF    8  UNDER+   8 RSHIFT   ENDIF
	DUP $000000F0 AND IF    4  UNDER+   4 RSHIFT   ENDIF
	DUP $0000000C AND IF    2  UNDER+   2 RSHIFT   ENDIF
	DUP $00000002 AND IF    1  UNDER+   1 RSHIFT   ENDIF
	1 AND + - ;  ( log2)

: '[]		6 %VAR ! ; IMMEDIATE		\ same as ADDR (arrays.frt)
: 'LASTOF	7 %VAR ! ; IMMEDIATE		\ address of last element

: HEAD		%VAR @  $10 +  %VAR ! ; IMMEDIATE
: TAIL		%VAR @  $20 +  %VAR ! ; IMMEDIATE

-- The #DIGITS modifier is used to manipulate a BIGNUM's head pointer

: #DIGITS	%VAR @  $30 +  %VAR ! ; IMMEDIATE



: ADMIN,	SWAP []CELL   ALITERAL ; PRIVATE \   --- 
: ADMIN@,	SWAP []CELL @ ALITERAL ; PRIVATE \   --- 

: NEG-2-ADMIN,	>S ['] NEGATE NOW? 		\  --- <>
		S> 2 ADMIN, ; PRIVATE

: SIZE@		EVAL" CELL+ 2@ - #CELLS 1+ " ;	\ <'admie> --- <#elements>
		IMMEDIATE

: SIZE+!	SWAP CELLS SWAP CELL+ -! ;	\  <'admie> --- <>

: SIZE!		2 CELLS + @- CELL+ 		\  <'admie> --- <>
		ROT CELLS -  SWAP ! ;

-- Note that 'HEAD@ etc. should not be stored as pointers: some
-- routines change the size and/or location of a BIGNUM ( see REPACK )
: 'HEAD@  	\ <'admie> --- <'head>
		EVAL" CELL+ @ " ; IMMEDIATE

: 'TAIL@	\ <'admie> --- <'tail>
		EVAL" 2 SWAP []CELL @ " ; IMMEDIATE

: []TAIL  	\  <'admie> --- 
		EVAL" 'TAIL@ SWAP NEGATE SWAP []CELL " ; IMMEDIATE

: []HEAD  	\  <'admie> --- 
		EVAL" 'HEAD@ []CELL " ; IMMEDIATE

: CLEAR-BIGNUM	>S				\ <'adm> --- <>
		3 S []CELL @ 			\ 'OF number  
		S @ ERASE			\ SIZEOF number
		2 S []CELL @ CELL+		\ 'LASTOF number + 1
		S>  CELL+ ! ; 			\ adjust HEAD of number 


: VVmove	>S   DUP @ >R			\ <'bignum1> <'bignum2> --- <>
		3 OVER []CELL @	  3 S []CELL @	\ 'OF_1  'OF_2
		R> S @ <> ABORT" source and destination differ in length"
		S @ MOVE			\ size_2 move
		>S
		2 T  []CELL @ 			\ 'last1 + 1 
		1 S> []CELL 2@ -  -		\ - ( elements1 + 1)
		1 S> []CELL ! ; 		\ store in head2


	-- Note the sometimes subtle differences between an ARRAY and
	-- a BIGNUM  ( /OF number  is not a constant)

: 	CELLS DUP , 			\  --- <>
		DUP ALLOCATE ?ALLOCATE ( count addr)
		2DUP + DUP ( head) ,  CELL- ( tail) , 
		DUP ( begin address) ,	
		SWAP ERASE ;

: BIGNUM			  	 	\  BIGNUM ##
	CREATE	IMMEDIATE  
		
	FORGET>	DUP  3 CELLS + @ FREE
		SWAP 4 CELLS ERASE 
		?ALLOCATE
	DOES>	%VAR @  0 %VAR !  \ without HEAD or TAIL : access head or tail
		CASE 
\	       ( +to)	 -1 OF ALITERAL ['] +BIGNUM       NOW?	ENDOF
	       ( from)	  0 OF ALITERAL			 	ENDOF
	       ( to)	  1 OF ALITERAL ['] VVmove        NOW?	ENDOF
	       ( clear)	  2 OF ALITERAL ['] CLEAR-BIGNUM  NOW?	ENDOF
	       ( 'of)	  3 OF 3 ADMIN@,	  		ENDOF
	       ( sizeof)  4 OF @ ILITERAL		  	ENDOF
	       ( /of)	  5 OF 1 ADMIN, EVAL" 2@ - #CELLS 1+ "	ENDOF
\	       ( '[])     6 OF 			  		ENDOF
	       ( 'last)   7 OF 2 ADMIN@,			ENDOF

	       ( +h)    #15 OF 1 ADMIN, EVAL" @ []CELL +! "	ENDOF
	       ( h@)    #16 OF 1 ADMIN, EVAL" @ []CELL @ " 	ENDOF
	       ( h!)    #17 OF 1 ADMIN, EVAL" @ []CELL ! "	ENDOF
	       ( h0!)   #18 OF 1 ADMIN, EVAL" @ []CELL OFF "	ENDOF
	       ( h'[])  #22 OF 1 ADMIN, EVAL" @ []CELL "	ENDOF

	       ( +t)    #31 OF NEG-2-ADMIN, EVAL" @ []CELL +! "	ENDOF
	       ( t@)    #32 OF NEG-2-ADMIN, EVAL" @ []CELL @ " 	ENDOF
	       ( t!)    #33 OF NEG-2-ADMIN, EVAL" @ []CELL ! " 	ENDOF
	       ( t0!)   #34 OF NEG-2-ADMIN, EVAL" @ []CELL 0! "	ENDOF
	       ( t'[])  #38 OF NEG-2-ADMIN, EVAL" @ []CELL "	ENDOF
	
	       ( +to)	#47 OF 1 ADMIN, EVAL" >S CELLS S> -! " 	ENDOF
	       ( from)	#48 OF 1 ADMIN, EVAL" 2@ - #CELLS 1+ "	ENDOF
	       ( to)	#49 OF ALITERAL ['] SIZE! NOW? 		ENDOF
	       ( clear)	#50 OF 2 ADMIN, EVAL" @- CELL+ SWAP ! "	ENDOF
	       ( 'of)	#51 OF 1 ADMIN,		 	 	ENDOF
\	       ( szeof) #52 OF DROP 1 ILITERAL			ENDOF
\	       ( /of)	#53 OF DROP 1 ILITERAL			ENDOF
\	       ( '[])   #54 OF 1 ADMIN,		  		ENDOF
	       ( 'last) #55 OF 2 ADMIN@,			ENDOF

			DUP ABORT" BIGNUM: undefined message"
		ENDCASE  ;


: REPACK				\ <'admin> --- <>
	LOCAL num
	BEGIN				\ throw away leading zeros.
	  num SIZE@ 0<> 		\ still digits?
	  num 'HEAD@ @ 0= AND		\ ..and leading 0?
	WHILE
	  -1 num SIZE+!			\ throw away.
	REPEAT ; 


=CELL 8 * =: BITS/CELL
    #1500 =: MAX.DIGITS	 		-- superdigits!




DOC Big number manipulations.
(*
     In the following, "V" means the address of a Vnum, "u" is an unsigned 
     single precision Forth number.

     Stack diagram ( V u -- )
     VS-          subtract u from V (in place)
     VS+          add u to V (in place)
     VS*          multiply V with u (in place)

     Stack diagram ( V u1 -- u2 )
     VS/MOD       as /MOD , quotient in V, remainder in u2

     Stack diagram ( V -- )
     VSqrt        Calculate the largest number whose square is smaller
                  than V, put it in SS.

     Stack diagram ( V1 V2 -- )
     VVmove       copy V1 to V2
     VV-          subtract V2 from V1 (in place)
     VV+          add V2 to V1 (in place)
     VV*          multiply V1 and V2, result to PP
     VV/MOD       as /MOD , quotient in QQ, remainder in RR
     VGCD         greatest common divisor of V1 and V2, result in SS

     Most are straightforward.

     VV* benefits from the formula : (Knuth part 3 pg. 278)
     ( 2?*u1+u0)*(2?*v1+v0) =
     ( 2?+2?)*u1*v1 + 2?*(u1-u0)*(v1-v0) + (2?+1)*u0*v0.
     (saves 1 out of 4 multiplications)

     VV/MOD can be implemented as a normal tail division, i.e. find
     a single precision multiplier D for V2 such that subtracting D*V2
     from the front of V1 makes it first cell zero, so D is the first
     cell of the quotient.
     Contrary to the expectation, this is about the best you can do.

     VGCD can be implemented using VV/MOD but an add and shift algorithm
     is probably faster.
*)
ENDDOC


-- Returns the number of the MSB (32..1), in the number U.

: SCOUNT-BITS				\  -- 
  DUP 0= IF EXIT ENDIF			\ infinite loop
  0 BEGIN  1+ 
	   SWAP 1 RSHIFT DUP
    WHILE  SWAP 
    REPEAT
  DROP ;


-- Returns the number of bits in the Vnumber V

: VCOUNT-BITS     			\  --- 
  >S S SIZE@ DUP
	IF 1- BITS/CELL *
	   S> 'HEAD@ @  SCOUNT-BITS + 	\ Get first cell
      ELSE -S
     ENDIF ;



-- Add u to V in place. No bounds check; if carry -> 1 digit longer.
-- We assume the least significant digit is at the highest memory address.
-- V is assumed positive.

: VS+		LOCAL carry			\   --- <>   
		LOCAL V
		V 'TAIL@  
		V SIZE@ 0 ?DO 
			      @-  carry UM+ TO carry
			      OVER CELL+ !
			 LOOP 	
		carry ?DUP IF SWAP !  1 V SIZE+!  EXIT
			ENDIF
		DROP ;


-- Subtract u from V in place. The number may become 1 digit shorter.

: (VS-)		  LOCAL u			\   ---    
		0 LOCAL borrow
		  LOCAL V
		V 'TAIL@  
		V SIZE@ 0 ?DO 
			      @- borrow SWAP u UM- TO borrow
			      OVER CELL+ !
			      CLEAR u
			 LOOP 
		CELL+ @ 0= IF  -1 V SIZE+!  ENDIF
		borrow ;


: VS-		(VS-) IF CR ." VS- : Overflow " \   --- 
		  ENDIF ;



-- Test if the Vnumber is 0.

: VS0= 		SIZE@ 0= ;			\  --- 


-- store n in BIGNUM

: V! 		DUP CLEAR-BIGNUM  		\   --- <> 
		SWAP VS+ ; 


-- VS= compares the Vnumber with a single i

: VS= 						\   --- 
		?DUP IF SWAP >S
			S SIZE@ 1 =		\ Length = 1 ?
			SWAP S> 'TAIL@ @ =	\ Content ok ?
			AND
		   ELSE VS0=
		  ENDIF ;


-- multiply V with u in place. The length of the result can be zero, equal, or
-- 1 digit larger.

: VS*		DUP 0= IF DROP CLEAR-BIGNUM 	\   --- <>
			  EXIT 
		    ENDIF
		  LOCAL u
		0 LOCAL carry
		  LOCAL V
		V 'TAIL@
		V SIZE@ 0 ?DO 
			      @- u UM* 
			      carry U>D D+ TO carry
			      OVER CELL+ !
			 LOOP 
		carry ?DUP IF  SWAP !  1 V SIZE+!  EXIT
		        ENDIF
		DROP ;


-- as MOD, remainder in u2, V untouched

: VSMOD         OVER SIZE@ 0=  OVER 0= OR	\   -- 
                IF 2DROP 0 EXIT ENDIF		\ already zero or div by 0?
                0 LOCAL carry
                  LOCAL u1
                  LOCAL V
                V 'HEAD@			\ '(latest digit)
                V SIZE@ FOR
                           AFT
                             @- carry u1  UM/MOD 
			     DROP TO carry
                          THEN
                       NEXT
                DROP
                carry ;


-- as /MOD , quotient in V, remainder in u2. 1 <= New length of V <= old len.

: VS/MOD	OVER SIZE@ 0=  OVER 0= OR	\   ---   
		IF 2DROP 0 EXIT ENDIF		\ already zero or div by 0?
		0 LOCAL carry
		  LOCAL u1
		  LOCAL V
		V 'HEAD@			\ '(latest digit)
		V SIZE@ FOR  
			     AFT
				@+ carry  u1 UM/MOD 
				SWAP TO carry
				OVER CELL- !
			    THEN 
		       NEXT DROP
		V REPACK carry ;


-- Give a Vnum at least u digits by extending it with zeros.
-- Count is adjusted!

: Vextend	SWAP LOCAL V			\   --- <>
		V SIZE@ - 0 MAX
		0 ?DO 
		      1 V SIZE+!
		      0 V 'HEAD@ !
		 LOOP ;


-- Shift a Vnum up over u bit positions. ( u <= bits/word)

: [V<<]		0 LOCAL carry	 		\   --- <>
		  LOCAL places
		  LOCAL V
		V 'TAIL@
		V SIZE@
		0 ?DO 
		      @- U>D  places DLSHIFT  carry U>D D+  TO carry
		      OVER CELL+ !
		 LOOP 
		carry IF carry SWAP !  
			 1 V SIZE+! EXIT 
		   ENDIF 
		DROP ;

-- Shift a Vnum up over u bit positions.
: V<< ( V u -- )
		BITS/CELL /MOD LOCALS| n1 n2 V |
		V n2 [V<<]
		n1 0 ?DO V BITS/CELL [V<<] LOOP ;

-- Shift a Vnum down over u bit positions. ( u <= bits/word)

: [V>>]		0 LOCAL carry 			\   --- <>
		  LOCAL places
		  LOCAL V
		V 'HEAD@
		V SIZE@
		0 ?DO 
		      @+ 0 SWAP  places DRSHIFT  0 carry D+  SWAP TO carry
		      OVER CELL- !
		 LOOP DROP
		V REPACK ;

: V>> ( V u -- )
		BITS/CELL /MOD LOCALS| n1 n2 V |
		V n2 [V>>]
		n1 0 ?DO V BITS/CELL [V>>] LOOP ;

-- Convert Vnum to binary `exponent, mantissa format', where the maximum 
-- exponent is 32 (cell width in bits).

: VNORMALIZE	  LOCAL V			\  --- 
		V SIZE@ 0= IF 0 EXIT ENDIF
		V 'HEAD@ @ FRONT.ZEROES 	\ highest word
		V OVER V<< ;
		

-- Convert `exponent, mantissa format' to Vnum

: VUNNORMALIZE	V>> ;	 			\   --- <>
		

-- Add V2 to V1 in place. V1 may grow to max(V1,V2)+1.

: VV+ 		        0 LOCAL carry		\   --- <> 
		          LOCAL V2
		          LOCAL V1
		V1 V2 SIZE@  Vextend		\ give them the same length
		V2 V1 SIZE@  Vextend
		V1 'TAIL@ LOCAL p1
		V2 'TAIL@ LOCAL p2
		V2 SIZE@
		  0 ?DO 
			p1 @- SWAP TO p1 
			p2 @- SWAP TO p2
			UM+  carry U>D D+  TO carry
			p1 CELL+ !
		   LOOP 
		V2 REPACK			\ reset length of V2
		carry ?DUP IF p1 !  
			      1 V1 SIZE+!  EXIT
			ENDIF ;


-- Subtract V2 from V1 in place. V2 is not modified. 0 <= Length V1 <= V1

: (VV-)		        0 LOCAL borrow		\   ---  
		          LOCAL V2
		          LOCAL V1
		V1 V2 SIZE@  Vextend		\ give them the same length
		V2 V1 SIZE@  Vextend
		V1 'TAIL@ LOCAL p1
		V2 'TAIL@ LOCAL p2
		V2 SIZE@
		  0 ?DO 
			borrow
			p1 @- SWAP TO p1
			p2 @- SWAP TO p2  
			UM- TO borrow  p1 CELL+ !
		   LOOP 
		V2 REPACK			\ reset length of V2
		V1 REPACK 
		borrow ;


: VV-		(VV-) IF CR ." VV- : overflow "	\   --- <> 
		   ENDIF ;



-- Scratch and input/output variables.

	MAX.DIGITS BIGNUM PP
	MAX.DIGITS BIGNUM QQ
	MAX.DIGITS BIGNUM RR
	MAX.DIGITS BIGNUM SS


-- multiply V1 and V2, result to PP.
-- See: `The Art of Computer Programming' Second Edition, Volume 2,  
-- Seminumerical Algorithms,  D. E. Knuth. 
-- Algorithm M, pp 253-254. 


: VV*      	     PP LOCAL w	 		\   --- <> 
		        LOCAL v 
		v SIZE@ LOCAL m
		        LOCAL u 
		u SIZE@ LOCAL n
		m 0=  n 0= OR IF EXIT ENDIF
( M1. )		w  CLEAR-BIGNUM 
		w  m n +  Vextend 
		      0 LOCAL carry
		m 0 DO  I v []TAIL @
( M2. )			   0= IF 0  
( M3. )			    ELSE CLEAR carry
( M4. )				 n 0 DO
					I u []TAIL @  
					J v []TAIL @  UM*
					I J + w []TAIL >S  S @ U>D  D+  
					carry U>D D+  TO carry  S> !
( M5. )				   LOOP
				 carry  
			   ENDIF 
( M6. )			I n + w []TAIL !
		  LOOP	
		w REPACK ;




-- Like /MOD . Quotient in QQ, remainder in RR.
-- Knuth's Algorithm D.

-- U should have at least two digits, u is the size of the largest of the 
-- strings at a1 and a2. (The other one needs leading zeroes).
-- Note that dst and src point to the FIRST digit of superdigit strings!

: MUL&SUB	    LOCAL qhat		\    <*> --- 
		ROT LOCAL 'dest
		  0 LOCAL carry
		  0 LOCAL borrow
		>S S CELLS DUP +TO 'dest 
		   CELL- + ( src)  S> ( u)
		0 ?DO
		      @- qhat UM*  carry U>D D+ TO carry
		      borrow 'dest @ ROT UM- TO borrow	'dest !
		      [ =CELL NEGATE ] LITERAL +TO 'dest
		 LOOP DROP
		borrow 'dest @ carry UM- SWAP 'dest !
		( Leaves borrow ) ; PRIVATE


-- Note that a1 and a2 point to the FIRST digit of superdigit strings!
-- Note that the carry must be added at the last step!

: ADDBACK	ROT LOCAL 'dest			\    --- <>
		  0 LOCAL carry
		>S S CELLS DUP +TO 'dest  
		   CELL- + ( src)  S> ( u)
		0 ?DO
		     @- 'dest @ UM+  carry U>D D+ TO carry
		     'dest !
		     [ =CELL NEGATE ] LITERAL +TO 'dest
		 LOOP DROP 
		carry 'dest +! ; PRIVATE	\ This ripples .. but cancels



-- VV/MOD has already removed trivial or cumbersome cases.

WARNING @ WARNING OFF

MAX.DIGITS BIGNUM U	PRIVATE
MAX.DIGITS BIGNUM V	PRIVATE

: (VV/MOD)	TO V   TO U				\   --- <>
		0 LOCAL qhat  0 LOCAL rhat  /OF V LOCAL n
		/OF U  n - 1+ LOCAL m+1  
		CLEAR QQ  QQ m+1 Vextend
		V VNORMALIZE LOCAL exp			\ normalize V
		0 HEAD V  LOCAL V1  1 HEAD V LOCAL V2	\ highest digits of V
( D1. )		U  /OF U 1+  Vextend    U exp V<<	\ normalize U
( D2. )		m+1 0 ?DO
( D3. )			 I HEAD U  V1 = 
			    IF -1 TO qhat
			  ELSE I 1+ HEAD U  I HEAD U  V1 UM/MOD TO qhat TO rhat
			 ENDIF
			 BEGIN  I 2+ HEAD U  rhat   	\ remainder*b + Uj+2
				V2 qhat UM*  
				DU<
			 WHILE  -1 +TO qhat   
				V1 rhat UM+ SWAP TO rhat 
			 UNTIL ( overflow) THEN 	
( D4. )			 I '[] HEAD U  0 '[] HEAD V  n  qhat  MUL&SUB ( borrow)
( D5. )		         qhat TO I HEAD QQ
( D6. )			    IF -1 +TO I HEAD QQ
			       I '[] HEAD U  0 '[] HEAD V  n  ADDBACK
			 ENDIF
( D7. )		     LOOP
( D8. )		U TO RR   n TO #DIGITS RR  		\ lower n digs of Un+m
		RR exp VUNNORMALIZE  
		QQ REPACK  RR REPACK ; PRIVATE

		

: VV/MOD	DUP SIZE@ 0=	 		\   --- <> 
		   IF 2DROP 			\ packed v must have at least
		      CLEAR QQ  CLEAR RR 	\ _two_ superdigits.
		      EXIT 
		ENDIF
		DUP SIZE@ 1 = 			\ if size is 1, use VS/MOD
		   IF CLEAR RR
		      SWAP TO QQ
		      QQ  SWAP 'HEAD@ @  VS/MOD
		      ?DUP IF RR SWAP VS+ 
			ENDIF
		      EXIT
		ENDIF
		OVER SIZE@  OVER SIZE@ 		\ if U < V we already know.
		 < IF DROP CLEAR QQ  TO RR 
		      EXIT	
		ENDIF
		(VV/MOD) ;

WARNING !


-- Greatest common divisor of U and V, result in SS
--   A1. v = 0 => u is answer
--   A2. r <- u mod v, u <- v, v <- r, loop to A1.

: VGCD		PP VVmove		\   -- <>
		SS VVmove
	BEGIN	PP SIZE@
	WHILE	SS PP VV/MOD		\ RR = remainder
		PP TO SS		\ u <- v
		RR TO PP 		\ v <- (u mod v)_old
	REPEAT	;



-- Is V1 equal to V2 ?

: VV=		>S DUP 'HEAD@ SWAP SIZE@ CELLS	\   ---  
		S> DUP 'HEAD@ SWAP SIZE@ CELLS
		COMPARE 0= ;

-- Is V1 less than V2 ?

: VV<		OVER SIZE@ OVER SIZE@ 		\   --- 
		2DUP < IF  2DROP 2DROP TRUE  EXIT  ENDIF
		     > IF        2DROP FALSE EXIT  ENDIF
		FALSE LOCAL less?
		'HEAD@ >S  DUP 'HEAD@ 
		SWAP SIZE@ 0 ?DO 
				@+ S> @+ SWAP >S
				2DUP <> IF  U< IF TRUE TO less? ENDIF
					    LEAVE
				      ELSE  2DROP
				     ENDIF
			    LOOP DROP -S
		less? ;


-- Calculate the largest number whose square is smaller than V, put it 
-- in SS. We use Newton-Raphson : sqrt(v) = lim n->? An+1=(An+v/An)/2

: VSqrt 	LOCAL V		 		\  --- <> 
		V TO SS  V VS0= IF EXIT ENDIF
		SS DUP VCOUNT-BITS 1- 2/ V>>	\ Use l.s. half of the bits
		V SIZE@ BITS/CELL *		\ bits per word = Too much!
		  0 ?DO  
			V SS VV/MOD 
			QQ SS VV+  
			QQ 1 V>> QQ REPACK
			QQ SS VV= IF LEAVE THEN
			QQ TO SS
		   LOOP ;


MAX.DIGITS BIGNUM IOscratch PRIVATE

: n-Group ( I n -- ) 
	LOCAL n
	U>D <#  n 0 ?DO  3 0 ?DO # LOOP ',' HOLD  LOOP  #> TYPE ; PRIVATE

-- Auxiliary routine for .VNUM
-- Uses the stack for reversing the order of digits (here a digit=10^9)

: x^n ( x n -- x^n ) 1 SWAP 0 ?DO OVER * LOOP NIP ; PRIVATE

: (.VNUM)  RECURSIVE
	BASE @ 3 x^n  DUP 3 x^n LOCALS| b10^9 b10^3 |
	/OF IOscratch 
	1 = IF	0 TAIL IOscratch  
		b10^3 U>= IF IOscratch b10^3 VS/MOD
		      	     (.VNUM) 1 n-Group
		  	ELSE 0 TAIL IOscratch 
		       	     U>D <# #S #> TYPE
		       ENDIF EXIT
 	 ENDIF
	IOscratch b10^9 VS/MOD (.VNUM) 3 n-Group ; PRIVATE


: .VNUM  ( VV -- )
	BASE @ >R DECIMAL
	DUP REPACK
	DUP SIZE@ 0= IF DROP ." 0"
	           ELSE TO IOscratch (.VNUM)
	          ENDIF 
	R> BASE ! ;


-- VREAD works for any BASE

: VREAD  ( VV -- )
	CLEAR IOscratch
	BL WORD COUNT 
	0 ?DO
	      C@+ BASE @ DIGIT? 0= ABORT" Strange character in number"
	      IOscratch BASE @ VS*
	      IOscratch SWAP VS+
	 LOOP 
	DROP
	IOscratch SWAP VVmove ;


:ABOUT
CR ."   In the following, `V' means the address of a Vnum,"
CR ."   `u' is an unsigned single precision Forth number."
CR
CR ."   Stack diagram ( V u -- )"
CR
CR ."     VS-          subtract u from V (in place)"
CR ."     VS+          add u to V (in place)"
CR ."     VS*          multiply V with u (in place)"
CR ."     Vextend      add leading zeroes, ensuring V has at least u digits."
CR
CR ."   Miscellaneous operators"
CR
CR ."     V!           ( u V -- )     Store u in V"
CR ."     VS/MOD       ( V u1 -- u2 ) as /MOD , quotient in V, remainder in u2"
CR ."     VS0=         ( V -- bool )  test if V is equal to zero."
CR ."     V<<          ( V +n -- )    shift V left over +n bit positions."
CR ."     V>>          ( V +n -- )    shift V right over +n bit positions."
CR ."     VUNNORMALIZE ( V +n -- )    exponent, mantissa format to Vnum. (*)"
CR ."     VNORMALIZE   ( V -- +n )    Vnum to exponent, mantissa format."
CR 
CR ."   (*) The maximum exponent is equal to the number of bits per cell : " BITS/CELL DEC.
CR
CR ." --more-- " KEY DROP ^M EMIT EOL
CR ."                      Stack diagrams ( v1 v2 -- ) "
CR ."                      --------------------------- "
CR
CR ."     VVmove       copy V1 to V2"
CR ."     VV-          subtract V2 from V1 (in place)"
CR ."     VV+          add V2 to V1 (in place)"
CR ."     VV*          multiply V1 and V2, result to PP"
CR ."     VV/MOD       as /MOD , quotient in QQ, remainder in RR"
CR ."     VGCD         greatest common divisor of V1 and V2, result in SS"
CR
CR ."     VV=          ( v1 v2 -- bool ) test for equality 
CR ."     VV<          ( v1 v2 -- bool ) test for unsigned less than 
CR ."     VSqrt        ( v -- )  Calculate the largest number whose square is"
CR ."                  smaller than v, put it in SS"
CR
CR ." --more-- " KEY DROP ^M EMIT EOL
CR ."                    INPUT and OUTPUT"
CR ."                    ----------------"
CR ."      BIGNUM ##  ( ## -(exec)->  )"
CR ."         VREAD  ## ( any base )" 
CR ."        .VNUM ( always in decimal ) " 
CR 
CR ." NOTE: BigNums have less than " MAX.DIGITS DEC. ." super digits."
CR ." NOTE: Define  1 =: testing  before loading to compile the example  DIV "
CR ;

		DEPRIVE

nesting @ 0= [IF] 
		CR .ABOUT -bignum

[DEFINED] testing 
 [IF]

		MAX.DIGITS BIGNUM V1   V1 VREAD 100000000000000000
		MAX.DIGITS BIGNUM V2   V2 VREAD  60000000000000000

: DIV		CR ." dividend  -> " QUERY V1 VREAD 
		CR ." divisor   -> " QUERY V2 VREAD
		V1 V2 VV/MOD  
	CR
		." v1 v2 " 
		/OF V1 DEC. /OF V2 DEC. 
		." pp qq rr ss " 
		/OF PP DEC. /OF QQ DEC. /OF RR DEC. /OF SS DEC. 
	CR
		CR ." quotient  -> " QQ .VNUM
		CR ." remainder -> " RR .VNUM
		QQ V2 VV*  PP RR VV+
		CR ." check     -> " PP .VNUM 
	CR ;

[THEN]
	   [THEN]	


                              (* End of Source *)

張貼者： 於

沒有留言:

張貼留言

訂閱： 張貼留言 (Atom)