home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / lisp / qpcommands.el < prev    next >
Lisp/Scheme  |  1992-05-26  |  31KB  |  1,087 lines
  1. ;;;  SCCS: @(#)91/01/10 qpcommands.el    3.10
  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. ;;; This interface was made possible by contributions from Fernando
  17. ;;; Pereira and various customers of Quintus Computer Systems, Inc.,
  18. ;;; based on code for Quintus's Unipress Emacs interface. 
  19. ;;; 
  20.  
  21. ; ----------------------------------------------------------------------
  22. ;                    Incremental reconsulting
  23. ; ----------------------------------------------------------------------
  24.  
  25.  
  26. (defmacro error-occurred (&rest body)
  27.   (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
  28.  
  29. (defun prolog-compile ()
  30.   (interactive)
  31.   (prolog-load "compile")
  32. )
  33.  
  34. (defun ensure-prolog-is-running ()
  35.   (let ((source-buffer (current-buffer)))
  36.     (if (get-buffer "*prolog*")
  37. ;    (progn
  38. ;      (switch-to-buffer-other-window "*prolog*")
  39. ;      (other-window 1))
  40.       (let ((proc (get-buffer-process (get-buffer "*prolog*"))))
  41.        (if (not (and proc (eq (process-status proc) 'run)))
  42.            (error "No Prolog process available")))
  43.       (condition-case nil
  44.       (progn
  45.         (switch-to-buffer-other-window "*prolog*")
  46.         (run-prolog)
  47.          (switch-to-buffer-other-window source-buffer))
  48.     (error
  49.      (progn
  50.        (or (get-buffer "*prolog*")
  51.            (kill-buffer "*prolog*")
  52.            (switch-to-buffer source-buffer)
  53.             (signal 'error nil))))))))
  54.  
  55. (defun prolog-consult-predicate ()
  56.   (interactive)
  57.   (ensure-prolog-is-running)
  58.   (let (pl-char )
  59.     (cond 
  60.      ((string-equal (buffer-name) "*prolog*")
  61.       (error "Cannot load from the Prolog execution buffer"))
  62.      ((string-equal (buffer-file-name) "")
  63.       (error "Cannot load from this buffer before it is written to a file"))
  64.      ((not (safe-to-load-code))
  65.       (error "Cannot load unless Prolog is at top-level prompt"))
  66.      (t
  67.       (send-load-to-prolog "consult" ?p)
  68.       )
  69.      )
  70.     )
  71.   )
  72.  
  73. (defun prolog-load  (pl-load-type)
  74.   (let (pl-char )
  75.     (ensure-prolog-is-running)
  76.     (cond 
  77.      ((string-equal (buffer-name) "*prolog*")
  78.       (error "Cannot load from the Prolog execution buffer"))
  79.      ((string-equal (buffer-file-name) "")
  80.       (error "Cannot load from this buffer before it is written to a file"))
  81.      ((not (safe-to-load-code))
  82.       (error "Cannot load unless Prolog is at top-level prompt"))
  83.      (t
  84.       (sleep-for 1)
  85.       (message 
  86.        (concat 
  87.         pl-load-type
  88.         " Prolog... enter p for procedure, r for region or b for buffer "))
  89.       (send-load-to-prolog pl-load-type (read-char))
  90.       )
  91.      )
  92.     )
  93.   )
  94.  
  95. (defun send-load-to-prolog  (sltp-load-type sltp-char)
  96.   (let (word1 word2
  97.           (file-name (expand-file-name (buffer-file-name))))
  98.     
  99.     (cond 
  100.      ((string-equal sltp-load-type "compile")
  101.       (setq word1 "Compiling"))
  102.      ((string-equal sltp-load-type "consult")
  103.       (setq word1 "Consulting"))
  104.      )
  105.     (cond 
  106.      ((= sltp-char ?p)
  107.       (save-excursion
  108.         (message "Please Wait, finding predicate boundaries...")
  109.         (sit-for 0)
  110.     (save-excursion
  111.       (find-pred)
  112.                     ;       (wink-region)
  113.       (write-region (point) (mark) prolog-zap-file)
  114.       )
  115.         )
  116.       (setq word2 "procedure")
  117.       )
  118.      ((= sltp-char ?r)
  119.                     ;      (wink-region)
  120.       (write-region (point) (mark) prolog-zap-file)
  121.       (setq word2 "region")
  122.       )
  123.      ((= sltp-char ?b)
  124.       (save-excursion
  125.         (mark-whole-buffer)
  126.         (write-region (point) (mark) prolog-zap-file)
  127.         )
  128.       (setq word2 "buffer")
  129.       )
  130.      (t (error "Bad option"))
  131.      )
  132.     (pop-to-buffer "*prolog*")
  133.     (goto-char (process-mark (get-buffer-process "*prolog*")))
  134.     (setq *prolog-term-reading-mode* nil)
  135.     (message (concat word1 " " word2 "..."))
  136.     (sit-for 0)
  137.     (&clear-message)
  138.     (send-prolog 
  139.      (concat "'$editor_load_code'('" word2 "','" file-name "')"))
  140.     ))
  141.  
  142. (defun safe-to-load-code ()
  143.   (and (or *prolog-term-reading-mode*
  144.        @at-debugger-prompt)
  145.        (dot-process-output-marker-ok)
  146.        )
  147.   )
  148.  
  149. (defun dot-process-output-marker-ok ()
  150.     (save-excursion
  151.     (set-buffer "*prolog*")
  152.     (goto-char (process-mark (get-buffer-process "*prolog*")))
  153.     (looking-at "[\001- \177]*\\'")
  154.     )
  155. )
  156.  
  157.  
  158. ; ---------------------------------------------------------------------
  159. ;   This routine is not being used presently, see goal-history instead
  160. ; ---------------------------------------------------------------------
  161.  
  162.  
  163. (defun execute-previous-input(arg)
  164.   (interactive "p")
  165.   (let ( index previous-query original-dot)
  166.        (cond 
  167.      ((and (>= (point-marker) 
  168.               (process-mark (get-buffer-process "*prolog*")))
  169.                 (<= arg 1)  ; Check This
  170.         (null ^X^E-cache-empty)
  171.           )
  172.           (end-of-buffer)
  173.       (insert-buffer "&^X^E-cache")
  174.          )
  175.       (t (setq original-dot (point-marker))
  176.          (cond 
  177.         ((= (point-marker) (process-mark
  178.                  (get-buffer-process "*prolog*")))
  179.              (search-backward "| ?- "))
  180.         ((> (point-marker) (process-mark
  181.                  (get-buffer-process "*prolog*")))
  182.              (goto-char (process-mark (get-buffer-process "*prolog*")))
  183.          (search-backward "| ?- "))
  184.           (t (forward-char))
  185.          )
  186.      (setq index arg)
  187.      (while (> index 0)
  188.        (cond 
  189.          ((error-occurred (search-backward "| ?- "))
  190.           (goto-char original-dot)
  191.           (error "Cannot find a valid query to grab"))
  192.          (t (save-excursion 
  193.           (re-search-forward " ?- ")
  194.           (setq previous-query (valid-line))
  195.         )
  196.         (cond ((not (string-equal previous-query ""))
  197.                (setq index (- index 1)))
  198.         )
  199.          )
  200.        )
  201.          )
  202.      (end-of-buffer)
  203.      (insert-string previous-query)
  204.       )
  205.   )
  206. ))
  207.  
  208. ;; valid-line
  209. ;; This function called by "prolog-newline"
  210. ;; Checks if current query is valid; appropriate to send to prolog
  211. ;;
  212.  
  213. (defun valid-line ()
  214.   (let ((current-token nil)
  215.      (return nil)
  216.      (continue 1)
  217.      (current-mark (dot))
  218.      (saved-mark  (mark-marker)))
  219.     (cond ((error-occurred (setq current-token (next-token)))
  220.        (setq continue 0)
  221.            (setq return ""))
  222.     )
  223.     (while (not (zerop continue))
  224.     (cond ((string-equal current-token "stop")
  225.                (setq continue 0)
  226.            (backward-char)
  227.            (set-mark (point))
  228.            (goto-char current-mark)
  229.            (setq return (region-to-string)))
  230.           ((and (string-equal current-token "atom")
  231.                 (string-equal (region-to-string) "?-"))
  232.            (setq continue 0)
  233.            (setq return ""))
  234.           ((string-equal current-token "eof")
  235.            (setq continue 0)
  236.            (setq return ""))
  237.           (t (cond ((error-occurred (setq current-token (next-token)))
  238.              (setq continue 0)
  239.              (setq return ""))))
  240.      )
  241.      )    
  242.     (set-mark (point))
  243.     (goto-char saved-mark)
  244.     (exchange-dot-and-mark)
  245.     return
  246. ))
  247.  
  248. ; ----------------------------------------------------------------------
  249. ;                          Goal History
  250. ;                          Author: Sitaram Muralidhar
  251. ;                          Date  : 4/18/89
  252. ; ----------------------------------------------------------------------
  253.  
  254. ;;
  255. ;; prolog-history-command-map - the key bindings available within the
  256. ;; the mini-buffer when goal-history is called.
  257. ;;
  258. ;;
  259. (defvar prolog-history-command-map (copy-alist minibuffer-local-map))
  260. (define-key prolog-history-command-map "\ep" 'previous-goal)
  261. (define-key prolog-history-command-map "\en" 'next-goal)
  262.  
  263. (defun goal-history (arg)
  264.   "Edit and re-evaluate last prolog goal, or ARGth from last.
  265. The goal is placed in the minibuffer as a string for editing.
  266. The result is executed, repeating the goal as changed.
  267. If the goal has been changed or is not the most recent previous goal
  268. it is added to the front of the goal history.
  269. Whilst editing the goal, the following commands are available:
  270. \\{prolog-history-command-map}"
  271.   (interactive "p")
  272.   (cond ((< (point) (process-mark 
  273.               (get-buffer-process "*prolog*")))
  274.      (end-of-line)
  275.      (let ((index 1))
  276.        (while (> index 0)
  277.              (cond ((error-occurred (search-backward  "| ?- "))
  278.                 (message  "Cannot find a valid query to grab")
  279.                 (setq index 0)
  280.                 (beginning-of-line))
  281.                (t (re-search-forward " ?- ")
  282.                   (cond ((string-equal
  283.                        (setq goal 
  284.                          (save-excursion
  285.                            (valid-line))) "")
  286.                      (beginning-of-line))
  287.                     (t (place-in-prolog-buffer goal)
  288.                        (setq index 0))))
  289.              )
  290.        )
  291.       )
  292.      )
  293.     (t (let ((goal (nth (1- arg) prolog-goal-history)))
  294.          (setq newgoal (read-from-minibuffer "| ?- "
  295.                          (prin1-to-string goal)
  296.                          prolog-history-command-map
  297.                          t))
  298. ;;  The new sequence of goals need not be added to the history
  299. ;;  since it would be added by prolog-newline (qprocess.el) anyway.
  300. ;;    (or (equal newgoal (car prolog-goal-history))
  301. ;;    (setq prolog-goal-history (cons newgoal prolog-goal-history)))
  302. ;;
  303. ;;
  304.          (place-in-prolog-buffer newgoal)
  305.            )
  306.      )
  307.    )
  308. )
  309.  
  310. ;;
  311. ;;  Place string (goal) in buffer (prolog)
  312. ;;  The goal sequence is placed in the *prolog* buffer and when a RET
  313. ;;  is entered "prolog-newline" is invoked.
  314.  
  315. (defun place-in-prolog-buffer (goal)
  316.     (set-buffer "*prolog*")
  317.     (goto-char (point-max))
  318.     (insert-string goal)
  319. )
  320.   
  321. (defun next-goal (n)
  322.   "Inserts the next element of `prolog-goal-history' into the minibuffer."
  323.   (interactive "p")
  324.     (let ((narg (min (max 1 (- arg n)) (length prolog-goal-history))))
  325.     (if (= arg narg)
  326.     (error (if (= arg 1)
  327.            "No following item in goal history"
  328.            "No preceding item in goal history"))
  329.       (erase-buffer)
  330.       (setq arg narg)
  331.       (insert (prin1-to-string (nth (1- arg) prolog-goal-history)))
  332.       (goto-char (point-min)))))
  333.  
  334. (defun previous-goal (n)
  335.   "Inserts the previous element of `prolog-goal-history' into the minibuffer."
  336.   (interactive "p")
  337.   (next-goal (- n)))
  338.  
  339.  
  340.  
  341. ;; Given a "string", search through prolog's goal history for a goal
  342. ;; which contains "string" as a substring; Place this goal in its
  343. ;; entire form in the minibuffer and ask for conformation ; If not the
  344. ;; desired goal then continue to search backward for next goal which
  345. ;; contains "string". Made minor changes to definition of
  346. ;; repeat-matching-complex-command from chistory.el in the GNU Emacs
  347. ;; distribution. 
  348.  
  349. (defun repeat-matching-goal-command (&optional pattern)
  350.   "Re-evaluate Prolog goal with name matching PATTERN.
  351. Matching occurrences are displayed, most recent first, until you
  352. select a form for evaluation.  If PATTERN is empty (or nil), every form
  353. in the goal history is offered."
  354.   (interactive "sRedo Goal (regexp): ")
  355.   (if pattern
  356.       (if (equal (setq pattern
  357.                        (substring pattern
  358.                                   (or (string-match "[ \t]*[^ \t]" pattern)
  359.                                       (length pattern))))
  360.                  "")
  361.           (setq pattern nil)))
  362.   (let ((history prolog-goal-history)
  363.         (temp)
  364.         (what))
  365.     (while (and history (not what))
  366.       (setq temp (car history))
  367.       (if (and (or (not pattern) 
  368.            (string-match pattern temp))
  369.                (y-or-n-p (format "| ?- %s? " 
  370.                  (setq temp (prin1-to-string temp)))))
  371.           (setq what (car history))
  372.         (setq history (cdr history))))
  373.     (if (not what)
  374.         (error "Prolog goal history exhausted.")
  375.       (place-in-prolog-buffer what))))
  376.  
  377.  
  378. ; ----------------------------------------------------------------------
  379.  
  380. (defvar *term-reading-mode-before-^C* nil)
  381.  
  382. ;;;  Used to be control-c-interrupt
  383. (defun interrupt-prolog ()
  384.   (interactive)
  385.     (&clear-message)
  386.         (progn
  387.           (setq *term-reading-mode-before-^C* *prolog-term-reading-mode*)
  388.           (setq *prolog-term-reading-mode* nil)
  389.           (setq @at-debugger-prompt nil)
  390.           (interrupt-process nil t)))
  391.     
  392. (defun @restore-term-reading-mode ()
  393.   (setq *prolog-term-reading-mode*
  394.     *term-reading-mode-before-^C*))
  395.  
  396. ; ---------------------------------------------------------------------
  397. ;                  Find Definition
  398. ; ---------------------------------------------------------------------
  399.  
  400. (defvar *functor* 0)
  401. (defvar *arity* 0)
  402. (defvar *env*)
  403. (defvar *print-name* "")
  404. (defvar *already-saw-last-file* t)
  405. (defvar *called-from-@find* nil)
  406. (defconst *NoArity* -1)
  407. (defvar *prolog-term-reading-mode* t)
  408.  
  409. (defun region-to-string ()
  410.   (buffer-substring (min (point) (mark)) (max (point) (mark))))
  411.  
  412. (defun safe-to-find-with-prolog ()
  413.    (and (or *prolog-term-reading-mode*
  414.         @at-debugger-prompt)
  415.         (dot-process-output-marker-ok)
  416.    )
  417. )
  418.  
  419.  
  420.  
  421. (defun find-definition  ()
  422.   (interactive)
  423.   (let (token-type token)
  424.     (@fd-clear)
  425.     (if (not (safe-to-find-with-prolog))
  426.         (progn 
  427.       (pop-to-buffer "*prolog*")
  428.       (error 
  429.            "Cannot use ""find-definition"" unless Prolog is at top level prompt")
  430.           )
  431.       )
  432.  
  433.     (save-excursion     ;; # added for FCP 
  434.       (if (not (re-search-backward "[][?\001- \"%(#),{|}?\177]" nil t))
  435.           (beginning-of-buffer)
  436.     (forward-char)
  437.         )
  438.       (condition-case nil 
  439.           (let (token1 token1-type)
  440.             (setq token-type (next-token))
  441.             (setq token (region-to-string))
  442.             (cond 
  443.              ((string-equal token-type "atom")
  444.               (setq *functor* token)
  445.               (save-excursion 
  446.                 (setq token1-type (next-token))
  447.                 (setq token1 (region-to-string))
  448.                 (if (string-equal token1 "/")
  449.                     (progn 
  450.                       (setq token1-type (next-token))
  451.                       (setq token1 (region-to-string))
  452.                       (if (string-equal token1-type "integer")
  453.                           (setq *arity* (string-to-int token1))
  454.                         (setq *arity* -1)
  455.                         )
  456.                       )
  457.                   (setq *arity* -1)
  458.                   )
  459.                 )
  460.               (if (= *arity* -1)
  461.                   (progn 
  462.                     (setq *arity* 0)
  463.                     (error-occurred
  464.                      (next-token)
  465.                      (if (string-equal (region-to-string) "-->")
  466.                          (setq *arity* (+ *arity* 2)
  467.                                )
  468.                        )
  469.                      )
  470.                     )
  471.                 ))
  472.              ((string-equal token-type "functor")
  473.               (setq *functor* token)
  474.               (condition-case nil
  475.                   (let ()
  476.                     (setq *arity* (head-arity))
  477.                     (error-occurred
  478.                      (next-token)
  479.                      (if (string-equal (region-to-string) "-->")
  480.                          (setq *arity* (+ *arity* 2)
  481.                                )
  482.                        )
  483.                      )
  484.                     )
  485.                 (error (setq *arity* *NoArity*)))
  486.               )
  487.              (t 
  488.               (setq *functor* "")
  489.               (setq *arity* -1)
  490.               )
  491.              )
  492.             )
  493.         (error                          ; Handler for error
  494.          (setq *functor* "")
  495.          (setq *arity* -1)
  496.          )
  497.         )
  498.       )
  499.     (query-user)
  500.     (let ((mess
  501.            (concat "Please Wait, looking for predicate: "
  502.                    *functor*
  503.                    (if (= *arity* *NoArity*)
  504.                        ""
  505.                      (concat "/" (int-to-string *arity*))
  506.                      )
  507.                    "..."
  508.                    )
  509.            ))
  510.       (message mess)
  511.       (sit-for 0)
  512.                                         ;   (&qp-message mess)
  513.       )
  514.     (get-predicate-files)
  515.     )
  516.   )
  517.  
  518. (defun get-prolog-buffers ()
  519.   (let ((buffers (buffer-list))
  520.         (prolog-mode-buffers))
  521.     (while buffers
  522.       (set-buffer (car buffers))
  523.       (if (eq major-mode 'prolog-mode)
  524.           (setq prolog-mode-buffers (cons (car buffers) prolog-mode-buffers)))
  525.       (setq buffers (cdr buffers)))
  526.       prolog-mode-buffers))
  527.  
  528. (defun get-predicate-files ()
  529.   (if (not (get-process "prolog"))
  530.       (progn
  531.         (setq *print-name*  (if (= *arity* -1)
  532.                                 *functor*
  533.                               (concat *functor* "/" *arity*)))
  534.         (let ((prolog-buffers (get-prolog-buffers))
  535.               (no-good t))
  536.           (while (and prolog-buffers no-good)
  537.             (set-buffer (car prolog-buffers))
  538.             (if (string-equal
  539.                  ""
  540.                  (locate-definition *functor* *arity* *print-name*))
  541.                 (progn
  542.                   (pop-to-buffer (car prolog-buffers))
  543.           
  544.                   (setq no-good nil))
  545.               (setq prolog-buffers (cdr prolog-buffers))))
  546.           (if no-good
  547.               (conditional-message 
  548.                (concat "Definition for " *print-name* " not found")))))
  549.     (send-prolog
  550.      (concat
  551.       "find_predicate1(("
  552.       *functor*
  553.       "),"
  554.       (if (= *arity* *NoArity*)
  555.           "NoArity"
  556.         (int-to-string *arity*)
  557.         )
  558.       ")"
  559.       )
  560.      )
  561.     )
  562.   )
  563.   
  564. (defun parse-*functor*-and-*arity*  (&optional string)
  565.   (let ((buf (get-buffer-create "*temp*"))
  566.         token-type token)
  567.     (if (not string)
  568.         (setq string (read-string "Name/Arity: ")))
  569.     (save-excursion 
  570.       (set-buffer buf)
  571.       (widen)
  572.       (erase-buffer)
  573.       (insert-string string)
  574.       (beginning-of-buffer)
  575.       (setq token-type (next-token))
  576.       (setq token (region-to-string))
  577.       (if (string-equal token-type "atom")
  578.           (progn 
  579.             (setq *functor* token)
  580.             (setq token-type (next-token))
  581.             (setq token (region-to-string))
  582.             (cond 
  583.              ((string-equal token-type "eof")
  584.               (setq *arity* *NoArity*))
  585.               ((not (string-equal token "/"))
  586.                (error 
  587.                 (concat "Name and arity must be separated by a '/': " token)))
  588.               (t
  589.                (setq token-type (next-token))
  590.                (setq token (region-to-string))
  591.                (if (string-equal token-type "integer")
  592.                    (progn
  593.                      (setq *arity* (string-to-int token))
  594.                      (setq token-type (next-token))
  595.                      (setq token (region-to-string))
  596.                      (if (not (string-equal token-type "eof"))
  597.                          (error "Extra tokens after arity will be ignored")
  598.                        )
  599.                      )
  600.                  (error "Arity must be an integer: " token)
  601.                  )
  602.                )
  603.               )
  604.             )
  605.         (error (concat "Functor must be an atom: " token))
  606.         )
  607.       )
  608.     ))
  609.  
  610.  
  611. (defun query-user  ()
  612.   (let (user-response)
  613.     (setq user-response
  614.       (read-from-minibuffer "Find (Name/Arity): "
  615.                 (if (string-equal *functor* "")
  616.                     ""
  617.                   (concat 
  618.                    *functor*
  619.                    (if (= *arity* *NoArity*)
  620.                        ""
  621.                      (concat "/" (int-to-string *arity*))
  622.                      )
  623.                    )
  624.                   )
  625.                 )
  626.           )
  627.     (if (not (string-equal user-response ""))
  628.     (parse-*functor*-and-*arity* user-response)
  629.       )
  630.     ))
  631.  
  632. (defun query-user-for-predicate  (message)
  633.   (let (user-response)
  634.     (setq user-response
  635.       (read-from-minibuffer message
  636.                 (if (string-equal *functor* "")
  637.                     ""
  638.                   (concat 
  639.                    *functor*
  640.                    (if (= *arity* *NoArity*)
  641.                        ""
  642.                      (concat "/" (int-to-string *arity*))
  643.                      )
  644.                    )
  645.                   )
  646.                 )
  647.           )
  648.     (if (not (string-equal user-response ""))
  649.     (parse-*functor*-and-*arity* user-response)
  650.       )
  651.     ))
  652.  
  653.  
  654. ; ----------------------------------------------------------------------
  655.  
  656. (defun @find  (&optional flag env)
  657.   (setq flag (or flag (read-string "Flag: ")))
  658.   (setq *env* (or env read-string "Env: "))
  659.   (setq *print-name* 
  660.         (if (= *arity* -1)
  661.             *functor*
  662.           (concat *functor* "/" *arity*))
  663.     )
  664.   (cond 
  665.    ((string-equal flag "built_in")
  666.     (&qp-message (concat *print-name* " is a built-in predicate")))
  667.    ((string-equal flag "undefined")
  668.     (&qp-message (concat *print-name* " is undefined")))
  669.     ((string-equal flag "none")    
  670.      (&qp-message (concat *print-name* " has no file(s) associated with it")))
  671.      ((string-equal flag "ok")
  672.       (setq *already-saw-last-file* nil)
  673.       (setq *called-from-@find* t)
  674.       (find-more-definition))
  675.      (t &qp-message (concat "Find definition error: " flag))
  676.     )
  677. )
  678.  
  679.  
  680. (defun find-more-definition  ()
  681.   (interactive)
  682.   (if *already-saw-last-file*
  683.       (conditional-message "find-definition ""ESC ."" must be used first")
  684.     (if (fd-buffer-empty)
  685.         (progn 
  686.           (setq *already-saw-last-file* t)
  687.           (conditional-message 
  688.            (concat *print-name* " has no more source files")))
  689.       (let ((fmd-file-name (fd-get-filename)) fmd-message)
  690.         (if (string-equal fmd-file-name "user")
  691.             (setq fmd-message (concat *print-name*
  692.                                       " was defined in pseudo-file 'user'"))
  693.           (progn
  694.             (condition-case nil
  695.                 (let () 
  696.                   (find-file fmd-file-name)
  697.                   (setq fmd-message
  698.                         (locate-definition *functor* *arity* *print-name*))
  699.                   (if (string-equal *env* "debug")
  700.                       (pop-to-buffer "*prolog*" nil))
  701.                   )
  702.               (error
  703.                (setq fmd-message
  704.                      (concat *print-name*
  705.                              " was defined in "
  706.                              fmd-file-name 
  707.                              ", but the file no longer exists")))
  708.               )
  709.             )
  710.           )
  711.         (if (fd-buffer-empty)
  712.             (if (string-equal fmd-message "")
  713.                 (setq fmd-message " ")
  714.               )
  715.           (if (string-equal fmd-message "")
  716.               (setq fmd-message "Type ""ESC ,"" for more")
  717.             (setq fmd-message
  718.                   (concat fmd-message ", type ""ESC ,"" for more"))
  719.             )
  720.           )
  721.         (conditional-message fmd-message)
  722.         )
  723.       )
  724.     )
  725.   (setq *called-from-@find* nil)
  726.   )
  727.  
  728. (defun conditional-message (message)
  729.   (if *called-from-@find*
  730.       (&qp-message message)
  731.     (progn 
  732.       (message message)
  733.         (sit-for 0)
  734.     )
  735.     )
  736. )
  737.  
  738.  
  739. (defun @fd-clear ()
  740.   (let ((buf (get-buffer-create "*find-def*")))
  741.     (save-excursion
  742.       (set-buffer buf)
  743.       (widen)
  744.       (erase-buffer)
  745.       )
  746.     )
  747.   )
  748.  
  749. (defun @fd-in (file)
  750.   (save-excursion
  751.     (set-buffer "*find-def*")
  752.     (end-of-buffer)
  753.     (insert-string (concat file "\n"))
  754.     )
  755.   )
  756.  
  757. (defun fd-get-filename ()
  758.   (let (ans)
  759.     (save-excursion
  760.       (set-buffer "*find-def*")
  761.       (goto-char (point-min))
  762.       (forward-char)
  763.       (search-forward "\"")
  764.       (backward-character)
  765.       (setq *functor* (buffer-substring (+ (point-min) 1) (point)))
  766.       (forward-character)
  767.       (forward-character)
  768.       (delete-region (point-min) (point))
  769.       (search-forward " ")
  770.       (backward-character)
  771.       (setq *arity* (string-to-int (buffer-substring (point-min) (point))))
  772.       (forward-character)
  773.       (delete-region (point-min) (point))
  774.       (end-of-line)
  775.       (setq ans (buffer-substring (point-min) (point)))
  776.       (beginning-of-line)
  777.       (kill-line)
  778.       (kill-line)
  779.       ans
  780.     )
  781. ))
  782.  
  783.  
  784. (defun fd-buffer-empty ()
  785.   (save-excursion
  786.     (set-buffer "*find-def*")
  787.     (= (buffer-size) 0)
  788.     )
  789.   )
  790.  
  791. ; ----------------------------------------------------------------------
  792.  
  793. (defun locate-definition (&optional functor arity print-name)
  794.  
  795.   (if (not functor) (setq  functor (read-string "Functor: ")))
  796.   (if (not arity) (setq  arity (read-string "Arity: ")))
  797.   (if (not print-name) (setq print-name (read-string "Print Name: ")))
  798.  
  799.   (let ((continue t)
  800.         (found-arity 0) (saved-point (point)) return)
  801.     (goto-char (point-min))
  802.     (while continue
  803.       (if (not (re-search-forward (concat "^'?" functor "'?") nil t))
  804.           (progn 
  805.         (goto-char saved-point)              
  806.         (setq return
  807.                   (concat "Cannot find a definition for " 
  808.                           print-name 
  809.                           " in this file"))
  810.         (setq continue nil)
  811.             )
  812.         (if (not (within-comment))
  813.             (let  (valid-arity (saved-dot (point)))
  814.               (cond 
  815.                ((looking-at "[A-Za-z0-9_]")
  816.                 (setq valid-arity nil))
  817.                ((= (following-char) ?\( )
  818.                 (setq valid-arity
  819.                       (condition-case nil
  820.                           (progn (setq found-arity (all-arity saved-dot)) t)
  821.                         (error nil))
  822.                       ))
  823.                (t
  824.                 (setq found-arity 0)
  825.                 (setq found-arity
  826.                       (+ found-arity
  827.                          (arity-overhead-for-grammar-rule saved-dot)))
  828.                 (setq valid-arity t)
  829.                 )
  830.                )
  831.               (if valid-arity
  832.                   (if (or (= arity found-arity) (= arity *NoArity*))
  833.                       (progn 
  834.             (goto-char saved-dot)
  835.             (beginning-of-line)
  836.             (setq return "")
  837.             (setq continue nil)
  838.                         )
  839.             (goto-char saved-dot)
  840.                     )
  841.         (goto-char saved-dot)
  842.                 )
  843.               )
  844.           )
  845.         )
  846.       )
  847.     (if (string-equal return "") (push-mark saved-point))
  848.     return)
  849.   )
  850.  
  851. ; ---------------------------------------------------------------------
  852. ;                  Change Directory
  853. ; ---------------------------------------------------------------------
  854.  
  855. ;;
  856. ;  Trap M-x cd, pass all others
  857. ;;
  858.  
  859. (defun meta-x-trap (cmd)
  860.   (interactive "CM-x ")
  861.   (cond ((string-equal cmd "cd")
  862.      (call-interactively 'prolog-cd))
  863.     (t (call-interactively cmd))
  864.   )
  865. )
  866.  
  867.  
  868. (defun prolog-cd  (cd-path)
  869.   (ensure-prolog-is-running)
  870.   (interactive "DChange default directory: ")
  871.   (cond
  872.     ((not (safe-to-load-code))
  873.      (error "Prolog is not at the top-level prompt"))
  874.     (t
  875.       (if (string-equal cd-path "")
  876.       (setq cd-path (getenv "HOME"))
  877.     (sit-for 0)
  878.     (&no-message)
  879.     (send-prolog (concat "unix(cd('" cd-path "'))")))))
  880. )
  881.  
  882.  
  883. ;
  884. ; This function is only called by Prolog
  885. ;
  886.  
  887. (defun @cd  (path prolog-success)
  888.   (cond ((not (zerop prolog-success))
  889.      (condition-case nil 
  890.          (progn
  891.            (cd path)
  892.            (&qp-message
  893.          (concat "Current directory now: " path)))
  894.        (error
  895.          (&qp-message
  896.           (concat 
  897.           "Prolog did, but Emacs did not change current directory to: " 
  898.         path)
  899.           )
  900.        )
  901.       )                  ; ends condition-case
  902.      )
  903.     (t (&qp-message
  904.          (concat 
  905.            "Neither Prolog nor Emacs changed current directory to: " 
  906.            path)
  907.        )
  908.     )
  909.    )
  910. )  
  911.  
  912. ; ---------------------------------------------------------------------
  913. ;                  Library
  914. ; ---------------------------------------------------------------------
  915.  
  916. ;The command "<ESC>-x library" supports the library directory package 
  917. ; of version 1.5
  918.  
  919. (defun library  ()
  920.   (interactive)
  921.   (cond ((bufferp (get-buffer "*prolog*"))
  922.      (if (safe-to-load-code)
  923.          (let* ((lib-file (read-string "Library name: "))
  924.             (mess (concat
  925.                 "Please Wait, looking for library file: "
  926.                 lib-file
  927.                 "..." )))
  928.            (message mess)
  929.            (sit-for 0)
  930.            (&qp-message mess)
  931.            (send-prolog (concat "find_library_package((" lib-file "))"))
  932.            )
  933.          (progn    
  934.            (error 
  935.          "Cannot use ""library"" unless Prolog is at top level prompt")
  936.            )
  937.          )
  938.      )
  939.     ((bufferp (get-buffer "*qui-emacs*"))
  940.      (error "Emacs Invoked from QUI: library not a valid command"))
  941.     (t (error "Invalid command")))
  942.   )
  943.     
  944. (defun @lib  (lib-file)
  945.   (if (string-equal
  946.        lib-file
  947.        "cannot find library file, check facts for library_directory/1")
  948.       (&qp-message lib-file)
  949.     (progn        
  950.       (pop-to-buffer "*prolog*")
  951.       (find-file-other-window lib-file)
  952.       (&clear-message)
  953.       )
  954.     )
  955.   )
  956.  
  957. (defun @remove-gc-tick-mark (tick)
  958.   (save-excursion 
  959.     (set-buffer "*prolog*")
  960.     (goto-char (point-max))
  961.     (if (= (preceding-char) tick))
  962.     (delete-previous-character)
  963.     (&qp-message "Gc tick mark missing from ""qprolog"" buffer")
  964.     )
  965.   )
  966.  
  967. (defvar @at-debugger-prompt nil)
  968.  
  969. (defun @debug ()
  970.   (setq *prolog-term-reading-mode* nil)
  971.   (setq @at-debugger-prompt t)
  972.   )
  973.  
  974. (defun spy ()
  975.   (interactive)
  976.   (@fd-clear)
  977.   (ensure-prolog-is-running)
  978.   (if (not (safe-to-find-with-prolog))
  979.       (progn 
  980.     (pop-to-buffer "*prolog*")
  981.     (error 
  982.      "Cannot use ""spy"" unless Prolog is at top level prompt")
  983.     )
  984.     )
  985.   (get-current-predicate)
  986.   (query-user-for-predicate "Spy (Name/Arity): ")
  987.   (pop-to-buffer "*prolog*")
  988.   (send-prolog (concat "spy " *functor* 
  989.                (if (< *arity* 0) ""
  990.              (concat "/" (int-to-string *arity*)))
  991.                )
  992.            )
  993.   )
  994.  
  995. (defun nospy ()
  996.   (interactive)
  997.   (@fd-clear)
  998.   (ensure-prolog-is-running)
  999.   (if (not (safe-to-find-with-prolog))
  1000.       (progn 
  1001.     (pop-to-buffer "*prolog*")
  1002.     (error 
  1003.      "Cannot use ""spy"" unless Prolog is at top level prompt")
  1004.     )
  1005.     )
  1006.   (get-current-predicate)
  1007.   (query-user-for-predicate "Spy (Name/Arity): ")
  1008.   (pop-to-buffer "*prolog*")
  1009.   (send-prolog (concat "nospy " *functor* 
  1010.                (if (< *arity* 0) ""
  1011.              (concat "/" (int-to-string *arity*)))
  1012.                )
  1013.            )
  1014.   )
  1015.  
  1016. (defun get-current-predicate ()
  1017.   (let (token-type token)
  1018.     (save-excursion;; # added for FCP 
  1019.       (if (not (re-search-backward "[][?\001- \"%(#),{|}?\177]" nil t))
  1020.       (beginning-of-buffer)
  1021.     (forward-char)
  1022.     )
  1023.       (condition-case nil 
  1024.       (let (token1 token1-type)
  1025.         (setq token-type (next-token))
  1026.         (setq token (region-to-string))
  1027.         (cond 
  1028.          ((string-equal token-type "atom")
  1029.           (setq *functor* token)
  1030.           (save-excursion 
  1031.         (setq token1-type (next-token))
  1032.         (setq token1 (region-to-string))
  1033.         (if (string-equal token1 "/")
  1034.             (progn 
  1035.               (setq token1-type (next-token))
  1036.               (setq token1 (region-to-string))
  1037.               (if (string-equal token1-type "integer")
  1038.               (setq *arity* (string-to-int token1))
  1039.             (setq *arity* -1)
  1040.             )
  1041.               )
  1042.           (setq *arity* -1)
  1043.           )
  1044.         )
  1045.           (if (= *arity* -1)
  1046.           (progn 
  1047.             (setq *arity* 0)
  1048.             (error-occurred
  1049.              (next-token)
  1050.              (if (string-equal (region-to-string) "-->")
  1051.              (setq *arity* (+ *arity* 2)
  1052.                    )
  1053.                )
  1054.              )
  1055.             )
  1056.         ))
  1057.          ((string-equal token-type "functor")
  1058.           (setq *functor* token)
  1059.           (condition-case nil
  1060.           (let ()
  1061.             (setq *arity* (head-arity))
  1062.             (error-occurred
  1063.              (next-token)
  1064.              (if (string-equal (region-to-string) "-->")
  1065.              (setq *arity* (+ *arity* 2)
  1066.                    )
  1067.                )
  1068.              )
  1069.             )
  1070.         (error (setq *arity* *NoArity*)))
  1071.           )
  1072.          (t 
  1073.           (setq *functor* "")
  1074.           (setq *arity* -1)
  1075.           )
  1076.          )
  1077.         )
  1078.     (error                ; Handler for error
  1079.      (setq *functor* "")
  1080.      (setq *arity* -1)
  1081.      )
  1082.     )
  1083.       )
  1084.     )
  1085.   )
  1086.  
  1087.