0.8alpha.0.13:

	CLISP build megapatch
	... mostly putting #-SB-XC in front of :COMPILE-TOPLEVEL,
		because clisp gives a full warning for function and
		macro redefinition;
	... workaround clisp's buggy pretty printer by not exercising it
		as much: use (INHIBIT-WARNINGS 3);
	... explicit :INITIAL-ELEMENT 0 when we're using 0 to mean
		"uninitialized" in MAKE-ARRAY;
	... SPECIAL-OPERATOR-P isn't a good test on the host for what
		can become a target macro;
	... slightly more portable floating point logic:
		Explicitly set *READ-DEFAULT-FLOAT-FORMAT* so that we
			don't create host LONG-FLOATs by accident;
		LOAD-TIME-VALUE magic for negative floating point zeros;
	Minor associated text file frobbage
	... braindump some unrelated TODO items
	Obligatory runtime code improvement
	... fix one warning in gencgc.h

diff --git a/INSTALL b/INSTALL
index 464a644..5839336 100644 (file)
--- a/INSTALL
+++ b/INSTALL
@@ -55,6 +55,7 @@ This software has been built successfully on these systems:
                os = Debian GNU/Linux 2.1 with libc >= 2.1
                        host lisp = CMU CL 2.4.17
                        host lisp = SBCL itself
                os = Debian GNU/Linux 2.1 with libc >= 2.1
                        host lisp = CMU CL 2.4.17
                        host lisp = SBCL itself

+                       host lisp = CLISP CVS as of end of April

                os = RedHat Linux 6.2
                        host lisp = SBCL itself
                os = FreeBSD 3.4 or 4.0
                os = RedHat Linux 6.2
                        host lisp = SBCL itself
                os = FreeBSD 3.4 or 4.0

@@ -77,9 +78,6 @@ This software has been built successfully on these systems:
                        host lisp = OpenMCL 0.12
                        host lisp = SBCL itself
 
                        host lisp = OpenMCL 0.12
                        host lisp = SBCL itself
 

-It is known not to build under CLISP (as of early June 2002) because
-of bugs in the CLISP garbage collector.
-

 Reports of other systems that it works on (or doesn't work on, for
 that matter), or help in making it run on more systems, would be
 appreciated.
 Reports of other systems that it works on (or doesn't work on, for
 that matter), or help in making it run on more systems, would be
 appreciated.

diff --git a/TODO b/TODO
index 561c9bd..28e5af2 100644 (file)
--- a/TODO
+++ b/TODO
@@ -35,6 +35,8 @@ for early 0.8.x:
 * fixups now feasible because of pre7 changes
        ** ANSIfied DECLAIM INLINE stuff (deprecating MAYBE-INLINE,
                including e.g. on the man page)
 * fixups now feasible because of pre7 changes
        ** ANSIfied DECLAIM INLINE stuff (deprecating MAYBE-INLINE,
                including e.g. on the man page)

+       ** (maybe) allow INLINE of a recursive function, so that the
+               body is inlined once

 * miscellaneous simple refactoring
        * belated renaming:
                ** renamed %PRIMITIVE to %VOP
 * miscellaneous simple refactoring
        * belated renaming:
                ** renamed %PRIMITIVE to %VOP

