(FILECREATED " 5-Aug-84 02:55:43" {ERIS}<SPEECH>WORK>NEWBOXFTIMES.;13 12921
changes to: (FNS NEW\BOXFTIMES2)
previous date: " 3-Aug-84 18:30:03" {ERIS}<SPEECH>WORK>NEWBOXFTIMES.;10)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT NEWBOXFTIMESCOMS)
(RPAQQ NEWBOXFTIMESCOMS [[DECLARE: EVAL@LOAD DOCOPY FIRST (P (MOVD? (QUOTE \BOXFTIMES2)
(QUOTE OLD\BOXFTIMES2))
(MOVD? (QUOTE \BOXFQUOTIENT)
(QUOTE OLD\BOXFQUOTIENT))
(MOVD? (QUOTE \FDIFFERENCE.UFN)
(QUOTE OLD\FDIFFERENCE.UFN))
(MOVD? (QUOTE \BOXFPLUSDIF)
(QUOTE OLD\BOXFPLUSDIF))
(MOVD? (QUOTE SIN)
(QUOTE OLDSIN))
(MOVD? (QUOTE COS)
(QUOTE OLDCOS]
(FNS COERCETOFLOATARRAY NEW\BOXFPLUSDIF NEW\BOXFQUOTIENT NEW\BOXFTIMES2
NEW\FDIFFERENCE.UFN GENVEC NEWCOS NEWSIN NUMARRAYTYP)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE NEW\BOXFTIMES2)
(QUOTE \BOXFTIMES2))
(MOVD (QUOTE NEW\BOXFQUOTIENT)
(QUOTE \BOXFQUOTIENT))
(MOVD (QUOTE NEW\FDIFFERENCE.UFN)
(QUOTE \FDIFFERENCE.UFN))
(MOVD (QUOTE NEW\BOXFPLUSDIF)
(QUOTE \BOXFPLUSDIF))
(MOVD (QUOTE NEWSIN)
(QUOTE SIN))
(MOVD (QUOTE NEWCOS)
(QUOTE COS])
(DECLARE: EVAL@LOAD DOCOPY FIRST
(MOVD? (QUOTE \BOXFTIMES2)
(QUOTE OLD\BOXFTIMES2))
(MOVD? (QUOTE \BOXFQUOTIENT)
(QUOTE OLD\BOXFQUOTIENT))
(MOVD? (QUOTE \FDIFFERENCE.UFN)
(QUOTE OLD\FDIFFERENCE.UFN))
(MOVD? (QUOTE \BOXFPLUSDIF)
(QUOTE OLD\BOXFPLUSDIF))
(MOVD? (QUOTE SIN)
(QUOTE OLDSIN))
(MOVD? (QUOTE COS)
(QUOTE OLDCOS))
)
(DEFINEQ
(COERCETOFLOATARRAY
[LAMBDA (A) (* rmk: " 2-Aug-84 22:06")
(* Assumes A is an array, not of floatps. If it is some form of integer array, the result will be a float array
with coerced values. Otherwise NIL.)
(SELECTQ (ARRAYTYP A)
((BYTE SMALLPOSP FIXP BIT)
(for I (RESULT ←(ARRAY (ARRAYSIZE A)
(QUOTE FLOATP)
NIL
(ARRAYORIG A)))
from (ARRAYORIG A) to (IPLUS (ARRAYSIZE A)
(SUB1 (ARRAYORIG A)))
do (SETA RESULT I (FLOAT (ELT A I))) finally (RETURN RESULT)))
NIL])
(NEW\BOXFPLUSDIF
[LAMBDA (X Y SUBTRACT) (* rmk: " 3-Aug-84 17:49")
(PROG (RESULT SIZE COERCEDX COERCEDY)
(RETURN (COND
([AND (ARRAYP X)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP X))
(SETQ COERCEDX (COERCETOFLOATARRAY X]
(COND
([AND (ARRAYP Y)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP Y))
(SETQ COERCEDY (COERCETOFLOATARRAY Y]
(* Both floating point arrays)
(OR (AND (EQ (SETQ SIZE (ARRAYSIZE X))
(ARRAYSIZE Y))
(EQ (ARRAYORIG X)
(ARRAYORIG Y)))
(ERROR "NONCONFORMABLE ARRAYS" (LIST X Y)))
[SETQ RESULT (OR COERCEDX COERCEDY (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(OR COERCEDX (SETQ COERCEDX X))
(OR COERCEDY (SETQ COERCEDY Y))
[for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FPLUS (ELT COERCEDX I)
(ELT COERCEDY I]
RESULT)
(T (SETQ SIZE (ARRAYSIZE X))
[SETQ RESULT (OR COERCEDX (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(for I (YFLOAT ←(FLOAT Y)) from (ARRAYORIG X)
to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FPLUS (ELT (OR COERCEDX X)
I)
YFLOAT)))
RESULT)))
((AND (ARRAYP Y)
(NUMARRAYTYP Y))
(SETQ RESULT (ARRAY (ARRAYSIZE Y)
(QUOTE FLOATP)
NIL
(ARRAYORIG Y)))
[for I (XFLOAT ←(FLOAT X)) from (ARRAYORIG Y)
to (IPLUS (ARRAYSIZE Y)
(SUB1 (ARRAYORIG Y)))
do (for I from 1 to (ARRAYSIZE Y) do (SETA RESULT I (FPLUS XFLOAT
(ELT Y I]
RESULT)
(T (OLD\BOXFPLUSDIF X Y])
(NEW\BOXFQUOTIENT
[LAMBDA (X Y BOX) (* rmk: " 3-Aug-84 17:39")
(PROG (RESULT SIZE COERCEDX COERCEDY)
(RETURN (COND
([AND (ARRAYP X)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP X))
(SETQ COERCEDX (COERCETOFLOATARRAY X]
(COND
([AND (ARRAYP Y)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP Y))
(SETQ COERCEDY (COERCETOFLOATARRAY Y]
(* Both floating point arrays)
(OR (AND (EQ (SETQ SIZE (ARRAYSIZE X))
(ARRAYSIZE Y))
(EQ (ARRAYORIG X)
(ARRAYORIG Y)))
(ERROR "NONCONFORMABLE ARRAYS" (LIST X Y)))
[SETQ RESULT (OR COERCEDX COERCEDY (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(OR COERCEDX (SETQ COERCEDX X))
(OR COERCEDY (SETQ COERCEDY Y))
[for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FQUOTIENT (ELT COERCEDX I)
(ELT COERCEDY I]
RESULT)
(T (SETQ SIZE (ARRAYSIZE X))
[SETQ RESULT (OR COERCEDX (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(for I (YFLOAT ←(FLOAT Y)) from (ARRAYORIG X)
to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FQUOTIENT (ELT (OR COERCEDX X)
I)
YFLOAT)))
RESULT)))
((AND (ARRAYP Y)
(NUMARRAYTYP Y))
(SETQ RESULT (ARRAY (ARRAYSIZE Y)
(QUOTE FLOATP)
NIL
(ARRAYORIG Y)))
[for I (XFLOAT ←(FLOAT X)) from (ARRAYORIG Y)
to (IPLUS (ARRAYSIZE Y)
(SUB1 (ARRAYORIG Y)))
do (for I from 1 to (ARRAYSIZE Y) do (SETA RESULT I (FQUOTIENT XFLOAT
(ELT Y I]
RESULT)
(T (OLD\BOXFQUOTIENT X Y BOX])
(NEW\BOXFTIMES2
[LAMBDA (X Y BOX) (* hdj " 5-Aug-84 02:52")
(PROG (RESULT SIZE COERCEDX COERCEDY)
(RETURN (COND
([AND (ARRAYP X)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP X))
(SETQ COERCEDX (COERCETOFLOATARRAY X]
(COND
([AND (ARRAYP Y)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP Y))
(SETQ COERCEDY (COERCETOFLOATARRAY Y]
(* Both floating point arrays)
(OR (AND (EQ (SETQ SIZE (ARRAYSIZE X))
(ARRAYSIZE Y))
(EQ (ARRAYORIG X)
(ARRAYORIG Y)))
(ERROR "NONCONFORMABLE ARRAYS" (LIST X Y)))
(\BLKFTIMES (fetch (ARRAYP BASE) of (OR COERCEDX X))
(fetch (ARRAYP BASE) of (OR COERCEDY Y))
[fetch (ARRAYP BASE) of (SETQ RESULT
(OR COERCEDX COERCEDY
(ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
SIZE)
RESULT)
(T (SETQ SIZE (ARRAYSIZE X))
[SETQ RESULT (OR COERCEDX (ARRAY SIZE (QUOTE FLOATP)
(FLOAT Y)
(ARRAYORIG X]
(\BLKFTIMES (fetch (ARRAYP BASE) of X)
(fetch (ARRAYP BASE) of RESULT)
(fetch (ARRAYP BASE) of RESULT)
SIZE)
RESULT)))
((AND (ARRAYP Y)
(NUMARRAYTYP Y))
(SETQ SIZE (ARRAYSIZE Y))
(SETQ RESULT (ARRAY (ARRAYSIZE Y)
(QUOTE FLOATP)
(FLOAT X)
(ARRAYORIG Y)))
(\BLKFTIMES (fetch (ARRAYP BASE) of RESULT)
(fetch (ARRAYP BASE) of Y)
(fetch (ARRAYP BASE) of RESULT)
SIZE)
RESULT)
(T (OLD\BOXFTIMES2 X Y BOX])
(NEW\FDIFFERENCE.UFN
[LAMBDA (X Y) (* rmk: " 3-Aug-84 17:48")
(PROG (RESULT SIZE COERCEDX COERCEDY)
(RETURN (COND
([AND (ARRAYP X)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP X))
(SETQ COERCEDX (COERCETOFLOATARRAY X]
(COND
([AND (ARRAYP Y)
(OR (EQ (QUOTE FLOATP)
(ARRAYTYP Y))
(SETQ COERCEDY (COERCETOFLOATARRAY Y]
(* Both floating point arrays)
(OR (AND (EQ (SETQ SIZE (ARRAYSIZE X))
(ARRAYSIZE Y))
(EQ (ARRAYORIG X)
(ARRAYORIG Y)))
(ERROR "NONCONFORMABLE ARRAYS" (LIST X Y)))
[SETQ RESULT (OR COERCEDX COERCEDY (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(OR COERCEDX (SETQ COERCEDX X))
(OR COERCEDY (SETQ COERCEDY Y))
[for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FDIFFERENCE (ELT COERCEDX I)
(ELT COERCEDY I]
RESULT)
(T (SETQ SIZE (ARRAYSIZE X))
[SETQ RESULT (OR COERCEDX (ARRAY SIZE (QUOTE FLOATP)
NIL
(ARRAYORIG X]
(for I (YFLOAT ←(FLOAT Y)) from (ARRAYORIG X)
to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (FDIFFERENCE (ELT (OR COERCEDX X)
I)
YFLOAT)))
RESULT)))
((AND (ARRAYP Y)
(NUMARRAYTYP Y))
(SETQ RESULT (ARRAY (ARRAYSIZE Y)
(QUOTE FLOATP)
NIL
(ARRAYORIG Y)))
[for I (XFLOAT ←(FLOAT X)) from (ARRAYORIG Y)
to (IPLUS (ARRAYSIZE Y)
(SUB1 (ARRAYORIG Y)))
do (for I from 1 to (ARRAYSIZE Y) do (SETA RESULT I (FDIFFERENCE
XFLOAT
(ELT Y I]
RESULT)
(T (OLD\BOXFPLUSDIF X Y T])
(GENVEC
[LAMBDA (INITIAL END BY ORIG) (* rmk: " 3-Aug-84 18:28")
(* Generates sequences of numbers)
(PROG ((N NIL)
(GV NIL))
(COND
((NULL END)
(SETQ END INITIAL)
(SETQ INITIAL 1)))
(OR BY (SETQ BY (if (GREATERP END INITIAL)
then 1
else -1)))
[SETQ N (ADD1 (FIX (QUOTIENT (DIFFERENCE END INITIAL)
BY]
(if (ILESSP N 1)
then (ERROR "Inconsistent increment and bounds"))
[SETQ GV (if (OR (FLOATP INITIAL)
(FLOATP END)
(FLOATP BY))
then (bind SF (ROW ←(ARRAY N (QUOTE FLOATP)
NIL ORIG))
(DBY ←(FLOAT BY)) for I from (OR ORIG 1)
to (COND
(ORIG (SUB1 N))
(T N))
first (SETQ SF (FDIFFERENCE (FLOAT INITIAL)
DBY))
do [SETA ROW I (FPLUS SF (FTIMES DBY (FLOAT I]
(* Done by multip so as to prevent accumulation of
roundoff error)
finally (RETURN ROW))
else (bind (VAL ← INITIAL)
(ROW ←(ARRAY N (QUOTE FIXP)
NIL ORIG))
for I from (OR ORIG 1) to (COND
(ORIG (SUB1 N))
(T N))
do (SETA ROW I VAL)
(add VAL BY)
finally (RETURN ROW]
(RETURN GV])
(NEWCOS
[LAMBDA (X RADIANSFLG) (* rmk: " 3-Aug-84 18:21")
(IF (AND (ARRAYP X)
(NUMARRAYTYP X))
THEN (PROG (RESULT (SIZE (ARRAYSIZE X)))
(SETQ RESULT (ARRAY SIZE (QUOTE FLOATP)))
(for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (OLDCOS (ELT X I)
RADIANSFLG)))
(RETURN RESULT))
ELSE (OLDCOS X RADIANSFLG])
(NEWSIN
[LAMBDA (X RADIANSFLG) (* rmk: " 3-Aug-84 18:21")
(IF (AND (ARRAYP X)
(NUMARRAYTYP X))
THEN (PROG (RESULT (SIZE (ARRAYSIZE X)))
(SETQ RESULT (ARRAY SIZE (QUOTE FLOATP)))
(for I from (ARRAYORIG X) to (IPLUS SIZE (SUB1 (ARRAYORIG X)))
do (SETA RESULT I (OLDSIN (ELT X I)
RADIANSFLG)))
(RETURN RESULT))
ELSE (OLDSIN X RADIANSFLG])
(NUMARRAYTYP
[LAMBDA (A) (* rmk: " 2-Aug-84 22:12")
(* T if A is a numeric array)
(SELECTQ (ARRAYTYP A)
((FLOATP BYTE SMALLPOSP FIXP BIT)
T)
NIL])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD (QUOTE NEW\BOXFTIMES2)
(QUOTE \BOXFTIMES2))
(MOVD (QUOTE NEW\BOXFQUOTIENT)
(QUOTE \BOXFQUOTIENT))
(MOVD (QUOTE NEW\FDIFFERENCE.UFN)
(QUOTE \FDIFFERENCE.UFN))
(MOVD (QUOTE NEW\BOXFPLUSDIF)
(QUOTE \BOXFPLUSDIF))
(MOVD (QUOTE NEWSIN)
(QUOTE SIN))
(MOVD (QUOTE NEWCOS)
(QUOTE COS))
)
(PUTPROPS NEWBOXFTIMES COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1727 12484 (COERCETOFLOATARRAY 1737 . 2375) (NEW\BOXFPLUSDIF 2377 . 4230) (
NEW\BOXFQUOTIENT 4232 . 6091) (NEW\BOXFTIMES2 6093 . 7842) (NEW\FDIFFERENCE.UFN 7844 . 9732) (GENVEC
9734 . 11224) (NEWCOS 11226 . 11706) (NEWSIN 11708 . 12188) (NUMARRAYTYP 12190 . 12482)))))
STOP