[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