Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml-mode/trunk/sml-proc.el
ViewVC logotype

Diff of /sml-mode/trunk/sml-proc.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 32, Thu Mar 12 16:54:39 1998 UTC revision 33, Thu Mar 12 16:57:15 1998 UTC
# Line 119  Line 119 
119  (defvar sml-default-arg ""  (defvar sml-default-arg ""
120    "*Default command line option to pass, if any.")    "*Default command line option to pass, if any.")
121    
122  (defvar sml-display-frame-alist  (defvar sml-make-command "CM.make()"
123    '((height . 24) (width . 80) (menu-bar-lines . 0))    "The command used by default by `sml-make'.")
   "*Alist of frame parameters used in creating dedicated ML interaction frames.  
 These supersede the values given in `default-frame-alist'.  
 You might like a larger screen  
124    
125    \(setcdr \(assoc 'height sml-display-frame-alist\) 40\)  (defvar sml-make-file-name "sources.cm"
126      "The name of the makefile that `sml-make' will look for (if non-nil).")
 or you might like a small font  
   
   \(setq sml-display-frame-alist  
         \(cons '\(font . \"7x14\"\) sml-display-frame-alist\)\)  
   
 in your `inferior-sml-load-hook', say. The parameters  
   
   '\(\(unsplittable . t\) \(icon-name . \"*sml*\"\)\)  
   
 are always added to sml-display-frame-alist by default, though the value of  
 icon-name is actually culled from `sml-program-name'.  
   
 See also the documentation for `modify-frame-parameters'.")  
   
 (defvar sml-dedicated-frame (if window-system t nil)  
   "*If non-nil, interaction buffers display in their own frame.  
 Default is equivalent to variable `window-system'.  
 If you reset this variable after starting the compiler, you might have  
 to reset the window-dedicated property of the window displaying the  
 interaction buffer. See `set-window-dedicated-p'.")  
127    
128  ;;(defvar sml-raise-on-error nil  ;;(defvar sml-raise-on-error nil
129  ;;  "*When non-nil, `sml-next-error' will raise the ML process's frame.")  ;;  "*When non-nil, `sml-next-error' will raise the ML process's frame.")
# Line 163  Line 140 
140  doesn't work very well -- e.g., SML/NJ nor Poly/ML incorrectly report  doesn't work very well -- e.g., SML/NJ nor Poly/ML incorrectly report
141  the line # of errors occurring in std_in.")  the line # of errors occurring in std_in.")
142    
143  (defvar sml-temp-file (make-temp-name "/tmp/ml")  (defvar sml-temp-file
144      (make-temp-name
145       (concat (file-name-as-directory (or (getenv "TMPDIR") "/tmp")) "/ml"))
146    "*Temp file that emacs uses to communicate with the ML process.    "*Temp file that emacs uses to communicate with the ML process.
147  See `sml-temp-threshold'. Defaults to \(make-temp-name \"/tmp/ml\"\)")  See `sml-temp-threshold'. Defaults to \(make-temp-name \"/tmp/ml\"\)")
148    
# Line 225  Line 204 
204  Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;  Set to \"use \\\"%s\\\"\" for SML/NJ or Edinburgh ML;
205  set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")  set to \"PolyML.use \\\"%s\\\"\" for Poly/ML, etc.")
206    
207  (defvar sml-cd-command "System.Directory.cd \"%s\""  (defvar sml-cd-command "OS.FileSys.chDir \"%s\""
208    "*Command template for changing working directories under ML.    "*Command template for changing working directories under ML.
209  Set this to nil if your compiler can't change directories.  Set this to nil if your compiler can't change directories.
210    
# Line 285  Line 264 
264  (defvar sml-error-regexp sml-smlnj-error-regexp  (defvar sml-error-regexp sml-smlnj-error-regexp
265    "*Regexp for matching \(the start of\) an error message.")    "*Regexp for matching \(the start of\) an error message.")
266    
267    ;; font-lock support
268    (defvar inferior-sml-font-lock-keywords
269      `((,(concat "\\(" sml-prompt-regexp "\\)\\(.*\\)")
270         (1 font-lock-prompt-face)
271         (2 font-lock-command-face keep))
272        (,sml-error-regexp . font-lock-warning-face)
273        ("^GC #.*" . font-lock-comment-face)
274        ("^\\[.*\\]" . font-lock-comment-face)))
275    
276    ;; default faces values
277    (defvar font-lock-prompt-face
278      (if (facep 'font-lock-prompt-face)
279          'font-lock-prompt-face
280        'font-lock-keyword-face))
281    (defvar font-lock-command-face
282      (if (facep 'font-lock-command-face)
283          'font-lock-command-face
284        'font-lock-function-name-face))
285    
286    (defvar inferior-sml-font-lock-defaults
287      '(inferior-sml-font-lock-keywords nil nil nil nil))
288    
289  (defun sml-smlnj-error-parser (pt)  (defun sml-smlnj-error-parser (pt)
290   "This parses the SML/NJ error message at PT into a 5 element list   "This parses the SML/NJ error message at PT into a 5 element list
291    
# Line 341  Line 342 
342   sml-program-name  <option> \(default \"sml\"\)   sml-program-name  <option> \(default \"sml\"\)
343   sml-default-arg   <option> \(default \"\"\)   sml-default-arg   <option> \(default \"\"\)
344   sml-use-command   \"use \\\"%s\\\"\"   sml-use-command   \"use \\\"%s\\\"\"
345   sml-cd-command    \"System.Directory.cd \\\"%s\\\"\"   sml-cd-command    \"OS.FileSys.chDir \\\"%s\\\"\"
346   sml-prompt-regexp \"^[\\-=] *\"   sml-prompt-regexp \"^[\\-=] *\"
347   sml-error-regexp  sml-sml-nj-error-regexp   sml-error-regexp  sml-sml-nj-error-regexp
348   sml-error-parser  'sml-sml-nj-error-parser"   sml-error-parser  'sml-sml-nj-error-parser"
# Line 355  Line 356 
356       (setq sml-default-arg  arg)       (setq sml-default-arg  arg)
357       ;; buffer-local (compiler-local) variables       ;; buffer-local (compiler-local) variables
358       (setq-default sml-use-command   "use \"%s\""       (setq-default sml-use-command   "use \"%s\""
359                     sml-cd-command    "System.Directory.cd \"%s\""                     sml-cd-command    "OS.FileSys.chDir \"%s\""
360                     sml-prompt-regexp "^[\-=] *"                     sml-prompt-regexp "^[\-=] *"
361                     sml-error-regexp  sml-smlnj-error-regexp                     sml-error-regexp  sml-smlnj-error-regexp
362                     sml-error-parser  'sml-smlnj-error-parser)                     sml-error-parser  'sml-smlnj-error-parser)
# Line 487  Line 488 
488    (sml-mode-variables)    (sml-mode-variables)
489    
490    ;; For sequencing through error messages:    ;; For sequencing through error messages:
491    (make-local-variable 'sml-error-cursor)  
492    (setq sml-error-cursor (marker-position (point-max-marker)))    (set (make-local-variable 'sml-error-cursor)
493    (make-local-variable 'sml-error-barrier)         (marker-position (point-max-marker)))
494    (setq sml-error-barrier (marker-position (point-max-marker)))    (set (make-local-variable 'sml-error-barrier)
495    (make-local-variable 'sml-real-file)         (marker-position (point-max-marker)))
496    (setq sml-real-file (cons nil 0))    (set (make-local-variable 'sml-real-file) (cons nil 0))
497      (set (make-local-variable 'font-lock-defaults)
498           inferior-sml-font-lock-defaults)
499    
500    (make-local-variable 'sml-use-command)    (make-local-variable 'sml-use-command)
501    (make-local-variable 'sml-cd-command)    (make-local-variable 'sml-cd-command)
# Line 511  Line 514 
514  ;;; FOR RUNNING ML FROM EMACS  ;;; FOR RUNNING ML FROM EMACS
515    
516  ;;;###autoload  ;;;###autoload
517  (defun sml (&optional pfx)  (defun run-sml (&optional pfx)
518    "Run an inferior ML process, input and output via buffer *sml*.    "Run an inferior ML process, input and output via buffer *sml*.
519  With a prefix argument, this command allows you to specify any command  With a prefix argument, this command allows you to specify any command
520  line options to pass to the complier. The command runs hook functions  line options to pass to the complier. The command runs hook functions
# Line 542  Line 545 
545           (bname (format "*%s*" pname))           (bname (format "*%s*" pname))
546           (args (if (equal arg "") () (sml-args-to-list arg))))           (args (if (equal arg "") () (sml-args-to-list arg))))
547      (if (comint-check-proc bname)      (if (comint-check-proc bname)
548          (sml-pop-to-buffer t)           ;do nothing but switch buffer          (pop-to-buffer (sml-proc-buffer)) ;do nothing but switch buffer
549        (setq sml-buffer        (setq sml-buffer
550              (if (null args)              (if (null args)
551                  ;; there is a good reason for this; to ensure                  ;; there is a good reason for this; to ensure
# Line 583  Line 586 
586    "Switch to the ML process buffer.    "Switch to the ML process buffer.
587  With prefix argument, positions cursor at point, otherwise at end of buffer."  With prefix argument, positions cursor at point, otherwise at end of buffer."
588    (interactive "P")    (interactive "P")
589    (sml-pop-to-buffer t)    (if (sml-noproc) (save-excursion (run-sml t)))
590      (pop-to-buffer (sml-proc-buffer))
591    (cond ((not eob-p)    (cond ((not eob-p)
592           (push-mark (point) t)           (push-mark (point) t)
593           (goto-char (point-max)))))           (goto-char (point-max)))))
# Line 603  Line 607 
607    
608  See variables `sml-temp-threshold', `sml-temp-file' and `sml-use-command'."  See variables `sml-temp-threshold', `sml-temp-file' and `sml-use-command'."
609    (interactive "r\nP")    (interactive "r\nP")
610    (if (sml-noproc) (save-excursion (sml t)))    (if (sml-noproc) (save-excursion (run-sml t)))
611    (cond ((equal start end)    (cond ((equal start end)
612           (message "The region is zero (ignored)"))           (message "The region is zero (ignored)"))
613          ((and sml-use-command          ((and sml-use-command
# Line 691  Line 695 
695    
696  ;; simplified from frame.el in Emacs: special-display-popup-frame...  ;; simplified from frame.el in Emacs: special-display-popup-frame...
697    
 ;; Display BUFFER in its own frame, reusing an existing window if any.  
 ;; Return the window chosen.  
   
 (defun sml-display-popup-frame (buffer &optional args)  
   (let ((window (get-buffer-window buffer t)))  
     (if window  
         ;; If we have a window already, make it visible.  
         (let ((frame (window-frame window)))  
           (make-frame-visible frame)  
           (raise-frame frame)  
           window)  
       ;; otherwise no window yet, make one in a new frame.  
       (let* ((frame (make-frame (append args sml-display-frame-alist)))  
              (window (frame-selected-window frame)))  
         (set-window-buffer window buffer)  
         ;; XEmacs mostly ignores this  
         (set-window-dedicated-p window t)  
         window))))  
   
698  (defun sml-proc-frame ()  (defun sml-proc-frame ()
699    "Returns the current ML process buffer's frame, or creates one first."    "Returns the current ML process buffer's frame, or creates one first."
700    (let ((buffer (sml-proc-buffer)))    (let ((buffer (sml-proc-buffer)))
701      (window-frame      (window-frame (display-buffer buffer))))
702       (or  
703        ;; if its already displayed on some frame, take that as default...  ;;(defun sml-pop-to-buffer (warp)
704        (get-buffer-window buffer t)  ;;  "(Towards) handling multiple frames properly.
705        ;; ...irrespective of what sml-dedicated-frame says, otherwise  ;;Raises the frame, and warps the mouse over there, only if WARP is non-nil."
706        ;; create a new frame (or raise an old one) perhaps...  ;;  (let ((current (window-frame (selected-window)))
707        (and sml-dedicated-frame  ;;        (buffer  (sml-proc-buffer)))
708             (sml-display-popup-frame buffer  ;;    (let ((frame (sml-proc-frame)))
709                                      (list (cons 'icon-name buffer)  ;;      (if (eq current frame)
710                                            '(unsplittable . t))))  ;;          (pop-to-buffer buffer)           ; stay on the same frame.
711        ;; ...or default to the current frame anyway.  ;;        (select-frame frame)               ; XEmacs sometimes moves focus.
712        (frame-selected-window)))))  ;;        (select-window (get-buffer-window buffer)) ; necc. for XEmacs
713    ;;        ;; (raise-frame frame)
714  (defun sml-pop-to-buffer (warp)  ;;        (if warp (sml-warp-mouse frame))))))
   "(Towards) handling multiple frames properly.  
 Raises the frame, and warps the mouse over there, only if WARP is non-nil."  
   (let ((current (window-frame (selected-window)))  
         (buffer  (sml-proc-buffer)))  
     (let ((frame (sml-proc-frame)))  
       (if (eq current frame)  
           (pop-to-buffer buffer)           ; stay on the same frame.  
         (select-frame frame)               ; XEmacs sometimes moves focus.  
         (select-window (get-buffer-window buffer)) ; necc. for XEmacs  
         ;; (raise-frame frame)  
         (if warp (sml-warp-mouse frame))))))  
715    
716    
717  ;;; H A C K   A T T A C K !   X E M A C S   V E R S U S   E M A C S  ;;; H A C K   A T T A C K !   X E M A C S   V E R S U S   E M A C S
# Line 812  Line 786 
786  the command to send to the ML process\; a trailing \"\;\\n\" will be added  the command to send to the ML process\; a trailing \"\;\\n\" will be added
787  automatically."  automatically."
788    (interactive "P")    (interactive "P")
789    (if (sml-noproc) (save-excursion (sml t)))    (if (sml-noproc) (save-excursion (run-sml t)))
790    (if sml-use-command    (if sml-use-command
791        (let ((file        (let ((file
792               (car (comint-get-source "Load ML file: " sml-prev-l/c-dir/file               (car (comint-get-source "Load ML file: " sml-prev-l/c-dir/file
# Line 836  Line 810 
810    (interactive "DSML Directory: ")    (interactive "DSML Directory: ")
811    (let* ((buf (sml-proc-buffer))    (let* ((buf (sml-proc-buffer))
812           (proc (get-buffer-process buf))           (proc (get-buffer-process buf))
813           (dir (expand-file-name dir)))           (dir (expand-file-name dir))
814             (string (concat (format sml-cd-command dir) ";\n")))
815      (save-excursion      (save-excursion
816        (set-buffer buf)        (set-buffer buf)
817        (if sml-cd-command        (goto-char (point-max))
818            (process-send-string proc        (insert string)
819                                 (concat (format sml-cd-command dir) ";\n")))        (set-marker (process-mark proc) (point))
820          (if sml-cd-command (process-send-string proc string))
821        (cd dir))        (cd dir))
822      (setq sml-prev-l/c-dir/file (cons dir nil))))      (setq sml-prev-l/c-dir/file (cons dir nil))))
823    
824  ;;; PARSING ERROR MESSAGES  (defun sml-send-command (cmd &optional dir)
825      "Send string to ML process, display this string in ML's buffer"
826      (if (sml-noproc) (save-excursion (run-sml t)))
827      (let* ((my-dir (or dir (expand-file-name default-directory)))
828             (cd-cmd (if my-dir
829                         (concat (format sml-cd-command my-dir) "; ")
830                       ""))
831             (buf (sml-proc-buffer))
832             (proc (get-buffer-process buf))
833             (string (concat cd-cmd cmd ";\n")))
834        (save-some-buffers t)
835        (save-excursion
836          (sml-update-cursor buf)
837          (set-buffer buf)
838          (goto-char (point-max))
839          (insert string)
840          (if my-dir (cd my-dir))
841          (set-marker (process-mark proc) (point))
842          (process-send-string proc string))
843        (switch-to-sml t)))
844    
845    (defun sml-make (command)
846      "re-make a system using (by default) CM.
847       The exact command used can be specified by providing a prefix argument."
848      (interactive
849       ;; code taken straight from compile.el
850       (if (or current-prefix-arg (not sml-make-command))
851           (list (read-from-minibuffer "Compile command: "
852                                     sml-make-command nil nil
853                                     '(compile-history . 1)))
854         (list sml-make-command)))
855      (setq sml-make-command command)
856      ;; try to find a makefile up the sirectory tree
857      (let ((dir (and sml-make-file-name (expand-file-name default-directory))))
858        (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
859          (let ((newdir (file-name-directory (directory-file-name dir))))
860            (setq dir (if (equal newdir dir) nil newdir))))
861        (sml-send-command command dir)))
862    
863  ;; to a very large extent "find-file-other-window" works admirably when the  ;;; PARSING ERROR MESSAGES
 ;; compiler is running in a dedicated, *unsplittable* window, and so all  
 ;; the goop in sml-file-other-frame-or-window is of questionable worth.  
 ;; unhappily, XEmacs doesn't (yet, will it ever?) implement the window  
 ;; unsplittable property, hence this nonsense...  
   
 (defun sml-file-other-frame-or-window (file &optional window)  
   "Find or make another frame on which to display FILE.  
 Start in ML interaction buffer, by hypothesis, and try not to use  
 this window to display the file (with bugs in it). FILE may already  
 be on display somewhere, so use that frame by default; otherwise,  
 try to find a window that is displaying an sml buffer; if there is  
 no such frame/window, find the nearest non-dedicated buffer or,  
 in the last resort, create a whole new frame.  
   
 If optional WINDOW is supplied, just use that window to display FILE."  
   (if window  
       (progn                            ; just reuse it  
         (set-window-buffer window (find-file-noselect file))  
         (select-window window))         ; assume "this" frame's selected)  
     (let* ((buf (find-file-noselect file))  
            (win (get-buffer-window buf t))  
            (frm (if win (window-frame win))))  
       (if frm  
           ;; buf is displayed in win on some frame: select frame & window  
           (progn (select-window win) (raise-frame (select-frame frm)))  
         (let* ((frame (selected-frame))   ;current frame & window  
                (window (selected-window)))  
           ;; look through all (but minibuffer) windows for an sml buffer  
           (while (and (not (eq window  
                                (select-window  
                                 (previous-window (selected-window) 'mini t))))  
                       (not (memq major-mode sml-source-modes))))  
           (if (not (eq window (selected-window)))  
               ;; found window displaying an sml buffer: use that window & frame  
               (raise-frame (select-frame (window-frame (selected-window))))  
             ;; otherwise, cycle through frames looking for a spare one  
             ;; select-frame also selects the top (or root) window  
             (while (and (not (eq frame (select-frame (previous-frame  
                                                       (selected-frame) nil))))  
                         (window-dedicated-p (selected-window))))  
             ;; if no suitable frame, create one and (belt & braces) select it  
             (if (eq frame (selected-frame))  
                 ;; sml-dedicated-frame iff window-dedicated-p (selected-window)  
                 (if sml-dedicated-frame  
                     (progn  
                       (sml-warp-mouse (select-frame (make-frame)))  
                       (set-window-buffer  
                        (frame-selected-window (selected-frame)) buf))  
                   (switch-to-buffer-other-window buf))  
               (raise-frame (selected-frame))))  
           (switch-to-buffer buf))))))  
864    
865  ;; This should need no modification to support other compilers.  ;; This should need no modification to support other compilers.
866    
# Line 946  Line 908 
908      (sml-error-overlay 'undo 1 1      (sml-error-overlay 'undo 1 1
909                         (and sml-error-file (get-file-buffer sml-error-file)))                         (and sml-error-file (get-file-buffer sml-error-file)))
910      ;; go to interaction buffer but don't raise it's frame      ;; go to interaction buffer but don't raise it's frame
911      (sml-pop-to-buffer nil)      (pop-to-buffer (sml-proc-buffer))
912      ;; go to the last remembered error, and search for the next one.      ;; go to the last remembered error, and search for the next one.
913      (goto-char sml-error-cursor)      (goto-char sml-error-cursor)
914      (if (not (re-search-forward sml-error-regexp (point-max) t))      (if (not (re-search-forward sml-error-regexp (point-max) t))
# Line 988  Line 950 
950          (if (not (file-readable-p file))          (if (not (file-readable-p file))
951              (sml-bottle (concat "Can't read " file))              (sml-bottle (concat "Can't read " file))
952            ;; instead of (find-file-other-window file) to lookup the file            ;; instead of (find-file-other-window file) to lookup the file
953            (sml-file-other-frame-or-window file sml-window)            (find-file-other-window file)
954            ;; no good if the buffer's narrowed, still...            ;; no good if the buffer's narrowed, still...
955            (goto-char (or pos 1))        ; line 1 if no tmp file            (goto-char (or pos 1))        ; line 1 if no tmp file
956            (forward-line (1- line0))            (forward-line (1- line0))
# Line 1017  Line 979 
979  ;;; Set up the inferior mode keymap, using sml-mode bindings...  ;;; Set up the inferior mode keymap, using sml-mode bindings...
980    
981  (cond ((not inferior-sml-mode-map)  (cond ((not inferior-sml-mode-map)
982         (setq inferior-sml-mode-map         (setq inferior-sml-mode-map (nconc (make-sparse-keymap) comint-mode-map))
              (copy-keymap comint-mode-map))  
983         (install-sml-keybindings inferior-sml-mode-map)         (install-sml-keybindings inferior-sml-mode-map)
984         (define-key inferior-sml-mode-map "\C-c\C-s" 'sml)         (define-key inferior-sml-mode-map "\C-c\C-s" 'run-sml)
985         (define-key inferior-sml-mode-map "\t"       'comint-dynamic-complete)))         (define-key inferior-sml-mode-map "\t"       'comint-dynamic-complete)))
986    
987  ;;; H A C K   A T T A C K !   X E M A C S   /   E M A C S   K E Y S  ;;; H A C K   A T T A C K !   X E M A C S   /   E M A C S   K E Y S

Legend:
Removed from v.32  
changed lines
  Added in v.33

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0