Changeset 12941

Timestamp:

Oct 9, 2009, 9:28:17 AM (15 years ago)

Author:

gz

Message:

Merge some irrelevant (other platforms, unused) trunk changes

Location:

branches/working-0711/ccl

Files:

• lib/dumplisp.lisp (modified) (7 diffs)
• lib/ffi-darwinppc64.lisp (modified) (1 diff)
• lib/numbers.lisp (modified) (2 diffs)
• library/chud-metering.lisp (modified) (1 diff)
• library/jp-encode-table.lisp (deleted)
• library/jp-encode.lisp (modified) (4 diffs)
• library/openmcl-gtk-support.lisp (modified) (1 diff)

branches/working-0711/ccl/lib/dumplisp.lisp

@@ -73 +73 @@
                          (mode #o644)
                          prepend-kernel
-                         )
+                         #+windows-target (application-type :console))
   (declare (ignore toplevel-function error-handler application-class
                    clear-clos-caches init-file impurify))
+  #+windows-target (check-type application-type (member :console :gui))
   (unless (probe-file (make-pathname :defaults nil
                                      :directory (pathname-directory (translate-logical-pathname filename))))
@@ -87 +88 @@
       (let* ((fd (open-dumplisp-file filename
                                      :mode mode
-                                     :prepend-kernel prepend-kernel)))
+                                     :prepend-kernel prepend-kernel
+                                     #+windows-target  #+windows-target 
+                                     :application-type application-type)))
         (process-interrupt ip
                            #'(lambda ()
@@ -109 +112 @@
                                       (init-file nil init-file-p)
                                       (clear-clos-caches t)
-                                      prepend-kernel)
-  (declare (ignore mode prepend-kernel))
+                                      prepend-kernel
+                                      #+windows-target application-type)
+  (declare (ignore mode prepend-kernel #+windows-target application-type))
   (when (and application-class (neq  (class-of *application*)
                                      (if (symbolp application-class)
@@ -189 +193 @@
                     header-pos))))))))))
                   
