(FILECREATED "18-Jun-85 22:49:07" {ERIS}<LISPCORE>LISPUSERS>EMACSUSER.;2 42408
changes to: (VARS EMACSUSERCOMS)
previous date: " 6-May-85 11:39:48" {ERIS}<LISPCORE>LISPUSERS>EMACSUSER.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT EMACSUSERCOMS)
(RPAQQ EMACSUSERCOMS ((* EMACSUSER -- By Kelly Roach. Defines a programming environment suitable for
users who wish to do their coding in EMACS. *)
(COMS (* EMACSUTI1 *)
(PROPS (DEFINE1 ARGNAMES)
(DEFINE2 ARGNAMES)
(DEFEXPR ARGNAMES)
(DEFEXPR TRAN)
(DEFEXPR CLISPWORD)
(DEFFEXPR ARGNAMES)
(DEFFEXPR TRAN)
(DEFFEXPR CLISPWORD)
(DEFFEXPR ARGNAMES)
(DEFTRAN ARGNAMES)
(DEFTRAN TRAN)
(DEFTRAN CLISPWORD)
(DEFCLISP ARGNAMES)
(DEFCLISP TRAN)
(DEFCLISP CLISPWORD))
(FNS DEFHELPER DEFEXPAND DEFEXPANDFN DEFFORMS DEFINE1 DEFINE2 DEFEXPR.TRAN
DEFEXPR.TRAN1 DEFFEXPR.TRAN DEFFEXPR.TRAN1 DEFARGNAMES DEFLAMBDA DEFTRAN.TRAN
DEFTRAN.TRAN1 DEFCLISP.TRAN DEFCLISP.TRAN1 DEFTRANSLATE))
(COMS (* EMACSUTI2 *)
(PROPS 'FPKGFN (DEFINEQ FPKGFN)
(DEFINE1 FPKGFN)
(DEFINE2 FPKGFN)
(DATATYPE FPKGFN)
(RECORD FPKGFN)
(TYPERECORD FPKGFN)
(ACCESSFNS FPKGFN)
(BLOCKRECORD FPKGFN)
(RPAQ? FPKGFN)
(DEFCONST FPKGFN)
(PUTPROP FPKGFN)
(DEFVAR TRAN)
(DEFPROP ARGNAMES)
(DEFPROP CLISPWORD)
(DEFPROP TRAN)
(DEFALIAS ARGNAMES)
(DEFALIAS CLISPWORD)
(DEFALIAS TRAN)
(IPLUS ALIAS)
(+ AKA)
(IDIFFERENCE ALIAS)
(- AKA)
(IMINUS ALIAS)
(0- AKA)
(ADD1 ALIAS)
(1+ AKA)
(SUB1 ALIAS)
(1- AKA)
(ITIMES ALIAS)
(x AKA)
(IQUOTIENT ALIAS)
(/ AKA)
(IREMAINDER ALIAS)
(\ AKA)
(IGREATERP ALIAS)
(> AKA)
(ILESSP ALIAS)
(< AKA)
(IGEQ ALIAS)
(>= AKA)
(ILEQ ALIAS)
(<= AKA)
(IEQP ALIAS)
(= AKA)
(<> TRAN)
(FPLUS ALIAS)
(+$ AKA)
(FDIFFERENCE ALIAS)
(-$ AKA)
(FMINUS ALIAS)
(0-$ AKA)
(1+$ TRAN)
(1-$ TRAN)
(FTIMES ALIAS)
(x$ AKA)
(FQUOTIENT ALIAS)
(/$ AKA)
(FREMAINDER ALIAS)
(\$ AKA)
(FGREATERP ALIAS)
(>$ AKA)
(FLESSP ALIAS)
(<$ AKA)
(>=$ TRAN)
(<=$ TRAN)
(FEQP ALIAS)
(=$ AKA)
(<>$ TRAN))
(FNS ECOMS EFILE ELOAD ECOMPL EREADFILE EFREE ECOMPARE FPKGFN.P FPKGFN.QUOTE FPKGFN.FNS
FPKGFN.RECORDS FPKGFN.INITVARS FPKGFN.CONSTANTS FPKGFN.PROPS DEFVAR.TRAN
DEFPROP.TRAN DEFALIAS.TRAN <> <>.TRAN 1+$ 1+$.TRAN 1-$ 1-$.TRAN >=$ >=$.TRAN <=$
<=$.TRAN <>$ <>$.TRAN)
(P (MOVD 'RPAQ? 'DEFVAR)
(MOVD 'RPAQ? 'DEFCONST)
(MOVD 'IPLUS '+)
(MOVD 'IDIFFERENCE '-)
(MOVD 'IMINUS '0-)
(MOVD 'ADD1 '1+)
(MOVD 'SUB1 '1-)
(MOVD 'ITIMES 'x)
(MOVD 'IQUOTIENT '/)
(MOVD 'IREMAINDER '\)
(MOVD 'IGREATERP '>)
(MOVD 'ILESSP '<)
(MOVD 'IGEQ '>=)
(MOVD 'ILEQ '<=)
(MOVD 'IEQP '=)
(MOVD 'FPLUS '+$)
(MOVD 'FDIFFERENCE '-$)
(MOVD 'FMINUS '0-$)
(MOVD 'FTIMES 'x$)
(MOVD 'FQUOTIENT '/$)
(MOVD 'FREMAINDER '\$)
(MOVD 'FGREATERP '>$)
(MOVD 'FLESSP '<$)
(MOVD 'FEQP '=$)))
(COMS (* EMACSIFY *)
(PROPS (if EMACS)
(IF EMACS)
(fetch EMACS)
(ffetch EMACS)
(FETCH EMACS)
(FFETCH EMACS)
(replace EMACS)
(freplace EMACS)
(REPLACE EMACS)
(FREPLACE EMACS)
(NEQ EMACS)
(PROG EMACS)
(SETA EMACS))
(FNS EMACSIFYFN EMACSIFY EMACSIFY.IF EMACSIFY.FETCH EMACSIFY.REPLACE EMACSIFY.NEQ
EMACSIFY.PROG EMACSIFY.SETA))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DEFINE2 DEFINE1)
(NLAML <>$.TRAN <=$.TRAN >=$.TRAN 1-$.TRAN 1+$.TRAN <>.TRAN DEFALIAS.TRAN
DEFPROP.TRAN DEFVAR.TRAN DEFTRANSLATE DEFCLISP.TRAN DEFTRAN.TRAN
DEFFEXPR.TRAN DEFEXPR.TRAN)
(LAMA)))))
(* EMACSUSER -- By Kelly Roach. Defines a programming environment suitable for users who wish
to do their coding in EMACS. *)
(* EMACSUTI1 *)
(PUTPROPS DEFINE1 ARGNAMES (FN VARS . BODY))
(PUTPROPS DEFINE2 ARGNAMES (FN VARS . BODY))
(PUTPROPS DEFEXPR ARGNAMES (FN VARS . BODY))
(PUTPROPS DEFEXPR TRAN DEFEXPR.TRAN)
(PUTPROPS DEFEXPR CLISPWORD (DEFTRANSLATE . DEFEXPR))
(PUTPROPS DEFFEXPR ARGNAMES (FN VARS . BODY))
(PUTPROPS DEFFEXPR TRAN DEFFEXPR.TRAN)
(PUTPROPS DEFFEXPR CLISPWORD (DEFTRANSLATE . DEFFEXPR))
(PUTPROPS DEFFEXPR ARGNAMES (FN VARS . BODY))
(PUTPROPS DEFTRAN ARGNAMES (FN VARS . BODY))
(PUTPROPS DEFTRAN TRAN DEFTRAN.TRAN)
(PUTPROPS DEFTRAN CLISPWORD (DEFTRANSLATE . DEFTRAN))
(PUTPROPS DEFCLISP ARGNAMES (FN VARS . BODY))
(PUTPROPS DEFCLISP TRAN DEFCLISP.TRAN)
(PUTPROPS DEFCLISP CLISPWORD (DEFTRANSLATE . DEFCLISP))
(DEFINEQ
(DEFHELPER
(LAMBDA NIL (* We put (DEFHELPER) on DWIMUSERFORMS so that DWIM can
handle DEFTRANs *)
(DECLARE (USEDFREE FAULTX))
(PROG (TRAN ATOM ANSWER)
(COND
((NOT (LISTP FAULTX))
(RETURN NIL)))
(SETQ ATOM (CAR FAULTX))
(SETQ TRAN (GETPROP ATOM (QUOTE TRAN)))
(COND
((NULL TRAN)
(RETURN NIL)))
(SETQ ANSWER (APPLY* TRAN FAULTX))
(RETURN ANSWER))))
(DEFEXPAND
(LAMBDA (EXPR) (* Recursively expands TRANs in EXPR *)
(PROG (AKA TRAN)
LOOP(COND
((NOT (LISTP EXPR))
(RETURN EXPR)))
(COND
((AND (LITATOM (CAR EXPR))
(SETQ AKA (GETPROP (CAR EXPR)
(QUOTE AKA))))
(SETQ EXPR (CONS AKA (CDR EXPR)))
(GO LOOP))
((AND (LITATOM (CAR EXPR))
(SETQ TRAN (GETPROP (CAR EXPR)
(QUOTE TRAN))))
(SETQ EXPR (APPLY* TRAN EXPR))
(GO LOOP))) (* This loop does right thing on dotted lsits.
*)
(for (TAIL ← EXPR) by (CDR TAIL) while (AND TAIL (LISTP TAIL))
do (RPLACA TAIL (DEFEXPAND (CAR TAIL))))
(RETURN EXPR))))
(DEFEXPANDFN
(LAMBDA (FN) (* Expand definition of FN. *)
(PUTDEF FN 'FNS (DEFEXPAND (GETDEF FN 'FNS)))
(MARKASCHANGED FN 'FNS 'CHANGED)))
(DEFFORMS
(LAMBDA (EXPR) (* Computes list of expressions from EXPR to be handed
to compiler etc. *)
(PROG (ANSWER)
(COND
((ATOM EXPR)
(RETURN (LIST EXPR)))
((EQ (CAR EXPR)
(QUOTE *))
(RETURN NIL))
((AND (EQ (CAR EXPR)
(QUOTE PROGN))
(EQUAL (CADR EXPR)
(QUOTE (QUOTE COMPILE))))
(GO SPLIT))
(T (RETURN (LIST EXPR))))
SPLIT (* Following the MACLISP formula.
EXPR = (PROGN (QUOTE COMPILE) form1 ...
formN) *)
(FOR E IN (CDDR EXPR) DO (SETQ ANSWER (NCONC ANSWER (DEFFORMS E))))
(RETURN ANSWER))))
(DEFINE1
(NLAMBDA $FEXPR$ (* Better target fn than DEFINEQ for my def fns.
*)
((LAMBDA (FN VARS BODY)
(DEFINE (\BQUOTE (((\COMMA FN)
(LAMBDA (\COMMA VARS)
(\COMMAAT BODY)))))))
(pop $FEXPR$)
(pop $FEXPR$)
$FEXPR$)))
(DEFINE2
(NLAMBDA $FEXPR$ (* Better target fn than DEFINEQ for my def fns.
*)
((LAMBDA (FN VARS BODY)
(DEFINE (\BQUOTE (((\COMMA FN)
(NLAMBDA (\COMMA VARS)
(\COMMAAT BODY)))))))
(POP $FEXPR$)
(POP $FEXPR$)
$FEXPR$)))
(DEFEXPR.TRAN
(NLAMBDA ($FORM$)
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $FORM$))
(SETQ $ANSWER$ (DEFEXPR.TRAN1 (POP $ARGS$)
$ARGS$))
(RPLACA $FORM$ (CAR $ANSWER$))
(RPLACD $FORM$ (CDR $ANSWER$))
(RETURN $FORM$))))
(DEFEXPR.TRAN1
(LAMBDA (PROTOCALL BODY)
(PROG (FN WRAPPERS LASTWRAPPER DEF ARGNAMES ANSWER)
(COND
((LISTP PROTOCALL)
(SETQ FN (CAR PROTOCALL))
(SETQ WRAPPERS (CDR PROTOCALL)))
(T (SETQ FN PROTOCALL)
(SETQ WRAPPERS (POP BODY)))) (* Get DEF. *)
(SETQ LASTWRAPPER (CAR (LAST WRAPPERS)))
(SETQ DEF (DEFLAMBDA WRAPPERS BODY))
(COND
((AND (LISTP LASTWRAPPER)
(EQ (CAR LASTWRAPPER)
(QUOTE REST)))
(SETQ DEF (\BQUOTE (LAMBDA $EXPR$
((\COMMA DEF)
(\COMMAAT (FOR I FROM 1 TO (SUB1 (LENGTH WRAPPERS))
COLLECT (\BQUOTE (COND
((IGEQ $EXPR$ (\COMMA I))
(ARG $EXPR$ (\COMMA I)))))))
(\COMMA (\BQUOTE (FOR I FROM (\COMMA (LENGTH WRAPPERS))
TO $EXPR$ COLLECT (ARG $EXPR$ I))))))))))
(FIXEDITDATE DEF) (* Get ARGNAMES. *)
(COND
((AND (LISTP LASTWRAPPER)
(EQ (CAR LASTWRAPPER)
(QUOTE REST)))
(SETQ ARGNAMES (DEFARGNAMES WRAPPERS)))) (* Get ANSWER. *)
(COND
(ARGNAMES (SETQ ANSWER (\BQUOTE (PROGN (QUOTE COMPILE)
(PUTPROP (QUOTE (\COMMA FN))
(QUOTE ARGNAMES)
(QUOTE (\COMMA ARGNAMES)))
(DEFINE1 (\COMMA FN)
(\COMMA (CADR DEF))
(\COMMAAT (CDDR DEF)))))))
(T (SETQ ANSWER (\BQUOTE (DEFINE1 (\COMMA FN)
(\COMMA (CADR DEF))
(\COMMAAT (CDDR DEF)))))))
(* Return ANSWER. *)
(RETURN ANSWER))))
(DEFFEXPR.TRAN
(NLAMBDA ($FORM$)
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $FORM$))
(SETQ $ANSWER$ (DEFFEXPR.TRAN1 (POP $ARGS$)
$ARGS$))
(RPLACA $FORM$ (CAR $ANSWER$))
(RPLACD $FORM$ (CDR $ANSWER$))
(RETURN $FORM$))))
(DEFFEXPR.TRAN1
(LAMBDA (PROTOCALL BODY)
(PROG (FN WRAPPERS LASTWRAPPER DEF ARGNAMES ANSWER)
(COND
((LISTP PROTOCALL)
(SETQ FN (CAR PROTOCALL))
(SETQ WRAPPERS (CDR PROTOCALL)))
(T (SETQ FN PROTOCALL)
(SETQ WRAPPERS (POP BODY)))) (* Get DEF. *)
(SETQ LASTWRAPPER (CAR (LAST WRAPPERS)))
(SETQ DEF (DEFLAMBDA WRAPPERS BODY))
(SETQ DEF (\BQUOTE (NLAMBDA $FEXPR$
((\COMMA DEF)
(\COMMAAT (FOR I FROM 1 TO (SUB1 (LENGTH WRAPPERS))
COLLECT (QUOTE (POP $FEXPR$))))
(\COMMA (COND
((AND (LISTP LASTWRAPPER)
(EQ (CAR LASTWRAPPER)
(QUOTE REST)))
(QUOTE $FEXPR$))
(T (QUOTE (POP $FEXPR$)))))))))
(FIXEDITDATE DEF) (* Get ARGNAMES. *)
(SETQ ARGNAMES (DEFARGNAMES WRAPPERS)) (* Get ANSWER. *)
(COND
(ARGNAMES (SETQ ANSWER (\BQUOTE (PROGN (QUOTE COMPILE)
(PUTPROP (QUOTE (\COMMA FN))
(QUOTE ARGNAMES)
(QUOTE (\COMMA ARGNAMES)))
(DEFINE2 (\COMMA FN)
(\COMMA (CADR DEF))
(\COMMAAT (CDDR DEF)))))))
(T (SETQ ANSWER (\BQUOTE (DEFINE2 (\COMMA FN)
(\COMMA (CADR DEF))
(\COMMAAT (CDDR DEF)))))))
(* OKEY DOKEY. *)
(RETURN ANSWER))))
(DEFARGNAMES
(LAMBDA (WRAPPERS)
(PROG (LASTWRAPPER ARGNAMES)
(SETQ LASTWRAPPER (CAR (LAST WRAPPERS)))
(COND
((AND (LISTP LASTWRAPPER)
(EQ (CAR LASTWRAPPER)
(QUOTE REST)))
(SETQ ARGNAMES (FOR WRAPPER IN WRAPPERS AS NEXTWRAPPER IN (CDR WRAPPERS)
COLLECT (COND
((LISTP WRAPPER)
(CADR WRAPPER))
(T WRAPPER))))
(COND
(ARGNAMES (RPLACD (LAST ARGNAMES)
(CADR LASTWRAPPER)))
(T (SETQ ARGNAMES (CADR LASTWRAPPER)))))
(T (SETQ ARGNAMES (FOR WRAPPER IN WRAPPERS COLLECT (COND
((LISTP WRAPPER)
(CADR WRAPPER))
(T WRAPPER))))))
(RETURN ARGNAMES))))
(DEFLAMBDA
(LAMBDA (WRAPPERS BODY) (* Get LAMBDA expression for WRAPPERS and BODY *)
(PROG (COMMENTS VARS VAR VALUE ANSWER) (* Save comments and declarations.
*)
(SETQ COMMENTS (WHILE (AND BODY (LISTP (CAR BODY))
(MEMB (CAAR BODY)
(QUOTE (* DECLARE))))
COLLECT (POP BODY))) (* Get lambda body *)
(FOR WRAPPER IN (REVERSE WRAPPERS)
DO (COND
((ATOM WRAPPER)
(PUSH VARS WRAPPER))
((MEMB (CAR WRAPPER)
(QUOTE (OPTIONAL REST)))
(SETQ VAR (CADR WRAPPER))
(SETQ VALUE (CADDR WRAPPER))
(PUSH VARS VAR)
(COND
(VALUE (PUSH BODY (\BQUOTE (COND
((NULL (\COMMA VAR))
(SETQ (\COMMA VAR)
(\COMMA VALUE)))))))))
(T (LISPERROR (\BQUOTE (ILLEGAL WRAPPER (\COMMA WRAPPER)))
""))))
(SETQ ANSWER (\BQUOTE (LAMBDA (\COMMA VARS)
(\COMMAAT COMMENTS)
(\COMMAAT BODY))))
(RETURN ANSWER))))
(DEFTRAN.TRAN
(NLAMBDA ($FORM$)
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $FORM$))
(SETQ $ANSWER$ (DEFTRAN.TRAN1 (POP $ARGS$)
$ARGS$))
(RPLACA $FORM$ (CAR $ANSWER$))
(RPLACD $FORM$ (CDR $ANSWER$))
(RETURN $FORM$))))
(DEFTRAN.TRAN1
(LAMBDA (PROTOCALL BODY)
(PROG (NAME WRAPPERS LASTWRAPPER DEF FN ANSWER)
(COND
((LISTP PROTOCALL)
(SETQ NAME (CAR PROTOCALL))
(SETQ WRAPPERS (CDR PROTOCALL)))
(T (SETQ NAME PROTOCALL)
(SETQ WRAPPERS (POP BODY))))
(SETQ LASTWRAPPER (CAR (LAST WRAPPERS))) (* Get def. *)
(SETQ DEF (DEFLAMBDA WRAPPERS BODY))
(SETQ DEF (\BQUOTE ((\COMMA DEF)
(\COMMAAT (FOR I FROM 1 TO (SUB1 (LENGTH WRAPPERS))
COLLECT (QUOTE (POP $ARGS$))))
(\COMMA (COND
((AND (LISTP LASTWRAPPER)
(EQ (CAR LASTWRAPPER)
(QUOTE REST)))
(QUOTE $ARGS$))
(T (QUOTE (POP $ARGS$))))))))
(SETQ DEF (\BQUOTE (NLAMBDA ($TRAN$)
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ (\COMMA DEF))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$)))))
(FIXEDITDATE DEF)
(SETQ FN (PACK* NAME (QUOTE .TRAN)))
(SETQ ANSWER (\BQUOTE (PROGN (QUOTE COMPILE)
(PUTPROP (QUOTE (\COMMA NAME))
(QUOTE TRAN)
(QUOTE (\COMMA FN)))
(DEFINE2 (\COMMA FN)
(\COMMA (CADR DEF))
(\COMMAAT (CDDR DEF))))))
(RETURN ANSWER))))
(DEFCLISP.TRAN
(NLAMBDA ($FORM$)
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $FORM$))
(SETQ $ANSWER$ (DEFCLISP.TRAN1 (POP $ARGS$)
$ARGS$))
(RPLACA $FORM$ (CAR $ANSWER$))
(RPLACD $FORM$ (CDR $ANSWER$))
(RETURN $FORM$))))
(DEFCLISP.TRAN1
(LAMBDA (PROTOCALL BODY)
(PROG (FN WRAPPERS LASTWRAPPER ARGNAMES ANSWER) (* Get FN, WRAPPERS, & LASTWRAPPER.
*)
(COND
((LISTP PROTOCALL)
(SETQ FN (CAR PROTOCALL))
(SETQ WRAPPERS (CDR PROTOCALL)))
(T (SETQ FN PROTOCALL)
(SETQ WRAPPERS (POP BODY))))
(SETQ LASTWRAPPER (CAR (LAST WRAPPERS))) (* Get ARGNAMES. *)
(SETQ ARGNAMES (DEFARGNAMES WRAPPERS))
(SETQ ANSWER (\BQUOTE (PROGN (QUOTE COMPILE)
(PUTPROP (QUOTE (\COMMA FN))
(QUOTE ARGNAMES)
(QUOTE (\COMMA ARGNAMES)))
(PUTPROP (QUOTE (\COMMA FN))
(QUOTE CLISPWORD)
(QUOTE (\COMMA (CONS (QUOTE DEFTRANSLATE)
FN))))
(\COMMA (DEFTRAN.TRAN1 (CONS FN WRAPPERS)
BODY)))))
(RETURN ANSWER))))
(DEFTRANSLATE
(NLAMBDA (SEX)
(CLISPTRAN SEX (APPLY* (GETPROP (CAR SEX)
(QUOTE TRAN))
(CONS (CAR SEX)
(CDR SEX))))))
)
(* EMACSUTI2 *)
(PUTPROPS QUOTE FPKGFN FPKGFN.QUOTE)
(PUTPROPS DEFINEQ FPKGFN FPKGFN.FNS)
(PUTPROPS DEFINE1 FPKGFN FPKGFN.FNS)
(PUTPROPS DEFINE2 FPKGFN FPKGFN.FNS)
(PUTPROPS DATATYPE FPKGFN FPKGFN.RECORDS)
(PUTPROPS RECORD FPKGFN FPKGFN.RECORDS)
(PUTPROPS TYPERECORD FPKGFN FPKGFN.RECORDS)
(PUTPROPS ACCESSFNS FPKGFN FPKGFN.RECORDS)
(PUTPROPS BLOCKRECORD FPKGFN FPKGFN.RECORDS)
(PUTPROPS RPAQ? FPKGFN FPKGFN.INITVARS)
(PUTPROPS DEFCONST FPKGFN FPKGFN.CONSTANTS)
(PUTPROPS PUTPROP FPKGFN FPKGFN.PROPS)
(PUTPROPS DEFVAR TRAN DEFVAR.TRAN)
(PUTPROPS DEFPROP ARGNAMES (ATOM PROP VALUE))
(PUTPROPS DEFPROP CLISPWORD (DEFTRANSLATE . DEFPROP))
(PUTPROPS DEFPROP TRAN DEFPROP.TRAN)
(PUTPROPS DEFALIAS ARGNAMES (ALIAS AKA))
(PUTPROPS DEFALIAS CLISPWORD (DEFTRANSLATE . DEFALIAS))
(PUTPROPS DEFALIAS TRAN DEFALIAS.TRAN)
(PUTPROPS IPLUS ALIAS +)
(PUTPROPS + AKA IPLUS)
(PUTPROPS IDIFFERENCE ALIAS -)
(PUTPROPS - AKA IDIFFERENCE)
(PUTPROPS IMINUS ALIAS 0-)
(PUTPROPS 0- AKA IMINUS)
(PUTPROPS ADD1 ALIAS 1+)
(PUTPROPS 1+ AKA ADD1)
(PUTPROPS SUB1 ALIAS 1-)
(PUTPROPS 1- AKA SUB1)
(PUTPROPS ITIMES ALIAS x)
(PUTPROPS x AKA ITIMES)
(PUTPROPS IQUOTIENT ALIAS /)
(PUTPROPS / AKA IQUOTIENT)
(PUTPROPS IREMAINDER ALIAS \)
(PUTPROPS \ AKA IREMAINDER)
(PUTPROPS IGREATERP ALIAS >)
(PUTPROPS > AKA IGREATERP)
(PUTPROPS ILESSP ALIAS <)
(PUTPROPS < AKA ILESSP)
(PUTPROPS IGEQ ALIAS >=)
(PUTPROPS >= AKA IGEQ)
(PUTPROPS ILEQ ALIAS <=)
(PUTPROPS <= AKA ILEQ)
(PUTPROPS IEQP ALIAS =)
(PUTPROPS = AKA IEQP)
(PUTPROPS <> TRAN <>.TRAN)
(PUTPROPS FPLUS ALIAS +$)
(PUTPROPS +$ AKA FPLUS)
(PUTPROPS FDIFFERENCE ALIAS -$)
(PUTPROPS -$ AKA FDIFFERENCE)
(PUTPROPS FMINUS ALIAS 0-$)
(PUTPROPS 0-$ AKA FMINUS)
(PUTPROPS 1+$ TRAN 1+$.TRAN)
(PUTPROPS 1-$ TRAN 1-$.TRAN)
(PUTPROPS FTIMES ALIAS x$)
(PUTPROPS x$ AKA FTIMES)
(PUTPROPS FQUOTIENT ALIAS /$)
(PUTPROPS /$ AKA FQUOTIENT)
(PUTPROPS FREMAINDER ALIAS \$)
(PUTPROPS \$ AKA FREMAINDER)
(PUTPROPS FGREATERP ALIAS >$)
(PUTPROPS >$ AKA FGREATERP)
(PUTPROPS FLESSP ALIAS <$)
(PUTPROPS <$ AKA FLESSP)
(PUTPROPS >=$ TRAN >=$.TRAN)
(PUTPROPS <=$ TRAN <=$.TRAN)
(PUTPROPS FEQP ALIAS =$)
(PUTPROPS =$ AKA FEQP)
(PUTPROPS <>$ TRAN <>$.TRAN)
(DEFINEQ
(ECOMS
(LAMBDA (FILE) (* kbr: "27-Apr-85 13:50")
(* Create FILECOMS for one FILE *)
(PROG (FILECOMS EXPRS FPKGFN)
(SETQ FILECOMS (FILECOMS FILE))
(SET FILECOMS (COPY (QUOTE ((CONSTANTS)
(INITVARS)
(RECORDS)
(FNS)
(P))))) (* Get FPKG expressions *)
(SETQ EXPRS (EREADFILE FILE)) (* Establish FPKG in lisp environment *)
(for EXPR in EXPRS when (LISTP EXPR)
do (EVAL EXPR)
(COND
((SETQ FPKGFN (GETPROP (CAR EXPR)
(QUOTE FPKGFN)))
(APPLY* FPKGFN FILECOMS EXPR))
(T (APPLY* (QUOTE FPKGFN.P)
FILECOMS EXPR))))
(SET FILECOMS (for BUCKET in (GETATOMVAL FILECOMS) when (CDR BUCKET) collect BUCKET)))))
(EFILE
(LAMBDA (FILE TOFILE) (* kbr: "27-Apr-85 13:50")
(* Takes my FILE and creates a filepackage TOFILE *)
(PROG (ULIST FILECOMS)
(ECOMS FILE) (* Get fullnames for FILE and TOFILE *)
(COND
((NULL TOFILE)
(SETQ ULIST (UNPACKFILENAME FILE))
(LISTPUT ULIST (QUOTE EXTENSION)
(QUOTE FPKG))
(SETQ TOFILE (PACKFILENAME ULIST))))
(SETQ FILECOMS (FILECOMS TOFILE))
(SET FILECOMS (GETATOMVAL (FILECOMS FILE)))
(SETPROPLIST (ROOTFILENAME TOFILE)
NIL)
(RETURN (MAKEFILE TOFILE)))))
(ELOAD
(LAMBDA (FILE) (* kbr: "27-Apr-85 13:50")
(* Load and translate FILE. *)
(* This code similar to EREADFILE.
*)
(PROG (EXPR EXPAND FORMS) (* Note: Must do eval after each read.
(READBITMAP) etc. *)
(RESETLST (RESETSAVE NIL (LIST (QUOTE INPUT)
(INFILE FILE)))
(SETQ FILE (OPENSTREAM (INPUT)
(QUOTE INPUT)
(QUOTE OLD)))
(DO (SETQ EXPR (READ FILE))
(SETQ EXPAND (DEFEXPAND EXPR))
(SETQ FORMS (DEFFORMS EXPAND))
(COND
((EQUAL FORMS (QUOTE (STOP)))
(RETURN)))
(FOR FORM IN FORMS WHEN (LISTP FORM) DO (EVAL FORM)))
(CLOSEF FILE)))))
(ECOMPL
(LAMBDA (FILE) (* kbr: "27-Apr-85 13:50")
(* Compile FILE. *)
(PROG NIL
(TCOMPL (EFILE FILE)))))
(EREADFILE
(LAMBDA (FILE) (* kbr: "27-Apr-85 13:50")
(* READFILE with translation.
*)
(PROG (EXPR EXPAND FORMS ANSWER)
(RESETLST (RESETSAVE NIL (LIST (QUOTE INPUT)
(INFILE FILE)))
(SETQ FILE (INPUT))
(do (SETQ EXPR (READ FILE))
(SETQ EXPAND (DEFEXPAND EXPR))
(SETQ FORMS (DEFFORMS EXPAND))
(SETQ ANSWER (NCONC ANSWER FORMS))
(COND
((EQUAL FORMS (QUOTE (STOP)))
(RETURN))))
(CLOSEF FILE))
(RETURN ANSWER))))
(EFREE
(LAMBDA (FILE) (* kbr: "27-Apr-85 13:50")
(PROG (FILECOMS FNS FREE ANSWER)
(SETQ FILECOMS (FILECOMS FILE))
(COND
((OR (NOT (BOUNDP FILECOMS))
(NULL (GETATOMVAL FILECOMS)))
(ECOMS FILE)))
(FOR FN IN (FILECOMSLST FILE (QUOTE FNS))
DO (SETQ FREE (CADDR (CALLS FN)))
(COND
(FREE (PUSH ANSWER (CONS FN FREE)))))
(RETURN ANSWER))))
(ECOMPARE
(LAMBDA (EMACSFILE FPKGFILE) (* kbr: "27-Apr-85 13:50")
(PROG NIL
(ECOMS EMACSFILE)
(FOR FN IN (FILECOMSLST EMACSFILE (QUOTE FNS))
DO (DWIMIFY FN)
(COMPARE FN FN (QUOTE FNS)
NIL FPKGFILE)))))
(FPKGFN.P
(LAMBDA (FILECOMS EXPR) (* kbr: "27-Apr-85 13:50")
(* P file package command. EXPR to be evaled when
loaded. *)
(PROG (ALIST)
(SETQ ALIST (GETATOMVAL FILECOMS))
(RPLACD (OR (ASSOC (QUOTE P)
ALIST)
(PROGN (PUSH ALIST (LIST (QUOTE P)))
(CAR ALIST)))
(NCONC (CDR (ASSOC (QUOTE P)
ALIST))
(LIST EXPR)))
(SET FILECOMS ALIST))))
(FPKGFN.QUOTE
(LAMBDA (FILECOMS EXPR) (* kbr: "27-Apr-85 13:50")
(* EXPR is a QUOTE expression that is ignored.
*)
(PROG NIL
(* Some of my definition-like constructs translate into forms like (PROGN (QUOTE COMPILE) ...
(QUOTE name)) so that they have name as their return value. In file packages, there's no point in keeping
(QUOTE name) around. *)
)))
(FPKGFN.FNS
(LAMBDA (FILECOMS EXPR) (* kbr: "27-Apr-85 13:50")
(* FNS file package command.
EXPR is a definition. *)
(PROG (FN ALIST)
(SELECTQ (CAR EXPR)
((DEFINE1 DEFINE2)
(SETQ FN (CADR EXPR)))
(DEFINEQ (SETQ FN (CAR (CADR EXPR))))
(SHOULDNT))
(SETQ ALIST (GETATOMVAL FILECOMS))
(RPLACD (OR (ASSOC (QUOTE FNS)
ALIST)
(PROGN (PUSH ALIST (LIST (QUOTE FNS)))
(CAR ALIST)))
(NCONC (CDR (ASSOC (QUOTE FNS)
ALIST))
(LIST FN)))
(SET FILECOMS ALIST))))
(FPKGFN.RECORDS
(LAMBDA (FILECOMS EXPR) (* kbr: "27-Apr-85 13:50")
(* RECORDS file package command.
EXPR is a record package declaration.
*)
(PROG (NAME ALIST)
(SETQ NAME (CADR EXPR))
(SETQ ALIST (GETATOMVAL FILECOMS))
(RPLACD (OR (ASSOC (QUOTE RECORDS)
ALIST)
(PROGN (PUSH ALIST (LIST (QUOTE RECORDS)))
(CAR ALIST)))
(NCONC (CDR (ASSOC (QUOTE RECORDS)
ALIST))
(LIST NAME)))
(SET FILECOMS ALIST))))
(FPKGFN.INITVARS
(LAMBDA (FILECOMS EXPR) (* kbr: "27-Apr-85 13:50")
(* INITVARS file package command.
EXPR is a RPAQ? expression. *)
(PROG (ALIST)
(SETQ ALIST (GETATOMVAL FILECOMS))
(RPLACD (OR (ASSOC (QUOTE INITVARS)
ALIST)
(PROGN (PUSH ALIST (LIST (QUOTE INITVARS)))
(CAR ALIST)))
(NCONC (CDR (ASSOC (QUOTE INITVARS)
ALIST))
(LIST (CDR EXPR))))
(SET FILECOMS ALIST))))
(FPKGFN.CONSTANTS
(LAMBDA (FILECOMS EXPR) (* kbr: "27-Apr-85 13:50")
(* CONSTANTS file package command.
EXPR is a RPAQQ expression. *)
(PROG (ALIST)
(SETQ ALIST (GETATOMVAL FILECOMS))
(RPLACD (OR (ASSOC (QUOTE CONSTANTS)
ALIST)
(PROGN (PUSH ALIST (LIST (QUOTE CONSTANTS)))
(CAR ALIST)))
(NCONC (CDR (ASSOC (QUOTE CONSTANTS)
ALIST))
(LIST (CDR EXPR))))
(SET FILECOMS ALIST))))
(FPKGFN.PROPS
(LAMBDA (FILECOMS EXPR) (* kbr: "27-Apr-85 13:50")
(* PROPS file package command.
EXPR is a PUTPROP expression.
*)
(PROG (ATOM PROPNAME ALIST)
(SETQ ATOM (CADR (CADR EXPR)))
(SETQ PROPNAME (CADR (CADDR EXPR)))
(SETQ ALIST (GETATOMVAL FILECOMS))
(RPLACD (OR (ASSOC (QUOTE PROPS)
ALIST)
(PROGN (push ALIST (LIST (QUOTE PROPS)))
(CAR ALIST)))
(NCONC (CDR (ASSOC (QUOTE PROPS)
ALIST))
(LIST (LIST ATOM PROPNAME))))
(SET FILECOMS ALIST))))
(DEFVAR.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (VAR VALUE)
(\BQUOTE (RPAQ? (\COMMA VAR)
(\COMMA VALUE))))
(pop $ARGS$)
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
(DEFPROP.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (ATOM PROP VALUE)
(\BQUOTE (PUTPROP (QUOTE (\COMMA ATOM))
(QUOTE (\COMMA PROP))
(QUOTE (\COMMA VALUE)))))
(pop $ARGS$)
(pop $ARGS$)
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
(DEFALIAS.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (ALIAS AKA)
(\BQUOTE (PROGN (QUOTE COMPILE)
(MOVD (QUOTE (\COMMA AKA))
(QUOTE (\COMMA ALIAS)))
(PUTPROP (QUOTE (\COMMA AKA))
(QUOTE ALIAS)
(QUOTE (\COMMA ALIAS)))
(PUTPROP (QUOTE (\COMMA ALIAS))
(QUOTE AKA)
(QUOTE (\COMMA AKA))))))
(pop $ARGS$)
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
(<>
(LAMBDA (ARG1 ARG2) (* kbr: "27-Apr-85 13:50")
(NOT (IEQP ARG1 ARG2))))
(<>.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (ARG1 ARG2)
(\BQUOTE (NOT (IEQP (\COMMA ARG1)
(\COMMA ARG2)))))
(pop $ARGS$)
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
(1+$
(LAMBDA (ARG) (* kbr: "27-Apr-85 13:50")
(FPLUS ARG 1.0)))
(1+$.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (ARG)
(\BQUOTE (FPLUS (\COMMA ARG)
1.0)))
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
(1-$
(LAMBDA (ARG) (* kbr: "27-Apr-85 13:50")
(FDIFFERENCE ARG 1.0)))
(1-$.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (ARG)
(\BQUOTE (FDIFFERENCE (\COMMA ARG)
1.0)))
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
(>=$
(LAMBDA (ARG1 ARG2) (* kbr: "27-Apr-85 13:50")
(* No FGEQ in Interlisp *)
(NOT (FLESSP ARG1 ARG2))))
(>=$.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (ARG1 ARG2)
(\BQUOTE (NOT (FLESSP (\COMMA ARG1)
(\COMMA ARG2)))))
(pop $ARGS$)
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
(<=$
(LAMBDA (ARG1 ARG2) (* kbr: "27-Apr-85 13:50")
(* No FLEQ in Interlisp *)
(NOT (FGREATERP ARG1 ARG2))))
(<=$.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (ARG1 ARG2)
(\BQUOTE (NOT (FGREATERP (\COMMA ARG1)
(\COMMA ARG2)))))
(pop $ARGS$)
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
(<>$
(LAMBDA (ARG1 ARG2) (* kbr: "27-Apr-85 13:50")
(NOT (FEQP ARG1 ARG2))))
(<>$.TRAN
(NLAMBDA ($TRAN$) (* kbr: "27-Apr-85 13:50")
(PROG ($ARGS$ $ANSWER$)
(SETQ $ARGS$ (CDR $TRAN$))
(SETQ $ANSWER$ ((LAMBDA (ARG1 ARG2)
(\BQUOTE (NOT (FEQP (\COMMA ARG1)
(\COMMA ARG2)))))
(pop $ARGS$)
(pop $ARGS$)))
(RPLACA $TRAN$ (CAR $ANSWER$))
(RPLACD $TRAN$ (CDR $ANSWER$))
(RETURN $TRAN$))))
)
(MOVD 'RPAQ? 'DEFVAR)
(MOVD 'RPAQ? 'DEFCONST)
(MOVD 'IPLUS '+)
(MOVD 'IDIFFERENCE '-)
(MOVD 'IMINUS '0-)
(MOVD 'ADD1 '1+)
(MOVD 'SUB1 '1-)
(MOVD 'ITIMES 'x)
(MOVD 'IQUOTIENT '/)
(MOVD 'IREMAINDER '\)
(MOVD 'IGREATERP '>)
(MOVD 'ILESSP '<)
(MOVD 'IGEQ '>=)
(MOVD 'ILEQ '<=)
(MOVD 'IEQP '=)
(MOVD 'FPLUS '+$)
(MOVD 'FDIFFERENCE '-$)
(MOVD 'FMINUS '0-$)
(MOVD 'FTIMES 'x$)
(MOVD 'FQUOTIENT '/$)
(MOVD 'FREMAINDER '\$)
(MOVD 'FGREATERP '>$)
(MOVD 'FLESSP '<$)
(MOVD 'FEQP '=$)
(* EMACSIFY *)
(PUTPROPS if EMACS EMACSIFY.IF)
(PUTPROPS IF EMACS EMACSIFY.IF)
(PUTPROPS fetch EMACS EMACSIFY.FETCH)
(PUTPROPS ffetch EMACS EMACSIFY.FETCH)
(PUTPROPS FETCH EMACS EMACSIFY.FETCH)
(PUTPROPS FFETCH EMACS EMACSIFY.FETCH)
(PUTPROPS replace EMACS EMACSIFY.REPLACE)
(PUTPROPS freplace EMACS EMACSIFY.REPLACE)
(PUTPROPS REPLACE EMACS EMACSIFY.REPLACE)
(PUTPROPS FREPLACE EMACS EMACSIFY.REPLACE)
(PUTPROPS NEQ EMACS EMACSIFY.NEQ)
(PUTPROPS PROG EMACS EMACSIFY.PROG)
(PUTPROPS SETA EMACS EMACSIFY.SETA)
(DEFINEQ
(EMACSIFYFN
(LAMBDA (FN COMPLETELY) (* kbr: "27-Apr-85 13:50")
(PUTDEF FN (QUOTE FNS)
(EMACSIFY (GETDEF FN (QUOTE FNS))
COMPLETELY))
(MARKASCHANGED FN (QUOTE FNS)
(QUOTE CHANGED))))
(EMACSIFY
(LAMBDA (EXPR COMPLETELY) (* kbr: "27-Apr-85 13:50")
(PROG (ALIAS EMACS)
(COND
((AND (LITATOM EXPR)
(GETPROP EXPR (QUOTE CLISPWORD))
COMPLETELY)
(RETURN (U-CASE (CDR (GETPROP EXPR (QUOTE CLISPWORD))))))
((NOT (LISTP EXPR))
(RETURN EXPR)))
(COND
((AND COMPLETELY (LITATOM (CAR EXPR))
(SETQ ALIAS (GETPROP (CAR EXPR)
(QUOTE ALIAS))))
(SETQ EXPR (CONS ALIAS (CDR EXPR))))
((AND (LITATOM (CAR EXPR))
(SETQ EMACS (GETPROP (CAR EXPR)
(QUOTE EMACS))))
(SETQ EXPR (APPLY* EMACS EXPR COMPLETELY)))
((EQ (CAR EXPR)
(QUOTE *))
(RETURN EXPR))) (* This loop does right thing on dotted lsits.
*)
(FOR TAIL ← EXPR BY (CDR TAIL) WHILE (AND TAIL (LISTP TAIL))
DO (RPLACA TAIL (EMACSIFY (CAR TAIL)
COMPLETELY)))
(RETURN EXPR))))
(EMACSIFY.IF
(LAMBDA (EXPR) (* kbr: "27-Apr-85 13:50")
(PROG (BRANCHES BRANCH)
(FOR E IN EXPR DO (SELECTQ E
((if IF)
(PUSH BRANCHES (QUOTE COND)))
((then
THEN) (* NOP *)
)
((else
ELSE)
(PUSH BRANCHES (DREVERSE BRANCH))
(* Must use (LIST (QUOTE T)) instead of
(QUOTE (T)) here. *)
(SETQ BRANCH (LIST (QUOTE T))))
((elseif
ELSEIF)
(PUSH BRANCHES (DREVERSE BRANCH))
(SETQ BRANCH NIL))
(PUSH BRANCH E)))
(PUSH BRANCHES (DREVERSE BRANCH))
(RETURN (DREVERSE BRANCHES)))))
(EMACSIFY.FETCH
(LAMBDA (EXPR COMPLETELY) (* kbr: "27-Apr-85 13:50")
(PROG (TYPE&FIELD TYPE.FIELD DATUM ANSWER)
(SETQ TYPE&FIELD (CAR (NTH EXPR 2)))
(SETQ DATUM (CAR (NTH EXPR 4)))
(COND
((LITATOM TYPE&FIELD) (* Unqualified FIELD. *)
(SETQ TYPE&FIELD (LIST (CADR (CAR (FIELDLOOK TYPE&FIELD)))
TYPE&FIELD))))
(COND
(COMPLETELY (SETQ TYPE.FIELD (PACK* (CAR TYPE&FIELD)
"."
(CADR TYPE&FIELD)))
(SETQ ANSWER (LIST TYPE.FIELD DATUM)))
(T (SETQ ANSWER (LIST (QUOTE fetch)
TYPE&FIELD
(QUOTE of)
DATUM))))
(RETURN ANSWER))))
(EMACSIFY.REPLACE
(LAMBDA (EXPR COMPLETELY) (* kbr: "27-Apr-85 13:50")
(PROG (TYPE&FIELD TYPE.FIELD DATUM NEWVALUE ANSWER)
(SETQ TYPE&FIELD (CAR (NTH EXPR 2)))
(SETQ DATUM (CAR (NTH EXPR 4)))
(SETQ NEWVALUE (CAR (NTH EXPR 6)))
(COND
((LITATOM TYPE&FIELD) (* Unqualified FIELD. *)
(SETQ TYPE&FIELD (LIST (CADR (CAR (FIELDLOOK TYPE&FIELD)))
TYPE&FIELD))))
(COND
(COMPLETELY (SETQ TYPE.FIELD (PACK* (CAR TYPE&FIELD)
"."
(CADR TYPE&FIELD)))
(SETQ ANSWER (LIST TYPE.FIELD DATUM))
(SETQ ANSWER (LIST (QUOTE SETF)
ANSWER NEWVALUE)))
(T (SETQ ANSWER (LIST (QUOTE replace)
TYPE&FIELD
(QUOTE of)
DATUM
(QUOTE with)
NEWVALUE))))
(RETURN ANSWER))))
(EMACSIFY.NEQ
(LAMBDA (EXPR) (* kbr: "27-Apr-85 13:50")
(PROG (E1 E2 ANSWER)
(SETQ E1 (CADR EXPR))
(SETQ E2 (CADDR EXPR))
(SETQ ANSWER (\BQUOTE (NOT (EQ (\COMMA E1)
(\COMMA E2)))))
(RETURN ANSWER))))
(EMACSIFY.PROG
(LAMBDA (EXPR) (* kbr: "27-Apr-85 13:50")
(PROG (VARS BODY ANSWER)
(SETQ VARS (CADR EXPR))
(SETQ BODY (CDDR EXPR))
(FOR VAR IN (REVERSE VARS) WHEN (LISTP VAR) DO (PUSH BODY (CONS (QUOTE SETQ)
VAR)))
(SETQ VARS (FOR VAR IN VARS COLLECT (COND
((LITATOM VAR)
VAR)
(T (CAR VAR)))))
(SETQ ANSWER (\BQUOTE (PROG (\COMMA VARS)
(\COMMAAT BODY))))
(RETURN ANSWER))))
(EMACSIFY.SETA
(LAMBDA (EXPR COMPLETELY) (* kbr: "27-Apr-85 13:50")
(COND
(COMPLETELY (LIST (QUOTE SETF)
(LIST (QUOTE ELT)
(CAR (NTH EXPR 2))
(CAR (NTH EXPR 3)))
(CAR (NTH EXPR 4))))
(T EXPR))))
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DEFINE2 DEFINE1)
(ADDTOVAR NLAML <>$.TRAN <=$.TRAN >=$.TRAN 1-$.TRAN 1+$.TRAN <>.TRAN DEFALIAS.TRAN DEFPROP.TRAN
DEFVAR.TRAN DEFTRANSLATE DEFCLISP.TRAN DEFTRAN.TRAN DEFFEXPR.TRAN DEFEXPR.TRAN)
(ADDTOVAR LAMA )
)
(PUTPROPS EMACSUSER COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5053 17919 (DEFHELPER 5063 . 5646) (DEFEXPAND 5648 . 6571) (DEFEXPANDFN 6573 . 6790) (
DEFFORMS 6792 . 7652) (DEFINE1 7654 . 7990) (DEFINE2 7992 . 8329) (DEFEXPR.TRAN 8331 . 8655) (
DEFEXPR.TRAN1 8657 . 10551) (DEFFEXPR.TRAN 10553 . 10880) (DEFFEXPR.TRAN1 10882 . 12524) (DEFARGNAMES
12526 . 13339) (DEFLAMBDA 13341 . 14532) (DEFTRAN.TRAN 14534 . 14858) (DEFTRAN.TRAN1 14860 . 16414) (
DEFCLISP.TRAN 16416 . 16743) (DEFCLISP.TRAN1 16745 . 17739) (DEFTRANSLATE 17741 . 17917)) (20416 35486
(ECOMS 20426 . 21439) (EFILE 21441 . 22255) (ELOAD 22257 . 23234) (ECOMPL 23236 . 23485) (EREADFILE
23487 . 24192) (EFREE 24194 . 24743) (ECOMPARE 24745 . 25062) (FPKGFN.P 25064 . 25674) (FPKGFN.QUOTE
25676 . 26204) (FPKGFN.FNS 26206 . 27001) (FPKGFN.RECORDS 27003 . 27712) (FPKGFN.INITVARS 27714 .
28365) (FPKGFN.CONSTANTS 28367 . 29023) (FPKGFN.PROPS 29025 . 29818) (DEFVAR.TRAN 29820 . 30297) (
DEFPROP.TRAN 30299 . 30872) (DEFALIAS.TRAN 30874 . 31616) (<> 31618 . 31754) (<>.TRAN 31756 . 32242) (
1+$ 32244 . 32374) (1+$.TRAN 32376 . 32813) (1-$ 32815 . 32951) (1-$.TRAN 32953 . 33402) (>=$ 33404 .
33635) (>=$.TRAN 33637 . 34128) (<=$ 34130 . 34364) (<=$.TRAN 34366 . 34856) (<>$ 34858 . 34995) (
<>$.TRAN 34997 . 35484)) (36542 42020 (EMACSIFYFN 36552 . 36836) (EMACSIFY 36838 . 38010) (EMACSIFY.IF
38012 . 38904) (EMACSIFY.FETCH 38906 . 39718) (EMACSIFY.REPLACE 39720 . 40713) (EMACSIFY.NEQ 40715 .
41058) (EMACSIFY.PROG 41060 . 41695) (EMACSIFY.SETA 41697 . 42018)))))
STOP