[OpenBIOS] r464 - dev forth/kernel

svn at openbios.org svn at openbios.org
Thu Jul 5 19:28:08 CEST 2007


Author: wmb
Date: 2007-07-05 19:28:08 +0200 (Thu, 05 Jul 2007)
New Revision: 464

Added:
   dev/diaguart.fth
   forth/kernel/dmuldiv.fth
Log:
Added some common files needed by the PowerPC version.


Added: dev/diaguart.fth
===================================================================
--- dev/diaguart.fth	                        (rev 0)
+++ dev/diaguart.fth	2007-07-05 17:28:08 UTC (rev 464)
@@ -0,0 +1,38 @@
+purpose: Diagnostic (before console installation) access to serial port
+copyright: Copyright 1994 Firmworks  All Rights Reserved
+
+headerless
+d# 1843200 constant uart-clock-frequency
+
+[ifndef] uart@
+h# 3f8 value uart-base	\ Virtual address of UART; set later
+
+: uart@  ( reg# -- byte )  uart-base +  pc@  ;	\ Read from a UART register
+: uart!  ( byte reg# -- )  uart-base +  pc!  ;	\ Write to a UART register
+[then]
+
+: baud  ( baud-rate -- )
+   uart-clock-frequency d# 16 /  swap rounded-/    ( baud-rate-divisor )
+
+   begin  5 uart@ h# 40 and  until		\ Wait until transmit done
+
+   3 uart@  dup >r  h# 80 or  3 uart!		\ divisor latch access bit on
+   dup h# ff and  0 uart!  8 >> 1 uart!		\ Write lsb and msb
+   r> 3 uart!					\ Restore old state
+;
+
+: inituarts  ( -- )
+   3 3 uart!  		\ 8 bits, no parity
+   7 2 uart!		\ Clear and enable FIFOs
+\   d# 38400 baud
+   d# 9600 baud
+;
+
+: ukey?    ( -- flag )  5 uart@      1 and  0<>  ;  \ Test for rcv character
+: uemit?   ( -- flag )  5 uart@  h# 20 and  0<>  ;  \ Test for xmit ready
+: ubreak?  ( -- flag )  5 uart@  h# 10 and  0<>  ;  \ Test for received break
+: clear-break   ( -- )  5 uart@  drop  ;	    \ Clear break indication
+
+: ukey   ( -- char )  begin  ukey?   until  0 uart@  ;  \ Receive a character
+: uemit  ( char -- )  begin  uemit?  until  0 uart!  ;  \ Transmit a character
+headers

Added: forth/kernel/dmuldiv.fth
===================================================================
--- forth/kernel/dmuldiv.fth	                        (rev 0)
+++ forth/kernel/dmuldiv.fth	2007-07-05 17:28:08 UTC (rev 464)
@@ -0,0 +1,172 @@
+purpose: Extended precision multiplication and division
+\ See license at end of file
+
+\ alias um*  u*x  ( u1 u2 -- ud )
+
+headerless
+/n-t 4 * constant bits/half-cell
+
+: scale-up    ( -- )  bits/half-cell <<  ;
+: scale-down  ( -- )  bits/half-cell >>  ;
+: split-halves  ( n -- low-half high-half )
+   dup 1 scale-up 1- and  swap scale-down
+;
+
+headers
+\ This is the elementary school long-division algorithm, base 2^^16 (on a
+\ 32-bit system) or 2^32 (on a 64-bit system).
+\ It depends on the assumption that "/" can accurately divide a single-cell
+\ (i.e. 32 or 64 bit) number by a half-cell (i.e. 16 or 32 bit) number.
+\ Each "digit" is a half-cell number; thus the dividend is a 4-digit
+\ number "ABCD" and the divisor is a 2-digit number "EF".
+
+\ It would be interesting to compare the performance of this to a
+\ "bit-banging" non-restoring division loop.
+: um/mod  ( ud u -- urem uquot )
+   2dup u>=  if                    \ Overflow; return max-uint for quotient
+      0=  if  0 /  then            \ Force divide by zero trap
+      2drop   0 -1  exit           ( 0 max-u )
+   then                            ( ud u )
+
+   \ Split the divisor into two 16-bit "digits"
+   dup split-halves		   ( ud u ulow uhigh )
+
+   \ If the high "digit" of the divisor is zero, we can skip a lot
+   \ of the steps.  In this case, we only have to worry about the
+   \ middle two digits of the dividend in developing the quotient.
+   ?dup 0=  if                     ( ud u ulow )
+
+      \ Approximate the high digit of the quotient by dividing the "BC"
+      \ digits by the "F" digit.  The answer could by low by one, but if
+      \ so it will be fixed in the next step.
+      2over swap scale-down swap scale-up + over /  scale-up
+				   ( ud u ulow guess<< )
+
+      \ Multiply the trial quotient by the divisor
+      rot over um*                 ( ud ulow guess<< udtemp )
+
+      \ Subtract the trial product from the dividend, giving the remainder
+      2swap >r >r  d-  drop        ( error )  ( r: guess<< ulow )
+
+      \ Divide the remainder by the divisor, giving the rest of the
+      \ quotient.
+      dup r@ u/mod nip             ( error guess1 )
+      r> r>                        ( error guess1 ulow guess<< )
+
+      \ Merge the two halves of the quotient
+      2 pick + >r                  ( error guess1 ulow ) ( r: uquot )
+
+      \ Calculate the remainder
+      * -  r>                      ( urem uquot )
+      exit
+   then                            ( ud u ulow uhigh )
+
+   \ The high divisor digit is non-zero, so we have to deal with
+   \ both digits, dividing "ABCD" by "EF".
+
+   \ Approximate the high digit of the quotient.
+   3 pick over u/mod nip           ( ud u ulow uhigh guess )
+
+   \ Reduce guess by one if "E" = "A"
+   dup 1 scale-up =  if  1-  then  ( ud u ulow uhigh guess' )
+
+   \ Multiply the trial quotient by the divisor
+   3 pick over scale-up um*        ( ud u ulow uhigh guess' ud.temp )
+
+   \ Subtract the trial product from the dividend, giving the remainder
+   >r >r 2rot r> r> d-             ( u ulow uhigh guess' d.resid )
+
+   \ If the remainder is negative, add the divisor and reduce the trial
+   \ quotient by one.  The following loop executes at most twice.
+   begin  dup 0<  while            ( u ulow uhigh guess' d.resid )
+      rot 1- -rot                  ( u ulow uhigh guess+ d.resid )
+      4 pick scale-up 4 pick d+    ( u ulow uhigh guess+ d.resid' )
+   repeat                          ( u ulow uhigh guess+ +d.resid )
+
+   \ Now we have the correct high quotient digit; save it for later
+   rot scale-up >r                 ( u ulow uhigh +d.resid ) ( r: q.high )
+
+   \ Repeat the above process, using the partial remainder as the
+   \ dividend.  Ulow is no longer needed
+   3 roll drop                     ( u uhigh +d.resid )
+
+   \ Trial quotient digit...
+   2dup scale-up swap scale-down + 3 roll u/mod nip
+                                   ( u +d.resid guess1 ) ( r: q.high )
+   dup 1 scale-up =  if  1-  then  ( u +d.resid guess1' )
+
+   \ Trial product
+   3 pick over um*                 ( u +d.resid guess1' d.err )
+
+   \ New partial remainder
+   rot >r d-                       ( u d.resid' )  ( r: q.high guess1' )
+
+   \ Adjust quotient digit until partial remainder is positive
+   begin  dup 0<  while            ( u d.resid' )  ( r: q.high guess1' )
+     r> 1- >r                      ( u d.resid' )  ( r: q.high guess1' )
+     2 pick m+                     ( u d.resid'' ) ( r: q.high guess1' )
+   repeat                          ( u +d.resid )  ( r: q.high guess1' )
+
+   \ Discard divisior and high cell of quotient (which must be zero)
+   rot 2drop                       ( u.rem )
+
+   \ Merge quotient digits
+   r> r> +                         ( u.rem u.quot )
+;
+: sm/rem  ( d n -- rem quot )
+   0                           ( d n sign )
+   2 pick 0<  if               ( d n sign )
+      1+  2swap dnegate 2swap  ( +d n sign )
+   then                        ( +d n sign )
+   over 0<  if                 ( +d n sign )
+      2+  swap negate swap     ( +d +n sign )
+   then                        ( +d +n sign )
+   >r um/mod r>                ( u.rem u.quot sign )
+   case
+      1 of  swap negate swap negate  endof  \ -dividend, +divisor
+      2 of  negate                   endof  \ +dividend, -divisor
+      3 of  swap negate swap         endof  \ -dividend, -divisor
+   endcase
+;
+: fm/mod  ( d.dividend n.divisor -- n.rem n.quot )
+   2dup xor 0<  if        \ Fixup only if operands have opposite signs
+      dup >r  sm/rem                                ( rem' quot' r: divisor )
+      over  if  1- swap r> + swap  else  r> drop  then
+      exit
+   then
+   \ In the usual case of similar signs (i.e. positive quotient),
+   \ sm/rem gives the correct answer
+   sm/rem   ( n.rem' n.quot' )
+;
+
+" m*" $sfind [if]  drop  [else]  2drop
+: m*  ( n1 n2 -- d )
+   2dup xor >r  abs swap  abs um*  r> 0<  if  dnegate  then
+;
+[then]
+: */mod  ( n1 n2 n3 -- n.mod n.quot )  >r m* r> fm/mod  ;
+: */  ( n1 n2 n3 -- n4 )  */mod nip  ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1994 FirmWorks
+\ 
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\ 
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\ 
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END




More information about the OpenBIOS mailing list