-  
-(defun %prepend-file (out-fd in-fd len)
+;;; Note that Windows executable files are in what they call "PE"
+;;; (= "Portable Executable") format, not to be confused with the "PEF"
+;;; (= "PowerPC Executable Format" or "Preferred Executable Format")
+;;; executable format that Apple used on Classic MacOS.
+(defun %prepend-file (out-fd in-fd len #+windows-target application-type)
   (declare (fixnum out-fd in-fd len))
   (fd-lseek in-fd 0 #$SEEK_SET)
-  (let* ((bufsize (ash 1 15)))
+  (let* ((bufsize (ash 1 15))
+         #+windows-target (first-buf t))
     (%stack-block ((buf bufsize))
       (loop
@@ -201 +209 @@
             (if (< nread 0)
               (%errno-disp nread))
-            (let* ((nwritten (fd-write out-fd buf nread)))
+            #+windows-target
+            (when (shiftf first-buf nil)
+              (let* ((application-byte (ecase application-type
+                                         (:console #$IMAGE_SUBSYSTEM_WINDOWS_CUI)
+                                         (:gui #$IMAGE_SUBSYSTEM_WINDOWS_GUI)))
+                     (offset (%get-long buf (get-field-offset #>IMAGE_DOS_HEADER.e_lfanew))))
+                (assert (< offset bufsize) () "PE header not within first ~D bytes" bufsize)
+                (assert (= (%get-byte buf (+ offset 0)) (char-code #\P)) ()
+                        "File does not appear to be a PE file")
+                (assert (= (%get-byte buf (+ offset 1)) (char-code #\E)) ()
+                        "File does not appear to be a PE file")
+                (assert (= (%get-byte buf (+ offset 2)) 0) ()
+                        "File does not appear to be a PE file")
+                (assert (= (%get-byte buf (+ offset 3)) 0) ()
+                        "File does not appear to be a PE file")
+                ;; File is a PE file -- Windows subsystem byte goes at offset 68 in the
+                ;;  "optional header" which appears right after the standard header (20 bytes)
+                ;;  and the PE cookie (4 bytes)
+                (setf (%get-byte buf (+ offset 4 (record-length #>IMAGE_FILE_HEADER) (get-field-offset #>IMAGE_OPTIONAL_HEADER.Subsystem) )) application-byte)))
+            (let* ((nwritten (fd-write out-fd buf nread)))
               (declare (fixnum nwritten))
               (unless (= nwritten nread)
@@ -221 +248 @@
 
 
-(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel)
+(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel
+                           #+windows-target application-type)
   (let* ((prepend-path (if prepend-kernel
                          (if (eq prepend-kernel t)
@@ -239 +267 @@
     (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode)))
       (unless (>= image-fd 0) (signal-file-error image-fd filename))
+      (when prepend-fd
+        (%prepend-file image-fd prepend-fd prepend-len #+windows-target application-type))
       (fd-chmod image-fd mode)
-      (when prepend-fd
-        (%prepend-file image-fd prepend-fd prepend-len))
       image-fd)))
 

branches/working-0711/ccl/lib/ffi-darwinppc64.lisp

@@ -508 +508 @@
                                           ,fp-args-ptr
                                           ,(* 8 (1- fp-arg-num))))))))))))))
-                (let* ((pair (list name (next-scalar-arg argtype))))
+                (let* ((form (next-scalar-arg argtype)))
                   (when name 
-                    (lets name))))
+                    (lets (list name form)))))
               #+nil
               (when (or (typep argtype 'foreign-pointer-type)

branches/working-0711/ccl/lib/numbers.lisp

@@ -47 +47 @@
         (ccl:set-fpu-mode :division-by-zero division-by-zero))))
 
-
+(defconstant double-float-nan
+  #.(let ((invalid (get-fpu-mode :invalid)))
+      (unwind-protect
+           (progn
+             (set-fpu-mode :invalid nil)
+             (+ double-float-positive-infinity double-float-negative-infinity))
+        (set-fpu-mode :invalid invalid))))
 
 (defun parse-float (str len off)  
@@ -109 +115 @@
          (nan 
           (return-from parse-float
-            (let* ((invalid (ccl:get-fpu-mode :invalid)))
-            (unwind-protect
-                (progn
-                  (ccl:set-fpu-mode :invalid nil)
-                  (coerce
-                   ;; we could also have used a double-float-nan
-                   ;; variable binding here:
-                   (+ double-float-positive-infinity
-                      double-float-positive-infinity)
-                   type))
-              (ccl:set-fpu-mode :invalid invalid)))))
+            (coerce double-float-nan type)))
          (expt (setq expt (%i+ expt (* esign eexp))))
          (t (return-from parse-float nil)))))

branches/working-0711/ccl/library/chud-metering.lisp

@@ -163 +163 @@
 #+ppc-target
 (defun identify-functions-with-pure-code ()
-  (ccl:purify)
+  (ccl::purify)
   (multiple-value-bind (pure-low pure-high)
                                  

branches/working-0711/ccl/library/jp-encode.lisp

@@ -17713 +17713 @@
 
 
-(defmacro define-jp-encoding (name document max-units-per-char
+(defmacro define-jp-encoding (name docstring aliases max-units-per-char
                               from-ucs
                               to-ucs
@@ -17719 +17719 @@
                               length-by-1st-unit)
   `(define-character-encoding ,name
-       ,document
+       ,docstring
+     :aliases ,aliases
      :native-endianness nil
      :max-units-per-char ,max-units-per-char
@@ -17909 +17910 @@
 
 
-(define-jp-encoding :eucjp
+(define-jp-encoding :euc-jp
     "An 8-bit, variable-length character encoding in which
 character code points in the range #x00-#x7f can be encoded in a
 single octet; characters with larger code values can be encoded
 in 2 to 3 bytes."
+  '(:eucjp)
   3
   ucs-to-eucjp
@@ -17927 +17929 @@
         (t 1)))
 
-(define-jp-encoding :cp932
+(define-jp-encoding :windows-31j
     "An 8-bit, variable-length character encoding in which
 character code points in the range #x00-#x7f can be encoded in a
 single octet; characters with larger code values can be encoded
 in 2 bytes."
+  '(:cp932 :csWindows31J)
   2
   ucs-to-cp932

branches/working-0711/ccl/library/openmcl-gtk-support.lisp

@@ -24 +24 @@
 
 (eval-when (:compile-toplevel :execute)
-  (use-interface-dir :GTK))
+  (use-interface-dir :GTK2))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  ;; I don't know why it's necessary to explicitly open
-  ;; libgdk.so (which transitively opens half a dozen
-  ;; other libraries), while opening libgtk.so by itself
-  ;; would complain about unresolved symbols from libgdk.
-  (dolist (lib '("libgdk.so" "libgtk.so"))
-    (open-shared-library lib)))
+  (open-shared-library "libgnomeui-2.so"))