home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / p / plbin.zip / pl / lisp / qprocess.el < prev    next >
Lisp/Scheme  |  1992-05-26  |  13KB  |  440 lines
  1. ;;;  SCCS: @(#)91/01/04 qprocess.el    3.7
  2. ;;;            Quintus Prolog - GNU Emacs Interface
  3. ;;;                         Support Functions
  4. ;;;
  5. ;;;                Consolidated by Sitaram Muralidhar
  6. ;;;
  7. ;;;                   sitaram@quintus.com
  8. ;;;              Quintus Computer Systems, Inc.
  9. ;;;                  2 May 1989       
  10. ;;;
  11. ;;; This file defines functions that support the Quintus Prolog - GNU Emacs
  12. ;;; interface.
  13. ;;;
  14. ;;;                   Acknowledgements
  15. ;;;
  16. ;;;
  17. ;;; This interface was made possible by contributions from Fernando
  18. ;;; Pereira and various customers of Quintus Computer Systems, Inc.,
  19. ;;; based on code for Quintus's Unipress Emacs interface.
  20. ;;; 
  21. (defvar *prolog-term-reading-mode* t)
  22. (defvar *saved-prolog-process-mark* nil    ; SWI
  23.   "Saved process mark of *prolog* buffer")
  24.  
  25. ;(defvar *last-prolog-command-string*)
  26. ;(defvar *startup-jcl*
  27. ;  (concat *c-switch* "\"Emacs:\"" prolog-zap-file "\""))
  28.  
  29. ; ----------------------------------------------------------------------
  30. ; Modification of the pr-do-newline found in Unipress process stuff.
  31. ; This needs to know when we are in clause reading mode and then sense
  32. ; end of clause properly.
  33. ; Modified again by Dave Bowen: now sends a newline to Prolog if no non-
  34. ; whitespace characters have been typed.  This causes a new ?\|?- ?\ o be
  35. ; printed by Prolog (which automatically updates the process-output-marker).
  36. ;
  37. ; Adapted for GnuEmacs, including goal-history stuff, by Muralidhar Sitaram.
  38. ; ----------------------------------------------------------------------
  39.  
  40. (defun prolog-newline ()
  41.   "Send input to prolog process. At end of buffer, sends all text after last output
  42. as input to the prolog process, including a newline inserted at the end."
  43.   (interactive)
  44.   (cond ((string-equal (process-name
  45.              (get-buffer-process (current-buffer))) "prolog")
  46.      (setq ori-dot (point))
  47.      (end-of-line)
  48.      (cond ((< (point) 
  49.            (process-mark (get-buffer-process (current-buffer))))
  50.         (goto-char ori-dot)
  51.         (newline))
  52.            (t (cond ((eobp)
  53.               (move-marker last-input-start
  54.                        (process-mark 
  55.                      (get-buffer-process 
  56.                        (current-buffer))))
  57. ;              (insert ?\n)
  58.               (move-marker last-input-end (point)))
  59.              (t (newline))
  60.               )
  61. ;           (end-of-line)
  62.           (cond ((or (not *prolog-term-reading-mode*)
  63.                   (clause-end-p))         
  64.               (insert ?\n)        ; send stuff to prolog
  65.               (push-mark (point) t)
  66.               (goto-char (process-mark 
  67.                        (get-buffer-process 
  68.                      (current-buffer))))
  69.               (setq input-clause (region-to-string))
  70. ;;
  71. ;; If not in debugger mode then add to prolog-goal-history only if the
  72. ;; query is valid  
  73. ;; 
  74.               (cond ((null @at-debugger-prompt)
  75.                  (save-excursion
  76.                    (cond ((not (string-equal (setq 
  77.                                    current-goal
  78.                                    (valid-line))
  79.                                  ""))
  80.                       (setq prolog-goal-history
  81.                         (cons current-goal
  82.                               prolog-goal-history))
  83.                      )))))
  84.               (pop-mark)
  85.               (setq *prolog-term-reading-mode* nil)
  86.               (setq @at-debugger-prompt nil)
  87.               (goto-char (point-max))
  88.               (let ((process (get-buffer-process 
  89.                        (current-buffer))))
  90.                 (send-string process input-clause)
  91.                 (set-marker (process-mark process) (point)))
  92.                       )
  93.              (t (cond ((white-space-only)   ;  print prompt
  94.                    (send-string (get-buffer-process
  95.                           (current-buffer)) "\n")
  96.                        (setq *prolog-term-reading-mode* nil)
  97.                        (setq @at-debugger-prompt nil)
  98.                        (newline))
  99.                   (t (insert-string "\n     ")))))
  100.              )   
  101.               )
  102.          )
  103.     (t (newline))
  104.       )
  105.  )
  106.  
  107. ; define ^X^E-cache-empty
  108.  
  109. (defvar ^X^E-cache-empty t)
  110.  
  111. (defun maybe-copy-into-^X^E-cache (clause)
  112.   (cond ((not (error-occurred (re-search-backward "| ?- \\=")))
  113.      (save-excursion
  114.        (set-buffer (get-buffer-create "&^X^E-cache"))
  115.        (erase-buffer)
  116.        (insert-string clause)
  117.        (delete-previous-character)
  118.        (setq ^X^E-cache-empty nil)))
  119.   )
  120. )
  121.  
  122. (defun white-space-only ()
  123.   (save-excursion
  124.     (goto-char 
  125.       (process-mark (get-buffer-process (current-buffer))))
  126.     (looking-at "[\001- \177]*\\'")
  127.     )
  128.   )
  129.  
  130. ; -------------------------------------------------------------------------
  131. ; clause-end-p looks to see if we are a the end of a clause, i.e. we are
  132. ; positioned after a "." which is not preceded by an agglutinating character.
  133. ; There may be any number of spaces, tabs and newlines between the "." and
  134. ; the current position and/or between the current position and the end of
  135. ; file.  Any such whitespace characters are deleted in the case where
  136. ; clause-end-p turns out to be true, but not if it is false.
  137. ; -------------------------------------------------------------------------
  138.  
  139. (defun clause-end-p ()
  140.   (setq init-dot (point))
  141.     (cond ((and  (progn
  142.                (while (or (= 32  (following-char))
  143.                   (= 9   (following-char))
  144.                   (= 10  (following-char))
  145.                   )
  146.              (forward-char))
  147.                (eobp)
  148.              )
  149.              (progn
  150.                (goto-char init-dot)
  151.                (while (or (= 32 (preceding-char))
  152.                   (= 9  (preceding-char))
  153.                   (= 10 (preceding-char))
  154.                   )
  155.              (backward-char)
  156.                )
  157.                (and (> (dot) (process-mark 
  158.                      (get-buffer-process (current-buffer))))
  159.                 (= (preceding-char) 46)   ; a "." 
  160.                )
  161.              )
  162.              (progn
  163.                (backward-char)
  164.                (not (agglutinating-charp (preceding-char))))
  165.            )
  166.            (forward-char)
  167.            (push-mark (point) t)
  168.            (goto-char (point-max))
  169.            (kill-region (point) (mark))
  170.            (pop-mark) t)
  171.           (t (goto-char init-dot)
  172.          nil))
  173. )
  174.  
  175.  
  176. (defun start-new-prollog-process (command-line)
  177. (let (
  178.     name
  179.   old-use-users-shell
  180.   old-use-csh-option-f)
  181.  
  182.     (setq name (ml-arg 1))
  183.     (pop-to-buffer name)
  184.         (change-current-filename (prolog-init-filename))
  185.       (erase-buffer)
  186.     (set-mark-command)
  187.     (setq process-output-marker (point-marker))
  188.     (setq prolog-term-reading-mode 0)
  189.     (setq old-use-users-shell use-users-shell)
  190.     (setq old-use-csh-option-f use-csh-option-f)
  191.     (setq use-users-shell 1)
  192.     (setq use-csh-option-f 1)
  193.     (start-filtered-process            
  194.         (ml-arg 2 "command:")
  195.         name
  196.         "prollog-process-filter"
  197.     )
  198.     (setq use-users-shell old-use-users-shell)
  199.     (setq use-csh-option-f old-use-csh-option-f)
  200.     1
  201.     )
  202. )
  203.  
  204.  
  205. (defun restart-prolog (input-saved-state)
  206.     (ml-if (/= (current-process) "qprolog")
  207.         (progn
  208.            (setq input-saved-state (read-string (concat
  209.           ":* saved state [<RETURN> for "
  210.           (get-saved-state)
  211.           "] ")))
  212.            (ml-if (= input-saved-state "")
  213.            0
  214.            (progn
  215.                   (setq last-prolog-command-string
  216.             (concat &machine-dependent-jcl
  217.              input-saved-state
  218.              startup-jcl))))
  219.                (&clear-message)
  220.            (start-prollog
  221.            last-prolog-command-string))
  222.         (progn
  223.            (bell-message
  224.             "Cannot start new Prolog until current one is killed"))))
  225.  
  226.  
  227.  
  228. ; This routine obtains the name of the current saved state
  229. (defun get-saved-state  (pos end tmp ans)
  230.     (setq pos (find-minus-c 1))
  231.     (setq end pos)
  232.     (ml-if
  233.        (/= pos "error")
  234.        (progn    ; pos is now at the end of the saved state name
  235.            (setq tmp (ml-substr last-prolog-command-string pos 1))
  236.            (while        
  237.            (not (zerop (logand (/= tmp " ")
  238.               (/= pos 0))))
  239.            (setq pos (- pos 1))
  240.            (setq tmp (ml-substr last-prolog-command-string pos 1))
  241.            )
  242.            (setq pos (+ pos 1))
  243.            (setq ans (ml-substr last-prolog-command-string pos 
  244.                  (+ (- end pos) 1)))
  245.        )
  246.        (progn        
  247.            (setq ans "none found")
  248.        )
  249.     )
  250.     ans
  251. )
  252.  
  253. ; ----------------------------------------------------------------------
  254. ; This program will return the position of the last character in the saved
  255. ;  state taken from the string last-prolog-command-string.  It should always be
  256. ;  given an initial argument of 1    
  257. ; ----------------------------------------------------------------------
  258.  
  259. (defun find-minus-c  (tmp tmp1 pos pos1 ans)
  260.     (setq pos (ml-arg 1))
  261.     (setq tmp (ml-substr last-prolog-command-string pos 1))
  262.     (setq pos1 (+ pos 1))
  263.     (setq tmp1 (ml-substr last-prolog-command-string pos1 1))
  264.     (while
  265.         (not (zerop (logand (/= "" tmp1)
  266.            (lognot (found-minus-c tmp tmp1))
  267.         )))
  268.         (setq pos (+ pos 1))
  269.         (setq tmp (ml-substr last-prolog-command-string pos 1))
  270.         (setq pos1 (+ pos 1))
  271.         (setq tmp1 (ml-substr last-prolog-command-string pos1 1))
  272.     )
  273.     (ml-if
  274.        (= "" tmp1)
  275.        (setq ans "error")
  276.        (ml-if
  277.           (= " " (ml-substr last-prolog-command-string (- pos 1) 1))
  278.           (setq ans (- pos 2))
  279.           (setq ans (- pos 3))
  280.        )
  281.     )             
  282.     ans
  283. )
  284.  
  285. (defun found-minus-c ans ()
  286.   (ml-if
  287.    (logand (= (ml-arg 1) "-")
  288.            (= (ml-arg 2) "C"))
  289.    (setq ans 1)
  290.    (setq ans 0)
  291.    )
  292.   ans
  293.  
  294.   )
  295.  
  296.  
  297. ; ----------------------------------------------------------------------
  298. ; the routine prollog-process-filter inserts output in the qprolog buffer  
  299. ; ----------------------------------------------------------------------
  300.  
  301. ; This flag is set to true only if in the middle of processing a packet.
  302. (defvar *packet-pending* nil)   ; Set the flag to its default position.
  303.  
  304. (defconst *begin-packet-char* 30)
  305. (defconst *end-packet-char* 29)
  306. (defvar *packet-buffer* nil)
  307.  
  308. (defconst *begin-packet-string* (char-to-string *begin-packet-char*))
  309. (defconst *end-packet-string* (char-to-string *end-packet-char*))
  310. (defconst *packet-control-string* (concat *begin-packet-string* "\\|"
  311.                                           *end-packet-string*))
  312. (defun prolog-process-filter (process packet)
  313.   (process-packets packet process)
  314.   (cond (*saved-prolog-process-mark*    ; SWI
  315.      (set-marker (process-mark (get-buffer-process "*prolog*"))
  316.              *saved-prolog-process-mark*)
  317.      (setq *saved-prolog-process-mark* nil)))
  318.   (display-any-messages)
  319.   )
  320.  
  321. (defun process-packets (packet process)
  322.   (let ((packet-control (string-match *packet-control-string* packet)))
  323.     (if *packet-pending*
  324.     (cond 
  325.      ((not packet-control) 
  326.       (setq *packet-buffer* (concat *packet-buffer*  packet)))
  327.      ((string-equal 
  328.        (substring packet packet-control (1+ packet-control))
  329.        *end-packet-string*)
  330.       (process-prolog-packets
  331.        (concat *packet-buffer*
  332.            (substring packet 0 packet-control)))
  333.       (setq *packet-buffer* "")
  334.       (setq *packet-pending* nil)
  335.       (process-packets 
  336.        (substring packet (1+ packet-control)) process))
  337.      (t
  338.       (setq *packet-pending* nil)
  339.       (&qp-message "New packet arrived before end of old one")
  340.       (setq *packet-buffer* "")
  341.       (process-packets
  342.        (substring packet (1+ packet-control))
  343.        process)))
  344.       ;; else
  345.       (cond 
  346.        ((not packet-control)
  347.     (save-excursion
  348.       (set-buffer (process-buffer process))
  349.       (goto-char (point-max))
  350.       (let ((now (point)))
  351.         (insert packet))
  352.       (if (process-mark process)
  353.           (set-marker (process-mark process) (point))))
  354.     (if (eq (process-buffer process) (current-buffer))
  355.         (goto-char (point-max))))
  356.        ((string-equal 
  357.      (substring packet packet-control (1+ packet-control)) 
  358.      *end-packet-string*)
  359.     (&qp-message "Found end of packet which was not started")
  360.     (setq *packet-buffer* "")
  361.     (process-packets (substring packet (1+ packet-control)) process))
  362.        (t
  363.     (if (> packet-control 0)
  364.         (progn
  365.           (save-excursion
  366.         (set-buffer (process-buffer process))
  367.         (goto-char (point-max))
  368.         (let ((now (point)))
  369.           (insert (substring packet 0 packet-control))
  370.           (if (process-mark process)
  371.               (set-marker (process-mark process) (point))))
  372.         (if (eq (process-buffer process) (current-buffer))
  373.             (goto-char (point-max))))))
  374.     (setq *packet-pending* t)
  375.     (process-packets
  376.      (substring packet (1+ packet-control)) process))
  377.        )
  378.       )
  379.     )
  380.   )
  381.  
  382. ; standard packet types that are very frequently given are indicated
  383. ; by a single letter, otherwise, the packet routine is simply the name
  384. ; of the Emacs-Lisp routine to be executed.
  385.  
  386. (defun process-prolog-packets (packet)
  387.   (let ((packet-type (substring packet 0 1)))
  388.     (cond    
  389.      ((string-equal packet-type "a") (setq *prolog-term-reading-mode* t))
  390.      ((string-equal packet-type "d")
  391.       (setq global-mode-string 
  392.         (append original-mode-string 
  393.             (list (strip-module packet))))
  394.       (cond 
  395.        ((string-match "debug" packet)
  396.         (setq mode-line-format 
  397.               "--%1*%1*-Emacs: %b   %M *Debug*   %[(%m: %s)%]----%3p--%-"))
  398.        ((string-match "trace" packet)
  399.         (setq mode-line-format 
  400.               "--%1*%1*-Emacs: %b   %M *Trace*  %[(%m: %s)%]----%3p--%-"))
  401.        (t
  402.         (setq mode-line-format 
  403.               "--%1*%1*-Emacs: %b   %M          %[(%m: %s)%]----%3p--%-")))
  404.       (set-buffer-modified-p (buffer-modified-p)))
  405.      ((string-equal packet-type "m") (&qp-message (substring packet 1)))
  406.      (t (if (error-occurred (eval (read packet)))
  407.             (progn 
  408.           (&qp-message 
  409.            (concat "Lisp packet could not execute: " packet))
  410.               )
  411.       )
  412.           )
  413.         )
  414.      )
  415. )
  416.  
  417. ;-----------------------------------------------------------------------
  418.  
  419. (defun send-prolog (query)
  420.   (send-string "prolog"
  421.                (concat "\^]" query " .\n")
  422.                )
  423.   )
  424.  
  425. ;; Function not used
  426.  
  427. (defun send-prolog-directly (string)
  428.   (&clear-message)
  429.   (setq *prolog-term-reading-mode* nil)
  430.   (setq @at-debugger-prompt nil)
  431.   (set-string "prolog" string)
  432.   )
  433.  
  434. ; mode-line support function
  435. (defun strip-module (packet)
  436.   (cond ((setq mod-pos (string-match "Module:" packet))
  437.      (concat "Module:" (substring packet (+ mod-pos 7) (+ mod-pos 17))))
  438.     (t nil)))
  439.  
  440.