/[slime]/slime/swank-cmucl.lisp
ViewVC logotype

Diff of /slime/swank-cmucl.lisp

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

revision 1.186 by heller, Mon Aug 11 17:41:55 2008 UTC revision 1.187 by heller, Tue Aug 12 17:54:44 2008 UTC
# Line 2267  The `symbol-value' of each element is a Line 2267  The `symbol-value' of each element is a
2267  (defimplementation make-weak-key-hash-table (&rest args)  (defimplementation make-weak-key-hash-table (&rest args)
2268    (apply #'make-hash-table :weak-p t args))    (apply #'make-hash-table :weak-p t args))
2269    
2270    
2271    ;;; Save image
2272    
2273    (defimplementation save-image (filename &optional restart-function)
2274      (multiple-value-bind (pid error) (unix:unix-fork)
2275        (when (not pid) (error "fork: ~A" (unix:get-unix-error-msg error)))
2276        (cond ((= pid 0)
2277               (let ((args `(,filename
2278                             ,@(if restart-function
2279                                   `((:init-function ,restart-function))))))
2280                 (apply #'ext:save-lisp args)))
2281              (t
2282               (let ((status (waitpid pid)))
2283                 (destructuring-bind (&key exited? status &allow-other-keys) status
2284                   (assert (and exited? (equal status 0)) ()
2285                           "Invalid exit status: ~a" status)))))))
2286    
2287    (defun waitpid (pid)
2288      (alien:with-alien ((status c-call:int))
2289        (let ((code (alien:alien-funcall
2290                     (alien:extern-alien
2291                      waitpid (alien:function unix::pid-t
2292                                              unix::pid-t
2293                                              (* c-call:int) c-call:int))
2294                     pid (alien:addr status) 0)))
2295          (cond ((= code -1) (error "waitpid: ~A" (unix:get-unix-error-msg)))
2296                (t (assert (= code pid))
2297                   (decode-wait-status status))))))
2298    
2299    (defun decode-wait-status (status)
2300      (let ((output (with-output-to-string (s)
2301                      (call-program (list (process-status-program)
2302                                          (format nil "~d" status))
2303                                    :output s))))
2304        (read-from-string output)))
2305    
2306    (defun call-program (args &key output)
2307      (destructuring-bind (program &rest args) args
2308        (let ((process (ext:run-program program args :output output)))
2309          (when (not program) (error "fork failed"))
2310          (unless (and (eq (ext:process-status process) :exited)
2311                       (= (ext:process-exit-code process) 0))
2312            (error "Non-zero exit status")))))
2313    
2314    (defvar *process-status-program* nil)
2315    
2316    (defun process-status-program ()
2317      (or *process-status-program*
2318          (setq *process-status-program*
2319                (compile-process-status-program))))
2320    
2321    (defun compile-process-status-program ()
2322      (let ((infile (system::pick-temporary-file-name
2323                     "/tmp/process-status~d~c.c")))
2324        (with-open-file (stream infile :direction :output :if-exists :supersede)
2325          (format stream "
2326    #include <stdio.h>
2327    #include <stdlib.h>
2328    #include <sys/types.h>
2329    #include <sys/wait.h>
2330    #include <assert.h>
2331    
2332    #define FLAG(value) (value ? \"t\" : \"nil\")
2333    
2334    int main (int argc, char** argv) {
2335      assert (argc == 2);
2336      {
2337        char* endptr = NULL;
2338        char* arg = argv[1];
2339        long int status = strtol (arg, &endptr, 10);
2340        assert (endptr != arg && *endptr == '\\0');
2341        printf (\"(:exited? %s :status %d :signal? %s :signal %d :coredump? %s\"
2342                \" :stopped? %s :stopsig %d)\\n\",
2343                FLAG(WIFEXITED(status)), WEXITSTATUS(status),
2344                FLAG(WIFSIGNALED(status)), WTERMSIG(status),
2345                FLAG(WCOREDUMP(status)),
2346                FLAG(WIFSTOPPED(status)), WSTOPSIG(status));
2347        fflush (NULL);
2348        return 0;
2349      }
2350    }
2351    ")
2352          (finish-output stream))
2353        (let* ((outfile (system::pick-temporary-file-name))
2354               (args (list "cc" "-o" outfile infile)))
2355          (warn "Running cc: ~{~a ~}~%" args)
2356          (call-program args :output t)
2357          (delete-file infile)
2358          outfile)))
2359    
2360    ;; (save-image "/tmp/x.core")
2361    
2362  ;; Local Variables:  ;; Local Variables:
2363  ;; pbook-heading-regexp:    "^;;;\\(;+\\)"  ;; pbook-heading-regexp:    "^;;;\\(;+\\)"
2364  ;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"  ;; pbook-commentary-regexp: "^;;;\\($\\|[^;]\\)"

Legend:
Removed from v.1.186  
changed lines
  Added in v.1.187

  ViewVC Help
Powered by ViewVC 1.1.5