Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge ../sbcl-upstream into tls-63

  • Loading branch information...
commit 39e8aa984de4b20b77e0c1a34dc11e823f4b4f0c 2 parents 9764bcd + 5f6c21f
@akovalenko authored
Showing with 1,456 additions and 397 deletions.
  1. +1 −0  .gitignore
  2. +7 −1 NEWS
  3. +92 −0 doc/GIT-WORKFLOW.md
  4. +13 −8 doc/PACKAGING-SBCL.txt
  5. +87 −0 generate-version.sh
  6. +734 −0 git/post-receive-email
  7. +3 −0  make.sh
  8. +145 −35 release.sh
  9. +1 −1  source-distribution.sh
  10. +1 −5 src/code/misc.lisp
  11. +6 −2 src/code/serve-event.lisp
  12. +32 −5 src/compiler/srctran.lisp
  13. +42 −16 src/runtime/gencgc.c
  14. +1 −2  tests/alien.impure.lisp
  15. +34 −0 tests/compiler.pure.lisp
  16. +46 −49 tests/deadline.impure.lisp
  17. +10 −16 tests/debug.impure.lisp
  18. +7 −14 tests/dynamic-extent.impure.lisp
  19. +1 −2  tests/eval.impure.lisp
  20. +40 −32 tests/exhaust.impure.lisp
  21. +14 −11 tests/float.pure.lisp
  22. +1 −2  tests/gc.impure.lisp
  23. +5 −6 tests/hash.impure.lisp
  24. +2 −4 tests/interface.impure.lisp
  25. +2 −3 tests/interface.pure.lisp
  26. +19 −26 tests/octets.pure.lisp
  27. +1 −2  tests/packages.impure.lisp
  28. +1 −2  tests/pathnames.impure.lisp
  29. +2 −4 tests/print.impure.lisp
  30. +1 −2  tests/run-program.impure.lisp
  31. +32 −22 tests/run-tests.lisp
  32. +2 −4 tests/stream.impure.lisp
  33. +27 −14 tests/test-util.lisp
  34. +19 −38 tests/threads.pure.lisp
  35. +24 −46 tests/timer.impure.lisp
  36. +1 −0  tests/win32-foreign-stack-unwind.impure.lisp
  37. +0 −23 version.lisp-expr
