(FILECREATED "15-Feb-87 18:22:58" {QV}<PEDERSEN>LISP>KOTO>IDLARRAY.;2 10221
changes to: (VARS IDLARRAYCOMS)
(FNS IDLARRAY-COERCE)
previous date: "28-Jun-86 15:46:11" {QV}<PEDERSEN>LISP>KOTO>IDLARRAY.;1)
(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT IDLARRAYCOMS)
(RPAQQ IDLARRAYCOMS [(RECORDS IDLARRAY)
(FNS IDLARRAY-CMLARRAY IDLARRAY-COERCE IDLARRAY-CREATE IDLARRAY-DIMENSION IDLARRAY-DIMNAMES
IDLARRAY-DIMS IDLARRAY-FROM-CMLARRAY IDLARRAY-LEVELNAMES IDLARRAY-RANK IDLARRAY-REF
IDLARRAY-SET IDLARRAY-TOTALSIZE IDLMATRIX-FROM-LIST MAKE-IDLARRAY TEST-RESULT)
(MACROS SCALARP)
(FILES IDLARRAYLABELS IDLARRAYTYPES IDLARRAYFNS IDLARRAYINSPECTOR IDLPLOTFNS MEDIANSMOOTHER
PLOT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA IDLARRAY-SET
IDLARRAY-REF])
[DECLARE: EVAL@COMPILE
(DATATYPE IDLARRAY (ELTTYPE DIMNAMES LEVELNAMES CMLARRAY))
]
(/DECLAREDATATYPE (QUOTE IDLARRAY)
(QUOTE (POINTER POINTER POINTER POINTER))
(QUOTE ((IDLARRAY 0 POINTER)
(IDLARRAY 2 POINTER)
(IDLARRAY 4 POINTER)
(IDLARRAY 6 POINTER)))
(QUOTE 8))
(DEFINEQ
(IDLARRAY-CMLARRAY
[LAMBDA (IDLARRAY) (* jop: "23-Jun-86 22:29")
(* *)
(if (SCALARP IDLARRAY)
then IDLARRAY
else (fetch (IDLARRAY CMLARRAY) of IDLARRAY])
(IDLARRAY-COERCE
[LAMBDA (IDLARRAY ELTYPE RESULT) (* edited: "15-Feb-87 17:13")
(LET [(L-ARRAY (EARRAY-LINEARIZE (IDLARRAY-CMLARRAY IDLARRAY]
(if (NULL ELTYPE)
then (SETQ ELTYPE (bind (LASTTYPE ←(IDLARRAY-ELTTYPE (AREF L-ARRAY 0)))
for I from 1 to (SUB1 (ARRAY-TOTAL-SIZE L-ARRAY))
until (EQ LASTTYPE (QUOTE ANY))
do [SETQ LASTTYPE (IDLARRAY-COMMON-TYPE
LASTTYPE
(IDLARRAY-ELTTYPE (AREF L-ARRAY I]
finally (RETURN LASTTYPE)))
else (if (NOT (for I from 0 to (SUB1 (ARRAY-TOTAL-SIZE L-ARRAY))
always (IDLARRAY-ELTTYPEP (AREF L-ARRAY I)
ELTYPE)))
then (ERROR "ARRAY not coercable to this type" ELTYPE)))
(if RESULT
then (if (NOT (AND (EQUAL (IDLARRAY-DIMS RESULT)
(IDLARRAY-DIMS IDLARRAY))
(IDLARRAY-ELTTYPEP RESULT ELTYPE)))
then (ERROR "RESULT not of correct element-type" RESULT))
else (SETQ RESULT (MAKE-IDLARRAY (IDLARRAY-DIMS IDLARRAY)
ELTYPE)))
(bind (L-RESULT ←(EARRAY-LINEARIZE (IDLARRAY-CMLARRAY RESULT))) for I from 0
to (SUB1 (ARRAY-TOTAL-SIZE L-ARRAY)) do (ASET (AREF L-ARRAY I)
L-RESULT I))
(COPYLABELS IDLARRAY RESULT])
(IDLARRAY-CREATE
[LAMBDA (CMLARRAY ELTTYPE DIMNAMES LEVELNAMES OLDIDLARRAY)
(* jop: "23-Jun-86 22:59")
(* *)
(if (EARRAY-SCALARP CMLARRAY)
then CMLARRAY
else (if (NULL OLDIDLARRAY)
then (SETQ OLDIDLARRAY (create IDLARRAY)))
(create IDLARRAY
ELTTYPE ← ELTTYPE
DIMNAMES ← DIMNAMES
LEVELNAMES ← LEVELNAMES
CMLARRAY ← CMLARRAY smashing OLDIDLARRAY])
(IDLARRAY-DIMENSION
[LAMBDA (IDLARRAY DIM) (* jop: "20-Jun-86 15:15")
(* *)
(EARRAY-DIMENSION (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-DIMINDEX IDLARRAY DIM])
(IDLARRAY-DIMNAMES
[LAMBDA (IDLARRAY) (* jop: "23-Jun-86 22:29")
(* *)
(if (NOT (SCALARP IDLARRAY))
then (fetch (IDLARRAY DIMNAMES) of IDLARRAY])
(IDLARRAY-DIMS
[LAMBDA (IDLARRAY) (* jop: "20-Jun-86 14:12")
(* *)
(EARRAY-DIMENSIONS (IDLARRAY-CMLARRAY IDLARRAY])
(IDLARRAY-FROM-CMLARRAY
[LAMBDA (CMLARRAY) (* jop: "20-Jun-86 15:27")
(IDLARRAY-CREATE CMLARRAY (IDLARRAY-MOST-SPECIFIC-TYPE (EARRAY-ELEMENT-TYPE CMLARRAY])
(IDLARRAY-LEVELNAMES
[LAMBDA (IDLARRAY) (* jop: "23-Jun-86 22:29")
(* *)
(if (NOT (SCALARP IDLARRAY))
then (fetch (IDLARRAY LEVELNAMES) of IDLARRAY])
(IDLARRAY-RANK
[LAMBDA (IDLARRAY) (* jop: "20-Jun-86 12:24")
(* *)
(EARRAY-RANK (IDLARRAY-CMLARRAY IDLARRAY])
(IDLARRAY-REF
[LAMBDA ARGS (* jop: "23-Jun-86 22:29")
(* * First arg is the Genarray. Rest are the indices SPREAD)
(if (ILESSP ARGS 1)
then (ERROR "Too few args"))
(LET ((IDLARRAY (ARG ARGS 1)))
(SELECTQ ARGS
(1 (if (SCALARP IDLARRAY)
then IDLARRAY
else (ERROR "Rank mismatch")))
[2 (AREF (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-LEVELINDEX IDLARRAY 0 (ARG ARGS 2]
[3 (AREF (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-LEVELINDEX IDLARRAY 0 (ARG ARGS 2))
(IDLARRAY-LEVELINDEX IDLARRAY 1 (ARG ARGS 3]
(APPLY (FUNCTION AREF)
(CONS (IDLARRAY-CMLARRAY IDLARRAY)
(for I from 2 to ARGS collect (IDLARRAY-LEVELINDEX
IDLARRAY
(IDIFFERENCE I 2)
(ARG ARGS I])
(IDLARRAY-SET
[LAMBDA ARGS (* jop: "23-Jun-86 22:29")
(* * First arg is the Genarray. Rest are the indices SPREAD)
(if (ILESSP ARGS 2)
then (ERROR "Too few args"))
(LET ((NEWVALUE (ARG ARGS 1))
(IDLARRAY (ARG ARGS 2)))
(SELECTQ ARGS
(2 (if (SCALARP IDLARRAY)
then NEWVALUE
else (ERROR "Rank mismatch")))
[3 (ASET NEWVALUE (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-LEVELINDEX IDLARRAY 0 (ARG ARGS 3]
[4 (ASET NEWVALUE (IDLARRAY-CMLARRAY IDLARRAY)
(IDLARRAY-LEVELINDEX IDLARRAY 0 (ARG ARGS 3))
(IDLARRAY-LEVELINDEX IDLARRAY 1 (ARG ARGS 4]
(APPLY (FUNCTION ASET)
(CONS NEWVALUE (CONS (IDLARRAY-CMLARRAY IDLARRAY)
(for I from 3 to ARGS
collect (IDLARRAY-LEVELINDEX
IDLARRAY
(IDIFFERENCE I 3)
(ARG ARGS I])
(IDLARRAY-TOTALSIZE
[LAMBDA (IDLARRAY) (* jop: "20-Jun-86 12:24")
(* *)
(EARRAY-TOTAL-SIZE (IDLARRAY-CMLARRAY IDLARRAY])
(IDLMATRIX-FROM-LIST
[LAMBDA (LST) (* jop: "24-Jun-86 21:29")
(* *)
(LET* [(TITLES (CAR LST))
(LABELS (CADR LST))
(REST (CDDR LST))
(ELTTYPE (bind [LASTTYPE ←(IDLARRAY-ELTTYPE (CADR (CAR REST] for ROW
in REST until (EQ LASTTYPE (QUOTE ANY))
do (for ENTRY in (CDR ROW) until (EQ (SETQ LASTTYPE
(IDLARRAY-COMMON-TYPE
LASTTYPE
(IDLARRAY-ELTTYPE
ENTRY)))
(QUOTE ANY)))
finally (RETURN LASTTYPE)))
(IDLARRAY (MAKE-IDLARRAY (LIST (LENGTH REST)
(SUB1 (LENGTH LABELS)))
ELTTYPE
(CDDR TITLES)
(LIST (for ROW in REST collect (CAR ROW))
(CDR LABELS]
(bind (CMLARRAY ←(IDLARRAY-CMLARRAY IDLARRAY)) for ROW in REST as I from 0
do (for J from 0 as ENTRY in (CDR ROW) do (ASET ENTRY CMLARRAY I J)))
IDLARRAY])
(MAKE-IDLARRAY
[LAMBDA (DIMS ELTTYPE DIMLABELS LEVELNAMES) (* jop: "24-Jun-86 16:45")
(* *)
(SETQ DIMS (MKLIST DIMS))
(if (NULL ELTTYPE)
then (SETQ ELTTYPE (QUOTE ANY)))
(LET* [(DEFAULT-VALUE (IDLARRAY-DEFAULTVALUE ELTTYPE))
(IDLARRAY (if (NULL DIMS)
then DEFAULT-VALUE
else (IDLARRAY-CREATE (MAKE-ARRAY DIMS (QUOTE :ELEMENT-TYPE)
(IDLARRAY-CMLTYPE ELTTYPE)
(QUOTE :INITIAL-ELEMENT)
DEFAULT-VALUE)
ELTTYPE]
(if DIMLABELS
then (IDLARRAY-SETDIMLABELS IDLARRAY DIMLABELS))
[if LEVELNAMES
then (for DIM from 0 as LEVELLST in LEVELNAMES
do (AND LEVELLST (IDLARRAY-SETLEVELLABELS IDLARRAY DIM LEVELLST]
IDLARRAY])
(TEST-RESULT
[LAMBDA (RESULTARRAY RESULTDIMS RESULTELTTYPE) (* jop: "25-Jun-86 09:52")
(* *)
(if (NULL RESULTELTTYPE)
then (SETQ RESULTELTTYPE (QUOTE ANY)))
(if (NULL RESULTARRAY)
then (SETQ RESULTARRAY (MAKE-IDLARRAY RESULTDIMS RESULTELTTYPE))
elseif (NOT (AND (EQUAL (IDLARRAY-DIMS RESULTARRAY)
RESULTDIMS)
(IDLARRAY-SUBTYPEP (IDLARRAY-ELTTYPE RESULTARRAY)
RESULTELTTYPE)))
then (HELP "Invalid RESULT" RESULTARRAY))
RESULTARRAY])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS SCALARP MACRO (OPENLAMBDA (DATUM)
(NOT (type? IDLARRAY DATUM]
)
(FILESLOAD IDLARRAYLABELS IDLARRAYTYPES IDLARRAYFNS IDLARRAYINSPECTOR IDLPLOTFNS MEDIANSMOOTHER PLOT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA IDLARRAY-SET IDLARRAY-REF)
)
(PUTPROPS IDLARRAY COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1242 9772 (IDLARRAY-CMLARRAY 1252 . 1507) (IDLARRAY-COERCE 1509 . 3018) (
IDLARRAY-CREATE 3020 . 3549) (IDLARRAY-DIMENSION 3551 . 3789) (IDLARRAY-DIMNAMES 3791 . 4032) (
IDLARRAY-DIMS 4034 . 4228) (IDLARRAY-FROM-CMLARRAY 4230 . 4452) (IDLARRAY-LEVELNAMES 4454 . 4699) (
IDLARRAY-RANK 4701 . 4889) (IDLARRAY-REF 4891 . 5874) (IDLARRAY-SET 5876 . 6935) (IDLARRAY-TOTALSIZE
6937 . 7136) (IDLMATRIX-FROM-LIST 7138 . 8286) (MAKE-IDLARRAY 8288 . 9175) (TEST-RESULT 9177 . 9770)))
))
STOP