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/trunk/sml-mode/sml-proc.el
ViewVC logotype

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

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

revision 39, Sat Mar 14 04:41:37 1998 UTC revision 319, Mon Jun 7 22:47:00 1999 UTC
# Line 365  Line 365 
365    
366  ;;; CODE  ;;; CODE
367    
368  (defvar inferior-sml-mode-map nil)  (defmap inferior-sml-mode-map
369      '(("\C-c\C-s" . run-sml)
370        ("\t"       . comint-dynamic-complete))
371      "Keymap for inferior-sml mode"
372      :inherit (list sml-bindings comint-mode-map))
373    
374    
375  ;; buffer-local  ;; buffer-local
376    
377  (defvar sml-error-file nil)             ; file from which the last error came  (defvar sml-error-file nil)             ; file from which the last error came
378  (defvar sml-real-file nil)              ; used for finding source errors  (defvar sml-real-file nil)              ; used for finding source errors
379  (defvar sml-error-cursor nil)           ;   ditto  (defvar sml-error-cursor nil)           ;   ditto
 (defvar sml-error-barrier nil)          ;   ditto  
380    
381  (defun sml-proc-buffer ()  (defun sml-proc-buffer ()
382    "Returns the current ML process buffer,    "Returns the current ML process buffer,
# Line 489  Line 493 
493    
494    ;; For sequencing through error messages:    ;; For sequencing through error messages:
495    
496    (set (make-local-variable 'sml-error-cursor)    (set (make-local-variable 'sml-error-cursor) (point-max-marker))
497         (marker-position (point-max-marker)))    (set (make-local-variable 'sml-real-file) nil)
   (set (make-local-variable 'sml-error-barrier)  
        (marker-position (point-max-marker)))  
   (set (make-local-variable 'sml-real-file) (cons nil 0))  
498    (set (make-local-variable 'font-lock-defaults)    (set (make-local-variable 'font-lock-defaults)
499         inferior-sml-font-lock-defaults)         inferior-sml-font-lock-defaults)
500    
# Line 626  Line 627 
627           (comint-send-string (sml-proc) ";\n")))           (comint-send-string (sml-proc) ";\n")))
628    (if and-go (switch-to-sml nil)))    (if and-go (switch-to-sml nil)))
629    
630  ;; Update the buffer-local variables sml-real-file and sml-error-barrier  ;; Update the buffer-local variables sml-real-file
631  ;; in the process buffer:  ;; in the process buffer:
632    
633  (defun sml-update-barrier (file pos)  (defun sml-update-barrier (&optional file pos)
634    (let ((buf (current-buffer)))    (let ((buf (current-buffer)))
635      (unwind-protect      (unwind-protect
636          (let* ((proc (sml-proc))          (let* ((proc (sml-proc))
637                 (pmark (marker-position (process-mark proc))))                 (pmark (marker-position (process-mark proc))))
638            (set-buffer (process-buffer proc))            (set-buffer (process-buffer proc))
639            ;; update buffer local variables            ;; update buffer local variables
640            (setq sml-real-file (and file (cons file pos)))            (setq sml-real-file (and file (cons file pos))))
           (setq sml-error-barrier pmark))  
641        (set-buffer buf))))        (set-buffer buf))))
642    
643  ;; Update the buffer-local error-cursor in proc-buffer to be its  ;; Update the buffer-local error-cursor in proc-buffer to be its
# Line 650  Line 650 
650                 (pmark (marker-position (process-mark proc))))                 (pmark (marker-position (process-mark proc))))
651            (set-buffer proc-buffer)            (set-buffer proc-buffer)
652            ;; update buffer local variable            ;; update buffer local variable
653            (setq sml-error-cursor pmark))            (set-marker sml-error-cursor pmark))
654        (set-buffer buf))))        (set-buffer buf))))
655    
656  ;; This is quite bogus, so it isn't bound to a key by default.  ;; This is quite bogus, so it isn't bound to a key by default.
# Line 667  Line 667 
667      (sml-send-region (point) (mark)))      (sml-send-region (point) (mark)))
668    (if and-go (switch-to-sml nil)))    (if and-go (switch-to-sml nil)))
669    
670    (defvar sml-source-modes '(sml-mode)
671      "*Used to determine if a buffer contains ML source code.
672    If it's loaded into a buffer that is in one of these major modes, it's
673    considered an ML source file by `sml-load-file'. Used by these commands
674    to determine defaults.")
675    
676  ;;;###autoload  ;;;###autoload
677  (defun sml-send-buffer (&optional and-go)  (defun sml-send-buffer (&optional and-go)
678    "Send buffer to inferior shell running ML process.    "Send buffer to inferior shell running ML process.
# Line 700  Line 706 
706    (let ((buffer (sml-proc-buffer)))    (let ((buffer (sml-proc-buffer)))
707      (window-frame (display-buffer buffer))))      (window-frame (display-buffer buffer))))
708    
 ;;(defun sml-pop-to-buffer (warp)  
 ;;  "(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))))))  
   
   
709  ;;; 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
710    
711  ;; Only these two functions have to dance around the inane differences  ;; Only these two functions have to dance around the inane differences
# Line 767  Line 759 
759    
760  ;;; LOADING AND IMPORTING SOURCE FILES:  ;;; LOADING AND IMPORTING SOURCE FILES:
761    
 (defvar sml-source-modes '(sml-mode)  
   "*Used to determine if a buffer contains ML source code.  
 If it's loaded into a buffer that is in one of these major modes, it's  
 considered an ML source file by `sml-load-file'. Used by these commands  
 to determine defaults.")  
   
762  (defvar sml-prev-l/c-dir/file nil  (defvar sml-prev-l/c-dir/file nil
763    "Caches the (directory . file) pair used in the last `sml-load-file'    "Caches the (directory . file) pair used in the last `sml-load-file'
764  or `sml-cd' command. Used for determining the default in the next one.")  or `sml-cd' command. Used for determining the default in the next one.")
# Line 821  Line 807 
807        (cd dir))        (cd dir))
808      (setq sml-prev-l/c-dir/file (cons dir nil))))      (setq sml-prev-l/c-dir/file (cons dir nil))))
809    
810  (defun sml-send-command (cmd &optional dir)  (defun sml-send-command (cmd &optional dir print)
811    "Send string to ML process, display this string in ML's buffer"    "Send string to ML process, display this string in ML's buffer"
812    (if (sml-noproc) (save-excursion (run-sml t)))    (if (sml-noproc) (save-excursion (run-sml t)))
813    (let* ((my-dir (or dir (expand-file-name default-directory)))    (let* ((my-dir (or dir (expand-file-name default-directory)))
814           (cd-cmd (if my-dir           (cd-cmd (if my-dir (concat (format sml-cd-command my-dir) "; ") ""))
                      (concat (format sml-cd-command my-dir) "; ")  
                    ""))  
815           (buf (sml-proc-buffer))           (buf (sml-proc-buffer))
816             (win (get-buffer-window buf 'visible))
817           (proc (get-buffer-process buf))           (proc (get-buffer-process buf))
818           (string (concat cd-cmd cmd ";\n")))           (string (concat cd-cmd cmd ";\n")))
819      (save-some-buffers t)      (save-some-buffers t)
820      (save-excursion      (save-excursion
       (sml-update-cursor buf)  
821        (set-buffer buf)        (set-buffer buf)
822          (when win (select-window win))
823        (goto-char (point-max))        (goto-char (point-max))
824        (insert string)        (when print (insert string))
825        (if my-dir (cd my-dir))        (when my-dir (cd my-dir))
826        (set-marker (process-mark proc) (point))        (sml-update-cursor buf)
827        (process-send-string proc string))        (sml-update-barrier)
828          (set-marker (process-mark proc) (point-max))
829          (comint-send-string proc string))
830      (switch-to-sml t)))      (switch-to-sml t)))
831    
832  (defun sml-make (command)  (defun sml-make (command)
# Line 858  Line 845 
845      (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))      (while (and dir (not (file-exists-p (concat dir sml-make-file-name))))
846        (let ((newdir (file-name-directory (directory-file-name dir))))        (let ((newdir (file-name-directory (directory-file-name dir))))
847          (setq dir (if (equal newdir dir) nil newdir))))          (setq dir (if (equal newdir dir) nil newdir))))
848      (sml-send-command command dir)))      (sml-send-command command dir t)))
849    
850  ;;; PARSING ERROR MESSAGES  ;;; PARSING ERROR MESSAGES
851    
# Line 899  Line 886 
886    (error msg))    (error msg))
887    
888  (defun sml-do-next-error ()  (defun sml-do-next-error ()
889    "The buisiness end of `sml-next-error' (qv)"    "The business end of `sml-next-error' (qv)"
890    (let ((case-fold-search nil)    (let ((case-fold-search nil)
891          ;; set this variable iff we called sml-next-error in a SML buffer          ;; set this variable iff we called sml-next-error in a SML buffer
892          (sml-window (if (memq major-mode sml-source-modes) (selected-window)))          (sml-window (if (memq major-mode sml-source-modes) (selected-window)))
# Line 910  Line 897 
897      ;; go to interaction buffer but don't raise it's frame      ;; go to interaction buffer but don't raise it's frame
898      (pop-to-buffer (sml-proc-buffer))      (pop-to-buffer (sml-proc-buffer))
899      ;; go to the last remembered error, and search for the next one.      ;; go to the last remembered error, and search for the next one.
900      (goto-char sml-error-cursor)      (goto-char (marker-position sml-error-cursor))
901      (if (not (re-search-forward sml-error-regexp (point-max) t))      (if (not (re-search-forward sml-error-regexp (point-max) t))
902          ;; no more errors -- move point to the sml prompt at the end          ;; no more errors -- move point to the sml prompt at the end
903          (progn          (progn
# Line 918  Line 905 
905            (if sml-window (select-window sml-window)) ;return there, perhaps            (if sml-window (select-window sml-window)) ;return there, perhaps
906            (message "No error message(s) found."))            (message "No error message(s) found."))
907        ;; error found: point is at end of last match; set the cursor posn.        ;; error found: point is at end of last match; set the cursor posn.
908        (setq sml-error-cursor (point))        (set-marker sml-error-cursor (point))
909        ;; move the SML window's text up to this line        ;; move the SML window's text up to this line
910        (set-window-start (get-buffer-window proc-buffer) (match-beginning 0))        (set-window-start (get-buffer-window proc-buffer) (match-beginning 0))
911        (let* ((pos)        (let* ((pos)
# Line 937  Line 924 
924              (sml-bottle "Sorry, can't locate errors on std_in.")              (sml-bottle "Sorry, can't locate errors on std_in.")
925            (if (string= file sml-temp-file)            (if (string= file sml-temp-file)
926                ;; errors found in tmp file; seek the real file                ;; errors found in tmp file; seek the real file
               (if (< (point) sml-error-barrier)  
                   ;; weird. user cleared *sml* and use'd the tmp file?  
                   (sml-bottle "Temp file error report is not current.")  
927                  (if (not (car sml-real-file))                  (if (not (car sml-real-file))
928                      ;; sent from a buffer w/o a file attached.                      ;; sent from a buffer w/o a file attached.
929                      ;; DEAL WITH THIS EVENTUALLY.                      ;; DEAL WITH THIS EVENTUALLY.
930                      (sml-bottle "No real file associated with the temp file.")                      (sml-bottle "No real file associated with the temp file.")
931                    ;; real file and error-barrier                    ;; real file and error-barrier
932                    (setq file (car sml-real-file))                    (setq file (car sml-real-file))
933                    (setq pos (cdr sml-real-file))))))                  (setq pos (cdr sml-real-file)))))
934          (if (not (file-readable-p file))          (if (not (file-readable-p file))
935              (sml-bottle (concat "Can't read " file))              (sml-bottle (concat "Can't read " file))
936            ;; instead of (find-file-other-window file) to lookup the file            ;; instead of (find-file-other-window file) to lookup the file
# Line 976  Line 960 
960    (sml-update-cursor (sml-proc-buffer))    (sml-update-cursor (sml-proc-buffer))
961    (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))    (if (eq major-mode 'sml-inferior-mode) (goto-char (point-max))))
962    
 ;;; Set up the inferior mode keymap, using sml-mode bindings...  
   
 (cond ((not inferior-sml-mode-map)  
        (setq inferior-sml-mode-map (nconc (make-sparse-keymap) comint-mode-map))  
        (install-sml-keybindings inferior-sml-mode-map)  
        (define-key inferior-sml-mode-map "\C-c\C-s" 'run-sml)  
        (define-key inferior-sml-mode-map "\t"       'comint-dynamic-complete)))  
   
963  ;;; 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
964    
965  (if window-system  (if window-system

Legend:
Removed from v.39  
changed lines
  Added in v.319

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