xlisponly/lsp/repair.lsp

   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 ; New methods so that we can "repair" methods.
 154 ; selectors :get-messages, :get-ivars, and :get-super changed to
 155 ; :messages, :ivars, and :superclass to be compatible with new classes.lsp.
 156
 157 (send Class :answer :messages '() '(messages))
 158
 159 (send Class :answer :set-messages '(value) '((setf messages value)))
 160
 161 ; new methods so that we can examine/change instance variables
 162
 163 (send Class :answer :ivars '() '(ivars))
 164
 165 (send Class :answer :superclass '() '(superclass))
 166
 167 (defun rep-ivar-list (obj &aux (cls (send obj :class)))
 168     (do ((ivars (send cls :ivars)
 169                 (append (send super :ivars) ivars))
 170          (super (send cls :superclass) (send super :superclass)))
 171         ((null super) ivars)
 172      ))
 173
 174 #+:packages (import '(xlisp::%struct-ref xlisp::%struct-set))
 175
 176 (defun rep-struct (struct &aux (count 0))
 177        (map 'list
 178             #'(lambda (x)
 179                       (list (first x)
 180                             (%struct-ref struct (setq count (1+ count)))
 181                             ))
 182             (get (type-of struct) '*struct-slots*)))
 183
 184 (defun rep-set-struct (nlist struct
 185                              &aux (slots (get (type-of struct)
 186                                               '*struct-slots*)))
 187        (mapc #'(lambda (x)
 188                        (when (and (consp x)
 189                                   (member (car x) slots :key #'car))
 190                              (%struct-set struct
 191                                           (1+ (position (car x)
 192                                                         slots
 193                                                         :key #'car))
 194                                           (cadr x))))
 195              nlist)
 196        struct)
 197
 198 #+:packages (unintern 'xlisp::%struct-ref)
 199 #+:packages (unintern 'xlisp::%struct-set)
 200
 201
 202 (defun rep-ivars (list obj)
 203     (mapcar #'(lambda (x)
 204                 (let ((y (errset (apply #'send
 205                                         (list obj
 206 #-:packages                                   (intern (strcat ":"
 207                                                               (string x)))
 208 #+:packages                                   (intern (string x) :keyword)
 209                                               ))
 210                                  nil)))
 211                   (if (consp y) (list x (car y)) x)))
 212             list))
 213
 214 (defun rep-set-ivars (alist obj)
 215     (mapc #'(lambda (x)
 216               (if (consp x)
 217                   (let ((y (errset (apply #'send
 218                                           (list obj
 219                                                 :set-ivar
 220                                                 (car x)
 221                                                 (cadr x)))
 222                                    nil)))
 223                     (unless (consp y)
 224                             (princ (list (car x) " not set."))
 225                             (terpri)))
 226                   (progn (princ (list x "not set.")) (terpri))))
 227           alist))
 228
 229 ; help function
 230 (defun rep-help (list)
 231        (terpri)
 232        (princ "Available commands:\n\n")
 233        (princ ":?\t\tprint list of commands\n")
 234        (princ ":RETURN\t\texit, saving all changes\n")
 235        (princ ":ABORT\t\texit, without changes\n")
 236        (princ ":BACK\t\tgo back one level (as before CAR CDR or N commands)\n")
 237        (princ ":B n\t\tgo back n levels\n")
 238        (cond ((symbolp list)
 239               (princ ":L\t\tshort description of selected symbol\n")
 240               (princ ":MAP\t\tcomplete description of selected symbols properties\n"))
 241              ((consp list)
 242               (princ ":L\t\tshow selection (using pprint)\n")
 243               (princ ":MAP\t\tpprints each element of selection\n"))
 244              (t
 245               (princ ":L\t\tshow selection (using pprint)\n")
 246               (princ ":MAP\t\tshow selection (using pprint)\n")))
 247        (format
 248         t
 249         ":PLEV n\t\tsets number of levels of printing (now ~s) NIL=infinite\n"
 250         *print-level*)
 251        (format
 252         t
 253         ":PLEN n\t\tsets length of list printing (now ~s) NIL=infinite\n"
 254         *print-length*)
 255        (princ ":EVAL x\t\tevaluates x and prints result\n")
 256        (princ "\t\tNote the symbol tools:@ is bound to the selection\n")
 257        (princ ":REPLACE x\treplaces the selection with evaluated x\n")
 258        (princ "\t\tNote the symbol tools:@ is bound to the selection\n")
 259        (when (symbolp list)
 260              (princ ":FUNCTION\tedit the function binding\n")
 261              (princ ":VALUE\t\tedit the value binding\n")
 262              (princ ":PROP pname\tedit property pname\n")
 263              (return-from rep-help nil))
 264        (unless (consp list) (return-from rep-help nil))
 265        (princ ":CAR\t\tSelect the CAR of the selection\n")
 266        (princ ":CDR\t\tSelect the CDR of the selection\n")
 267        (princ "n\t\tSelect the nth element in the selection (0 based)\n")
 268        (princ ":SUBST x y\tall EQUAL occurances of y are replaced with x\n")
 269        (princ ":RAISE n\tremoves parenthesis surrounding nth element of the selection\n")
 270        (princ ":LOWER n m\tinserts parenthesis starting with the nth element,\n")
 271        (princ "\t\tfor m elements of the selection\n")
 272        (princ ":ARRAY n m\tas in LOWER, but makes elements into an array\n")
 273        (princ ":I n x\t\tinserts (quoted) x before nth element in selection\n")
 274        (princ ":R n x\t\treplaces nth element in selection with (quoted) x\n")
 275        (princ ":D n\t\tdeletes nth element in selection\n"))
 276
 277
 278 ; rep-rep repairs its argument.  It looks at the argument type to decide
 279 ;  how to do the repair.
 280 ;  ARRAY  -- repair as list
 281 ;  OBJECT -- if class, repair MESSAGE ivar, else repair list of ivars
 282 ;  CLOSURE -- allows repairing of closure body by destructive modification
 283 ;             upon return
 284 ;  OTHER  -- repair as is.
 285
 286 (defun rep-rep (list)
 287         (cond ((arrayp list)
 288                (format t "Editing array~%")
 289                (coerce (rep-rep2 (coerce list 'cons)) 'array))
 290               ((classp list)
 291                (format t "Editing Methods~%")
 292                (send list :set-messages
 293                           (rep-rep2 (send list :messages)))
 294                list) ; return the object
 295               ((objectp list)
 296                (format t "Editing Instance Vars~%")
 297                (rep-set-ivars (rep-rep2
 298                                (rep-ivars
 299                                 (rep-ivar-list list) list)) list)
 300                list) ; return the object
 301               ((typep list 'struct)
 302                (format t "Editing structure~%")
 303                (rep-set-struct (rep-rep2 (rep-struct list)) list))
 304               ((typep list 'closure)
 305                (format t "Editing closure~%")
 306                (let*  ((orig (get-lambda-expression list))
 307                        (new (rep-rep2 orig)))
 308                       (when (not (equal (second orig) (second new)))
 309                             (princ "Argument list unchanged")
 310                             (terpri))
 311                       (rplaca (cddr orig) (caddr new))
 312                       (rplacd (cddr orig) (cdddr new))
 313                       list)) ; return closure
 314               (t (rep-rep2 list))))
 315
 316
 317 ; printing routines
 318
 319 ; print a property list
 320 (defun rep-print-prop (plist verbosity)
 321         (when plist
 322               (format t "Property: ~s" (first plist))
 323               (when verbosity
 324                     (format t "   ~s" (second plist)))
 325               (terpri)
 326               (rep-print-prop (cddr plist) verbosity)))
 327
 328 ; print a symbols function binding, value, and property list
 329 (defun rep-print-symbol (symbol verbosity)
 330        (format t "Print name: ~s~%" symbol)
 331        (unless (null symbol)
 332         (when (fboundp symbol)
 333               (if verbosity
 334                   (if (typep (symbol-function symbol) 'closure)
 335                       (progn
 336                        (format t "Function:~%")
 337                        (pprint (get-lambda-expression
 338                                 (symbol-function symbol))))
 339                       (format t "Function: ~s~%" (symbol-function symbol)))
 340                   (format t "Function binding~%")))
 341         (when (boundp symbol)
 342               (if (constantp symbol)
 343                   (princ "Constant V")
 344                   (princ "V"))
 345               (if verbosity
 346                   (if (< (flatsize (symbol-value symbol)) 60)
 347                       (format t "alue: ~s~%" (symbol-value symbol))
 348                       (progn
 349                        (format t "alue:~%")
 350                        (pprint (symbol-value symbol))))
 351                   (format t "alue binding~%")))
 352         (when (symbol-plist symbol)
 353               (rep-print-prop (symbol-plist symbol) verbosity)))
 354 )
 355
 356 ; print a list, using mapcar
 357 (defun rep-print-map (list &aux (x 0))
 358        (mapc #'(lambda (y)
 359                        (format t "(~s) " (prog1 x (setf x (1+ x)) ))
 360                        (pprint y))
 361              list))
 362
 363 ; main list repair interface
 364 (defun rep-rep2 (list)
 365     (prog (command n)
 366         y (rep-teread nil)
 367           (setq command (rep-protread))
 368           ;; When packages installed, we will convert symbol names
 369           ;; entered as commands into keywords
 370           ;; This *does* clutter the current package symbol list
 371           #+:packages(when (and (symbolp command)
 372                                 (not (eq (symbol-package command)
 373                                          (find-package :keyword))))
 374                            (setq command
 375                                  (intern (string command)
 376                                          :keyword)))
 377           (cond ((eq command :?) (rep-help list))
 378                 ((eq command :return) (setq *rep-exit* -1))
 379                 ((eq command :abort) (throw 'abort))
 380                 ((eq command :back) (return list))
 381                 ((and (eq command :b)
 382                       (integerp (setq n (rep-protread)))
 383                       (> n 0))
 384                  (setq *rep-exit* n))
 385                 ((eq command :l)
 386                  (if (symbolp list) (rep-print-symbol list nil) (print list)))
 387                 ((eq command :map)
 388                  (cond ((symbolp list) (rep-print-symbol list t))
 389                        ((consp list) (rep-print-map list))
 390                        (t (pprint list))))
 391                 ((eq command :eval) (print (rep-proteval)))
 392                 ((and (eq command :plev)
 393                       (or (and (integerp (setq n (rep-protread)))
 394                                (>= n 1))
 395                           (null n)))
 396                  (format t "Was ~s\n" *print-level*)
 397                  (setq *print-level* n))
 398                 ((and (eq command :plen)
 399                       (or (and (integerp (setq n (rep-protread)))
 400                                (>= n 1))
 401                           (null n)))
 402                  (format t "Was ~s\n" *print-length*)
 403                  (setq *print-length* n))
 404                 ((eq command :replace)
 405                  (setq n (rep-proteval))
 406                  (if (eq (type-of n) (type-of list))
 407                      (setq list n)
 408                      (return (rep-rep n))))
 409 ; symbol only commands
 410                 ((and (symbolp list)
 411                       (eq command :function)
 412                       (fboundp list)
 413                       (typep (symbol-function list) 'closure))
 414                  (let ((*rep-name* (cons "function" list)))
 415                         (setf (symbol-function list)
 416                               (rep-rep (symbol-function list)))))
 417                 ((and (symbolp list)
 418                       (eq command :value)
 419                       (boundp list)
 420                       (null (constantp list)))
 421                  (let ((*rep-name* (cons "value" list)))
 422                         (setf (symbol-value list)
 423                               (rep-rep (symbol-value list)))))
 424                 ((and (symbolp list)
 425                       (eq command :prop)
 426                       (symbolp (setq n (rep-protread)))
 427                       (rep-propp list n))
 428                  (let ((*rep-name* (cons n list)))
 429                         (setf (get list n) (rep-rep (get list n)))))
 430 ; cons only commands
 431                 ((and (consp list)
 432                       (eq command :car))
 433                  (setq list (cons (rep-rep (car list)) (cdr list))))
 434                 ((and (consp list)
 435                       (eq command :cdr))
 436                  (setq list (cons (car list) (rep-rep (cdr list)))))
 437                 ((and (consp list)
 438                       (integerp command)
 439                       (> command -1)
 440                       (< command (length list)))
 441                  (setq list (append
 442                              (subseq list 0 command)
 443                              (list (rep-rep (nth command list)))
 444                              (nthcdr (1+ command) list))))
 445                 ((and (consp list)
 446                       (eq command :raise)
 447                       (integerp (setq n (rep-protread)))
 448                       (> n -1)
 449                       (< n (length list))
 450                       (or (consp (nth n list)) (arrayp (nth n list))))
 451                  (setq list (append
 452                              (subseq list 0 n)
 453                              (let ((x (nth  n list)))
 454                                   (if (arrayp x)
 455                                       (coerce x 'cons)
 456                                       x))
 457                              (nthcdr (1+ n) list))))
 458                 ((and (consp list)
 459                       (eq command :lower)
 460                       (integerp (setq n (rep-protread)))
 461                       (> n -1)
 462                       (integerp (setq n2 (rep-protread)))
 463                       (> n2 0)
 464                       (>= (length list) (+ n n2)))
 465                  (setq list (append
 466                              (subseq list 0 n)
 467                              (list (subseq list n (+ n n2)))
 468                              (nthcdr (+ n n2) list))))
 469                 ((and (consp list)
 470                       (eq command :array)
 471                       (integerp (setq n (rep-protread)))
 472                       (> n -1)
 473                       (integerp (setq n2 (rep-protread)))
 474                       (> n2 0)
 475                       (>= (length list) (+ n n2)))
 476                  (setq list (append
 477                              (subseq list 0 n)
 478                              (list (coerce (subseq list n (+ n n2)) 'array))
 479                              (nthcdr (+ n n2) list))))
 480                 ((and (consp list)
 481                       (eq command :i)
 482                       (integerp (setq n (rep-protread)))
 483                       (> n -1))
 484                  (setq list (append
 485                              (subseq list 0 n)
 486                              (list (rep-protread))
 487                              (nthcdr n list))))
 488                 ((and (consp list)
 489                       (eq command :r)
 490                       (integerp (setq n (rep-protread)))
 491                       (> n -1))
 492                  (setq list (append
 493                              (subseq list 0 n)
 494                              (list (rep-protread))
 495                              (nthcdr (1+ n) list))))
 496                 ((and (consp list)
 497                       (eq command :d)
 498                       (integerp (setq n (rep-protread)))
 499                       (> n -1))
 500                  (setq list (append
 501                              (subseq list 0 n)
 502                              (nthcdr (1+ n) list))))
 503                 ((and (consp list)
 504                       (eq command :subst))
 505                  (setq list (subst (rep-protread)
 506                                    (rep-protread)
 507                                    list
 508                                    :test #'equal)))
 509                 (t (princ "What??\n") (go y)))
 510
 511           (when (zerop *rep-exit*) (go y))
 512           (setq *rep-exit* (1- *rep-exit*))
 513           (return list)))
 514