(FILECREATED "26-Feb-85 12:14:56" {ERIS}<LISPCORE>LIBRARY>FLOATARRAY.;3 16315
changes to: (FNS \NEWMISC5.UFN)
(VARS FLOATARRAYCOMS)
previous date: "21-Nov-84 16:20:20" {ERIS}<LISPCORE>LIBRARY>FLOATARRAY.;2)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FLOATARRAYCOMS)
(RPAQQ FLOATARRAYCOMS [(* * MAPELT fns and macros)
(FNS MAPELT MAPELT1 MAPELT2 EXPANDMAPELT EXPANDMAPELT1 EXPANDMAPELT2
RATIONALIZEMAPELT1 RATIONALIZEMAPELT2)
(MACROS MAPELT MAPELT1 MAPELT2)
(* * FFT stuff)
(FNS FFTSTEP \FFTSTEP)
(PROP DOPVAL \FFTSTEP)
(RECORDS FFTTABLE FFTSOURCE COMPLEX)
(CONSTANTS \FFTTABLESIZE)
(* * UFNs)
(FNS \FLOATBLT)
(PROP DOPVAL \FLOATBLT)
(* * For convenience)
(PROP ARGNAMES MAPELT \BLKEXPONENT \BLKFDIFF \BLKFLOATP2COMP \BLKFPLUS
\BLKFTIMES \BLKMAG \BLKPERM \BLKSEP \BLKSMALLP2FLOAT \IBLT1 \IBLT2)
(MACROS ARRAYHIELT DOUBLE QUADRUPLE)
(FNS ARRAYBASE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA MAPELT])
(* * MAPELT fns and macros)
(DEFINEQ
(MAPELT
[LAMBDA ARGS (* hdj "13-Nov-84 14:25")
(* * Top level entry to array mapper: recognizes MAPELT1 and MAPELT2 cases.)
(* * if RESULT is not an array, ARRAY1 had better be)
(LET ((RESULT (ARG ARGS 1))
(MAPFN (ARG ARGS 2))
(ARRAY1 (ARG ARGS 3)))
(SELECTQ ARGS
(3 (MAPELT1 RESULT MAPFN ARRAY1))
(4 (MAPELT2 RESULT MAPFN ARRAY1 (ARG ARGS 4)))
(LET* ([INPUTARRAYBASES (for ARGUMENT from 3 to ARGS collect (ARRAYBASE (ARG ARGS
ARGUMENT]
(NUMINPUTARRAYS (LENGTH INPUTARRAYBASES))
(ELEMENTS (ARRAYSIZE ARRAY1))
[GOODRESULT (OR (ARRAYP RESULT)
(ARRAY (ARRAYSIZE ARRAY1)
(QUOTE FLOATP)
0.0
(ARRAYORIG ARRAY1]
(RESULTBASE (ARRAYBASE GOODRESULT)))
[for ELEMENT from 0 to ELEMENTS
do (\PUTBASEFLOATP RESULTBASE (DOUBLE ELEMENT)
(APPLY MAPFN
(for OPERAND from 1 to NUMINPUTARRAYS as ARRAY
in INPUTARRAYBASES collect (\GETBASEFLOATP
ARRAY
(DOUBLE ELEMENT]
GOODRESULT])
(MAPELT1
[LAMBDA (RESULT MAPFN ARRAY) (* hdj "28-Sep-84 12:44")
(* * Map a function across an array. Recognizes the special cases that can run in microcode.)
(LET [(GOODRESULT (OR RESULT (ARRAY (ARRAYSIZE ARRAY)
(QUOTE FLOATP)
0.0
(ARRAYORIG ARRAY]
(LET ((ARRAYSIZE (ARRAYSIZE ARRAY))
(ARRAYBASE (ARRAYBASE ARRAY))
(RESULTBASE (ARRAYBASE GOODRESULT)))
[SELECTQ MAPFN
(EXPONENT (\BLKEXPONENT ARRAYBASE RESULTBASE ARRAYSIZE))
(MAGNITUDE (\BLKMAG ARRAYBASE RESULTBASE (HALF ARRAYSIZE)))
(FLOAT (\BLKSMALLP2FLOAT ARRAYBASE RESULTBASE ARRAYSIZE))
(COMPLEXIFYFLOATP (\BLKFLOATP2COMP ARRAYBASE RESULTBASE ARRAYSIZE))
(SEPARATE (\BLKSEP ARRAYBASE (\ADDBASE ARRAYBASE (DOUBLE (IDIFFERENCE
(ARRAYSIZE ARRAY)
2)))
RESULTBASE ARRAYSIZE))
(for ELT from 0 to (DOUBLE (SUB1 ARRAYSIZE)) by 2
do (\PUTBASEFLOATP RESULTBASE ELT (APPLY* MAPFN (\GETBASEFLOATP ARRAYBASE
ELT]
GOODRESULT])
(MAPELT2
[LAMBDA (RESULT MAPFN ARRAY1 ARRAY2) (* hdj "28-Sep-84 13:31")
(* * Map a function across two arrays. Recognizes the cases that can run in microcode.)
(PROG (ARRAY1SIZE ARRAY1BASE ARRAY2SIZE ARRAY2BASE RESULTBASE)
(* if ARRAY1 is really an array, leave it alone. Otherwise it is a constant; create an array that has each elt equal
to that constant)
[SETQ ARRAY1 (OR (ARRAYP ARRAY1)
(if (ARRAYP ARRAY2)
then (ARRAY (ARRAYSIZE ARRAY2)
(QUOTE FLOATP)
ARRAY1
(ARRAYORIG ARRAY2))
else (HELP "Neither ARRAY1 nor ARRAY2 is an array"]
(* * same, but for ARRAY2)
[SETQ ARRAY2 (OR (ARRAYP ARRAY2)
(if (ARRAYP ARRAY1)
then (ARRAY (ARRAYSIZE ARRAY1)
(QUOTE FLOATP)
ARRAY1
(ARRAYORIG ARRAY1))
else (HELP "Neither ARRAY1 nor ARRAY2 is an array"]
[SETQ RESULT (OR (ARRAYP RESULT)
(ARRAY (ARRAYSIZE ARRAY1)
(QUOTE FLOATP)
0.0
(ARRAYORIG ARRAY1]
(SETQ ARRAY1SIZE (ARRAYSIZE ARRAY1))
(SETQ ARRAY1BASE (ARRAYBASE ARRAY1))
(SETQ ARRAY2SIZE (ARRAYSIZE ARRAY2))
(SETQ ARRAY2BASE (ARRAYBASE ARRAY2))
(SETQ RESULTBASE (ARRAYBASE RESULT))
[SELECTQ MAPFN
(FTIMES (\BLKFTIMES ARRAY1BASE ARRAY2BASE RESULTBASE ARRAY1SIZE))
((PERMUTE ELT)
(\BLKPERM ARRAY1BASE ARRAY2BASE RESULTBASE ARRAY1SIZE))
(FPLUS (\BLKFPLUS ARRAY1BASE ARRAY2BASE RESULTBASE ARRAY1SIZE))
(FDIFF (\BLKFDIFF ARRAY1BASE ARRAY2BASE RESULTBASE ARRAY1SIZE))
(for ELT from 0 to (DOUBLE (SUB1 ARRAY1SIZE)) by 2
do (\PUTBASEFLOATP RESULTBASE ELT (APPLY* MAPFN (\GETBASEFLOATP ARRAY1BASE ELT)
(\GETBASEFLOATP ARRAY2BASE ELT]
(RETURN RESULT])
(EXPANDMAPELT
[LAMBDA (ARGS) (* hdj "28-Sep-84 12:12")
(* * Expands the MAPELT macro. Recognizes when you want MAPELT1 and when you want MAPELT2)
(* * Args looks like "(RESULT MAPFN ARRAY1 {ARRAY2})")
(LET ((ARRAY2 (CADDDR ARGS)))
(if ARRAY2
then (EXPANDMAPELT2 ARGS)
else (EXPANDMAPELT1 ARGS])
(EXPANDMAPELT1
[LAMBDA (ARGS) (* hdj "26-Sep-84 18:50")
(* * Expands the MAPELT macro. Recognizes when MAPFN equals EXPONENT, MAGNITUDE, FLOATSMALLP, COMPLEXIFYFLOATP, or
SEPARATE, and expands into a call on the appropriate opcodes.)
(PROG ((RESULT (CAR ARGS))
(MAPFN (CADR ARGS))
(ARRAY (CADDR ARGS)))
(RETURN (if (OR (EQ (CAR MAPFN)
(QUOTE QUOTE))
(EQ (CAR MAPFN)
(QUOTE FUNCTION)))
then (SELECTQ (CADR MAPFN)
(EXPONENT (RATIONALIZEMAPELT1 RESULT (QUOTE \BLKEXPONENT)
ARRAY))
(MAGNITUDE (RATIONALIZEMAPELT1 RESULT (QUOTE \BLKMAG)
ARRAY))
(FLOATSMALLP (RATIONALIZEMAPELT1 RESULT (QUOTE \BLKSMALLP2FLOAT)
ARRAY))
(COMPLEXIFYFLOATP (RATIONALIZEMAPELT1 RESULT (QUOTE
\BLKFLOATP2COMP)
ARRAY))
[SEPARATE (BQUOTE (PROG ((SIZE (ARRAYSIZE , ARRAY))
RESULT)
[SETQ RESULT
(OR (ARRAYP RESULT)
(ARRAY SIZE (QUOTE FLOATP)
0.0
(ARRAYORIG , ARRAY]
(\BLKSEP (ARRAYBASE , ARRAY)
(\ADDBASE (ARRAYBASE , ARRAY)
(DOUBLE (IDIFFERENCE
SIZE 2)))
(ARRAYBASE , RESULT)
SIZE)
(RETURN RESULT]
(QUOTE IGNOREMACRO))
else (QUOTE IGNOREMACRO])
(EXPANDMAPELT2
[LAMBDA (ARGS) (* hdj "28-Sep-84 11:57")
(* * Expands the MAPELT2 macro. Recognizes when MAPFN equals FTIMES, PERMUTE, ELT, FPLUS, FDIFF, or SEP, and expands
into a call on the appropriate opcodes.)
(LET ((RESULT (CAR ARGS))
(MAPFN (CADR ARGS))
(ARRAY1 (CADDR ARGS))
(ARRAY2 (CADDDR ARGS)))
(if (OR (EQ (CAR MAPFN)
(QUOTE QUOTE))
(EQ (CAR MAPFN)
(QUOTE FUNCTION)))
then (SELECTQ (CADR MAPFN)
(FTIMES (RATIONALIZEMAPELT2 RESULT (QUOTE \BLKFTIMES)
ARRAY1 ARRAY2))
((PERMUTE ELT)
(RATIONALIZEMAPELT2 RESULT (QUOTE \BLKPERM)
ARRAY1 ARRAY2))
(FPLUS (RATIONALIZEMAPELT2 RESULT (QUOTE \BLKFPLUS)
ARRAY1 ARRAY2))
(FDIFF (RATIONALIZEMAPELT2 RESULT (QUOTE \BLKFDIFF)
ARRAY1 ARRAY2))
(QUOTE IGNOREMACRO))
else (QUOTE IGNOREMACRO])
(RATIONALIZEMAPELT1
[LAMBDA (ACTUALRESULT ACTUALMAPFN ACTUALARRAY) (* hdj "28-Sep-84 11:48")
(BQUOTE (LET* [(SIZE (ARRAYSIZE , ACTUALARRAY))
(RESULT (OR (ARRAYP , ACTUALRESULT)
(ARRAY SIZE (QUOTE FLOATP)
0.0
(ARRAYORIG , ACTUALARRAY]
(, ACTUALMAPFN (ARRAYBASE , ACTUALARRAY)
(ARRAYBASE RESULT)
SIZE)
RESULT])
(RATIONALIZEMAPELT2
[LAMBDA (ACTUALRESULT ACTUALMAPFN ACTUALARRAY1 ACTUALARRAY2)
(* hdj "12-Nov-84 17:14")
(BQUOTE (LET* [(SIZE (ARRAYSIZE , ACTUALARRAY1))
(RESULT (OR (ARRAYP , ACTUALRESULT)
(ARRAY SIZE (QUOTE FLOATP)
0.0
(ARRAYORIG , ACTUALARRAY1]
(, ACTUALMAPFN (ARRAYBASE , ACTUALARRAY1)
(ARRAYBASE , ACTUALARRAY2)
(ARRAYBASE RESULT)
SIZE)
RESULT])
)
(DECLARE: EVAL@COMPILE
(PUTPROPS MAPELT MACRO (ARGS (EXPANDMAPELT ARGS)))
(PUTPROPS MAPELT1 MACRO (ARGS (EXPANDMAPELT1 ARGS)))
(PUTPROPS MAPELT2 DMACRO (ARGS (EXPANDMAPELT2 ARGS)))
)
(* * FFT stuff)
(DEFINEQ
(FFTSTEP
[LAMBDA (FFTTABLE) (* hdj "23-Jul-84 23:50")
(\BLT \FFTTABLE FFTTABLE \FFTTABLESIZE)
(\FFTSTEP \FFTTABLE (fetch (FFTTABLE LCNT) of FFTTABLE])
(\FFTSTEP
[LAMBDA (TABLE COUNTLO) (* hdj "25-Sep-84 19:15")
(PROG (X Y)
[with FFTTABLE TABLE (do (with FFTSOURCE (\ADDBASE SOURCE (ITIMES 2 (IPLUS HCNT COUNTLO)))
(SETQ X (FDIFFERENCE (FTIMES C TWIDDLE)
(FTIMES D ITWIDDLE)))
(SETQ Y (FPLUS (FTIMES C ITWIDDLE)
(FTIMES D TWIDDLE)))
(SETCOMPLEX (\ADDBASE ABDEST (IPLUS HCNT COUNTLO))
(FPLUS A X)
(FPLUS B Y))
(SETCOMPLEX (\ADDBASE CDDEST (IPLUS HCNT COUNTLO))
(FDIFFERENCE A X)
(FDIFFERENCE B Y))
(COND
((IGREATERP COUNTLO 0)
(add COUNTLO -4))
((ILEQ HCNT 0) (* return from iteration)
(OR (EQ HCNT 0)
(SHOULDNT))
(RETURN))
(T (SETQ HCNT (IDIFFERENCE HCNT TCNT))
(SETQ COUNTLO (IDIFFERENCE TCNT 4))
(SETQ X (FDIFFERENCE (FTIMES TWIDDLE DELTA)
(FTIMES ITWIDDLE IDELTA)))
(SETQ ITWIDDLE (FPLUS (FTIMES ITWIDDLE DELTA)
(FTIMES TWIDDLE IDELTA)))
(SETQ TWIDDLE X]
(RETURN 0])
)
(PUTPROPS \FFTSTEP DOPVAL (2 FFTSTEP))
[DECLARE: EVAL@COMPILE
(DATATYPE FFTTABLE ((TWIDDLE FLOATP)
(ITWIDDLE FLOATP (* imaginary part of TWIDDLE))
(SOURCE XPOINTER (* virtual address of source array base))
(ABDEST XPOINTER (* virtual address of destination array base)
)
(CDDEST XPOINTER (* midpoint in destination array))
(TCNT WORD (* count of butterfiles with same twiddle x4)
)
(HCNT WORD (* (mod cnt tcnt) high portion of count of butterflies
remaining x4))
(NIL 2 FLOATP (* must have floating complex zero here))
(DELTA FLOATP (* packed complex root of unity to change twiddle)
)
(IDELTA FLOATP (* imaginary part of DELTA))
(LCNT WORD (* (remainder cnt tcnt) low portion of count of
butterflies remaining x4))
(PAD 11 WORD (* padding so that FFTTABLE will never cross page
boundary.))))
(BLOCKRECORD FFTSOURCE ((A FLOATP)
(B FLOATP)
(C FLOATP)
(D FLOATP)))
(BLOCKRECORD COMPLEX ((REAL FLOATP)
(IMAG FLOATP)))
]
(/DECLAREDATATYPE (QUOTE FFTTABLE)
(QUOTE (FLOATP FLOATP XPOINTER XPOINTER XPOINTER WORD WORD FLOATP FLOATP FLOATP
FLOATP WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD)))
(DECLARE: EVAL@COMPILE
(RPAQQ \FFTTABLESIZE 32)
(CONSTANTS \FFTTABLESIZE)
)
(* * UFNs)
(DEFINEQ
(\FLOATBLT
[LAMBDA (SOURCE1 SOURCE2 DEST OPERATION N) (* edited: " 7-OCT-83 17:00")
(for I from 0 to (PLUS N N) by 2 do (\PUTBASEFLOATP DEST I
(SELECTQ N
(0 (FLOATWRAP (\GETBASEFLOATP
SOURCE1 I)))
(1 (FLOATUNWRAP (\GETBASEFLOATP
SOURCE1 I)))
(2 (FLOAT (\GETBASEFIXP SOURCE1 I)))
(3 (\PUTBASEFIXP
DEST I (FIX (\GETBASEFLOATP
SOURCE1 I)))
(GO $$ITERATE))
(4 (FPLUS (\GETBASEFLOATP SOURCE1 I)
(\GETBASEFLOATP SOURCE2 I))
)
(5 (FDIFFERENCE (\GETBASEFLOATP
SOURCE1 I)
(\GETBASEFLOATP
SOURCE2 I)))
(6 (FDIFFERENCE (\GETBASEFLOATP
SOURCE2 I)
(\GETBASEFLOATP
SOURCE1 I)))
[7 (FPLUS (ABS (\GETBASEFLOATP
SOURCE1 I))
(ABS (\GETBASEFLOATP
SOURCE2 I]
[8 (ABS (FDIFFERENCE (\GETBASEFLOATP
SOURCE1 I)
(\GETBASEFLOATP
SOURCE2 I]
[9 (ABS (FPLUS (\GETBASEFLOATP
SOURCE1 I)
(\GETBASEFLOATP
SOURCE2 I]
(16 (FTIMES (\GETBASEFLOATP SOURCE1
I)
(\GETBASEFLOATP SOURCE2
I)))
(SHOULDNT])
)
(PUTPROPS \FLOATBLT DOPVAL (5 FLOATBLT))
(* * For convenience)
(PUTPROPS MAPELT ARGNAMES "RESULT MAPFN ARRAY1")
(PUTPROPS \BLKEXPONENT ARGNAMES (source destination kount))
(PUTPROPS \BLKFDIFF ARGNAMES (source1 source2 dest kount))
(PUTPROPS \BLKFLOATP2COMP ARGNAMES (source destination kount))
(PUTPROPS \BLKFPLUS ARGNAMES (source1 source2 dest kount))
(PUTPROPS \BLKFTIMES ARGNAMES (source1 source2 dest kount))
(PUTPROPS \BLKMAG ARGNAMES (complexArray magnitudeArray kount))
(PUTPROPS \BLKPERM ARGNAMES (orig permutations destination kount))
(PUTPROPS \BLKSEP ARGNAMES (source1 source2 dest kount))
(PUTPROPS \BLKSMALLP2FLOAT ARGNAMES (source destination kount))
(PUTPROPS \IBLT1 ARGNAMES (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth
Kount))
(PUTPROPS \IBLT2 ARGNAMES (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth
Kount))
(DECLARE: EVAL@COMPILE
(PUTPROPS ARRAYHIELT MACRO [(ARRAY)
(IPLUS (ARRAYSIZE ARRAY)
(SUB1 (ARRAYORIG ARRAY])
(PUTPROPS DOUBLE MACRO ((A)
(LLSH A 1)))
(PUTPROPS QUADRUPLE MACRO ((A)
(LLSH A 2)))
)
(DEFINEQ
(ARRAYBASE
[LAMBDA (ARRAY) (* hdj "14-Nov-84 18:16")
(FETCH (ARRAYP BASE) OF ARRAY])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA MAPELT)
)
(PUTPROPS FLOATARRAY COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1234 9697 (MAPELT 1244 . 2497) (MAPELT1 2499 . 3662) (MAPELT2 3664 . 5720) (
EXPANDMAPELT 5722 . 6144) (EXPANDMAPELT1 6146 . 7718) (EXPANDMAPELT2 7720 . 8768) (RATIONALIZEMAPELT1
8770 . 9189) (RATIONALIZEMAPELT2 9191 . 9695)) (9919 11452 (FFTSTEP 9929 . 10153) (\FFTSTEP 10155 .
11450)) (13176 14684 (\FLOATBLT 13186 . 14682)) (15922 16091 (ARRAYBASE 15932 . 16089)))))
STOP