(FILECREATED " 3-JUN-79 09:49:57" <NEWLISP>TSET.;2
 18693  

     changes to:  TRANSORSET LISPXUSERFN TSETCOMS TSETFNS TRANSORSETUSERFN

     previous date: " 8-Jul-76 23:22:21" <LISP>TSET.;6)


(PRETTYCOMPRINT TSETCOMS)

(RPAQQ TSETCOMS
 [(FNS * TSETFNS)
	TSETMACROS
	(VARS (LISPXMACROS (UNION TSETMACROS LISPXMACROS))
|
	      (TESTFORM)
	      [LISPXCOMS (UNION LISPXCOMS (MAPCAR TSETMACROS (FUNCTION CAR]
|
	      (MERGE)
	      (PRETTYDEFMACROS
		(CONS [QUOTE (TRANSAVE NIL DUMPFILE USERNOTES NLISTPCOMS LAMBDACOMS
				       (PROP XFORM * TRANSFORMATIONS)
				       (P (COND [(EQ (EVALV (QUOTE MERGE))
						     T)
						 [RPAQ TRANSFORMATIONS
						       (UNION TRANSFORMATIONS
							      (LISTP (GETP (QUOTE TRANSFORMATIONS)
									   (QUOTE VALUE]
						 (MAPC (GETP (QUOTE USERNOTES)
							     (QUOTE VALUE))
						       (FUNCTION (LAMBDA (NOTE)
									 (OR (ASSOC (CAR NOTE)
										    USERNOTES)
									     (SETQ USERNOTES
										   (CONS NOTE 
											USERNOTES]
						(T (MAPC (GETP (QUOTE TRANSFORMATIONS)
							       (QUOTE VALUE))
							 (FUNCTION (LAMBDA
								     (X)
								     (AND (NOT (MEMB X TRANSFORMATONS)
									       )
									  (/REMPROP X (QUOTE XFORM]
		      PRETTYDEFMACROS))
	      (LCASELST (APPEND (QUOTE (DO TRANSFORMATIONS))
				LCASELST)))
	(PROP UCASE BBN LISP SRI MIT QA3 PLANNER UCI INTERLISP)
	(PROP FILEGROUP TSET)
	(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
									      (NLAML TRANSUNDER)
									      (LAMA])

(RPAQQ TSETFNS
 (TRANSORSET TRANSORINPUTP TRANSORSETUSERFN RUMARK RUMARK1 TRANSUNDER TXFN TXFN1 TXDUMP 

|
			   TXERASE TXERASE1 TXTEST TXSHOW TXEDIT TXEXIT TXNOTE GENREMNAM TXDELNOTE))
(DEFINEQ

(TRANSORSET

  [LAMBDA NIL                                               (* wt: " 2-JUN-79 18:53")

    (PROG (CURRENTFN)
          (COND
	    ((NOT (BOUNDP (QUOTE TRANSFORMATIONS)))
|
	      (RPAQ TRANSFORMATIONS NIL)
|
	      (RPAQ USERNOTES NIL)
|
	      (RPAQ UDRS)))

          (* CURRENTFN must be bound in the outer PROG so that 
          errors don't change its setting to NIL.
          LISPXHIST must be bound in the inner PROG so that 
          the initialization above will go on the history-list 
          with the call to TRANSORSET, not with the first 
          input to it. The normal return from TRANSORSET is 
          via a RETFROM in TRANSEXIT.
          The ERSETQ returns only from a control E or error.)



      OUTER
          (USEREXEC (QUOTE +)
|
		    NIL
|
		    (QUOTE TRANSORSETUSERFN))
|
          (CLEARBUF T)
          (GO OUTER])

(TRANSORINPUTP
  [LAMBDA (A B)

          (* TRANSORSET has a feature whereby any random edit 
          commands typed to the + sign will be accepted as 
          part of the transformation for CURRENTFN.
          See LISPXUSERFN. TRANSORINPUTP has to decide if the 
          input looks like edit commands.
          If so, return T. A is the first thing on the input 
          line, B is a list (possibly NULL) of all the other 
          inputs on that line.)


    (PROG NIL

          (* The following test for edit input is more 
          stringent than the DWIM test which causes LISPX to 
          edit the nearest reasonable thing.
          Numbers, e.g., are not caught by DWIM because they 
          do not cause errors. However, some mistakes will not 
          be noticed by this test. Typing BO as if an atomic 
          editcommand is not legal edit input but will pass 
          this test if there is something else on the line.
          Hopefully that will not matter much.)


          (COND
            ((AND (NULL A)
                  (NULL B))                     (* True only for extra 
                                                paren's and NIL's.)
              (RETURN))
            ((EQ A (QUOTE PP))
              (RETURN)))
          (RETURN (OR (SMALLP A)
                      [AND (LITATOM A)
                           (OR (FMEMB A EDITCOMSA)
                               (AND B (FMEMB A EDITCOMSL]
                      (AND (LISTP A)
                           (OR (SMALLP (CAR A))
                               (AND (LITATOM (CAR A))
                                    (FMEMB (CAR A)
                                           EDITCOMSL])

(TRANSORSETUSERFN

  [LAMBDA (A B)                                             (* wt: " 2-JUN-79 19:06")

    (PROG (INLINE)
          (COND
|
	    ((NULL (TRANSORINPUTP
 A B))
|
	      
|

|
          (* Not random editcommands, so let LISPX handle it normally. All the other TRANSORSET stuff is implemented as 

|
	  vanilla LISPXMACROS so don't have to worry about it here.)

|

|

|
	      (RETURN)))
|
          (SETQ INLINE (CONS (COPY A)
			     (COPY B)))

          (* Always copy the works, since it will be put onto 
          the property list and will likely be edited and 
          added to a lot during the next few history events 
          and we don't want to show this on the history list.
          I.e. show input as typed in, so a REDO does what one 
          expects.)



          (AND (LITATOM A)
	       (NULL (FMEMB A EDITCOMSA))
	       (FMEMB A EDITCOMSL)
	       (SETQ INLINE (LIST INLINE)))

          (* Convert an input line such as 
          "BO 4 5 <carriage return>" to simply be 
          (BO 4 5).)



          (COND
	    ((NULL CURRENTFN)
	      (ERROR (QUOTE "You must specify a function with the 'fn' command")
		     (QUOTE "before transformations can be stored")
		     T)))
          (RUMARK
 INLINE CURRENTFN)
          (/PUT CURRENTFN (QUOTE XFORM)
		(/NCONC (GETP CURRENTFN (QUOTE XFORM))
			INLINE))
          (LISPXSTOREVALUE LISPXHIST CURRENTFN)
|

          (* I want to show where these TRANSFORMATIONS went on history list in case user gets confused;

	  but I don't want to be printing it at him each time around the loop. The only way to avoid printing is to RETFROM 

	  out of LISPX; but if I do that, I have to put the 'value' on the history myself.)



          (RETFROM (QUOTE LISPX])

(RUMARK
  [LAMBDA (XFORM FN)
    (AND (LISTP XFORM)
         (EDITFINDP XFORM (QUOTE (REMARK --))
                    T)
         (EDITE (LIST XFORM)
                (QUOTE ((LPQ F (REMARK --)
                             (E (RUMARK1)
                                T])

(RUMARK1
  [LAMBDA NIL                                   (* dcl: 7 Jul 76 15:57)
    (PROG ((CALL (CAR L))
	   RNAME TEXT)
          (COND
	    ((NLISTP (CDR CALL))                (* Illegally formed;
						complain.)
	      (PRIN1 (QUOTE "
Warning - badly formed remark: ")
		     T)
	      (PRINT CALL T T))
	    ([AND (NULL (CDDR CALL))
		  (LITATOM (SETQ RNAME (CADR CALL]
                                                (* Standard use of named
						remark: (REMARK REMNAME)
)
	      )
	    ([OR [LISTP (CDR (SETQ TEXT (CDR CALL]
		 (LISTP (SETQ TEXT (CADR CALL]

          (* The user may type (REMARK RANDOM TEXT) or 
	  (REMARK (RANDOM TEXT)). Either way, we make it into 
	  a named remark and add star 
	  (COMMENTFLG) if necessary.)


	      [/RPLACD CALL (LIST (SETQ RNAME (GENREMNAM FN]
                                                (* FN is picked up free 
						from RUMARK.)
	      (OR (EQ (CAR TEXT)
		      COMMENTFLG)
		  (SETQ TEXT (CONS COMMENTFLG TEXT)))
	      (/SETATOMVAL (QUOTE USERNOTES)								       |
			   (CONS (LIST RNAME TEXT)								       |
				 USERNOTES])

(TRANSUNDER
  [NLAMBDA (TSETFN FLG)

          (* This function is used by the TRANSORSET commands 
          implemented as LISPXMACROS, to do initial checks.
          Abort if not at + sign, and make sure that every 
          element of the input line is atomic, unless FLG=T 
          (for the TEST command, the only one at present which 
          can legally take a non-atomic arg.))


    (COND
      ((NEQ (EVALV (QUOTE LISPXID))
            (QUOTE +))
        (LISPXUNREAD (QUOTE (REDO -1)))
        (TRANSORSET))
      (T [OR FLG (MAPC LISPXLINE (FUNCTION (LAMBDA (X)
                           (COND
                             ((NOT (LITATOM X))
                               (ERROR (QUOTE "Arg not litatom:")
                                      X T]
         (APPLY* TSETFN LISPXLINE])

(TXFN
  [LAMBDA (LIN)
    (COND
      ((NULL LIN)

          (* 'FN' followed by carriage return or NIL at + will 
          just print current value of CURRENTFN without 
          changing it.)


        CURRENTFN)
      (T [MAPC LIN (FUNCTION (LAMBDA (X)
                   (TXFN1 X T]
         (CAR (LAST LIN])

(TXFN1
  [LAMBDA (FN OLDMESS)                          (* dcl: 7 Jul 76 15:58)

          (* TXFN1 is used in several ways.
	  TXFN uses it to reset CURRENTFN, but never to NIL.
	  Other function use it to reset CURRENTFN to NIL, to 
	  their last arg, or for side effect of 'noticing' a 
	  FN name.)


    (AND CURRENTFN (NULL (GETP CURRENTFN (QUOTE XFORM)))
	 (/SETATOMVAL (QUOTE TRANSFORMATIONS)								       |
		      (/DREMOVE CURRENTFN TRANSFORMATIONS)))								       |

          (* It is desirable to avoid accumulating atoms on 
	  TRANSFORMATIONS which never got any entries.
	  User probably mistyped the arg to a FN command, and 
	  should be able to just do FN again without having to
	  ERASE the bad entry.)


    (AND OLDMESS FN (GETP FN (QUOTE XFORM))
	 (PRIN1 (QUOTE "You're adding to old xforms.")
		T))                             (* If the new CURRENTFN 
						already has some 
						TRANSFORMATIONS, alert 
						user.)
    (AND FN (NULL (FMEMB FN TRANSFORMATIONS))
	 (/SETATOMVAL (QUOTE TRANSFORMATIONS)								       |
		      (CONS FN TRANSFORMATIONS)))								       |

          (* Put FN on TRANSFORMATIONS if necessary, and 
	  finally reset CURRENTFN. Value of TXFN1 is not 
	  used.)


    (SAVESETQ CURRENTFN FN)
    NIL])

(TXDUMP
  [LAMBDA (LIN)                                 (* dcl: 8 Jul 76 23:22)
    (PROG ((FILE (CAR LIN))
	   F)
          (TXFN1)
          (SORT TRANSFORMATIONS)
          (SORT USERNOTES T)
          [COND
	    (FILE (SETQ F FILE))
	    ((NEQ (QUOTE NOBIND)
		  DUMPFILE)
	      (SETQ F DUMPFILE))
	    (T (PRIN1 (QUOTE "
File to dump on: ")
		      T)
	       (SETQ F (RATOM T T]
          (COND
	    ((NULL (SETQ FILE (OUTFILEP F)))
	      (ERROR (QUOTE "Cannot open file:")
		     F T)))
          (/SETATOMVAL (QUOTE DUMPFILE)
		       F)
          (SETQ F (NAMEFIELD F))
          [COND
	    ((NOT (ASSOC (QUOTE TRANSAVE)
			 XFORMSVARS))

          (* Initialize VARS if necessary;
	  if some existing stuff just add TSET's command to 
	  it, otherwise initialize to 
	  ((transave)))


	      (/SETATOMVAL (QUOTE XFORMSVARS)
			   (CONS (LIST (QUOTE TRANSAVE))
				 (LISTP XFORMSVARS]
          (COND
	    ((EQ XFORMSFNS (QUOTE NOBIND))

          (* If we leave it nobind, PRETTYDEF won't write out 
	  an RPAQQ and therefore when FILE is loaded it won't 
	  clobber any possible previous settings of 
	  xformsfns.)


	      (/SETATOMVAL (QUOTE XFORMSFNS)
			   NIL)))
          (AND XFORMSFNS (NOT (MEMB (QUOTE XFORMSFNS)								       |
				    XFORMSVARS))								       |
	       (/SETATOMVAL (QUOTE XFORMSVARS)								       |
			    (CONS (QUOTE XFORMSFNS)								       |
				  XFORMSVARS)))								       |
          (PRETTYDEF XFORMSFNS FILE (QUOTE XFORMSVARS))								       |
          (RETURN FILE])

(TXERASE
  [LAMBDA (LIN)

          (* Forgets the TRANSFORMATIONS for functions.
          Undoable. Has to remove the property entry with 
          REMPROP, and take them off the list TRANSFORMATIONS.
          Always resets CURRENTFN to NIL.
          ERASE followed by carriage return erases CURRENTFN.)


    (COND
      ((NLISTP LIN)
        (TXERASE1 CURRENTFN))
      (T (TXFN1 (CAR (LAST LIN)))
         (MAPCAR LIN (FUNCTION TXERASE1])

(TXERASE1
  [LAMBDA (FN)                                  (* dcl: 7 Jul 76 16:00)
    (AND (FMEMB FN TRANSFORMATIONS)
	 (/SETATOMVAL (QUOTE TRANSFORMATIONS)								       |
		      (/DREMOVE FN TRANSFORMATIONS)))								       |
    (COND
      ((GETP FN (QUOTE XFORM))
	(/REMPROP FN (QUOTE XFORM))
	FN)
      (T (CONS FN (QUOTE (-- NOTHING FOUND.])

(TXTEST
  [LAMBDA (LIN)                                 (* dcl: 7 Jul 76 16:00)
    (PROG ((TESTRAN T)
	   (OLDO (OUTPUT T)))

          (* TESTRAN is a flag used by the listing machinery 
	  to suppress listing for the tests made my the TEST 
	  command.)


          (COND
	    ((LISTP (CAR LIN))
	      (/SETATOMVAL (QUOTE TESTFORM)								       |
			   (CAR LIN)))								       |
	    ((NULL TESTFORM)
	      (ERROR (QUOTE "Correct format is:")
		     (QUOTE 
		     "+TEST (SAMPLE S-EXPRESSION TO BE TRANSOR'ED)")
		     T)))
          (COND
	    ((NULL (GETD (QUOTE TRANSORFORM)))
	      (ERROR (QUOTE 
   "You must load <LISP>TRANSOR.COM before using the TEST command.")
		     (QUOTE "")
		     T)))
          (RETURN (PROG1 (TRANSORFORM (COPY TESTFORM))
			 (OUTPUT OLDO])

(TXSHOW
  [LAMBDA (LIN)
    (PROG [(OLDO (OUTPUT T))
	   (FLG (OR (NULL LIN)
		    (CDR LIN]
          (OR LIN (SETQ LIN (LIST CURRENTFN)))
          [MAPC LIN (FUNCTION (LAMBDA (FN)
		    (TXFN1 FN)
		    (COND
		      (FLG 

          (* Print the name of each transformation being shown 
          if more than one being done, or if doing the 
          default)


			   (PRINT FN NIL T)))
		    [PRINTDEF (OR (GETP FN (QUOTE XFORM))
				  (QUOTE (No transformations]
		    (TERPRI]
          (OUTPUT OLDO)
          (RETURN (CAR (LAST LIN])

(TXEDIT
  [LAMBDA (LIN)
    (OR LIN (SETQ LIN (LIST CURRENTFN)))
    [MAPC LIN (FUNCTION (LAMBDA (FN)
              (TXFN1 FN)
              (RUMARK (PUT FN (QUOTE XFORM)
                           (EDITE (OR (GETP FN (QUOTE XFORM))
                                      (ERROR FN (QUOTE "not editable.")
                                             T))
                                  NIL FN))
                      FN]
    (CAR (LAST LIN])

(TXEXIT
  [LAMBDA NIL                                   (* dcl: 7 Jul 76 16:01)
    (SETATOMVAL (QUOTE USERINPUTP))								       |
    (RETFROM (QUOTE TRANSORSET])

(TXNOTE
  [LAMBDA (LIN)                                 (* dcl: 7 Jul 76 16:01)

          (* Remark has a mandatory arg, the name of the 
	  remark. If old, edits it; if new, demands TEXT and 
	  enters it on USEREMARKS.)


    (PROG ((NAME (CAR LIN))
	   TEXT)
          (COND
	    ((OR (NULL NAME)
		 (NULL (LITATOM NAME)))
	      (ERROR (QUOTE "Arg not litatom:")
		     NAME T))
	    ((SETQ TEXT (CADR (FASSOC NAME USERNOTES)))
	      [EDITE (COND
		       ((EQ (CADR TEXT)
			    (QUOTE %%))         (* Don't edit the star 
						and per-cent sign we put
						in for him.)
			 (CDDR TEXT))
		       (T (CDR TEXT]            (* Old remark;
						EDIT it.)
	      (RETURN NAME))
	    ((LISTP (SETQ TEXT (CDR LIN)))      (* He should be able to 
						type either 
						"REMARK NAME RANDOM TEXT"
)
	      [COND
		((AND (LISTP (CAR TEXT))
		      (NULL (CDR TEXT)))        (* or 
						"REMARK NAME(RANDOM TEXT]"
)
		  (SETQ TEXT (CAR TEXT]
	      (GO CHECKTXT))
	    ((NOT (LISPXREADP))
	      (PRIN1 (QUOTE "Text: ")
		     T)))
          (SETQ TEXT (READ T T))
          [COND
	    ((NLISTP TEXT)
	      (SETQ TEXT (CONS TEXT (READLINE]

          (* Make sure it works whether he types in a list or 
	  a line.)


      CHECKTXT
          (OR (EQ (CAR TEXT)
		  COMMENTFLG)
	      (SETQ TEXT (CONS COMMENTFLG TEXT)))
                                                (* Make sure it has a 
						star.)
          (/SETATOMVAL (QUOTE USERNOTES)								       |
		       (CONS (LIST NAME TEXT)								       |
			     USERNOTES))        (* Enter on list of 								       |
						remarks he has defined.)
          (RETURN NAME])

(GENREMNAM
  [LAMBDA (FN)

          (* Generates a name for a remark which has been used 
          in the transformation for FN.)


    (PROG [(N 0)
           (NAM (PACK (LIST FN (QUOTE :]
      CHECKIT
          (COND
            ((NULL (FASSOC NAM USERNOTES))      (* Name hasn't been used
                                                already so is ok.)
              (RETURN NAM)))
          [SETQ NAM (PACK (LIST FN (SETQ N (ADD1 N))
                                (QUOTE :]       (* Otherwise try again, 
                                                adding, or incrementing,
                                                a suffix of the FORM n:)
          (GO CHECKIT])

(TXDELNOTE
  [LAMBDA (LIN)                                 (* dcl: 7 Jul 76 16:02)
    (MAPCAR LIN (FUNCTION (LAMBDA (R1 TMP)
		(SETQ TMP (FASSOC R1 USERNOTES))
		(COND
		  [(NULL TMP)
		    (CONS R1 (QUOTE (NOT FOUND]
		  (T (/SETATOMVAL (QUOTE USERNOTES)								       |
				  (/DREMOVE TMP USERNOTES))								       |
		     R1])
)

(RPAQQ TSETMACROS
 ((SHOW (TRANSUNDER TXSHOW))
		   (EXIT (TRANSUNDER TXEXIT))
		   (NOTE (TRANSUNDER TXNOTE T))
		   (TEST (TRANSUNDER TXTEST T))
		   (ERASE (TRANSUNDER TXERASE))
		   (EDIT (TRANSUNDER TXEDIT))
		   (DUMP (TRANSUNDER TXDUMP))
		   (FN (TRANSUNDER TXFN))
		   (DELNOTE (TRANSUNDER TXDELNOTE))))

(RPAQ LISPXMACROS
 (UNION TSETMACROS LISPXMACROS))

(RPAQ TESTFORM
 NIL)

(RPAQ LISPXCOMS
 (UNION LISPXCOMS (MAPCAR TSETMACROS (FUNCTION CAR))))

(RPAQ MERGE
 NIL)

(RPAQ PRETTYDEFMACROS
 (CONS [QUOTE (TRANSAVE NIL DUMPFILE USERNOTES NLISTPCOMS LAMBDACOMS
					     (PROP XFORM * TRANSFORMATIONS)
					     (P (COND [(EQ (EVALV (QUOTE MERGE))
							   T)
						       [RPAQ TRANSFORMATIONS
							     (UNION TRANSFORMATIONS
								    (LISTP (GETP (QUOTE 
										  TRANSFORMATIONS)
										 (QUOTE VALUE]
						       (MAPC (GETP (QUOTE USERNOTES)
								   (QUOTE VALUE))
							     (FUNCTION (LAMBDA
									 (NOTE)
									 (OR (ASSOC (CAR NOTE)
										    USERNOTES)
									     (SETQ USERNOTES
										   (CONS NOTE 
											USERNOTES]
						      (T (MAPC (GETP (QUOTE TRANSFORMATIONS)
								     (QUOTE VALUE))
							       (FUNCTION
								 (LAMBDA (X)
									 (AND (NOT (MEMB X 
										   TRANSFORMATONS))
									      (/REMPROP X
											(QUOTE XFORM]
			    PRETTYDEFMACROS))

(RPAQ LCASELST
 (APPEND (QUOTE (DO TRANSFORMATIONS))
		       LCASELST))

(PUTPROPS BBN UCASE
 T)

(PUTPROPS LISP UCASE
 T)

(PUTPROPS SRI UCASE
 T)

(PUTPROPS MIT UCASE
 T)

(PUTPROPS QA3 UCASE
 T)

(PUTPROPS PLANNER UCASE
 T)

(PUTPROPS UCI UCASE
 T)

(PUTPROPS INTERLISP UCASE
 T)

(PUTPROPS TSET FILEGROUP
 (TRANSOR TSET))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 TRANSUNDER)

(ADDTOVAR LAMA
 )
)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (1734 16815 (TRANSORSET 1746 . 2634) (TRANSORINPUTP 2636 . 4331) (TRANSORSETUSERFN 4335
 . 6136) (RUMARK 6138 . 6408) (RUMARK1 6410 . 7506) (TRANSUNDER 7508 . 8312) (TXFN 8314 . 8628) (TXFN1
 8630 . 9888) (TXDUMP 9890 . 11415) (TXERASE 11417 . 11863) (TXERASE1 11865 . 12214) (TXTEST 12216 . 
12999) (TXSHOW 13001 . 13545) (TXEDIT 13547 . 13990) (TXEXIT 13992 . 14156) (TXNOTE 14158 . 15791) (
GENREMNAM 15793 . 16479) (TXDELNOTE 16481 . 16813)))))
STOP
P