(FILECREATED " 2-Apr-86 23:21:32" {QV}<IDL>SOURCES>USERARITH.;26 18646
changes to: (FNS IDLCOS IDLLOG IDLANTILOG IDLABS IDLMINUS IDLSQRT)
previous date: "16-Feb-86 17:16:13" {QV}<IDL>SOURCES>USERARITH.;25)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT USERARITHCOMS)
(RPAQQ USERARITHCOMS [(* loading this file will redefine most arithmetic functions to accept idl
objects. punt functions are also redefined to handle the compiled case.)
(DECLARE: FIRST (VARS USERARITHFNS))
(FNS * USERARITHFNS)
(FNS * UTILFNS)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVEARITHFNS USERARITHFNS)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA IDLTIMES IDLPLUS IDLMIN IDLMAX])
(* loading this file will redefine most arithmetic functions to accept idl objects. punt
functions are also redefined to handle the compiled case.)
(DECLARE: FIRST
(RPAQQ USERARITHFNS (IDLABS IDLANTILOG IDLARCCOS IDLARCSIN IDLARCTAN IDLARCTAN2 IDLCOS
IDLDIFFERENCE IDLEQP IDLEXPT IDLGCD IDLGREATERP IDLLESSP IDLLOG IDLMAX
IDLMIN IDLMINUS IDLMINUSP IDLPLUS IDLQUOTIENT IDLRAND IDLREMAINDER
IDLSIN IDLSQRT IDLTAN IDLTIMES IDL\SLOWDIFFERENCE IDL\SLOWPLUS2
IDL\SLOWQUOTIENT IDL\SLOWTIMES2))
)
(RPAQQ USERARITHFNS (IDLABS IDLANTILOG IDLARCCOS IDLARCSIN IDLARCTAN IDLARCTAN2 IDLCOS
IDLDIFFERENCE IDLEQP IDLEXPT IDLGCD IDLGREATERP IDLLESSP IDLLOG IDLMAX
IDLMIN IDLMINUS IDLMINUSP IDLPLUS IDLQUOTIENT IDLRAND IDLREMAINDER
IDLSIN IDLSQRT IDLTAN IDLTIMES IDL\SLOWDIFFERENCE IDL\SLOWPLUS2
IDL\SLOWQUOTIENT IDL\SLOWTIMES2))
(DEFINEQ
(IDLABS
[LAMBDA (X) (* jop: " 2-Apr-86 20:50")
(if (type? ARRAY X)
then (UENTRY (QUOTE ABS)
(EAPPLY* [FUNCTION (LAMBDA (X)
(AND (SETQ X (CONV.SCALAR X))
(ABS.LISP X]
(QUOTE (SCALAR))
X))
else (AND X (ABS.LISP X])
(IDLANTILOG
[LAMBDA (X) (* jop: " 2-Apr-86 20:48")
(if (type? ARRAY X)
then (UENTRY (QUOTE ANTILOG)
(EAPPLY* [FUNCTION (LAMBDA (X)
(AND (SETQ X (CONV.SCALAR X))
(ANTILOG.LISP X]
(QUOTE (SCALAR))
X))
else (AND X (ANTILOG.LISP X])
(IDLARCCOS
[LAMBDA (X RADIANSFLG) (* edited: "16-Feb-86 14:30")
(if (type? ARRAY X)
then (UENTRY (QUOTE ARCCOS)
(EAPPLY* [FUNCTION (LAMBDA (X RADIANSFLG)
(SETQ X (CONV.SCALAR X))
(AND X (ARCCOS.LISP X RADIANSFLG]
(QUOTE (SCALAR))
X RADIANSFLG))
else (AND X (ARCCOS.LISP X RADIANSFLG])
(IDLARCSIN
[LAMBDA (X RADIANSFLG) (* edited: "16-Feb-86 14:29")
(if (type? ARRAY X)
then (UENTRY (QUOTE ARCSIN)
(EAPPLY* [FUNCTION (LAMBDA (X RADIANSFLG)
(SETQ X (CONV.SCALAR X))
(AND X (ARCSIN.LISP X RADIANSFLG]
(QUOTE (SCALAR))
X RADIANSFLG))
else (AND X (ARCSIN.LISP X RADIANSFLG])
(IDLARCTAN
[LAMBDA (X RADIANSFLG) (* edited: "16-Feb-86 14:29")
(if (type? ARRAY X)
then (UENTRY (QUOTE ARCTAN)
(EAPPLY* [FUNCTION (LAMBDA (X RADIANSFLG)
(SETQ X (CONV.SCALAR X))
(AND X (ARCTAN.LISP X RADIANSFLG]
(QUOTE (SCALAR))
X RADIANSFLG))
else (AND X (ARCTAN.LISP X RADIANSFLG])
(IDLARCTAN2
[LAMBDA (X Y RADIANSFLG) (* edited: "16-Feb-86 14:32")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE ARCTAN2)
(EAPPLY* [FUNCTION (LAMBDA (X Y RADIANSFLG)
(SETQ X (CONV.SCALAR X))
(SETQ Y (CONV.SCALAR Y))
(AND X Y (ARCTAN2.LISP X Y RADIANSFLG]
(QUOTE (SCALAR SCALAR))
X Y RADIANSFLG))
else (AND X Y (ARCTAN2.LISP X Y RADIANSFLG])
(IDLCOS
[LAMBDA (X RADIANSFLG) (* jop: " 2-Apr-86 20:39")
(if (type? ARRAY X)
then (UENTRY (QUOTE COS)
(EAPPLY* [FUNCTION (LAMBDA (X RADIANSFLG)
(SETQ X (CONV.SCALAR X))
(AND X (COS.LISP X RADIANSFLG]
(QUOTE (SCALAR))
X RADIANSFLG))
else (AND X (COS.LISP X RADIANSFLG])
(IDLDIFFERENCE
[ULAMBDA ((X (EXPECTS SCALAR))
(Y (EXPECTS SCALAR)))
(* edited: "16-Feb-86 17:07")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE DIFFERENCE)
(EAPPLY* [FUNCTION (LAMBDA (X Y)
(SETQ X (CONV.SCALAR X))
(SETQ Y (CONV.SCALAR Y))
(AND X Y (DIFFERENCE.LISP X Y]
(QUOTE (SCALAR SCALAR))
X Y))
else (AND X Y (DIFFERENCE.LISP X Y)))])
(IDLEQP
[LAMBDA (X Y) (* edited: "16-Feb-86 15:43" posted: "10-OCT-77 22:04"
)
(* Not extended cause it's a predicate. Does the EQP.LISP before coercion because EQP.LISP also works on stack
pointers. Coercion under UERRORGUARD cause EQP.LISP is defined in system not to cause an error on non-numeric
data.)
(OR (EQP.LISP X Y)
(UENTRY (QUOTE EQP)
(AND [NOT (UERRORGUARD (PROGN (SETQ X (CONV.SCALAR X))
(SETQ Y (CONV.SCALAR Y]
(EQP.LISP X Y])
(IDLEXPT
[LAMBDA (A N) (* edited: "16-Feb-86 17:07")
(if (OR (type? ARRAY A)
(type? ARRAY N))
then (UENTRY (QUOTE EXPT)
(EAPPLY* [FUNCTION (LAMBDA (A N)
(SETQ A (CONV.SCALAR A))
(SETQ N (CONV.SCALAR N))
(AND A N (EXPT.LISP A N]
(QUOTE (SCALAR SCALAR))
A N))
else (AND A N (EXPT.LISP A N])
(IDLGCD
[LAMBDA (X Y) (* edited: "16-Feb-86 14:38")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE GCD)
(EAPPLY* [FUNCTION (LAMBDA (X Y)
(AND X Y (GCD.LISP X Y]
(QUOTE (SCALAR SCALAR))
X Y))
else (AND X Y (GCD.LISP X Y])
(IDLGREATERP
[LAMBDA (X Y) (* edited: "16-Feb-86 17:13" posted: "10-OCT-77 21:59"
) (* A predicate, so not extended)
(UENTRY (QUOTE GREATERP)
[UERRORGUARD (PROGN (SETQ X (CONV.SCALAR X))
(SETQ Y (CONV.SCALAR Y]
(OR X (SETQ X 0))
(OR Y (SETQ X 0))
(if (AND (FIXP X)
(FIXP Y))
then (IGREATERP X Y)
else (FGREATERP X Y])
(IDLLESSP
[LAMBDA (X Y) (* edited: "16-Feb-86 17:15" posted: "10-OCT-77 21:59"
) (* A predicate, so not extended)
(UENTRY (QUOTE LESSP)
[UERRORGUARD (PROGN (SETQ X (CONV.SCALAR X))
(SETQ Y (CONV.SCALAR Y]
(LESSP.LISP (OR X 0)
(OR Y 0])
(IDLLOG
[LAMBDA (X) (* jop: " 2-Apr-86 20:47")
(if (type? ARRAY X)
then (UENTRY (QUOTE LOG)
(EAPPLY* [FUNCTION (LAMBDA (X)
(AND (SETQ X (CONV.SCALAR X))
(LOG.LISP X]
(QUOTE (SCALAR))
X))
else (AND X (LOG.LISP X])
(IDLMAX
[LAMBDA NARGS (* edited: "16-Feb-86 15:24")
(if [AND (EQ NARGS 2)
(for I from 1 to NARGS never (OR (NULL (ARG NARGS I))
(type? ARRAY (ARG NARGS I]
then (MAX.LISP (ARG NARGS 1)
(ARG NARGS 2))
else (UENTRY (QUOTE MAX)
(if (IGREATERP NARGS 0)
then (EAPPLY [FUNCTION (LAMBDA NARGS
(bind V MAX for I from 1 to NARGS
when (AND (SETQ V (CONV.SCALAR (ARG NARGS
I)))
(OR (NULL MAX)
(GREATERP.LISP V MAX)))
do (SETQ MAX V) finally (RETURN MAX]
(QUOTE (SCALAR ...))
(for I to NARGS collect (ARG NARGS I])
(IDLMIN
[LAMBDA NARGS (* edited: "16-Feb-86 15:24")
(if [AND (EQ NARGS 2)
(for I from 1 to NARGS never (OR (NULL (ARG NARGS I))
(type? ARRAY (ARG NARGS I]
then (MIN.LISP (ARG NARGS 1)
(ARG NARGS 2))
else (UENTRY (QUOTE MIN)
(if (IGREATERP NARGS 0)
then (EAPPLY [FUNCTION (LAMBDA NARGS
(for I V MIN to NARGS
when (AND (SETQ V (CONV.SCALAR (ARG NARGS
I)))
(OR (NULL MIN)
(GREATERP.LISP MIN V)))
do (SETQ MIN V) finally (RETURN MIN]
(QUOTE (SCALAR ...))
(for I to NARGS collect (ARG NARGS I])
(IDLMINUS
[LAMBDA (X) (* jop: " 2-Apr-86 20:50")
(if (type? ARRAY X)
then (UENTRY (QUOTE MINUS)
(EAPPLY* [FUNCTION (LAMBDA (X)
(AND (SETQ X (CONV.SCALAR X))
(MINUS.LISP X]
(QUOTE (SCALAR))
X))
else (AND X (MINUS.LISP X])
(IDLMINUSP
[LAMBDA (X) (* edited: "16-Feb-86 15:28")
(* IDLMINUSP modified to handle scalars.)
(UENTRY (QUOTE MINUSP)
(UERRORGUARD (SETQ X (CONV.SCALAR X)))
(AND X (GREATERP.LISP 0 X])
(IDLPLUS
[LAMBDA NARGS (* edited: "16-Feb-86 15:42")
(if [AND (EQ NARGS 2)
(for I from 1 to NARGS never (OR (NULL (ARG NARGS I))
(type? ARRAY (ARG NARGS I]
then (PLUS.LISP (ARG NARGS 1)
(ARG NARGS 2))
else (UENTRY (QUOTE PLUS)
(EAPPLY [FUNCTION (LAMBDA NARGS
(for I V (SUM ← 0) to NARGS
do (if (SETQ V (CONV.SCALAR (ARG NARGS I)))
then (SETQ SUM (PLUS.LISP SUM V))
else (RETURN NIL))
finally (RETURN SUM]
(QUOTE (SCALAR ...))
(for I to NARGS collect (ARG NARGS I])
(IDLQUOTIENT
[LAMBDA (X Y) (* edited: "16-Feb-86 17:06")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE QUOTIENT)
(EAPPLY* [FUNCTION (LAMBDA (X Y)
(SETQ X (CONV.SCALAR X))
(SETQ Y (CONV.SCALAR Y))
(AND X Y (FQUOTIENT X Y]
(QUOTE (SCALAR SCALAR))
X Y))
else (AND X Y (QUOTIENT.LISP X Y])
(IDLRAND
[LAMBDA (LOWER UPPER) (* edited: "16-Feb-86 15:51")
(* Difficult case since either LOWER may have default
values of NIL)
(if (OR (type? ARRAY LOWER)
(type? ARRAY UPPER))
then (UENTRY (QUOTE RAND)
(EAPPLY* (FUNCTION [LAMBDA (LOWER UPPER)
(RAND.LISP LOWER UPPER])
(QUOTE (SCALAR SCALAR))
LOWER UPPER))
else (RAND.LISP LOWER UPPER])
(IDLREMAINDER
[LAMBDA (X Y) (* edited: "16-Feb-86 17:08")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE REMAINDER)
(EAPPLY* [FUNCTION (LAMBDA (X Y)
(SETQ X (CONV.SCALAR X))
(SETQ Y (CONV.SCALAR Y))
(AND X Y (REMAINDER.LISP X Y]
(QUOTE (SCALAR SCALAR))
X Y))
else (AND X Y (REMAINDER.LISP X Y])
(IDLSIN
[LAMBDA (X RADIANSFLG) (* edited: "16-Feb-86 15:53")
(if (type? ARRAY X)
then (UENTRY (QUOTE SIN)
(EAPPLY* [FUNCTION (LAMBDA (X RADIANSFLG)
(SETQ X (CONV.SCALAR X))
(AND X (SIN.LISP X RADIANSFLG]
(QUOTE (SCALAR))
X RADIANSFLG))
else (AND X (SIN.LISP X RADIANSFLG])
(IDLSQRT
[LAMBDA (X) (* jop: " 2-Apr-86 20:51")
(if (type? ARRAY X)
then (UENTRY (QUOTE SQRT)
(EAPPLY* [FUNCTION (LAMBDA (X)
(AND (SETQ X (CONV.SCALAR X))
(SQRT.LISP X]
(QUOTE (SCALAR))
X))
else (AND X (SQRT.LISP X])
(IDLTAN
[LAMBDA (X RADIANSFLG) (* edited: "16-Feb-86 15:55")
(if (type? ARRAY X)
then (UENTRY (QUOTE TAN)
(EAPPLY* [FUNCTION (LAMBDA (X RADIANSFLG)
(SETQ X (CONV.SCALAR X))
(AND X (TAN.LISP X RADIANSFLG]
(QUOTE (SCALAR))
X RADIANSFLG))
else (AND X (TAN.LISP X RADIANSFLG])
(IDLTIMES
[LAMBDA NARGS (* edited: "16-Feb-86 15:56")
(if [AND (EQ NARGS 2)
(for I from 1 to NARGS never (OR (NULL (ARG NARGS I))
(type? ARRAY (ARG NARGS I]
then (TIMES.LISP (ARG NARGS 1)
(ARG NARGS 2))
else (UENTRY (QUOTE TIMES)
(EAPPLY [FUNCTION (LAMBDA NARGS
(for I V (PROD ← 1) to NARGS
do (if (SETQ V (CONV.SCALAR (ARG NARGS I)))
then (SETQ PROD (TIMES.LISP PROD V))
else (RETURN NIL))
finally (RETURN PROD]
(QUOTE (SCALAR ...))
(for I to NARGS collect (ARG NARGS I])
(IDL\SLOWDIFFERENCE
[LAMBDA (X Y) (* edited: "16-Feb-86 15:58")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE DIFFERENCE)
(EAPPLY* [FUNCTION (LAMBDA (XX YY)
(if (AND (SETQ XX (CONV.SCALAR XX))
(SETQ YY (CONV.SCALAR YY)))
then (DIFFERENCE.LISP XX YY]
(QUOTE (SCALAR SCALAR))
X Y))
elseif (AND X Y)
then (\SLOWDIFFERENCE.LISP X Y])
(IDL\SLOWPLUS2
[LAMBDA (X Y) (* edited: "16-Feb-86 15:59")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE PLUS)
(EAPPLY* [FUNCTION (LAMBDA (XX YY)
(if (AND (SETQ XX (CONV.SCALAR XX))
(SETQ YY (CONV.SCALAR YY)))
then (PLUS.LISP XX YY]
(QUOTE (SCALAR SCALAR))
X Y))
elseif (AND X Y)
then (\SLOWPLUS2.LISP X Y])
(IDL\SLOWQUOTIENT
[LAMBDA (X Y) (* edited: "16-Feb-86 16:01")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE QUOTIENT)
(EAPPLY* [FUNCTION (LAMBDA (XX YY)
(if (AND (SETQ XX (CONV.SCALAR XX))
(SETQ YY (CONV.SCALAR YY)))
then (FQUOTIENT XX YY]
(QUOTE (SCALAR SCALAR))
X Y))
elseif (AND X Y)
then (\SLOWQUOTIENT.LISP X Y])
(IDL\SLOWTIMES2
[LAMBDA (X Y) (* edited: "16-Feb-86 16:02")
(if (OR (type? ARRAY X)
(type? ARRAY Y))
then (UENTRY (QUOTE TIMES)
(EAPPLY* [FUNCTION (LAMBDA (XX YY)
(if (AND (SETQ XX (CONV.SCALAR XX))
(SETQ YY (CONV.SCALAR YY)))
then (TIMES.LISP XX YY]
(QUOTE (SCALAR SCALAR))
X Y))
elseif (AND X Y)
then (\SLOWTIMES2.LISP X Y])
)
(RPAQQ UTILFNS (MOVEARITHFNS))
(DEFINEQ
(MOVEARITHFNS
[LAMBDA (IDLFNS) (* edited: "16-Feb-86 16:25" posted: " 5-OCT-77 21:30"
)
(* * Moves definition of arithmetic functions to NAME.LISP. IDLFNS will be a list of names of the form IDLNAME)
(bind (COMPPROPS ←(QUOTE (DOPVAL DMACRO BYTEMACRO)))
LISPFN NEWNAME for IDLFN in IDLFNS
do (SETQ LISPFN (SUBATOM IDLFN 4))
(SETQ NEWNAME (PACK* LISPFN (QUOTE .LISP)))
(if (AND (LITATOM LISPFN)
(GETD LISPFN))
then (if (NULL (GETD NEWNAME))
then (MOVD LISPFN NEWNAME)) (* Move compiler props)
(bind PROPVAL for PROP in COMPPROPS
do (SETQ PROPVAL (GETPROP LISPFN PROP))
(if PROPVAL
then (PUTPROP NEWNAME PROP PROPVAL)))
else (PRINTOUT T "**Note: Lispfn" ,, LISPFN , "was not defined!" T))
(if (AND (LITATOM IDLFN)
(GETD IDLFN))
then (MOVD IDLFN LISPFN)
else (PRINTOUT T "**Note: IDLfn" ,, IDLFN , "was not defined!" T])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVEARITHFNS USERARITHFNS)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA IDLTIMES IDLPLUS IDLMIN IDLMAX)
)
(PUTPROPS USERARITH COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1735 17150 (IDLABS 1745 . 2122) (IDLANTILOG 2124 . 2517) (IDLARCCOS 2519 . 2957) (
IDLARCSIN 2959 . 3397) (IDLARCTAN 3399 . 3837) (IDLARCTAN2 3839 . 4374) (IDLCOS 4376 . 4799) (
IDLDIFFERENCE 4801 . 5374) (IDLEQP 5376 . 5979) (IDLEXPT 5981 . 6460) (IDLGCD 6462 . 6851) (
IDLGREATERP 6853 . 7406) (IDLLESSP 7408 . 7825) (IDLLOG 7827 . 8204) (IDLMAX 8206 . 9065) (IDLMIN 9067
. 9906) (IDLMINUS 9908 . 10297) (IDLMINUSP 10299 . 10639) (IDLPLUS 10641 . 11428) (IDLQUOTIENT 11430
. 11921) (IDLRAND 11923 . 12482) (IDLREMAINDER 12484 . 12983) (IDLSIN 12985 . 13411) (IDLSQRT 13413
. 13794) (IDLTAN 13796 . 14222) (IDLTIMES 14224 . 15016) (IDL\SLOWDIFFERENCE 15018 . 15562) (
IDL\SLOWPLUS2 15564 . 16086) (IDL\SLOWQUOTIENT 16088 . 16620) (IDL\SLOWTIMES2 16622 . 17148)) (17187
18332 (MOVEARITHFNS 17197 . 18330)))))
STOP