@@ -52,6 +54,16 @@ for early 0.8.x:
 * Either get rid of or at least rework the fdefinition/encapsulation
        system so that (SYMBOL-FUNCTION 'FOO) is identically equal to
        (FDEFINITION 'FOO).
 * Either get rid of or at least rework the fdefinition/encapsulation
        system so that (SYMBOL-FUNCTION 'FOO) is identically equal to
        (FDEFINITION 'FOO).

+* Make the system sources understandable to the system, so that
+       searching for sources doesn't error out quite so often
+       (e.g. in error handlers)
+       ** provided a location-independent way of referring to source
+               files in the target image, maybe a SYS: logical
+               pathname, and made the build system respect this.
+       ** provided a suitable readtable for reading in the source
+               files when necessary, and a mechanism for activating
+               this readtable rather than the standard one.
+

 =======================================================================
 for 0.9:
 
 =======================================================================
 for 0.9:
 

diff --git a/build-order.lisp-expr b/build-order.lisp-expr
index 7761ef2..05efd7b 100644 (file)
--- a/build-order.lisp-expr
+++ b/build-order.lisp-expr
@@ -129,6 +129,8 @@
 
  ("src/code/defbangstruct")
 
 
  ("src/code/defbangstruct")
 

+ ("src/code/unportable-float")
+ 

  ("src/code/funutils" :not-host)
 
  ;; This needs DEF!STRUCT, and is itself needed early so that structure
  ("src/code/funutils" :not-host)
 
  ;; This needs DEF!STRUCT, and is itself needed early so that structure

@@ -336,12 +338,16 @@
  ;; defining types
  ("src/compiler/parse-lambda-list")
 
  ;; defining types
  ("src/compiler/parse-lambda-list")
 

+ ;; The following two files trigger function/macro redefinition
+ ;; warnings in clisp during make-host-2; as a workaround, we ignore
+ ;; the failure values from COMPILE-FILE under clisp.
+ 

  ;; for DEFSTRUCT ALIEN-TYPE, needed by host-type.lisp
  ;; for DEFSTRUCT ALIEN-TYPE, needed by host-type.lisp

- ("src/code/host-alieneval")
+ ("src/code/host-alieneval" #+clisp :ignore-failure-p)

 
  ;; can't be done until definition of e.g. DEFINE-ALIEN-TYPE-CLASS in
  ;; host-alieneval.lisp
 
  ;; can't be done until definition of e.g. DEFINE-ALIEN-TYPE-CLASS in
  ;; host-alieneval.lisp

- ("src/code/host-c-call")
+ ("src/code/host-c-call" #+clisp :ignore-failure-p)

 
  ;; SB!XC:DEFTYPE is needed in order to compile late-type
  ;; in the host Common Lisp, and in order to run, it needs
 
  ;; SB!XC:DEFTYPE is needed in order to compile late-type
  ;; in the host Common Lisp, and in order to run, it needs

diff --git a/make-genesis-2.sh b/make-genesis-2.sh
index 38786ba..42efb07 100644 (file)
--- a/make-genesis-2.sh
+++ b/make-genesis-2.sh
@@ -51,6 +51,7 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
                       ;; be very handy when debugging cold init problems.
                       :map-file-name "output/cold-sbcl.map")
         #+cmu (ext:quit)
                       ;; be very handy when debugging cold init problems.
                       :map-file-name "output/cold-sbcl.map")
         #+cmu (ext:quit)

+        #+clisp (ext:quit)

        EOF
 
 echo //testing for consistency of first and second GENESIS passes
        EOF
 
 echo //testing for consistency of first and second GENESIS passes

diff --git a/make-host-1.sh b/make-host-1.sh
index 01ba05b..1b6cf9b 100644 (file)
--- a/make-host-1.sh
+++ b/make-host-1.sh
@@ -45,4 +45,5 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
         (host-cload-stem "src/compiler/generic/genesis")
        (sb!vm:genesis :c-header-dir-name "src/runtime/genesis")
         #+cmu (ext:quit)
         (host-cload-stem "src/compiler/generic/genesis")
        (sb!vm:genesis :c-header-dir-name "src/runtime/genesis")
         #+cmu (ext:quit)

+        #+clisp (ext:quit)

        EOF
        EOF

diff --git a/make-host-2.sh b/make-host-2.sh
index e266d77..c57fe2c 100644 (file)
--- a/make-host-2.sh
+++ b/make-host-2.sh
@@ -55,17 +55,22 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
        (load-or-cload-xcompiler #'host-load-stem)
         (defun proclaim-target-optimization ()
           (let ((debug (if (position :sb-show *shebang-features*) 2 1)))
        (load-or-cload-xcompiler #'host-load-stem)
         (defun proclaim-target-optimization ()
           (let ((debug (if (position :sb-show *shebang-features*) 2 1)))

-           (sb-xc:proclaim `(optimize (compilation-speed 1)
-                                      (debug ,debug)
-                                      (sb!ext:inhibit-warnings 2)
-                                      ;; SAFETY = SPEED (and < 3) should 
-                                      ;; reasonable safety, but might skip 
-                                      ;; some unreasonably expensive stuff
-                                      ;; (e.g. %DETECT-STACK-EXHAUSTION
-                                      ;; in sbcl-0.7.2).
-                                       (safety 2)
-                                       (space 1)
-                                      (speed 2)))))
+           (sb-xc:proclaim 
+             `(optimize
+              (compilation-speed 1)
+              (debug ,debug)
+              ;; CLISP's pretty-printer is fragile and tends to cause
+              ;; stack corruption or fail internal assertions, as of
+              ;; 2003-04-20; we therefore turn off as many notes as
+              ;; possible.
+              (sb!ext:inhibit-warnings #-clisp 2
+                                       #+clisp 3)
+              ;; SAFETY = SPEED (and < 3) should provide reasonable
+              ;; safety, but might skip some unreasonably expensive
+              ;; stuff (e.g. %DETECT-STACK-EXHAUSTION in sbcl-0.7.2).
+              (safety 2)
+              (space 1)
+              (speed 2)))))

         (compile 'proclaim-target-optimization)
        (defun in-target-cross-compilation-mode (fun)
          "Call FUN with everything set up appropriately for cross-compiling
         (compile 'proclaim-target-optimization)
        (defun in-target-cross-compilation-mode (fun)
          "Call FUN with everything set up appropriately for cross-compiling

@@ -122,8 +127,10 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
        (when (position :sb-after-xc-core *shebang-features*)
           #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
           #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")
        (when (position :sb-after-xc-core *shebang-features*)
           #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
           #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core")

+          #+clisp (ext:saveinitmem "output/after-xc.core")

          )
         #+cmu (ext:quit)
          )
         #+cmu (ext:quit)

+        #+clisp (ext:quit)

        EOF
 
 # Run GENESIS (again) in order to create cold-sbcl.core. (The first
        EOF
 
 # Run GENESIS (again) in order to create cold-sbcl.core. (The first

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 84c86f8..03af7eb 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1128,6 +1128,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
              "MAKE-NULL-LEXENV" "MAKE-NULL-INTERACTIVE-LEXENV"
             "MAKE-NUMERIC-TYPE"
              "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
              "MAKE-NULL-LEXENV" "MAKE-NULL-INTERACTIVE-LEXENV"
             "MAKE-NUMERIC-TYPE"
              "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"

+            "MAKE-UNPORTABLE-FLOAT"

              "%MAKE-INSTANCE"
             "MAKE-VALUE-CELL"
              "MAKE-VALUES-TYPE"
              "%MAKE-INSTANCE"
             "MAKE-VALUE-CELL"
              "MAKE-VALUES-TYPE"

diff --git a/src/code/class.lisp b/src/code/class.lisp
index a0e26d9..0d19c7c 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -211,7 +211,7 @@
            (layout-proper-name layout)
            (layout-invalid layout))))
 
            (layout-proper-name layout)
            (layout-invalid layout))))
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun layout-proper-name (layout)
     (classoid-proper-name (layout-classoid layout))))
 \f
   (defun layout-proper-name (layout)
     (classoid-proper-name (layout-classoid layout))))
 \f

@@ -521,7 +521,11 @@
        (when (> depth max-depth)
          (setf max-depth depth))))
     (let* ((new-length (max (1+ max-depth) length))
        (when (> depth max-depth)
          (setf max-depth depth))))
     (let* ((new-length (max (1+ max-depth) length))

-          (inherits (make-array new-length)))
+          ;; KLUDGE: 0 here is the "uninitialized" element.  We need
+          ;; to specify it explicitly for portability purposes, as
+          ;; elements can be read before being set [ see below, "(EQL
+          ;; OLD-LAYOUT 0)" ].  -- CSR, 2002-04-20
+          (inherits (make-array new-length :initial-element 0)))

       (dotimes (i length)
        (let* ((layout (svref layouts i))
               (depth (layout-depthoid layout)))
       (dotimes (i length)
        (let* ((layout (svref layouts i))
               (depth (layout-depthoid layout)))

diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp
index 72e6638..e0b2eb0 100644 (file)
--- a/src/code/cross-float.lisp
+++ b/src/code/cross-float.lisp
@@ -237,3 +237,4 @@
                               (ash 1 52))
                       (expt 0.5d0 52))))
         (* sign (kludge-opaque-expt 2.0d0 expt) mant)))))
                               (ash 1 52))
                       (expt 0.5d0 52))))
         (* sign (kludge-opaque-expt 2.0d0 expt) mant)))))

+

diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp
index ea2939e..7b9ba18 100644 (file)
--- a/src/code/defbangstruct.lisp
+++ b/src/code/defbangstruct.lisp
@@ -104,7 +104,7 @@
   ;; DEF!STRUCT is made to work fully, this list is processed, then
   ;; made unbound, and should no longer be used.
   (defvar *delayed-def!structs* nil))
   ;; DEF!STRUCT is made to work fully, this list is processed, then
   ;; made unbound, and should no longer be used.
   (defvar *delayed-def!structs* nil))

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   ;; Parse the arguments for a DEF!STRUCT call, and return
   ;;   (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
   ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
   ;; Parse the arguments for a DEF!STRUCT call, and return
   ;;   (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
   ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the

diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp
index c80dcba..aec98f0 100644 (file)
--- a/src/code/defmacro.lisp
+++ b/src/code/defmacro.lisp
@@ -16,10 +16,18 @@
 ;;; bootstrap idiom
 ;;;   CL:DEFMACRO SB!XC:DEFMACRO
 ;;;   SB!XC:DEFMACRO CL:DEFMACRO
 ;;; bootstrap idiom
 ;;;   CL:DEFMACRO SB!XC:DEFMACRO
 ;;;   SB!XC:DEFMACRO CL:DEFMACRO

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun %expander-for-defmacro (name lambda-list body)
     (unless (symbolp name)
       (error "The macro name ~S is not a symbol." name))
   (defun %expander-for-defmacro (name lambda-list body)
     (unless (symbolp name)
       (error "The macro name ~S is not a symbol." name))

+    ;; When we are building the cross-compiler, we could be in a host
+    ;; lisp which implements CL macros (e.g. CL:AND) as special
+    ;; operators (while still providing a macroexpansion for
+    ;; compliance): therefore can't use the host's SPECIAL-OPERATOR-P
+    ;; as a discriminator, but that's OK because the set of forms the
+    ;; cross-compiler compiles is tightly controlled.  -- CSR,
+    ;; 2003-04-20
+    #-sb-xc-host

     (when (special-operator-p name)
       (error "The special operator ~S can't be redefined as a macro."
              name))
     (when (special-operator-p name)
       (error "The special operator ~S can't be redefined as a macro."
              name))

@@ -92,7 +100,7 @@
             name))))
   (progn
     (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
             name))))
   (progn
     (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)

-    (def (:compile-toplevel) nil)))
+    (def (#-sb-xc :compile-toplevel) nil)))

 
 ;;; Parse the definition and make an expander function. The actual
 ;;; definition is done by %DEFMACRO which we expand into. After the
 
 ;;; Parse the definition and make an expander function. The actual
 ;;; definition is done by %DEFMACRO which we expand into. After the

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index c020545..89a4edc 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -207,11 +207,14 @@
 
 ;;; Return the name of a defstruct slot as a symbol. We store it as a
 ;;; string to avoid creating lots of worthless symbols at load time.
 
 ;;; Return the name of a defstruct slot as a symbol. We store it as a
 ;;; string to avoid creating lots of worthless symbols at load time.

+;;;
+;;; FIXME: This has horrible package issues.  In many ways, it would
+;;; be very nice to treat the names of structure slots as strings, but
+;;; unfortunately PCL requires slot names to be interned symbols.
+;;; Maybe we want to resurrect something like the old
+;;; SB-SLOT-ACCESSOR-NAME package?

 (defun dsd-name (dsd)
 (defun dsd-name (dsd)

-  (intern (string (dsd-%name dsd))
-         (if (dsd-accessor-name dsd)
-             (symbol-package (dsd-accessor-name dsd))
-             (sane-package))))
+  (intern (dsd-%name dsd)))

 \f
 ;;;; typed (non-class) structures
 
 \f
 ;;;; typed (non-class) structures
 

@@ -223,7 +226,7 @@
 \f
 ;;;; shared machinery for inline and out-of-line slot accessor functions
 
 \f
 ;;;; shared machinery for inline and out-of-line slot accessor functions
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
   ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
   (defstruct raw-slot-data
 
   ;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
   (defstruct raw-slot-data

@@ -1049,16 +1052,16 @@
     (collect ((moved)
              (retyped))
       (dolist (name (intersection onames nnames))
     (collect ((moved)
              (retyped))
       (dolist (name (intersection onames nnames))

-       (let ((os (find name oslots :key #'dsd-name))
-             (ns (find name nslots :key #'dsd-name)))
-         (unless (subtypep (dsd-type ns) (dsd-type os))
+       (let ((os (find name oslots :key #'dsd-name :test #'string=))
+             (ns (find name nslots :key #'dsd-name :test #'string=)))
+         (unless (sb!xc:subtypep (dsd-type ns) (dsd-type os))

            (retyped name))
          (unless (and (= (dsd-index os) (dsd-index ns))
                       (eq (dsd-raw-type os) (dsd-raw-type ns)))
            (moved name))))
       (values (moved)
              (retyped)
            (retyped name))
          (unless (and (= (dsd-index os) (dsd-index ns))
                       (eq (dsd-raw-type os) (dsd-raw-type ns)))
            (moved name))))
       (values (moved)
              (retyped)

-             (set-difference onames nnames)))))
+             (set-difference onames nnames :test #'string=)))))

 
 ;;; If we are redefining a structure with different slots than in the
 ;;; currently loaded version, give a warning and return true.
 
 ;;; If we are redefining a structure with different slots than in the
 ;;; currently loaded version, give a warning and return true.

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index d279677..1a62a86 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -161,7 +161,7 @@
 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
 ;;; is the pointer to the current tail of the list, or NIL if the list
 ;;; is empty.
 ;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
 ;;; is the pointer to the current tail of the list, or NIL if the list
 ;;; is empty.

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun collect-normal-expander (n-value fun forms)
     `(progn
        ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
   (defun collect-normal-expander (n-value fun forms)
     `(progn
        ,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)

@@ -616,7 +616,7 @@
                    (consp (cdr name))
                    (symbolp (cadr name))
                    (consp (cddr name))
                    (consp (cdr name))
                    (symbolp (cadr name))
                    (consp (cddr name))

-                   (symbolp (caddr name))
+                   (or (symbolp (caddr name)) (stringp (caddr name)))

                    (consp (cdddr name))
                    (member
                     (cadddr name)
                    (consp (cdddr name))
                    (member
                     (cadddr name)

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 77698dd..5aace45 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -326,22 +326,22 @@
   ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
   ;; ranges are compared by arithmetic operators (while MEMBERship is
   ;; compared by EQL).  -- CSR, 2003-04-23
   ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
   ;; ranges are compared by arithmetic operators (while MEMBERship is
   ;; compared by EQL).  -- CSR, 2003-04-23

-  (let ((singlep (subsetp '(-0.0f0 0.0f0) members))
-       (doublep (subsetp '(-0.0d0 0.0d0) members))
+  (let ((singlep (subsetp `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
+       (doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))

        #!+long-float
        #!+long-float

-       (longp (subsetp '(-0.0l0 0.0l0) members)))
+       (longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members)))

     (if (or singlep doublep #!+long-float longp)
        (let (union-types)
          (when singlep
            (push (ctype-of 0.0f0) union-types)
     (if (or singlep doublep #!+long-float longp)
        (let (union-types)
          (when singlep
            (push (ctype-of 0.0f0) union-types)

-           (setf members (set-difference members '(-0.0f0 0.0f0))))
+           (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))

          (when doublep
            (push (ctype-of 0.0d0) union-types)
          (when doublep
            (push (ctype-of 0.0d0) union-types)

-           (setf members (set-difference members '(-0.0d0 0.0d0))))
+           (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))

          #!+long-float
          (when longp
            (push (ctype-of 0.0l0) union-types)
          #!+long-float
          (when longp
            (push (ctype-of 0.0l0) union-types)

-           (setf members (set-difference members '(-0.0l0 0.0l0))))
+           (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))

          (aver (not (null union-types)))
          (make-union-type t
                           (if (null members)
          (aver (not (null union-types)))
          (make-union-type t
                           (if (null members)

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 766b241..413beba 100644 (file)
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -30,7 +30,7 @@
 \f
 ;;;; ALIEN-TYPE-INFO stuff
 
 \f
 ;;;; ALIEN-TYPE-INFO stuff
 

-(eval-when (:compile-toplevel :execute :load-toplevel)
+(eval-when (#-sb-xc :compile-toplevel :execute :load-toplevel)

 
 (defstruct (alien-type-class (:copier nil))
   (name nil :type symbol)
 
 (defstruct (alien-type-class (:copier nil))
   (name nil :type symbol)

@@ -147,7 +147,7 @@
 ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
 ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
 ;;; a similar effect.
 ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
 ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
 ;;; a similar effect.

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun auxiliary-type-definitions (env)
     (multiple-value-bind (result expanded-p)
        (sb!xc:macroexpand '&auxiliary-type-definitions& env)
   (defun auxiliary-type-definitions (env)
     (multiple-value-bind (result expanded-p)
        (sb!xc:macroexpand '&auxiliary-type-definitions& env)

@@ -259,7 +259,7 @@
               ,body))
           (%define-alien-type-translator ',name #',defun-name ,docs))))))
 
               ,body))
           (%define-alien-type-translator ',name #',defun-name ,docs))))))
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun %define-alien-type-translator (name translator docs)
     (declare (ignore docs))
     (setf (info :alien-type :kind name) :primitive)
   (defun %define-alien-type-translator (name translator docs)
     (declare (ignore docs))
     (setf (info :alien-type :kind name) :primitive)

@@ -285,7 +285,7 @@
   (deprecation-warning 'def-alien-type 'define-alien-type)
   `(define-alien-type ,@rest))
 
   (deprecation-warning 'def-alien-type 'define-alien-type)
   `(define-alien-type ,@rest))
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun %def-auxiliary-alien-types (types)
     (dolist (info types)
       (destructuring-bind (kind name defn) info
   (defun %def-auxiliary-alien-types (types)
     (dolist (info types)
       (destructuring-bind (kind name defn) info

diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp
index bab7661..fe13620 100644 (file)
--- a/src/code/irrat.lisp
+++ b/src/code/irrat.lisp
@@ -14,8 +14,9 @@
 \f
 ;;;; miscellaneous constants, utility functions, and macros
 
 \f
 ;;;; miscellaneous constants, utility functions, and macros
 

-(defconstant pi 3.14159265358979323846264338327950288419716939937511L0)
-;(defconstant e 2.71828182845904523536028747135266249775724709369996L0)
+(defconstant pi
+  #!+long-float 3.14159265358979323846264338327950288419716939937511l0
+  #!-long-float 3.14159265358979323846264338327950288419716939937511d0)

 
 ;;; Make these INLINE, since the call to C is at least as compact as a
 ;;; Lisp call, and saves number consing to boot.
 
 ;;; Make these INLINE, since the call to C is at least as compact as a
 ;;; Lisp call, and saves number consing to boot.

@@ -903,13 +904,18 @@
       ;; space 0 to get maybe-inline functions inlined
       (declare (optimize (speed 3) (space 0)))
     (cond ((> (abs x)
       ;; space 0 to get maybe-inline functions inlined
       (declare (optimize (speed 3) (space 0)))
     (cond ((> (abs x)

-             #-(or linux hpux) #.(/ (asinh most-positive-double-float) 4d0)
-             ;; This is more accurate under linux.
-             #+(or linux hpux) #.(/ (+ (log 2.0d0)
-                                       (log most-positive-double-float))
-                                    4d0))
-              (coerce-to-complex-type (float-sign x)
-                                      (float-sign y) z))
+             ;; FIXME: this form is hideously broken wrt
+             ;; cross-compilation portability.  Much else in this
+             ;; file is too, of course, sometimes hidden by
+             ;; constant-folding, but this one in particular clearly
+             ;; depends on host and target
+             ;; MOST-POSITIVE-DOUBLE-FLOATs being equal.  -- CSR,
+             ;; 2003-04-20
+             #.(/ (+ (log 2.0d0)
+                     (log most-positive-double-float))
+                  4d0))
+          (coerce-to-complex-type (float-sign x)
+                                  (float-sign y) z))

          (t
           (let* ((tv (%tan y))
                  (beta (+ 1.0d0 (* tv tv)))
          (t
           (let* ((tv (%tan y))
                  (beta (+ 1.0d0 (* tv tv)))

diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp
index a0d204e..ee5deb1 100644 (file)
--- a/src/code/late-format.lisp
+++ b/src/code/late-format.lisp
@@ -327,7 +327,7 @@
        (values (progn ,@body-without-decls)
               ,directives))))
 
        (values (progn ,@body-without-decls)
               ,directives))))
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
 (defun %set-format-directive-expander (char fn)
   (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
 
 (defun %set-format-directive-expander (char fn)
   (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index c74a081..ec42475 100644 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -1321,8 +1321,10 @@
        (let ((members (member-type-members not-type)))
         (if (some #'floatp members)
             (let (floats)
        (let ((members (member-type-members not-type)))
         (if (some #'floatp members)
             (let (floats)

-              (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0)
-                              #!+long-float (0.0l0 . -0.0l0)))
+              (dolist (pair `((0.0f0 . ,(load-time-value (make-unportable-float :single-float-negative-zero)))
+                              (0.0d0 . ,(load-time-value (make-unportable-float :double-float-negative-zero)))
+                              #!+long-float
+                              (0.0l0 . ,(load-time-value (make-unportable-float :long-float-negative-zero)))))

                 (when (member (car pair) members)
                   (aver (not (member (cdr pair) members)))
                   (push (cdr pair) floats)
                 (when (member (car pair) members)
                   (aver (not (member (cdr pair) members)))
                   (push (cdr pair) floats)

@@ -1547,17 +1549,17 @@
          ((consp low-bound)
           (let ((low-value (car low-bound)))
             (or (eql low-value high-bound)
          ((consp low-bound)
           (let ((low-value (car low-bound)))
             (or (eql low-value high-bound)

-                (and (eql low-value -0f0) (eql high-bound 0f0))
-                (and (eql low-value 0f0) (eql high-bound -0f0))
-                (and (eql low-value -0d0) (eql high-bound 0d0))
-                (and (eql low-value 0d0) (eql high-bound -0d0)))))
+                (and (eql low-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql high-bound 0f0))
+                (and (eql low-value 0f0) (eql high-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
+                (and (eql low-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql high-bound 0d0))
+                (and (eql low-value 0d0) (eql high-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))

          ((consp high-bound)
           (let ((high-value (car high-bound)))
             (or (eql high-value low-bound)
          ((consp high-bound)
           (let ((high-value (car high-bound)))
             (or (eql high-value low-bound)

-                (and (eql high-value -0f0) (eql low-bound 0f0))
-                (and (eql high-value 0f0) (eql low-bound -0f0))
-                (and (eql high-value -0d0) (eql low-bound 0d0))
-                (and (eql high-value 0d0) (eql low-bound -0d0)))))
+                (and (eql high-value (load-time-value (make-unportable-float :single-float-negative-zero))) (eql low-bound 0f0))
+                (and (eql high-value 0f0) (eql low-bound (load-time-value (make-unportable-float :single-float-negative-zero))))
+                (and (eql high-value (load-time-value (make-unportable-float :double-float-negative-zero))) (eql low-bound 0d0))
+                (and (eql high-value 0d0) (eql low-bound (load-time-value (make-unportable-float :double-float-negative-zero)))))))

          ((and (eq (numeric-type-class low) 'integer)
                (eq (numeric-type-class high) 'integer))
           (eql (1+ low-bound) high-bound))
          ((and (eq (numeric-type-class low) 'integer)
                (eq (numeric-type-class high) 'integer))
           (eql (1+ low-bound) high-bound))

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index 9f5a486..7e7783a 100644 (file)
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -176,11 +176,11 @@
             name))))
   (progn
     (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)
             name))))
   (progn
     (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)

-    (def (:compile-toplevel) nil)))
+    #-sb-xc (def (:compile-toplevel) nil)))

 \f
 ;;;; CASE, TYPECASE, and friends
 
 \f
 ;;;; CASE, TYPECASE, and friends
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
 ;;; CASE-BODY returns code for all the standard "case" macros. NAME is
 ;;; the macro name, and KEYFORM is the thing to case on. MULTI-P
 
 ;;; CASE-BODY returns code for all the standard "case" macros. NAME is
 ;;; the macro name, and KEYFORM is the thing to case on. MULTI-P

diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp
index da7e137..61195bd 100644 (file)
--- a/src/code/pathname.lisp
+++ b/src/code/pathname.lisp
@@ -54,15 +54,16 @@
 
 ;;; A PATTERN is a list of entries and wildcards used for pattern
 ;;; matches of translations.
 
 ;;; A PATTERN is a list of entries and wildcards used for pattern
 ;;; matches of translations.

-(sb!xc:defstruct (pattern (:constructor make-pattern (pieces)))
+(def!struct (pattern (:constructor make-pattern (pieces)))

   (pieces nil :type list))
 \f
 ;;;; PATHNAME structures
 
 ;;; the various magic tokens that are allowed to appear in pretty much
 ;;; all pathname components
   (pieces nil :type list))
 \f
 ;;;; PATHNAME structures
 
 ;;; the various magic tokens that are allowed to appear in pretty much
 ;;; all pathname components

-(sb!xc:deftype pathname-component-tokens ()
-  '(member nil :unspecific :wild))
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+  (def!type pathname-component-tokens ()
+    '(member nil :unspecific :wild)))

 
 (sb!xc:defstruct (pathname (:conc-name %pathname-)
                           (:constructor %make-pathname (host
 
 (sb!xc:defstruct (pathname (:conc-name %pathname-)
                           (:constructor %make-pathname (host

diff --git a/src/code/pred.lisp b/src/code/pred.lisp
index 78a51c2..dd6ccb2 100644 (file)
--- a/src/code/pred.lisp
+++ b/src/code/pred.lisp
@@ -245,7 +245,7 @@
 
 (/show0 "about to do test cases in pred.lisp")
 #!+sb-test
 
 (/show0 "about to do test cases in pred.lisp")
 #!+sb-test

-(let ((test-cases '((0.0 -0.0 t)
+(let ((test-cases `((0.0 ,(load-time-value (make-unportable-float :single-float-negative-zero)) t)

                    (0.0 1.0 nil)
                    (#c(1 0) #c(1.0 0) t)
                    (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error
                    (0.0 1.0 nil)
                    (#c(1 0) #c(1.0 0) t)
                    (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error

diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp
index 9edc6d9..4f25976 100644 (file)
--- a/src/code/primordial-extensions.lisp
+++ b/src/code/primordial-extensions.lisp
@@ -57,7 +57,7 @@
 \f
 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
 
 \f
 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun frob-do-body (varlist endlist decls-and-code bind step name block)
     (let* ((r-inits nil) ; accumulator for reversed list
           (r-steps nil) ; accumulator for reversed list
   (defun frob-do-body (varlist endlist decls-and-code bind step name block)
     (let* ((r-inits nil) ; accumulator for reversed list
           (r-steps nil) ; accumulator for reversed list

@@ -164,7 +164,7 @@
 
 ;;; Concatenate together the names of some strings and symbols,
 ;;; producing a symbol in the current package.
 
 ;;; Concatenate together the names of some strings and symbols,
 ;;; producing a symbol in the current package.

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun symbolicate (&rest things)
     (let ((name (case (length things)
                  ;; why isn't this just the value in the T branch?
   (defun symbolicate (&rest things)
     (let ((name (case (length things)
                  ;; why isn't this just the value in the T branch?

diff --git a/src/code/print.lisp b/src/code/print.lisp
index 0acd176..a6539ee 100644 (file)
--- a/src/code/print.lisp
+++ b/src/code/print.lisp
@@ -1391,30 +1391,36 @@
 ;;; part of the computation to avoid over/under flow. When
 ;;; denormalized, we must pull out a large factor, since there is more
 ;;; negative exponent range than positive range.
 ;;; part of the computation to avoid over/under flow. When
 ;;; denormalized, we must pull out a large factor, since there is more
 ;;; negative exponent range than positive range.

+
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format*
+       #!+long-float 'long-float #!-long-float 'double-float))

 (defun scale-exponent (original-x)
   (let* ((x (coerce original-x 'long-float)))
     (multiple-value-bind (sig exponent) (decode-float x)
       (declare (ignore sig))
 (defun scale-exponent (original-x)
   (let* ((x (coerce original-x 'long-float)))
     (multiple-value-bind (sig exponent) (decode-float x)
       (declare (ignore sig))

-      (if (= x 0.0l0)
-         (values (float 0.0l0 original-x) 1)
-         (let* ((ex (round (* exponent (log 2l0 10))))
+      (if (= x 0.0e0)
+         (values (float 0.0e0 original-x) 1)
+         (let* ((ex (round (* exponent (log 2e0 10))))

                 (x (if (minusp ex)
                        (if (float-denormalized-p x)
                            #!-long-float
                 (x (if (minusp ex)
                        (if (float-denormalized-p x)
                            #!-long-float

-                           (* x 1.0l16 (expt 10.0l0 (- (- ex) 16)))
+                           (* x 1.0e16 (expt 10.0e0 (- (- ex) 16)))

                            #!+long-float
                            #!+long-float

-                           (* x 1.0l18 (expt 10.0l0 (- (- ex) 18)))
-                           (* x 10.0l0 (expt 10.0l0 (- (- ex) 1))))
-                       (/ x 10.0l0 (expt 10.0l0 (1- ex))))))
-           (do ((d 10.0l0 (* d 10.0l0))
+                           (* x 1.0e18 (expt 10.0e0 (- (- ex) 18)))
+                           (* x 10.0e0 (expt 10.0e0 (- (- ex) 1))))
+                       (/ x 10.0e0 (expt 10.0e0 (1- ex))))))
+           (do ((d 10.0e0 (* d 10.0e0))

                 (y x (/ x d))
                 (ex ex (1+ ex)))
                 (y x (/ x d))
                 (ex ex (1+ ex)))

-               ((< y 1.0l0)
-                (do ((m 10.0l0 (* m 10.0l0))
+               ((< y 1.0e0)
+                (do ((m 10.0e0 (* m 10.0e0))

                      (z y (* y m))
                      (ex ex (1- ex)))
                      (z y (* y m))
                      (ex ex (1- ex)))

-                    ((>= z 0.1l0)
+                    ((>= z 0.1e0)

                      (values (float z original-x) ex))))))))))
                      (values (float z original-x) ex))))))))))

+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format* 'single-float))

 \f
 ;;;; entry point for the float printer
 
 \f
 ;;;; entry point for the float printer
 

diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 41226cb..49a0ba0 100644 (file)
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -1220,22 +1220,19 @@
                 ;; while attempting to constant-fold. Maybe some sort
                 ;; of load-time-form magic could be used instead?
                 (case float-format
                 ;; while attempting to constant-fold. Maybe some sort
                 ;; of load-time-form magic could be used instead?
                 (case float-format

-                  (short-float
-                   (values
-                    (log sb!xc:least-positive-normalized-short-float 10s0)
-                    (log sb!xc:most-positive-short-float 10s0)))
-                  (single-float
+                  ((short-float single-float)

                    (values
                     (log sb!xc:least-positive-normalized-single-float 10f0)
                     (log sb!xc:most-positive-single-float 10f0)))
                    (values
                     (log sb!xc:least-positive-normalized-single-float 10f0)
                     (log sb!xc:most-positive-single-float 10f0)))

-                  (double-float
+                  ((double-float #!-long-float long-float)

                    (values
                     (log sb!xc:least-positive-normalized-double-float 10d0)
                     (log sb!xc:most-positive-double-float 10d0)))
                    (values
                     (log sb!xc:least-positive-normalized-double-float 10d0)
                     (log sb!xc:most-positive-double-float 10d0)))

+                  #!+long-float

                   (long-float
                    (values
                   (long-float
                    (values

-                    (log sb!xc:least-positive-normalized-long-float 10L0)
-                    (log sb!xc:most-positive-long-float 10L0))))
+                    (log sb!xc:least-positive-normalized-long-float 10l0)
+                    (log sb!xc:most-positive-long-float 10l0))))

               (let ((correction (cond ((<= exponent min-expo)
                                        (ceiling (- min-expo exponent)))
                                       ((>= exponent max-expo)
               (let ((correction (cond ((<= exponent min-expo)
                                        (ceiling (- min-expo exponent)))
                                       ((>= exponent max-expo)

diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp
index cb9c502..0cdd509 100644 (file)
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -15,7 +15,7 @@
 ;;;; utilities
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 ;;;; utilities
 
 (eval-when (:compile-toplevel :load-toplevel :execute)

-  (defconstant max-hash most-positive-fixnum))
+  (defconstant max-hash sb!xc:most-positive-fixnum))

 
 (deftype hash ()
   `(integer 0 ,max-hash))
 
 (deftype hash ()
   `(integer 0 ,max-hash))

diff --git a/src/code/target-random.lisp b/src/code/target-random.lisp
index af1e45f..28c4db4 100644 (file)
--- a/src/code/target-random.lisp
+++ b/src/code/target-random.lisp
@@ -263,12 +263,12 @@
   (cond
     ((and (fixnump arg) (<= arg random-fixnum-max) (> arg 0))
      (rem (random-chunk state) arg))
   (cond
     ((and (fixnump arg) (<= arg random-fixnum-max) (> arg 0))
      (rem (random-chunk state) arg))

-    ((and (typep arg 'single-float) (> arg 0.0S0))
+    ((and (typep arg 'single-float) (> arg 0.0f0))

      (%random-single-float arg state))
      (%random-single-float arg state))

-    ((and (typep arg 'double-float) (> arg 0.0D0))
+    ((and (typep arg 'double-float) (> arg 0.0d0))

      (%random-double-float arg state))
     #!+long-float
      (%random-double-float arg state))
     #!+long-float

-    ((and (typep arg 'long-float) (> arg 0.0L0))
+    ((and (typep arg 'long-float) (> arg 0.0l0))

      (%random-long-float arg state))
     ((and (integerp arg) (> arg 0))
      (%random-integer arg state))
      (%random-long-float arg state))
     ((and (integerp arg) (> arg 0))
      (%random-integer arg state))

diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp
index b703a60..d493d41 100644 (file)
--- a/src/code/type-class.lisp
+++ b/src/code/type-class.lisp
@@ -122,8 +122,8 @@
       (:complex-= . type-class-complex-=)
       (:unparse . type-class-unparse))))
 
       (:complex-= . type-class-complex-=)
       (:unparse . type-class-unparse))))
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
-  
+(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 ;;; Copy TYPE-CLASS object X, using only operations which will work
 ;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
 ;;; because it needs RAW-INDEX and RAW-LENGTH information from
 ;;; Copy TYPE-CLASS object X, using only operations which will work
 ;;; early in cold load. (COPY-STRUCTURE won't work early in cold load,
 ;;; because it needs RAW-INDEX and RAW-LENGTH information from

@@ -147,7 +147,6 @@
 ;;; the positive effect of removing indirection could be cancelled by
 ;;; the negative effect of imposing an unnecessary GC write barrier on
 ;;; raw data which doesn't actually affect GC.)
 ;;; the positive effect of removing indirection could be cancelled by
 ;;; the negative effect of imposing an unnecessary GC write barrier on
 ;;; raw data which doesn't actually affect GC.)

-(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))

 (defun copy-type-class-coldly (x)
   ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
   ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will
 (defun copy-type-class-coldly (x)
   ;; KLUDGE: If the slots of TYPE-CLASS ever change in a way not
   ;; reflected in *TYPE-CLASS-FUN-SLOTS*, the slots here will

diff --git a/src/cold/ansify.lisp b/src/cold/ansify.lisp
index 50023dc..5bfa6d2 100644 (file)
--- a/src/cold/ansify.lisp
+++ b/src/cold/ansify.lisp
@@ -40,7 +40,10 @@
     ;; These problems don't seem deep, and could probably be worked
     ;; around.
     #+nil (clisp-ouch "no (DOCUMENTATION X) when X is a PACKAGE")
     ;; These problems don't seem deep, and could probably be worked
     ;; around.
     #+nil (clisp-ouch "no (DOCUMENTATION X) when X is a PACKAGE")

-    #+nil (clisp-ouch "no (FUNCTION (SETF SYMBOL-FUNCTION))")))
+    #+nil (clisp-ouch "no (FUNCTION (SETF SYMBOL-FUNCTION))"))
+  
+  (ext:without-package-lock ("SYSTEM")
+    (setf system::*inhibit-floating-point-underflow* t)))

 \f
 ;;;; CMU CL issues
 
 \f
 ;;;; CMU CL issues
 

diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp
index 55bb02a..c61e18b 100644 (file)
--- a/src/cold/defun-load-or-cload-xcompiler.lisp
+++ b/src/cold/defun-load-or-cload-xcompiler.lisp
@@ -147,6 +147,7 @@
                          "SB!PRETTY"
                          "SB!PROFILE"
                          "SB!SYS"
                          "SB!PRETTY"
                          "SB!PROFILE"
                          "SB!SYS"

+                         "SB!THREAD"

                          "SB!UNIX"
                          "SB!VM"
                          "SB!WALKER"))
                          "SB!UNIX"
                          "SB!VM"
                          "SB!WALKER"))

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 96f51b1..f4f65bf 100644 (file)
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -538,9 +538,18 @@
     (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
                         (complex ,float-type)))))
 
     (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
                         (complex ,float-type)))))
 

+) ; PROGN
+
+(eval-when (:compile-toplevel :execute)
+  ;; So the problem with this hack is that it's actually broken.  If
+  ;; the host does not have long floats, then setting *R-D-F-F* to
+  ;; LONG-FLOAT doesn't actually buy us anything.  FIXME.
+  (setf *read-default-float-format*
+       #!+long-float 'long-float #!-long-float 'double-float))

 ;;; Test whether the numeric-type ARG is within in domain specified by
 ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
 ;;; Test whether the numeric-type ARG is within in domain specified by
 ;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to

-;;; be distinct. 
+;;; be distinct.
+#-sb-xc-host  ; (See CROSS-FLOAT-INFINITY-KLUDGE.)

 (defun domain-subtypep (arg domain-low domain-high)
   (declare (type numeric-type arg)
           (type (or real null) domain-low domain-high))
 (defun domain-subtypep (arg domain-low domain-high)
   (declare (type numeric-type arg)
           (type (or real null) domain-low domain-high))

@@ -552,11 +561,18 @@
     (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
               (minusp (float-sign arg-lo-val)))
       (compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo)
     (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
               (minusp (float-sign arg-lo-val)))
       (compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo)

-      (setq arg-lo '(0l0) arg-lo-val 0l0))
+      (setq arg-lo '(0e0) arg-lo-val 0e0))

     (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
               (plusp (float-sign arg-hi-val)))
       (compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi)
     (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
               (plusp (float-sign arg-hi-val)))
       (compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi)

-      (setq arg-hi '(-0l0) arg-hi-val -0l0))
+      (setq arg-hi `(,(ecase *read-default-float-format*
+                       (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+                       #!+long-float
+                       (long-float (load-time-value (make-unportable-float :long-float-negative-zero)))))
+           arg-hi-val (ecase *read-default-float-format*
+                        (double-float (load-time-value (make-unportable-float :double-float-negative-zero)))
+                        #!+long-float
+                        (long-float (load-time-value (make-unportable-float :long-float-negative-zero))))))

     (and (or (null domain-low)
             (and arg-lo (>= arg-lo-val domain-low)
                  (not (and (zerop domain-low) (floatp domain-low)
     (and (or (null domain-low)
             (and arg-lo (>= arg-lo-val domain-low)
                  (not (and (zerop domain-low) (floatp domain-low)

@@ -573,6 +589,11 @@
                            (if (consp arg-hi)
                                (minusp (float-sign arg-hi-val))
                                (plusp (float-sign arg-hi-val))))))))))
                            (if (consp arg-hi)
                                (minusp (float-sign arg-hi-val))
                                (plusp (float-sign arg-hi-val))))))))))

+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format* 'single-float))
+
+#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
+(progn

 
 ;;; Handle monotonic functions of a single variable whose domain is
 ;;; possibly part of the real line. ARG is the variable, FCN is the
 
 ;;; Handle monotonic functions of a single variable whose domain is
 ;;; possibly part of the real line. ARG is the variable, FCN is the

@@ -672,7 +693,7 @@
   (frob atanh -1d0 1d0 -1 1)
   ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
   ;; includes -0.0.
   (frob atanh -1d0 1d0 -1 1)
   ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
   ;; includes -0.0.

-  (frob sqrt -0d0 nil 0 nil))
+  (frob sqrt (load-time-value (make-unportable-float :double-float-negative-zero)) nil 0 nil))

 
 ;;; Compute bounds for (expt x y). This should be easy since (expt x
 ;;; y) = (exp (* y (log x))). However, computations done this way
 
 ;;; Compute bounds for (expt x y). This should be easy since (expt x
 ;;; y) = (exp (* y (log x))). However, computations done this way

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 9bfeeaa..5f91e0e 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -2021,7 +2021,7 @@
 (defun cold-load-symbol (size package)
   (let ((string (make-string size)))
     (read-string-as-bytes *fasl-input-stream* string)
 (defun cold-load-symbol (size package)
   (let ((string (make-string size)))
     (read-string-as-bytes *fasl-input-stream* string)

-    (cold-intern (intern string package) package)))
+    (cold-intern (intern string package))))

 
 (macrolet ((frob (name pname-len package-len)
             `(define-cold-fop (,name)
 
 (macrolet ((frob (name pname-len package-len)
             `(define-cold-fop (,name)

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index ee434de..8a7a6ef 100644 (file)
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -360,7 +360,7 @@
             ,(do-compact-info name class type type-number value
                               n-env body)))))
 
             ,(do-compact-info name class type type-number value
                               n-env body)))))
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
 ;;; Return code to iterate over a compact info environment.
 (defun do-compact-info (name-var class-var type-var type-number-var value-var
 
 ;;; Return code to iterate over a compact info environment.
 (defun do-compact-info (name-var class-var type-var type-number-var value-var

diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index d30e87a..a86bbc9 100644 (file)
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -133,7 +133,7 @@
 
 (deftype attributes () 'fixnum)
 
 
 (deftype attributes () 'fixnum)
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
 ;;; Given a list of attribute names and an alist that translates them
 ;;; to masks, return the OR of the masks.
 
 ;;; Given a list of attribute names and an alist that translates them
 ;;; to masks, return the OR of the masks.

@@ -263,7 +263,7 @@
 ;;;; to parse the IR1 representation of a function call using a
 ;;;; standard function lambda-list.
 
 ;;;; to parse the IR1 representation of a function call using a
 ;;;; standard function lambda-list.
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
 ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
 ;;; the arguments of a combination with respect to that lambda-list.
 
 ;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
 ;;; the arguments of a combination with respect to that lambda-list.

@@ -707,7 +707,7 @@
 ;;; experimentation, not for ordinary use, so it should probably
 ;;; become conditional on SB-SHOW.
 
 ;;; experimentation, not for ordinary use, so it should probably
 ;;; become conditional on SB-SHOW.
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
 (defstruct (event-info (:copier nil))
   ;; The name of this event.
 
 (defstruct (event-info (:copier nil))
   ;; The name of this event.

diff --git a/src/compiler/policy.lisp b/src/compiler/policy.lisp
index ff543cc..9ec12e3 100644 (file)
--- a/src/compiler/policy.lisp
+++ b/src/compiler/policy.lisp
@@ -22,12 +22,18 @@
 ;;; alists instead.
 (def!type policy () 'list)
 
 ;;; alists instead.
 (def!type policy () 'list)
 

-(eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute)
-  (defstruct policy-dependent-quality
-    name
-    expression
-    getter
-    values-documentation))
+;;; FIXME: the original implementation of this was protected by
+;;;
+;;; (eval-when (#-sb-xc-host :compile-toplevel :load-toplevel :execute)
+;;;
+;;; but I don't know why.  This seems to work, but I don't understand
+;;; why the original wasn't this in the first place.  -- CSR,
+;;; 2003-05-04
+(defstruct policy-dependent-quality
+  name
+  expression
+  getter
+  values-documentation)

 
 ;;; names of recognized optimization policy qualities
 (defvar *policy-qualities*) ; (initialized at cold init)
 
 ;;; names of recognized optimization policy qualities
 (defvar *policy-qualities*) ; (initialized at cold init)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 648b31f..462e449 100644 (file)
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -834,11 +834,11 @@
             :low (if lo-float-zero-p
                      (if (consp lo)
                          (list (float 0.0 lo-val))
             :low (if lo-float-zero-p
                      (if (consp lo)
                          (list (float 0.0 lo-val))

-                         (float -0.0 lo-val))
+                         (float (load-time-value (make-unportable-float :single-float-negative-zero)) lo-val))

                      lo)
             :high (if hi-float-zero-p
                       (if (consp hi)
                      lo)
             :high (if hi-float-zero-p
                       (if (consp hi)

-                          (list (float -0.0 hi-val))
+                          (list (float (load-time-value (make-unportable-float :single-float-negative-zero)) hi-val))

                           (float 0.0 hi-val))
                       hi))
            type))
                           (float 0.0 hi-val))
                       hi))
            type))

@@ -956,7 +956,9 @@
 
 ;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
 ;;; belong in the kernel's type logic, invoked always, instead of in
 
 ;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably
 ;;; belong in the kernel's type logic, invoked always, instead of in

-;;; the compiler, invoked only during some type optimizations.
+;;; the compiler, invoked only during some type optimizations. (In
+;;; fact, as of 0.pre8.100 or so they probably are, under
+;;; MAKE-MEMBER-TYPE, so probably this code can be deleted)

 
 ;;; Take a list of types and return a canonical type specifier,
 ;;; combining any MEMBER types together. If both positive and negative
 
 ;;; Take a list of types and return a canonical type specifier,
 ;;; combining any MEMBER types together. If both positive and negative

@@ -971,15 +973,15 @@
          (setf members (union members (member-type-members type)))
          (push type misc-types)))
     #!+long-float
          (setf members (union members (member-type-members type)))
          (push type misc-types)))
     #!+long-float

-    (when (null (set-difference '(-0l0 0l0) members))
-      (push (specifier-type '(long-float 0l0 0l0)) misc-types)
-      (setf members (set-difference members '(-0l0 0l0))))
-    (when (null (set-difference '(-0d0 0d0) members))
-      (push (specifier-type '(double-float 0d0 0d0)) misc-types)
-      (setf members (set-difference members '(-0d0 0d0))))
-    (when (null (set-difference '(-0f0 0f0) members))
-      (push (specifier-type '(single-float 0f0 0f0)) misc-types)
-      (setf members (set-difference members '(-0f0 0f0))))
+    (when (null (set-difference `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))
+      (push (specifier-type '(long-float 0.0l0 0.0l0)) misc-types)
+      (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0))))
+    (when (null (set-difference `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members))
+      (push (specifier-type '(double-float 0.0d0 0.0d0)) misc-types)
+      (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0))))
+    (when (null (set-difference `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members))
+      (push (specifier-type '(single-float 0.0f0 0.0f0)) misc-types)
+      (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0))))

     (if members
        (apply #'type-union (make-member-type :members members) misc-types)
        (apply #'type-union misc-types))))
     (if members
        (apply #'type-union (make-member-type :members members) misc-types)
        (apply #'type-union misc-types))))

diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index 3cc9def..3cf0cf0 100644 (file)
--- a/src/compiler/x86/float.lisp
+++ b/src/compiler/x86/float.lisp
@@ -177,26 +177,30 @@
 ;;; stored in a more precise form on chip. Anyhow, might as well use
 ;;; the feature. It can be turned off by hacking the
 ;;; "immediate-constant-sc" in vm.lisp.
 ;;; stored in a more precise form on chip. Anyhow, might as well use
 ;;; the feature. It can be turned off by hacking the
 ;;; "immediate-constant-sc" in vm.lisp.

+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format*
+       #!+long-float 'long-float #!-long-float 'double-float))

 (define-move-fun (load-fp-constant 2) (vop x y)
   ((fp-constant) (single-reg double-reg #!+long-float long-reg))
   (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
     (with-empty-tn@fp-top(y)
       (cond ((zerop value)
             (inst fldz))
 (define-move-fun (load-fp-constant 2) (vop x y)
   ((fp-constant) (single-reg double-reg #!+long-float long-reg))
   (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
     (with-empty-tn@fp-top(y)
       (cond ((zerop value)
             (inst fldz))

-           ((= value 1l0)
+           ((= value 1e0)

             (inst fld1))
             (inst fld1))

-           ((= value pi)
+           ((= value (coerce pi *read-default-float-format*))

             (inst fldpi))
             (inst fldpi))

-           ((= value (log 10l0 2l0))
+           ((= value (log 10e0 2e0))

             (inst fldl2t))
             (inst fldl2t))

-           ((= value (log 2.718281828459045235360287471352662L0 2l0))
+           ((= value (log 2.718281828459045235360287471352662e0 2e0))

             (inst fldl2e))
             (inst fldl2e))

-           ((= value (log 2l0 10l0))
+           ((= value (log 2e0 10e0))

             (inst fldlg2))
             (inst fldlg2))

-           ((= value (log 2l0 2.718281828459045235360287471352662L0))
+           ((= value (log 2e0 2.718281828459045235360287471352662e0))

             (inst fldln2))
            (t (warn "ignoring bogus i387 constant ~A" value))))))
             (inst fldln2))
            (t (warn "ignoring bogus i387 constant ~A" value))))))

-
+(eval-when (:compile-toplevel :execute)
+  (setf *read-default-float-format* 'single-float))

 \f
 ;;;; complex float move functions
 
 \f
 ;;;; complex float move functions
 

diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp
index 9febabb..514f116 100644 (file)
--- a/src/compiler/x86/insts.lisp
+++ b/src/compiler/x86/insts.lisp
@@ -286,7 +286,7 @@
   :printer #'print-word-reg/mem)
 
 ;;; added by jrd
   :printer #'print-word-reg/mem)
 
 ;;; added by jrd

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 (defun print-fp-reg (value stream dstate)
   (declare (ignore dstate))
   (format stream "FR~D" value))
 (defun print-fp-reg (value stream dstate)
   (declare (ignore dstate))
   (format stream "FR~D" value))

diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index 1af259d..d870e2f 100644 (file)
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -253,7 +253,7 @@
     ,@forms))
 \f
 ;;;; error code
     ,@forms))
 \f
 ;;;; error code

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))
       `((inst int 3)                           ; i386 breakpoint instruction
   (defun emit-error-break (vop kind code values)
     (let ((vector (gensym)))
       `((inst int 3)                           ; i386 breakpoint instruction

diff --git a/src/compiler/x86/static-fn.lisp b/src/compiler/x86/static-fn.lisp
index ba94709..9e080e4 100644 (file)
--- a/src/compiler/x86/static-fn.lisp
+++ b/src/compiler/x86/static-fn.lisp
@@ -22,7 +22,7 @@
   (:temporary (:sc unsigned-reg :offset ecx-offset
                   :from (:eval 0) :to (:eval 2)) ecx))
 
   (:temporary (:sc unsigned-reg :offset ecx-offset
                   :from (:eval 0) :to (:eval 2)) ecx))
 

-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)

 
 (defun static-fun-template-name (num-args num-results)
   (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"
 
 (defun static-fun-template-name (num-args num-results)
   (intern (format nil "~:@(~R-arg-~R-result-static-fun~)"

diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp
index f0c102e..bb7a622 100644 (file)
--- a/src/compiler/x86/vm.lisp
+++ b/src/compiler/x86/vm.lisp
@@ -375,6 +375,18 @@
 ;;; If value can be represented as an immediate constant, then return
 ;;; the appropriate SC number, otherwise return NIL.
 (!def-vm-support-routine immediate-constant-sc (value)
 ;;; If value can be represented as an immediate constant, then return
 ;;; the appropriate SC number, otherwise return NIL.
 (!def-vm-support-routine immediate-constant-sc (value)

+  ;; KLUDGE: although this might not look different from the FIXNUM
+  ;; below, in the TYPECASE, SB-INT:FIXNUMP actually tests against the
+  ;; target FIXNUM type, as opposed to TYPECASE FIXNUM which tests
+  ;; against the host FIXNUM range.
+  #+sb-xc-host
+  (when (fixnump value)
+    ;; FIXME: this block name was not obvious.  Also, since this idiom
+    ;; is presumably going to be repeated in all six (current)
+    ;; backends, it would be nice to wrap it up somewhat more nicely.
+    ;; -- CSR, 2003-04-20
+    (return-from impl-of-vm-support-routine-immediate-constant-sc
+      (sc-number-or-lose 'immediate)))

   (typecase value
     ((or fixnum #-sb-xc-host system-area-pointer character)
      (sc-number-or-lose 'immediate))
   (typecase value
     ((or fixnum #-sb-xc-host system-area-pointer character)
      (sc-number-or-lose 'immediate))

diff --git a/src/runtime/gencgc.h b/src/runtime/gencgc.h
index d9d4804..170fc09 100644 (file)
--- a/src/runtime/gencgc.h
+++ b/src/runtime/gencgc.h
@@ -93,4 +93,4 @@ void  gc_alloc_update_page_tables(int unboxed,
                                  struct alloc_region *alloc_region);
 void gc_alloc_update_all_page_tables(void);
 void gc_set_region_empty(struct alloc_region *region);
                                  struct alloc_region *alloc_region);
 void gc_alloc_update_all_page_tables(void);
 void gc_set_region_empty(struct alloc_region *region);

-#endif _GENCGC_H_
+#endif /* _GENCGC_H_ */

diff --git a/version.lisp-expr b/version.lisp-expr
index 2344731..f99abeb 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

-"0.8alpha.0.12"
+"0.8alpha.0.13"