[openfirmware] [commit] r2260 - cpu/arm/olpc/1.75 dev/hdaudio forth/kernel forth/lib
repository service
svn at openfirmware.info
Sat Jun 11 01:51:31 CEST 2011
Author: wmb
Date: Sat Jun 11 01:51:31 2011
New Revision: 2260
URL: http://tracker.coreboot.org/trac/openfirmware/changeset/2260
Log:
OLPC XO-1.75 trac #10886 - autocorrelation-based audio selftest for XO-1.75
Modified:
cpu/arm/olpc/1.75/alc5631.fth
cpu/arm/olpc/1.75/sound.fth
dev/hdaudio/noiseburst.fth
dev/hdaudio/test.fth
forth/kernel/double.fth
forth/lib/isin.fth
forth/lib/tones.fth
Modified: cpu/arm/olpc/1.75/alc5631.fth
==============================================================================
--- cpu/arm/olpc/1.75/alc5631.fth Fri Jun 10 23:41:31 2011 (r2259)
+++ cpu/arm/olpc/1.75/alc5631.fth Sat Jun 11 01:51:31 2011 (r2260)
@@ -14,7 +14,7 @@
b# 1110.0000.0001.1101 h# 3c codec! \ Fast VREF control
d# 100 ms
- h# 8021 h# 34 codec! \ Slave mode, 16 bits, left justified, left channel on LRCLK high
+ h# 8001 h# 34 codec! \ Slave mode, 16 bits, left justified
h# 1010 h# 38 codec! \ Divisors; the values in this register don't seem to make much
\ difference unless you set the divisors to very high values.
@@ -95,10 +95,10 @@
false value force-speakers?
: set-volume ( n -- )
- headphones-inserted? force-speakers? 0= and if
- set-headphone-volume
+ headphones-inserted? ( force-speakers? 0= and ) if
+ set-headphone-volume mute-speakers
else
- set-speaker-volume
+ set-speaker-volume mute-headphones
then
;
d# 0 constant default-adc-gain \ 0 dB - range is -96.625 to +28.5
@@ -179,7 +179,7 @@
: mic+20db ( -- ) d# 20 set-mic-gain ;
: set-default-gains ( -- )
output-config
- headphones-inserted? force-speakers? 0= and if
+ headphones-inserted? ( force-speakers? 0= and ) if
headphones-on
speakers-off
else
Modified: cpu/arm/olpc/1.75/sound.fth
==============================================================================
--- cpu/arm/olpc/1.75/sound.fth Fri Jun 10 23:41:31 2011 (r2259)
+++ cpu/arm/olpc/1.75/sound.fth Sat Jun 11 01:51:31 2011 (r2260)
@@ -48,6 +48,12 @@
: reset-rx ( -- ) h# 8000.0002 h# 0c sspa! ;
+: active-low-rx-fs ( -- )
+ h# 0c sspa@ h# 8001.0000 or h# 0c sspa!
+;
+: active-high-rx-fs ( -- )
+ h# 0c sspa@ h# 10000 invert and h# 8000.0000 or h# 0c sspa!
+;
: setup-sspa-rx ( -- )
reset-rx
@@ -64,10 +70,10 @@
h# 8000.0000 \ Enable writes
d# 15 d# 20 lshift or \ Frame sync width
-\ We choose the master/slave configuration later, in enable-sspa-tx
+\ We choose the master/slave configuration later, in enable-sspa-rx
0 d# 18 lshift or \ Internal clock - master configuration
0 d# 17 lshift or \ Sample on rising edge of clock
- 0 d# 16 lshift or \ Active high frame sync
+ 1 d# 16 lshift or \ Active low frame sync (I2S standard)
d# 31 d# 4 lshift or \ Frame sync period
1 d# 2 lshift or \ Flush the FIFO
h# 0c sspa!
@@ -80,6 +86,12 @@
: reset-tx ( -- ) h# 8000.0002 h# 8c sspa! ;
+: active-low-tx-fs ( -- )
+ h# 8c sspa@ h# 8001.0000 or h# 8c sspa!
+;
+: active-high-tx-fs ( -- )
+ h# 8c sspa@ h# 10000 and h# 8000.0000 or h# 8c sspa!
+;
: setup-sspa-tx ( -- )
reset-tx
@@ -100,7 +112,10 @@
\ We choose the master/slave configuration later, in master-tx
0 d# 18 lshift or \ External clock - slave configuration (Rx is master)
0 d# 17 lshift or \ Sample on rising edge of clock
- 0 d# 16 lshift or \ Active high frame sync
+
+\ Empirically, this needs to be backwards from what we think it should be
+ 0 d# 16 lshift or \ Active high frame sync (should be active low, but that gives backwards results)
+
d# 31 d# 4 lshift or \ Frame sync period
1 d# 2 lshift or \ Flush the FIFO
h# 8c sspa!
@@ -247,7 +262,7 @@
: open-in ( -- ) ;
: close-in ( -- ) ;
-: open-out ( -- ) setup-sspa-tx ;
+: open-out ( -- ) ;
: close-out ( -- ) ;
: wait-out ( -- )
@@ -274,6 +289,7 @@
: stop-out ( -- )
disable-sspa-tx
+ reset-tx
stop-out-ring
uninstall-playback-alarm
false to playing?
@@ -313,6 +329,7 @@
: start-audio-out ( adr len -- )
to out-len ( adr )
to out-adr ( )
+ setup-sspa-tx ( )
make-out-ring
copy-out
out-len if copy-out then \ Prefill the second buffer
@@ -369,15 +386,30 @@
copy-in ( actual )
repeat ( actual )
disable-sspa-rx ( actual )
+ reset-rx ( actual )
;
: read ( adr len -- actual ) open-in audio-in ;
+0 value mono?
+0 value in-adr0
+0 value in-len0
+: collapse-in ( -- )
+ in-len0 0 ?do
+ in-adr0 i la+ w@ in-adr0 i wa+ w!
+ loop
+;
: out-in ( out-adr out-len in-adr in-len -- )
- to in-len to in-adr ( out-adr out-len )
+ to in-len0 to in-adr0 ( out-adr out-len )
to out-len to out-adr ( )
+ in-adr0 to in-adr ( )
+ in-len0 mono? if 2* then to in-len
+
+ audio-clock-on ( ) \ This will mess up any frequency settings
+
setup-sspa-tx ( )
setup-sspa-rx ( )
+ active-high-rx-fs ( )
make-in-ring ( )
make-out-ring ( )
@@ -402,7 +434,12 @@
disable-sspa-rx ( )
disable-sspa-tx ( )
+ reset-rx
+ reset-tx
+
dac-off adc-off ( )
+
+ mono? if collapse-in then ( )
;
0 [if] \ Interactive test words for out-in
@@ -452,8 +489,8 @@
set-adc-gain
;
-: stereo ;
-: mono ;
+: stereo false to mono? ;
+: mono true to mono? ;
: init-codec ( -- )
codec-on
@@ -486,6 +523,12 @@
false value force-internal-mic? \ Can't be implemented on XO-1.75
2 value #channels
fload ${BP}/dev/hdaudio/test.fth
+: input-settings ( -- )
+ audio-clock-on ( ) \ If you don't do this, the L/R phase is often wrong
+;
+: output-settings ( -- ) ;
+' input-settings to input-common-settings
+' output-settings to output-common-settings
end-package
Modified: dev/hdaudio/noiseburst.fth
==============================================================================
--- dev/hdaudio/noiseburst.fth Fri Jun 10 23:41:31 2011 (r2259)
+++ dev/hdaudio/noiseburst.fth Sat Jun 11 01:51:31 2011 (r2260)
@@ -302,9 +302,11 @@
drop ( )
;
: -stereo-wmean ( adr len -- )
- 2dup stereo-wmean ( adr len mean )
- -rot bounds ?do ( mean )
- i <w@ over - h# 7fff min h# -7fff max i w!
+ 2dup stereo-wmean >r ( adr len r: lmean )
+ over wa1+ over stereo-wmean r> swap ( adr len lmean rmean )
+ 2swap bounds ?do ( lmean rmean )
+ i <w@ 2 pick - h# 7fff min h# -7fff max i w!
+ i wa1+ <w@ over - h# 7fff min h# -7fff max i wa1+ w!
/l +loop ( mean )
drop ( )
;
@@ -340,34 +342,44 @@
3drop ( )
;
+\ sample-delay accounts for the different timing between adc-on and dac-on
+\ for different combinations of codec and controller.
+
+d# 0 value sample-delay
+: +sample-delay ( start #samples -- end' start' )
+ swap sample-delay + swap bounds
+;
0. 2value total-covar
-: sm-covar-sum ( adr1 adr2 len end start -- d.covar )
+: sm-covar-sum ( adr1 adr2 len start #samples -- d.covar )
+ +sample-delay ( adr1 adr2 len end' start' )
0. to total-covar
do
3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 len d.covar )
total-covar d+ to total-covar ( adr1 adr2 len )
loop ( adr1 adr2 len )
3drop ( )
- total-covar
+ total-covar d2* d2*
;
-: sm-covar-abs-sum ( adr1 adr2 len end start -- d.covar )
+: sm-covar-abs-sum ( adr1 adr2 len start #samples -- d.covar )
+ +sample-delay ( adr1 adr2 len end' start' )
0. to total-covar
do
3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 len d.covar )
dabs total-covar d+ to total-covar ( adr1 adr2 len )
loop ( adr1 adr2 len )
3drop ( )
- total-covar
+ total-covar d2* d2*
;
-: ss-covar-abs-sum ( adr1 adr2 len end start -- d.covar )
+: ss-covar-abs-sum ( adr1 adr2 len start #samples -- d.covar )
+ +sample-delay ( adr1 adr2 len end' start' )
0. to total-covar
do
3dup swap i la+ swap stereo-covar ( adr1 adr2 len d.covar )
dabs total-covar d+ to total-covar ( adr1 adr2 len )
loop ( adr1 adr2 len )
3drop ( )
- total-covar
+ total-covar d2* d2*
;
@@ -457,47 +469,70 @@
debug? if dup .d cr then
;
+d# 100 value #fixture
+d# 25 value fixture-threshold
: fixture-ratio-left ( -- error? )
- left-range d# 160 d# 60 sm-covar-abs-sum nip ( sum1 )
- left-range d# 400 d# 300 sm-covar-abs-sum nip ( sum1 sum2 )
+ left-range d# 60 #fixture sm-covar-abs-sum nip ( sum1 )
+ left-range d# 300 #fixture sm-covar-abs-sum nip ( sum1 sum2 )
>ratio
- d# 25 <
+ fixture-threshold <
;
: fixture-ratio-right ( -- error? )
- right-range d# 160 d# 60 sm-covar-abs-sum nip ( sum1 )
- right-range d# 400 d# 300 sm-covar-abs-sum nip ( sum1 sum2 )
+ right-range d# 60 #fixture sm-covar-abs-sum nip ( sum1 )
+ right-range d# 300 #fixture sm-covar-abs-sum nip ( sum1 sum2 )
>ratio
- d# 25 <
+ fixture-threshold <
;
+d# 60 value case-start-left
+d# 60 value case-start-right
+d# 400 value case-start-quiet
+d# 60 value #case-left
+d# 190 value #case-right
+d# 25 value case-threshold-left
+d# 14 value case-threshold-right
+
\ This compares the total energy within the impulse response band to the
\ total energy in a similar-length band
: case-ratio-left ( -- error? )
- left-range d# 120 d# 60 sm-covar-abs-sum nip ( sum1.high )
- left-range d# 460 d# 400 sm-covar-abs-sum nip ( sum1.high sum2.high )
+ left-range case-start-left #case-left sm-covar-abs-sum nip ( sum1.high )
+ left-range case-start-quiet #case-left sm-covar-abs-sum nip ( sum1.high sum2.high )
>ratio
- d# 25 <
+ case-threshold-left <
;
: case-ratio-right ( -- error? )
- right-range d# 250 d# 60 sm-covar-abs-sum nip ( sum1.high )
- right-range d# 590 d# 400 sm-covar-abs-sum nip ( sum1.high sum2.high )
+ right-range case-start-right #case-right sm-covar-abs-sum nip ( sum1.high )
+ right-range case-start-quiet #case-right sm-covar-abs-sum nip ( sum1.high sum2.high )
>ratio
- d# 14 <
+ case-threshold-right <
;
+d# 20 value #loopback
+d# 70 value loopback-threshold
\ This compares the total energy within the impulse response band to the
\ total energy in a similar-length band
: loopback-ratio-left ( -- error? )
- left-stereo-range d# 68 d# 48 ss-covar-abs-sum nip ( sum1.high )
- left-stereo-range d# 220 d# 200 ss-covar-abs-sum nip ( sum1.high sum2.high )
+ left-stereo-range d# 48 #loopback ss-covar-abs-sum nip ( sum1.high )
+ left-stereo-range d# 200 #loopback ss-covar-abs-sum nip ( sum1.high sum2.high )
>ratio
- d# 70 <
+ loopback-threshold <
;
: loopback-ratio-right ( -- error? )
- right-stereo-range d# 68 d# 48 ss-covar-abs-sum nip ( sum1.high )
- right-stereo-range d# 220 d# 200 ss-covar-abs-sum nip ( sum1.high sum2.high )
+ right-stereo-range d# 48 #loopback ss-covar-abs-sum nip ( sum1.high )
+ right-stereo-range d# 200 #loopback ss-covar-abs-sum nip ( sum1.high sum2.high )
>ratio
- d# 70 <
+ loopback-threshold <
+;
+
+\ Ideally we would not put platform-specific information in this module.
+\ If we add many more platforms, this should be redesigned.
+: configure-xo1.75 ( -- )
+ d# -23 to sample-delay
+ d# 50 to fixture-threshold
+ d# 40 to #fixture
+ d# 83 to case-start-right
+ d# 30 to #case-right
+ d# 25 to case-threshold-right
;
d# 1200 constant #impulse-response
@@ -507,7 +542,7 @@
pb + rb #samples ( adr1 adr2 #samples )
#impulse-response 0 do
3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 #samples d.covar )
- d# 50000000 m/mod nip ( adr1 adr2 #samples n.covar )
+ d# 500,000,000 m/mod nip ( adr1 adr2 #samples n.covar )
impulse-response i wa+ w! ( adr1 adr2 #samples )
loop ( adr1 adr2 len )
3drop ( )
@@ -516,8 +551,8 @@
: calc-stereo-impulse ( offset -- adr ) \ offset is 0 for left or 2 for right
dup pb + swap rb + #samples ( adr1 adr2 #samples )
#impulse-response 0 do
- 3dup swap i wa+ swap stereo-covar ( adr1 adr2 #samples d.covar )
- d# 50000000 m/mod nip ( adr1 adr2 #samples n.covar )
+ 3dup swap i la+ swap stereo-covar ( adr1 adr2 #samples d.covar )
+ d# 50,000,000 m/mod nip ( adr1 adr2 #samples n.covar )
impulse-response i wa+ w! ( adr1 adr2 #samples )
loop ( adr1 adr2 len )
3drop ( )
@@ -561,8 +596,6 @@
: setup-fixture ( -- )
h# 20000 to /pb \ Medium burst
/pb 2/ h# 1000 + to /rb \ Mono reception (internal mic)
-\ ['] fixture-analyze-left to analyze-left
-\ ['] fixture-analyze-right to analyze-right
['] fixture-ratio-left to analyze-left
['] fixture-ratio-right to analyze-right
['] -mono-wmean to fix-dc
Modified: dev/hdaudio/test.fth
==============================================================================
--- dev/hdaudio/test.fth Fri Jun 10 23:41:31 2011 (r2259)
+++ dev/hdaudio/test.fth Sat Jun 11 01:51:31 2011 (r2260)
@@ -108,7 +108,7 @@
defer input-common-settings
defer output-common-settings
[ifdef] with-adc
-\ XXX this is hd-audio specific. Factore it out
+\ XXX this is hd-audio specific. Factor it out
: (input-common-settings) ( -- )
open-in 48kHz 16bit with-adc d# 73 input-gain
;
@@ -120,11 +120,12 @@
[then]
: test-with-case ( -- )
- " setup-case" $call-analyzer
+\ " setup-case" $call-analyzer
\ xxx - this needs to use the internal speakers and mic even though the loopback cable is attached
true to force-speakers? true to force-internal-mic?
+ mic-bias-on
input-common-settings mono
- output-common-settings d# -9 set-volume
+ output-common-settings d# -1 set-volume
." Testing internal speakers and microphone" cr
" setup-case" test-common
false to force-speakers? false to force-internal-mic?
@@ -135,8 +136,9 @@
;
: test-with-fixture ( -- error? )
true to force-speakers? true to force-internal-mic?
+ mic-bias-on
input-common-settings mono
- output-common-settings d# -23 set-volume \ -23 prevents obvious visible clipping
+ output-common-settings d# -13 set-volume \ -23 prevents obvious visible clipping
." Testing internal speakers and microphone with fixture" cr
" setup-fixture" test-common
false to force-speakers? false to force-internal-mic?
@@ -146,8 +148,9 @@
then
;
: test-with-loopback ( -- error? )
- input-common-settings stereo
- output-common-settings d# -33 set-volume \ -23 prevents obvious visible clipping
+ mic-bias-off
+ input-common-settings stereo
+ output-common-settings d# -22 set-volume
." Testing headphone and microphone jacks with loopback cable" cr
" setup-loopback" test-common
plot? if
@@ -193,8 +196,13 @@
instructions-done
then
;
+: configure-platform ( -- )
+ board-revision h# 1a28 >= if " configure-xo1.75" $call-analyzer exit then
+;
\ Returns failure by throwing
: automatic-test ( -- )
+ configure-platform
+ disconnect-loopback \ Not for 1.5; it can test internal while loopback is connected
" smt-test?" evaluate if
test-with-fixture throw
else
Modified: forth/kernel/double.fth
==============================================================================
--- forth/kernel/double.fth Fri Jun 10 23:41:31 2011 (r2259)
+++ forth/kernel/double.fth Sat Jun 11 01:51:31 2011 (r2260)
@@ -43,6 +43,25 @@
: drot ( d1 d2 d3 -- d2 d3 d1 ) 2>r 2swap 2r> 2swap ;
: -drot ( d1 d2 d3 -- d3 d1 d2 ) drot drot ;
: dinvert ( d1 -- d2 ) swap invert swap invert ;
+
+: dlshift ( d1 n -- d2 )
+ tuck lshift >r ( low n r: high2 )
+ 2dup bits/cell swap - rshift r> or >r ( low n r: high2' )
+ lshift r> ( d2 )
+;
+: drshift ( d1 n -- d2 )
+ 2dup rshift >r ( low high n r: high2 )
+ tuck bits/cell swap - lshift ( low n low2 r: high2 )
+ -rot rshift or ( low2 r: high2 )
+ r> ( d2 )
+;
+: d>>a ( d1 n -- d2 )
+ 2dup rshift >r ( low high n r: high2 )
+ tuck bits/cell swap - lshift ( low n low2 r: high2 )
+ -rot >>a or ( low2 r: high2 )
+ r> ( d2 )
+;
+
\ LICENSE_BEGIN
\ Copyright (c) 2006 FirmWorks
\
Modified: forth/lib/isin.fth
==============================================================================
--- forth/lib/isin.fth Fri Jun 10 23:41:31 2011 (r2259)
+++ forth/lib/isin.fth Sat Jun 11 01:51:31 2011 (r2260)
@@ -16,23 +16,23 @@
0 value freq
0 value fstep
0 value #cycle
-0 value #half-cycle
-0 value #quarter-cycle
+0 value #cycle/2
+0 value #cycle/4
: set-freq ( freq sample-rate -- )
to fs ( freq )
dup to freq ( freq )
pi * to fstep
fs freq / dup to #cycle
- 2/ dup to #half-cycle
- 2/ to #quarter-cycle
+ 2/ dup to #cycle/2
+ 2/ to #cycle/4
;
-: set-period ( quarter-cycle -- )
- dup to #quarter-cycle ( quarter-cycle )
- 2* dup to #half-cycle ( half-cycle )
+: set-period ( cycle/4 -- )
+ dup to #cycle/4 ( cycle/4 )
+ 2* dup to #cycle/2 ( cycle/2 )
2* dup to #cycle ( cycle )
fs over / to freq ( period )
- pi swap / fs * to fstep ( )
+ pi fs rot */ to fstep ( )
;
\ Multiply two fractional numbers where the scale factor is 2^15
@@ -42,27 +42,84 @@
\ Computes (1 - (theta^2 / divisor) * last)
: sin-step ( last divisor -- next ) thetasq swap / times one min one swap - ;
+0 [if]
+\ Cos
+\ 1 - t^2/(2) + t^4/(2..4) - t^6/2..6) + t^8/(2..8)
+\ 1 - (t^2/(1*2)) * (1 - (t^2/(3*4)) * (1 - (t^2/(5*6)) * (1 - (t^2/(7*8))))
+
+: icos ( index -- frac )
+ fstep fs 2/ */ to theta
+ theta dup times to thetasq
+ one d# 90 cos-step d# 56 cos-step d# 30 cos-step d# 12 cos-step 2 cos-step one min
+;
+[then]
+
\ Taylor series expansion of sin, calculated as
+\ t - t^3/(2*3) + t^5/(2*3*4*5) - t^7/(2..7) + t^9/(2...9)
\ theta * (1 - (theta^2/(2*3)) * (1 - (theta^2/(4*5)) * (1 - (theta^2/(6*7)) * (1 - (theta^2/(8*9))))))
\ This is good for the first quadrant only, i.e. 0 <= index <= fs / freq / 4
-: isin ( index -- frac )
- fstep * fs 2/ / to theta
+: calc-sin ( index -- frac )
+ fstep fs 2/ */ to theta
theta dup times to thetasq
one d# 72 sin-step d# 42 sin-step d# 20 sin-step 6 sin-step theta times one min
;
: one-cycle ( adr -- )
- #quarter-cycle 1+ 0 do ( adr )
- i isin
+ #cycle/4 1+ 0 do ( adr )
+ i calc-sin
2dup swap i wa+ w! ( adr isin )
- 2dup swap #half-cycle i - wa+ w! ( adr isin )
+ 2dup swap #cycle/2 i - wa+ w! ( adr isin )
negate ( adr -isin )
- 2dup swap #half-cycle i + wa+ w! ( adr -isin )
+ 2dup swap #cycle/2 i + wa+ w! ( adr -isin )
over #cycle i - wa+ w! ( adr )
loop ( adr )
drop
;
+
+0 [if]
+: reduce-to-quarter-cycle ( -- )
+ \ Move a cycle/4 to the left until negative, then fix
+ #cycle/4 - dup 0<= if #cycle/4 + (sin) exit then ( theta' ) \ Quadrant 1
+ #cycle/4 - dup 0<= if negate (sin) exit then ( theta' ) \ Quadrant 2
+ #cycle/4 - dup 0<= if #cycle/4 + (sin) negate exit then ( theta' ) \ Quadrant 3
+ #cycle/4 - negate (sin) negate \ Quadrant 4
+;
+[then]
+
+\ For isin and icos we use a cosine table instead of a sine table.
+\ Argument reduction is a bit easier for cos because it is an even function.
+: one-cycle-cos ( adr -- )
+ #cycle/4 1+ 0 do ( adr )
+ i calc-sin ( adr isin )
+ 2dup swap #cycle/4 i - wa+ w! ( adr isin ) \ Quadrant 1
+ 2dup swap #cycle/4 3 * i + wa+ w! ( adr isin ) \ Quadrant 4
+ negate ( adr -isin )
+ 2dup swap #cycle/4 i + wa+ w! ( adr -isin ) \ Quadrant 2
+ over #cycle/4 3 * i - wa+ w! ( adr ) \ Quadrant 3
+ loop ( adr )
+ drop
+;
+
+\ The scale factor for theta is such that h# 10000 is pi radians.
+\ Binary 1 is therefore pi/2^16
+0 value cos-table
+: init-sincos ( -- )
+ cos-table if exit then
+ h# 20000 /w* alloc-mem to cos-table
+ 1 h# 20000 set-freq
+ cos-table one-cycle-cos
+;
+: release-cos-table ( -- ) cos-table h# 20000 /w* free-mem 0 to cos-table ;
+
+: icos ( theta -- cos )
+ abs ( theta' )
+ dup #cycle >= if #cycle mod then ( theta' )
+ cos-table swap wa+ <w@ ( cos )
+;
+: isin ( theta -- sin ) #cycle/4 - icos ;
+
+
\ d# 16000 to fs
\ d# 150 set-freq
\ here one-cycle
Modified: forth/lib/tones.fth
==============================================================================
--- forth/lib/tones.fth Fri Jun 10 23:41:31 2011 (r2259)
+++ forth/lib/tones.fth Sat Jun 11 01:51:31 2011 (r2260)
@@ -3,14 +3,14 @@
: /cycle ( -- #bytes ) #cycle /l* ;
: make-cycle ( adr -- adr' )
- #quarter-cycle 1+ 0 do ( adr )
- i isin ( adr isin )
- 2dup swap i la+ w! ( adr isin )
- 2dup swap #half-cycle i - la+ w! ( adr isin )
- negate ( adr -isin )
- 2dup swap #half-cycle i + la+ w! ( adr -isin )
- over #cycle i - la+ w! ( adr )
- loop ( adr )
+ #cycle/4 1+ 0 do ( adr )
+ i calc-sin ( adr isin )
+ 2dup swap i la+ w! ( adr isin )
+ 2dup swap #cycle/2 i - la+ w! ( adr isin )
+ negate ( adr -isin )
+ 2dup swap #cycle/2 i + la+ w! ( adr -isin )
+ over #cycle i - la+ w! ( adr )
+ loop ( adr )
/cycle +
;
More information about the openfirmware
mailing list