(FILECREATED " 4-Sep-85 13:10:59" {QV}<IDL>SOURCES>AT.;10 18601
changes to: (VARS ATCOMS)
previous date: " 3-Sep-85 17:25:38" {QV}<IDL>SOURCES>AT.;9)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ATCOMS)
(RPAQQ ATCOMS [(* This file contains the user interface to the selection operations)
(FNS AT AT.CODE AT.LABEL CODE INDEX INDEX1 LABEL MAKE1DIMSPEC MAKEDIMSPEC MAKE1SLTR
MAKESLTR TITLE)
(PROP (CLISPINFIX SETFN)
AT)
(PROP (CLISPTYPE LISPFN)
@)
(IF: TESTSYS (RECORDS CODESLTR LABSLTR TITLESLTR))
(VARS (ALL (QUOTE ALL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* This file contains the user interface to the selection operations)
(DEFINEQ
(AT
[ULAMBDA ((A ARRAY)
(SLTR ANY))
(* edited: "15-Aug-85 15:25")
(* User level selection function.)
(* Coerce non-lists to single-element lists.)
(if (OR (NLISTP SLTR)
(EQ (CAR (LISTP (CDR SLTR)))
(QUOTE =)))
then (SETQ SLTR (LIST SLTR)))
[SELECTQ (fetch KEY of SLTR)
(*LABEL* (AT.LABEL A SLTR))
(*CODE* (AT.CODE A SLTR))
(*TITLE* (MAKEUSERTITLE A))
(if (EQ [CAR (LISTP (CDR (LISTP (CAR SLTR]
(QUOTE =))
then (bind DIM (TTAB ←(create ROWPTR
NELTS ←(fetch NDIMS of A)
INIT ←(QUOTE ALL)))
declare (TTAB ROWPTR)
(DIM POSINT)
(RETURNS SELARRAY)
for S in SLTR do (if (EQ [CAR (LISTP (CDR (LISTP S]
(QUOTE =))
then (SETQ DIM (MAKE1DIMSPEC A (CAR S)))
(SETRELT TTAB DIM (MAKESLTR A (CADDR S)
DIM))
else (UERROR "Can't mix %"=%" and position selectors: "
.P2 S))
finally (RETURN (FSELECT A TTAB)))
else (bind S (NALLS ←(IDIFFERENCE (fetch NDIMS of A)
(LENGTH SLTR)))
(TTAB ←(create ROWPTR
NELTS ←(fetch NDIMS of A)))
declare (NALLS INTEGER (* No. of left-default ALL's))
(TTAB ROWPTR)
(RETURNS SELARRAY)
for I from 1 to (fetch NDIMS of A) first (if (MINUSP NALLS)
then (UERROR
"Selector list too long: "
.P2 SLTR))
do (SETRELT TTAB I (if (GREATERP I NALLS)
then (SETQ S (pop SLTR))
(if (NEQ [CAR (LISTP (CDR (LISTP S]
(QUOTE =))
then (MAKESLTR A S I)
else (UERROR
"Can't mix %"=%" and position selectors: "
.P2 S))
else (QUOTE ALL)))
finally (RETURN (FSELECT A TTAB]])
(AT.CODE
[DLAMBDA ((A ARRAY)
(CODESPEC CODESLTR)
(RETURNS (ONEOF LABEL INTEGER SCALAR CODEBOOK)))
(* rmk: " 4-FEB-80 08:41" posted: " 9-FEB-79 19:29")
(* Returns the valdim, the code-book for a given level on the valdim, or the label for a given value or vice versa,
depending on the length of the CODESPEC)
(DPROG ((VALDIM (GETVALDIM A) (ONEOF NIL INTEGER))
THEN (CB (AND VALDIM (fetch CLEV of CODESPEC)
(GETCODES A (MAKE1SLTR A (fetch CLEV of CODESPEC)
VALDIM))) (ONEOF NIL CODEBOOK)))
[RETURN (AND VALDIM (if (NULL (fetch CLEV of CODESPEC))
then VALDIM
elseif (NULL (fetch VAL of CODESPEC))
then (for CP in CB collect (LIST (fetch CODE of CP)
(fetch CODELAB of CP)))
else (DPROG ((VALSPEC (fetch VAL of CODESPEC) (ONEOF LABEL ARITH)))
(RETURN (if (type? ARITH VALSPEC)
then (perform CODEBOOK.FINDLAB CB VALSPEC)
else (GETCODENUM CB VALSPEC))))])])
(AT.LABEL
[DLAMBDA ((A ARRAY)
(LABSPEC LABSLTR)
(RETURNS (ONEOF LABEL NIL (LISTP OF (ONEOF LABEL NIL)))))
(* jop: "12-Nov-84 15:51" posted: " 9-FEB-79 19:32")
(* Returns the labels corresponding to a user
specification. Produces dimension or level
information.)
[if (fetch LLEV of LABSPEC)
then (DPROG ((DIMNUM (MAKE1DIMSPEC A (fetch DIM of LABSPEC)) INTEGER)
THEN (SLTR (MAKESLTR A (fetch LLEV of LABSPEC)
DIMNUM) (ONEOF INTEGER ARRAY (MEMQ ALL))))
[RETURN (SELTYPEQ SLTR
(INTEGER (GETLEVLAB A DIMNUM SLTR))
((MEMQ ALL)
(for L from 1 to (GETRELT (fetch SHAPE of A)
DIMNUM)
declare (L IJK) collect (GETLEVLAB A DIMNUM L)))
[VECTOR (bind (GSBS ←(SETUP SLTR (QUOTE ROWMAJOR)))
until (fetch DONE of GSBS)
collect (GETLEVLAB A DIMNUM (GETAELT SLTR
(NEXT GSBS]
(UERROR "Invalid label selector: " .P2 (fetch LLEV of LABSPEC])
else (SELTYPEQ (fetch DIM of LABSPEC)
((MEMQ ALL)
(for D from 1 to (fetch NDIMS of A) collect (GETDIMLAB A D)))
[[ONEOF LISTP (ARRAY (SATISFIES ~(VSCALARP VALUE]
(DPROG ((SLTR (MAKEDIMSPEC A (fetch DIM of LABSPEC)) ROWINT))
[RETURN (for I from 1 to (fetch NELTS of SLTR)
collect (GETDIMLAB A (GETRELT SLTR I])]
(GETDIMLAB A (MAKE1DIMSPEC A (fetch DIM of LABSPEC]])
(CODE
[ULAMBDA ((LEV (ONEOF NIL LABEL INTEGER))
(VAL (ONEOF NIL LABEL ARITH))
(RETURNS CODESLTR))
(* rmk: " 4-FEB-80 08:43" posted: " 9-FEB-79 19:28")
(* Returns a Code selector, with LEV and VAL coerced
part way)
(create CODESLTR
CLEV ← LEV
VAL ← VAL)])
(INDEX
[ULAMBDA ((A ARRAY)
(DIM ANY)
(LEV ANY)
(NOSPELL BOOL (* T if labels shouldn't be corrected))
(RETURNS (ONEOF INTEGER NIL ARRAY)))
(* rmk: " 8-MAR-80 14:32" posted: " 1-FEB-79 09:20")
(* Returns the integer index for the specified
dimension or level, NIL if the specification is
invalid)
[if LEV
then (SETQ DIM (MAKE1DIMSPEC A DIM)) (* Permit spelling correction here)
(RESETVARS ((NOSPELLFLG NOSPELL))
(RETURN (INDEX1 A LEV DIM)))
else (RESETVARS ((NOSPELLFLG NOSPELL))
(RETURN (INDEX1 A DIM]])
(INDEX1
[DLAMBDA ((A ARRAY)
(SPEC ANY)
(DIM (ONEOF NIL INTEGER) (* DIM specified if this is for level indexing)))
(* jop: "12-Nov-84 15:54")
(* Maps selector specifications for dimensions and levels (depending on DIM) into the appropriate
(arrays of) indices. Result contains NIL for bad specifications unless the specifications are syntactically invalid,
in which case a UERROR.)
(DPROG (VAL
(LIM (if DIM
then (GETRELT (fetch SHAPE of A)
DIM)
else (fetch NDIMS of A)) IJK))
(UERRORGUARD [if (EQ SPEC (QUOTE ALL))
then (SETQ VAL (VFROMR (GENROW 1 LIM)))
elseif (LISTP SPEC)
then (SETQ VAL (CONV.NARRAY SPEC A DIM T))
(ASSERT (type? SIMARRAY VAL)
(EQ (fetch AELTTYPE of VAL)
(QUOTE INTEGER)))
elseif (AND (type? ARRAY SPEC)
(NOT (VSCALARP SPEC)))
then (DPROG ((EB NIL ROWSCALAR)
(COPIED NIL BOOL))
(if [AND (type? SIMARRAY SPEC)
(type? ROWINT (SETQ EB (fetch ELEMENTBLOCK of SPEC]
then (SETQ VAL SPEC)
else (SETQ VAL (COPYIDLARRAY SPEC (QUOTE INTEGER)))
(SETQ EB (fetch ELEMENTBLOCK of VAL))
(SETQ COPIED T))
(for J EBJ (TOP ←(ADD1 LIM)) to (fetch NELTS of EB)
declare (J IJK)
(EBJ (ONEOF INTEGER NIL))
(TOP IJK)
when [AND (SETQ EBJ (GETRELT EB J))
(NOT (if DIM
then (LEVELP A DIM EBJ)
else (DIMENSIONP A EBJ]
do (if (NULL COPIED)
then (SETQ COPIED T)
(SETQ VAL (COPYIDLARRAY VAL (QUOTE INTEGER)))
(SETQ EB (fetch ELEMENTBLOCK of VAL)))
(SETRELT EB J (if [AND (MINUSP EBJ)
(if DIM
then (LEVELP A DIM
(add EBJ TOP))
else (DIMENSIONP A
(add EBJ TOP]
then EBJ)))
(if (NULL COPIED)
then (SETQ VAL (PRESERVE VAL))))
else (SETQ VAL (if DIM
then (MAKE1SLTR A SPEC DIM T)
else (MAKE1DIMSPEC A SPEC T]
(if DIM
then (printout T "Invalid selector for dimension " DIM)
": " DIM
else "Invalid dimension specification: ")
.P2 SPEC)
(RETURN VAL))])
(LABEL
[ULAMBDA ((DIM ANY)
(LEV ANY)
(RETURNS LABSLTR))
(* rmk: " 9-MAR-80 22:40" posted: " 9-FEB-79 19:29")
(* Returns a label selector)
(create LABSLTR
DIM ← DIM
LLEV ← LEV)])
(MAKE1DIMSPEC
[DLAMBDA ((A ARRAY)
(DIMSPEC ANY)
(PREDFLAG BOOL (* T if this call is predicational, not coercional))
(RETURNS (ONEOF INTEGER NIL)))
(* bas: "15-FEB-83 10:16")
(* Handles integer {perhaps virtual} or label dimension
selectors. Returns dimension number if its valid,
otherwise NIL if PREDFLG or causes a UERROR.)
(if (STRINGP DIMSPEC)
then (OR (NLSETQ (SETQ DIMSPEC (MKATOM DIMSPEC)))
(UERROR "Label too long: " .P2 DIMSPEC)))
(if (type? LABEL DIMSPEC)
then (if (GETDIMNUM A DIMSPEC)
elseif (NOT PREDFLAG)
then (UERROR "Invalid dimension specification: " .P2 DIMSPEC))
else (DPROG ((DIMNUM NIL SCALAR))
(UERRORGUARD (OR (AND (SETQ DIMNUM (CONV.SCALAR DIMSPEC))
(OR (DIMENSIONP A (SETQ DIMNUM (FIXR DIMNUM)))
[AND (MINUSP DIMNUM)
(DIMENSIONP A (add DIMNUM 1 (fetch NDIMS of A]
(SETQ DIMNUM NIL)))
PREDFLAG
(UERROR))
"Invalid dimension specification: " .P2 DIMSPEC)
(RETURN DIMNUM)))])
(MAKEDIMSPEC
[DLAMBDA ((ARY ARRAY)
(DSPEC ANY)
(RETURNS ROWINT))
(* rmk: " 9-MAR-80 22:51" posted: "21-SEP-77 00:30")
(* Builds a dimension specification rowint for ary)
(DPROG ((DROW NIL ROWINT))
(UERRORGUARD [if (type? VECTOR DSPEC)
then (SETQ DROW (CONV.ROWINT DSPEC))
(for I DI COPIED to (fetch NELTS of DROW)
unless (DIMENSIONP ARY (SETQ DI (GETRELT DROW I)))
do (if [AND (MINUSP DI)
(DIMENSIONP ARY (add DI 1 (fetch NELTS of DROW]
then (if (NULL COPIED)
then (SETQ DROW (COPYROW DROW))
(SETQ COPIED T))
(SETRELT DROW I DI)
else (UERROR)))
elseif (EQ DSPEC (QUOTE ALL))
then (SETQ DROW (GENROW 1 (fetch NDIMS of ARY)))
else (OR (LISTP DSPEC)
(SETQ DSPEC (LIST DSPEC)))
(SETQ DROW (create ROWINT
NELTS ←(LENGTH DSPEC)))
(for D in DSPEC as I from 1 do (SETRELT DROW I (MAKE1DIMSPEC ARY D]
"Invalid dimension specification: " .P2 DSPEC)
(RETURN DROW))])
(MAKE1SLTR
[DLAMBDA ((A ARRAY)
(SEL ANY)
(DIM INTEGER)
(PREDFLAG BOOL (* T if this call is predicational, not coercional))
(RETURNS (ONEOF INTEGER NIL)))
(* bas: "15-FEB-83 10:16")
(* Handles integer {perhaps virtual} or label level
selectors. Returns level number if its valid, otherwise
NIL if PREDFLG or causes a UERROR.)
(if (STRINGP SEL)
then (OR (NLSETQ (SETQ SEL (MKATOM SEL)))
(UERROR "Label too long: " .P2 SEL)))
(if (type? LABEL SEL)
then (if (GETLEVNUM A DIM SEL)
elseif (NOT PREDFLAG)
then (UERROR "Invalid level specification: " .P2 SEL))
else (DPROG ((LEVNUM NIL SCALAR))
(UERRORGUARD (OR (AND (SETQ LEVNUM (CONV.SCALAR SEL))
(OR (LEVELP A DIM (SETQ LEVNUM (FIXR LEVNUM)))
[AND (MINUSP LEVNUM)
(LEVELP A DIM (add LEVNUM 1
(GETRELT (fetch SHAPE of A)
DIM]
(SETQ LEVNUM NIL)))
PREDFLAG
(UERROR))
"Invalid level specification: " .P2 SEL)
(RETURN LEVNUM)))])
(MAKESLTR
[DLAMBDA ((A ARRAY)
(SEL ANY)
(DIM INTEGER (SATISFIES (DIMENSIONP A DIM)))
(RETURNS (ONEOF SIMARRAY INTEGER (MEMQ ALL))))
(* jop: "12-Nov-84 15:55" posted: "14-SEP-77 16:41")
(* Converts a user-level selector specification for
dimension DIM of A into a valid TTAB entry)
(DPROG (VAL)
(UERRORGUARD (if (EQ SEL (QUOTE ALL))
then (SETQQ VAL ALL)
elseif (LISTP SEL)
then (SETQ VAL (CONV.NARRAY SEL A DIM))
(ASSERT (type? SIMARRAY VAL)
(EQ (fetch AELTTYPE of VAL)
(QUOTE INTEGER)))
elseif (AND (type? ARRAY SEL)
(NOT (VSCALARP SEL)))
then (DPROG ((EB NIL ROWSCALAR)
(COPIED NIL BOOL))
(if [AND (type? SIMARRAY SEL)
(type? ROWINT (SETQ EB (fetch ELEMENTBLOCK of SEL]
then (SETQ VAL SEL)
elseif [HASNILS (SETQ EB (fetch ELEMENTBLOCK
of (SETQ VAL (COPYIDLARRAY
SEL
(QUOTE INTEGER]
then (UERROR)
else (SETQ COPIED T))
(DPROGN ((EB ROWINT))
(for J EBJ (TOP ←(ADD1 (GETRELT (fetch SHAPE of A)
DIM)))
to (fetch NELTS of EB)
declare (J IJK)
(EBJ IJK)
(TOP IJK)
unless (LEVELP A DIM (SETQ EBJ (GETRELT EB J)))
do (if (AND (MINUSP EBJ)
(LEVELP A DIM (add EBJ TOP)))
then (if (NULL COPIED)
then (SETQ COPIED T)
(SETQ VAL (COPYIDLARRAY VAL
(QUOTE INTEGER)
))
(SETQ EB (fetch ELEMENTBLOCK
of VAL)))
(SETRELT EB J EBJ)
else (UERROR))))
(if (NULL COPIED)
then (SETQ VAL (PRESERVE VAL))))
else (SETQ VAL (MAKE1SLTR A SEL DIM)))
"Illegal selector for dimension " DIM ": " .P2 SEL)
(RETURN VAL))])
(TITLE
[LAMBDA NIL (* rmk: " 4-FEB-80 08:48" posted: " 2-DEC-77 16:27")
(* Builds TITLE selector)
(create TITLESLTR])
)
(PUTPROPS AT CLISPINFIX @)
(PUTPROPS AT SETFN AT.ASSIGN)
(PUTPROPS @ CLISPTYPE (12 . 15))
(PUTPROPS @ LISPFN AT)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN TESTSYS
[DECLARE: EVAL@COMPILE
(RECORD CODESLTR (KEY CLEV VAL)
KEY ←(QUOTE *CODE*)
(TYPE? (EQ (CAR (LISTP DATUM))
(QUOTE *CODE*))))
(RECORD LABSLTR (KEY DIM LLEV)
KEY ←(QUOTE *LABEL*)
(TYPE? (EQ (CAR (LISTP DATUM))
(QUOTE *LABEL*))))
(RECORD TITLESLTR (KEY)
KEY ←(QUOTE *TITLE*)
(TYPE? (EQ (CAR (LISTP DATUM))
(QUOTE *TITLE*))))
]
)
)
(RPAQQ ALL ALL)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS AT COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (872 17727 (AT 882 . 3219) (AT.CODE 3221 . 4480) (AT.LABEL 4482 . 6335) (CODE 6337 .
6786) (INDEX 6788 . 7646) (INDEX1 7648 . 10494) (LABEL 10496 . 10851) (MAKE1DIMSPEC 10853 . 12239) (
MAKEDIMSPEC 12241 . 13628) (MAKE1SLTR 13630 . 15027) (MAKESLTR 15029 . 17476) (TITLE 17478 . 17725))))
)
STOP