home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / XLisp 2.1e3 ƒ / lisp / repair.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-10-29  |  15.4 KB  |  469 lines  |  [TEXT/ttxt]
  1. ; New Structure Editor  by Tom Almy
  2.  
  3. ; (repair <symbol>)  or (repairf <symbol>) to repair only the function
  4. ; binding, with the capability of changing the argument list and type
  5. ; (MACRO or LAMBDA).
  6.  
  7. ; Execute (repairs symbol) to edit any symbol binding
  8.  
  9. ; Editor alters the "selection" by copying so that aborting  all changes
  10. ;  is generally posible.
  11. ; Exception: when editing a closure, if the closure is BACKed out of, the
  12. ;   change is permanent.
  13. ; For all commands taking a numeric argument, the first element of the
  14. ; selection is the 0th (as in NTH function).
  15.  
  16. ; Any array elements become lists when they are selected, and
  17. ; return to arrays upon RETURN or BACK commands.
  18.  
  19. ; Do not create new closures, because the environment will be incorrect.
  20.  
  21. ; Closures become LAMBDA or MACRO expressions when selected.  Only
  22. ; the closure body may be changed; the argument list cannot be successfully
  23. ; modified, nor can the environment.
  24.  
  25. ; For class objects, only the methods and selectors can be modified.  For
  26. ; instance objects, instance variables can be examined (if the object under-
  27. ; stands the message :<ivar> for the particular ivar), and changed 
  28. ; if :SET-IVAR is defined for that class (as it is if CLASSES.LSP is used)
  29.  
  30. ; COMMANDS:
  31. ;    CAR -- select the CAR of the current selection.
  32. ;    CDR -- select the CDR of the current selection.
  33. ;    n -- where n is small non-negative integer, changes selection
  34. ;            to (NTH n list)
  35. ;    RETURN -- exit, saving all changes
  36. ;    ABORT -- exit, without changes
  37. ;    BACK -- go back one level (as before CAR CDR or N commands)
  38. ;       B n -- go back n levels.
  39. ;    L -- display selection using pprint; if selection is symbol, give
  40. ;         short description
  41. ;    MAP -- pprints each element of selection, if selection is symbol
  42. ;              then give complete description of properties.
  43. ;       PLEN n -- change maximum print length (default 10)
  44. ;       PLEV n -- change maximum print depth (default 3)    
  45. ;    EVAL x -- evaluates x and prints result
  46. ;        The symbol @ is bound to the selection
  47. ;    REPLACE x -- replaces the selection with evaluated x.
  48. ;        The symbol @ is bound to the selection
  49. ; additional commands if selection is a symbol:
  50. ;    VALUE -- edit value binding
  51. ;    FUNCTION -- edit function binding (if a closure)
  52. ;    PROP x -- edit property x
  53. ; additional commands if selection is a list:
  54. ;    SUBST x y -- all occurances of (quoted) y are replaced with 
  55. ;        (quoted) x.  EQUAL is used for the comparison.
  56. ;    RAISE n -- removes parenthesis surrounding nth element of selection
  57. ;    LOWER n m -- inserts parenthesis starting with the nth element,
  58. ;        for m elements.
  59. ;    ARRAY n m -- as in LOWER, but makes elements into an array
  60. ;    I n x -- inserts (quoted) x before nth element in selection.
  61. ;    R n x -- replaces nth element in selection with (quoted) x.
  62. ;    D n -- deletes nth element in selection.
  63.  
  64.  
  65. ; Global variable used by repair functions
  66. ; Assuming globals are specials -- if you are using this with old XLISP
  67. ; then search for binding of globals, and change LET's to PROGV's
  68.  
  69. (defparameter *rep-exit* 0)   ; "returning" flag
  70. (defparameter *rep-name* nil) ; name of what we are editing
  71.  
  72. (defvar *rep-plev* 3)    ; initial print level used
  73. (defvar *rep-plen* 10)    ; initial print length used
  74.                        
  75.                          
  76. ; repair a symbol -- the generic entry point
  77.  
  78. (defmacro repair (a)
  79.     (unless (symbolp a) (error (format nil "~s is not a symbol" a)))
  80.     (let
  81.      ((*breakenable* nil)
  82.       (*rep-exit* 0)
  83.       (*rep-name* (cons "symbol" a))
  84.       (*print-level* *rep-plev*)
  85.       (*print-length* *rep-plen*))
  86.      (catch 'abort (rep-rep a)))
  87.      `',a)
  88.  
  89. ; repair a function, with editable arguments
  90.  
  91. (defmacro repairf (a)
  92.     (let
  93.      ((*breakenable* nil)
  94.       (*rep-exit* 0) 
  95.       (*rep-name* (cons "function" a)) 
  96.       (*print-level* *rep-plev*)
  97.       (*print-length* *rep-plen*))
  98.      (catch 'abort
  99.         (if (fboundp a)
  100.         (let ((x (rep-rep(get-lambda-expression(symbol-function a)))))
  101.              (case (first x)
  102.                (lambda `(defun ,a ,@(rest x)))
  103.                (macro  `(defmacro ,a ,@(rest x)))
  104.                (t (error "not a closure!"))))
  105.         (error "can't repair")))))
  106.  
  107.  
  108. ; rep-propp returns T if p is a property of a
  109.  
  110. (defun rep-propp (a p)
  111.     (do     ((plist (symbol-plist a) (cddr plist)))
  112.         ((or (null plist) (eq (car plist) p))
  113.          (not (null plist)))))
  114.  
  115. ; terminate input line
  116.  
  117. (defun rep-teread (error) 
  118.     (if (not (eq (peek-char) #\Newline))
  119.         (read-line))
  120.     (if error
  121.         (princ "Try again:")
  122.         (format t "~a ~a>" (car *rep-name*) (cdr *rep-name*))))
  123.  
  124. (defmacro rep-protread () ;;Protected read -- we handle errors
  125.     '(do ((val (errset (read)) 
  126.           (progn (rep-teread t) (errset (read)))))
  127.         ((consp val) (car val))))
  128.  
  129. (defmacro rep-proteval () ;;protected eval -- we handle errors
  130.               ;; we also use evalhook so environment is global
  131.               ;;  plus a local @, which cannot be changed!
  132.     '(do* ((env (cons (list (list (cons '@ list))) nil))
  133.            (val (errset (evalhook (read) nil nil env))
  134.             (progn (rep-teread t) 
  135.                (errset (evalhook (read) nil nil env)))))
  136.           ((consp val) (car val))))
  137.  
  138.  
  139. ; Part of modified classes.lsp. Repeated here in case classes.lsp not used
  140.  
  141. (defun classp (name)
  142.        (when (objectp name)
  143.          (eq (send name :class) class)))
  144.  
  145. ; New methods so that we can "repair" methods.
  146. ; selectors :get-messages, :get-ivars, and :get-super changed to 
  147. ; :messages, :ivars, and :superclass to be compatible with new classes.lsp.
  148.  
  149. (send Class :answer :messages '() '(messages))
  150.  
  151. (send Class :answer :set-messages '(value) '((setf messages value)))
  152.  
  153. ; new methods so that we can examine/change instance variables
  154.  
  155. (send Class :answer :ivars '() '(ivars))
  156.  
  157. (send Class :answer :superclass '() '(superclass))
  158.  
  159. (defun rep-ivar-list (obj &aux (cls (send obj :class)))
  160.     (do ((ivars (send cls :ivars)
  161.             (append (send super :ivars) ivars))
  162.      (super (send cls :superclass) (send super :superclass)))
  163.     ((null super) ivars)
  164.      ))
  165.  
  166. (defun rep-ivars (list obj)
  167.     (mapcar #'(lambda (x)
  168.             (let ((y (errset (apply #'send
  169.                         (list obj
  170.                           (intern (strcat ":"
  171.                                   (string x)))))
  172.                  nil)))
  173.           (if (consp y) (list x (car y)) x)))
  174.         list))
  175.  
  176. (defun rep-set-ivars (alist obj)
  177.     (mapc #'(lambda (x)
  178.           (if (consp x)
  179.           (let ((y (errset (apply #'send
  180.                       (list obj
  181.                             :set-ivar
  182.                         (car x)
  183.                             (cadr x)))
  184.                    nil)))
  185.             (unless (consp y)
  186.                 (princ (list (car x) " not set."))
  187.                 (terpri)))
  188.           (progn (princ (list x "not set.")) (terpri))))
  189.       alist))
  190.  
  191. ; help function
  192. (defun rep-help (list)
  193.        (terpri)
  194.        (princ "Available commands:\n\n")
  195.        (princ "?\t\tprint list of commands\n")
  196.        (princ "RETURN\t\texit, saving all changes\n")
  197.        (princ "ABORT\t\texit, without changes\n")
  198.        (princ "BACK\t\tgo back one level (as before CAR CDR or N commands)\n")
  199.        (princ "B n\t\tgo back n levels\n")
  200.        (cond ((symbolp list)
  201.           (princ "L\t\tshort description of selected symbol\n")
  202.           (princ "MAP\t\tcomplete description of selected symbols properties\n"))
  203.          ((consp list)
  204.           (princ "L\t\tshow selection (using pprint)\n")
  205.           (princ "MAP\t\tpprints each element of selection\n"))
  206.          (t 
  207.           (princ "L\t\tshow selection (using pprint)\n")
  208.           (princ "MAP\t\tshow selection (using pprint)\n")))
  209.        (format
  210.     t 
  211.     "PLEV n\t\tsets number of levels of printing (now ~s) NIL=infinite\n"
  212.     *print-level*)
  213.        (format
  214.     t
  215.     "PLEN n\t\tsets length of list printing (now ~s) NIL=infinite\n"
  216.     *print-length*)
  217.        (princ "EVAL x\t\tevaluates x and prints result\n")
  218.        (princ "\t\tNote the symbol @ is bound to the selection\n")
  219.        (princ "REPLACE x\treplaces the selection with evaluated x\n")
  220.        (princ "\t\tNote the symbol @ is bound to the selection\n")
  221.        (when (symbolp list)
  222.          (princ "FUNCTION\tedit the function binding\n")
  223.          (princ "VALUE\t\tedit the value binding\n")
  224.          (princ "PROP pname\tedit property pname\n")
  225.          (return-from rep-help nil))
  226.        (unless (consp list) (return-from rep-help nil))
  227.        (princ "CAR\t\tSelect the CAR of the selection\n")
  228.        (princ "CDR\t\tSelect the CDR of the selection\n")
  229.        (princ "n\t\tSelect the nth element in the selection (0 based)\n")
  230.        (princ "SUBST x y\tall EQUAL occurances of y are replaced with x\n")
  231.        (princ "RAISE n\t\tremoves parenthesis surrounding nth element of the selection\n")
  232.        (princ "LOWER n m\tinserts parenthesis starting with the nth element,\n")
  233.        (princ "\t\tfor m elements of the selection\n")
  234.        (princ "ARRAY n m\tas in LOWER, but makes elements into an array\n")
  235.        (princ "I n x\t\tinserts (quoted) x before nth element in selection\n")
  236.        (princ "R n x\t\treplaces nth element in selection with (quoted) x\n")
  237.        (princ "D n\t\tdeletes nth element in selection\n"))
  238.  
  239.  
  240. ; rep-rep repairs its argument.  It looks at the argument type to decide
  241. ;  how to do the repair.
  242. ;  ARRAY  -- repair as list
  243. ;  OBJECT -- if class, repair MESSAGE ivar, else repair list of ivars
  244. ;  CLOSURE -- allows repairing of closure body by destructive modification
  245. ;             upon return
  246. ;  OTHER  -- repair as is.
  247.  
  248. (defun rep-rep (list) 
  249.     (cond ((arrayp list) 
  250.            (princ "Editing array") 
  251.            (terpri)
  252.            (coerce (rep-rep2 (coerce list 'cons)) 'array))
  253.           ((classp list)
  254.            (princ "Editing Methods")
  255.            (terpri)
  256.            (send list :set-messages 
  257.                     (rep-rep2 (send list :messages)))
  258.            list) ; return the object
  259.           ((objectp list)
  260.            (princ "Editing Instance Vars")
  261.            (terpri)
  262.            (rep-set-ivars (rep-rep2 
  263.                            (rep-ivars 
  264.                     (rep-ivar-list list) list)) list)
  265.            list) ; return the object
  266.           ((typep list 'closure)
  267.            (princ "Editing closure")
  268.            (terpri)
  269.            (let*  ((orig (get-lambda-expression list))
  270.                    (new (rep-rep2 orig)))
  271.               (when (not (equal (second orig) (second new)))
  272.                       (princ "Argument list unchanged")
  273.                 (terpri))
  274.               (rplaca (cddr orig) (caddr new))
  275.               (rplacd (cddr orig) (cdddr new))
  276.               list)) ; return closure
  277.           (t (rep-rep2 list))))
  278.  
  279.  
  280. ; printing routines
  281.  
  282. ; print a property list
  283. (defun rep-print-prop (plist verbosity)
  284.     (when plist
  285.           (format t "Property: ~s" (first plist))
  286.           (when verbosity
  287.             (format t "   ~s" (second plist)))
  288.           (terpri)
  289.           (rep-print-prop (cddr plist) verbosity)))
  290.  
  291. ; print a symbols function binding, value, and property list
  292. (defun rep-print-symbol (symbol verbosity)
  293.        (format t "Print name: ~s~%" symbol)
  294.        (unless (null symbol)
  295.     (when (fboundp symbol)
  296.           (if verbosity 
  297.           (if (typep (symbol-function symbol) 'closure)
  298.               (progn
  299.                (format t "Function:~%")
  300.                (pprint (get-lambda-expression
  301.                 (symbol-function symbol))))
  302.               (format t "Function: ~s~%" (symbol-function symbol)))
  303.           (format t "Function binding~%")))
  304.     (when (boundp symbol)
  305.           (if (constantp symbol) 
  306.           (princ "Constant V")
  307.           (princ "V"))
  308.           (if verbosity
  309.           (if (< (flatsize (symbol-value symbol)) 60)
  310.               (format t "alue: ~s~%" (symbol-value symbol))
  311.               (progn
  312.                (format t "alue:~%")
  313.                (pprint (symbol-value symbol))))
  314.           (format t "alue binding~%")))
  315.     (when (symbol-plist symbol)
  316.           (rep-print-prop (symbol-plist symbol) verbosity)))
  317. )
  318.  
  319. ; print a list, using mapcar
  320. (defun rep-print-map (list &aux (x 0))
  321.        (mapc #'(lambda (y)
  322.                (format t "(~s) " (prog1 x (setf x (1+ x)) ))
  323.                (pprint y))
  324.          list))
  325.  
  326. ; main list repair interface
  327. (defun rep-rep2 (list) 
  328.     (prog (command n)
  329.     y (rep-teread nil)
  330.       (setq command (rep-protread))
  331.       (cond    ((eq command '?) (rep-help list))
  332.         ((eq command 'return) (setq *rep-exit* -1))
  333.         ((eq command 'abort) (throw 'abort))
  334.         ((eq command 'back) (return list))
  335.         ((and (eq command 'b)
  336.               (integerp (setq n (rep-protread)))
  337.               (> n 0))
  338.          (setq *rep-exit* n))
  339.         ((eq command 'l)
  340.          (if (symbolp list) (rep-print-symbol list nil) (print list)))
  341.         ((eq command 'map)
  342.          (cond ((symbolp list) (rep-print-symbol list t))
  343.                ((consp list) (rep-print-map list))
  344.                (t (pprint list))))
  345.         ((eq command 'eval) (print (rep-proteval)))
  346.         ((and (eq command 'plev)
  347.               (or (and (integerp (setq n (rep-protread)))
  348.                    (>= n 1))
  349.               (null n)))
  350.          (format t "Was ~s\n" *print-level*)
  351.          (setq *print-level* n))
  352.         ((and (eq command 'plen)
  353.               (or (and (integerp (setq n (rep-protread)))
  354.                    (>= n 1))
  355.               (null n)))
  356.          (format t "Was ~s\n" *print-length*)
  357.          (setq *print-length* n))
  358.         ((eq command 'replace) 
  359.          (setq n (rep-proteval))
  360.          (if (eq (type-of n) (type-of list))
  361.              (setq list n)
  362.              (return (rep-rep n))))
  363. ; symbol only commands
  364.         ((and (symbolp list)
  365.               (eq command 'function) 
  366.               (fboundp list)
  367.               (typep (symbol-function list) 'closure))
  368.          (let ((*rep-name* (cons "function" list)))
  369.             (setf (symbol-function list) 
  370.                   (rep-rep (symbol-function list)))))
  371.         ((and (symbolp list)
  372.               (eq command 'value)
  373.               (boundp list)
  374.               (null (constantp list)))
  375.          (let ((*rep-name* (cons "value" list)))
  376.             (setf (symbol-value list)
  377.                   (rep-rep (symbol-value list)))))
  378.         ((and (symbolp list)
  379.               (eq command 'prop)
  380.               (symbolp (setq n (rep-protread)))
  381.               (rep-propp list n))
  382.          (let ((*rep-name* (cons n list)))
  383.             (setf (get list n) (rep-rep (get list n)))))
  384. ; cons only commands
  385.         ((and (consp list)
  386.               (eq command 'car))
  387.          (setq list (cons (rep-rep (car list)) (cdr list))))
  388.         ((and (consp list)
  389.               (eq command 'cdr))
  390.          (setq list (cons (car list) (rep-rep (cdr list)))))
  391.         ((and (consp list)
  392.               (integerp command)
  393.               (> command -1) 
  394.               (< command (length list)))
  395.          (setq list (append
  396.                  (subseq list 0 command)
  397.                  (list (rep-rep (nth command list)))
  398.                  (nthcdr (1+ command) list))))
  399.         ((and (consp list)
  400.               (eq command 'raise) 
  401.               (integerp (setq n (rep-protread)))
  402.               (> n -1) 
  403.               (< n (length list))
  404.               (or (consp (nth n list)) (arrayp (nth n list))))
  405.          (setq list (append
  406.                  (subseq list 0 n)
  407.                  (let ((x (nth  n list)))
  408.                   (if (arrayp x)
  409.                       (coerce x 'cons)
  410.                       x))
  411.                  (nthcdr (1+ n) list))))
  412.         ((and (consp list)
  413.               (eq command 'lower)
  414.               (integerp (setq n (rep-protread)))
  415.               (> n -1)
  416.               (integerp (setq n2 (rep-protread)))
  417.               (> n2 0)
  418.               (>= (length list) (+ n n2)))
  419.          (setq list (append
  420.                  (subseq list 0 n)
  421.                  (list (subseq list n (+ n n2)))
  422.                  (nthcdr (+ n n2) list))))
  423.         ((and (consp list)
  424.               (eq command 'array)
  425.               (integerp (setq n (rep-protread)))
  426.               (> n -1)
  427.               (integerp (setq n2 (rep-protread)))
  428.               (> n2 0)
  429.               (>= (length list) (+ n n2)))
  430.          (setq list (append
  431.                  (subseq list 0 n)
  432.                  (list (coerce (subseq list n (+ n n2)) 'array))
  433.                  (nthcdr (+ n n2) list))))
  434.         ((and (consp list)
  435.               (eq command 'i) 
  436.               (integerp (setq n (rep-protread)))
  437.               (> n -1))
  438.          (setq list (append
  439.                  (subseq list 0 n)
  440.                  (list (rep-protread))
  441.                  (nthcdr n list))))
  442.         ((and (consp list)
  443.               (eq command 'r) 
  444.               (integerp (setq n (rep-protread)))
  445.               (> n -1))
  446.          (setq list (append
  447.                  (subseq list 0 n)
  448.                  (list (rep-protread))
  449.                  (nthcdr (1+ n) list))))
  450.         ((and (consp list)
  451.               (eq command 'd) 
  452.               (integerp (setq n (rep-protread)))
  453.               (> n -1))
  454.          (setq list (append
  455.                  (subseq list 0 n)
  456.                  (nthcdr (1+ n) list))))
  457.         ((and (consp list)
  458.               (eq command 'subst))
  459.          (setq list (subst (rep-protread) 
  460.                    (rep-protread) 
  461.                    list
  462.                    :test #'equal)))
  463.         (t (princ "What??\n") (go y)))
  464.  
  465.       (when (zerop *rep-exit*) (go y))
  466.       (setq *rep-exit* (1- *rep-exit*))
  467.       (return list)))
  468.  
  469.