(FILECREATED "11-Feb-86 23:01:34" {QV}<IDL>SOURCES>ASSIGN.;12 13551
changes to: (FNS COPY CLISPIFYUSERFN COPYHACK)
(VARS ASSIGNCOMS)
previous date: " 7-Oct-85 22:03:18" {QV}<IDL>SOURCES>ASSIGN.;11)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ASSIGNCOMS)
(RPAQQ ASSIGNCOMS [(* Implementation of the IDL assignment operator)
(FNS ASSIGN ASSIGN! ASSIGN.CODE ASSIGN.LABEL ASSIGN.SELARRAY ASSIGNMAC COPYHACK)
(MACROS ASSIGN)
(* Kludge to get ASSIGN to clispify and dwimify properly)
(FNS AT.ASSIGNTRAN CLISPIFYUSERFN)
(VARS (CLISPIFYUSERFN T))
(PROP (ARGNAMES INFO)
ASSIGN)
(PROP CLISPWORD AT.ASSIGN)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA ASSIGN)
(NLAML)
(LAMA])
(* Implementation of the IDL assignment operator)
(DEFINEQ
(ASSIGN
[NLAMBDA ASSIGNARGS (* jop: " 5-Sep-85 17:24" posted: " 8-JUL-77 17:53")
(* The IDL assignment operator. This is an NLAMBDA cause we don't have label locatives, hence we must be able to
inspect the forms in order to fake it. The STKEVAL of the list is so that the argument list gets dwiified correctly.
This is not completely adequate, since the user will be in a funny state in a break.)
(DECLARE (SPECVARS ASSIGNARGS))
(APPLY (FUNCTION ASSIGN!)
(STKEVAL (QUOTE ASSIGN)
(CONS (QUOTE LIST)
ASSIGNARGS)
NIL
(QUOTE INTERNAL])
(ASSIGN!
[DLAMBDA ((TARGET (USEDIN UERROR break))
(SOURCE (USEDIN UERROR break)))
(CLISP:(RECORD ASSIGNARGS (TARGET SOURCE))) (* rmk: "18-NOV-79 20:47")
(* This body of ASSIGN is a separate function so that TARGET and SOURCE will be bound at a UERROR break.
However, breaks caused by bad labels won't work right--if the user resets TARGET, the ASSIGNARGS won't get updated)
(UENTRY 'ASSIGN
(if (type? SELARRAY TARGET)
then (ASSIGN.SELARRAY TARGET (CONV.ARRAY SOURCE))
elseif (LISTP ASSIGNARGS:TARGET):1='AT
then
(* This is a fake for label locatives. Everything has been dwimified correctly, but we are now going to re-evaluate
the source array and selector. Hopefully, these do not have bad side-effects, but ...)
(* We could avoid re-evaluation if we got the forms
dwimified without evaluating them, then inspected for
AT.)
(DPROG ((A (coerce (STKEVAL 'ASSIGN ASSIGNARGS:TARGET:2)
ARRAY))
(SLTR (STKEVAL 'ASSIGN ASSIGNARGS:TARGET:3)))
(SELECTQ ((LISTP SLTR):1)
(*LABEL* (ASSIGN.LABEL A SLTR SOURCE))
(*CODE* (ASSIGN.CODE A SLTR SOURCE))
[*TITLE* (SETTITLE A
(if (OR SOURCE=NIL (STRINGP SOURCE))
then SOURCE
elseif (ATOM SOURCE)
then (MKSTRING SOURCE)
elseif (LISTP SOURCE)
then (APPLY (FUNCTION MAKETITLE)
(if SOURCE:1
then SOURCE
else <'USER% FORM
! SOURCE::1>))
else (UERROR "Invalid title: " .P2 SOURCE]
(UERROR "TARGET not a selection: " .P2 TARGET)))
else (UERROR "TARGET not a selection: " .P2 TARGET)))
SOURCE])
(ASSIGN.CODE
[DLAMBDA ((A ARRAY)
(CODESPEC CODESLTR)
(SOURCE ANY))
(* rmk: " 4-FEB-80 08:51" posted: " 8-OCT-77 18:03")
(* Implements the assignment of CODE selections. Sets 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)
[if CODESPEC:CLEV=NIL
then (SETVALDIM A (MAKE1DIMSPEC A SOURCE))
else (DPROG ((VALDIM (GETVALDIM A) (ONEOF NIL INTEGER)))
(if VALDIM=NIL
then (UERROR "Value-labeled dimension not defined for " A))
[if CODESPEC:VAL
then (SETCODELAB A (MAKE1SLTR A CODESPEC:CLEV VALDIM)
(coerce CODESPEC:VAL ARITH (MSG "Invalid code value: " .P2 UARG)
)
(coerce SOURCE LABEL (MSG "Invalid code label: " .P2 UARG)))
else (SETCODES A (MAKE1SLTR A CODESPEC:CLEV VALDIM)
(for PAIR C (ATYPE ← A:AELTTYPE)
in (coerce SOURCE (ONEOF NIL CODEBOOK)
(MSG "Illegal codebook specification: " .P2 UARG))
collect (C←(coerce (LISTP PAIR):1 ARITH (MSG
"Illegal code value: "
.P2 UARG)))
(C←(if ATYPE='INTEGER
then (FIXR C)
else (FLOAT C)))
(if (SASSOC C $$VAL)
then (UERROR "Duplicate code specification: " .P2 C))
(create CODEPAIR
CODE ← C
CODELAB ←(coerce PAIR:2 LABEL
(MSG "Invalid code label: " .P2
UARG])]])
(ASSIGN.LABEL
[DLAMBDA ((A ARRAY)
(LABSPEC LABSLTR)
(SOURCE ANY))
(* jop: " 5-Sep-85 19:40" posted: " 9-FEB-79 19:32")
(* Returns the labels corresponding to a user
specification. Produces dimension or level
information.)
(if (NLISTP SOURCE)
then (SETQ SOURCE (LIST SOURCE))) (* Standardize SOURCE to a list)
[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))))
(SELTYPEQ SLTR
[INTEGER (SETLEVLAB A DIMNUM SLTR (coerce (CAR SOURCE)
LABEL
(MSG "Invalid label: " .P2
UARG]
[(MEMQ ALL)
(for L (S ← SOURCE) from 1 to (GETRELT (fetch SHAPE of A)
DIMNUM)
declare (L IJK)
do (SETLEVLAB A DIMNUM L (coerce (pop S)
LABEL
(MSG "Invalid label: " .P2 UARG)))
(if (NLISTP S)
then (SETQ S SOURCE]
[VECTOR (bind (S ← SOURCE)
(GSBS ←(SETUP SLTR (QUOTE ROWMAJOR)))
until (fetch DONE of GSBS)
do (SETLEVLAB A DIMNUM (GETAELT SLTR (NEXT GSBS))
(coerce (pop S)
LABEL
(MSG "Invalid label: " .P2 UARG)))
(if (NLISTP S)
then (SETQ S SOURCE]
(UERROR "Invalid label selector: " .P2 (fetch LLEV of LABSPEC))))
else (SELTYPEQ (fetch DIM of LABSPEC)
[(MEMQ ALL)
(for D (S ← SOURCE) from 1 to (fetch NDIMS of A)
do (SETDIMLAB A D (coerce (pop S)
LABEL
(MSG "Invalid label: " .P2 UARG)))
(if (NLISTP S)
then (SETQ S SOURCE]
[[ONEOF LISTP (ARRAY (SATISFIES ~(VSCALARP VALUE]
(DPROG ((SLTR (MAKEDIMSPEC A (fetch DIM of LABSPEC)) ROWINT))
(for I (S ← SOURCE) from 1 to (fetch NELTS of SLTR)
do (SETDIMLAB A (GETRELT SLTR I)
(coerce (pop S)
LABEL
(MSG "Invalid label: " .P2 UARG)))
(if (NLISTP S)
then (SETQ S SOURCE))))]
(SETDIMLAB A (MAKE1DIMSPEC A (fetch DIM of LABSPEC))
(coerce (CAR SOURCE)
LABEL
(MSG "Invalid label: " .P2 UARG]])
(ASSIGN.SELARRAY
[DLAMBDA ((TARG SELARRAY)
(SOURCE ANY))
(* rmk: "10-JAN-79 15:24" posted: " 7-OCT-77 19:20")
(* Assigns SOURCE through the selection window TARG)
(DPROG ((BA TARG:BASEARRAY SIMARRAY)
THEN (EB BA:ELEMENTBLOCK ROWSCALAR))
(if EB:REFCOUNT GT 1
then (add EB:REFCOUNT -1)
(replace REFCOUNT of (BA:ELEMENTBLOCK←(COPYROW EB)) with 1)))
(* Copyrow leaves refcnt at 0 -
we set to 1 for the frame)
[if (VSCALARP TARG)
then [SETAELT TARG (VSCALARPTR TARG)
(DPROG ((VAL [if [type? SCALAR (SOURCE←(coerce SOURCE (ONEOF SCALAR ARRAY)
(MSG "Invalid source: " UARG]
then SOURCE
else (GETAELT SOURCE (NEXT (SETUP SOURCE 'DONTCARE] SCALAR))
(RETURN (if (AND TARG:AELTTYPE='INTEGER (type? FLOATING VAL))
then (FIXR VAL)
else VAL)))]
else (SOURCE←(coerce SOURCE ARRAY (MSG "Source not an array: " UARG)))
(DPROG ((GSBT (SETUP TARG 'ROWMAJOR) GENSTATEBLOCK)
(GSBS (SETUP SOURCE 'ROWMAJOR) GENSTATEBLOCK)
(FIXFLG (AND TARG:AELTTYPE='INTEGER SOURCE:AELTTYPE='FLOATING) BOOL))
(until GSBT:DONE bind VAL
do (SETAELT TARG (NEXT GSBT)
(AND VAL←(GETAELT SOURCE (NEXT GSBS))
(if FIXFLG
then (FIXR VAL)
else VAL)))
(if GSBS:DONE
then (RESETUP GSBS))))]])
(ASSIGNMAC
[LAMBDA (TARG SRCE) (* rmk: " 2-DEC-79 22:56")
(* Compile hack for ASSIGN. Makes sure that argument
forms are compiled and bound to variables)
(if SRCE='$$S
then (* We hit an earlier output)
('IGNOREMACRO)
elseif (AND (LISTP TARG)
TARG:1='AT)
then (* Bind all args. This could be improved by noticing
constants, etc...)
(<'[LAMBDA ($$T1 $$T2 $$S)
(DECLARE (SPECVARS $$T1 $$T2 $$S))
(ASSIGN (AT $$T1 $$T2)$$S]
TARG:2 TARG:3 SRCE>)
else (* Don't understand the Target.
Must eventually evaluate to a selarray.
Bind values so that all local vars in the forms behave
correctly.)
(<'[LAMBDA ($$T1 $$S)
(DECLARE (SPECVARS $$T1 $$S))
(ASSIGN $$T1 $$S]
TARG SRCE>])
(COPYHACK
[LAMBDA (X) (* rmk: "25-JAN-83 14:57" posted: " 1-DEC-77 10:33")
(* This is LISP's COPYHACK function extended to "copy"
IDL arrays, suitably annotating their titles.)
(COND
((LISTP X)
(PROG (Y Z)
[SETQ Y (SETQ Z (LIST (COPYHACK (CAR X]
LP (COND
((NLISTP (SETQ X (CDR X)))
(FRPLACD Z (COPYHACK X))
(RETURN Y)))
[SETQ Z (CDR (FRPLACD Z (FRPLACD (CONS (COPYHACK (CAR X))
Z]
(GO LP)))
((TYPENAMEP X (QUOTE ARRAYFRAME))
(PROG ((C (PRESERVE X)))
(SETTITLE C (MAKETITLE (QUOTE COPYHACK)
X))
(RETURN C)))
(T X])
)
(DECLARE: EVAL@COMPILE
[PUTPROPS ASSIGN MACRO (ARGS (ASSIGNMAC (CAR ARGS)
(CADR ARGS]
)
(* Kludge to get ASSIGN to clispify and dwimify properly)
(DEFINEQ
(AT.ASSIGNTRAN
[LAMBDA (FORM) (* rmk: "21-JAN-79 21:28" posted: "21-JAN-79 21:23")
(* This finishes the translation of X@Y←Z into (ASSIGN (AT X Y) Z). FORM is the (AT.ASSIGN X Y Z) that dwimifying
the ← gives. This works because AT.ASSIGN is a fake clispword.)
CLISPCHANGE←T
FORM::1← <<'AT FORM:2 FORM:3> ! FORM::3> FORM:1←'ASSIGN])
(CLISPIFYUSERFN
[LAMBDA (FORM) (* rmk: "21-JAN-79 21:36" posted: "21-JAN-79 21:37")
(* Special hack to convert (ASSIGN (AT --) --) into the left-arrow format, given that Clisp doesn't understand the
2-argument form of assignment)
(if (AND (EQ (CAR FORM)
(QUOTE ASSIGN))
(EQ (CAR (LISTP (CADR FORM)))
(QUOTE AT)))
then (NCONC (CLISPIFY (CADR FORM))
(LIST (QUOTE ←))
(AND (LISTP (CDDR FORM))
(CLISPIFY (CDDR FORM])
)
(RPAQQ CLISPIFYUSERFN T)
(PUTPROPS ASSIGN ARGNAMES (NIL (TARGET SOURCE) . ASSIGNARGS))
(PUTPROPS ASSIGN INFO EVAL)
(PUTPROPS AT.ASSIGN CLISPWORD (AT.ASSIGNTRAN . ASSIGN))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA ASSIGN)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS ASSIGN COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (923 11924 (ASSIGN 933 . 1616) (ASSIGN! 1618 . 3603) (ASSIGN.CODE 3605 . 5296) (
ASSIGN.LABEL 5298 . 8079) (ASSIGN.SELARRAY 8081 . 9883) (ASSIGNMAC 9885 . 11037) (COPYHACK 11039 .
11922)) (12085 13135 (AT.ASSIGNTRAN 12095 . 12514) (CLISPIFYUSERFN 12516 . 13133)))))
STOP