diff --git a/bootfiles/18e/boot6.lisp b/bootfiles/18e/boot6.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3ccd82fa29bc233aeac71d724280899517748049 --- /dev/null +++ b/bootfiles/18e/boot6.lisp @@ -0,0 +1,55 @@ +;;;; +;;;; This boot-file is needed only when cross-compiling from a lisp which +;;;; doesn't have the type-union related type-system changes to one which +;;;; has. If one does a normal recompile to do the update, this isn't +;;;; needed, but if one wants to e.g. go from 18e directly to current HEAD, +;;;; a cross-compile is necessary, as is this boot file. +;;;; +;;;; This needs to be placed in the target:bootstrap.lisp file, while doing +;;;; the cross-compile, which is loaded after compiling the cross-compiler, +;;;; unlike the target:cross-bootstrap.lisp file. +;;;; + +(in-package :C) + +(defun make-canonical-union-type (type-list) + (let ((members '()) + (misc-types '())) + (dolist (type type-list) + (if (member-type-p type) + (setf members (union members (member-type-members type))) + (push type misc-types))) + #+long-float + (when (null (set-difference '(-0l0 0l0) members)) + #-negative-zero-is-not-zero + (push (specifier-type '(long-float 0l0 0l0)) misc-types) + #+negative-zero-is-not-zero + (push (specifier-type '(long-float -0l0 0l0)) misc-types) + (setf members (set-difference members '(-0l0 0l0)))) + (when (null (set-difference '(-0d0 0d0) members)) + #-negative-zero-is-not-zero + (push (specifier-type '(double-float 0d0 0d0)) misc-types) + #+negative-zero-is-not-zero + (push (specifier-type '(double-float -0d0 0d0)) misc-types) + (setf members (set-difference members '(-0d0 0d0)))) + (when (null (set-difference '(-0f0 0f0) members)) + #-negative-zero-is-not-zero + (push (specifier-type '(single-float 0f0 0f0)) misc-types) + #+negative-zero-is-not-zero + (push (specifier-type '(single-float -0f0 0f0)) misc-types) + (setf members (set-difference members '(-0f0 0f0)))) + (cond ((null members) + (let ((res (first misc-types))) + (dolist (type (rest misc-types)) + (setq res (type-union res type))) + res)) + ((null misc-types) + (make-member-type :members members)) + (t + (let ((res (first misc-types))) + (dolist (type (rest misc-types)) + (setq res (type-union res type))) + (dolist (type members) + (setq res (type-union + res (make-member-type :members (list type))))) + res)))))