(FILECREATED "22-Nov-85 15:52:24" {QV}<IDL>SOURCES>EXTEND.;20 32433
changes to: (FNS EAPPLY EAPPLY*MAC EAPPLY*)
previous date: " 7-Oct-85 22:11:20" {QV}<IDL>SOURCES>EXTEND.;19)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT EXTENDCOMS)
(RPAQQ EXTENDCOMS [(* Facilities and definitions for function extension)
(FNS EAPPLY EAPPLY* EAPPLY*MAC EAPPLY.CALLER EARGNAME EVALP EXPCHK EXPLIST EXPNUM EXTEND
EXTENDER EXTND.FIXROW EXTND.FNNAME EXTND.KEEPTITLE EXTND.MAPTITLE EXTND.PACKRSLT KEEP
KEEP.MERGE LEAVE)
(PROP ARGNAMES EAPPLY* KEEP LEAVE)
(IF: TESTSYS (MACROS EAPPLY EAPPLY* EVALP XDM))
[IF: (NOT TESTSYS)
(P (NCONC [OR (ASSOC (QUOTE APPLY)
BAKTRACELST)
(CAR (SETQ BAKTRACELST (CONS (CONS (QUOTE APPLY))
BAKTRACELST]
(QUOTE ((**EXTENSION** EXTENDER EAPPLY.CALLER *PROG*LAM)
(NIL EXTENDER *PROG*LAM)
(NIL EXTENDER EAPPLY.CALLER APPLY *PROG*LAM *PROG*LAM]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA LEAVE KEEP EXTENDER EAPPLY.CALLER EAPPLY*])
(* Facilities and definitions for function extension)
(DEFINEQ
(EAPPLY
[ULAMBDA ((FN FUNCTION (SATISFIES (EVALP FN)) "Function does not evaluate its arguments")
(EXPECTS LST)
(ARGS LISTP))
(* jop: " 5-Sep-85 17:24" posted: "14-SEP-77 20:35")
(* Extended APPLY)
(APPLY (FUNCTION EAPPLY.CALLER)
(CONS FN (CONS (EXPLIST EXPECTS)
ARGS)))])
(EAPPLY*
[LAMBDA EAPPLYARGS (* DECLARATIONS: (RECORD ARGRECORD
(FN EXPECTS . ARGS)))
(* jop: " 5-Sep-85 19:04" posted: "14-JAN-79 14:40")
(* Extended APPLY*)
(DECLARE (SPECVARS EAPPLYARGS))
(UENTRY (QUOTE EAPPLY*)
(bind AI EI EL FN
first (SETQ FN (SETARG EAPPLYARGS 1 (coerce (ARG EAPPLYARGS 1)
FUNCTION
(SATISFIES (EVALP VALUE))
"Function does not evaluate its arguments")))
[SETQ EL (SETARG EAPPLYARGS 2 (EXPLIST (ARG EAPPLYARGS 2]
for I from 3 to EAPPLYARGS
collect (if (if (EQ (CAR EL)
(QUOTE ...))
then EI
else (SETQ EI (pop EL)))
then (SETQ AI (coerce (ARG EAPPLYARGS I)
(ONEOF SCALAR ARRAY)
(MSG (EARGNAME FN (IDIFFERENCE I 2))
" is not a scalar or array: " .P2 UARG))
)
(AND (type? ARRAY AI)
(OR (fetch KEEPS of AI)
(IGREATERP (fetch NDIMS of AI)
EI))
(SETQ FN (FUNCTION EXTENDER)))
AI
else (ARG EAPPLYARGS I))
finally (RETURN (APPLY FN $$VAL])
(EAPPLY*MAC
[LAMBDA (EARGS EAPPLYFLG) (* jop: "22-Nov-85 15:49" posted: " 1-NOV-77 09:18")
(* Compiles calls to EAPPLY* and EAPPLY from system code where the function and expects are quoted and therefore
can be checked at compile-time. Main benefit besides speed is that it eliminates the EAPPLY* as a secret uentry on
the stack. If EAPPLYFLG is T, then this is a call from EAPPLY and the appropriate APPLY form is constructed.)
(PROG ((TEMP (CAR EARGS)))
(RETURN (if (AND (LISTP TEMP)
(FMEMB (CAR TEMP)
(QUOTE (QUOTE FUNCTION)))
(NULL (CADDR TEMP))
(OR (AND (FNTYP (CADR TEMP))
(EVALP (CADR TEMP)))
(HELP "BAD FUNCTION SPECIFICATION" TEMP))
(EQ (CAADR EARGS)
(QUOTE QUOTE)))
then [if EAPPLYFLG
then [LIST (QUOTE APPLY)
(QUOTE (FUNCTION EAPPLY.CALLER))
(LIST (QUOTE CONS)
(CAR EARGS)
(LIST
(QUOTE CONS)
[KWOTE (EXPLIST
(CADR (CADR EARGS]
(CADDR EARGS]
else (CONS (QUOTE EAPPLY.CALLER)
(CONS (CAR EARGS)
(CONS [KWOTE
(EXPLIST (CADR (CADR EARGS]
(CDDR EARGS]
else (QUOTE IGNOREMACRO])
(EAPPLY.CALLER
[LAMBDA EAPPLYARGS (* jop: " 5-Sep-85 19:05")
(* Does the spread for EAPPLY. Coercion is done here instead of EAPPLY because system calls to EAPPLY* are compiled
to go directly through here)
(DECLARE (SPECVARS EAPPLYARGS))
(bind AI EI (FN ←(ARG EAPPLYARGS 1))
(EL ←(ARG EAPPLYARGS 2)) for I from 3 to EAPPLYARGS
collect (if (if (EQ (CAR EL)
(QUOTE ...))
then EI
else (SETQ EI (pop EL)))
then (SETQ AI (coerce (ARG EAPPLYARGS I)
(ONEOF SCALAR ARRAY)
(MSG (EARGNAME FN (IDIFFERENCE I 2))
" is not a scalar or array: " .P2 UARG)))
(AND (type? ARRAY AI)
(OR (fetch KEEPS of AI)
(IGREATERP (fetch NDIMS of AI)
EI))
(SETQ FN (FUNCTION EXTENDER)))
AI
else (ARG EAPPLYARGS I))
finally (RETURN (APPLY FN $$VAL])
(EARGNAME
[LAMBDA (FN N) (* rmk: "21-APR-78 10:14" posted: "24-MAR-78 09:33")
(* Returns the name of the Nth argument of FN.
Used for EAPPLY-- error messages.)
(if (LITATOM (SETQ FN (ARGLIST FN)))
then (PACK* FN N)
else (CAR (NTH FN N])
(EVALP
[DLAMBDA ((F FUNCTION))
(* rmk: "18-APR-78 21:09" posted: " 5-OCT-77 15:28")
(* True if F is a function-object that evaluates its
arguments)
(FMEMB (ARGTYPE F)
(QUOTE (0 2)))])
(EXPCHK
[DLAMBDA ((EX LST)
(RETURNS LST))
(* bas: " 9-FEB-83 16:40")
(* Returns the sublist beginning with the first wrong
entry or NIL if they are all correct)
[for I TMP on EX thereis (if (LITATOM (CAR I))
then [NOT (OR (FMEMB (CAR I)
(QUOTE (SCALAR VECTOR MATRIX ARRAY NIL ...)))
(AND (NOT (CDR I))
(FMEMB (CAR I)
(QUOTE (.. ....)))
(FRPLACA I (QUOTE ...)))
(AND [SETQ TMP (FIXSPELL (CAR I)
70
(QUOTE (ARRAY SCALAR VECTOR
MATRIX]
(FRPLACA I TMP]
else (OR [UERRORGUARD (SETQ TMP (CONV.SCALAR (CAR I]
(AND TMP (MINUSP TMP]])
(EXPLIST
[DLAMBDA ((EL LST)
(RETURNS LST))
(* bas: "20-JAN-79 00:02" posted: "18-JAN-79 18:29")
(* Converts a user expects list into EXTENDER form)
[for I on EL collect (OR (AND (NOT (CDR I))
(SELECTQ (CAR I)
(... (QUOTE ...))
((.. ....)
(printout NIL "=..." T)
(QUOTE ...))
NIL))
(EXPNUM (CAR I]])
(EXPNUM
[DLAMBDA ((EI ANY)
(RETURNS (ONEOF CARDINAL NIL)))
(* bas: "15-FEB-83 11:50")
(* Translates a single expectation to a CARDINAL or
NIL)
(if (LITATOM EI)
then [SELECTQ EI
(SCALAR 0)
(VECTOR 1)
(MATRIX 2)
(ARRAY 1535)
(NIL NIL)
(EXPNUM (OR (FIXSPELL EI 70 (QUOTE (SCALAR ARRAY MATRIX VECTOR)))
(UERROR "Invalid expects entry: " EI]
else (coerce EI (ONEOF NIL CARDINAL)
(MSG "Invalid expects entry: " .P2 UARG)))])
(EXTEND
[ULAMBDA ((FN FUNCTION)
(EXPECTS LST))
(* rmk: "27-MAR-80 09:01" posted: " 8-SEP-77 10:33")
(* Modifies FN so that EXTENDER is called between entry
and execution of the body.)
(DPROG ((TMP NIL (ONEOF LST LITATOM))
(NEWNAME NIL LITATOM)
(DEF (if (LITATOM FN)
then (GETD FN)
else FN) ANY))
(if (AND (EXPRP DEF)
(for I in (CDDR DEF)
always (SELECTQ (CAR I)
[(EAPPLY EAPPLY*)
(if TMP
then NIL
elseif [AND (SETQ TMP (LISTP (CADR I)))
(FMEMB (CAR TMP)
(QUOTE (FUNCTION QUOTE)))
(EQUAL (ARGLIST DEF)
(if (EQ (CAR I)
(QUOTE EAPPLY))
then (CADDDR I)
else (CDDDR I]
then (SETQ TMP (CADR TMP]
((CLISP: DECLARE *)
T)
NIL)))
then (* The form was an extension form.
TMP is set to the EAPPLY* function)
(if (LITATOM TMP)
then (* Compiled code)
(SETQ DEF (GETD (SETQ NEWNAME TMP)))
else (* An embedded form)
(/RPLACD (CDR DEF)
(CDDR TMP)))
else (* Compiled code or subr)
(SETQ NEWNAME (PACK* FN (QUOTE .UNEXTENDED)))
(if (GETD NEWNAME)
then (/PUTD FN (SETQ DEF (GETD NEWNAME)))
(* Move the original definition back to FN if we are
about to extend it again)
else (/PUTD NEWNAME DEF)))
(* This shuffling of definitions must be done BEFORE what follows as the tests may not be true until it is done if
FN has previously been extended)
[if EXPECTS
then (* Otherwise we assume that the extension is to be
removed)
(OR (EVALP FN)
(UERROR FN " does not evaluate its arguments"))
(if (SETQ TMP (EXPCHK EXPECTS))
then (UERROR "Invalid EXPECTS entry: " (CAR TMP)))
(SETQ TMP (ARGLIST DEF))
(SETQ DEF (LIST (QUOTE LAMBDA)
TMP
(NCONC (LIST (if (LISTP TMP)
then (QUOTE EAPPLY*)
else (QUOTE EAPPLY))
(LIST (QUOTE FUNCTION)
(OR NEWNAME DEF)))
(CONS (KWOTE EXPECTS)
(OR (LISTP TMP)
(SUBST TMP (QUOTE TMP)
(QUOTE ((FOR I TO TMP
COLLECT (ARG TMP I]
(RETURN (if (LITATOM FN)
then (/PUTD FN DEF)
FN
else DEF)))])
(EXTENDER
[LAMBDA NXARGS
(* DECLARATIONS: (ACCESSFNS EXTENDER ((ARG (ARG NXARGS (the (INTEGER (SATISFIES (BETWEEN VALUE 1 NXARGS))) DATUM)))
(DIMMAP NIL (SETRELT DV DATUM NEWVALUE)) (DISC (the INTEGER (OR (GETRELTD DV DATUM) 0)) (SETRELTD DV DATUM
(the INTEGER NEWVALUE))) (TOOBIG (GETRELTD DV DATUM)))))
(* jop: " 5-Sep-85 19:06")
(DECLARE (USEDFREE EAPPLYARGS UERRORNAME))
(* The internal function for function extension. Slices ARGs up according to EXPs and KEEPs, applies FN to all the
pieces, and then packs the results together into a larger object.)
(DPROG ((FN (ARG EAPPLYARGS 1) FUNCTION)
(OUT NIL ANY (* Hook on which to hang the result))
(DV (create ROWPTR
NELTS ← NXARGS
INIT ← NIL) ROWPTR (* Dope vector! Disc and dimmaps in here))
(C NIL INTEGER (SATISFIES (BETWEEN C 1 NXARGS))
(* Controlling arg index))
(M NIL INTEGER (SATISFIES (IGREATERP M 0)) (* Maximum excess dims))
(SLCIDX NIL ROWINT (* Current slice index))
(EXTNDSHP NIL ROWINT (* Result shape))
(INVIDX NIL ROWINT (* INVerse InDeX to controlling arg)))
(for I A KEPT NDA NDE XD (EXPECTS ←(ARG EAPPLYARGS 2)) to NXARGS
when [AND (if (EQ (CAR EXPECTS)
(QUOTE ...))
then NDE
else (SETQ NDE (pop EXPECTS)))
(type? ARRAY (SETQ A (fetch ARG of I]
do (SETQ NDA (fetch NDIMS of A))
(SETQ XD
(IMAX (IDIFFERENCE NDA NDE)
(if (SETQ KEPT (fetch KEEPS of A))
then [OR (for I in KEPT as J from 1 always (IEQP I J))
(replace DIMMAP of I
with (bind (X ←(create ROWINT
NELTS ← NDA))
(L ←(FLENGTH KEPT)) declare (X ROWINT)
for J to NDA
do (SETRELT X
(OR (for P from 1 as K in KEPT
thereis (IEQP K J))
(add L 1))
J)
finally (RETURN X]
(FLENGTH KEPT)
else 0))) (* XD is max of expects discrepancies and keeps)
(if (IGREATERP XD 0)
then (if [OR (NOT M)
(ILESSP M XD)
(AND (IEQP M XD)
(LABELP A)
(NOT (LABELP (fetch ARG of C]
then (SETQ C I)
(SETQ M XD)) (* Is it the leftmost arg of greatest discrepancy?)
(replace DISC of I with XD) (* The number of dims to be held outside of FN.)
))
(SETQ INVIDX (GENROW 1 M))
[for I from 2 to M do (for J to (SUB1 I) unless (ILESSP (XDM C (GETRELT INVIDX J))
(XDM C (GETRELT INVIDX I)))
do (SETRELT INVIDX J (PROG1 (GETRELT INVIDX I)
(SETRELT INVIDX I (GETRELT INVIDX J]
(* INVIDX is the inverse of the permutation of the discrepant dimensions in the controlling argument.
This is used to map the slice subscripts out of SLCIDX onto the controlling argument dimensions and thus by yoking
onto all the other arguments)
(DPROG ((CSHP (fetch SHAPE of (fetch ARG of C)) ROWINT)
(ISHP NIL ROWINT))
(if [for I to NXARGS unless (EQ I C) when (fetch TOOBIG of I)
always (SETQ ISHP (fetch SHAPE of (fetch ARG of I)))
(for J to (fetch DISC of I) always (IEQP (GETRELT ISHP (XDM I J))
(GETRELT CSHP (XDM C J]
else (UERROR "Non-conformable argument extensions"))
(* Checking for conformability)
(SETQ EXTNDSHP (create ROWINT
NELTS ← M))
[for I to M do (SETRELT EXTNDSHP I (GETRELT CSHP (XDM C (GETRELT INVIDX I]
(* EXTNDSHP is the shape of the extension)
) (SETQ SLCIDX (create ROWINT
NELTS ← M
INIT ← 1))
[for IDX APPLYLIST RSLT (END ←(IPLUS (NLOGICALELTS EXTNDSHP))) from 1
until (IGREATERP IDX END)
first [SETQ APPLYLIST (for I to NXARGS
collect (if (fetch TOOBIG of I)
then (bind (SR ←(create ROWPTR
NELTS ←(fetch NDIMS
of (fetch ARG
of I))
INIT ←(QUOTE ALL)))
declare (SR ROWPTR) for J
to (fetch DISC of I)
do (SETRELT SR (XDM I J)
1)
finally (RETURN (FSELECT (fetch ARG
of I)
SR)))
else (fetch ARG of I]
(* Bindings: APPLYLIST: List of args that will go to FN via APPLY. RSLT: Hook on which to hang the return while you
ponder it. IDX: Index to the current result slice)
do (SETQ RSLT (coerce (APPLY FN APPLYLIST)
(ONEOF SCALAR ARRAY)
(MSG "Extension result is neither scalar nor array: " .P2 UARG)))
(* Make the call)
[if (VSCALARP RSLT)
then (SETQ RSLT (GETAELT RSLT (VSCALARPTR RSLT]
[if (type? ROWPTR OUT)
then [OR (AND (type? ARRAY RSLT)
(EQUALROW (fetch SHAPE of (GETRELT OUT 1))
(fetch SHAPE of RSLT)))
(SETQ OUT (EXTND.FIXROW OUT (IJKBOX (SUB1 IDX]
elseif (type? ROWSCALAR OUT)
then (UERRORGUARD (SETQ RSLT (CONV.SCALAR RSLT))
"Extension results have different shapes")
(* Previous returns must have been scalars)
[AND (type? FLOATING RSLT)
(EQ (fetch RELTTYPE of OUT)
(QUOTE INTEGER))
(SETQ OUT (FLOATROW OUT (IJKBOX (SUB1 IDX]
else (* Must be first call)
(SETQ OUT (create ROW
NELTS ←(NLOGICALELTS EXTNDSHP)
RELTTYPE ←(if (type? ARRAY RSLT)
then (QUOTE POINTER)
elseif (type? FLOATING RSLT)
then (QUOTE FLOATING)
else (QUOTE INTEGER]
(SETRELT OUT IDX RSLT)
(if (IEQP IDX END)
else (for J K V from M by -1 to 1 declare (V IJK)
do (SETRELT SLCIDX J (SETQ V (if (ILESSP (GETRELT SLCIDX J)
(GETRELT EXTNDSHP J))
then (ADD1 (GETRELT SLCIDX J))
else 1)))
(SETQ K (GETRELT INVIDX J))
(for I to NXARGS as A in APPLYLIST unless (IGREATERP K
(fetch DISC
of I))
do (ADJUST.SELECTION A (XDM I K)
V))
repeatwhile (IEQP V 1))) (* The adjustment is expensive, so bypass it on the
last slice)
finally [SETQ OUT (if (type? ROWPTR OUT)
then [EXTND.PACKRSLT OUT EXTNDSHP
(for I to NXARGS as J in APPLYLIST
when (AND (fetch TOOBIG of I)
(GETTITLE J T))
collect (CONS (GETTITLE J T)
(EXTND.KEEPTITLE
(fetch ARG of I]
else (* OUT=NIL iff the internal fn was never called so
build a dummy eltblk)
(create SIMARRAY
SHAPE ← EXTNDSHP
ELEMENTBLOCK ←(OR OUT (ROWINTOF))
FORMAT ←(QUOTE FULL]
(if LABPROPFLAG
then (for I (CA ←(fetch ARG of C)) to M
do (LAB.COPYDIM CA OUT (XDM C (GETRELT INVIDX I))
I)) (* Moving over labels from the controlling argument)
(OR (GETTITLE OUT T)
(SETTITLE OUT (APPLY (FUNCTION MAKETITLE)
(CONS (if (FMEMB UERRORNAME
(QUOTE (EAPPLY EAPPLY*)))
then (EXTND.FNNAME FN)
else UERRORNAME)
(for I IARG to NXARGS
collect (SETQ IARG
(fetch ARG of I))
(if (type? ARRAY IARG)
then (EXTND.KEEPTITLE
IARG)
else IARG]
(RETURN OUT))])
(EXTND.FIXROW
[DLAMBDA ((R ROWPTR)
(N INTEGER (SATISFIES (BETWEEN N 1 R:NELTS)))
(RETURNS ROWSCALAR))
(* jop: "12-Nov-84 16:11" posted: "30-AUG-78 03:09")
(* Called by EXTENDER to build a rowscalar from the ruins of the rowptr that is was trying to build when the user fn
suddenly returned a scalar. Tries to convert all the entries to scalars, noting their types, before allocating the
rowscalar.)
(DPROG ((NEW (create ROWSCALAR
NELTS ←(fetch NELTS of R)
RELTTYPE ←(OR (for I to N declare (I IJK)
do (UERRORGUARD (AND [type? FLOATING
(SETRELT R I
(CONV.SCALAR
(GETRELT R I]
(SETQQ $$VAL FLOATING))
"Extension results have different shapes"))
(QUOTE INTEGER))) ROWSCALAR))
(for I to N declare (I IJK) do (SETRELT NEW I (GETRELT R I)))
(RETURN NEW))])
(EXTND.FNNAME
[DLAMBDA ((F FUNCTION)
(RETURNS LITATOM))
(* rmk: "22-FEB-82 17:19" posted: "30-AUG-78 13:16")
(* Returns the function name from the object that is
being extended)
(if (LITATOM F)
then (OR (AND [STREQUAL ".UNEXTENDED" (SUBSTRING F -11 -1 (CONSTANT (CONCAT]
(NEQ F (QUOTE .UNEXTENDED))
(SUBATOM F 1 -12))
(AND (EQ (CHARCODE A)
(NTHCHARCODE F -5))
(for I from -4 by -1 to -1 always (BETWEEN (NTHCHARCODE F I)
(CHARCODE 0)
(CHARCODE 9)))
(SUBATOM F 1 -6))
F)
else (QUOTE EXTENDED% FORM))])
(EXTND.KEEPTITLE
[DLAMBDA ((A ARRAY)
(RETURNS TITLE))
(* bas: "18-JAN-79 20:54" posted: "30-AUG-78 13:16")
(* Returns the title of A adorned with its keeps. Called only from EXTENDER as that is the only fn that promotes
keeps into the title)
(DPROG ((AK (fetch KEEPS of A) LST)
(ATIT (GETTITLE A) TITLE))
(RETURN (if AK
then [CONS (QUOTE KEEP)
(CONS ATIT (for I in AK collect (OR (GETDIMLAB A I)
I]
else ATIT)))])
(EXTND.MAPTITLE
[DLAMBDA ((A ALIST)
(L ANY)
(RETURNS ANY))
(* bas: "25-SEP-78 15:43" posted: "30-AUG-78 18:48")
(* Fixes up the titles in EXTENDER by smashing in the
real titles for those that contain the EXTENDER
selection)
(OR (CDR (FASSOC L A))
(if (LISTP L)
then (for I in L collect (EXTND.MAPTITLE A I))
else L))])
(EXTND.PACKRSLT
[DLAMBDA ((RPTR ROWPTR)
(EXSHP ROWINT (SATISFIES (IEQP RPTR:NELTS (NLOGICALELTS EXSHP))))
(TITLEMAP ALIST (* ALIST of title translations))
(RETURNS SIMARRAY))
(* jop: "12-Nov-84 16:16" posted: " 9-SEP-78 01:05")
(* Code to pack together collected array results)
(DPROG ((N (fetch NELTS of RPTR) IJK)
THEN (RN (GETRELT RPTR N) ARRAY (* Random element))
THEN (ED (fetch NELTS of EXSHP) INTEGER (* External Dims))
(ID (fetch NDIMS of RN) INTEGER (* Internal Dims))
THEN (SHP (create ROWINT
NELTS ←(IPLUS ED ID)) ROWINT (* Shape of result))
(OUT NIL (ONEOF ROWSCALAR SIMARRAY) (* Hook for output)))
(for I to ED do (SETRELT SHP I (GETRELT EXSHP I)))
(bind (ISHP ←(fetch SHAPE of RN)) declare (ISHP ROWINT) for I to ID as J
from (ADD1 ED) do (SETRELT SHP J (GETRELT ISHP I)))
[SETQ OUT (create ROWSCALAR
NELTS ←(NLOGICALELTS SHP)
RELTTYPE ←(if (for I to N declare (I IJK)
always (EQ (fetch AELTTYPE of (GETRELT RPTR I))
(QUOTE INTEGER)))
then (QUOTE INTEGER)
else (QUOTE FLOATING]
[for I GSB RI (J ← 0)
declare (GSB GENSTATEBLOCK)
(I IJK)
(J IJK)
(RI ARRAY)
to N
do (SETQ GSB (SETUP (SETQ RI (GETRELT RPTR I))
(QUOTE ROWMAJOR)
GSB))
(until (fetch DONE of GSB) do (SETRELT OUT (add J 1)
(GETAELT RI (NEXT GSB]
(SETQ OUT (create SIMARRAY
SHAPE ← SHP
ELEMENTBLOCK ← OUT
FORMAT ←(QUOTE FULL))) (* Take keeps and labels from RN)
[if (fetch KEEPS of RN)
then (* If RN has keeps, then the corresponding dims in OUT
are kept, as well as all the external dimensions)
(replace KEEPS of OUT with (NCONC (for I from 1 to ED collect I)
(for I in (fetch KEEPS of RN)
collect (IPLUS ED I]
[if LABPROPFLAG
then (for I to ID do (LAB.COPYDIM RN OUT I (IPLUS I ED)
T))
(SETTITLE OUT (EXTND.MAPTITLE TITLEMAP (GETTITLE RN T]
(RETURN OUT))])
(KEEP
[LAMBDA NARGS (* bas: "10-FEB-83 16:54")
(* If input is kept, new dimensions are added as specified. If dimensionspec is NIL, no changes to the keeps are
made. If there is no dimensionspec, a vector of the old keeps is returned, if any)
(UENTRY (QUOTE KEEP)
(DPROG ((A (coerce (if (IGREATERP NARGS 0)
then (ARG NARGS 1)
else (QUOTE Defaulted))
ARRAY) ARRAY)
THEN (AK (fetch KEEPS of A) LST)
(RETURNS ARRAY))
[if (ILESSP NARGS 2)
then (* Request for existing KEEPS)
(RETURN (VFROMR (if AK
then (CONV.ROWINT AK)
else (ROWINTOF))
(MAKETITLE (QUOTE Keeps)
A]
(SETQ A (PRESERVE A))
(replace KEEPS of A
with (if (AND (EQ NARGS 2)
(EQ (ARG NARGS 2)
(QUOTE ALL)))
then (for I to (fetch NDIMS of A) collect I)
else (KEEP.MERGE (for I VAL ARG from 2 to NARGS when (SETQ ARG
(ARG NARGS I))
join (if [UERRORGUARD (SETQ VAL
(LIST (MAKE1DIMSPEC A ARG]
then (SETQ VAL (MAKEDIMSPEC A ARG))
(for J from 1
to (fetch NELTS of VAL)
collect (GETRELT VAL J))
else VAL))
AK)))
(RETURN A))])
(KEEP.MERGE
[DLAMBDA ((NK LST)
(OK LST)
(RETURNS LST))
(* bas: "18-JAN-79 20:50" posted: "18-JAN-79 22:19")
(* Merges the new and old keeps.
New keeps are new structure and can be modified,
whereas old ones must be copied)
(if NK
then (bind (I ← NK) do (if (for J on NK until (EQ J (CDR I)) thereis (EQ (CADR I)
(CAR J)))
then (FRPLACD I (CDDR I))
else (SETQ I (CDR I)))
while (CDR I))
(NCONC NK (for I in OK collect I unless (FMEMB I NK)))
else (COPY OK))])
(LEAVE
[LAMBDA NARGS (* rmk: " 2-MAR-80 10:23" posted: "12-OCT-77 17:58")
(* If input is kept, new dimensions are removed as
specified)
(UENTRY (QUOTE LEAVE)
(DPROG ((A (coerce (if (IGREATERP NARGS 0)
then (ARG NARGS 1)
else (QUOTE Defaulted))
ARRAY) ARRAY)
THEN (AK (fetch KEEPS of A) LST)
(RETURNS ARRAY))
(SETQ A (PRESERVE A)) (* We now have an unkept, smashable arrayframe)
[if (AND AK (IGREATERP NARGS 1))
then (replace KEEPS of A
with (if [NOT (AND (EQ NARGS 2)
(EQ (ARG NARGS 2)
(QUOTE ALL]
then (for J VAL from 2 to NARGS
do (SETARG NARGS J
(if [UERRORGUARD (SETQ VAL
(MAKE1DIMSPEC
A
(ARG NARGS J]
then (MAKEDIMSPEC A (ARG NARGS J))
else VAL)))
(for I in AK collect I
unless (for J ARGJ from 2 to NARGS
thereis
(if (EQ I (SETQ ARGJ (ARG NARGS J)))
elseif (type? ROWINT ARGJ)
then (DPROGN ((ARGJ ROWINT))
(for M from 1
to (fetch NELTS of ARGJ)
thereis (IEQP I
(GETRELT ARGJ M)
)))]
(RETURN A))])
)
(PUTPROPS EAPPLY* ARGNAMES (NIL (FN EXPECTS ARGS ...) . EXTNDARGS))
(PUTPROPS KEEP ARGNAMES (NIL (A DIMS ...) . NARGS))
(PUTPROPS LEAVE ARGNAMES (NIL (A DIMS ...) . NARGS))
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN TESTSYS
(DECLARE: EVAL@COMPILE
(PUTPROPS EAPPLY MACRO (ARGS (EAPPLY*MAC ARGS T)))
(PUTPROPS EAPPLY* MACRO (ARGS (EAPPLY*MAC ARGS)))
[PUTPROPS EVALP MACRO ((F)
(FMEMB (ARGTYPE F)
(QUOTE (0 2]
(PUTPROPS XDM MACRO ((ARG DARG)
([LAMBDA (DMAP DIM)
(COND (DMAP (GETRELT (the ROWINT DMAP)
DIM))
(T DIM]
(GETRELT DV ARG)
DARG)))
)
)
)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN (NOT TESTSYS)
[NCONC [OR (ASSOC (QUOTE APPLY)
BAKTRACELST)
(CAR (SETQ BAKTRACELST (CONS (CONS (QUOTE APPLY))
BAKTRACELST]
(QUOTE ((**EXTENSION** EXTENDER EAPPLY.CALLER *PROG*LAM)
(NIL EXTENDER *PROG*LAM)
(NIL EXTENDER EAPPLY.CALLER APPLY *PROG*LAM *PROG*LAM]
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA LEAVE KEEP EXTENDER EAPPLY.CALLER EAPPLY*)
)
(PUTPROPS EXTEND COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1217 31233 (EAPPLY 1227 . 1697) (EAPPLY* 1699 . 3166) (EAPPLY*MAC 3168 . 4652) (
EAPPLY.CALLER 4654 . 5716) (EARGNAME 5718 . 6136) (EVALP 6138 . 6494) (EXPCHK 6496 . 7457) (EXPLIST
7459 . 8023) (EXPNUM 8025 . 8722) (EXTEND 8724 . 11888) (EXTENDER 11890 . 21064) (EXTND.FIXROW 21066
. 22147) (EXTND.FNNAME 22149 . 22998) (EXTND.KEEPTITLE 23000 . 23634) (EXTND.MAPTITLE 23636 . 24206)
(EXTND.PACKRSLT 24208 . 27011) (KEEP 27013 . 28676) (KEEP.MERGE 28678 . 29491) (LEAVE 29493 . 31231)))
))
STOP