View
1  .gitignore
@@ -44,3 +44,4 @@ contrib/*/a.exe
contrib/asdf/asdf-upstream
contrib/sb-cover/test-output
doc/manual/*.html
+version.lisp-expr
View
8 NEWS
@@ -1,5 +1,11 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
-changes relative to sbcl-1.0.48:
+changes relative to sbcl-1.0.49:
+ * enhancement: errors from FD handlers now provide a restart to remove
+ the offending handler.
+ * bug fix: bound derivation for floating point operations is now more
+ careful about rounding possibly closing open bounds. (lp#793771)
+
+changes in sbcl-1.0.49 relative to sbcl-1.0.48:
* minor incompatible change: WITH-LOCKED-HASH-TABLE no longer disables
interrupts for its body.
* enhancement: source locations are now available for files loaded as
View
92 doc/GIT-WORKFLOW.md
@@ -0,0 +1,92 @@
+# Git workflow for SBCL
+
+## Version numbering
+
+Historically each SBCL commit incremented the number in
+version.lisp-expr, and prepended that version number to the first line
+of the commit message. For CVS this served us well, but since Git
+makes it easier for anyone to create branches that run in parallel to
+the current "master" timeline, it destroys the illusion of a single
+official timeline defined through version.lisp-expr.
+
+In Git workflow, version.lisp-expr no longer exists in the repository,
+nor is the version number prepended to commit messages.
+
+Instead, we construct a version number as follows when building SBCL
+or generating a source tarball:
+
+For branch master:
+
+ release.commits-on-master-since-release.sha1
+
+ Eg. 1.0.48.20-152c97d
+
+ Last release: 1.0.48
+ Commits on master after release: 20
+ SHA1 abbrev for current HEAD: 152c97d
+
+ If there are no commits on master since the last release, both the
+ count and the SHA1 are dropped.
+
+For other branches:
+
+ release.commits-on-branch-and-master-since-release.branch.commits-on-branch.sha1
+
+ Eg. 1.0.44.26.wip-pretty-backtraces.4-674f875
+
+ Last release: 1.0.44
+ Commits on master after release: 26
+ Branch: wip-pretty-backtraces
+ Commits on branch but not on master: 4
+ SHA1 abbrev for current HEAD: 674f875
+
+In both cases -dirty is appended to the version number if the tree
+isn't clean when building.
+
+Anyone who publishes binaries built using an altered version, should
+do so on a branch named appropriately, so that the binaries identify
+themselves as 1.0.50.debian.2 or whatever. If they wish to use a
+source release instead working from Git, they should identify their
+changes with an appropriate edit to version.lisp-expr.
+
+To cater for those whose existing processes really don't like the
+SHA1s part in version numbers, setting NO_GIT_HASH_IN_VERSION=t in the
+environment for make.sh will make the version number generator leave
+out the hash.
+
+## Making a release (release.sh)
+
+Short story: use `release.sh`.
+
+`release.sh` makes a release *locally.* This means it will perform all
+actions required for the release in the local git checkout, and will
+then instruct you how to proceed in order to push the release to the
+outside world.
+
+###Synopsis:
+
+ ./release.sh VERSION [-s]
+
+**VERSION** is the version to make a release for. Example: `1.0.46`.
+
+**-s** instructs `git tag` to create a gpg-signed tag for this
+release. Highly recommended.
+
+###Description:
+
+`release.sh` will perform these actions:
+
+* Check that the local checkout is clean.
+* Update NEWS and make a commit stating the release version number
+* Make an sbcl.<VERSION> tag and optionally sign it.
+* Build SBCL
+* Run tests
+* Build SBCL with the SBCL that just had tests pass
+* Build docs
+* Create source, binary, documentation tarballs
+* Sign these tarballs
+* Give you further instructions.
+
+After release.sh is done, you can inspect the results, and commence
+struggling with the SF.net file release system from hell. You are very
+brave.
View
21 doc/PACKAGING-SBCL.txt
@@ -1,19 +1,24 @@
Packaging SBCL
==============
-If you package SBCL for a distribution, please edit version.lisp-expr,
-and append ".packaging-target-or-patch[.version]".
+If you package SBCL for distribution, we ask that you to take steps to
+make the version number reflect this. Our users often report bugs that
+are intimately tied up with configuration issues, and much confusion
+can result from mistaking a packaged SBCL for the upstream one.
+
+If you are working from a Git branch, all you need to do is make sure
+the branch name reflects the situation -- the build system will
+incorporate the it in the version string.
+
+If you are working from a release tarball, please edit
+version.lisp-expr, and append ".packaging-target-or-patch[.version]".
Examples:
- "1.0.7.gentoo"
- "1.0.7.mikes-rpms.2"
+ "1.0.50.gentoo"
+ "1.0.50.mikes-rpms.2"
This will make the startup banner, --version, and
(lisp-implementation-version) all identify the packaged version
correctly.
-We ask you to do this because users report bugs that are intimately
-tied up with configuration issues at regular intervals, and much
-confusion can result from mistaking a packaged SBCL for the upstream
-one.
View
87 generate-version.sh
@@ -0,0 +1,87 @@
+#!/bin/sh
+# Not a shell script, but something intended to be sourced from shell scripts
+git_available_p() {
+ # Check that (1) we have git (2) this is a git tree.
+ if (which git >/dev/null 2>/dev/null && git describe >/dev/null 2>/dev/null)
+ then
+ # Check that some of the newer git versions we use are supported.
+ if [ "0" != "$(git rev-list HEAD --not HEAD --count 2> /dev/null)" ]
+ then
+ echo "Too old a git installation."
+ echo
+ echo "Your git doesn't support --count option with git rev-list,"
+ echo "which SBCL build requires. Git 1.7.2 or later should work."
+ exit 1
+ else
+ true
+ fi
+ else
+ false
+ fi
+}
+
+generate_version() {
+ if ([ -f version.lisp-expr ] && ! git_available_p)
+ then
+ # Relase tarball, leave version.lisp-expr alone.
+ return
+ elif ! git_available_p
+ then
+ echo "Can't run 'git describe' and version.lisp-expr is missing." >&2
+ echo "To fix this, either install git or create a fake version.lisp-expr file." >&2
+ echo "You can create a fake version.lisp-expr file like this:" >&2
+ echo " \$ echo '\"1.0.99.999\"' > version.lisp-expr" >&2
+ exit 1
+ fi
+ # Build it.
+ version_head=`git rev-parse HEAD`
+ if [ -z "$SBCL_BUILDING_RELEASE_FROM" ]
+ then
+ version_root="origin/master"
+ else
+ version_root="$SBCL_BUILDING_RELEASE_FROM"
+ fi
+ version_base=`git rev-parse "$version_root"`
+ version_tag=`git describe --tags --match="sbcl*" --abbrev=0 $version_base`
+ version_release=`echo $version_tag | sed -e 's/sbcl[_-]//' | sed -e 's/_/\./g'`
+ version_n_root=`git rev-list $version_base --not $version_tag --count`
+ version_n_branch=`git rev-list HEAD --not $version_base --count`
+ if [ -z "$NO_GIT_HASH_IN_VERSION" ]
+ then
+ version_hash="-`git rev-parse --short $version_head`"
+ else
+ version_hash=""
+ fi
+ if git diff HEAD --no-ext-diff --quiet --exit-code
+ then
+ version_dirty=""
+ else
+ version_dirty="-dirty"
+ fi
+ # Now that we have all the pieces, put them together.
+ cat >version.lisp-expr <<EOF
+;;; This file is auto-generated using generate-version.sh. Every time
+;;; you re-run make.sh, this file will be overwritten if you are
+;;; working from a Git checkout.
+EOF
+ if [ "$version_base" = "$version_head" ]
+ then
+ if [ "0" = "$version_n_root" ]
+ then
+ printf "\"%s%s\"\n" \
+ $version_release $version_dirty >>version.lisp-expr
+ else
+ printf "\"%s.%s%s%s\"\n" \
+ $version_release $version_n_root \
+ $version_hash $version_dirty >>version.lisp-expr
+ fi
+ else
+ echo "base=$version_base"
+ echo "head=$version_head"
+ version_branchname=`git describe --contains --all HEAD`
+ printf "\"%s.%s.%s.%s%s%s\"\n" \
+ $version_release $version_n_root \
+ $version_branchname $version_n_branch \
+ $version_hash $version_dirty >>version.lisp-expr
+ fi
+}
View
734 git/post-receive-email
@@ -0,0 +1,734 @@
+#!/bin/sh
+#
+# (Modified for SBCL.)
+#
+# Copyright (c) 2007 Andy Parkins
+#
+# An example hook script to mail out commit update information. This hook
+# sends emails listing new revisions to the repository introduced by the
+# change being reported. The rule is that (for branch updates) each commit
+# will appear on one email and one email only.
+#
+# This hook is stored in the contrib/hooks directory. Your distribution
+# will have put this somewhere standard. You should make this script
+# executable then link to it in the repository you would like to use it in.
+# For example, on fedora the hook is stored in
+# /usr/share/git-core/contrib/hooks/post-receive-email:
+#
+# chmod a+x post-receive-email
+# cd /path/to/your/repository.git
+# ln -sf /usr/share/git-core/contrib/hooks/post-receive-email hooks/post-receive
+#
+# This hook script assumes it is enabled on the central repository of a
+# project, with all users pushing only to it and not between each other. It
+# will still work if you don't operate in that style, but it would become
+# possible for the email to be from someone other than the person doing the
+# push.
+#
+# Config
+# ------
+# hooks.mailinglist
+# This is the list that all pushes will go to; leave it blank to not send
+# emails for every ref update.
+# hooks.announcelist
+# This is the list that all pushes of annotated tags will go to. Leave it
+# blank to default to the mailinglist field. The announce emails lists
+# the short log summary of the changes since the last annotated tag.
+# hooks.envelopesender
+# If set then the -f option is passed to sendmail to allow the envelope
+# sender address to be set
+# hooks.emailprefix
+# All emails have their subjects prefixed with this prefix, or "[SCM]"
+# if emailprefix is unset, to aid filtering
+# hooks.showrev
+# The shell command used to format each revision in the email, with
+# "%s" replaced with the commit id. Defaults to "git rev-list -1
+# --pretty %s", displaying the commit id, author, date and log
+# message. To list full patches separated by a blank line, you
+# could set this to "git show -C %s; echo".
+# To list a gitweb/cgit URL *and* a full patch for each change set, use this:
+# "t=%s; printf 'http://.../?id=%%s' \$t; echo;echo; git show -C \$t; echo"
+# Be careful if "..." contains things that will be expanded by shell "eval"
+# or printf.
+#
+# Notes
+# -----
+# All emails include the headers "X-Git-Refname", "X-Git-Oldrev",
+# "X-Git-Newrev", and "X-Git-Reftype" to enable fine tuned filtering and
+# give information for debugging.
+#
+
+# ---------------------------- Functions
+
+#
+# Top level email generation function. This decides what type of update
+# this is and calls the appropriate body-generation routine after outputting
+# the common header
+#
+# Note this function doesn't actually generate any email output, that is
+# taken care of by the functions it calls:
+# - generate_email_header
+# - generate_create_XXXX_email
+# - generate_update_XXXX_email
+# - generate_delete_XXXX_email
+# - generate_email_footer
+#
+generate_email()
+{
+ # --- Arguments
+ oldrev=$(git rev-parse $1)
+ newrev=$(git rev-parse $2)
+ refname="$3"
+
+ # --- Interpret
+ # 0000->1234 (create)
+ # 1234->2345 (update)
+ # 2345->0000 (delete)
+ if expr "$oldrev" : '0*$' >/dev/null
+ then
+ change_type="create"
+ else
+ if expr "$newrev" : '0*$' >/dev/null
+ then
+ change_type="delete"
+ else
+ change_type="update"
+ fi
+ fi
+
+ # --- Get the revision types
+ newrev_type=$(git cat-file -t $newrev 2> /dev/null)
+ oldrev_type=$(git cat-file -t "$oldrev" 2> /dev/null)
+ case "$change_type" in
+ create|update)
+ rev="$newrev"
+ rev_type="$newrev_type"
+ ;;
+ delete)
+ rev="$oldrev"
+ rev_type="$oldrev_type"
+ ;;
+ esac
+
+ # The revision type tells us what type the commit is, combined with
+ # the location of the ref we can decide between
+ # - working branch
+ # - tracking branch
+ # - unannoted tag
+ # - annotated tag
+ case "$refname","$rev_type" in
+ refs/tags/*,commit)
+ # un-annotated tag
+ refname_type="tag"
+ short_refname=${refname##refs/tags/}
+ ;;
+ refs/tags/*,tag)
+ # annotated tag
+ refname_type="annotated tag"
+ short_refname=${refname##refs/tags/}
+ # change recipients
+ if [ -n "$announcerecipients" ]; then
+ recipients="$announcerecipients"
+ fi
+ ;;
+ refs/heads/*,commit)
+ # branch
+ refname_type="branch"
+ short_refname=${refname##refs/heads/}
+ ;;
+ refs/remotes/*,commit)
+ # tracking branch
+ refname_type="tracking branch"
+ short_refname=${refname##refs/remotes/}
+ echo >&2 "*** Push-update of tracking branch, $refname"
+ echo >&2 "*** - no email generated."
+ exit 0
+ ;;
+ *)
+ # Anything else (is there anything else?)
+ echo >&2 "*** Unknown type of update to $refname ($rev_type)"
+ echo >&2 "*** - no email generated"
+ exit 1
+ ;;
+ esac
+
+ # Check if we've got anyone to send to
+ if [ -z "$recipients" ]; then
+ case "$refname_type" in
+ "annotated tag")
+ config_name="hooks.announcelist"
+ ;;
+ *)
+ config_name="hooks.mailinglist"
+ ;;
+ esac
+ echo >&2 "*** $config_name is not set so no email will be sent"
+ echo >&2 "*** for $refname update $oldrev->$newrev"
+ exit 0
+ fi
+
+ # Email parameters
+ # The email subject will contain the best description of the ref
+ # that we can build from the parameters
+ describe=$(git describe $rev 2>/dev/null)
+ if [ -z "$describe" ]; then
+ describe=$rev
+ fi
+ # SBCL: Also grab the commit title.
+ title=$(git log -n1 --pretty=format:%s $rev)
+ if [ -z "$title" ]; then
+ title=$rev
+ fi
+
+ generate_email_header
+
+ # Call the correct body generation function
+ fn_name=general
+ case "$refname_type" in
+ "tracking branch"|branch)
+ fn_name=branch
+ ;;
+ "annotated tag")
+ fn_name=atag
+ ;;
+ esac
+ generate_${change_type}_${fn_name}_email
+
+ generate_email_footer
+}
+
+generate_email_header()
+{
+ # --- Email (all stdout will be the email)
+ # Generate header
+
+ # SBCL: branch updates get the commit title in the subject
+ if [ "branch" = "$refname_type" ] && [ "update" = "$change_type" ]
+ then
+ subject="${emailprefix} $short_refname: $title"
+ else
+ subject="${emailprefix} $refname_type $short_refname: ${change_type}d. $describe"
+ fi
+
+ cat <<-EOF
+ To: $recipients
+ Subject: $subject
+ X-Git-Refname: $refname
+ X-Git-Reftype: $refname_type
+ X-Git-Oldrev: $oldrev
+ X-Git-Newrev: $newrev
+
+The $refname_type "$short_refname" has been ${change_type}d in $projectdesc:
+ EOF
+}
+
+generate_email_footer()
+{
+ SPACE=" "
+ cat <<-EOF
+
+
+ hooks/post-receive
+ --${SPACE}
+ $projectdesc
+ EOF
+}
+
+# --------------- Branches
+
+#
+# Called for the creation of a branch
+#
+generate_create_branch_email()
+{
+ # This is a new branch and so oldrev is not valid
+ echo " at $newrev ($newrev_type)"
+ echo ""
+
+ echo $LOGBEGIN
+ show_new_revisions
+ echo $LOGEND
+}
+
+#
+# Called for the change of a pre-existing branch
+#
+generate_update_branch_email()
+{
+ # Consider this:
+ # 1 --- 2 --- O --- X --- 3 --- 4 --- N
+ #
+ # O is $oldrev for $refname
+ # N is $newrev for $refname
+ # X is a revision pointed to by some other ref, for which we may
+ # assume that an email has already been generated.
+ # In this case we want to issue an email containing only revisions
+ # 3, 4, and N. Given (almost) by
+ #
+ # git rev-list N ^O --not --all
+ #
+ # The reason for the "almost", is that the "--not --all" will take
+ # precedence over the "N", and effectively will translate to
+ #
+ # git rev-list N ^O ^X ^N
+ #
+ # So, we need to build up the list more carefully. git rev-parse
+ # will generate a list of revs that may be fed into git rev-list.
+ # We can get it to make the "--not --all" part and then filter out
+ # the "^N" with:
+ #
+ # git rev-parse --not --all | grep -v N
+ #
+ # Then, using the --stdin switch to git rev-list we have effectively
+ # manufactured
+ #
+ # git rev-list N ^O ^X
+ #
+ # This leaves a problem when someone else updates the repository
+ # while this script is running. Their new value of the ref we're
+ # working on would be included in the "--not --all" output; and as
+ # our $newrev would be an ancestor of that commit, it would exclude
+ # all of our commits. What we really want is to exclude the current
+ # value of $refname from the --not list, rather than N itself. So:
+ #
+ # git rev-parse --not --all | grep -v $(git rev-parse $refname)
+ #
+ # Get's us to something pretty safe (apart from the small time
+ # between refname being read, and git rev-parse running - for that,
+ # I give up)
+ #
+ #
+ # Next problem, consider this:
+ # * --- B --- * --- O ($oldrev)
+ # \
+ # * --- X --- * --- N ($newrev)
+ #
+ # That is to say, there is no guarantee that oldrev is a strict
+ # subset of newrev (it would have required a --force, but that's
+ # allowed). So, we can't simply say rev-list $oldrev..$newrev.
+ # Instead we find the common base of the two revs and list from
+ # there.
+ #
+ # As above, we need to take into account the presence of X; if
+ # another branch is already in the repository and points at some of
+ # the revisions that we are about to output - we don't want them.
+ # The solution is as before: git rev-parse output filtered.
+ #
+ # Finally, tags: 1 --- 2 --- O --- T --- 3 --- 4 --- N
+ #
+ # Tags pushed into the repository generate nice shortlog emails that
+ # summarise the commits between them and the previous tag. However,
+ # those emails don't include the full commit messages that we output
+ # for a branch update. Therefore we still want to output revisions
+ # that have been output on a tag email.
+ #
+ # Luckily, git rev-parse includes just the tool. Instead of using
+ # "--all" we use "--branches"; this has the added benefit that
+ # "remotes/" will be ignored as well.
+
+ # List all of the revisions that were removed by this update, in a
+ # fast-forward update, this list will be empty, because rev-list O
+ # ^N is empty. For a non-fast-forward, O ^N is the list of removed
+ # revisions
+ fast_forward=""
+ rev=""
+ for rev in $(git rev-list $newrev..$oldrev)
+ do
+ revtype=$(git cat-file -t "$rev")
+ echo " discards $rev ($revtype)"
+ done
+ if [ -z "$rev" ]; then
+ fast_forward=1
+ fi
+
+ # List all the revisions from baserev to newrev in a kind of
+ # "table-of-contents"; note this list can include revisions that
+ # have already had notification emails and is present to show the
+ # full detail of the change from rolling back the old revision to
+ # the base revision and then forward to the new revision
+ #
+ # For SBCL we skip this for branch updates, since we're getting
+ # one email per commit.
+ if [ "branch" != "$refname_type" ] || [ "update" != "$change_type" ]
+ then
+ for rev in $(git rev-list $oldrev..$newrev)
+ do
+ revtype=$(git cat-file -t "$rev")
+ echo " via $rev ($revtype)"
+ done
+ fi
+
+ if [ "$fast_forward" ]; then
+ echo " from $oldrev ($oldrev_type)"
+ else
+ # 1. Existing revisions were removed. In this case newrev
+ # is a subset of oldrev - this is the reverse of a
+ # fast-forward, a rewind
+ # 2. New revisions were added on top of an old revision,
+ # this is a rewind and addition.
+
+ # (1) certainly happened, (2) possibly. When (2) hasn't
+ # happened, we set a flag to indicate that no log printout
+ # is required.
+
+ echo ""
+
+ # Find the common ancestor of the old and new revisions and
+ # compare it with newrev
+ baserev=$(git merge-base $oldrev $newrev)
+ rewind_only=""
+ if [ "$baserev" = "$newrev" ]; then
+ echo "This update discarded existing revisions and left the branch pointing at"
+ echo "a previous point in the repository history."
+ echo ""
+ echo " * -- * -- N ($newrev)"
+ echo " \\"
+ echo " O -- O -- O ($oldrev)"
+ echo ""
+ echo "The removed revisions are not necessarilly gone - if another reference"
+ echo "still refers to them they will stay in the repository."
+ rewind_only=1
+ else
+ echo "This update added new revisions after undoing existing revisions. That is"
+ echo "to say, the old revision is not a strict subset of the new revision. This"
+ echo "situation occurs when you --force push a change and generate a repository"
+ echo "containing something like this:"
+ echo ""
+ echo " * -- * -- B -- O -- O -- O ($oldrev)"
+ echo " \\"
+ echo " N -- N -- N ($newrev)"
+ echo ""
+ echo "When this happens we assume that you've already had alert emails for all"
+ echo "of the O revisions, and so we here report only the revisions in the N"
+ echo "branch from the common base, B."
+ fi
+ fi
+
+ echo ""
+ if [ -z "$rewind_only" ]; then
+ # Silenced for SBCL.
+ #
+ # echo "Those revisions listed above that are new to this repository have"
+ # echo "not appeared on any other notification email; so we list those"
+ # echo "revisions in full, below."
+
+ echo ""
+ echo $LOGBEGIN
+ show_new_revisions
+
+ # XXX: Need a way of detecting whether git rev-list actually
+ # outputted anything, so that we can issue a "no new
+ # revisions added by this update" message
+
+ echo $LOGEND
+ else
+ echo "No new revisions were added by this update."
+ fi
+
+ # The diffstat is shown from the old revision to the new revision.
+ # This is to show the truth of what happened in this change.
+ # There's no point showing the stat from the base to the new
+ # revision because the base is effectively a random revision at this
+ # point - the user will be interested in what this revision changed
+ # - including the undoing of previous revisions in the case of
+ # non-fast-forward updates.
+ #
+ # Silenced for SBCL: we use "git show -p --stat -C %s" to generate
+ # revision information, getting the diffstat between the commit message
+ # and the diff. This would just duplicate that.
+ #
+ # echo ""
+ # echo "Summary of changes:"
+ # git diff-tree --stat --summary --find-copies-harder $oldrev..$newrev
+}
+
+#
+# Called for the deletion of a branch
+#
+generate_delete_branch_email()
+{
+ echo " was $oldrev"
+ echo ""
+ echo $LOGEND
+ git show -s --pretty=oneline $oldrev
+ echo $LOGEND
+}
+
+# --------------- Annotated tags
+
+#
+# Called for the creation of an annotated tag
+#
+generate_create_atag_email()
+{
+ echo " at $newrev ($newrev_type)"
+
+ generate_atag_email
+}
+
+#
+# Called for the update of an annotated tag (this is probably a rare event
+# and may not even be allowed)
+#
+generate_update_atag_email()
+{
+ echo " to $newrev ($newrev_type)"
+ echo " from $oldrev (which is now obsolete)"
+
+ generate_atag_email
+}
+
+#
+# Called when an annotated tag is created or changed
+#
+generate_atag_email()
+{
+ # Use git for-each-ref to pull out the individual fields from the
+ # tag
+ eval $(git for-each-ref --shell --format='
+ tagobject=%(*objectname)
+ tagtype=%(*objecttype)
+ tagger=%(taggername)
+ tagged=%(taggerdate)' $refname
+ )
+
+ echo " tagging $tagobject ($tagtype)"
+ case "$tagtype" in
+ commit)
+
+ # If the tagged object is a commit, then we assume this is a
+ # release, and so we calculate which tag this tag is
+ # replacing
+ prevtag=$(git describe --abbrev=0 $newrev^ 2>/dev/null)
+
+ if [ -n "$prevtag" ]; then
+ echo " replaces $prevtag"
+ fi
+ ;;
+ *)
+ echo " length $(git cat-file -s $tagobject) bytes"
+ ;;
+ esac
+ echo " tagged by $tagger"
+ echo " on $tagged"
+
+ echo ""
+ echo $LOGBEGIN
+
+ # Show the content of the tag message; this might contain a change
+ # log or release notes so is worth displaying.
+ git cat-file tag $newrev | sed -e '1,/^$/d'
+
+ echo ""
+ case "$tagtype" in
+ commit)
+ # Only commit tags make sense to have rev-list operations
+ # performed on them
+ if [ -n "$prevtag" ]; then
+ # Show changes since the previous release
+ git rev-list --pretty=short "$prevtag..$newrev" | git shortlog
+ else
+ # No previous tag, show all the changes since time
+ # began
+ git rev-list --pretty=short $newrev | git shortlog
+ fi
+ ;;
+ *)
+ # XXX: Is there anything useful we can do for non-commit
+ # objects?
+ ;;
+ esac
+
+ echo $LOGEND
+}
+
+#
+# Called for the deletion of an annotated tag
+#
+generate_delete_atag_email()
+{
+ echo " was $oldrev"
+ echo ""
+ echo $LOGEND
+ git show -s --pretty=oneline $oldrev
+ echo $LOGEND
+}
+
+# --------------- General references
+
+#
+# Called when any other type of reference is created (most likely a
+# non-annotated tag)
+#
+generate_create_general_email()
+{
+ echo " at $newrev ($newrev_type)"
+
+ generate_general_email
+}
+
+#
+# Called when any other type of reference is updated (most likely a
+# non-annotated tag)
+#
+generate_update_general_email()
+{
+ echo " to $newrev ($newrev_type)"
+ echo " from $oldrev"
+
+ generate_general_email
+}
+
+#
+# Called for creation or update of any other type of reference
+#
+generate_general_email()
+{
+ # Unannotated tags are more about marking a point than releasing a
+ # version; therefore we don't do the shortlog summary that we do for
+ # annotated tags above - we simply show that the point has been
+ # marked, and print the log message for the marked point for
+ # reference purposes
+ #
+ # Note this section also catches any other reference type (although
+ # there aren't any) and deals with them in the same way.
+
+ echo ""
+ if [ "$newrev_type" = "commit" ]; then
+ echo $LOGBEGIN
+ git show --no-color --root -s --pretty=medium $newrev
+ echo $LOGEND
+ else
+ # What can we do here? The tag marks an object that is not
+ # a commit, so there is no log for us to display. It's
+ # probably not wise to output git cat-file as it could be a
+ # binary blob. We'll just say how big it is
+ echo "$newrev is a $newrev_type, and is $(git cat-file -s $newrev) bytes long."
+ fi
+}
+
+#
+# Called for the deletion of any other type of reference
+#
+generate_delete_general_email()
+{
+ echo " was $oldrev"
+ echo ""
+ echo $LOGEND
+ git show -s --pretty=oneline $oldrev
+ echo $LOGEND
+}
+
+
+# --------------- Miscellaneous utilities
+
+#
+# Show new revisions as the user would like to see them in the email.
+#
+show_new_revisions()
+{
+ # This shows all log entries that are not already covered by
+ # another ref - i.e. commits that are now accessible from this
+ # ref that were previously not accessible
+ # (see generate_update_branch_email for the explanation of this
+ # command)
+
+ # Revision range passed to rev-list differs for new vs. updated
+ # branches.
+ if [ "$change_type" = create ]
+ then
+ # Show all revisions exclusive to this (new) branch.
+ revspec=$newrev
+ else
+ # Branch update; show revisions not part of $oldrev.
+ revspec=$oldrev..$newrev
+ fi
+
+ other_branches=$(git for-each-ref --format='%(refname)' refs/heads/ |
+ grep -F -v $refname)
+ # SBCL: show oldest first via --reverse
+ git rev-parse --not $other_branches |
+ if [ -z "$custom_showrev" ]
+ then
+ git rev-list --reverse --pretty --stdin $revspec
+ else
+ git rev-list --reverse --stdin $revspec |
+ while read onerev
+ do
+ eval $(printf "$custom_showrev" $onerev)
+ done
+ fi
+}
+
+
+send_mail()
+{
+ if [ -n "$envelopesender" ]; then
+ /usr/sbin/sendmail -t -f "$envelopesender"
+ else
+ /usr/sbin/sendmail -t
+ fi
+}
+
+# ---------------------------- main()
+
+# --- Constants
+LOGBEGIN="- Log -----------------------------------------------------------------"
+LOGEND="-----------------------------------------------------------------------"
+
+# --- Config
+# Set GIT_DIR either from the working directory, or from the environment
+# variable.
+GIT_DIR=$(git rev-parse --git-dir 2>/dev/null)
+if [ -z "$GIT_DIR" ]; then
+ echo >&2 "fatal: post-receive: GIT_DIR not set"
+ exit 1
+fi
+
+projectdesc=$(sed -ne '1p' "$GIT_DIR/description")
+# Check if the description is unchanged from it's default, and shorten it to
+# a more manageable length if it is
+if expr "$projectdesc" : "Unnamed repository.*$" >/dev/null
+then
+ projectdesc="UNNAMED PROJECT"
+fi
+
+recipients=$(git config hooks.mailinglist)
+announcerecipients=$(git config hooks.announcelist)
+envelopesender=$(git config hooks.envelopesender)
+emailprefix=$(git config hooks.emailprefix || echo '[SCM] ')
+custom_showrev=$(git config hooks.showrev)
+
+# --- Main loop
+# Allow dual mode: run from the command line just like the update hook, or
+# if no arguments are given then run as a hook script
+if [ -n "$1" -a -n "$2" -a -n "$3" ]; then
+ # Output to the terminal in command line mode - if someone wanted to
+ # resend an email; they could redirect the output to sendmail
+ # themselves
+ PAGER= generate_email $2 $3 $1
+else
+ while read oldrev newrev refname
+ do
+ echo "Sending email for $refname: $oldrev -> $newrev"
+ # SBCL KLUDGE: the default script sends one email per
+ # push. We want one per commit. As long as we're
+ # in fast-forward-only world, this should do the
+ # right thing.
+ if (expr "$oldrev" : '0*$' >/dev/null ||
+ expr "$newrev" : '0*$' >/dev/null ||
+ ! expr "$refname" : "refs/heads/" > /dev/null)
+ then
+ # Just one email.
+ generate_email $oldrev $newrev $refname | send_mail
+ else
+ # Branch update, one mail per commit.
+ lastrev=$oldrev
+ for step in $(git rev-list --reverse $oldrev..$newrev)
+ do
+ generate_email $lastrev $step $refname | send_mail
+ lastrev=$step
+ done
+ fi
+ done
+fi
View
3  make.sh
@@ -186,6 +186,9 @@ export DEVNULL
. ./find-gnumake.sh
find_gnumake
+. ./generate-version.sh
+generate_version
+
# If you're cross-compiling, you should probably just walk through the
# make-config.sh script by hand doing the right thing on both the host
# and target machines.
View
180 release.sh
@@ -1,71 +1,180 @@
#! /bin/sh
-set -ex
+set -e
+
+usage () {
+ if ! [ -z "$1" ]
+ then
+ echo $1
+ fi
+ cat <<EOF
+
+usage: $0 [-s] VERSION-NUMBER [REV]
+
+ This script frobs NEWS, makes a "release" commit, builds, runs tests
+ and creates an annotated tag for the release with VERSION-NUMBER.
+
+ If -s is given, then use the gpg-sign mechanism of "git tag". You
+ will need to have your gpg secret key handy.
+
+ if REV is given, it is the git revision to build into a release.
+ Default is origin/master.
+
+ No changes will be pushed upstream. This script will tell you how to
+ do this when it finishes.
+
+EOF
+ exit 1
+}
+
+if [ "-s" = "$1" ] || [ "--sign" = "$1" ]
+then
+ sign="-s"; shift
+else
+ sign=""
+fi
+
+if [ -z "$1" ]
+then
+ usage "No version number."
+else
+ version=$1; shift
+fi
+
+if [ -z "$1" ]
+then
+ rev=origin/master
+else
+ rev=$1; shift
+ type=$(git cat-file -t "$rev" 2> /dev/null || echo "unknown")
+ if ([ "tag" != "$type" ] && [ "commit" != "$type" ])
+ then
+ usage "$rev is $type, not a tag or a commit."
+ fi
+fi
+
+if ! [ -z "$@" ]
+then
+ usage "Extra command-line arguments: $@"
+fi
+
+sbcl_directory="$(cd "$(dirname $0)"; pwd)"
+tmpfile=$(mktemp -t sbcl-build-$(date +%Y%m%d)-XXXXXXXXX)
+tmpdir="$(mktemp -d -t sbcl-build-tree-$(date +%Y%m%d)-XXXXXXXXX)"
+
+## Check for messy work dirs:
+
+echo "Fetching updates."
+git fetch
+
+branch_name="release-$(date '+%s')"
+original_branch="$(git describe --all --contains HEAD)"
+trap "cd \"$sbcl_directory\" ; git checkout $original_branch" EXIT
+git checkout -b $branch_name $rev
+
+echo "Checking that the tree is clean."
+if ! [ $(git status --porcelain | wc -l) = 0 ]
+then
+ echo "There are uncommitted / unpushed changes in this checkout!"
+ git status
+ exit 1
+fi
+
+## Perform the necessary changes to the NEWS file:
+
+echo "Munging NEWS"
+sed -i.orig "/^changes relative to sbcl-.*:/ s/changes/changes in sbcl-$version/ " NEWS
+rm -f NEWS.orig
+if ! grep "^changes in sbcl-$version relative to" NEWS > /dev/null
+then
+ echo "NEWS munging failed!"
+ exit 1
+fi
-cd "$1"
+cd "$sbcl_directory"
-sbcl_directory="$(pwd)"
+echo "Committing release version."
+git add NEWS
+git commit -m "$version: will be tagged as \"sbcl-$version\""
-cd "$sbcl_directory"
+relnotes=$tmpdir/sbcl-$version-release-notes.txt
+awk "BEGIN { state = 0 }
+ /^changes in sbcl-/ { state = 0 }
+ /^changes in sbcl-$version/ { state = 1 }
+ { if(state == 1) print \$0 }" < NEWS > $relnotes
-tmpfile=$(mktemp --tmpdir sbcl-build-$(date +%Y%m%d)-XXXXXXXXX)
+tag="sbcl-$version"
+echo "Tagging as $tag"
+git tag $sign -F $relnotes "$tag"
+SBCL_BUILDING_RELEASE_FROM=HEAD
+export SBCL_BUILDING_RELEASE_FROM
+echo "Building SBCL, log: $tmpfile"
./make.sh >$tmpfile 2>&1
-./src/runtime/sbcl --version | grep '^SBCL [1-9][0-9]*\.[0-9]\+\.[1-9][0-9]*$'
+if [ "SBCL $version" != "$(./src/runtime/sbcl --version)" ]
+then
+ echo "Built version number doesn't match requested one:" &>2
+ echo &>2
+ echo " $(./src/runtime/sbcl --version)" &>2
+ exit 1
+fi
-version=$(./src/runtime/sbcl --version | awk '{print $2}')
-grep "^changes in sbcl-$version relative to" NEWS
+built_version=$(./src/runtime/sbcl --version | awk '{print $2}')
+echo "Running tests, log: $tmpfile"
cd tests
sh ./run-tests.sh >>$tmpfile 2>&1
cd ..
-cp ./src/runtime/sbcl /tmp/sbcl-$version
-cp ./output/sbcl.core /tmp/sbcl-$version.core
+cp ./src/runtime/sbcl "$tmpdir"/sbcl-$version-bin
+cp ./output/sbcl.core "$tmpdir"/sbcl-$version.core
+
+echo "Self-building, log: $tmpfile"
+./make.sh --xc-host="$tmpdir/sbcl-$version-bin --core $tmpdir/sbcl-$version.core --no-userinit --no-sysinit --disable-debugger" >>$tmpfile 2>&1
-./make.sh "/tmp/sbcl-$version --core /tmp/sbcl-$version.core" > /tmp/sbcl-$version-build-log 2>&1
-cd doc && sh ./make-doc.sh
+echo "Building docs, log: $tmpfile"
+cd doc && sh ./make-doc.sh >$tmpfile 2>&1
cd ..
-rm /tmp/sbcl-$version /tmp/sbcl-$version.core
+rm -f "$tmpdir"/sbcl-$version-bin "$tmpdir"/sbcl-$version.core
-cp -a "$sbcl_directory" /tmp/sbcl-$version
+cp -a "$sbcl_directory" "$tmpdir"/sbcl-$version
-ln -s /tmp/sbcl-$version /tmp/sbcl-$version-x86-linux
-cd /tmp/
-sh sbcl-$version/binary-distribution.sh sbcl-$version-x86-linux
-sh sbcl-$version/html-distribution.sh sbcl-$version
+echo "Building tarballs, log $tmpfile"
+ln -s "$tmpdir"/sbcl-$version "$tmpdir"/sbcl-$version-x86-linux
+cd "$tmpdir"/
+sh sbcl-$version/binary-distribution.sh sbcl-$version-x86-linux >$tmpfile 2>&1
+sh sbcl-$version/html-distribution.sh sbcl-$version >$tmpfile 2>&1
cd sbcl-$version
-sh ./distclean.sh
+sh ./distclean.sh >$tmpfile 2>&1
cd ..
-sh sbcl-$version/source-distribution.sh sbcl-$version
-
-awk "BEGIN { state = 0 }
- /^changes in sbcl-/ { state = 0 }
- /^changes in sbcl-$version/ { state = 1 }
- { if(state == 1) print \$0 }" < sbcl-$version/NEWS > sbcl-$version-release-notes.txt
+sh sbcl-$version/source-distribution.sh sbcl-$version >$tmpfile 2>&1
echo "The SHA256 checksums of the following distribution files are:" > sbcl-$version-crhodes
echo >> sbcl-$version-crhodes
sha256sum sbcl-$version*.tar >> sbcl-$version-crhodes
-bzip2 /tmp/sbcl-$version*.tar
+bzip2 "$tmpdir"/sbcl-$version*.tar
-echo Bugs fixed by sbcl-$version release > sbcl-$version-bugmail.txt
-for bugnum in $(egrep -o "#[1-9][0-9][0-9][0-9][0-9][0-9]+" sbcl-$version-release-notes.txt | sed s/#// | sort -n)
+echo "Building bugmail."
+bugmail=sbcl-$version-bugmail.txt
+echo Bugs fixed by sbcl-$version release > $bugmail
+for bugnum in $(egrep -o "#[1-9][0-9][0-9][0-9][0-9][0-9]+" $relnotes | sed s/#// | sort -n)
do
- printf "\n bug %s\n status fixreleased" $bugnum >> sbcl-$version-bugmail.txt
+ printf "\n bug %s\n status fixreleased" $bugnum >> $bugmail
done
-echo >> sbcl-$version-bugmail.txt
-
-set +x
+echo >> $bugmail
+echo SBCL distribution has been prepared in "$tmpdir"
echo TODO:
echo
-echo cvs commit -m "\"$version: will be tagged as sbcl_$(echo $version | sed 's/\./_/g')\""
-echo cvs tag sbcl_$(echo $version | sed 's/\./_/g')
-echo gpg -sta /tmp/sbcl-$version-crhodes
+echo "Sanity check: git show $tag"
+echo
+echo "git merge $branch_name && git push && git push --tags"
+echo "git branch -d $branch_name"
+echo "cd \"$tmpdir\""
+echo gpg -sta sbcl-$version-crhodes
echo sftp crhodes,sbcl@frs.sourceforge.net
echo \* cd /home/frs/project/s/sb/sbcl/sbcl
echo \* mkdir $version
@@ -89,3 +198,4 @@ echo \* check and send sbcl-$version-bugmail.txt to edit@bugs.launchpad.net
echo \ \ '(sign: C-c RET s p)'
echo \* update \#lisp IRC topic
echo \* update sbcl website
+
View
2  source-distribution.sh
@@ -4,4 +4,4 @@ set -e
# Create a source distribution. (You should run clean.sh first.)
b=${1:?"missing base directory name argument"}
-tar cf $b-source.tar $b
+tar cf $b-source.tar --exclude .git $b
View
6 src/code/misc.lisp
@@ -16,8 +16,4 @@
"SBCL")
(defun sb!xc:lisp-implementation-version ()
- #.(format nil "~A~@[.~A~]"
- (sb-cold:read-from-file "version.lisp-expr")
- (let ((pathname "branch-version.lisp-expr"))
- (when (probe-file pathname)
- (sb-cold:read-from-file pathname)))))
+ #.(sb-cold:read-from-file "version.lisp-expr"))
View
8 src/code/serve-event.lisp
@@ -330,7 +330,11 @@ happens. Server returns T if something happened and NIL otherwise. Timeout
(ecase (handler-direction handler)
(:input (sb!unix:fd-isset fd read-fds))
(:output (sb!unix:fd-isset fd write-fds)))))))
- (funcall (handler-function handler)
- (handler-descriptor handler)))
+ (with-simple-restart (remove-fd-handler "Remove ~S" handler)
+ (funcall (handler-function handler)
+ (handler-descriptor handler))
+ (go :next))
+ (remove-fd-handler handler)
+ :next)
t))))))
View
37 src/compiler/srctran.lisp
@@ -419,11 +419,38 @@
(t (,op ,x ,y))))
(defmacro bound-binop (op x y)
- `(and ,x ,y
- (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
- (set-bound (safely-binop ,op (type-bound-number ,x)
- (type-bound-number ,y))
- (or (consp ,x) (consp ,y))))))
+ (with-unique-names (xb yb res)
+ `(and ,x ,y
+ (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
+ (let* ((,xb (type-bound-number ,x))
+ (,yb (type-bound-number ,y))
+ (,res (safely-binop ,op ,xb ,yb)))
+ (set-bound ,res
+ (and (or (consp ,x) (consp ,y))
+ ;; Open bounds can very easily be messed up
+ ;; by FP rounding, so take care here.
+ ,(case op
+ (*
+ ;; Multiplying a greater-than-zero with
+ ;; less than one can round to zero.
+ `(or (not (fp-zero-p ,res))
+ (cond ((and (consp ,x) (fp-zero-p ,xb))
+ (>= (abs ,yb) 1))
+ ((and (consp ,y) (fp-zero-p ,yb))
+ (>= (abs ,xb) 1)))))
+ (/
+ ;; Dividing a greater-than-zero with
+ ;; greater than one can round to zero.
+ `(or (not (fp-zero-p ,res))
+ (cond ((and (consp ,x) (fp-zero-p ,xb))
+ (<= (abs ,yb) 1))
+ ((and (consp ,y) (fp-zero-p ,yb))
+ (<= (abs ,xb) 1)))))
+ ((+ -)
+ ;; Adding or subtracting greater-than-zero
+ ;; can end up with identity.
+ `(and (not (fp-zero-p ,xb))
+ (not (fp-zero-p ,yb))))))))))))
(defun coerce-for-bound (val type)
(if (consp val)
View
58 src/runtime/gencgc.c
@@ -530,7 +530,29 @@ write_generation_stats(FILE *file)
}
extern void
-print_generation_stats()
+write_heap_exhaustion_report(FILE *file, long available, long requested,
+ struct thread *thread)
+{
+ fprintf(file,
+ "Heap exhausted during %s: %ld bytes available, %ld requested.\n",
+ gc_active_p ? "garbage collection" : "allocation",
+ available,
+ requested);
+ write_generation_stats(file);
+ fprintf(file, "GC control variables:\n");
+ fprintf(file, " *GC-INHIBIT* = %s\n *GC-PENDING* = %s\n",
+ SymbolValue(GC_INHIBIT,thread)==NIL ? "false" : "true",
+ (SymbolValue(GC_PENDING, thread) == T) ?
+ "true" : ((SymbolValue(GC_PENDING, thread) == NIL) ?
+ "false" : "in progress"));
+#ifdef LISP_FEATURE_SB_THREAD
+ fprintf(file, " *STOP-FOR-GC-PENDING* = %s\n",
+ SymbolValue(STOP_FOR_GC_PENDING,thread)==NIL ? "false" : "true");
+#endif
+}
+
+extern void
+print_generation_stats(void)
{
write_generation_stats(stderr);
}
@@ -548,11 +570,28 @@ log_generation_stats(char *logfile, char *header)
write_generation_stats(log);
fclose(log);
} else {
- fprintf(stderr, "Could not open gc logile: %s\n", gc_logfile);
+ fprintf(stderr, "Could not open gc logfile: %s\n", logfile);
fflush(stderr);
}
}
}
+
+extern void
+report_heap_exhaustion(long available, long requested, struct thread *th)
+{
+ if (gc_logfile) {
+ FILE * log = fopen(gc_logfile, "a");
+ if (log) {
+ write_heap_exhaustion_report(log, available, requested, th);
+ fclose(log);
+ } else {
+ fprintf(stderr, "Could not open gc logfile: %s\n", gc_logfile);
+ fflush(stderr);
+ }
+ }
+ /* Always to stderr as well. */
+ write_heap_exhaustion_report(stderr, available, requested, th);
+}
#if defined(LISP_FEATURE_X86)
@@ -1209,20 +1248,7 @@ gc_heap_exhausted_error_or_lose (intptr_t available, intptr_t requested)
* the danger that we bounce back here before the error has been
* handled, or indeed even printed.
*/
- fprintf(stderr, "Heap exhausted during %s: %ld bytes available, %ld requested.\n",
- gc_active_p ? "garbage collection" : "allocation",
- available, requested);
- print_generation_stats();
- fprintf(stderr, "GC control variables:\n");
- fprintf(stderr, " *GC-INHIBIT* = %s\n *GC-PENDING* = %s\n",
- SymbolValue(GC_INHIBIT,thread)==NIL ? "false" : "true",
- (SymbolValue(GC_PENDING, thread) == T) ?
- "true" : ((SymbolValue(GC_PENDING, thread) == NIL) ?
- "false" : "in progress"));
-#ifdef LISP_FEATURE_SB_THREAD
- fprintf(stderr, " *STOP-FOR-GC-PENDING* = %s\n",
- SymbolValue(STOP_FOR_GC_PENDING,thread)==NIL ? "false" : "true");
-#endif
+ report_heap_exhaustion(available, requested, thread);
if (gc_active_p || (available == 0)) {
/* If we are in GC, or totally out of memory there is no way
* to sanely transfer control to the lisp-side of things.
View
3  tests/alien.impure.lisp
@@ -264,8 +264,7 @@
((foo (unsigned 32)))
foo)
-#+(or x86-64 x86)
-(with-test (:name bug-316325)
+(with-test (:name bug-316325 :skipped-on '(not (or :x86-64 :x86)))
;; This test works by defining a callback function that provides an
;; identity transform over a full-width machine word, then calling
;; it as if it returned a narrower type and checking to see if any
View
34 tests/compiler.pure.lisp
@@ -3892,3 +3892,37 @@
(let* ((cell (cons t t)))
(funcall f cell :ok)
(assert (equal '(:ok . t) cell)))))
+
+(with-test (:name (:bug-793771 +))
+ (let ((f (compile nil `(lambda (x y)
+ (declare (type (single-float 2.0) x)
+ (type (single-float (0.0)) y))
+ (+ x y)))))
+ (assert (equal `(function ((single-float 2.0) (single-float (0.0)))
+ (values (single-float 2.0) &optional))
+ (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 -))
+ (let ((f (compile nil `(lambda (x y)
+ (declare (type (single-float * 2.0) x)
+ (type (single-float (0.0)) y))
+ (- x y)))))
+ (assert (equal `(function ((single-float * 2.0) (single-float (0.0)))
+ (values (single-float * 2.0) &optional))
+ (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 *))
+ (let ((f (compile nil `(lambda (x)
+ (declare (type (single-float (0.0)) x))
+ (* x 0.1)))))
+ (assert (equal `(function ((single-float (0.0)))
+ (values (or (member 0.0) (single-float (0.0))) &optional))
+ (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-793771 /))
+ (let ((f (compile nil `(lambda (x)
+ (declare (type (single-float (0.0)) x))
+ (/ x 3.0)))))
+ (assert (equal `(function ((single-float (0.0)))
+ (values (or (member 0.0) (single-float (0.0))) &optional))
+ (sb-kernel:%simple-fun-type f)))))
View
95 tests/deadline.impure.lisp
@@ -65,55 +65,52 @@
(assert (= n 1))
(assert (not final))))
-#+(and sb-thread (not sb-lutex))
-(progn
-
- (with-test (:name (:deadline :get-mutex))
- (assert-timeout
- (let ((lock (sb-thread:make-mutex))
- (waitp t))
- (sb-thread:make-thread (lambda ()
- (sb-thread:get-mutex lock)
- (setf waitp nil)
- (sleep 5)))
- (loop while waitp do (sleep 0.01))
- (sb-sys:with-deadline (:seconds 1)
- (sb-thread:get-mutex lock)))))
-
- (with-test (:name (:deadline :wait-on-semaphore))
- (assert-timeout
- (let ((sem (sb-thread::make-semaphore :count 0)))
- (sb-sys:with-deadline (:seconds 1)
- (sb-thread::wait-on-semaphore sem)))))
+(with-test (:name (:deadline :get-mutex) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+ (assert-timeout
+ (let ((lock (sb-thread:make-mutex))
+ (waitp t))
+ (sb-thread:make-thread (lambda ()
+ (sb-thread:get-mutex lock)
+ (setf waitp nil)
+ (sleep 5)))
+ (loop while waitp do (sleep 0.01))
+ (sb-sys:with-deadline (:seconds 1)
+ (sb-thread:get-mutex lock)))))
- (with-test (:name (:deadline :join-thread))
- (assert-timeout
+(with-test (:name (:deadline :wait-on-semaphore) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+ (assert-timeout
+ (let ((sem (sb-thread::make-semaphore :count 0)))
(sb-sys:with-deadline (:seconds 1)
- (sb-thread:join-thread
- (sb-thread:make-thread (lambda () (loop (sleep 1))))))))
+ (sb-thread::wait-on-semaphore sem)))))
+
+(with-test (:name (:deadline :join-thread) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+ (assert-timeout
+ (sb-sys:with-deadline (:seconds 1)
+ (sb-thread:join-thread
+ (sb-thread:make-thread (lambda () (loop (sleep 1))))))))
- (with-test (:name (:deadline :futex-wait-eintr))
- (let ((lock (sb-thread:make-mutex))
- (waitp t))
- (sb-thread:make-thread (lambda ()
- (sb-thread:get-mutex lock)
- (setf waitp nil)
- (sleep 5)))
- (loop while waitp do (sleep 0.01))
- (let ((thread (sb-thread:make-thread
- (lambda ()
- (let ((start (get-internal-real-time)))
- (handler-case
- (sb-sys:with-deadline (:seconds 1)
- (sb-thread:get-mutex lock))
- (sb-sys:deadline-timeout (x)
- (declare (ignore x))
- (let ((end (get-internal-real-time)))
- (float (/ (- end start)
- internal-time-units-per-second)
- 0.0)))))))))
- (sleep 0.3)
- (sb-thread:interrupt-thread thread (lambda () 42))
- (let ((seconds-passed (sb-thread:join-thread thread)))
- (format t "Deadline in ~S~%" seconds-passed)
- (assert (< seconds-passed 1.2)))))))
+(with-test (:name (:deadline :futex-wait-eintr) :skipped-on '(not (and :sb-thread (not :sb-lutex))))
+ (let ((lock (sb-thread:make-mutex))
+ (waitp t))
+ (sb-thread:make-thread (lambda ()
+ (sb-thread:get-mutex lock)
+ (setf waitp nil)
+ (sleep 5)))
+ (loop while waitp do (sleep 0.01))
+ (let ((thread (sb-thread:make-thread
+ (lambda ()
+ (let ((start (get-internal-real-time)))
+ (handler-case
+ (sb-sys:with-deadline (:seconds 1)
+ (sb-thread:get-mutex lock))
+ (sb-sys:deadline-timeout (x)
+ (declare (ignore x))
+ (let ((end (get-internal-real-time)))
+ (float (/ (- end start)
+ internal-time-units-per-second)
+ 0.0)))))))))
+ (sleep 0.3)
+ (sb-thread:interrupt-thread thread (lambda () 42))
+ (let ((seconds-passed (sb-thread:join-thread thread)))
+ (format t "Deadline in ~S~%" seconds-passed)
+ (assert (< seconds-passed 1.2))))))
View
26 tests/debug.impure.lisp
@@ -264,8 +264,7 @@
(assert (verify-backtrace (lambda () (bug-354 354)) '((bug-354 354)))))
;;; FIXME: This test really should be broken into smaller pieces
-(with-test (:name (:backtrace :tl-xep)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :tl-xep))
(with-details t
(assert (verify-backtrace #'namestring
'(((sb-c::tl-xep namestring) 0 ?)))))
@@ -273,8 +272,7 @@
(assert (verify-backtrace #'namestring
'((namestring))))))
-(with-test (:name (:backtrace :more-processor)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :more-processor))
(with-details t
(assert (verify-backtrace (lambda () (bt.1.1 :key))
'(((sb-c::&more-processor bt.1.1) &rest))))
@@ -290,8 +288,7 @@
(assert (verify-backtrace (lambda () (bt.1.3 :key))
'((bt.1.3 &rest))))))
-(with-test (:name (:backtrace :xep)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :xep))
(with-details t
(assert (verify-backtrace #'bt.2.1
'(((sb-c::xep bt.2.1) 0 ?))))
@@ -307,8 +304,7 @@
(assert (verify-backtrace #'bt.2.3
'((bt.2.3 &rest))))))
-(with-test (:name (:backtrace :varargs-entry)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :varargs-entry))
(with-details t
(assert (verify-backtrace #'bt.3.1
'(((sb-c::varargs-entry bt.3.1) :key nil))))
@@ -324,8 +320,7 @@
(assert (verify-backtrace #'bt.3.3
'((bt.3.3 &rest))))))
-(with-test (:name (:backtrace :hairy-args-processor)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :hairy-args-processor))
(with-details t
(assert (verify-backtrace #'bt.4.1
'(((sb-c::hairy-arg-processor bt.4.1) ?))))
@@ -342,8 +337,7 @@
'((bt.4.3 &rest))))))
-(with-test (:name (:backtrace :optional-processor)
- :fails-on '(and :x86 (or :sunos)))
+(with-test (:name (:backtrace :optional-processor))
(with-details t
(assert (verify-backtrace #'bt.5.1
'(((sb-c::&optional-processor bt.5.1)))))
@@ -434,9 +428,9 @@
;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
;;; suspicions that the breakpoint trace might corrupt the whole image
;;; on that platform.
-#-(and (or ppc x86 x86-64) (or darwin sunos))
(with-test (:name (trace :encapsulate nil)
- :fails-on '(or (and :ppc (not :linux)) :sparc :mips))
+ :fails-on '(or (and :ppc (not :linux)) :sparc :mips)
+ :broken-on '(or :darwin :sunos))
(let ((out (with-output-to-string (*trace-output*)
(trace trace-this :encapsulate nil)
(assert (eq 'ok (trace-this)))
@@ -444,9 +438,9 @@
(assert (search "TRACE-THIS" out))
(assert (search "returned OK" out))))
-#-(and (or ppc x86 x86-64) darwin)
(with-test (:name (trace-recursive :encapsulate nil)
- :fails-on '(or (and :ppc (not :linux)) :sparc :mips :sunos))
+ :fails-on '(or (and :ppc (not :linux)) :sparc :mips :sunos)
+ :broken-on '(or :darwin (and :x86 :sunos)))
(let ((out (with-output-to-string (*trace-output*)
(trace trace-fact :encapsulate nil)
(assert (= 120 (trace-fact 5)))
View
21 tests/dynamic-extent.impure.lisp
@@ -499,12 +499,10 @@
(defvar *a-cons* (cons nil nil))
-#+stack-allocatable-closures
-(with-test (:name (:no-consing :dx-closures))
+(with-test (:name (:no-consing :dx-closures) :skipped-on '(not :stack-allocatable-closures))
(assert-no-consing (dxclosure 42)))
-#+stack-allocatable-lists
-(with-test (:name (:no-consing :dx-lists))
+(with-test (:name (:no-consing :dx-lists) :skipped-on '(not :stack-allocatable-lists))
(assert-no-consing (dxlength 1 2 3))
(assert-no-consing (dxlength t t t t t t))
(assert-no-consing (dxlength))
@@ -520,8 +518,7 @@
(with-test (:name (:no-consing :dx-value-cell))
(assert-no-consing (dx-value-cell 13)))
-#+stack-allocatable-fixed-objects
-(with-test (:name (:no-consing :dx-fixed-objects))
+(with-test (:name (:no-consing :dx-fixed-objects) :skipped-on '(not :stack-allocatable-fixed-objects))
(assert-no-consing (cons-on-stack 42))
(assert-no-consing (make-foo1-on-stack 123))
(assert-no-consing (nested-good 42))
@@ -529,8 +526,7 @@
(assert-no-consing (dx-handler-bind 2))
(assert-no-consing (dx-handler-case 2)))
-#+stack-allocatable-vectors
-(with-test (:name (:no-consing :dx-vectors))
+(with-test (:name (:no-consing :dx-vectors) :skipped-on '(not :stack-allocatable-vectors))
(assert-no-consing (force-make-array-on-stack 128))
(assert-no-consing (make-array-on-stack-1))
(assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
@@ -539,8 +535,7 @@
(assert-no-consing (make-array-on-stack-5))
(assert-no-consing (vector-on-stack :x :y)))
-#+raw-instance-init-vops
-(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc)
+(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc :skipped-on '(not :raw-instance-init-vops))
(let (a b)
(setf a 1.24 b 1.23d0)
(assert-no-consing (make-foo2-on-stack a b)))
@@ -574,12 +569,10 @@
(sb-thread:with-mutex (*mutex*)
(true *mutex*)))
-#+sb-thread
-(with-test (:name (:no-consing :mutex) :fails-on :ppc)
+(with-test (:name (:no-consing :mutex) :fails-on :ppc :skipped-on '(not :sb-thread))
(assert-no-consing (test-mutex)))
-#+sb-thread
-(with-test (:name (:no-consing :spinlock) :fails-on :ppc)
+(with-test (:name (:no-consing :spinlock) :fails-on :ppc :skipped-on '(not :sb-thread))
(assert-no-consing (test-spinlock)))
View
3  tests/eval.impure.lisp
@@ -249,8 +249,7 @@
(simple-type-error () 'error)))
t)))
-#+sb-eval
-(with-test (:name :bug-524707)
+(with-test (:name :bug-524707 :skipped-on '(not :sb-eval))
(let ((*evaluator-mode* :interpret)
(lambda-form '(lambda (x) (declare (fixnum x)) (1+ x))))
(let ((fun (eval lambda-form)))
View
72 tests/exhaust.impure.lisp
@@ -12,6 +12,12 @@
;;;; more information.
(cl:in-package :cl-user)
+
+(load "test-util.lisp")
+(load "assertoid.lisp")
+(use-package "TEST-UTIL")
+(use-package "ASSERTOID")
+
;;; Prior to sbcl-0.7.1.38, doing something like (RECURSE), even in
;;; safe code, would crash the entire Lisp process. Then the soft
@@ -30,45 +36,48 @@
(defvar *count* 100)
;;; Base-case: detecting exhaustion
-(assert (eq :exhausted
- (handler-case
- (recurse)
- (storage-condition (c)
- (declare (ignore c))
- :exhausted))))
+(with-test (:name (:exhaust :basic) :broken-on '(and :sunos :x86-64))
+ (assert (eq :exhausted
+ (handler-case
+ (recurse)
+ (storage-condition (c)
+ (declare (ignore c))
+ :exhausted)))))
;;; Check that non-local control transfers restore the stack
;;; exhaustion checking after unwinding -- and that previous test
;;; didn't break it.
-(let ((exhaust-count 0)
- (recurse-count 0))
- (tagbody
+(with-test (:name (:exhaust :non-local-control) :broken-on '(and :sunos :x86-64))
+ (let ((exhaust-count 0)
+ (recurse-count 0))
+ (tagbody
:retry
- (handler-bind ((storage-condition (lambda (c)
- (declare (ignore c))
- (if (= *count* (incf exhaust-count))
- (go :stop)
- (go :retry)))))
- (incf recurse-count)
- (recurse))
+ (handler-bind ((storage-condition (lambda (c)
+ (declare (ignore c))
+ (if (= *count* (incf exhaust-count))
+ (go :stop)
+ (go :retry)))))
+ (incf recurse-count)
+ (recurse))
:stop)
- (assert (= exhaust-count recurse-count *count*)))
+ (assert (= exhaust-count recurse-count *count*))))
;;; Check that we can safely use user-provided restarts to
;;; unwind.
-(let ((exhaust-count 0)
- (recurse-count 0))
- (block nil
- (handler-bind ((storage-condition (lambda (c)
- (declare (ignore c))
- (if (= *count* (incf exhaust-count))
- (return)
- (invoke-restart (find-restart 'ok))))))
- (loop
- (with-simple-restart (ok "ok")
- (incf recurse-count)
- (recurse)))))
- (assert (= exhaust-count recurse-count *count*)))
+(with-test (:name (:exhaust :restarts) :broken-on '(and :sunos :x86-64))
+ (let ((exhaust-count 0)
+ (recurse-count 0))
+ (block nil
+ (handler-bind ((storage-condition (lambda (c)
+ (declare (ignore c))
+ (if (= *count* (incf exhaust-count))
+ (return)
+ (invoke-restart (find-restart 'ok))))))
+ (loop
+ (with-simple-restart (ok "ok")
+ (incf recurse-count)
+ (recurse)))))
+ (assert (= exhaust-count recurse-count *count*))))
(with-test (:name (:exhaust :binding-stack))
(let ((ok nil)
@@ -84,8 +93,7 @@
(setq ok t)))
(assert ok))))
-#+c-stack-is-control-stack
-(with-test (:name (:exhaust :alien-stack))
+(with-test (:name (:exhaust :alien-stack) :skipped-on '(not :c-stack-is-control-stack))
(let ((ok nil))
(labels ((exhaust-alien-stack (i)
(with-alien ((integer-array (array int 500)))
View
25 tests/float.pure.lisp
@@ -245,10 +245,12 @@
(the (eql #c(1.0 2.0))
x))))))))
-;; The x86 port used not to reduce the arguments of transcendentals
-;; correctly. On other platforms, we trust libm to DTRT.
-#+x86
-(with-test (:name :range-reduction)
+;; This was previously x86-only, with note:
+;; The x86 port used not to reduce the arguments of transcendentals
+;; correctly. On other platforms, we trust libm to DTRT.
+;; but it doesn't cost any real amount to just test them all
+(with-test (:name :range-reduction
+ :fails-on '(and :x86-64 (or :linux :darwin)))
(flet ((almost= (x y)
(< (abs (- x y)) 1d-5)))
(macrolet ((foo (op value)
@@ -288,7 +290,8 @@
;; The tests are extremely brittle and could be broken by any number of
;; back- or front-end optimisations. We should just keep the issue above
;; in mind at all times when working with SSE or similar instruction sets.
-#+(or x86 x86-64) ;; No other platforms have SB-VM::TOUCH-OBJECT.
+;;
+;; Run only on x86/x86-64m as no other platforms have SB-VM::TOUCH-OBJECT.
(macrolet ((with-pinned-floats ((count type &rest names) &body body)
"Force COUNT float values to be kept live (and hopefully in registers),
fill a temporary register with noise, and execute BODY."
@@ -313,7 +316,7 @@
(locally ,@body))
,@(loop for var in dummy
collect `(sb-vm::touch-object ,var)))))))
- (with-test (:name :clear-sqrtsd)
+ (with-test (:name :clear-sqrtsd :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-sqrtsd (float)
(declare (optimize speed (safety 1))
(type (double-float (0d0)) float))
@@ -323,7 +326,7 @@
(declare (notinline test-sqrtsd))
(assert (zerop (imagpart (test-sqrtsd 4d0))))))
- (with-test (:name :clear-sqrtsd-single)
+ (with-test (:name :clear-sqrtsd-single :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-sqrtsd-float (float)
(declare (optimize speed (safety 1))
(type (single-float (0f0)) float))
@@ -333,7 +336,7 @@
(declare (notinline test-sqrtsd-float))
(assert (zerop (imagpart (test-sqrtsd-float 4f0))))))
- (with-test (:name :clear-cvtss2sd)
+ (with-test (:name :clear-cvtss2sd :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-cvtss2sd (float)
(declare (optimize speed (safety 1))
(type single-float float))
@@ -343,7 +346,7 @@
(declare (notinline test-cvtss2sd))
(assert (zerop (imagpart (test-cvtss2sd 1f0))))))
- (with-test (:name :clear-cvtsd2ss)
+ (with-test (:name :clear-cvtsd2ss :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-cvtsd2ss (float)
(declare (optimize speed (safety 1))
(type double-float float))
@@ -353,7 +356,7 @@
(declare (notinline test-cvtsd2ss))
(assert (zerop (imagpart (test-cvtsd2ss 4d0))))))
- (with-test (:name :clear-cvtsi2sd)
+ (with-test (:name :clear-cvtsi2sd :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-cvtsi2sd (int)
(declare (optimize speed (safety 0))
(type (unsigned-byte 10) int))
@@ -362,7 +365,7 @@
(declare (notinline test-cvtsi2sd))
(assert (zerop (imagpart (test-cvtsi2sd 4))))))
- (with-test (:name :clear-cvtsi2ss)
+ (with-test (:name :clear-cvtsi2ss :skipped-on '(not (or :x86 :x86-64)))
(flet ((test-cvtsi2ss (int)
(declare (optimize speed (safety 0))
(type (unsigned-byte 10) int))
View
3  tests/gc.impure.lisp
@@ -53,8 +53,7 @@
(assert gc-happend)))
;;; SB-EXT:GENERATION-* accessors returned bogus values for generation > 0
-#+gencgc
-(with-test (:name :bug-529014)
+(with-test (:name :bug-529014 :skipped-on '(not :gencgc))
;; FIXME: These parameters are a) tunable in the source and b)
;; duplicated multiple times there and now here. It would be good to
;; OAOO-ify them (probably to src/compiler/generic/params.lisp).
View
11 tests/hash.impure.lisp
@@ -261,7 +261,6 @@
;;; This test works reliably on non-conservative platforms and
;;; somewhat reliably on conservative platforms with threads.
-#+(or (not (or x86 x86-64)) sb-thread)
(progn
(defparameter *ht* nil)
@@ -292,7 +291,7 @@
(sb-thread::wait-on-semaphore ,sem)
(values-list ,values))))
-(with-test (:name (:hash-table :weakness :eql :numbers))
+(with-test (:name (:hash-table :weakness :eql :numbers) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(flet ((random-number ()
(random 1000)))
(loop for weakness in '(nil :key :value :key-and-value :key-or-value) do
@@ -331,7 +330,7 @@
(format stream "Hash: ~S~%" (sb-impl::hash-table-hash-vector ht))
(force-output stream))
-(with-test (:name (:hash-table :weakness :removal))
+(with-test (:name (:hash-table :weakness :removal) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(loop for test in '(eq eql equal equalp) do
(format t "test: ~A~%" test)
(loop for weakness in '(:key :value :key-and-value :key-or-value)
@@ -358,7 +357,7 @@
(return)))
(gc :full t))))))
-(with-test (:name (:hash-table :weakness :string-interning))
+(with-test (:name (:hash-table :weakness :string-interning) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(let ((ht (make-hash-table :test 'equal :weakness :key))
(s "a"))
(setf (gethash s ht) s)
@@ -366,7 +365,7 @@
(assert (eq (gethash (copy-seq s) ht) s))))
;;; see if hash_vector is not written when there is none ...
-(with-test (:name (:hash-table :weakness :eq))
+(with-test (:name (:hash-table :weakness :eq) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(loop repeat 10 do
(let ((index (random 2000)))
(let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
@@ -377,7 +376,7 @@
hash-table)))))
;; used to crash in gc
-(with-test (:name (:hash-table :weakness :keep))
+(with-test (:name (:hash-table :weakness :keep) :skipped-on '(or :x86 :x86-64 (not :sb-thread)))
(loop repeat 2 do
(let ((h1 (make-hash-table :weakness :key :test #'equal))
(keep ()))
View
6 tests/interface.impure.lisp
@@ -239,12 +239,10 @@
(assert (not (setf (documentation 'docfoo 'function) nil)))
(assert (string= (documentation 'docfoo 'function) "zot")))
-#+sb-doc
-(with-test (:name (documentation built-in-macro))
+(with-test (:name (documentation built-in-macro) :skipped-on '(not :sb-doc))
(assert (documentation 'trace 'function)))
-#+sb-doc
-(with-test (:name (documentation built-in-function))
+(with-test (:name (documentation built-in-function) :skipped-on '(not :sb-doc))
(assert (documentation 'cons 'function)))
(with-test (:name :describe-generic-function-with-assumed-type)
View
5 tests/interface.pure.lisp
@@ -65,8 +65,7 @@
;;; SLEEP should work with large integers as well -- no timers
;;; on win32, so don't test there.
-#-win32
-(with-test (:name (sleep pretty-much-forever))
+(with-test (:name (sleep pretty-much-forever) :skipped-on :win32)
(assert (eq :timeout
(handler-case
(sb-ext:with-timeout 1
@@ -116,4 +115,4 @@
;;; comprehensive test.
(loop repeat 2
do (compile nil '(lambda (x) x))
- do (sb-ext:gc :full t))
+ do (sb-ext:gc :full t))
View
45 tests/octets.pure.lisp
@@ -260,8 +260,7 @@
(assert (equalp #(251) (string-to-octets (string (code-char 369))
:external-format :latin-2)))
-#+sb-unicode
-(with-test (:name (:euc-jp :decoding-errors))
+(with-test (:name (:euc-jp :decoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-decoding-error
(lambda (c) (use-value #\? c))))
(assert (string= "?{?"
@@ -269,23 +268,20 @@
(coerce #(182 123 253 238) '(vector (unsigned-byte 8)))
:external-format :euc-jp)))))
-#+sb-unicode
-(with-test (:name (:utf-8 :surrogates :encoding-errors))
+(with-test (:name (:utf-8 :surrogates :encoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-encoding-error
(lambda (c) (use-value #\? c))))
(assert (equalp (string-to-octets (string (code-char #xd800))
:external-format :utf-8)
(vector (char-code #\?))))))
-#+sb-unicode
-(with-test (:name (:utf-8 :surrogates :decoding-errors))
+(with-test (:name (:utf-8 :surrogates :decoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-decoding-error
(lambda (c) (use-value #\? c))))
(assert (find #\? (octets-to-string
(coerce #(237 160 128) '(vector (unsigned-byte 8)))
:external-format :utf-8)))))
-#+sb-unicode
-(with-test (:name (:ucs-2 :out-of-range :encoding-errors))
+(with-test (:name (:ucs-2 :out-of-range :encoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-encoding-error
(lambda (c) (use-value "???" c))))
(assert (equalp (string-to-octets (string (code-char #x10001))
@@ -297,8 +293,7 @@
:external-format :ucs-2be)
#(0 63 0 63 0 63)))))
-#+sb-unicode
-(with-test (:name (:ucs-4 :out-of-range :decoding-errors))
+(with-test (:name (:ucs-4 :out-of-range :decoding-errors) :skipped-on '(not :sb-unicode))
(handler-bind ((sb-int:character-decoding-error
(lambda (c) (use-value "???" c))))
(assert (equalp (octets-to-string (coerce '(1 2 3 4) '(vector (unsigned-byte 8)))
@@ -316,8 +311,7 @@
:external-format :ucs-4be)
(string (code-char #x10ffff))))))
-#+sb-unicode
-(with-test (:name (:utf-16le :ensure-roundtrip))
+(with-test (:name (:utf-16le :ensure-roundtrip) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format :utf-16le))
(dec (x)
@@ -328,8 +322,8 @@
(octets #(#x20 0 0 #x2 0 #x20 0 #xd8 0 #xdc 1 #xd8 1 #xdc #xff #xdb #xfd #xdf)))
(assert (equalp (enc string) octets))
(assert (equalp (dec octets) string)))))
-#+sb-unicode
-(with-test (:name (:utf-16le :encoding-error))
+
+(with-test (:name (:utf-16le :encoding-error) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format '(:utf-16le :replacement #\?)))
(dec (x)
@@ -338,8 +332,7 @@
(let ((string (map 'string 'code-char '(#xd800 #xdc00 #xfffe #x10ffff))))
(assert (equalp (enc string) #(63 0 63 0 63 0 63 0))))))
-#+sb-unicode
-(with-test (:name (:utf-16be :ensure-roundtrip))
+(with-test (:name (:utf-16be :ensure-roundtrip) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format :utf-16be))
(dec (x)
@@ -350,8 +343,8 @@
(octets #(0 #x20 #x2 0 #x20 0 #xd8 0 #xdc 0 #xd8 1 #xdc 1 #xdb #xff #xdf #xfd)))
(assert (equalp (enc string) octets))
(assert (equalp (dec octets) string)))))
-#+sb-unicode
-(with-test (:name (:utf-16be :encoding-error))
+
+(with-test (:name (:utf-16be :encoding-error) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format '(:utf-16be :replacement #\?)))
(dec (x)
@@ -360,8 +353,8 @@
(let ((string (map 'string 'code-char '(#xd800 #xdc00 #xfffe #x10ffff))))
(assert (equalp (enc string) #(0 63 0 63 0 63 0 63))))))
-#+sb-unicode
-(with-test (:name (:utf-32le :ensure-roundtrip))
+
+(with-test (:name (:utf-32le :ensure-roundtrip) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format :utf-32le))
(dec (x)
@@ -372,8 +365,8 @@
(octets #(#x20 0 0 0 0 #x2 0 0 0 #x20 0 0 0 0 1 0 1 4 1 0 #xfd #xff #x10 0)))
(assert (equalp (enc string) octets))
(assert (equalp (dec octets) string)))))
-#+sb-unicode
-(with-test (:name (:utf-32le :encoding-error))
+
+(with-test (:name (:utf-32le :encoding-error) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format '(:utf-32le :replacement #\?)))
(dec (x)
@@ -382,8 +375,8 @@
(let ((string (map 'string 'code-char '(#xd800 #xdc00 #xfffe #x10ffff))))
(assert (equalp (enc string) #(63 0 0 0 63 0 0 0 63 0 0 0 63 0 0 0))))))
-#+sb-unicode
-(with-test (:name (:utf-32be :ensure-roundtrip))
+
+(with-test (:name (:utf-32be :ensure-roundtrip) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format :utf-32be))
(dec (x)
@@ -394,8 +387,8 @@
(octets #(0 0 0 #x20 0 0 #x2 0 0 0 #x20 0 0 1 0 0 0 1 4 1 0 #x10 #xff #xfd)))
(assert (equalp (enc string) octets))
(assert (equalp (dec octets) string)))))
-#+sb-unicode
-(with-test (:name (:utf-32be :encoding-error))
+
+(with-test (:name (:utf-32be :encoding-error) :skipped-on '(not :sb-unicode))
(flet ((enc (x)
(string-to-octets x :external-format '(:utf-32be :replacement #\?)))
(dec (x)
View
3  tests/packages.impure.lisp
@@ -290,8 +290,7 @@ if a restart was invoked."
:good)))))
;;; MAKE-PACKAGE error in another thread blocking FIND-PACKAGE & FIND-SYMBOL
-#+sb-thread
-(with-test (:name :bug-511072)
+(with-test (:name :bug-511072 :skipped-on '(not :sb-thread))
(let* ((p (make-package :bug-511072))
(sem (sb-thread:make-semaphore))
(t2 (sb-thread:make-thread (lambda ()
View
3  tests/pathnames.impure.lisp
@@ -531,8 +531,7 @@
;;; Reported by Willem Broekema: Reading #p"\\\\" caused an error due
;;; to insufficient sanity in input testing in EXTRACT-DEVICE (in
;;; src;code;win32-pathname).
-#+win32
-(with-test (:name :bug-489698)
+(with-test (:name :bug-489698 :skipped-on '(not :win32))
(assert (equal (make-pathname :directory '(:absolute))
(read-from-string "#p\"\\\\\\\\\""))))
View
6 tests/print.impure.lisp
@@ -402,12 +402,10 @@
(ignore-errors
(delete-file file)))))
-#+sb-unicode
-(with-test (:name (:print-readable :character :utf-8))
+(with-test (:name (:print-readable :character :utf-8) :skipped-on '(not :sb-unicode))
(test-readable-character (code-char #xfffe) :utf-8))
-#+sb-unicode
-(with-test (:name (:print-readable :character :iso-8859-1))
+(with-test (:name (:print-readable :character :iso-8859-1) :skipped-on '(not :sb-unicode))
(test-readable-character (code-char #xfffe) :iso-8859-1))
(assert (string= (eval '(format nil "~:C" #\a)) "a"))
View
3  tests/run-program.impure.lisp
@@ -31,8 +31,7 @@
(assert (= (read-byte in) i)))
(process-close process))))
-#+sb-thread
-(with-test (:name :run-program-cat-2)
+(with-test (:name :run-program-cat-2 :skipped-on '(not :sb-thread))
;; Tests that reading from a FIFO is interruptible.
(let* ((process (sb-ext:run-program "/bin/cat" '()
:wait nil
View
54 tests/run-tests.lisp
@@ -41,27 +41,35 @@
(defun report ()
(terpri)
(format t "Finished running tests.~%")
- (cond (*all-failures*
- (format t "Status:~%")
- (dolist (fail (reverse *all-failures*))
- (cond ((eq (car fail) :unhandled-error)
- (format t " ~20a ~a~%"
- "Unhandled error"
- (enough-namestring (second fail))))
- ((eq (car fail) :invalid-exit-status)
- (format t " ~20a ~a~%"
- "Invalid exit status:"
- (enough-namestring (second fail))))
- (t
- (format t " ~20a ~a / ~a~%"
- (ecase (first fail)
- (:expected-failure "Expected failure:")
- (:unexpected-failure "Failure:")
- (:unexpected-success "Unexpected success:"))
- (enough-namestring (second fail))
- (third fail))))))
- (t
- (format t "All tests succeeded~%"))))
+ (let ((skipcount 0))
+ (cond (*all-failures*
+ (format t "Status:~%")
+ (dolist (fail (reverse *all-failures*))
+ (cond ((eq (car fail) :unhandled-error)
+ (format t " ~20a ~a~%"
+ "Unhandled error"
+ (enough-namestring (second fail))))
+ ((eq (car fail) :invalid-exit-status)
+ (format t " ~20a ~a~%"
+ "Invalid exit status:"
+ (enough-namestring (second fail))))
+ ((eq (car fail) :skipped-disabled)
+ (incf skipcount))
+ (t
+ (format t " ~20a ~a / ~a~%"
+ (ecase (first fail)
+ (:expected-failure "Expected failure:")
+ (:unexpected-failure "Failure:")
+ (:unexpected-success "Unexpected success:")
+ (:skipped-broken "Skipped (broken):")
+ (:skipped-disabled "Skipped (irrelevant):"))
+ (enough-namestring (second fail))
+ (third fail)))))
+ (when (> skipcount 0)
+ (format t " (~a tests skipped for this combination of platform and features)~%"
+ skipcount)))
+ (t
+ (format t "All tests succeeded~%")))))
(defun pure-runner (files test-fun)
(format t "// Running pure tests (~a)~%" test-fun)
@@ -165,7 +173,9 @@
(defun unexpected-failures ()
(remove-if (lambda (x)
(or (eq (car x) :expected-failure)
- (eq (car x) :unexpected-success)))
+ (eq (car x) :unexpected-success)
+ (eq (car x) :skipped-broken)
+ (eq (car x) :skipped-disabled)))
*all-failures*))
(defun setup-cl-user ()
View
6 tests/stream.impure.lisp
@@ -610,8 +610,7 @@
#-win32
(require :sb-posix)
-#-win32
-(with-test (:name :interrupt-open)
+(with-test (:name :interrupt-open :skipped-on :win32)
(let ((fifo nil)
(to 0))
(unwind-protect
@@ -641,8 +640,7 @@
#-win32
(require :sb-posix)
-#-win32
-(with-test (:name :overeager-character-buffering)
+(with-test (:name :overeager-character-buffering :skipped-on :win32)
(let ((fifo nil)
(proc nil))
(maphash
View
41 tests/test-util.lisp
@@ -18,21 +18,28 @@
(terpri *trace-output*)
(force-output *trace-output*))
-(defmacro with-test ((&key fails-on name) &body body)
+(defmacro with-test ((&key fails-on broken-on skipped-on name) &body body)
(let ((block-name (gensym)))
- `(block ,block-name
- (handler-bind ((error (lambda (error)
- (if (expected-failure-p ,fails-on)
- (fail-test :expected-failure ',name error)
- (fail-test :unexpected-failure ',name error))
- (return-from ,block-name))))
- (progn
- (log-msg "Running ~S" ',name)
- (start-test)
- ,@body
- (if (expected-failure-p ,fails-on)
- (fail-test :unexpected-success ',name nil)
- (log-msg "Success ~S" ',name)))))))
+ `(progn
+ (start-test)
+ (cond
+ ((broken-p ,broken-on)
+ (fail-test :skipped-broken ',name "Test broken on this platform"))
+ ((skipped-p ,skipped-on)
+ (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features"))
+ (t
+ (block ,block-name
+ (handler-bind ((error (lambda (error)
+ (if (expected-failure-p ,fails-on)
+ (fail-test :expected-failure ',name error)
+ (fail-test :unexpected-failure ',name error))
+ (return-from ,block-name))))
+ (progn
+ (log-msg "Running ~S" ',name)
+ ,@body
+ (if (expected-failure-p ,fails-on)
+ (fail-test :unexpected-success ',name nil)
+ (log-msg "Success ~S" ',name))))))))))
(defun report-test-status ()
(with-standard-io-syntax
@@ -60,6 +67,12 @@
(defun expected-failure-p (fails-on)
(sb-impl::featurep fails-on))
+(defun broken-p (broken-on)
+ (sb-impl::featurep broken-on))
+
+(defun skipped-p (skipped-on)
+ (sb-impl::featurep skipped-on))
+
(defun really-invoke-debugger (condition)
(with-simple-restart (continue "Continue")
(let ((*invoke-debugger-hook* *invoke-debugger-hook*))
View
57 tests/threads.pure.lisp
@@ -51,9 +51,9 @@