(FILECREATED " 4-Sep-85 13:10:13" {QV}<IDL>SOURCES>CONV.;8 14793
changes to: (VARS CONVCOMS)
previous date: " 3-Sep-85 17:24:04" {QV}<IDL>SOURCES>CONV.;7)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CONVCOMS)
(RPAQQ CONVCOMS [(* Conversion functions: A function with name CONV.XXX will take its argument and
convert it to an xxx or return it if it is already of that form.)
(FNS CONV.ARITH CONV.ARRAY CONV.NARRAY CONV.NARRAY1 CONV.ROWFLOAT CONV.ROWINT
CONV.ROWSCALAR CONV.SCALAR CONV.SIMARRAY CONV.VECTOR LISPNUMBER)
(IF: (NOT TESTSYS)
(ADDVARS (ERRORTYPELST (10 (LISPNUMBER (CADR ERRORMESS])
(* Conversion functions: A function with name CONV.XXX will take its argument and convert it to
an xxx or return it if it is already of that form.)
(DEFINEQ
(CONV.ARITH
[DLAMBDA (A
(RETURNS ARITH))
(* bas: "31-MAY-78 12:08")
(* like conv.scalar but never returns NIL)
(OR (CONV.SCALAR A)
(UERROR "Invalid numeric data: " .P2 A))])
(CONV.ARRAY
[DLAMBDA (A
(RETURNS ARRAY))
(* rmk: "13-AUG-78 23:32" posted: "18-JUN-78 23:53")
(* Makes an array out of its arguments -
uses CONV.ROWSCALAR or CONV.NARRAY)
(if (type? ARRAY A)
then A
else (DPROG ((TEMP NIL ARRAY))
(if (AND (UERRORGUARD TEMP←(VFROMR (CONV.ROWSCALAR A)))
(UERRORGUARD TEMP←(CONV.NARRAY A)))
then (UERROR "Invalid array: " .P2 A))
(RETURN TEMP)))])
(CONV.NARRAY
[DLAMBDA (DATA
(LABSOURCE (ONEOF NIL ARRAY) (USEDIN CONV.NARRAY1))
(LABDIM [ONEOF NIL (INTEGER (SATISFIES (DIMENSIONP LABSOURCE LABDIM] (USEDIN CONV.NARRAY1)
(* If LABSOURCE is given, LABDIM=NIL means we want
dimension selectors))
(PREDFLAG BOOL (USEDIN CONV.NARRAY1) (* T on INDEX calls, when selector coercion is a
predicate)))
(* jop: " 8-Nov-84 16:46" posted: "13-AUG-78 23:38")
(* Constructs an IDL N-array out of DATA, a list structure with dimensions represented in row-major order.
Eventually, should be extended to allow for title and labels)
(DPROG ((SH [for (D ← DATA)
VAL by (CAR D) while (LISTP D) do (push VAL (LENGTH D))
finally [if (type? ARRAY D)
then (DPROG ((DS (fetch SHAPE of D) ROWINT))
(for I from 1 to (fetch NELTS of DS)
do (push VAL (GETRELT DS I))))]
(RETURN (ROWINTOF1 (DREVERSE VAL] ROWINT (USEDIN CONV.NARRAY1))
THEN (ARRAY (ALLOC.SARRAY SH (QUOTE FULL)
(QUOTE INTEGER)) ARRAY (USEDIN CONV.NARRAY1))
(NDIMS (fetch NELTS of SH) INTEGER (USEDIN CONV.NARRAY1))
THEN (GSBA (SETUP ARRAY (QUOTE ROWMAJOR)) GENSTATEBLOCK (USEDIN CONV.NARRAY1))
(GSBD NIL (ONEOF NIL GENSTATEBLOCK) (USEDIN CONV.NARRAY1))
(FIXFLG T BOOL (USEDIN CONV.NARRAY1))
(N 0 IJK (USEDIN CONV.NARRAY1)))
(CONV.NARRAY1 DATA 0)
(RETURN ARRAY))])
(CONV.NARRAY1
[DLAMBDA (DATA
(DIM INTEGER))
(* jop: " 8-Nov-84 16:43" posted: "13-AUG-78 23:38")
(* Internal recursion for CONV.NARRAY)
(DECL (LABSOURCE (ONEOF NIL ARRAY) (BOUNDIN CONV.NARRAY))
(LABDIM [ONEOF NIL (INTEGER (SATISFIES (DIMENSIONP LABSOURCE LABDIM] (BOUNDIN CONV.NARRAY))
(PREDFLAG BOOL (BOUNDIN CONV.NARRAY))
(SH ROWINT (BOUNDIN CONV.NARRAY))
(ARRAY ARRAY (BOUNDIN CONV.NARRAY))
(NDIMS INTEGER (BOUNDIN CONV.NARRAY))
(GSBA GENSTATEBLOCK (BOUNDIN CONV.NARRAY))
(GSBD (ONEOF NIL GENSTATEBLOCK) (BOUNDIN CONV.NARRAY))
(FIXFLG BOOL (BOUNDIN CONV.NARRAY))
(N IJK (BOUNDIN CONV.NARRAY)))
(if (LISTP DATA)
then (if (IEQP DIM NDIMS)
then (UERROR "Too many dimensions specified: " .P2 DATA))
(add DIM 1)
(for D (L ← 0)
(LIM ←(GETRELT SH DIM)) on DATA
declare (L INTEGER (* Not LARGEP, cause recursive))
(LIM INTEGER (* Ditto))
do (add L 1)
(if (IGREATERP L LIM)
then (UERROR "Too many elements for dimension " DIM ": " .P2 DATA))
(CONV.NARRAY1 (CAR D)
DIM)
finally (if (ILESSP L LIM)
then (UERROR "Too few elements for dimension " DIM ": " .P2 DATA)))
elseif (AND (type? ARRAY DATA)
(NOT (VSCALARP DATA)))
then (bind (DSH ←(fetch SHAPE of DATA)) declare (DSH ROWINT) for I from (ADD1 DIM)
to NDIMS as J from 1 first (if (NOT (IEQP (fetch NELTS of DSH)
(IDIFFERENCE NDIMS DIM)))
then (UERROR "Array has too "
(if (ILESSP (fetch NELTS of DSH)
(IDIFFERENCE NDIMS DIM))
then "few"
else "many")
" dimensions: " .P2 DATA))
do (if (IEQP (GETRELT SH I)
(GETRELT DSH J))
then (OR (GETDIMLAB ARRAY I)
(SETDIMLAB ARRAY I (GETDIMLAB DATA J)))
(for L from 1 to (GETRELT SH I) unless (GETLEVLAB ARRAY I L)
do (SETLEVLAB ARRAY I L (GETLEVLAB DATA J L)))
else (UERROR "Dimension " J " has too " (if (ILESSP (GETRELT DSH J)
(GETRELT SH I))
then "few"
else "many")
" levels: " .P2 DATA)))
(SETQ GSBD (SETUP DATA (QUOTE ROWMAJOR)
GSBD))
[if LABSOURCE
then [until (fetch DONE of GSBD) do (SETAELT ARRAY (NEXT GSBA)
(if LABDIM
then (MAKE1SLTR
LABSOURCE
(GETAELT DATA (NEXT GSBD))
LABDIM PREDFLAG)
else (MAKE1DIMSPEC
LABSOURCE
(GETAELT DATA (NEXT GSBD))
PREDFLAG]
else [if FIXFLG
then (if (EQ (fetch AELTTYPE of DATA)
(QUOTE FLOATING))
then (SETQ FIXFLG NIL)
(FLOATROW (fetch ELEMENTBLOCK of ARRAY)
N)
else (add N (NLOGICALELTS (fetch SHAPE of DATA]
(until (fetch DONE of GSBD) do (SETAELT ARRAY (NEXT GSBA)
(GETAELT DATA (NEXT GSBD]
elseif (IEQP DIM NDIMS)
then (DPROG ((VAL NIL SCALAR))
[if LABSOURCE
then (SETQ VAL (if LABDIM
then (MAKE1SLTR LABSOURCE DATA LABDIM PREDFLAG)
else (MAKE1DIMSPEC LABSOURCE DATA PREDFLAG)))
else (SETQ VAL (coerce DATA SCALAR))
(if FIXFLG
then (if (type? FLOATING VAL)
then (SETQ FIXFLG NIL)
(FLOATROW (fetch ELEMENTBLOCK of ARRAY)
N)
else (add N 1]
(SETAELT ARRAY (NEXT GSBA)
VAL))
else (UERROR "Too few dimensions specified: " .P2 DATA))])
(CONV.ROWFLOAT
[DLAMBDA (A
(RETURNS ROWFLOAT))
(* rmk: "10-JAN-79 12:48" posted: "10-JAN-79 13:02")
(* uses conv.rowscalar, checks for nils, converts to
floats)
[if (type? ROWFLOAT A)
then A
else (DPROG ((R (CONV.ROWSCALAR A) ROWSCALAR))
(if (HASNILS R)
then (UERROR "Invalid numeric data: NIL"))
(RETURN (SELECTQ R:RELTTYPE
(FLOATING R)
(INTEGER (for I to R:NELTS bind (RR ←(create ROWFLOAT
NELTS ← R:NELTS))
declare (R ROWINT)
(RR ROWFLOAT)
do (RR$I←R$I) finally (RETURN RR)))
(SHOULDNT))))]])
(CONV.ROWINT
[DLAMBDA (A
(RETURNS ROWINT))
(* rmk: "10-JAN-79 14:55" posted: "10-JAN-79 13:00")
(* uses conv.rowscalar, checks for nils, converts to
ints with FIXR)
[if (type? ROWINT A)
then A
else (DPROG ((R (CONV.ROWSCALAR A) ROWSCALAR))
(if (HASNILS R)
then (UERROR "Invalid numeric data: NIL"))
(RETURN (SELECTQ R:RELTTYPE
(INTEGER R)
(FLOATING (for I to R:NELTS bind TEMP (RR ←(create ROWINT (
NELTS←R:NELTS)))
declare (R ROWFLOAT)
(TEMP FLOATING)
(RR ROWINT)
do (TEMP←R$I)
(* Suppresses box but allows FIXR to compile open.
Can be removed if FIXR macro improved to handle
non-atoms)
(RR$I←(FIXR TEMP))
finally (RETURN RR)))
(SHOULDNT))))]])
(CONV.ROWSCALAR
[DLAMBDA (A
(RETURNS ROWSCALAR))
(* rmk: "25-MAY-78 15:55")
(* converts tuples arrays rowariths ariths and nulls
into a rowarith)
[if (type? ROWSCALAR A)
then A
elseif (AND (type? ARRAY A)
~(VSCALARP A))
then (for I FLAG to A:NDIMS unless (IEQP 1 A:SHAPE$I) do (if FLAG
then (UERROR
"Array has more than one non-empty extent: "
A)
else FLAG←T))
(CONV.SIMARRAY A):ELEMENTBLOCK
elseif (LISTP A)
then (bind V FLOATFLAG (CA ←(create ROWINT
NELTS ←(LENGTH A)))
declare (V SCALAR)
(FLOATFLAG BOOL)
(CA ROWSCALAR)
for I from 1 as J in A
do (V←(CONV.SCALAR J))
(if (AND FLOATFLAG=NIL (type? FLOATING V))
then (FLOATFLAG←T)
(CA←(FLOATROW CA I-1)))
(CA$I←V)
finally (RETURN CA))
else (DPROG ((TMP (CONV.SCALAR A) SCALAR))
(RETURN (create ROWSCALAR
NELTS ← 1
RELTTYPE ←(if (type? FLOATING TMP)
then 'FLOATING
else 'INTEGER)
INIT ← TMP)))]])
(CONV.SCALAR
[DLAMBDA (A
(RETURNS SCALAR))
(* rmk: "15-NOV-79 21:24" posted: "10-JAN-79 12:56")
(* Extracts scalars from arrays, etc. The PPL code also handled singleton rows. We eliminate that case here, since
rows can never be handed in by the user.)
(if (type? SCALAR A)
then A
elseif (type? ARRAY A)
then (if (VSCALARP A)
then (COPYAELT A (VSCALARPTR A))
elseif (IEQP 1 (NLOGICALELTS (fetch SHAPE of A)))
then (COPYAELT A (AELTPTR A (fetch SHAPE of A)))
else (UERROR "Array given where scalar expected: " A))
elseif (AND (LISTP A)
(NULL (CDR A)))
then (CONV.SCALAR (CAR A))
elseif (AND (LITATOM A)
(NULL (U-CASE A)))
then NIL
else (UERROR "Invalid scalar: " .P2 A))])
(CONV.SIMARRAY
[DLAMBDA ((A ARRAY)
LABPROPFLAG
(RETURNS SIMARRAY))
(* rmk: "25-MAY-78 15:57" posted: "13-MAY-77 00:30")
(DECLARE (SPECVARS LABPROPFLAG)) (* Converts a selarray into a simarray by streaming its
elements into a new block)
(if (type? SIMARRAY A)
then A
else (DPROG ((RESULT (ALLOC.SARRAY A:SHAPE A:FORMAT A:AELTTYPE) SIMARRAY)
(GSBOLD (SETUP A (if A:FORMAT='FULL
then 'DONTCARE
else 'SYMMETRIC)) GENSTATEBLOCK))
[bind (GSBNEW ←(SETUP RESULT GSBOLD:ORDER)) declare (GSBNEW GENSTATEBLOCK)
until GSBOLD:DONE do (SETAELT RESULT (NEXT GSBNEW)
(GETAELT A (NEXT GSBOLD]
(LAB.COPYALL A RESULT)
(RETURN RESULT)))])
(CONV.VECTOR
[DLAMBDA (A
(RETURNS VECTOR))
(* rmk: " 2-MAR-80 14:46" posted: "31-MAR-78 11:28")
(* Coerces user arguments to vectors)
A←(CONV.ARRAY A)
[SELECTQ A:NDIMS
(1 A)
(0 (if (VSCALARP A)
then (CONV.ARRAY (GETAELT A (VSCALARPTR A)))
else (UERROR "Array has no dimensions: " A)))
(for DIM SLTR REALDIM (SH ← A:SHAPE) to A:NDIMS declare (SH ROWINT)
unless (IEQP 1 SH$DIM) do (if REALDIM
then (UERROR
"Array has more than one non-empty extent: "
A)
else REALDIM←DIM)
finally (SLTR←(create ROWPTR
NELTS ← A:NDIMS
INIT ← 1))
(SLTR$(OR REALDIM 1)←'ALL)
(RETURN (FSELECT A SLTR]])
(LISPNUMBER
[LAMBDA (X) (* rmk: "16-JUL-78 13:41" posted: "16-JUL-78 13:00")
(* Called from ERRORTYPELST on non-numeric args.
Tries to coerce to a scalar.
NIL return will permit the non-numeric arg error to
take place)
(AND ~(UERRORGUARD X←(CONV.ARITH X))
X])
)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN (NOT TESTSYS)
(ADDTOVAR ERRORTYPELST (10 (LISPNUMBER (CADR ERRORMESS))))
)
)
(PUTPROPS CONV COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (861 14583 (CONV.ARITH 871 . 1206) (CONV.ARRAY 1208 . 1847) (CONV.NARRAY 1849 . 3651) (
CONV.NARRAY1 3653 . 7902) (CONV.ROWFLOAT 7904 . 8750) (CONV.ROWINT 8752 . 9884) (CONV.ROWSCALAR 9886
. 11256) (CONV.SCALAR 11258 . 12249) (CONV.SIMARRAY 12251 . 13205) (CONV.VECTOR 13207 . 14135) (
LISPNUMBER 14137 . 14581)))))
STOP