(FILECREATED " 3-JUN-79 09:49:57" <NEWLISP>TSET.;2 18715
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 16837 (TRANSORSET 1746 . 2634) (TRANSORINPUTP 2636 . 4331) (TRANSORSETUSERFN 4335
. 6136) (RUMARK 6138 . 6408) (RUMARK1 6410 . 7508) (TRANSUNDER 7510 . 8314) (TXFN 8316 . 8630) (TXFN1
8632 . 9894) (TXDUMP 9896 . 11427) (TXERASE 11429 . 11875) (TXERASE1 11877 . 12228) (TXTEST 12230 .
13015) (TXSHOW 13017 . 13561) (TXEDIT 13563 . 14006) (TXEXIT 14008 . 14173) (TXNOTE 14175 . 15811) (
GENREMNAM 15813 . 16499) (TXDELNOTE 16501 . 16835)))))
STOP
P