home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / INSPECT.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  19KB  |  562 lines
  1. ; XLISP INSPECTOR/EDITOR by TOM ALMY
  2. ; This is a rewritten and improved version of "REPAIR"
  3.  
  4. ; (ins <symbol>)  or (insf <symbol>) to repair only the function
  5. ; binding, with the capability of changing the argument list and type
  6. ; (MACRO or LAMBDA).
  7.  
  8. ; Editor alters the "selection" by copying so that aborting  all changes
  9. ;  is generally posible.
  10. ; Exception: when editing a closure, if the closure is Backed out of, the
  11. ;   change is permanent.
  12.  
  13. ; Do not create new closures, because the environment will be incorrect.
  14.  
  15. ; Closures become LAMBDA or MACRO expressions when edited.  Only
  16. ; the closure body may be changed; the argument list cannot be successfully
  17. ; modified, nor can the environment.
  18.  
  19. ; For all commands taking a numeric argument, the first element of the
  20. ; selection is the 0th (as in NTH function).
  21.  
  22. ; Structure elements, class methods, instance variables, and properties
  23. ; are selected by name, using the E command.
  24.  
  25. ; For class objects, only the methods, selectors and class variables
  26. ; can be edited. Class variables can only be changed if instance variables
  27. ; of class instances can be changed (see next paragraph).
  28.  
  29. ; For instance objects, instance variables can be examine
  30. ; (if the object understands the message :<ivar> for the particular ivar),
  31. ; and changed if :SET-IVAR is defined for that class (as it is if CLASSES.LSP
  32. ; is used)
  33.  
  34. ; COMMANDS (case is significant):
  35. ;    A -- select the CAR of the current selection.
  36. ;    D -- select the CDR of the current selection.
  37. ;    e n -- select element n
  38. ;    r n x -- replaces element n with (quoted) x.
  39. ;    X -- exit, saving all changes
  40. ;    Q -- exit, without changes
  41. ;    b -- go back one level (as before A, D or e commands)
  42. ;       B n -- go back n levels.
  43. ;    l -- display selection using pprint; if selection is symbol, give
  44. ;         short description
  45. ;    v -- verbosity toggle
  46. ;       . n -- change maximum print length (default 10)
  47. ;       # n -- change maximum print depth (default 3)    
  48. ;    ! x -- evaluates x and prints result
  49. ;        The symbol tools:@ is bound to the selection
  50. ;    R x -- replaces the selection with evaluated x.
  51. ;        The symbol tools:@ is bound to the selection
  52. ; additional commands if selection is a list or array:
  53. ;    ( n m -- inserts parenthesis starting with the nth element,
  54. ;        for m elements.
  55. ;    ) n -- removes parenthesis surrounding nth element of selection,
  56. ;              which may be array or list
  57. ;    [ n m -- as in [, but makes elements into an array
  58. ;    i n x -- inserts (quoted) x before nth element in selection.
  59. ;    d n -- deletes nth element in selection.
  60. ; additional command if selection is a list:
  61. ;    S x y -- all occurances of (quoted) y are replaced with 
  62. ;        (quoted) x.  EQUAL is used for the comparison.
  63.  
  64.  
  65. #+:packages
  66. (unless (find-package "TOOLS")
  67.     (make-package "TOOLS" :use '("XLISP")))
  68.  
  69. (in-package "TOOLS")
  70.  
  71. (export '(ins insf @))
  72.  
  73. ; Global variable used by inspect functions
  74.  
  75. (defparameter *ins-exit* 0)   ; "returning" flag
  76. (defparameter *ins-name* nil) ; name of what we are editing
  77.  
  78. (defvar *ins-plev* 3)    ; initial print level used
  79. (defvar *ins-plen* 10)    ; initial print length used
  80. (defvar *verbosity* t)  ; printing verbosity flag                       
  81. (defconstant *LPAR* #\()
  82. (defconstant *RPAR* #\))
  83.  
  84.                  
  85. ; inspect a symbol -- the generic entry point
  86.  
  87. (defmacro ins (a)
  88.     (unless (symbolp a) (error "~s is not a symbol" a))
  89.     (let
  90.      ((*breakenable* t)
  91.       (*ins-exit* 0)
  92.       (*ins-name* (cons "symbol" a))
  93.       (*print-level* *ins-plev*)
  94.       (*print-length* *ins-plen*))
  95.      (catch 'abort (ins-ins a)))
  96.      `',a)
  97.  
  98. ; inspect a function, with editable arguments
  99.  
  100. (defmacro insf (a)
  101.     (let
  102.      ((*breakenable* nil)
  103.       (*ins-exit* 0) 
  104.       (*ins-name* (cons "function" a)) 
  105.       (*print-level* *ins-plev*)
  106.       (*print-length* *ins-plen*))
  107.      (catch 'abort
  108.         (if (and (fboundp a) (typep (symbol-function a) 'closure))
  109.         (let ((x (ins-ins(get-lambda-expression(symbol-function a)))))
  110.              (case (first x)
  111.                (lambda `(defun ,a ,@(rest x)))
  112.                (macro  `(defmacro ,a ,@(rest x)))
  113.                (t (error "not a closure!"))))
  114.         (error "can't repair")))))
  115.  
  116.  
  117. ; ins-propp returns T if p is a property of a
  118.  
  119. (defun ins-propp (a p)
  120.     (do     ((plist (symbol-plist a) (cddr plist)))
  121.         ((or (null plist) (eq (car plist) p))
  122.          (not (null plist)))))
  123.  
  124. ; terminate input line
  125.  
  126. (defun ins-teread (error) 
  127.        (fresh-line)
  128.        (if (not (eq (peek-char) #\Newline))
  129.        (read-line))
  130.        (if error
  131.        (format t "Try again:")
  132.        (format t "~a ~a>" (car *ins-name*) (cdr *ins-name*))))
  133.  
  134. (defmacro ins-protread () ;;Protected read -- we handle errors
  135.       '(do ((val (errset (read)) 
  136.              (progn (ins-teread t) (errset (read)))))
  137.            ((consp val) (car val))))
  138.  
  139. (defmacro ins-proteval () ;;protected eval -- we handle errors
  140.               ;; we also use evalhook so environment is global
  141.               ;;  plus a local @, which cannot be changed!
  142.     '(do* ((env (cons (list (list (cons '@ list))) nil))
  143.            (val (errset (evalhook (read) nil nil env))
  144.             (progn (ins-teread t) 
  145.                (errset (evalhook (read) nil nil env)))))
  146.           ((consp val) (car val))))
  147.  
  148.  
  149. ; Part of modified classes.lsp. Repeated here in case classes.lsp not used
  150. #+:packages (shadow 'classp)
  151. (defun classp (name)
  152.        (when (objectp name)
  153.          (eq (send name :class) class)))
  154.  
  155. ; New methods so that we can inspect and repair messages.
  156.  
  157. (send Class :answer :messages '() '(messages))
  158.  
  159. ; new methods so that we can inspect and repair instance variables
  160.  
  161. (send Class :answer :ivars '() '(ivars))
  162.  
  163. (send Class :answer :cvars '() '((map 'list #'cons cvars cvals)))
  164.  
  165. (send Class :answer :superclass '() '(superclass))
  166.  
  167. #+:packages (import '(xlisp::%struct-ref xlisp::%struct-set))
  168.  
  169. (defun ins-struct (struct name)  ; get structure element
  170.        (%struct-ref struct
  171.             (1+ (position name
  172.                   (get (type-of struct) '*struct-slots*)
  173.                   :key #'first))))
  174.  
  175. (defun ins-set-struct (struct name value)  ; set structure element
  176.        (%struct-set struct
  177.             (1+ (position name
  178.                   (get (type-of struct) '*struct-slots*)
  179.                   :key #'first))
  180.             value))
  181.  
  182. #+:packages (unintern 'xlisp::%struct-ref)
  183. #+:packages (unintern 'xlisp::%struct-set)
  184.  
  185.  
  186. (defun ins-ivar (obj name)
  187.        (funcall #'send obj
  188. #+:packages    (intern (string name) :keyword)
  189. #-:packages      (intern (strcat ":" name))
  190.         ))
  191.  
  192. (defun ins-set-ivar (obj name value)
  193.        (funcall #'send obj :set-ivar
  194. #+:packages    (intern (string name) :keyword)
  195. #-:packages     (intern (strcat ":" name))
  196.         value))
  197.  
  198. ; help function
  199. (defun ins-help (list)
  200.        (format t "~%Available commands:~2%")
  201.        (format t "e n~8tselect element n~%")
  202.        (format t "r n x~8treplaces element n with (quoted) x.~%")
  203.        (format t "X~8texit, saving all changes~%")
  204.        (format t "Q~8texit, without changes~%")
  205.        (format t "b~8tgo back one level (as before A, D or e commands)~%")
  206.        (format t "B n~8tgo back n levels.~%")
  207.        (format t (if (symbolp list)
  208.              "l~8tshow symbol"
  209.              "l~8tdisplay selection using pprint~%"))
  210.        (format t "v~8tverbosity toggle~%")
  211.        (format t ". n~8tchange maximum print length (default 10)~%")
  212.        (format t "# n~8tchange maximum print depth (default 3)~%")
  213.        (format t "! x~8tevaluates x and prints result.~%~8tThe symbol tools:@ is bound to the selection~%")
  214.        (format t "R x~8treplaces the selection with evaluated x.~%~8tThe symbol tools:@ is bound to the selection~%")
  215.        (unless (typep list '(or cons array)) (return-from ins-help list))
  216.        (format t "A~8tselect the CAR of the current selection.~%")
  217.        (format t "D~8tselect the CDR of the current selection.~%")
  218.        (format t "( n m~8tinserts parens from nth element for m elements.~%")
  219.        (format t ") n~8tremoves parens around nth element of selection~%")
  220.        (format t "[ n m~8tas in [, but makes elements into an array~%")
  221.        (format t "i n x~8tinserts (quoted) x before nth element in selection.~%")
  222.        (format t "d n~8tdeletes nth element in selection.~%")
  223.        (unless (typep list 'cons) (return-from ins-help list))
  224.        (format t "S x y~8tall occurances of (quoted) y are replaced with~%~8t(quoted) x.  EQUAL is used for the comparison.~%")
  225.        list)
  226.  
  227.  
  228. ; Display current selection
  229. (defun ins-display (list)
  230.        (fresh-line)
  231.        (cond ((typep list '(or cons array))
  232.           (let ((n 0))
  233.            (map nil #'(lambda (l)
  234.                       (format t "~3@s ~s~%" n l)
  235.                       (setq n (1+ n)))
  236.             list)))
  237.          ((typep list 'struct)
  238.           (format t "~a structure ~%" (type-of list))
  239.           (mapc #'(lambda (n)
  240.                   (format t
  241.                       "~10s~s~%"
  242.                       (car n)
  243.                       (ins-struct list (car n))))
  244.             (get (type-of list) '*struct-slots*)))
  245.          ((classp list)
  246.           (format t "Class ~s, messages:~%" (send list :pname))
  247.           (mapc #'(lambda (n) (format t " ~s" (car n)))
  248.             (send list :messages))
  249.           (terpri)
  250.           (when (send list :cvars)
  251.             (format t "~%cvars:~%")
  252.             (mapc #'(lambda (n) (format t " ~s ~s~%" (car n) (cdr n)))
  253.               (send list :cvars))))
  254.          ((objectp list)
  255.           (format t "A ~s, ivars:~%" (send (send list :class) :pname))
  256.           (mapc #'(lambda (n) (format t " ~s ~s~%" n (ins-ivar list n)))
  257.             (send (send list :class) :ivars))
  258.           (terpri))
  259.          ((symbolp list)
  260.           (format t "Symbol ~s:~%" (symbol-name list))
  261.           (when (fboundp list) (format t "Function binding~%"))
  262.           (when (boundp list)
  263.             (format t "Value binding~a: ~s~%"
  264.                 (cond ((constantp list) " (constant)")
  265.                   ((specialp list) "  (special)")
  266.                   (t ""))
  267.                 (symbol-value list)))
  268.           (when (symbol-plist list)
  269.             (format t "Properties:~%")
  270.             (do ((l (symbol-plist list) (cddr l)))
  271.             ((null l) nil)
  272.             (format t "~s ~s~%" (first l) (second l)))))
  273.          (t (pprint list)))
  274.        list)
  275.  
  276.  
  277. ; Bad command
  278. (defun ins-bad (list)
  279.        (format t "What??~%")
  280.        list)
  281.       
  282. ;; Expects number >=min and <max (if max non-nil)
  283. ;; returns valid number, or prints message and returns nil
  284. (defun ins-number (min max err &aux (n (ins-protread)))
  285.        (if (and (numberp n)
  286.         (>= n min)
  287.         (or (null max) (< n max)))
  288.        n
  289.        (if err (ins-bad nil) nil)))
  290.  
  291. ; inspect and replace list/array/structure/object/symbol elements
  292. (defun ins-list-spec (list)
  293.        (princ " element #? ")
  294.        (ins-number 0 (length list) nil))
  295.  
  296. (defun ins-struct-spec (list &aux name)
  297.        (princ " element name? ")
  298.        (when (assoc (setq name (ins-protread))
  299.             (get (type-of list) '*struct-slots*))
  300.          name))
  301.  
  302. (defun ins-class-spec (list &aux name)
  303.        (princ " message/cvar name? ")
  304.        (cond ((assoc (setq name (ins-protread))
  305.              (send list :messages))
  306.           (cons t name))
  307.          ((assoc name (send list :cvars))
  308.           (cons nil name))))
  309.        
  310. (defun ins-object-spec (list &aux name)
  311.        (princ " ivar name? ")
  312.        (when (member (setq name (ins-protread))
  313.             (send (send list :class) :ivars))
  314.          name))
  315.  
  316. (defun ins-symbol-spec (list &aux name)
  317.        (if (and (boundp list) (not (fboundp list)) (not (symbol-plist list)))
  318.        :v
  319.        (if (and (not (boundp list)) (fboundp list)
  320.             (not (symbol-plist list)))
  321.            :f
  322.            (progn
  323.         (princ " :f :v or propname?")
  324.         (if (ins-propp list (setq name (ins-protread)))
  325.             name
  326.             (case name ((:f :v) name)))))))
  327.  
  328. (defun ins-enter (list &aux val)
  329.        (cond ((typep list '(or cons array))
  330.           (if (setq val (ins-list-spec list))
  331.           (concatenate (type-of list)
  332.                    (subseq list 0 val)
  333.                    (list (ins-ins (elt list val)))
  334.                    (subseq list (1+ val)))
  335.           (ins-bad list)))
  336.          ((typep list 'struct)
  337.           (if (setq val (ins-struct-spec list))
  338.           (progn (ins-set-struct list val
  339.                      (ins-ins (ins-struct list val)))
  340.              list)
  341.           (ins-bad list)))
  342.          ((classp list)
  343.           (if (setq val (ins-class-spec list))
  344.           (if (car val)
  345.               (let ((closure (cdr (assoc (cdr val)
  346.                          (send list :messages))))
  347.                 closure2 result)
  348.                (unless (typep closure 'closure)
  349.                    (ins-bad list)
  350.                    (return-from ins-enter list))
  351.                (setq closure2 (get-lambda-expression closure))
  352.                (setq result (ins-ins closure2))
  353.                (setf (cdr (cddr closure2)) (cdddr result))
  354.                (setf (car (cddr closure2)) (caddr result))
  355.                list)
  356.               (progn (ins-set-ivar (send list :new)
  357.                        (cdr val)
  358.                        (ins-ins (ins-ivar (send list :new)
  359.                                   (cdr val))))
  360.                  list))
  361.           (ins-bad list)))
  362.          ((objectp list)
  363.           (if (setq val (ins-object-spec list))
  364.           (progn
  365.            (ins-set-ivar list val (ins-ins (ins-ivar list val)))
  366.            list)
  367.           (ins-bad list)))
  368.          ((typep list 'closure)
  369.           (let* ((x (get-lambda-expression list))
  370.              (y (ins-ins x)))
  371.             (setf (cdr (cddr x)) (cdddr y))
  372.             (setf (car (cddr x)) (caddr y))
  373.             list))
  374.          ((symbolp list)
  375.           (if (setq val (ins-symbol-spec list))
  376.           (case val
  377.             (:f
  378.              (if (and (fboundp list)
  379.                   (typep (symbol-function list) 'closure))
  380.                  (let* ((x
  381.                      (get-lambda-expression
  382.                       (symbol-function list)))
  383.                     (y (ins-ins x)))
  384.                    (setf (cdr (cddr x)) (cdddr y))
  385.                    (setf (car (cddr x)) (caddr y))
  386.                    list)
  387.                  (ins-bad list)))
  388.             (:v
  389.              (if (boundp list)
  390.                  (let* ((*ins-name* (cons "symbol" list))
  391.                     (result (ins-ins (symbol-value list))))
  392.                    (if (constantp list)
  393.                        list
  394.                        (progn (set list result) list)))
  395.                  (ins-bad list)))
  396.             (t (setf (get list val)
  397.                  (ins-ins (get list val)))
  398.                list))))))
  399.                   
  400. (defun ins-repwith (list)
  401.        (format t "~&Replace with: ")
  402.        (ins-protread))
  403.  
  404. (defun ins-replace (list &aux val)
  405.        (cond ((typep list '(or cons array))
  406.           (if (setq val (ins-list-spec list))
  407.           (concatenate (type-of list)
  408.                    (subseq list 0 val)
  409.                    (list (ins-repwith list))
  410.                    (subseq list (1+ val)))
  411.           (ins-bad list)))
  412.          ((typep list 'struct)
  413.           (if (setq val (ins-struct-spec list))
  414.           (progn (ins-set-struct list val
  415.                      (ins-repwith list))
  416.              list)
  417.           (ins-bad list)))
  418.          ((classp list)    ; gotta catch this error here
  419.           (ins-bad list))
  420.          ((objectp list)
  421.           (if (setq val (ins-object-spec list))
  422.           (progn
  423.            (ins-set-ivar list val (ins-repwith list))
  424.            list)
  425.           (ins-bad list)))
  426.          ((symbolp list)
  427.           (if (setq val (ins-symbol-spec list))
  428.           (case val
  429.             (:f
  430.              (ins-bad list))
  431.             (:v
  432.              (if (not (constantp list))
  433.                  (progn (setf (symbol-value list)
  434.                       (ins-repwith list))
  435.                     list)
  436.                  (ins-bad list)))
  437.             (t (setf (get list val)
  438.                  (ins-repwith list))
  439.                list))))))
  440.  
  441. ; main list repair interface
  442. (defun ins-ins (list) 
  443.        (ins-display list)
  444.        (prog (command n newlist)
  445.          y (ins-teread nil)
  446.          (setq command (int-char (get-key)))  ;; Works with most systems
  447.          (princ command)
  448.          (setq
  449.           newlist  ;; new list value, if any
  450.           (case
  451.            command
  452.            (#\? (ins-help list))
  453.            (#\v (if (setq *verbosity* (not *verbosity*))
  454.             (ins-display list)
  455.             list))
  456.            (#\X (setq *ins-exit* -1) list)
  457.            (#\Q (throw 'abort))
  458.            (#\b (format t "ack") (return list))
  459.            (#\B (format t "ack #? ")
  460.             (when (setq n (ins-number 1 nil t))
  461.               (setq *ins-exit* n))
  462.             list)
  463.            (#\l (if *verbosity*
  464.             (if (symbolp list)
  465.                 (ins-display list)
  466.                 (progn (terpri) (pprint list)))
  467.             (format t "~%~s~%" list))
  468.             list)
  469.            (#\! (format t " Eval:~%")
  470.             (print (ins-proteval))
  471.             list)
  472.            (#\R (format t "eplace w. evaled:~%")
  473.             (ins-proteval))
  474.            (#\# (format t " print-level? ")
  475.             (when (setq n (ins-number 1 nil t))
  476.               (format t "Was ~s\n" *print-level*)
  477.               (setq *print-level* n))
  478.             list)
  479.            (#\. (format t " print-length? ")
  480.             (when (setq n (ins-number 1 nil t))
  481.               (format t "Was ~s\n" *print-length*)
  482.               (setq *print-length* n))
  483.             list)
  484. ; cons only commands
  485.            (#\A (if (consp list)
  486.             (cons (ins-ins (car list)) (cdr list))
  487.             (ins-bad list)))
  488.            (#\D (if (consp list)
  489.             (cons (car list) (ins-ins (cdr list)))
  490.             (ins-bad list)))
  491. ; various special commands
  492.            (#\e (if (typep list '(or cons struct array object symbol closure))
  493.             (ins-enter list)
  494.             (ins-bad list)))
  495.            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
  496.         (setq n (- (char-int command) (char-int #\0)))
  497.         (if (and (typep list '(or cons array))
  498.              (< n (length list)))
  499.             (concatenate (type-of list)
  500.                  (subseq list 0 n)
  501.                  (list (ins-ins (elt list n)))
  502.                  (subseq list (1+ n)))
  503.             (ins-bad list)))
  504.            (#\r (if (typep list '(or cons struct array object symbol))
  505.             (ins-replace list)
  506.             (ins-bad list)))
  507.            (#.*RPAR* (if (and (typep list '(or cons array))
  508.                   (princ " remove nesting at #? ")
  509.                   (setq n (ins-number 0 (length list) nil))
  510.                   (typep (elt list n) '(or cons array)))
  511.              (concatenate (type-of list)
  512.                       (subseq list 0 n)
  513.                       (elt list n)
  514.                       (subseq list (1+ n)))
  515.              (ins-bad list)))
  516.            ((#.*LPAR* #\[)
  517.         (if (and (typep list '(or cons array))
  518.              (princ " insert nesting starting at # and length? ")
  519.              (setq n (ins-number 0 nil nil))
  520.              (setq n2 (ins-number 1
  521.                           (- (1+ (length list)) n)
  522.                           nil)))
  523.             (concatenate (type-of list)
  524.                  (subseq list 0 n)
  525.                  (list (coerce (subseq list n (+ n n2))
  526.                            (if (eq command *LPAR*)
  527.                            'list
  528.                            'array)))
  529.                  (subseq list (+ n n2)))
  530.             (ins-bad list)))
  531.            (#\i (if (and (typep list '(or array cons))
  532.                  (princ "nsert before # and value? ")
  533.                  (setq n (ins-number 0 (1+ (length list)) nil)))
  534.             (concatenate (type-of list)
  535.                      (subseq list 0 n)
  536.                      (list (ins-protread))
  537.                      (subseq list n))
  538.             (ins-bad list)))
  539.            (#\d (if (and (typep list '(or array cons))
  540.                  (princ "elete #? ")
  541.                  (setq n (ins-number 0 (length list) nil)))
  542.             (concatenate (type-of list)
  543.                      (subseq list 0 n)
  544.                      (subseq list (1+ n)))
  545.             (ins-bad list)))
  546.            (#\S (if (typep list 'cons)
  547.             (progn
  548.              (princ "ubstitute expr with expr\n")
  549.              (subst (ins-protread) 
  550.                 (ins-protread) 
  551.                 list
  552.                 :test #'equal))
  553.             (ins-bad list)))
  554.            (t (ins-bad list))))
  555.          (when (not (eq list newlist))        ;; show any changes
  556.            (setq list newlist)
  557.            (when (and (zerop *ins-exit*) *verbosity*)
  558.              (ins-display list)))
  559.          (when (zerop *ins-exit*) (go y))
  560.          (setq *ins-exit* (1- *ins-exit*)) ;; return a level
  561.          (return list)))
  562.