(PROG (Q)
     LP (SETQ Q (EVAL (READ 1)))
      (COND ((EQ Q 'SLUT)(RETURN (CLOSE 1)))
            (T(GO LP))))

(DE COPY (L)
(COND ((ATOM L) L)
      (T (CONS (COPY (CAR L))
               (COPY (CDR L))))))

(DF PP (L A)
(PL (COND ((GETD (CAR L)))
          ((EVAL (CAR L) A))))
(TERPRI)
(CAR L))

(DE GETD (F)
(PROG (DEF)
 (COND ((GETPROP F 'EXPR)(SETQ DEF 'EXPR))
       ((GETPROP F 'FEXPR)(SETQ DEF 'FEXPR))
       ((GETPROP F 'SUBR)(RETURN 'SUBR))
       ((GETPROP F 'FSUBR)(RETURN 'FSUBR))
       (T (RETURN)))
 (RETURN (CONS DEF (GETPROP F DEF)))))

(DE EDITV (L)
 (PROG (CEXP CMD)
       (SETQ CEXP (LIST L))
EDITLP (TERPRI)
       (PRIN1 '*)
       (SETQ CMD (READ))
       (COND ((LISTP CMD)
              (COND ((NUMBERP (CAR CMD))
                     (REPINS (CAR CEXP)
                             (CAR CMD)
                             (CDR CMD)))
                    ((EVAL (GETPROP (CAR CMD)
                                    'ELF)
                                    (ALIST)))))
             ((NUMBERP CMD)
              (EDITN (CAR CEXP) CMD))
             ((EVAL (GETPROP CMD 'EDF)
                    (ALIST)))
             (T(PRINT '???)))
        (GO EDITLP)))


(DE EDITN (P NN)
      (COND ((ZEROP NN)
             (AND (CDR CEXP)
                  (SETQ CEXP (CDR CEXP))))
            ((EQ NN 1)
             (OR (ATOM P)
                 (SETQ CEXP (CONS (CAR P)
                                  CEXP))))
            (T(EDITN (CDR P)
                     (SUB1 NN)))))


(DE REPINS (P NN NEW)
(COND ((OR (NULL P)
           (ZEROP NN)) NIL )
      ((AND (EQ NN 2)
            (LISTP (CDR P)))
       (COND ((ATOM NEW)
              (RPLACD P (CDDR P)))
             (T(RPLACD (LAST NEW)
                       (CDDR P))
               (RPLACD P NEW))))
      ((EQ NN 1)
       (COND (NEW (RPLACA P (CAR NEW)))
             (T(RPLACA P (CADR P))
               (RPLACD P (CDDR P)))))
      ((EQ NN -1)
       (RPLACD P (CONS (CAR P)
                       (CDR P)))
       (RPLACA P (CAR NEW)))
      ((GREATERP NN 1)
       (REPINS (CDR P)
               (SUB1 NN)
               NEW))
      (T(REPINS (CDR P)
                (ADD1 NN)
                NEW))))


(PUTPROP 'P 'EDF '(PROGN (PRL (CAR CEXP) 1)
                    T))

(PUTPROP '? 'EDF '(PROGN (PRINT (CAR CEXP))
                    T))

(PUTPROP '^ 'EDF '(PROGN (SETQ CEXP (LIST L))
                    T))

(PUTPROP 'E 'EDF '(PROGN (EVAL (READ)
                          (ALIST))
                    T))

(PUTPROP 'Z 'EDF '(PROGN (SETQ CEXP (CONS (CAR (LAST (CAR CEXP)))
                                     CEXP))
                    (PRL (CAR CEXP) 1)
                    T))

(PUTPROP 'OK 'EDF '(RETURN 'OK))
(PUTPROP 'AB 'EDF '(RETURN))
(PUTPROP 'PP 'EDF '(PROGN (PL (CAR CEXP)) T))

(PUTPROP 'UP 'EDF
         '(COND ((MEMB (CAR CEXP)
                       (CADR CEXP))
                 (RPLACA CEXP (MEMB (CAR CEXP)
                                    (CADR CEXP) ) ) )))


(PUTPROP 'N 'ELF '(RPLACD (LAST (CAR CEXP))
                     (CDR CMD)))

(PUTPROP ': 'ELF '(PROGN (RPLACA (MEMB (CAR CEXP)
                                  (CADR CEXP))
                            (CADR CMD))
                    (RPLACA CEXP (CADR CMD))
                    T))


(DF EDITF (L A)
(PROG (R F)
  (SETQ F (GETD (CAR L)))
  (COND ((LISTP F)
         (SETQ R (COPY F))
         (COND ((EDITV R)
                (PUTPROP (CAR L)
                         (CAR R)
                         (CDR R))
                (TERPRI)
                (RETURN (CAR L)))
               (T (TERPRI)
                  (RETURN (QUOTE ABORTED)))))
        (T (RETURN (LIST (CAR L)
                         (QUOTE NOT)
                         (QUOTE EDITABLE)))))))

(DE PRL (L N)
    (PROG NIL (COND ((NULL L)
                      (RETURN))
                    ((ATOM L)
                      (RETURN (PRINT L))))
          (PRIN1 (QUOTE %())
          LP (COND ((NULL L)
                     (RETURN (PRIN1 (QUOTE %))))))
          (COND ((ATOM (CAR L))
                  (PRINT (CAR L))
                  (COND ((CDR L)
                          (PRIN1 (QUOTE % )))))
                (T (COND ((EQ N  1)
                           (PRIN1 (QUOTE &% )))
                         (T (PRL (CAR L)
                                 (SUB1 N))))))
          (SETQ L (CDR L))
          (GO LP)))

(QUOTE SLUT)
))))))))))))