archive/src/buffer.lisp

   1 ;;;;;; -*- Mode: LISP; Package: zwei; Base: 8; Syntax: Zetalisp -*-;;;;;;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;  (c) Copyright 1976, 1983 Massachusetts Institute of Technology      ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11
  12 (import '(sloop::SLOOP lisp::multiple-value-setq) 'zwei)
  13
  14
  15 ;;note in zwei *standard-output* for the moment *standard-output* replace later.
  16 #+ti
  17 (defflavor macsyma-mode nil nil )
  18
  19 ;;the (KM) is so that the region will be marked.
  20 (defcom com-forward-macsyma-expression "Forward over one expression"
  21         (KM -R)
  22  (move-bp (point)  (forward-macsyma-expression (point) 1))
  23   dis-bps)
  24
  25 ;;until get zwei into cl.
  26
  27 (defmacro lisp-eval (form &optional nohook)
  28    nohook
  29   `(#+ti cli:eval #-ti eval ,form))
  30
  31 (defun get-maxima-package ()
  32   #+cl (#+symbolics cl:find-package #-symbolics find-package 'maxima)
  33   #-cl (pkg-find-package 'macsyma))
  34
  35 (defcom com-backward-macsyma-expression "backward over one expression"
  36         (KM -R)
  37   (let  ((point (point)))
  38     (move-bp point (forward-macsyma-expression point -1))
  39     dis-bps))
  40
  41 (defun forward-macsyma-expression
  42        (bp &optional (times 1)
  43         fixup-p (level 0) stop-bp (move-over-singlequotes-p t) n-up-p (signal-error t)
  44         &aux bp1 new-line ;(region? (window-mark-p *window*))
  45         )
  46   (setq bp (copy-bp bp))
  47   (sloop for i from 0 below (abs times)
  48         do (cond ((and (> times 0) (member (bp-char bp) *maxima-form-delimiters*))
  49                   (setq bp (forward-char bp times t))))
  50             (cond ((zerop times) (copy-bp bp))
  51                   (t
  52                    (setq bp1 (macsyma-skip-comments bp (< times 0) stop-bp))
  53                    (setq new-line (forward-sexp
  54                                     bp1 (signum times)
  55                                     fixup-p level stop-bp
  56                                     move-over-singlequotes-p n-up-p))
  57                    (cond (new-line
  58                           (setq bp1 (setq bp1 new-line)))
  59                          (t
  60                           (and signal-error(barf)) (return bp1)))))
  61             finally   (return bp1))
  62    )
  63
  64
  65 (defun macsyma-skip-comments (bp &optional reversep stop-bp &aux  (found-comment t))
  66   (sloop while found-comment
  67         do (multiple-value-setq
  68              (bp found-comment)
  69              (macsyma-skip-comment bp reversep stop-bp)))
  70   bp)
  71
  72 ;;a terrible kludge, which won't work if strings are half in comments etc.
  73 (defun in-macsyma-string (bp)
  74        (MULTIPLE-VALUE-BIND (IN-STRING SLASHIFIED IN-COMMENT)
  75            (LISP-BP-SYNTACTIC-CONTEXT (FORWARD-CHAR BP -1))
  76           in-string))
  77
  78
  79 (defmacro show (&rest l)
  80   (sloop for x in l
  81         collecting
  82         `(format *typein-window* "~%Value of ~A is ~A." ',x ,x)
  83          into bod
  84         finally (return `(prog ((default-cons-area working-storage-area))
  85                                 ,@ bod))))
  86 #+ti
  87 (defmacro with-common-lisp (&body body)
  88   `(let ((si:*READTABLE*     si:COMMON-LISP-READTABLE)
  89         (si:*READER-SYMBOL-SUBSTITUTIONS*    si:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)
  90         (si:*lisp-mode* :common-lisp))
  91     ,@ body))
  92
  93 #-ti  ;;what should be done here??
  94 (defmacro with-common-lisp (&body body)
  95   `(progn ,@ body))
  96
  97 ;for release 5 we need to use setf to assign the symbol-macro *default-major-mode*
  98
  99 (defmacro with-marked-region (&body body)
 100   `(let ((bp1 ())
 101         (bp2 ()))
 102     (cond ((window-mark-p *window*)
 103             (setq bp1 (mark) bp2 (point)))
 104           ((mark-current-macsyma-form)
 105            (setq bp1 (copy-bp (mark))  bp2 (copy-bp (point))))
 106 ;                  (setq bp1 (mark)  bp2  (point)))
 107           (t (barf "~&~a" "No region")))
 108     ,@ body))
 109
 110
 111 (defcom com-macsyma-evaluate-region
 112   "Call the Macsyma evaluator on a region in the buffer. With a
 113   numeric arg different from 2 let the region be from the beginning of the current
 114   line to the next $ or ;, otherwise a region that has been marked,
 115   or if no region then between the last and next $ or ;.  Thus without a numeric arg
 116   of 2 one one need not have a $ after the previous form, but parsing will begin
 117   at the beginning of the current line and continue to the  next $."
 118
 119              ()
 120   (let ((bp1 ())
 121         (bp2 ()))
 122     (cond ((not (eql *numeric-arg* 1))
 123            (setq bp1 (copy-bp (point)))
 124            (setf (bp-index bp1) 0)
 125            (setq bp2 (zwei::search-set bp1 *maxima-form-delimiters*
 126                                                 nil))
 127            (zwei::move-bp (point) bp2))
 128           ((window-mark-p *window*)
 129            (setq bp1 (mark) bp2 (point)))
 130           ((mark-current-macsyma-form)
 131            (setq bp1 (mark) bp2 (point)))
 132           (t (barf "~&~a" "No region")))
 133       (macsyma-evaluate-for-editor bp1 bp2 "Region"))
 134   dis-text)
 135
 136 (defcom com-macsyma-compile-region
 137              "Call the Macsyma evaluator on a region in the buffer and~
 138               then translate and compile the result."
 139              ()
 140       (with-marked-region (macsyma-compile-for-editor bp1 bp2  "Region"))
 141   dis-all)
 142
 143 (defcom com-macsyma-translate-region
 144              "Call the Macsyma evaluator on a region in the buffer and  and translate the result. ~
 145              with a numeric argument bigger than 1 it displays the translated result
 146              and less than 1 it grinds it into the buffer"
 147              ()
 148  (with-marked-region (macsyma-translate-for-editor bp1 bp2 "Region"))
 149   dis-all)
 150
 151 (defcom com-macsyma-evaluate-buffer
 152              "Call the Macsyma evaluator on the entire buffer"
 153             ()
 154   (macsyma-evaluate-for-editor (interval-first-bp *interval*)
 155                                (interval-last-bp *interval*)
 156                                "Buffer")
 157   dis-none)
 158
 159 (defcom com-macsyma-compile-buffer
 160              "Call the Macsyma evaluator on the entire buffer"
 161             ()
 162   (macsyma-compile-for-editor (interval-first-bp *interval*)
 163                                (interval-last-bp *interval*)
 164                                "Buffer")
 165   dis-none)
 166
 167 (defcom com-macsyma-translate-buffer
 168              "Call the Macsyma evaluator on the entire buffer"
 169             ()
 170   (macsyma-translate-for-editor (interval-first-bp *interval*)
 171                                (interval-last-bp *interval*)
 172                                "Buffer")
 173   dis-none)
 174
 175
 176
 177
 178 (defmacro move-on-read-error (str &body body)
 179   #+ti
 180      (condition-case (condit)
 181         `(progn  ,@ body)
 182        (fs:parse-error (beep)
 183                        (format *typein-window* (send condit :format-string))))
 184      #+symbolics
 185      `(move-point-on-read-error #+genera (,str) ,@ body))
 186
 187
 188 #+ti
 189 (defmacro with-possible-read-error ( body what-am-i-evaluating)
 190   `(let (read-error)
 191      (funcall 'prompt-line "~&Evaluating ~A" ,what-am-i-evaluating)
 192      (condition-case (condit)
 193          ,body
 194        (fs:parse-error (beep) (setq read-error t)
 195 ;       (point-pdl-push (send editor-stream :read-bp) *window*)
 196 ;                      (move-bp bp2 (setq li (send editor-stream :read-bp)))
 197        (format *typein-window* (send condit :format-string))))
 198      (cond ((null read-error)
 199             (funcall 'typein-line "~&~A Evaluated" ,what-am-i-evaluating)))))
 200
 201 #+ti
 202 (defun macsyma-evaluate-for-editor (bp2 bp1 what-am-i-evaluating)
 203     (let ((package (get-maxima-package))
 204           (editor-stream
 205             (INTERVAL-STREAM bp2 bp1 ()))
 206           (eof (list nil)))
 207        (with-possible-read-error
 208       (sloop for expr = (cl-macsyma::mread editor-stream eof)
 209             while (not (equal expr    eof))
 210             do      (cl-macsyma::meval* (caddr expr))) what-am-i-evaluating)
 211     ))
 212 #-ti
 213 (defun macsyma-evaluate-for-editor (bp2 bp1 what-am-i-evaluating)
 214
 215     (funcall 'prompt-line "~&Evaluating ~A" what-am-i-evaluating)
 216     (let ((package(get-maxima-package)
 217                                    )
 218           (editor-stream
 219             (INTERVAL-STREAM bp2 bp1 ()))
 220           (eof (list nil)))
 221       (or (eql  package (cl:find-package 'cl-maxima))
 222           (error "Set package to maxima package"))
 223        (move-on-read-error editor-stream
 224       (sloop for expr = (cl-macsyma::mread editor-stream eof)
 225             while (not (equal expr eof))
 226             do      (cl-macsyma::meval* (caddr expr))))
 227     (funcall 'typein-line "~&~A Evaluated" what-am-i-evaluating)
 228     ))
 229
 230 (defcom com-macsyma-display-on-typeout
 231         "Displays current expression or region in scroll down  window (standard-output)"
 232         ()
 233   (with-marked-region
 234     (let ((stream (interval-stream bp2 bp1 nil))
 235           (eof (list nil)))
 236       (sloop for expr = (cl-macsyma::mread stream eof)
 237             while (not (equal expr    eof))
 238             do (cl-macsyma::displa (setq cl-macsyma::$% (cl-macsyma::meval* (third expr))))
 239             finally (com-down-real-line))))
 240   dis-none)
 241
 242
 243 (defmacro macsyma-apply-into-buffer (bp2 bp1 what-am-i-evaluating expr &rest body)
 244   "The expr will run thru the cl-macsyma::mread of things in the region bp2
 245    to bp1.  Usually you want the (caddr expr) to get the actual macsyma
 246    expression minus the cl-macsyma::displa output etc."
 247   `(let ((window (car (send current-process :run-reasons))))
 248      (setq cl-macsyma::linel (- (send window :size-in-characters) 3))
 249
 250      (funcall #'prompt-line "~&Evaluating ~A" ,what-am-i-evaluating)
 251      (let ((package (get-maxima-package))
 252            (stream
 253              (interval-stream ,bp2 ,bp1 ()))
 254            (eof (list nil)))
 255        (move-on-read-error
 256          stream
 257          (sloop for ,expr = (cl-macsyma::mread stream eof)
 258                 while (not (eq ,expr eof))
 259                 do
 260                 (with-editor-stream (standard-output :window *window*
 261                                                      :start :point)
 262                                     ,@ body)
 263                 (funcall #'typein-line "~&~A Evaluated" ,what-am-i-evaluating))))))
 264
 265 (defcom com-macsyma-display-into-buffer
 266         "Displays current expression or region into buffer"
 267         ()
 268   (let ((cl-maxima::$linedisp nil)(cl-maxima::$cursordisp nil)(cl-maxima::^w t)
 269         (cl-maxima::^r t  )(cl-maxima::$display2d t) to-display
 270         (package (get-maxima-package)))
 271     (with-marked-region
 272       (let ((stream (interval-stream bp2 bp1 nil)))
 273         (sloop with eof = (list nil)
 274               for expr = (cl-maxima::mread stream eof)
 275               until (equal expr eof)
 276               collecting (third expr) into for-display
 277               finally (setq to-display for-display))))
 278     (with-editor-stream
 279       (standard-output :window *window*
 280                        :start :point)
 281       (sloop for v in to-display
 282             do       (format t "~%")
 283                      (cl-maxima::displa (cl-maxima::meval* v))
 284                      (format t "$"))))
 285   dis-all)
 286
 287
 288 (defun zdel (&optional n)
 289  (let ((*numeric-arg* n))
 290   (com-delete-forward)))
 291
 292 (defun zfor (&optional ( n 1))
 293    (let ((*numeric-arg* n))
 294   (com-forward)))
 295
 296 (defun zbac (&optional (n 1))
 297    (let ((*numeric-arg* n))
 298   (com-backward)))
 299
 300 (defun zrub (&optional ( n 1))
 301    (let ((*numeric-arg* n))
 302   (com-tab-hacking-rubout)))
 303
 304 (defun zsearch (sstring &optional (reverse nil) (how-many 1) &aux point)
 305   "searches forward and moves to end of sstring (or back if reverse is t )"
 306   (sloop for i below how-many
 307         do
 308   (setq point (search (point) sstring reverse  ))
 309   (move-bp (point) point)))
 310
 311 ;(defun kill-return ()
 312 ;  (zsearch (string 215) nil)
 313 ;  (zrub 1))
 314
 315 (defun macsyma-evaluate-with-arrow (bp2 bp1 what-am-i-evaluating &aux me label (dollars 1))
 316   (macsyma-apply-into-buffer
 317     bp2 bp1 what-am-i-evaluating expres
 318     (setq me (caddr expres))
 319     (cond ((symbolp me)
 320            (format standard-output ":")
 321            (cond ((member me cl-macsyma::$labels)
 322                   (cond ((string-search "c" (string me))
 323                          (incf dollars)
 324                          (cl-maxima::i-$grind me )
 325
 326                          (incf cl-maxima::$edlinenum)
 327                          (setq label   (cl-maxima::$new_concat '$ed cl-maxima::$edlinenum))
 328                          (format standard-output "  ==>~80T $")
 329                          (format standard-output "~%ED~A:" cl-maxima::$edlinenum)))))
 330            (cl-maxima::i-$grind (cl-maxima::meval* me) ))
 331           (t (format standard-output "  ==> ~80T  $")
 332              (incf  cl-maxima::$edlinenum)
 333              (setq label   (cl-maxima::$new_concat '$ed cl-maxima::$edlinenum))
 334              (format standard-output "~%ED~A:" cl-maxima::$edlinenum)
 335              (cl-maxima::i-$grind (cl-maxima::meval* me)) nil))
 336     (cond (label (set label me) (incf dollars)))
 337     (zrub 1)
 338                                                 ;(zsearch (string 215) )
 339                                                 ;(zrub 1)
 340     (zsearch "$" nil dollars)
 341     (format t "~%~% ")))
 342
 343
 344 ;(defvar *my-stream* (make-array 200 :type 'art-string :fill-pointer 0))
 345
 346 (defcom com-macsyma-parse-string-into-buffer
 347         "parses string and inserts into buffer"
 348   ()
 349
 350     (let ( expr (stream (interval-stream (mark) (point) ())))
 351         (move-on-read-error
 352           stream
 353           (setq expr (caddr (cl-macsyma::mread stream)))
 354           (with-editor-stream (standard-output :window *window*
 355                                                :start :point)
 356                               (format t "`~A" expr))))
 357   dis-text)
 358
 359
 360
 361 (defcom com-macsyma-parse-region-into-buffer
 362         "parses region string and inserts into buffer"
 363   ()
 364     (let ( expr (stream (interval-stream (mark) (point) ())))
 365   (move-on-read-error
 366     stream
 367     (setf (fill-pointer *my-stream*) 0)
 368     (with-output-to-string  (st *my-stream*  )
 369
 370                             (stream-copy-until-eof stream  st))
 371     (with-editor-stream (standard-output :window *window*
 372                                          :start :mark)
 373                         (setq expr (cl-maxima::parse-string *my-stream*))
 374                         (format t "`~A ; " expr ))))
 375
 376           dis-text)
 377
 378
 379 (defcom com-evaluate-with-arrow
 380         "Evaluates into buffer with arrow"
 381   ()
 382   (with-marked-region (macsyma-evaluate-with-arrow bp1 bp2 "region"))
 383                               dis-all)
 384
 385
 386 (defun kill-region (bp1 bp2 ignore)
 387   (kill-interval bp1 bp2 t t t))
 388
 389 (defcom com-macsyma-grind-expression
 390              "Grinds current expression or region into buffer"
 391          ()
 392         (with-marked-region (macsyma-evaluate-into-buffer1 bp1 bp2 "region"))
 393         (with-marked-region (kill-region bp1 bp2 'ignore))
 394         dis-all)
 395
 396 ;;;the following work but have abbreviations elsewhere
 397
 398 (defcom com-macsyma-evaluate-into-buffer
 399   "Evaluates the current Macsyma  expression or region into the end of buffer
 400  With a numeric arg > 1 it puts any output during  the evaluation into the buffer as well"
 401   ()
 402   (let ((bp1 ()) cl-macsyma::$display2d
 403         (bp2 ()))
 404     (cond  ((window-mark-p *window*)
 405            (setq bp1 (mark) bp2 (point)))
 406           ((mark-current-macsyma-form)
 407            (setq bp1 (mark) bp2 (point)))
 408           (t (barf "~&~a" "No region")))
 409       (macsyma-evaluate-into-buffer1 bp1 bp2 "Region"))
 410   dis-text)
 411
 412 (defun macsyma-evaluate-into-buffer1 (bp2 bp1 what-am-i-evaluating &aux val)
 413     (funcall #'prompt-line "~&Evaluating ~A" what-am-i-evaluating)
 414     (let ((package (get-maxima-package))
 415           (stream
 416             (INTERVAL-STREAM bp2 bp1 ()))
 417           (eof (list nil)))
 418   (move-on-read-error
 419     stream
 420       (sloop for expr = (cl-macsyma::mread stream eof)
 421             while (not (equal expr    eof))
 422             do
 423             (with-editor-stream (str :window *window*
 424                                      :start :point)
 425               (format str "~%")
 426               (cond ((and (boundp '*numeric-arg*)
 427                           (> *numeric-arg* 1))
 428                      (let ((standard-output str))
 429                        (setq val (cl-macsyma::meval* (caddr expr)))))
 430                     (t  (setq val (cl-macsyma::meval* (caddr expr)))))
 431               (cl-macsyma::mgrind val                            str )
 432               (format str "$")
 433               )))
 434     (funcall #'typein-line "~&~A Evaluated" what-am-i-evaluating)))
 435
 436 (defvar *grind-definition-only* t)
 437
 438 (defmacro bind-and-translate-form  (to-transl)
 439   `(let (( cl-maxima::*translation-msgs-files* *typein-window*))
 440      (cl-maxima::bind-transl-state
 441        (setq cl-maxima::*in-translate-file* t)
 442        (cond(function-to-translate (cl-maxima::tr-mdefine-toplevel ,to-transl))
 443             (t (cl-maxima::translate-macexpr-toplevel ,to-transl))))))
 444
 445
 446 (defun macsyma-translate-for-editor (bp2 bp1 what-am-i-evaluating
 447                                      &aux transl to-transl function-to-translate)
 448   (with-common-lisp
 449     (funcall #'prompt-line "~&Evaluating ~A" what-am-i-evaluating)
 450     (let ((package (get-maxima-package))
 451           (stream (INTERVAL-STREAM bp2 bp1 ()))
 452           (eof (list nil)))
 453     (move-on-read-error
 454       stream
 455       (sloop for expr = (cl-maxima::mread stream eof)
 456             while (not (equal expr    eof))
 457                do
 458         (setq function-to-translate nil)
 459                                                 ;(cl-maxima::meval* (caddr expr))
 460                                                 ;     (show (third expr))
 461         (setq to-transl (third expr))
 462         (cond ((member (caar to-transl) '(cl-maxima::mdefine cl-maxima::mdefmacro))
 463                (setq function-to-translate (caar (second to-transl)))))
 464         (and function-to-translate
 465              (funcall #'prompt-line "~&translating ~A" function-to-translate))
 466         (setq transl (bind-and-translate-form to-transl))
 467
 468         (lisp-eval transl)
 469         (cond ((and *grind-definition-only*
 470                function-to-translate)
 471                (setq transl (fifth transl))))
 472         (cond ((> *numeric-arg* 1)
 473                (pprint transl))
 474               ((< *numeric-arg* 1)
 475                (terpri stream)
 476                (pprint transl nil stream)
 477                (princ '$ stream)
 478               (return nil)))
 479       (funcall #'prompt-line "~&Translated ~A" function-to-translate))))))
 480
 481 (defun macsyma-compile-for-editor (bp2 bp1 what-am-i-evaluating
 482                                    &aux function-to-translate to-transl transl
 483                                    rule-to-translate)
 484     (funcall #'prompt-line "~&Evaluating ~A" what-am-i-evaluating)
 485     (let ((package(get-maxima-package))
 486 ;        (package  (send *interval* :get ':package);(get-maxima-package)
 487 ;                   )
 488           (stream (INTERVAL-STREAM bp2 bp1 ()))
 489           (eof (list nil)))
 490   (move-on-read-error
 491     stream
 492       (sloop for expr = (cl-macsyma::mread stream eof)
 493             while (not (equal expr    eof))
 494             do (setq function-to-translate nil)
 495                (setq to-transl (third expr))
 496                (cond ((member (caar to-transl) '(cl-maxima::mdefine  ))
 497                       (setq function-to-translate (caar (second to-transl)) ))
 498                      ((member (caar to-transl) '(cl-maxima::$defrule  ))
 499                       (setq rule-to-translate  (second to-transl)) ))
 500                (setq transl (bind-and-translate-form to-transl))
 501                (lisp-eval transl)
 502                (cond (function-to-translate
 503                       (funcall #'prompt-line "~&compiling ~A"  function-to-translate)
 504                       (compiler:compile function-to-translate)
 505                       (and function-to-translate
 506                            (prompt-line "~&Compiled ~A" function-to-translate))))
 507                (cond (rule-to-translate (compiler:compile rule-to-translate)))
 508 ;              (show cl-maxima::forms-to-compile-queue)
 509                (compile-forms cl-maxima::forms-to-compile-queue)
 510                (setq cl-maxima::forms-to-compile-queue nil)))))
 511
 512 (defun compile-forms (list)
 513   (sloop for v in list
 514         when (and v (listp v))
 515          do
 516            (#+symbolics
 517             cl:case #-symbolics case
 518             (car v)
 519              (defun (compile (second v) v))
 520              (deprop (eval v))
 521              (defmacro (compile (second v) v))
 522              (macro  (compile (second v) v))
 523              (t (lisp-eval v)))))
 524
 525 (defcom com-macsyma-translate-region-to-buffer
 526              "Call the Macsyma evaluator on a region in the buffer and  and translate the result and grind."
 527              ()
 528   (let ((bp1 ())
 529         (bp2 ()))
 530     (cond ((window-mark-p *window*)
 531            (setq bp1 (mark) bp2 (point)))
 532           ((mark-current-macsyma-form)
 533            (setq bp1 (mark) bp2 (point)))
 534           (t (barf "~&~a" "No region")))
 535       (macsyma-translate-to-buffer bp1 bp2 "Region"))
 536   dis-all)
 537
 538 (defun macsyma-translate-to-buffer (bp2 bp1 what-am-i-evaluating
 539                                             &aux function-to-translate)
 540     (funcall #'prompt-line "~&Evaluating ~A" what-am-i-evaluating)
 541     (let ((package (get-maxima-package))
 542           (stream (INTERVAL-STREAM bp2 bp1 ()))
 543           (eof (list nil))
 544           (temp *default-major-mode*))
 545   (move-on-read-error stream
 546
 547       (setf *default-major-mode* :lisp)
 548       (with-editor-stream (standard-output ':buffer-name  "Translated")
 549
 550         (sloop for expr = (cl-macsyma::mread stream eof)
 551               while (not (equal expr    eof))
 552               do (cl-macsyma::meval* (caddr expr)) (SETQ FUNCTION-TO-TRANSLATE
 553                                              (FIRST (FIRST (SECOND (THIRD EXPR)))))
 554               (funcall #'prompt-line "~&translating ~A" function-to-translate)
 555               (CL-MACSYMA::MEVAL* `(($TRANSLATE) ,FUNCTION-TO-TRANSLATE))
 556               (pprint `(defprop ,function-to-translate ,t translated))
 557               (pprint `(add2lnc ,`(,function-to-translate ) $props))
 558               (let ((fdef (symbol-function function-to-translate)))
 559                 (pprint
 560                 (append `(defmtrfun ,`(,function-to-translate
 561                                             $any mdefine nil nil))
 562                         (cddr fdef))))
 563               (format t "~&")))
 564             (funcall #'prompt-line
 565                      "&~Translated ~A in buffer: Translated" function-to-translate)
 566     (setf *default-major-mode* temp))))
 567
 568 (defun skip-back-over-whitespace ()
 569   (sloop for char = (bp-char (point))
 570         until (not (member char *whitespace-chars*))
 571         do  (dbp (point))))
 572
 573 ;;in release 5 at the beginning we needed the mode-settable-p property
 574 ;;but now in release 6 since some of these are symbol macros that is not necessary
 575
 576 (eval-when (load eval compile)
 577   (sloop for u in
 578         '(*LIST-SYNTAX-TABLE*
 579            *MODE-LIST-SYNTAX-TABLE*
 580            *atom-word-syntax-table*
 581            *SPACE-INDENT-FLAG*   ;;these two are symbol-macros
 582            *PARAGRAPH-DELIMITER-LIST*
 583            *COMMENT-COLUMN*
 584            *COMMENT-START*
 585            *COMMENT-BEGIN*
 586            *COMMENT-END*)
 587         when (null (get u 'si:symbol-macro))
 588         do  (putprop u t 'mode-settable-p)
 589         else do (remprop u 'mode-settable-p)))
 590
 591 (defun reset-comtab-for-lisp ()
 592   "In case the comtab gets mucked by macsyma buffer eval this function
 593    to get going again in lisp buffer"
 594        (set-comtab *comtab* (list #\c-sh-e 'com-evaluate-region
 595                           #\c-sh-c 'com-compile-region)))
 596
 597
 598
 599 ;si:
 600 ;(define-ie-command rh-macsyma-arglist (#\control-meta-a)
 601 ;   (cl-macsyma::macsyma-print-arglist tv:rubout-handler-buffer))
 602
 603 ;;these need work for release 6 since the interactive-stream flavor is now
 604 ;;used.
 605
 606 ;(DEFSTRUCT (INPUT-EDITOR-BUFFER (:TYPE :ARRAY-LEADER)
 607 ;                               (:MAKE-ARRAY (:LENGTH 512. :TYPE ART-FAT-STRING))
 608 ;                               (:DEFAULT-POINTER INPUT-EDITOR-BUFFER)
 609 ;                               (:CONC-NAME IEB-))
 610 ;  (FILL-POINTER 0)
 611 ;  (SCAN-POINTER 0)
 612 ;  (TYPEIN-POINTER 0)
 613 ;  (NOISE-STRINGS NIL))
 614
 615 ;;                    Input Editor Commands
 616
 617 ;;Use define-input-editor-command to define and add a function which will be
 618 ;;on the main rubout handler command table used by macsyma listener.  The
 619 ;;name of the buffer is tv:rubout-handler-buffer and tv:(rhb-typein-pointer)
 620 ;;yields the current position.  Symbolics changed the names from "rubout-handler-"
 621 ;;to "input-editor-" and "rhb" to "ieb" and the package from tv to si.  How
 622 ;;helpful.
 623
 624 #+symbolics
 625 (defmacro define-input-editor-command (&rest l)
 626   (cond ((fboundp 'si:define-ie-command)
 627          (setq l(subst  'sI:input-editor-buffer 'tv:rubout-handler-buffer l))
 628          `(si:define-ie-command ,@ l))
 629         (t `(tv:define-rh-command ,@ l))))
 630
 631 #+ti
 632 (defmacro define-input-editor-command (name keys &body body)
 633   `(progn 'compile
 634           (defun ,name (ignore)
 635                ,@ body)
 636           (ucl:add-command ',name
 637                            '(:keys ,keys
 638                                   :names ,(string name)
 639                                   :command-flavor tv:rh-command)
 640                            'tv:rh-command-table t)))
 641
 642
 643 (define-input-editor-command com-macsyma-arglist (#\control-meta-a)
 644    (macsyma-print-arglist tv:rubout-handler-buffer) )
 645
 646 (define-input-editor-command com-macsyma-documentation (#\control-meta-d)
 647   (macsyma-print-documentation tv:rubout-handler-buffer))
 648
 649 #+ti  ;;definition ok for symbolics but would a zetalisp string be a sequence??
 650 (defun string-reverse-search-some (set strg &optional start)
 651   "set and strg are sequences and this gives the element position of the first (coming in reverse
 652    from star) occurence of and element of set in strg"
 653   (cond (start
 654          (position-if #'(lambda (x)  (position x set)) strg :from-end t
 655                       :end start))
 656         (t  (position-if #'(lambda (x)  (position x set)) strg :from-end t))))
 657
 658 #-ti
 659 (deff string-reverse-search-some #'string-reverse-search-set)
 660
 661 (defun macsyma-print-arglist (a-string &aux start fun end ignore)
 662   #+ti (setq a-string   (coerce a-string 'string)) ;; until rubout-handler-buffer is a string..
 663   (setq end (string-reverse-search-some "([" a-string #+ti (tv:rhb-typein-pointer ) #-ti (si:ieb-typein-pointer )))
 664   (setq start (string-reverse-search-some " (*+.-[" a-string end))
 665   (cond ((null start)(setq  start 0))
 666         (t (setq start (add1 start))))
 667   (send standard-input :fresh-line)
 668   (setq me (list start end a-string a-string #+ti (tv:rhb-typein-pointer ) #-ti (si:ieb-typein-pointer )))
 669   (setq fun  (intern (string-upcase
 670                        (string-append "$"
 671                                       (substring a-string start end))) 'cl-maxima))
 672
 673   ( #-ti si:ie-display-info
 674  #+ti tv:rh-display-info  #-ti (ignore ignore si:*numeric-arg-p* fun)
 675     (let ((arg))
 676       (cond ((and (sys:validate-function-spec fun)
 677                   (or (fdefinedp fun)
 678                       (and (symbolp fun)
 679                            (get fun 'compiled-only-arglist))))
 680              (print-arglist fun standard-output))
 681             ((setq arg (macsyma-arglist fun))
 682              (format t "~A : ~A" fun (macsyma-arglist fun)))
 683             (t (format t "Can't seem to find definition of ~A" fun))))))
 684
 685
 686
 687 (defun macsyma-print-documentation (a-string &aux start fun end)
 688   (declare (special tv:rubout-handler-buffer))
 689   #+ti (setq a-string (coerce a-string 'string))
 690   (setq end (string-reverse-search-some"([" a-string (tv:rhb-typein-pointer )))
 691   (setq start (string-reverse-search-some " (*+.-[" a-string end))
 692   (cond ((null start)(setq  start 0))
 693         (t (setq start (add1 start))))
 694   (send standard-input :fresh-line)
 695   (setq fun  (intern (string-upcase
 696                        (string-append "$"
 697                                       (substring a-string start end))) 'macsyma))
 698   ( #-ti si:ie-display-info
 699    #+ti tv:rh-display-info  #-ti (ignore ignore tv:rh-numeric-arg-p fun)
 700     (let ((arg))
 701       (cond ((and (sys:validate-function-spec fun)
 702                   (or (fdefinedp fun)
 703                       (and (symbolp fun)
 704                            (get fun 'compiled-only-arglist))))
 705              (format  standard-output (function-documentation fun)))
 706             ((setq arg (macsyma-arglist fun))
 707              (format t "~A : ~A" fun (macsyma-arglist fun)))
 708             (t (format t "Can't seem to MAXIMA-FIND definition of ~A" fun))))))
 709
 710
 711 (DEFMACRO macsyma-LIST-SYNTAX (CHAR)
 712   `(CHAR-SYNTAX ,CHAR *macsyma-LIST-SYNTAX-TABLE*))
 713
 714 (DEFMETHOD (macsyma-mode :MATCHING-CHAR-TO-BLINK) (BP LIMIT-BP)
 715   (AND (= (macsyma-LIST-SYNTAX (BP-CHAR-BEFORE BP)) LIST-CLOSE)
 716        (MULTIPLE-VALUE-BIND (IN-STRING SLASHIFIED IN-COMMENT)
 717            (LISP-BP-SYNTACTIC-CONTEXT (FORWARD-CHAR BP -1))
 718          (NOT (OR IN-STRING SLASHIFIED IN-COMMENT (in-macsyma-comment bp) )))
 719        ;;don't signal error if have to return nil
 720        (FORWARD-macsyma-expression BP -1 NIL 0 LIMIT-BP t nil nil)))
 721
 722
 723
 724 (DEFMACRO macsyma-LIST-SYNTAX (CHAR)
 725   `(CHAR-SYNTAX ,CHAR *macsyma-LIST-SYNTAX-TABLE*))
 726
 727 (defvar *Macsyma-MATCHING-DELIMITERS* "()[]{}")
 728 (DEFUN Macsyma-OPENING-DELIMITER (CHAR)
 729   (SLOOP WITH STRING = *macsyma-MATCHING-DELIMITERS*
 730         FOR I FROM 1 BELOW (length (the string  STRING)) BY 2
 731         WHEN (EQL CHAR (AREF STRING I))
 732         RETURN (AREF STRING (f1- I))
 733         FINALLY (ERROR "~C has no tex matching delimiter" CHAR)))
 734
 735 (SETQ *MACSYMA-LIST-SYNTAX-TABLE* (MAKE-SYNTAX-TABLE *MACSYMA-LIST-SYNTAX-LIST*))
 736
 737 (defcom com-macsyma-describe
 738     "Searches the documentation for keys containing a given string
 739     with a numeric argument different from 1 it puts the result in the current buffer."
 740       ()
 741   (let ((str (zwei::typein-line-read "String to describe")))
 742     (cl-macsyma::$describe str :editor (not (eql *numeric-arg* 1)))
 743     (cond ((not (eql *numeric-arg* 1))
 744            (format t "~%Type a space to see return to the documentation in the buffer:"))))
 745   dis-all)
 746
 747 (defun non-trivial-lines (point &optional ( n 1) reversep
 748                           &aux  (str ""))
 749   (let* ((nex (cond (reversep #'line-previous)
 750                    (t #'line-next)))
 751          (line  (car point)))
 752   (cond ((null reversep) (setq line (line-previous line))))
 753   (sloop while (setq line (funcall nex line))
 754         collecting line into lines
 755         when (not(eq 0 (length (the string  line))))
 756         count 1 into m
 757         while (< m n)
 758         finally (cond (reversep (setq lines(nreverse lines))))
 759                 (sloop for v in lines
 760                       do (setq str (string-append str (format nil "~A~%" v)))))
 761   str))
 762
 763
 764 (defvar *record-changes* nil)
 765
 766 (defun  get-record-changes-buffer ()
 767   (cond (*record-changes*)
 768         (t (with-editor-stream (str :buffer-name "Record Changes")
 769                                (format str ";;;*-changes - ~A" (time:print-current-time nil)))
 770            (sloop for v in zwei::*zmacs-buffer-list*
 771                  when (string-search "record changes" v)
 772                  do (return (setq *record-changes*  v))))))
 773
 774 ;;at present you must manually make *record-changes* by
 775 ;;going to a buffer and setq *record-changes* to it.
 776
 777
 778 (defvar *buffer-changes-recorded* nil)
 779
 780 #+symbolics
 781
 782 (defun record-changes (&optional bp1 bp2 &aux (m 3) an an2 an3)
 783   "Puts the current region into the buffer *record-changes* and records the surrounding information.  "
 784       (get-record-changes-buffer)
 785                 (let((bp (copy-bp (interval-last-bp *record-changes*)))
 786                         (name (or (and (send *interval* :pathname)
 787                                        (send (send *interval* :pathname) :truename))
 788                                         (string *interval*))))
 789   (cond ((fboundp 'user:push-new)  (user:push-new *interval* *buffer-changes-recorded*)))
 790     (cond ((bp-< bp1 bp2) nil)
 791           (t (swapf bp1 bp2)))
 792
 793   (setq an
 794         (insert-moving bp (format nil
 795                                   "~%;;****************~%~%;;From file ~A~%~%~
 796                                    ;;****preceding ~A lines***~%#|~A|#~%;;**BEGIN REPLACEMENT TEXT:~%"
 797                            name m
 798                        (non-trivial-lines bp1 M t)
 799                        )))
 800
 801  (setq an2   (insert-interval-moving an bp1 bp2 t))
 802
 803    (setq an3 (insert-moving an2 (format nil "~%;;**END REPLACEMENT.~%;;****subsequent ~A lines***~
 804                                              ~%#|~A|#~%~%" m
 805                        (non-trivial-lines bp2 m nil))))
 806
 807    (let ((*interval* *record-changes*))  (move-bp bp an3)
 808         )))
 809
 810 #+symbolics
 811
 812 (defcom com-record-changes
 813   "Records changes of the current region into a buffer called record changes"
 814   ( )
 815   (let (bp1 bp2 error-p definition-name node)
 816     (COND ((WINDOW-REGION-P) (format t "hi")
 817            ;; there is a region, use it.
 818            (SETQ BP1 (MARK) BP2 (POINT))
 819            (cond ((BP-< BP1 BP2) nil)
 820                  (t(swapf  BP1 BP2)))
 821            (SETQ DEFINITION-NAME "the region"))
 822           ((WINDOW-MARK-P *WINDOW*)
 823            (BARF "The region is empty"))
 824           (T                                    ;No region, get relevant definition
 825            (CHECK-INTERVAL-SECTIONS *INTERVAL*)
 826            (MULTIPLE-VALUE-SETQ (NODE DEFINITION-NAME ERROR-P)
 827              (SEND *MAJOR-MODE* ':DEFINITION-INTERVAL
 828                    (POINT) T))
 829            (WHEN ERROR-P (BARF ERROR-P))
 830            (SETQ BP1 (INTERVAL-FIRST-BP NODE)
 831                  BP2 (INTERVAL-LAST-BP NODE))))
 832     (record-changes bp1 bp2))
 833     dis-mark-goes)
 834
 835
 836
 837
 838