X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-executable%2Fsb-executable.lisp;h=77740e009065e705603c9f2bc2cdab578d434cc3;hb=062283b901155792f65775491aea51481c56faaa;hp=f785a98eba33d7871fd25497cc14949c690e8444;hpb=6387a29a5c3aae2cb319dcaf803fb2df24eea46d;p=sbcl.git

diff --git a/contrib/sb-executable/sb-executable.lisp b/contrib/sb-executable/sb-executable.lisp
index f785a98..77740e0 100644
--- a/contrib/sb-executable/sb-executable.lisp
+++ b/contrib/sb-executable/sb-executable.lisp
@@ -7,46 +7,63 @@
 (cl:in-package :sb-executable)
 
 (defvar *stream-buffer-size* 8192)
-(defun copy-stream (from to)
+(defun copy-stream (from to &key (element-type (stream-element-type from) element-type-passed-p))
   "Copy into TO from FROM until end of the input stream, in blocks of
-*stream-buffer-size*.  The streams should have the same element type."
-  (unless (subtypep (stream-element-type to) (stream-element-type from))
-    (error "Incompatible streams ~A and ~A." from to))
+*stream-buffer-size*.  The streams should have the same element type.
+
+The argument :element-type indicates the element type of the
+buffer used to copy data from FROM to TO.
+
+If one of the streams has an element type that is different from
+what (stream-element-type stream) reports, that is, if it was
+opened with :element-type :default, the argument :element-type is
+required in order to select the correct stream decoding/encoding
+strategy."
+  (unless (or element-type-passed-p
+              (subtypep (stream-element-type to) element-type))
+    (error "Incompatible streams ~A and ~A:" from to))
   (let ((buf (make-array *stream-buffer-size*
-			 :element-type (stream-element-type from))))
+                         :element-type element-type)))
     (loop
-     (let ((pos (read-sequence buf from)))
-       (when (zerop pos) (return))
-       (write-sequence buf to :end pos)))))
+      (let ((pos (read-sequence buf from)))
+        (when (zerop pos) (return))
+        (write-sequence buf to :end pos)))))
+
 
 (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) (funcall (quote ~A)) (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)) (exit))\" --end-toplevel-options ${1+\"$@\"}
 ")
 
 (defun make-executable (output-file fasls
-			&key (runtime-flags '("--disable-debugger"
-					      "--userinit /dev/null"
-					      "--sysinit /dev/null"))
-			initial-function)
+                        &key (runtime-flags '("--disable-debugger"
+                                              "--no-userinit"
+                                              "--no-sysinit"))
+                        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
-		       :element-type '(unsigned-byte 8))
+  (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
-				 (or initial-function 'values))) 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))
-	 (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)))))
-			 
+                                           (make-pathname :type "fasl"))
+                          :element-type '(unsigned-byte 8))
+        (copy-stream in out))))
+  (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)))
+    #-win32
+    (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"))))
+
 (provide 'sb-executable)