/[cmucl]/src/hemlock/lispeval.lisp
ViewVC logotype

Diff of /src/hemlock/lispeval.lisp

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

revision 1.1 by ram, Wed May 9 13:05:00 1990 UTC revision 1.2 by ram, Fri Feb 11 21:53:23 1994 UTC
# Line 1  Line 1 
1  ;;; -*- Package: Hemlock; Log: hemlock.log -*-  ;;; -*- Package: Hemlock; Log: hemlock.log -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the Spice Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
5  ;;; Carnegie-Mellon University, and has been placed in the public domain.  ;;; Carnegie Mellon University, and has been placed in the public domain.
6  ;;; Spice Lisp is currently incomplete and under active development.  ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7  ;;; If you want to use this code or any part of Spice Lisp, please contact  ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8  ;;; Scott Fahlman (FAHLMAN@CMUC).  ;;;
9    (ext:file-comment
10      "$Header$")
11    ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
14  ;;; This file contains code for sending requests to eval servers and the  ;;; This file contains code for sending requests to eval servers and the
# Line 39  Line 42 
42    error-file                  ; The file to dump errors into    error-file                  ; The file to dump errors into
43    load                        ; Load compiled file or not?    load                        ; Load compiled file or not?
44    (errors 0)                  ; Count of compiler errors.    (errors 0)                  ; Count of compiler errors.
45    (warnings 0))               ; Count of compiler warnings.    (warnings 0)                ; Count of compiler warnings.
46      (notes 0))                  ; Count of compiler notes.
47  ;;;  ;;;
48  (defun %print-note (note stream d)  (defun %print-note (note stream d)
49    (declare (ignore d))    (declare (ignore d))
# Line 97  Line 101 
101      (setf (note-state note) :pending)      (setf (note-state note) :pending)
102      (message "Sending ~A." (note-context note))      (message "Sending ~A." (note-context note))
103      (case (note-kind note)      (case (note-kind note)
104          (:dylan-eval
105           (wire:remote wire
106             (server-eval-dylan-text remote
107                                     (note-package note)
108                                     (note-text note)
109                                     (and ts (ts-data-stream ts)))))
110        (:eval        (:eval
111         (wire:remote wire         (wire:remote wire
112           (server-eval-text remote           (server-eval-text remote
113                             (note-package note)                             (note-package note)
114                             (note-text note)                             (note-text note)
115                             (and ts (ts-data-stream ts)))))                             (and ts (ts-data-stream ts)))))
116          (:dylan-compile
117           (wire:remote wire
118             (server-compile-dylan-text remote
119                                        (note-package note)
120                                        (note-text note)
121                                        (note-input-file note)
122                                        (and ts (ts-data-stream ts))
123                                        (and bg (ts-data-stream bg)))))
124        (:compile        (:compile
125         (wire:remote wire         (wire:remote wire
126           (server-compile-text remote           (server-compile-text remote
# Line 158  Line 176 
176           (line (mark-line           (line (mark-line
177                  (buffer-end-mark                  (buffer-end-mark
178                   (server-info-background-buffer server))))                   (server-info-background-buffer server))))
179           (message (format nil "~:(~A~) in ~A during ~A."           (message (format nil "~:(~A~) ~@[in ~A ~]during ~A."
180                            severity                            severity
181                            function                            function
182                            (note-context note)))                            (note-context note)))
# Line 166  Line 184 
184                                   :message message                                   :message message
185                                   :line line)))                                   :line line)))
186      (message "~A" message)      (message "~A" message)
187        (case severity
188          (:error (incf (note-errors note)))
189          (:warning (incf (note-warnings note)))
190          (:note (incf (note-notes note))))
191      (let ((region (case (note-kind note)      (let ((region (case (note-kind note)
192                      (:compile                      ((:compile :dylan-compile)
193                       (note-region note))                       (note-region note))
194                      (:compile-file                      (:compile-file
195                       (buffer-region (note-buffer note)))                       (let ((buff (note-buffer note)))
196                           (and buff (buffer-region buff))))
197                      (t                      (t
198                       (error "Compiler error in ~S?" note)))))                       (error "Compiler error in ~S?" note)))))
199        (when region        (when region
# Line 208  Line 231 
231      (setf (note-server note) nil)      (setf (note-server note) nil)
232    
233      (if abortp      (if abortp
234        (loud-message "The ~A aborted." (note-context note))          (loud-message "The ~A aborted." (note-context note))
235        (let ((errors (note-errors note))          (let ((errors (note-errors note))
236              (warnings (note-warnings note)))                (warnings (note-warnings note))
237          (message "The ~A complete.~@[ ~D error~:P~]~@[ ~D warning~:P~]"                (notes (note-notes note)))
238                   (note-context note)            (message "The ~A complete.~
239                   (and (plusp errors) errors)                      ~@[ ~D error~:P~]~@[ ~D warning~:P~]~@[ ~D note~:P~]"
240                   (and (plusp warnings) warnings))))                     (note-context note)
241                       (and (plusp errors) errors)
242                       (and (plusp warnings) warnings)
243                       (and (plusp notes) notes))))
244    
245      (let ((region (note-region note)))      (let ((region (note-region note)))
246        (when (regionp region)        (when (regionp region)
# Line 228  Line 254 
254                 file)                 file)
255        (if (> (file-write-date file)        (if (> (file-write-date file)
256               (note-output-date note))               (note-output-date note))
257          (let ((new-name (make-pathname :type "fasl"            (let ((new-name (make-pathname :type "fasl"
258                                         :defaults (note-input-file note))))                                           :defaults (note-input-file note))))
259            (rename-file file new-name)              (rename-file file new-name)
260            (mach:unix-chmod (namestring new-name) #o644))              (unix:unix-chmod (namestring new-name) #o644))
261          (delete-file file)))            (delete-file file)))
262      (maybe-send-next-note server))      (maybe-send-next-note server))
263    (values))    (values))
264    
# Line 255  Line 281 
281    (when (server-info-notes server-info)    (when (server-info-notes server-info)
282      (editor-error "Server ~S is currently busy.  See \"List Operations\"."      (editor-error "Server ~S is currently busy.  See \"List Operations\"."
283                    (server-info-name server-info)))                    (server-info-name server-info)))
284    (multiple-value-bind (values error)    (multiple-value-bind
285                         (wire:remote-value (server-info-wire server-info)        (values error)
286                           (server-eval-form package form))        (if (dylan-mode-p)
287              (wire:remote-value (server-info-wire server-info)
288                (server-eval-dylan-form package form))
289              (wire:remote-value (server-info-wire server-info)
290                (server-eval-form package form)))
291      (when error      (when error
292        (editor-error "The server died before finishing"))        (editor-error "The server died before finishing"))
293      values))      values))
# Line 284  Line 314 
314     string.  If package is not supplied, the string is eval'ed in the slave's     string.  If package is not supplied, the string is eval'ed in the slave's
315     current package."     current package."
316    (declare (simple-string string))    (declare (simple-string string))
317    (queue-note (make-note :kind :eval    (queue-note (make-note :kind (if (dylan-mode-p) :dylan-eval :eval)
318                           :context context                           :context context
319                           :package package                           :package package
320                           :text string)                           :text string)
# Line 300  Line 330 
330     is not supplied, the string is eval'ed in the slave's current package."     is not supplied, the string is eval'ed in the slave's current package."
331    (let ((region (region (copy-mark (region-start region) :left-inserting)    (let ((region (region (copy-mark (region-start region) :left-inserting)
332                          (copy-mark (region-end region) :left-inserting))))                          (copy-mark (region-end region) :left-inserting))))
333      (queue-note (make-note :kind :eval      (queue-note (make-note :kind (if (dylan-mode-p) :dylan-eval :eval)
334                             :context context                             :context context
335                             :region region                             :region region
336                             :package package                             :package package
# Line 317  Line 347 
347    (let* ((region (region (copy-mark (region-start region) :left-inserting)    (let* ((region (region (copy-mark (region-start region) :left-inserting)
348                           (copy-mark (region-end region) :left-inserting)))                           (copy-mark (region-end region) :left-inserting)))
349           (buf (line-buffer (mark-line (region-start region))))           (buf (line-buffer (mark-line (region-start region))))
350           (defined-from (and buf           (pn (and buf (buffer-pathname buf)))
351                              (namestring (buffer-pathname buf)))))           (defined-from (if pn (namestring pn) "unknown")))
352      (queue-note (make-note :kind :compile      (queue-note (make-note :kind (if (dylan-mode-p) :dylan-compile :compile)
353                             :context (region-context region "compilation")                             :context (region-context region "compilation")
354                             :buffer (and region                             :buffer (and region
355                                          (region-start region)                                          (region-start region)
# Line 410  Line 440 
440                                  file)))                                  file)))
441                         (unless (probe-file f) (return f))))))                         (unless (probe-file f) (return f))))))
442      (multiple-value-bind (fd err)      (multiple-value-bind (fd err)
443                           (mach:unix-open (namestring ofile)                           (unix:unix-open (namestring ofile)
444                                           mach:o_creat #o666)                                           unix:o_creat #o666)
445        (unless fd        (unless fd
446          (editor-error "Couldn't create compiler temporary output file:~%~          (editor-error "Couldn't create compiler temporary output file:~%~
447          ~A" (mach:get-unix-error-msg err)))          ~A" (unix:get-unix-error-msg err)))
448        (mach:unix-fchmod fd #o666)        (unix:unix-fchmod fd #o666)
449        (mach:unix-close fd))        (unix:unix-close fd))
450      (let ((net-ofile (pathname-for-remote-access ofile)))      (let ((net-ofile (pathname-for-remote-access ofile)))
451        (values (make-pathname :directory (pathname-directory net-ofile)        (values (make-pathname :directory (pathname-directory net-ofile)
452                               :defaults file)                               :defaults file)
# Line 563  Line 593 
593        :buffer (current-buffer)        :buffer (current-buffer)
594        :value (maybe-create-server))))        :value (maybe-create-server))))
595    
 #+ :IGNORETHIS  
 (defcommand "Connect Registered Eval Server" (p)  
   "Tries to connect to a registered eval server.  Prompts for name."  
   "Tries to connect to a registered eval server.  Prompts for name."  
   (declare (ignore p))  
   (connect-registered-eval-server  
    (prompt-for-string :prompt "Name to lookup: "  
                       :help "Registered eval server to connect to.")  
    (prompt-for-string  
     :prompt "Local server name: "  
     :help "Editor's name for server and \"Background <name>\" buffer.")))  
   
596  (defcommand "Evaluate Defun" (p)  (defcommand "Evaluate Defun" (p)
597    "Evaluates the current or next top-level form.    "Evaluates the current or next top-level form.
598     If the current region is active, then evaluate it."     If the current region is active, then evaluate it."
# Line 686  Line 704 
704                           :help "The name of the file to load"))))                           :help "The name of the file to load"))))
705      (setv load-pathname-defaults name)      (setv load-pathname-defaults name)
706      (string-eval (format nil "(load ~S)"      (string-eval (format nil "(load ~S)"
707                           (namestring (pathname-for-remote-access name))))))                           (namestring
708                              (if (value remote-compile-file)
709                                  (pathname-for-remote-access name)
710                                  name))))))
711    
712  (defcommand "Compile File" (p)  (defcommand "Compile File" (p)
713    "Prompts for file to compile.  Does not compare source and binary write    "Prompts for file to compile.  Does not compare source and binary write

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

  ViewVC Help
Powered by ViewVC 1.1.5