(FILECREATED "17-Feb-86 11:58:55" {ERIS}<LISPUSERS>KOTO>EMACSUSER.;3 63333
changes to: (PROPS (ffetch EMACS)
(FFETCH EMACS)
(freplace EMACS)
(FREPLACE EMACS))
(FNS EMACSIFY.REPLACE EMACSIFY.FFETCH EMACSIFY.FREPLACE)
(VARS EMACSUSERCOMS)
previous date: "18-Jun-85 22:49:07" {ERIS}<LISPUSERS>KOTO>EMACSUSER.;1)
(* Copyright (c) 1985, 1986 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 (QUOTE 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 (QUOTE RPAQ?)
(QUOTE DEFVAR))
(MOVD (QUOTE RPAQ?)
(QUOTE DEFCONST))
(MOVD (QUOTE IPLUS)
(QUOTE +))
(MOVD (QUOTE IDIFFERENCE)
(QUOTE -))
(MOVD (QUOTE IMINUS)
(QUOTE 0-))
(MOVD (QUOTE ADD1)
(QUOTE 1+))
(MOVD (QUOTE SUB1)
(QUOTE 1-))
(MOVD (QUOTE ITIMES)
(QUOTE x))
(MOVD (QUOTE IQUOTIENT)
(QUOTE /))
(MOVD (QUOTE IREMAINDER)
(QUOTE \))
(MOVD (QUOTE IGREATERP)
(QUOTE >))
(MOVD (QUOTE ILESSP)
(QUOTE <))
(MOVD (QUOTE IGEQ)
(QUOTE >=))
(MOVD (QUOTE ILEQ)
(QUOTE <=))
(MOVD (QUOTE IEQP)
(QUOTE =))
(MOVD (QUOTE FPLUS)
(QUOTE +$))
(MOVD (QUOTE FDIFFERENCE)
(QUOTE -$))
(MOVD (QUOTE FMINUS)
(QUOTE 0-$))
(MOVD (QUOTE FTIMES)
(QUOTE x$))
(MOVD (QUOTE FQUOTIENT)
(QUOTE /$))
(MOVD (QUOTE FREMAINDER)
(QUOTE \$))
(MOVD (QUOTE FGREATERP)
(QUOTE >$))
(MOVD (QUOTE FLESSP)
(QUOTE <$))
(MOVD (QUOTE FEQP)
(QUOTE =$))))
(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.FFETCH
EMACSIFY.FREPLACE 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 (QUOTE FNS)
(DEFEXPAND (GETDEF FN (QUOTE FNS))))
(MARKASCHANGED FN (QUOTE FNS)
(QUOTE 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 (QUOTE RPAQ?)
(QUOTE DEFVAR))
(MOVD (QUOTE RPAQ?)
(QUOTE DEFCONST))
(MOVD (QUOTE IPLUS)
(QUOTE +))
(MOVD (QUOTE IDIFFERENCE)
(QUOTE -))
(MOVD (QUOTE IMINUS)
(QUOTE 0-))
(MOVD (QUOTE ADD1)
(QUOTE 1+))
(MOVD (QUOTE SUB1)
(QUOTE 1-))
(MOVD (QUOTE ITIMES)
(QUOTE x))
(MOVD (QUOTE IQUOTIENT)
(QUOTE /))
(MOVD (QUOTE IREMAINDER)
(QUOTE \))
(MOVD (QUOTE IGREATERP)
(QUOTE >))
(MOVD (QUOTE ILESSP)
(QUOTE <))
(MOVD (QUOTE IGEQ)
(QUOTE >=))
(MOVD (QUOTE ILEQ)
(QUOTE <=))
(MOVD (QUOTE IEQP)
(QUOTE =))
(MOVD (QUOTE FPLUS)
(QUOTE +$))
(MOVD (QUOTE FDIFFERENCE)
(QUOTE -$))
(MOVD (QUOTE FMINUS)
(QUOTE 0-$))
(MOVD (QUOTE FTIMES)
(QUOTE x$))
(MOVD (QUOTE FQUOTIENT)
(QUOTE /$))
(MOVD (QUOTE FREMAINDER)
(QUOTE \$))
(MOVD (QUOTE FGREATERP)
(QUOTE >$))
(MOVD (QUOTE FLESSP)
(QUOTE <$))
(MOVD (QUOTE FEQP)
(QUOTE =$))
(* EMACSIFY *)
(PUTPROPS if EMACS EMACSIFY.IF)
(PUTPROPS IF EMACS EMACSIFY.IF)
(PUTPROPS fetch EMACS EMACSIFY.FETCH)
(PUTPROPS ffetch EMACS EMACSIFY.FFETCH)
(PUTPROPS FETCH EMACS EMACSIFY.FETCH)
(PUTPROPS FFETCH EMACS EMACSIFY.FFETCH)
(PUTPROPS replace EMACS EMACSIFY.REPLACE)
(PUTPROPS freplace EMACS EMACSIFY.FREPLACE)
(PUTPROPS REPLACE EMACS EMACSIFY.REPLACE)
(PUTPROPS FREPLACE EMACS EMACSIFY.FREPLACE)
(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.FFETCH
(LAMBDA (EXPR COMPLETELY) (* kbr:
"17-Feb-86 11:55")
(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 ffetch)
TYPE&FIELD
(QUOTE of)
DATUM))))
(RETURN ANSWER))))
(EMACSIFY.FREPLACE
(LAMBDA (EXPR COMPLETELY) (* kbr:
"17-Feb-86 11:55")
(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 freplace)
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 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (8135 26561 (DEFHELPER 8145 . 8916) (DEFEXPAND 8918 . 10110) (DEFEXPANDFN 10112 . 10457)
(DEFFORMS 10459 . 11939) (DEFINE1 11941 . 12462) (DEFINE2 12464 . 12986) (DEFEXPR.TRAN 12988 . 13303)
(DEFEXPR.TRAN1 13305 . 16120) (DEFFEXPR.TRAN 16122 . 16439) (DEFFEXPR.TRAN1 16441 . 18887) (
DEFARGNAMES 18889 . 20138) (DEFLAMBDA 20140 . 22094) (DEFTRAN.TRAN 22096 . 22411) (DEFTRAN.TRAN1 22413
. 24526) (DEFCLISP.TRAN 24528 . 24845) (DEFCLISP.TRAN1 24847 . 26340) (DEFTRANSLATE 26342 . 26559)) (
29058 51182 (ECOMS 29068 . 30955) (EFILE 30957 . 32079) (ELOAD 32081 . 33761) (ECOMPL 33763 . 34179) (
EREADFILE 34181 . 35161) (EFREE 35163 . 35800) (ECOMPARE 35802 . 36320) (FPKGFN.P 36322 . 37284) (
FPKGFN.QUOTE 37286 . 38076) (FPKGFN.FNS 38078 . 39152) (FPKGFN.RECORDS 39154 . 40192) (FPKGFN.INITVARS
40194 . 41194) (FPKGFN.CONSTANTS 41196 . 42201) (FPKGFN.PROPS 42203 . 43301) (DEFVAR.TRAN 43303 .
43928) (DEFPROP.TRAN 43930 . 44690) (DEFALIAS.TRAN 44692 . 45834) (<> 45836 . 46052) (<>.TRAN 46054 .
46684) (1+$ 46686 . 46896) (1+$.TRAN 46898 . 47460) (1-$ 47462 . 47678) (1-$.TRAN 47680 . 48248) (>=$
48250 . 48649) (>=$.TRAN 48651 . 49285) (<=$ 49287 . 49689) (<=$.TRAN 49691 . 50328) (<>$ 50330 .
50547) (<>$.TRAN 50549 . 51180)) (52722 62922 (EMACSIFYFN 52732 . 53098) (EMACSIFY 53100 . 54571) (
EMACSIFY.IF 54573 . 56093) (EMACSIFY.FETCH 56095 . 57226) (EMACSIFY.REPLACE 57228 . 58618) (
EMACSIFY.FFETCH 58620 . 59753) (EMACSIFY.FREPLACE 59755 . 61147) (EMACSIFY.NEQ 61149 . 61575) (
EMACSIFY.PROG 61577 . 62463) (EMACSIFY.SETA 62465 . 62920)))))
STOP