(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