;
;                      The XLISP EDITOR V1.1
;                                by
;                          R.C. Philbrick
;
; For use with Xlisp V2.0.T5 on the Atari ST.
;
; To edit a function: (ef '<function-name>)
; To edit a list: (edit '<list-name>)
; To save a function (function must be executed outside the editor):
;    (sve '(<function-names>))
;    where <function-names> is a series of function names separated
;    by spaces.
;
; To use with Xlisp V1.7 simply delete the "ef" function,
; use (edit '<function-name>), and provide a pretty-print program.
; The main pretty-print procedure should be named "pprint".
;
; If you prefer to have prompts active in the editor program,
; just remove the semicolons in the appropriate places in the listing.
;
;
; Sorry, the editor doesn't work completely right on IBMs... yet.
;
;
; Send questions, suggestions, bug reports (about the editor), etc.
; to one of the following addresses:
;
; Bitnet address:               Home address: 204 Orchard Circle
; IO60260 at MAINE.BITNET                     Hamilton, Va. 22068
;
; Campus address:
; 103 Gannett Hall
; Univ. of Maine
; Orono, Me. 04469
;
;
;
; Command Summary:
;
;   ex - Exits the editor.
; cmds - Returns the current command set.
;    a - Advance through the current list.
;    b - Back up through the list.
;    d - descend into a sublist.
;  top - Moves back to the top.
;  bot - Moves to the bottom of the.
;  del - Deletes the current element.
;  rmp - Remove one level of parentheses from the current element.
;  enp - Enclose the current element in one level of parentheses.
;    g - Group the current element to following elements.
;   pp - pretty-print the entire expression being edited.
;
; The following commands expect parameters to be supplied:
;
;   goto <n> - Finds the point in the current sublist that equates to
;              <n> and makes it the current element.
;      r <n> - Replaces the current element with <n>.
; xcg <a><b> - Exchanges all occurrences of <a> with <b>.
;      i <n> - Inserts <n> behind the current element.
;   mv <cmd> - mv c "Move function: Cut" Saves the current element
;                   to the variable "sxpr" and deletes it from the
;                   current sublist.
;              mv p "Move function: Paste" Inserts the contents of the
;                   just behind the current element.
;   pre <n> - "Prefix" creates a list whose members are <n> followed
;             by the current element.
;
;
; And now... Here's the program!
;
(defun edit (s-exp)
(prog nil
(gc)
(setq comset '(ex cmds a b d top bot goto r xcg i mv pre del rmp enp g pp))
top
(terpri)
(setq base s-exp)
(setq curloc s-exp)
loop
(pprint (eval curloc))
(terpri)
(princ '"Edit:  ")
(setq cmd (read))
(cond ((equal cmd 'ex)
       (setq curloc base)
       (gc)
       (princ "exited")
       (terpri)
       (terpri)
       (return))
      ((equal cmd 'top)
       (setq curloc base))
      ((equal cmd 'cmds)
       (print comset)
       (terpri))
      ((member cmd comset)
       (funcall cmd curloc))
      (t (prin1 cmd)
         (princ '" is not in the command set.")
         (terpri)))
(go loop)))
;
;
; advance
(defun a (x)
(cond ((atom x)
       (setq x (list 'car x)))
      (t (setq x (list 'car (list 'cdr (cadr x))))))
(cond ((equal (length (eval (cadr x))) 0)
       (princ '"End of s-expression.")
       (terpri)
       curloc)
      (t (setq curloc x))))
;
;
; backup
(defun b (x)
(cond ((atom x)
       (princ '"At top level.")
       (terpri)
       x)
      ((atom (cadr x))
       (setq x (cadr x)))
      (t (setq x (rplacd x (cdadr x)))))
(setq curloc x))
;
;
; descend
(defun d (x)
(cond ((atom (eval x))
       (princ '"S-expression is atomic.")
       (terpri)
       x)
      (t (setq x (list 'car x))))
(setq curloc x))
;
;
; advance to end (used by bot)
(defun ae (x)
(cond ((atom (eval x))
       x)
      ((equal (length (eval x)) 1)
       (ae (list 'car x)))
      (t (ae (list 'cdr x)))))
;
;
; go to a point in the list that starts with the same s-expression
(defun goto (x)
(setq tmp2 x)
;(princ "Go to --")                     ;You want prompts?  We got prompts.
(find (read) x)
(setq x tmp2)
(setq curloc x))
;
;
; used by goto
(defun find (tmp x)
(cond ((equal tmp (eval x)) (setq tmp2 x))
((atom (eval x)) x)
(t (find tmp (list (quote cdr) x))
 (find tmp (list (quote car) x)))))
;
;
; go to the bottom of the current list
(defun bot (x)
(setq x (ae x))
(setq curloc x))
;
;
; replace
(defun r (x)
;(princ "Enter new expression --")      ;You want prompts?  We got prompts.
(rplaca (eval (cadr x)) (read))
(setq curloc x))
;
;
; exchange all occurrences of x with y
(defun xcg (x)
;(princ "Exchange --")                  ;You want prompts?  We got prompts.
(switch (read) (read) x)
(setq curloc x))
;
;
; used by xcg
(defun switch (tmp tmp2 x)
(cond ((equal tmp (eval x))
       (rplaca (eval (cadr x)) tmp2))
      ((atom (eval x)) x)
      (t (switch tmp tmp2 (list (quote cdr) x))
         (switch tmp tmp2 (list (quote car) x)))))
;
;
; insert
(defun i (x)
;(princ "Enter insertion --")           ;You want prompts?  We got prompts.
(setq tmp (cons (read) (cdr (eval (cadr x)))))
(rplacd (eval (cadr x)) tmp)
(setq x (a x))
(setq curloc x))
;
;
; prefix
(defun pre (x)
;(princ "Enter prefix --")              ;You want prompts?  We got prompts.
(rplaca (eval (cadr x)) (list (read) (eval x)))
(setq curloc x))
;
;
; remove current element
(defun del (x)
(cond ((atom x) (set x (cdr (eval x))))
      ((atom (cadr x))
       (set (cadr x) (cdr (eval (cadr x)))))
      ((equal (caadr x) 'car)
       (rplaca (eval (cadadr x)) (cdr (eval (cadr x)))))
      (t (rplacd (eval (cadadr x)) (cdr (eval (cadr x))))))
(setq curloc x))
;
;
; move current element
(defun mv (x)
;(princ "cut/paste (c/p) --")           ;You want prompts?  We got prompts.
(cond ((equal (read) (quote c))
       (setq sxpr (eval x))
       (del x))
      (t (setq sxpr (cons sxpr (cdr (eval (cadr x)))))
       (rplacd (eval (cadr x)) sxpr)
       (setq x (a x))))
(setq curloc x))
;
;
; remove parentheses
(defun rmp (x)
(setq tmp (eval (cadr x)))
(setq tmp (nconc (car tmp) (cdr tmp)))
(rplaca (eval (cadr x)) (car tmp))
(rplacd (eval (cadr x)) (cdr tmp))
(setq curloc x))
;
;
; enclose in parentheses
(defun enp (x)
(rplaca (eval (cadr x)) (list (eval x)))
(setq curloc x))
;
;
; group current element to trailing elements
(defun g (x)
(prog nil
(cond ((atom x)
       (princ "Not available at this level.")
       (terpri)
       (terpri)
       (return)))
(setq tmp (list (eval x)))
(setq tmp2 (list (quote cdr) (cadr x)))
loop
(terpri)
(pprint tmp)
loop2
(terpri)
(princ "Continue? (y/n) --")
(cond ((equal (read) (quote y))
       (cond ((equal (length (eval tmp2)) 0)
              (terpri)
              (princ "At bottom level.")
              (terpri)
              (terpri)
              (go loop2))
             (t (setq tmp (nconc tmp
                           (list (eval (list (quote car) tmp2)))))
              (setq tmp2 (list (quote cdr) tmp2))
              (go loop))))
      (t (terpri)
        (cond ((atom (cadr x))
               (set (cadr x) (cons tmp (eval tmp2))))
              ((equal (caadr x) (quote car))
               (rplaca (eval (cadadr x)) (cons tmp (eval tmp2))))
              (t (rplacd (eval (cadadr x))
                 (cons tmp (eval tmp2))))))))
(setq curloc x))
;
;
; pprint entire expression being edited
(defun pp (x)
(pprint (eval base))
(princ "________________________________________")
(terpri)
(terpri))
;
;
; save a function or macro definition
(defun sve (x)
(prog nil
(cond ((atom x)
       (princ "No can do.  Must be a list.")
       (terpri)
       (return)))
(princ "Enter filename --")
(setq fnme (read))
(setq fp (open fnme :direction :output))
loop
(cond ((not (fboundp (car x)))
       (prin1 (car x))
       (princ " -- is not a function.")
       (terpri)
       (go pop)))
(setq bse (car x))
(setq bse (symbol-function bse))
(setq prms (cadar bse))
(setq nmf (cadr (caddar bse)))
(setq rst (cddr (caddar bse)))
(cond ((equal (caar bse) (quote macro))
       (setq tpe (quote defmacro)))
      (t (setq tpe (quote defun))))
(setq ttl (cons tpe (cons nmf (cons prms rst))))
(pprint ttl fp)
pop
(cond ((equal (length (cdr x)) 0)
       (close fp)
       (return 'saved))
      (t (terpri fp)
       (setq x (cdr x))
       (go loop)))))
;
;
; used to invoke the editor on function definitions
(defun ef (x)
(prog nil
(setq sf x)
(cond ((not (fboundp sf))
(prin1 sf)
(princ " -- is not a function.")
(terpri)
(return 'exited)))
; For Atari ST Xlisp V2.0.T5:
(setq sf (symbol-function sf))
; For IBM Xlisp V2.0:
;(setq sf (list (get-lambda-expression (symbol-function sf))))
(edit (quote sf))))
;
;
; --==<<** And now for some marginally useful function definitions **>>==--
;
;
; use to pretty-print functions
(defun ppf (x)
; For Atari ST Xlisp V2.0.T5:
(pprint (symbol-function x))
; For IBM Xlisp V2.0:
;(pprint (get-lambda-expression (symbol-function x)))
)
;
;
; Because typing "(top-level)" that many times is a royal pain!
(defun tl () (eval (top-level)))
;
;
; use to clear the screen
(defun cls ()
(prog nil
(setq lp 24)
loop
(cond ((> lp 0)
       (setq lp (- lp 1))
       (terpri)
       (go loop)))))