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