X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-executable%2Fsb-executable.lisp;h=90d39d49d533b78f0a4fba7c7e652e03c1a313f4;hb=988afd9d54ba6c8a915544822658824ab6ae0d6c;hp=c424d4304d0f7266191e8d2256b0bddbb77c0944;hpb=f4b9ac56f10a3a83f1c4db98c6fd9428bbc5f4e3;p=sbcl.git

diff --git a/contrib/sb-executable/sb-executable.lisp b/contrib/sb-executable/sb-executable.lisp
index c424d43..90d39d4 100644
--- a/contrib/sb-executable/sb-executable.lisp
+++ b/contrib/sb-executable/sb-executable.lisp
@@ -21,30 +21,37 @@
 
 (defvar *exec-header*
   "#!/bin/sh --
-exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type '(unsigned-byte 8)) (loop while (< ret 2) when (= (read-byte i) 10) count 1 into ret) (load i) (quit))\" --end-toplevel-options ${1+\"$@\"}
+exec sbcl --noinform ~{~A ~}--eval \"(with-open-file (i \\\"$0\\\" :element-type '(unsigned-byte 8)) (loop while (< ret 2) when (= (read-byte i) 10) count 1 into ret) (load i) (funcall (quote ~A)) (quit))\" --end-toplevel-options ${1+\"$@\"}
 ")
 
 (defun make-executable (output-file fasls
 			&key (runtime-flags '("--disable-debugger"
 					      "--userinit /dev/null"
-					      "--sysinit /dev/null")))
+					      "--sysinit /dev/null"))
+			initial-function)
   "Write an executable called OUTPUT-FILE which can be run from the shell, by 'linking' together code from FASLS.  Actually works by concatenating them and prepending a #! header"
-  (with-open-file (out output-file :direction :output
+  (with-open-file (out output-file
+		       :direction :output
+		       :if-exists :supersede
 		       :element-type '(unsigned-byte 8))
     (write-sequence (map 'vector #'char-code
-			 (format nil *exec-header* runtime-flags)) out)
+			 (format nil *exec-header* runtime-flags
+				 (or initial-function 'values))) out)
     (dolist (input-file (if (listp fasls) fasls (list fasls)))
       (with-open-file (in (merge-pathnames input-file
 					   (make-pathname :type "fasl"))
 			  :element-type '(unsigned-byte 8))
 	(copy-stream in out))))
-  (let* ((out-name (namestring output-file))
+  (let* (;; FIXME: use OUT as the pathname designator
+	 (out-name (namestring (translate-logical-pathname output-file)))
 	 (prot (elt (multiple-value-list (sb-unix:unix-stat out-name)) 3)))
-    (sb-unix::void-syscall ("chmod" c-string int)
-			   out-name
-			   (logior prot
-				   (if (logand prot #o400) #o100)
-				   (if (logand prot  #o40)  #o10)
-				   (if (logand prot   #o4)   #o1)))))
+    (if prot
+	(sb-unix::void-syscall ("chmod" c-string int)
+			       out-name
+			       (logior prot
+				       (if (logand prot #o400) #o100)
+				       (if (logand prot  #o40)  #o10)
+				       (if (logand prot   #o4)   #o1)))
+	(error "stat() call failed"))))
 			 
-  
\ No newline at end of file
+(provide 'sb-executable)