• R/O
  • HTTP
  • SSH
  • HTTPS

Commit

Tags
No Tags

Frequently used words (click to add to your profile)

javaandroidc++cocoaobjective-cc#誰得gamephpbathyscaphelinuxrubyqtcomegat翻訳pythontwitterwindowsbtronvb.nettestframeworkgui計画中(planning stage)directxpreviewerpukiwikidommruby

Functions for working with the idealized calendar of Planet Xhilr


Commit MetaInfo

Revision4df80e85a95a025aa7dd1dcc66316b3ca0fd60dc (tree)
Time2017-06-13 18:05:45
AuthorJoel Matthew Rees <joel.rees@gmai...>
CommiterJoel Matthew Rees

Log Message

full double division in Forth-level code

Change Summary

Incremental Difference

--- a/econmonths.fs
+++ b/econmonths.fs
@@ -120,19 +120,6 @@
120120 : DMIN ( d1 d2 --- d : Leave smaller of top two. )
121121 4DUP D< IF 2DROP ELSE 2SWAP 2DROP THEN ;
122122
123-( 2/ and d2/ requires words which have various names -- u/, etc., )
124-( and are very slow. )
125-( Just best to do in assembler, along with UD* and UQD/MOD . )
126-( : 2* DUP + ; ( u1 --- u2 : Double the top cell. Not fastest. )
127-
128-( : D2* 2DUP D+ ; ( ud1 --- ud2 : Double the top double cell. Not fastest. )
129-
130-( Do it in assembler instead! )
131-( : 2/ 0 2 UM/MOD SWAP DROP ; ( u1 --- u2 : Halve the top cell. SLOW! )
132-
133-( Do it in assembler instead! )
134-( : D2/ 2 M/MOD ROT DROP ; ( uD1 --- uD2 : Halve the top cell. SLOW! )
135-
136123 ( : R@ R ; ( Modern name for copy top of return stack. )
137124
138125 ( Showing the above in infix won't help. )
@@ -143,10 +130,12 @@
143130 ( -- even if all you have is the bit math. )
144131
145132
146-( Already there as M/MOD in some Forths: )
133+( JM/MOD is already there as M/MOD in some Forths: )
147134 ( : JM/MOD M/MOD ; ( uddividend udivisor -- uremainder udquotient )
148135 : JM/MOD ( uddividend udivisor -- uremainder udquotient )
149136 >R 0 R> DUP >R UM/MOD R> SWAP >R UM/MOD R> ;
137+( Tick ' has various semantics, even in different fig Forths. )
138+( This definition is safe, anyway. )
150139
151140 SP@ SP@ - ABS CONSTANT CELLWIDTH
152141 ( Infix won't help here, either, but I can try to explain: )
@@ -164,6 +153,25 @@ SP@ SP@ - ABS CONSTANT CELLWIDTH
164153 CELLWIDTH + ! ( MS-CELL )
165154 ;
166155
156+( Left shifts can be done with addition. )
157+: SUM2* DUP + ; ( u1 --- u2 : Double the top cell. Not fastest, not too slow. )
158+: SUMD2* 2DUP D+ ; ( ud1 --- ud2 : Double the top double cell. Not fastest. )
159+: SLOWQ2* ( uq1 --- uq2 : Double the top double cell. Not fastest. )
160+ SUMD2* >R OVER 0< IF
161+ 1 OR ( carry )
162+ THEN
163+ >R
164+ SUMD2*
165+ R> R> ;
166+
167+: MY-BIT-COUNTER ( --- u ) ( Let's figure out how wide a CELL is. )
168+ 0. 1. BEGIN
169+ SUMD2* 2SWAP 1. D+ 2SWAP SP@ @
170+ UNTIL 2DROP DROP ;
171+
172+MY-BIT-COUNTER CONSTANT CELLBITS
173+CELLBITS CELLWIDTH /MOD CONSTANT BYTEBITS CONSTANT LEFTOVERBITS
174+
167175 ( Semi-simulate local variables with the ability to fetch and store relative to top of stack. )
168176
169177 ( Infix will be confusing here, too. )
@@ -311,19 +319,75 @@ SP@ SP@ - ABS CONSTANT CELLWIDTH
311319 3 LC! 3 LC! 3 LC! 3 LC!
312320 ;
313321
314-( Scaling, to keep the steps time-bounded, is going to leave me at the binary long division )
315-( unless I use tables. Tables will not fit in a 16-bit address space. )
316-( AL AML AMH AH BL BH --- QL QML QMH QH : unsigned 4-cell by unsigned double yielding 4-cell unsigned )
317-( : UQD/MOD ( uqdividend uddivisor --- udremainder uhqquotient )
318-( DUP 0= IF )
319-( DROP UQS/MOD ( Get divisor high word 0 case out of the way. )
320-( ELSE )
321-( 2>R ( Divisor high byte handy. )
322-( DUP 0 R> DUP >R JM/MOD ( Trial division for guess. )
323-( ROT DROP 2R> 2DUP 2>R UMD* )
324-( )
325-( THEN )
326-( ; )
322+
323+( 2/ and d2/ require words which have various names -- u/, etc., )
324+( and are very slow. )
325+( Just best to do in assembler, along with UD* and UQD/MOD . )
326+
327+( Do it in assembler instead! Hundreds of times as slow!!!! )
328+: DIV2/ ( u1 --- u2 : Halve the top cell. REALLY SLOW! )
329+ S>D 2 UM/MOD SWAP DROP ;
330+
331+( Do it in assembler instead! Hundreds of times as slow!!!! )
332+: DIVD2/ ( ud1 --- ud2 : Halve the top double cell. REALLY SLOW! )
333+ 2 UM/MOD ROT DROP ;
334+
335+( Scaling, to keep the steps time-bounded, )
336+( is going to leave me at the binary long division )
337+( unless I use tables. )
338+( Tables will not fit in a 16-bit address space. )
339+( And scaling requires shifts, )
340+( which are painfully slow if not defined low level. )
341+( Some dividends will overflow quotient, not valid for such cases. )
342+( Intended to be used for known products of two doubles.
343+( AL AML AMH AH BL BH --- RL RH QL QH : unsigned quad by unsigned double yielding unsigned double )
344+: MOLASSES-UMD/MOD ( uqdividend uddivisor --- udremainder udquotient )
345+ DUP 0= IF
346+ DROP UQS/MOD 2DROP 0 ROT ROT ( Get divisor high word 0 easy case done quickly. )
347+ ELSE
348+ 2ROT 2ROT ( Get the divisor out of the way, but accessible with pick. )
349+ CELLBITS SUM2* 1+ >R ( Count )
350+ 0 >R ( Force flag )
351+ BEGIN
352+ 2DUP ( high double of dividend )
353+ 6 DLC@ D< 0= ( Greater or equal? )
354+ R> OR ( Force it? )
355+ IF
356+ D- 1 ( Mark the subtraction. )
357+ ELSE
358+ DROP 0 ( Mark no subtraction. )
359+ THEN
360+ SWAP >R SWAP >R ( Save top half of remainder and bury the subtraction flag. )
361+ OVER >R ( Remember the carry from bottom to top half -- AML. )
362+ >R SUMD2* ( Save subtraction flag and shift the bottom half: AL AML. )
363+ SWAP R> OR SWAP ( Record the subtraction in emptied bit of remainder. )
364+ R> DUP 0< IF 1 ELSE 0 THEN ( Convert AML to bit to shift in to top half. )
365+ R> R> ( BL BH AL AML CARRY AMH AH )
366+ R> 1 - DUP >R ( Count down. )
367+ WHILE ( BL BH AL AML CARRY AMH AH )
368+ DUP 0< >R ( Remember the high bit of the remainder, to force subtract. )
369+ SUMD2* >R OR R> ( Shift the remainder, with the bit from the low half. )
370+ REPEAT ( BL BH AL AML AMH AH )
371+ R> DROP ( the count )
372+ ( BL BH QL QH RL RH )
373+ 2>R 2>R 2DROP 2R> 2R> ( QL QH RL RH )
374+ 2SWAP
375+ THEN
376+;
377+
378+( If your 16-bit Forth has UD/MOD, uncomment this and comment out the fake! *********** )
379+( : JUD/MOD UD/MOD ; ( uqdividend uddivisor -- udremainder udquotient : If it exists. )
380+( If UD/MOD does not exist and we are working on 32 or 64 bit, fake it. )
381+( But make it safe! )
382+: JUD/MOD ( uqdividend uddivisor -- udremainder udquotien : fake double division )
383+
384+ CELLWIDTH 4 < 0= IF
385+ DROP >R 2DROP R> JM/MOD
386+ ELSE ( Things get hairy! )
387+
388+ THEN ;
389+( In 32-bit or more, get rid of unneeded stuff and use single division. )
390+
327391
328392 ( Make things easier to read. )
329393 ( Infix will be confusing here, too. )