(FILECREATED "25-Jun-86 01:48:16" {QV}<PEDERSEN>LISP>IDLARRAYTYPES.;8 9803
changes to: (VARS IDLARRAY-TYPE-TREE)
(FNS IDLARRAY-ELTTYPE IDLARRAY-ELTTYPEP)
previous date: "20-Jun-86 15:41:28" {QV}<PEDERSEN>LISP>IDLARRAYTYPES.;6)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT IDLARRAYTYPESCOMS)
(RPAQQ IDLARRAYTYPESCOMS ((RECORDS IDLARRAY-TYPE)
(FNS AMOUNT-P ANY-P CATEGORY-P COUNT-P IDLARRAY-CMLTYPE IDLARRAY-COMMON-TYPE
IDLARRAY-DEFAULTVALUE IDLARRAY-ELTTYPE IDLARRAY-ELTTYPEP IDLARRAY-EQUALFN
IDLARRAY-FIND-TYPE IDLARRAY-MOST-SPECIFIC-TYPE IDLARRAY-NUMERIC-RESULT
IDLARRAY-NUMERIC-TYPE IDLARRAY-POSITIVE-TYPE IDLARRAY-RANKP IDLARRAY-SUBNODESP
IDLARRAY-SUBTYPEP IDLARRAY-TYPEP LOGICAL-P RATIO-P)
(VARS IDLARRAY-TYPE-TREE)))
[DECLARE: EVAL@COMPILE
(RECORD IDLARRAY-TYPE (TYPENAME PREDICATE EQUALFN CMLTYPE DEFAULTVALUE SUBTYPES))
]
(DEFINEQ
(AMOUNT-P
[LAMBDA (OBJECT) (* jop: " 8-May-86 20:14")
(AND (FLOATP OBJECT)
(GEQ OBJECT 0.0])
(ANY-P
[LAMBDA (OBJECT) (* jop: " 8-May-86 15:16")
T])
(CATEGORY-P
[LAMBDA (OBJECT) (* jop: " 9-May-86 18:17")
(AND OBJECT (LITATOM OBJECT])
(COUNT-P
[LAMBDA (OBJECT) (* jop: " 8-May-86 20:14")
(AND (FIXP OBJECT)
(IGEQ OBJECT 0])
(IDLARRAY-CMLTYPE
[LAMBDA (TYPE) (* jop: " 8-May-86 22:20")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(fetch (IDLARRAY-TYPE CMLTYPE) of (IDLARRAY-FIND-TYPE TYPE IDLARRAY-TYPE-TREE])
(IDLARRAY-COMMON-TYPE
[LAMBDA (ELTTYPE1 ELTTYPE2) (* jop: " 9-May-86 18:26")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(if (OR (EQ ELTTYPE1 ELTTYPE2)
(NULL ELTTYPE2))
then ELTTYPE1
elseif (NULL ELTTYPE1)
then ELTTYPE2
else (bind (CURRENTCHILDREN ←(fetch (IDLARRAY-TYPE SUBTYPES) of IDLARRAY-TYPE-TREE))
(MOSTSPECIFICNODE ← IDLARRAY-TYPE-TREE)
CURRENTNODE while (SETQ CURRENTNODE (for NODE in CURRENTCHILDREN
thereis (IDLARRAY-SUBNODESP ELTTYPE1 ELTTYPE2
NODE)))
do (SETQ CURRENTCHILDREN (fetch (IDLARRAY-TYPE SUBTYPES) of CURRENTNODE))
(SETQ MOSTSPECIFICNODE CURRENTNODE) finally (RETURN (AND MOSTSPECIFICNODE
(fetch (IDLARRAY-TYPE
TYPENAME)
of MOSTSPECIFICNODE])
(IDLARRAY-DEFAULTVALUE
[LAMBDA (TYPE) (* jop: " 8-May-86 22:20")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(fetch (IDLARRAY-TYPE DEFAULTVALUE) of (IDLARRAY-FIND-TYPE TYPE IDLARRAY-TYPE-TREE])
(IDLARRAY-ELTTYPE
[LAMBDA (IDLARRAY) (* jop: "23-Jun-86 22:29")
(* *)
(if (SCALARP IDLARRAY)
then (IDLARRAY-MOST-SPECIFIC-TYPE IDLARRAY)
else (fetch (IDLARRAY ELTTYPE) of IDLARRAY])
(IDLARRAY-ELTTYPEP
[LAMBDA (IDLARRAY ELTTYPE) (* jop: "23-Jun-86 22:29")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(if (SCALARP IDLARRAY)
then [LET ((IDLARRAY-TYPE (IDLARRAY-FIND-TYPE ELTTYPE IDLARRAY-TYPE-TREE)))
(AND IDLARRAY-TYPE (NOT (NULL (APPLY* (fetch (IDLARRAY-TYPE PREDICATE)
of IDLARRAY-TYPE)
IDLARRAY]
else (IDLARRAY-SUBTYPEP (IDLARRAY-ELTTYPE IDLARRAY)
ELTTYPE])
(IDLARRAY-EQUALFN
[LAMBDA (TYPE) (* jop: "12-May-86 20:57")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(fetch (IDLARRAY-TYPE EQUALFN) of (IDLARRAY-FIND-TYPE TYPE IDLARRAY-TYPE-TREE])
(IDLARRAY-FIND-TYPE
[LAMBDA (TYPE TYPE-TREE) (* jop: " 8-May-86 15:27")
(* *)
(if (EQ TYPE (fetch (IDLARRAY-TYPE TYPENAME) of TYPE-TREE))
then TYPE-TREE
else (bind RESULT for SUBTYPE in (fetch (IDLARRAY-TYPE SUBTYPES) of TYPE-TREE)
thereis (SETQ RESULT (IDLARRAY-FIND-TYPE TYPE SUBTYPE)) finally (RETURN RESULT])
(IDLARRAY-MOST-SPECIFIC-TYPE
[LAMBDA (SCALAR) (* jop: " 8-May-86 19:57")
(* *)
(DECLARE (GLOBALVARS (IDLARRAY-TYPE-TREE)))
(bind (MOST-SPECIFIC-TYPE ← IDLARRAY-TYPE-TREE)
(CURRENT-SUBTYPES ←(fetch (IDLARRAY-TYPE SUBTYPES) of IDLARRAY-TYPE-TREE))
CURRENT-TYPE while (SETQ CURRENT-TYPE (for SUBTYPE in CURRENT-SUBTYPES
thereis (APPLY* (fetch (IDLARRAY-TYPE PREDICATE)
of SUBTYPE)
SCALAR)))
do (SETQ CURRENT-SUBTYPES (fetch (IDLARRAY-TYPE SUBTYPES) of CURRENT-TYPE))
(SETQ MOST-SPECIFIC-TYPE CURRENT-TYPE) finally (RETURN (fetch (IDLARRAY-TYPE TYPENAME)
of MOST-SPECIFIC-TYPE])
(IDLARRAY-NUMERIC-RESULT
[LAMBDA (ARRAY1 ARRAY2) (* jop: "13-May-86 10:21")
(* *)
(LET ((ELTTYPE1 (IDLARRAY-NUMERIC-TYPE ARRAY1))
(ELTTYPE2 (IDLARRAY-NUMERIC-TYPE ARRAY2)))
(if (OR (EQ ELTTYPE1 (QUOTE FLOAT))
(EQ ELTTYPE2 (QUOTE FLOAT)))
then (QUOTE FLOAT)
elseif (OR (EQ ELTTYPE1 (QUOTE NUMERIC))
(EQ ELTTYPE2 (QUOTE NUMERIC)))
then (QUOTE NUMERIC)
else (QUOTE INTEGER])
(IDLARRAY-NUMERIC-TYPE
[LAMBDA (ARRAY) (* jop: "13-May-86 10:10")
(* *)
(LET ((ELTTYPE (IDLARRAY-ELTTYPE ARRAY)))
(if (EQ ELTTYPE (QUOTE NUMERIC))
then (QUOTE NUMERIC)
elseif (IDLARRAY-SUBTYPEP ELTTYPE (QUOTE FLOAT))
then (QUOTE FLOAT)
elseif (IDLARRAY-SUBTYPEP ELTTYPE (QUOTE INTEGER))
then (QUOTE INTEGER)
else (HELP "Not a numeric type" ELTTYPE])
(IDLARRAY-POSITIVE-TYPE
[LAMBDA (ARRAY) (* jop: "13-May-86 10:49")
(* *)
(LET ((ELTTYPE (IDLARRAY-ELTTYPE ARRAY)))
(if (EQ ELTTYPE (QUOTE NUMERIC))
then (QUOTE NUMERIC)
elseif (EQ ELTTYPE (QUOTE FLOAT))
then (QUOTE AMOUNT)
elseif (EQ ELTTYPE (QUOTE INTEGER))
then (QUOTE COUNT)
else ELTTYPE])
(IDLARRAY-RANKP
[LAMBDA (IDLARRAY RANKSPEC) (* jop: "20-Jun-86 14:06")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(OR (NULL RANKSPEC)
(LET ((RANK (IDLARRAY-RANK IDLARRAY)))
(SELECTQ RANKSPEC
(1+ (IGREATERP RANK 0))
(2+ (IGREATERP RANK 1))
(3+ (IGREATERP RANK 2))
(EQ RANK RANKSPEC])
(IDLARRAY-SUBNODESP
[LAMBDA (ELTTYPE1 ELTTYPE2 TREE) (* jop: " 9-May-86 15:55")
(AND (IDLARRAY-FIND-TYPE ELTTYPE1 TREE)
(IDLARRAY-FIND-TYPE ELTTYPE2 TREE])
(IDLARRAY-SUBTYPEP
[LAMBDA (SUBTYPE SUPERTYPE) (* jop: " 9-May-86 18:23")
(* *)
(DECLARE (GLOBALVARS IDLARRAY-TYPE-TREE))
(OR (NULL SUBTYPE)
(LET ((ROOT (IDLARRAY-FIND-TYPE SUPERTYPE IDLARRAY-TYPE-TREE)))
(AND ROOT (NOT (NULL (IDLARRAY-FIND-TYPE SUBTYPE ROOT])
(IDLARRAY-TYPEP
[LAMBDA (IDLARRAY TYPE) (* jop: " 9-May-86 11:02")
(* *)
(AND (IDLARRAY-ELTTYPEP IDLARRAY (CAR TYPE))
(IDLARRAY-RANKP IDLARRAY (CADR TYPE])
(LOGICAL-P
[LAMBDA (OBJECT) (* jop: "20-Jun-86 14:07")
(OR (EQ OBJECT 1)
(EQ OBJECT 0])
(RATIO-P
[LAMBDA (OBJECT) (* jop: " 8-May-86 20:14")
(AND (FLOATP OBJECT)
(GEQ OBJECT 0.0)
(LEQ OBJECT 1.0])
)
(RPAQQ IDLARRAY-TYPE-TREE (ANY ANY-P EQUALP T NIL
([NUMERIC NUMBERP EQUALP T 0
([INTEGER FIXP EQL T 0
((COUNT COUNT-P EQL T 0
((LOGICAL LOGICAL-P EQL T 0 NIL]
(FLOAT FLOATP EQL SINGLE-FLOAT 0.0
((AMOUNT AMOUNT-P EQL SINGLE-FLOAT 0.0
((RATIO RATIO-P EQL SINGLE-FLOAT 0.0 NIL]
(CATEGORICAL CATEGORY-P EQ T NIL NIL))))
(PUTPROPS IDLARRAYTYPES COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (943 9327 (AMOUNT-P 953 . 1114) (ANY-P 1116 . 1230) (CATEGORY-P 1232 . 1377) (COUNT-P
1379 . 1536) (IDLARRAY-CMLTYPE 1538 . 1833) (IDLARRAY-COMMON-TYPE 1835 . 3129) (IDLARRAY-DEFAULTVALUE
3131 . 3436) (IDLARRAY-ELTTYPE 3438 . 3725) (IDLARRAY-ELTTYPEP 3727 . 4276) (IDLARRAY-EQUALFN 4278 .
4573) (IDLARRAY-FIND-TYPE 4575 . 5045) (IDLARRAY-MOST-SPECIFIC-TYPE 5047 . 6067) (
IDLARRAY-NUMERIC-RESULT 6069 . 6653) (IDLARRAY-NUMERIC-TYPE 6655 . 7212) (IDLARRAY-POSITIVE-TYPE 7214
. 7706) (IDLARRAY-RANKP 7708 . 8132) (IDLARRAY-SUBNODESP 8134 . 8350) (IDLARRAY-SUBTYPEP 8352 . 8724)
(IDLARRAY-TYPEP 8726 . 8977) (LOGICAL-P 8979 . 9137) (RATIO-P 9139 . 9325)))))
STOP