haskal
/
rosette
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

merge into: haskal:xenia/patches
Branches Tags
haskal:xenia/patches
haskal:xenia/test2
haskal:dependabot/github_actions/actions/checkout-6
haskal:master
haskal:gh-pages
haskal:4.1
haskal:4.0
haskal:3.2
haskal:3.1
haskal:3.0
haskal:assume
haskal:2.2
haskal:v2.1
haskal:v2.0
haskal:v1.1
haskal:objectives
haskal:v1.0
...
pull from: haskal:gh-pages
Branches Tags
haskal:xenia/test2
haskal:xenia/patches
haskal:dependabot/github_actions/actions/checkout-6
haskal:master
haskal:gh-pages
haskal:4.1
haskal:4.0
haskal:3.2
haskal:3.1
haskal:3.0
haskal:assume
haskal:2.2
haskal:v2.1
haskal:v2.0
haskal:v1.1
haskal:objectives
haskal:v1.0

No commits in common. "xenia/patches" and "gh-pages" have entirely different histories.
xenia/patc ... gh-pages

471 changed files with 1368 additions and 52333 deletions
Show Stats Expand all files Collapse all files

6
.github/dependabot.yml vendored
View File

@ -1,6 +0,0 @@
version: 2
updates:
- package-ecosystem: "github-actions"
directory: "/"
schedule:
interval: "daily"

50
.github/workflows/docker.yml vendored
View File

@ -1,50 +0,0 @@
name: Docker
on:
push:
tags:
- '*'
branches:
- master
pull_request:
jobs:
docker:
runs-on: ubuntu-latest
steps:
- name: Clone Repository
uses: actions/checkout@v4
- name: Configure Docker Metadata
id: meta
uses: docker/metadata-action@v5
with:
images: ghcr.io/${{ github.repository }}
tags: |
type=ref,event=branch
type=ref,event=pr
type=ref,event=tag
type=semver,pattern={{version}}
type=semver,pattern={{major}}.{{minor}}
- name: Authenticate to Package Registry
uses: docker/login-action@v3
if: ${{ github.event_name != 'pull_request' }}
with:
registry: ghcr.io
username: ${{ github.actor }}
password: ${{ secrets.GITHUB_TOKEN }}
- name: Set up Docker Buildx
uses: docker/setup-buildx-action@v3
- name: Build and Publish Rosette Image
uses: docker/build-push-action@v6
with:
context: .
push: ${{ github.event_name != 'pull_request' }}
tags: ${{ steps.meta.outputs.tags }}
labels: ${{ steps.meta.outputs.labels }}
cache-from: type=gha
cache-to: type=gha,mode=max

102
.github/workflows/tests.yml vendored
View File

@ -1,102 +0,0 @@
name: Tests
on: [push, pull_request]
env:
CVC4_URL: "http://cvc4.cs.stanford.edu/downloads/builds/x86_64-linux-opt/cvc4-1.8-x86_64-linux-opt"
BOOLECTOR_URL: "https://github.com/Boolector/boolector/archive/3.2.1.tar.gz"
CVC5_URL: "https://github.com/cvc5/cvc5/releases/download/cvc5-1.0.7/cvc5-Linux"
BITWUZLA_URL: "https://github.com/bitwuzla/bitwuzla/archive/93a3d930f622b4cef0063215e63b7c3bd10bd663.tar.gz"
STP_URL: "https://github.com/stp/stp/archive/d70085462f07c8a5a2f1225f727cda3ef505b141.tar.gz"
YICES2_URL: "https://github.com/SRI-CSL/yices2/archive/e27cf308cffb0ecc6cc7165c10e81ca65bc303b3.tar.gz"
jobs:
test:
strategy:
matrix:
racket-version: ['8.1', 'current']
racket-variant: ['CS']
allow-failure: [false]
name: Racket ${{ matrix.racket-version }} (${{ matrix.racket-variant }})
runs-on: ubuntu-latest
continue-on-error: ${{ matrix.allow-failure }}
steps:
- uses: actions/checkout@master
- name: Setup Racket
uses: Bogdanp/setup-racket@v1.14
with:
architecture: x64
version: ${{ matrix.racket-version }}
variant: ${{ matrix.racket-variant }}
- name: Install solvers
# Note that setting LD_LIBRARY_PATH can be removed once this bug is
# fixed: https://github.com/stp/stp/issues/485
run: |
mkdir bin &&
wget $CVC4_URL -nv -O bin/cvc4 &&
chmod +x bin/cvc4 &&
wget $BOOLECTOR_URL -nv -O boolector.tar.gz &&
mkdir boolector &&
tar xzf boolector.tar.gz -C boolector --strip-components=1 &&
pushd boolector &&
./contrib/setup-cadical.sh &&
./contrib/setup-btor2tools.sh &&
./configure.sh &&
cd build &&
make &&
popd &&
cp boolector/build/bin/boolector bin/ &&
rm -rf boolector* &&
wget $CVC5_URL -nv -O bin/cvc5 &&
chmod +x bin/cvc5 &&
sudo apt-get update &&
sudo apt-get install -y ninja-build &&
pip3 install meson &&
wget $BITWUZLA_URL -nv -O bitwuzla.tar.gz &&
mkdir bitwuzla &&
tar xzf bitwuzla.tar.gz -C bitwuzla --strip-components=1 &&
pushd bitwuzla &&
./configure.py &&
pushd build &&
ninja &&
popd &&
popd &&
cp bitwuzla/build/src/main/bitwuzla bin/ &&
sudo apt-get install -y build-essential git cmake bison flex libboost-all-dev libtinfo-dev python3 perl &&
wget $STP_URL -nv -O stp.tar.gz &&
mkdir stp &&
tar xzf stp.tar.gz -C stp --strip-components=1 &&
pushd stp &&
echo "LD_LIBRARY_PATH=$PWD/deps/cadical/build:$PWD/deps/cadiback/:$LD_LIBRARY_PATH" >> $GITHUB_ENV &&
./scripts/deps/setup-gtest.sh &&
./scripts/deps/setup-outputcheck.sh &&
./scripts/deps/setup-cms.sh &&
./scripts/deps/setup-minisat.sh &&
mkdir build &&
pushd build &&
cmake .. &&
cmake --build . &&
popd &&
popd &&
ln -s stp/build/stp bin/stp &&
sudo apt-get install -y gperf &&
wget $YICES2_URL -nv -O yices2.tar.gz &&
mkdir yices2 &&
tar xvf yices2.tar.gz -C yices2 --strip-components=1 &&
pushd yices2 &&
autoconf &&
./configure --prefix=$PWD/out/ &&
make &&
make install &&
popd &&
cp yices2/out/bin/yices-smt2 bin/yices-smt2
- name: Install Rosette
run: raco pkg install --auto --name rosette
- name: Compile Rosette tests
run: raco make test/all-rosette-tests.rkt
- name: Run Rosette tests
run: raco test test/all-rosette-tests.rkt
- name: Compile SDSL tests
run: raco make test/all-sdsl-tests.rkt
- name: Run SDSL tests
run: raco test test/all-sdsl-tests.rkt

20
.gitignore vendored
View File

@ -1,19 +1,3 @@
# OS generated files # _site/**
######################
.DS_Store .DS_Store
.DS_Store? .jekyll-cache/
._*
.Spotlight-V100
.Trashes
ehthumbs.db
Thumbs.db
**/doc
**/doc/**
**/bin/**
**/compiled
**/compiled/**
*~
node_modules
.cache
yarn.lock

97
Dockerfile
View File

@ -1,97 +0,0 @@
FROM alpine:3.15
## ========================== [ Install Racket ] =========================== ##
## Define default Racket version and variant. The Racket version is of the form
## <major>.<minor>. The variant can be "cs" (Chez Scheme), "bc" (Before Chez) or
## "natipkg" (where external libraries are included in the Racket packages).
##
ARG RACKET_VERSION=8.4
ARG RACKET_VARIANT=cs
## Install Racket. We first install system dependencies: [gcompat] is needed for
## Racket and [ncurses] is needed for the [xrepl] and [expeditor] packages,
## providing the REPL. We then download the installer, run it with the right
## parameters, then remove it. After that, all that remains is to set-up the
## Racket packages and install [expeditor]. See later for a description of the
## arguments to [raco pkg install].
##
RUN apk add --no-cache gcompat ncurses
RUN wget "https://download.racket-lang.org/installers/${RACKET_VERSION}/racket-minimal-${RACKET_VERSION}-x86_64-linux-${RACKET_VARIANT}.sh"
RUN echo 'yes\n1\n' | sh racket-minimal-${RACKET_VERSION}-x86_64-linux-${RACKET_VARIANT}.sh --create-dir --unix-style --dest /usr/
RUN rm racket-minimal-${RACKET_VERSION}-x86_64-linux-${RACKET_VARIANT}.sh
RUN raco setup --no-docs
RUN raco pkg install -i --batch --auto --no-docs expeditor-lib
## =================== [ Install Rosette's Dependencies ] =================== ##
## Work on Rosette's installation within /usr/local. This directory will be
## cleaned up later on so it could be anything.
##
WORKDIR /usr/local/rosette
## Get all the info.rkt files. Trying to install Rosette based only on these
## files would fail, but we can use them to only install dependencies.
##
COPY info.rkt .
COPY rosette/info.rkt rosette/
## Install only Rosette's dependencies. We have to install the external
## dependencies [libstdc++] and [libgcc] because Z3 needs them at runtime. As
## for the Racket dependencies only, we achieve that in three steps:
##
## 1. We use [raco pkg install --no-setup] to download and register Rosette
## and all its dependencies without setting them up, that is without
## compiling them. At this point, the system is in an inconsistent state,
## where packages are registered but not actually present. The other flags
## are the following:
##
## -i install packages for all users
## --batch disable interactive mode and suppress prompts
## --auto download missing packages automatically
##
## 2. We use [raco pkg remove --no-setup] to unregister Rosette. This keeps
## the dependencies as registered. The system is still in an inconsistent
## state. See above for the flags.
##
## 3. We use [raco setup] to set up all the registered package. This brings
## the system back in a consistent state. Since Rosette's dependencies were
## registered but not Rosette itself, this achieves our goal. The flags are
## the following:
##
## --fail-fast fail on the first error encountered
## --no-docs do not compile the documentations
##
RUN apk add --no-cache libstdc++ libgcc
RUN raco pkg install -i --batch --auto --no-setup ../rosette
RUN raco pkg remove -i --no-setup rosette
RUN raco setup --fail-fast --no-docs
## ========================== [ Install Rosette ] =========================== ##
## Get all of Rosette; build and install it. The dependencies should all be
## installed, so we can remove the --auto flag which will lead us to failure if
## a dependency cannot be found. The additional flags are the following:
##
## --copy copy content to install path (instead of linking)
##
COPY . .
RUN raco pkg install -i --batch --copy --no-docs ./rosette
RUN rm -R /usr/local/rosette
## ===================== [ Prepare Clean Entry Point ] ====================== ##
## For further use of the image, we can start with user `rosette`, group
## `rosette` in `/rosette` by default.
##
RUN addgroup rosette
RUN adduser --system --shell /bin/false --disabled-password \
--home /rosette --ingroup rosette rosette
RUN chown -R rosette:rosette /rosette
USER rosette
WORKDIR /rosette
## Rosette files are simply Racket files using the Rosette library: the default
## entry point of this image is therefore the Racket executable.
##
ENTRYPOINT ["/usr/bin/racket", "-I", "rosette"]

26
LICENSE
View File

@ -1,26 +0,0 @@
Copyright (c) 2014, Regents of the University of California
All rights reserved.
Authored by Emina Torlak.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

166
NOTES.md
View File

@ -1,166 +0,0 @@
# Release Notes
## Version 4.1
This is a minor bug-fixing release.
## Version 4.0
This is a major release with significant changes to the language and the runtime. Rosette 4.0 is *not backward compatible* with Rosette 3.x. But porting Rosette 3.x code to Rosette 4.0 should be straightforward for most applications.
This release includes the following features:
- Support for assumptions (see `assume`).
- New symbolic evaluation core that tracks verification conditions (VCs) rather than path conditions and assertions.
- New symbolic reflection constructs for working with VCs, including `vc`, `with-vc`, and `clear-vc!`.
- New symbolic reflection facilities for managing symbolic `terms`, including the option of using a garbage-collected data structure.
- Updated `verify`, `synthesize`, `solve`, and `optimize` queries.
- New synthesis library with efficient support for grammar holes (see `define-grammar`).
- New list and vector operators that use bitvectors instead of integers.
- Updates to The Rosette Guide to document the new language in detail.
The following features have been removed:
- The `debug` query.
- Reflection facilities for working with path conditions and assertions: `pc`, `with-asserts`, `with-asserts-only`, `clear-asserts!`, and `asserts`.
- Support for CPLEX.
## Version 3.2
This release includes minor updates and a new [value destructuring library].
[value destructuring library]: https://docs.racket-lang.org/rosette-guide/sec_utility-libs.html#%28part._.Value_.Destructuring_.Library%29
## Version 3.1
This release includes bug fixes and updates Rosette to use the latest version of Z3 as its default SMT solver.
This release also includes the following new functionality contributed by [Sorawee Porncharoenwase][]:
- An interactive [value browser][] to help programmers navigate and read complex symbolic values.
- An *error tracer* for finding bugs in Rosette programs that manifest as exceptions intercepted during symbolic evaluation. To use the error tracer, run the command `raco symtrace <prog>`. The [debugging][] chapter in the Rosette guide describes some common issues due to intercepted exceptions, how to test for them, and how to find them with the error tracer.
[Sorawee Porncharoenwase]: https://github.com/sorawee
[debugging]: https://docs.racket-lang.org/rosette-guide/ch_error-tracing.html
[value browser]: https://docs.racket-lang.org/rosette-guide/sec_utility-libs.html#%28part._.Value_.Browser_.Library%29
## Version 3.0
This is a major release with significant changes to the language and the runtime. Rosette 3.0 is *not backward compatible* with Rosette 2.x. But porting Rosette 2.x code to Rosette 3.0 should be straightforward for most applications.
The semantics of Rosette 3.0 differs from Rosette 2.x in two ways:
- The `current-bitwidth` parameter that controls the reasoning precision is set to `#f` by default. As a result, symbolic constants that are declared to be integers or reals are interpreted in the theories of integers and reals, respectively. This means that the semantics of assertions over these types follows that of Racket. But reasoning about such assertions is expensive (or undecidable), so Rosette 3.0 still provides the option of approximating integer and real constants with finite-precision bitvectors. The key difference is that programs must now *explicitly opt into* this approximation by setting `current-bitwidth` to a positive integer.
- If `current-bitwidth` is set to a positive integer _k_, the solutions produced by the `verify`, `synthesize`, `solve`, and `debug` queries are guaranteed to be correct under the _k_-bit semantics for integer and real constants. They are _not_ guaranteed to be sound with respect to the infinite-precision semantics.
This release also includes the following new functionality and features contributed by [James Bornholt][] and [Phitchaya Mangpo Phothilimthana][]:
- Developed a new *symbolic profiler* for diagnosing performance issues in Rosette programs. The symbolic profiler instruments Rosette and tracks key performance metrics to identify potential issues. To use the symbolic profiler, run the command `raco symprofile program.rkt`. A new [performance][] chapter in the Rosette guide details common performance issues and how to use the symbolic profiler to identify them.
- Extended and generalized the interface to constraint solvers. The new interface allows the client code to specify a path to the solver, set the logic, provide solver-specific configuration options, and export the problem encodings sent to the solver.
- Added support for four new solvers: [Boolector][], [CVC4][], [Yices][], and [CPLEX][]. These solvers are not included in the default distribution and need to be installed separately for use with Rosette.
[performance]: https://docs.racket-lang.org/rosette-guide/ch_performance.html
[Boolector]: https://docs.racket-lang.org/rosette-guide/sec_solvers-and-solutions.html#%28def._%28%28lib._rosette%2Fsolver%2Fsmt%2Fboolector..rkt%29._boolector%29%29
[CVC4]: https://docs.racket-lang.org/rosette-guide/sec_solvers-and-solutions.html#%28def._%28%28lib._rosette%2Fsolver%2Fsmt%2Fcvc4..rkt%29._cvc4%29%29
[Yices]: https://docs.racket-lang.org/rosette-guide/sec_solvers-and-solutions.html#%28def._%28%28lib._rosette%2Fsolver%2Fsmt%2Fyices..rkt%29._yices%29%29
[CPLEX]: https://docs.racket-lang.org/rosette-guide/sec_solvers-and-solutions.html#%28def._%28%28lib._rosette%2Fsolver%2Fmip%2Fcplex..rkt%29._cplex%29%29
[Phitchaya Mangpo Phothilimthana]: https://github.com/mangpo
## Version 2.2
This release includes bug fixes and the following updates:
- Added support for quantified formulas. Quantifiers can appear in assertions passed to `solve` and `verify` queries. They should not be used with `synthesize` queries. When using quantified formulas, `current-bitwidth` must be set to `#f`.
- Added the `unknown` solution type. An `unknown` solution is returned if the underlying solver cannot decide if a given set of constraints is (un)satisfiable.
- Added the `distinct?` predicate that returns true iff all of its arguments are pairwaise un-equal. This has a direct (efficient) translation to Z3 if the arguments are primitive solvable values (booleans, integers, reals, or bitvectors).
## Version 2.1
This release includes the following updates to Rosette 2.0:
- Added support for the `push` / `pop` interface to Z3.
- Switched to log-based evaluation for Rosette documentation. Documentation generation no longer depends on Z3.
- Improved the implementation of the lifted `struct` construct. The new implementation is a minimal patch to the corresponding Racket implementation, and it enables creation and use of `struct`s in the REPL.
- Improved the implementation of `#%top-interaction` to disallow mutation of top-level variables in the REPL. This enables definition and use of recursive procedures in the REPL, as well as definition and use of generic interfaces.
## Version 2.0
This is a major release with significant changes to the language and
the symbolic evaluator. Rosette 2.0 is *not backward compatible* with
Rosette 1.x.
This release includes the following features:
- New symbolic datatypes.
- Replaced the `number?` type with `integer?` and `real?` types.
These datatypes are translated to the theories of integers and
reals if `current-bitwidth` is set to `#f`. Otherwise, they are
translated to bitvectors of length `(current-bitwidth)`.
- Added the `bitvector?` datatype, which embeds the SMT theory of
bitvectors into Rosette.
- Added the `function?` datatype, which embeds uninterpreted
functions into Rosette.
- New solver-aided queries.
- Changed the behavior of solver-aided queries to no longer throw
exceptions when a model is not found. Instead they return an
`unsat?` solution.
- Changed the `solve` and `verify` queries to ensure that any
solution obtained with finite-precision reasoning is correct under
the aribitrary-precision semantics of integers and reals.
- Added the `optimize` query, which exposes Z3's optimization
features.
- Improved implementation for the `define-synthax` form and other
high-level synthesis constructs.
- Improved printing of symbolic values by [James Bornholt][].
- Ported sample SDSLs to Rosette 2.0.
- Updated The Rosette Guide to document the new language in detail.
The following features have been removed:
- Support for Kodkod and CVC4 solvers.
- Support for the `enum` datatype.
- Support for internal logging via `current-log-handler`.
[James Bornholt]: https://github.com/jamesbornholt
## Version 1.1
- This release includes a new reader for `rosette` and `rosette/safe`
implemented by [bmastenbrook](https://github.com/bmastenbrook).
- It also includes a fix for a bug in the evaluation of symbolic
boxes. Thanks to Alan Borning for reporting it.
## Version 1.0
- This is the initial release of the Rosette language and Symbolic
Virtual Machine, as described in [PLDI'14][1] and [Onward13][2].
- It includes two symbolic datatypes: `boolean?` and `number?`.
Assertions over numbers are translated to the theory of bitvectors.
- Rosette 1.0 supports the Kodkod, Z3, and CVC4 solvers.
- This release also includes the source code for three solver-aided
DSLs: WebSynth (web scraping by demonstration), IFC (verification
for secure stack machine semantics), and SynthCL (synthesis and
verification for an Open-CL imperative language).
[1]: http://dl.acm.org/citation.cfm?id=2594340
[2]: http://dl.acm.org/citation.cfm?id=2509586

81
README.md
View File

@ -1,81 +0,0 @@
The Rosette Language
====================
[![Tests](https://github.com/emina/rosette/workflows/Tests/badge.svg)](https://github.com/emina/rosette/actions?query=workflow%3ATests)
[Rosette](http://emina.github.io/rosette/) is a solver-aided programming language that extends [Racket](http://racket-lang.org) with language constructs for program synthesis, verification, and more. This repository includes the source code for Rosette, as well as several example solver-aided DSLs.
## Installing Rosette
The easiest way to install Rosette is from Racket's package manager:
* Download and install Racket 8.1 or later from http://racket-lang.org
* Use Racket's `raco` tool to install Rosette:
`$ raco pkg install rosette`
### Installing from source
Alternatively, you can install Rosette from source:
* Download and install Racket 8.1 or later from http://racket-lang.org
* Clone the rosette repository:
`$ git clone https://github.com/emina/rosette.git`
* Uninstall any previous versions of Rosette:
`$ raco pkg remove rosette`
* Use Racket's `raco` tool to install Rosette:
`$ cd rosette`
`$ raco pkg install`
## Executing Rosette programs
* Open the target program in DrRacket (e.g., [`rosette/sdsl/fsm/demo.rkt`](https://github.com/emina/rosette/blob/master/sdsl/fsm/demo.rkt))
and hit run!
* DrRacket is the preferred way to execute Rosette programs. If you
need to use the command line, make sure to first compile the program:
`$ raco make <your program>`
`$ racket <your program>`
## Available languages
* Rosette ships with two languages: `#lang rosette/safe` and `#lang rosette`.
* The `rosette/safe` language includes only constructs that are safe to
use with symbolic values. This (for now) excludes some nice Racket
features, such as iteration constructs. The semantics of these
constructs can be expressed in the core language, however, so no
expressiveness is lost (just convenience). It is recommended for
new users of Rosette to start with the `rosette/safe` language. To
see the list of syntactic forms and procedures provided by
`rosette/safe`, type the following into the Rosette REPL:
`> (rosette)`
`'(define assert let let* ...)`
* The `rosette` language includes all of Racket. This places the burden
on the programmer to decide whether a given Racket construct (which
is not overridden by Rosette) is safe to use in a given context.
Rosette provides no guarantees or checks for programs that use
unsafe constructs. In the best case, such a program will fail with
an exception if a symbolic value flows to a construct that does not
support it. In the worst case, it will continue executing with
incorrect semantics or cause more serious problems (e.g., data loss if
it writes to a file).
* For more on using Rosette, see [_The Rosette Guide_][1]. Rosette's internals are described in [this PLDI'14 paper][2].
[1]: https://docs.racket-lang.org/rosette-guide/index.html
[2]: http://dl.acm.org/citation.cfm?id=2594340

23
_config.yml Normal file
View File

@ -0,0 +1,23 @@
# Site settings
title: "The Rosette Language"
email: emina@cs.washington.edu
description: The Rosette Language
baseurl: "/rosette"
url: "http://emina.github.io"
github_username: emina
# Markdown settings
markdown: kramdown
kramdown:
input: GFM
hard_wrap: false
syntax_highlighter: rouge
# Layouts
defaults:
-
scope:
path: ""
values:
layout: "default"

58
_data/bib.json Normal file
View File

@ -0,0 +1,58 @@
[
{
"author": "Sorawee Porncharoenwase and Luke Nelson and Xi Wang and Emina Torlak",
"booktitle": "Principles of Programming Languages (POPL)",
"key": "rosette:popl22",
"title": "A Formal Foundation for Symbolic Evaluation with Merging",
"type": "inproceedings",
"url": "https://doi.org/10.1145/3498709",
"year": "2022"
},
{
"author": "Sorawee Porncharoenwase and James Bornholt and Emina Torlak",
"booktitle": "Verification, Model Checking, and Abstract Interpretation (VMCAI)",
"key": "symfix:vmcai20",
"title": "Fixing Code That Explodes Under Symbolic Evaluation",
"type": "inproceedings",
"year": "2020",
"url": "https://link.springer.com/chapter/10.1007/978-3-030-39322-9_3"
},
{
"author": "James Bornholt and Emina Torlak",
"award": "Distinguished Artifact Award",
"booktitle": "Object-Oriented Programming, Systems, Languages, and Applications (OOPSLA)",
"key": "sympro:oopsla18",
"title": "Finding Code That Explodes Under Symbolic Evaluation",
"type": "inproceedings",
"year": "2018",
"url": "https://dl.acm.org/citation.cfm?id=3276519"
},
{
"author": "Stephen Chang and Alex Knauth and Emina Torlak",
"booktitle": "Principles of Programming Languages (POPL)",
"key": "typedrosette:popl18",
"title": "Symbolic Types for Lenient Symbolic Execution",
"type": "inproceedings",
"url": "https://dl.acm.org/citation.cfm?doid=3158128",
"year": "2018"
},
{
"author": "Emina Torlak and Rastislav Bodik",
"booktitle": "Programming Language Design and Implementation (PLDI)",
"key": "rosette:pldi14",
"title": "A Lightweight Symbolic Virtual Machine for Solver-Aided Host Languages",
"type": "inproceedings",
"url": "http://dl.acm.org/citation.cfm?id=2594340",
"year": "2014"
},
{
"author": "Emina Torlak and Rastislav Bodik",
"booktitle": "New Ideas, New Paradigms, and Reflections on Programming & Software (Onward!)",
"key": "rosette:onward13",
"title": "Growing Solver-Aided Languages with Rosette",
"type": "inproceedings",
"url": "http://dl.acm.org/citation.cfm?id=2509586",
"year": "2013"
}
]

58
_data/courses.json Normal file
View File

@ -0,0 +1,58 @@
[
{ "course": "CSE 507",
"title": "Computer-Aided Reasoning for Software",
"level": "graduate",
"institution": "University of Washington",
"unsat": true,
"url": "https://courses.cs.washington.edu/courses/cse507/19au/index.html",
"terms": [ "19au", "19wi", "18sp", "17wi", "16sp", "14au" ]},
{ "course": "CSC 530",
"title": "Languages and Translators",
"level": "graduate",
"institution": "Cal Poly",
"url": "https://www.brinckerhoff.org/clements/2214-csc530",
"terms": [ "21sp" ]},
{ "course": "CS162",
"title": "Programming Languages",
"level": "undergraduate",
"institution": "UC Santa Barbara",
"url": "https://github.com/fredfeng/CS162",
"terms": [ "20wi" ]},
{ "course": "CS292C",
"title": "Computer-Aided Reasoning for Software",
"level": "graduate",
"institution": "UC Santa Barbara",
"url": "https://github.com/fredfeng/CS292C",
"terms": [ "19au" ]},
{ "course": "CSE290Q",
"title": "SMT Solving and Solver-Aided Systems",
"level": "graduate",
"institution": "UC Santa Cruz",
"url": "http://composition.al/CSE290Q-2019-09/index.html",
"terms": [ "19au" ]},
{ "course": "COS IW09",
"title": "Programs Generating Programs",
"level": "undergraduate",
"institution": "Princeton",
"url": "https://www.cs.princeton.edu/courses/archive/fall18/cosIW09/index.html",
"terms": [ "18au" ]},
{ "course": "CSCI1950-Y",
"title": "Logic for Systems",
"level": "undergraduate",
"institution": "Brown",
"url": "http://cs.brown.edu/courses/cs195y/2017/",
"terms": [ "17sp" ]},
{ "course": "CS294",
"title": "Program Synthesis for Everyone",
"level": "graduate",
"institution": "UC Berkeley",
"url": "https://homes.cs.washington.edu/~bodik/ucb/cs294fa12.html",
"terms": [ "12au" ]}
]

19
_data/tutorials.json Normal file
View File

@ -0,0 +1,19 @@
[
{
"title": "Solver-Aided Programming",
"url": "https://homes.cs.washington.edu/~emina/media/cav19-tutorial/index.html",
"unsat": true,
"events": [
{"venue": "CAV 2019", "year": "2019", "url": "http://i-cav.org/2019/tutorials/"},
{"venue": "SSFT 2018", "year": "2018", "url": "http://fm.csl.sri.com/SSFT18/"}
]
},
{
"title": "Automated Verification of Systems Software with Serval",
"url": "https://github.com/uw-unsat/serval-tutorial-sosp19",
"unsat": true,
"events": [
{"venue": "SOSP 2019", "year": "2019", "url": "https://sosp19.rcs.uwaterloo.ca/tutorials.html"}
]
}
]

63
_layouts/default.html Normal file
View File

@ -0,0 +1,63 @@
<!DOCTYPE html>
<html lang="en">
<head>
<!-- Basic Page Needs -->
<meta charset="utf-8">
<title>Rosette: {{ page.title }}</title>
<meta name="description" content="The Rosette Language">
<meta name="author" content="Emina Torlak">
<!-- Mobile Specific Metas -->
<meta name="viewport" content="width=device-width, initial-scale=1">
<!-- FONT -->
<link href="//fonts.googleapis.com/css?family=Raleway:400,300,600" rel="stylesheet" type="text/css">
<!-- CSS -->
<link rel="stylesheet" href="{{ site.baseurl }}/css/normalize.css">
<link rel="stylesheet" href="{{ site.baseurl }}/css/tango.css">
<link rel="stylesheet" href="{{ site.baseurl }}/css/default.css">
<!-- Scripts -->
<script src="//ajax.googleapis.com/ajax/libs/jquery/2.1.1/jquery.min.js"></script>
<script src="https://google-code-prettify.googlecode.com/svn/loader/run_prettify.js"></script>
<link rel="stylesheet" href="{{ site.baseurl }}/css/github-prettify-theme.css">
<script src="{{ site.baseurl }}/js/site.js"></script>
<!-- Favicon -->
<link rel="icon" type="image/png" href="{{ site.baseurl }}/images/rosette-black.png">
</head>
<body>
<header>
<h1><img src="{{ site.baseurl }}/images/rosette-gray.png" alt="Rosette"> The Rosette Language</h1>
<nav>
<ul>
<li><a class="{% if page.url == '/' %}active{% endif %}" href="{{ site.baseurl }}/index.html">About</a></li>
<li><a href="https://github.com/emina/rosette">Download</a></li>
<li><a href="https://docs.racket-lang.org/rosette-guide/index.html" target="_blank">Docs</a></li>
<li><a class="{% if page.url == '/apps.html' %}active{% endif %}" href="{{ site.baseurl }}/apps.html">Apps</a></li>
<li><a class="{% if page.url == '/courses.html' %}active{% endif %}" href="{{ site.baseurl }}/courses.html">Courses</a></li>
<li><a class="{% if page.url == '/pubs.html' %}active{% endif %}" href="{{ site.baseurl }}/pubs.html">Papers</a></li>
</ul>
</nav>
</header>
<main>
{{ content }}
</main>
<footer>
<p>
&copy; <a href="http://homes.cs.washington.edu/~emina/">Emina Torlak</a>.
Built with <a href="http://jekyllrb.com/">Jekyll</a>.
Last updated {{ site.time | date_to_string }}.
</p>
</footer>
</body>
</html>

57
apps.md Normal file
View File

@ -0,0 +1,57 @@
---
title: Applications
---
## Applications
Rosette hosts many domain-specific languages (DSLs) with advanced
programming tools that scale to real-world applications, from
verification of radiotherapy software to synthesis of code for
ultra-low power hardware. Several of these tools have been developed by
first-time users of Rosette in just a few days or weeks.
| [Jitterbug][] | A framework for writing and verifying just-in-time compilers. |
| [SEEC][] | A framework for reasoning about emergent computations. |
| [SCFTL][] | A framework for verifying a snapshot-consistent flash translation layer. |
| [Serval][] | A framework for developing automated verifiers for systems software. |
| [Notary][] | A verified device for secure transaction approval. |
| [SwizzleInventor][] | A framework for synthesizing swizzle GPU kernels. |
| [MemSynth][] | A language and tool for verifying, synthesizing, and disambiguating memory consistency models. |
| [Ocelot][] | An engine for solving, verifying, and synthesizing specifications in bounded relational logic. |
| [Cosette][] | A framework for reasoning about SQL equivalences. |
| [Bagpipe][] | A language for specifying [BGP][] policies and verifying that an Internet Service Provider’s router configurations implement these policies. |
| [Neutrons][] | A verifier for a subset of [EPICS][EPICS]. Currently in use at the University of Washington [Clinical Neutron Therapy System][CNTS]. |
| [Greenthumb][] | A framework for constructing superoptimizers. |
| [Chlorophyll][] | A synthesis-aided programming model and compiler for [GreenArrays GA144][GA144], a minimalist low-power spatial architecture. |
| [Nonograms][] | A system for synthesizing problem-solving strategies for logic puzzles. |
| [Quivela][] | A tool for proving the security of cryptographic protocols. |
| [Ferrite][] | A framework for specifying and checking file system crash-consistency models. |
| [Synapse][] | A framework for specifying and solving optimal synthesis problems. |
| [Wallingford][] | An experimental constraint reactive programming language. |
| [More][] | Demo languages and tools for [secure stack machines][SSM], data-parallel programing, and web-scraping. |
[Jitterbug]: https://unsat.cs.washington.edu/projects/jitterbug/
[SCFTL]: https://github.com/yunshengtw/scftl
[SEEC]: https://galois.com/project/seec/
[Serval]: https://unsat.cs.washington.edu/projects/serval/
[Notary]: https://github.com/anishathalye/notary
[SwizzleInventor]: https://github.com/mangpo/swizzle-inventor
[Bagpipe]: http://www.konne.me/bagpipe/
[BGP]: https://en.wikipedia.org/wiki/Border_Gateway_Protocol
[Chlorophyll]: http://pl.eecs.berkeley.edu/projects/chlorophyll/
[GA144]: http://www.greenarraychips.com/
[Cosette]: http://cosette.cs.washington.edu/
[Ferrite]: http://sandcat.cs.washington.edu/ferrite/
[Greenthumb]: http://pl.eecs.berkeley.edu/projects/greenthumb/
[MemSynth]: http://memsynth.uwplse.org
[Neutrons]: http://neutrons.uwplse.org
[Nonograms]: https://github.com/edbutler/nonograms-rule-synthesis
[Ocelot]: https://jamesbornholt.github.io/ocelot/
[Quivela]: https://github.com/jamesbornholt/quivela
[EPICS]: http://www.aps.anl.gov/epics/
[CNTS]: https://staff.washington.edu/jon/cnts/
[Synapse]: http://synapse.uwplse.org
[Wallingford]: https://github.com/cdglabs/wallingford
[More]: https://github.com/emina/rosette/tree/master/sdsl
[SSM]: http://dl.acm.org/citation.cfm?id=2544174.2500574

25
courses.md Normal file
View File

@ -0,0 +1,25 @@
---
title: Courses
---
## Teaching
Rosette is used for teaching in the following courses and tutorials on
solver-aided programming and, more generally, computer-aided reasoning for
software. Contact [our team][UNSAT contact] if you would like to use our teaching
materials (starred) in your own course, or have your course listed here.
### Courses
{% for course in site.data.courses %}
| {% if course.unsat %}&#9734; {% endif %} [{{course.course}}]({{course.url}}): {{course.title}} | {{course.institution}} | {% endfor %}
### Tutorials
{% for tutorial in site.data.tutorials %}
| {% if tutorial.unsat %}&#9734; {% endif %} [{{tutorial.title}}]({{tutorial.url}}) at {% for event in tutorial.events %}{% if forloop.index0 > 0 %}, {% endif %}[{{event.venue}}]({{event.url}}){% endfor %}| {% endfor %}
[UNSAT contact]: https://unsat.cs.washington.edu/index.html#contact

102
css/custom.css Normal file
View File

@ -0,0 +1,102 @@
/* stylesheet from http://getskeleton.com */
.container {
max-width: 600px; }
body.index div.row li {
list-style-type: none;
list-style-position: inside;
text-indent: -1.7rem;
padding-left: 1.7rem;
margin-bottom: 1rem;
padding-bottom: 0rem;
padding-top: 0rem;
margin-top: 0rem;
}
img.logo {
width: 2.6rem;
}
.header {
margin-top: 6rem;
margin-bottom: 0rem;
text-align: center; }
a {
text-decoration: none;
}
.footer {
margin-top: 4rem;
padding-top: 2rem;
border-top: 1px solid #eee;
font-size: 1.2rem;
}
/* Navbar */
.navbar {
border-top-width: 0; }
.navbar,
.navbar-spacer {
display: block;
width: 100%;
background: #fff;
z-index: 99;
border-top: 1px solid #eee;
border-bottom: 1px solid #eee; }
.navbar-spacer {
display: none; }
.navbar > .container {
width: 100%; }
.navbar-list {
width: 80%;
margin-left: 10%;
list-style: none;
margin-bottom: 0; }
.navbar-item {
position: relative;
float: left;
margin-bottom: 0; }
.navbar-link {
text-transform: uppercase;
font-size: 11px;
font-weight: 600;
letter-spacing: .2rem;
margin-left: 10px;
margin-right: 10px;
text-decoration: none;
line-height: 6.5rem;
color: #222; }
.navbar-link.active {
color: #33C3F0; }
/**
.has-docked-nav .navbar {
position: fixed;
top: 0;
left: 0; }
.has-docked-nav .navbar-spacer {
display: block; }
.has-docked-nav .navbar > .container {
width: 80%; }
**/
@media (max-width: 700px) {
.navbar-list {
width: 100%;
margin-left: 0%;
list-style: none;
margin-bottom: 0; }
.navbar-item {
float: none;
margin: 0rem;
padding: 0rem;}
.navbar-link {
line-height: 1.5rem;
margin: 0rem;}
}

154
css/default.css Normal file
View File

@ -0,0 +1,154 @@
html { font-size: 62.5%; }
body {
max-width: 600px;
margin: 0 auto;
padding: 0 20px;
font-size: 1.5em; /* currently ems cause chrome bug misinterpreting rems on body element */
line-height: 1.6;
font-weight: 400;
font-family: "Raleway", "HelveticaNeue", "Helvetica Neue", Helvetica, Arial, sans-serif;
color: #222;
}
header {
margin-top: 4rem;
}
nav {
width: 100%;
}
nav > ul {
width: 500px;
list-style: none;
margin: 0 auto;
}
nav > ul > li {
display: inline-block;
border-top: 1px solid #eee;
border-bottom: 1px solid #eee;
margin-bottom: 4rem;
}
nav > ul > li > a {
text-transform: uppercase;
font-size: 12px;
font-weight: 600;
letter-spacing: .2rem;
margin-left: 10px;
margin-right: 10px;
text-decoration: none;
line-height: 6.5rem;
color: #222;
}
nav > ul > li > a.active {
color: #A6A6AF; }
@media (max-width: 700px) {
nav > ul {
width: 100%;
margin-left: 0%;
border-top: 1px solid #eee;
border-bottom: 1px solid #eee;
list-style: none;
margin-bottom: 4rem;
}
nav > ul > li {
display: block;
border: 0;
margin: 0rem;
padding: 0rem;}
nav > ul > li > a {
line-height: 1.5rem;
margin: 0rem;}
}
footer {
margin-top: 4rem;
padding-top: 2rem;
border-top: 1px solid #eee;
font-size: 1.2rem;
}
h1, h2, h3, h4, h5, h6 {
margin-top: 0;
margin-bottom: 2rem;
font-weight: 300;
}
h1 { font-size: 3.6rem; line-height: 1.25; letter-spacing: -.1rem; text-align: center; }
h2 { font-size: 3.0rem; line-height: 1.3; letter-spacing: -.1rem; }
h3 { font-size: 2.4rem; line-height: 1.35; letter-spacing: -.08rem; }
h4 { font-size: 1.8rem; line-height: 1.5; letter-spacing: -.05rem; }
h5 { font-size: 1.5rem; line-height: 1.6; letter-spacing: 0; }
h6 { font-size: 1.5rem; line-height: 1.6; letter-spacing: 0; }
h1 > img { width: 1em; vertical-align: text-bottom; }
p { margin-top: 0; }
a { text-decoration: none; color: #1EAEDB; }
a:hover { color: #0FA0CE; }
ul { list-style: circle inside; }
ol { list-style: decimal inside; }
ol, ul {
padding-left: 0;
margin-top: 0;
}
ul ul,
ul ol,
ol ol,
ol ul {
margin: 1.5rem 0 1.5rem 3rem;
font-size: 90%;
}
li { margin-bottom: 1rem; }
ul.bibliography {
list-style-type: none;
list-style-position: inside;
text-indent: -17px;
padding-left: 17px;
padding-right: 0;
margin-right: 0;
}
ul.bibliography li {
margin-bottom: 15px;
margin-right: 0;
padding-right: 0;
}
table { margin: 2rem 0 2rem 0; }
th,
td {
padding: 5px 12px;
text-align: left;
vertical-align: top;
}
/* border-bottom: 1px solid #E1E1E1; } */
th:first-child,
td:first-child {
padding-left: 0; }
th:last-child,
td:last-child {
padding-right: 0; }
code {
padding: .2rem .5rem;
margin: 0 .2rem;
font-size: 90%;
white-space: nowrap;
background: #F1F1F1;
border: 1px solid #E1E1E1;
border-radius: 4px; }
pre > code {
display: block;
padding: 1rem 1.5rem;
white-space: pre; }

150
css/github-prettify-theme.css Normal file
View File

@ -0,0 +1,150 @@
/* stylesheet from http://getskeleton.com */
/* GitHub Theme */
.prettyprint {
background: #fff;
font-family: Menlo, 'Bitstream Vera Sans Mono', 'DejaVu Sans Mono', Monaco, Consolas, monospace;
font-size: 1.2rem;
padding: 2.5rem 3rem;
-webkit-font-smoothing: antialiased;
}
.pln {
color: #333333;
}
@media screen {
.str {
color: #dd1144;
}
.kwd {
color: #333333;
}
.com {
color: #999988;
}
.typ {
color: #445588;
}
.lit {
color: #445588;
}
.pun {
color: #333333;
}
.opn {
color: #333333;
}
.clo {
color: #333333;
}
.tag {
color: navy;
}
.atn {
color: teal;
}
.atv {
color: #dd1144;
}
.dec {
color: #333333;
}
.var {
color: teal;
}
.fun {
color: #990000;
}
}
@media print, projection {
.str {
color: #006600;
}
.kwd {
color: #006;
font-weight: bold;
}
.com {
color: #600;
font-style: italic;
}
.typ {
color: #404;
font-weight: bold;
}
.lit {
color: #004444;
}
.pun, .opn, .clo {
color: #444400;
}
.tag {
color: #006;
font-weight: bold;
}
.atn {
color: #440044;
}
.atv {
color: #006600;
}
}
/* Specify class=linenums on a pre to get line numbering */
ol.linenums {
margin-top: 0;
margin-bottom: 0;
}
/* IE indents via margin-left */
li.L0,
li.L1,
li.L2,
li.L3,
li.L4,
li.L5,
li.L6,
li.L7,
li.L8,
li.L9 {
/* */
}
/* Alternate shading for lines */
li.L1,
li.L3,
li.L5,
li.L7,
li.L9 {
/* */
}
/* My additional styles */
/*li.L0, li.L1, li.L2, li.L3,
li.L5, li.L6, li.L7, li.L8
{ list-style-type: decimal !important }*/
.prettyprint li {
margin-bottom: .3rem;
}

427
css/normalize.css vendored Normal file
View File

@ -0,0 +1,427 @@
/*! normalize.css v3.0.2 | MIT License | git.io/normalize */
/**
* 1. Set default font family to sans-serif.
* 2. Prevent iOS text size adjust after orientation change, without disabling
* user zoom.
*/
html {
font-family: sans-serif; /* 1 */
-ms-text-size-adjust: 100%; /* 2 */
-webkit-text-size-adjust: 100%; /* 2 */
}
/**
* Remove default margin.
*/
body {
margin: 0;
}
/* HTML5 display definitions
========================================================================== */
/**
* Correct `block` display not defined for any HTML5 element in IE 8/9.
* Correct `block` display not defined for `details` or `summary` in IE 10/11
* and Firefox.
* Correct `block` display not defined for `main` in IE 11.
*/
article,
aside,
details,
figcaption,
figure,
footer,
header,
hgroup,
main,
menu,
nav,
section,
summary {
display: block;
}
/**
* 1. Correct `inline-block` display not defined in IE 8/9.
* 2. Normalize vertical alignment of `progress` in Chrome, Firefox, and Opera.
*/
audio,
canvas,
progress,
video {
display: inline-block; /* 1 */
vertical-align: baseline; /* 2 */
}
/**
* Prevent modern browsers from displaying `audio` without controls.
* Remove excess height in iOS 5 devices.
*/
audio:not([controls]) {
display: none;
height: 0;
}
/**
* Address `[hidden]` styling not present in IE 8/9/10.
* Hide the `template` element in IE 8/9/11, Safari, and Firefox < 22.
*/
[hidden],
template {
display: none;
}
/* Links
========================================================================== */
/**
* Remove the gray background color from active links in IE 10.
*/
a {
background-color: transparent;
}
/**
* Improve readability when focused and also mouse hovered in all browsers.
*/
a:active,
a:hover {
outline: 0;
}
/* Text-level semantics
========================================================================== */
/**
* Address styling not present in IE 8/9/10/11, Safari, and Chrome.
*/
abbr[title] {
border-bottom: 1px dotted;
}
/**
* Address style set to `bolder` in Firefox 4+, Safari, and Chrome.
*/
b,
strong {
font-weight: bold;
}
/**
* Address styling not present in Safari and Chrome.
*/
dfn {
font-style: italic;
}
/**
* Address variable `h1` font-size and margin within `section` and `article`
* contexts in Firefox 4+, Safari, and Chrome.
*/
h1 {
font-size: 2em;
margin: 0.67em 0;
}
/**
* Address styling not present in IE 8/9.
*/
mark {
background: #ff0;
color: #000;
}
/**
* Address inconsistent and variable font size in all browsers.
*/
small {
font-size: 80%;
}
/**
* Prevent `sub` and `sup` affecting `line-height` in all browsers.
*/
sub,
sup {
font-size: 75%;
line-height: 0;
position: relative;
vertical-align: baseline;
}
sup {
top: -0.5em;
}
sub {
bottom: -0.25em;
}
/* Embedded content
========================================================================== */
/**
* Remove border when inside `a` element in IE 8/9/10.
*/
img {
border: 0;
}
/**
* Correct overflow not hidden in IE 9/10/11.
*/
svg:not(:root) {
overflow: hidden;
}
/* Grouping content
========================================================================== */
/**
* Address margin not present in IE 8/9 and Safari.
*/
figure {
margin: 1em 40px;
}
/**
* Address differences between Firefox and other browsers.
*/
hr {
-moz-box-sizing: content-box;
box-sizing: content-box;
height: 0;
}
/**
* Contain overflow in all browsers.
*/
pre {
overflow: auto;
}
/**
* Address odd `em`-unit font size rendering in all browsers.
*/
code,
kbd,
pre,
samp {
font-family: monospace, monospace;
font-size: 1em;
}
/* Forms
========================================================================== */
/**
* Known limitation: by default, Chrome and Safari on OS X allow very limited
* styling of `select`, unless a `border` property is set.
*/
/**
* 1. Correct color not being inherited.
* Known issue: affects color of disabled elements.
* 2. Correct font properties not being inherited.
* 3. Address margins set differently in Firefox 4+, Safari, and Chrome.
*/
button,
input,
optgroup,
select,
textarea {
color: inherit; /* 1 */
font: inherit; /* 2 */
margin: 0; /* 3 */
}
/**
* Address `overflow` set to `hidden` in IE 8/9/10/11.
*/
button {
overflow: visible;
}
/**
* Address inconsistent `text-transform` inheritance for `button` and `select`.
* All other form control elements do not inherit `text-transform` values.
* Correct `button` style inheritance in Firefox, IE 8/9/10/11, and Opera.
* Correct `select` style inheritance in Firefox.
*/
button,
select {
text-transform: none;
}
/**
* 1. Avoid the WebKit bug in Android 4.0.* where (2) destroys native `audio`
* and `video` controls.
* 2. Correct inability to style clickable `input` types in iOS.
* 3. Improve usability and consistency of cursor style between image-type
* `input` and others.
*/
button,
html input[type="button"], /* 1 */
input[type="reset"],
input[type="submit"] {
-webkit-appearance: button; /* 2 */
cursor: pointer; /* 3 */
}
/**
* Re-set default cursor for disabled elements.
*/
button[disabled],
html input[disabled] {
cursor: default;
}
/**
* Remove inner padding and border in Firefox 4+.
*/
button::-moz-focus-inner,
input::-moz-focus-inner {
border: 0;
padding: 0;
}
/**
* Address Firefox 4+ setting `line-height` on `input` using `!important` in
* the UA stylesheet.
*/
input {
line-height: normal;
}
/**
* It's recommended that you don't attempt to style these elements.
* Firefox's implementation doesn't respect box-sizing, padding, or width.
*
* 1. Address box sizing set to `content-box` in IE 8/9/10.
* 2. Remove excess padding in IE 8/9/10.
*/
input[type="checkbox"],
input[type="radio"] {
box-sizing: border-box; /* 1 */
padding: 0; /* 2 */
}
/**
* Fix the cursor style for Chrome's increment/decrement buttons. For certain
* `font-size` values of the `input`, it causes the cursor style of the
* decrement button to change from `default` to `text`.
*/
input[type="number"]::-webkit-inner-spin-button,
input[type="number"]::-webkit-outer-spin-button {
height: auto;
}
/**
* 1. Address `appearance` set to `searchfield` in Safari and Chrome.
* 2. Address `box-sizing` set to `border-box` in Safari and Chrome
* (include `-moz` to future-proof).
*/
input[type="search"] {
-webkit-appearance: textfield; /* 1 */
-moz-box-sizing: content-box;
-webkit-box-sizing: content-box; /* 2 */
box-sizing: content-box;
}
/**
* Remove inner padding and search cancel button in Safari and Chrome on OS X.
* Safari (but not Chrome) clips the cancel button when the search input has
* padding (and `textfield` appearance).
*/
input[type="search"]::-webkit-search-cancel-button,
input[type="search"]::-webkit-search-decoration {
-webkit-appearance: none;
}
/**
* Define consistent border, margin, and padding.
*/
fieldset {
border: 1px solid #c0c0c0;
margin: 0 2px;
padding: 0.35em 0.625em 0.75em;
}
/**
* 1. Correct `color` not being inherited in IE 8/9/10/11.
* 2. Remove padding so people aren't caught out if they zero out fieldsets.
*/
legend {
border: 0; /* 1 */
padding: 0; /* 2 */
}
/**
* Remove default vertical scrollbar in IE 8/9/10/11.
*/
textarea {
overflow: auto;
}
/**
* Don't inherit the `font-weight` (applied by a rule above).
* NOTE: the default cannot safely be changed in Chrome and Safari on OS X.
*/
optgroup {
font-weight: bold;
}
/* Tables
========================================================================== */
/**
* Remove most spacing between table cells.
*/
table {
border-collapse: collapse;
border-spacing: 0;
}
td,
th {
padding: 0;
}

69
css/tango.css Normal file
View File

@ -0,0 +1,69 @@
.highlight .hll { background-color: #ffffcc }
.highlight .c { color: #8f5902; font-style: italic } /* Comment */
.highlight .err { color: #a40000; border: 1px solid #ef2929 } /* Error */
.highlight .g { color: #000000 } /* Generic */
.highlight .k { color: #204a87; font-weight: bold } /* Keyword */
.highlight .l { color: #000000 } /* Literal */
.highlight .n { color: #000000 } /* Name */
.highlight .o { color: #ce5c00; font-weight: bold } /* Operator */
.highlight .x { color: #000000 } /* Other */
.highlight .p { color: #000000; font-weight: bold } /* Punctuation */
.highlight .cm { color: #8f5902; font-style: italic } /* Comment.Multiline */
.highlight .cp { color: #8f5902; font-style: italic } /* Comment.Preproc */
.highlight .c1 { color: #8f5902; font-style: italic } /* Comment.Single */
.highlight .cs { color: #8f5902; font-style: italic } /* Comment.Special */
.highlight .gd { color: #a40000 } /* Generic.Deleted */
.highlight .ge { color: #000000; font-style: italic } /* Generic.Emph */
.highlight .gr { color: #ef2929 } /* Generic.Error */
.highlight .gh { color: #000080; font-weight: bold } /* Generic.Heading */
.highlight .gi { color: #00A000 } /* Generic.Inserted */
.highlight .go { color: #000000; font-style: italic } /* Generic.Output */
.highlight .gp { color: #8f5902 } /* Generic.Prompt */
.highlight .gs { color: #000000; font-weight: bold } /* Generic.Strong */
.highlight .gu { color: #800080; font-weight: bold } /* Generic.Subheading */
.highlight .gt { color: #a40000; font-weight: bold } /* Generic.Traceback */
.highlight .kc { color: #204a87; font-weight: bold } /* Keyword.Constant */
.highlight .kd { color: #204a87; font-weight: bold } /* Keyword.Declaration */
.highlight .kn { color: #204a87; font-weight: bold } /* Keyword.Namespace */
.highlight .kp { color: #204a87; font-weight: bold } /* Keyword.Pseudo */
.highlight .kr { color: #204a87; font-weight: bold } /* Keyword.Reserved */
.highlight .kt { color: #204a87; font-weight: bold } /* Keyword.Type */
.highlight .ld { color: #000000 } /* Literal.Date */
.highlight .m { color: #0000cf; font-weight: bold } /* Literal.Number */
.highlight .s { color: #4e9a06 } /* Literal.String */
.highlight .na { color: #c4a000 } /* Name.Attribute */
.highlight .nb { color: #204a87 } /* Name.Builtin */
.highlight .nc { color: #000000 } /* Name.Class */
.highlight .no { color: #000000 } /* Name.Constant */
.highlight .nd { color: #5c35cc; font-weight: bold } /* Name.Decorator */
.highlight .ni { color: #ce5c00 } /* Name.Entity */
.highlight .ne { color: #cc0000; font-weight: bold } /* Name.Exception */
.highlight .nf { color: #000000 } /* Name.Function */
.highlight .nl { color: #f57900 } /* Name.Label */
.highlight .nn { color: #000000 } /* Name.Namespace */
.highlight .nx { color: #000000 } /* Name.Other */
.highlight .py { color: #000000 } /* Name.Property */
.highlight .nt { color: #204a87; font-weight: bold } /* Name.Tag */
.highlight .nv { color: #000000 } /* Name.Variable */
.highlight .ow { color: #204a87; font-weight: bold } /* Operator.Word */
.highlight .w { color: #f8f8f8; text-decoration: underline } /* Text.Whitespace */
.highlight .mf { color: #0000cf; font-weight: bold } /* Literal.Number.Float */
.highlight .mh { color: #0000cf; font-weight: bold } /* Literal.Number.Hex */
.highlight .mi { color: #0000cf; font-weight: bold } /* Literal.Number.Integer */
.highlight .mo { color: #0000cf; font-weight: bold } /* Literal.Number.Oct */
.highlight .sb { color: #4e9a06 } /* Literal.String.Backtick */
.highlight .sc { color: #4e9a06 } /* Literal.String.Char */
.highlight .sd { color: #8f5902; font-style: italic } /* Literal.String.Doc */
.highlight .s2 { color: #4e9a06 } /* Literal.String.Double */
.highlight .se { color: #4e9a06 } /* Literal.String.Escape */
.highlight .sh { color: #4e9a06 } /* Literal.String.Heredoc */
.highlight .si { color: #4e9a06 } /* Literal.String.Interpol */
.highlight .sx { color: #4e9a06 } /* Literal.String.Other */
.highlight .sr { color: #4e9a06 } /* Literal.String.Regex */
.highlight .s1 { color: #4e9a06 } /* Literal.String.Single */
.highlight .ss { color: #4e9a06 } /* Literal.String.Symbol */
.highlight .bp { color: #3465a4 } /* Name.Builtin.Pseudo */
.highlight .vc { color: #000000 } /* Name.Variable.Class */
.highlight .vg { color: #000000 } /* Name.Variable.Global */
.highlight .vi { color: #000000 } /* Name.Variable.Instance */
.highlight .il { color: #0000cf; font-weight: bold } /* Literal.Number.Integer.Long */

BIN
images/rosette-black.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 650 B

BIN
images/rosette-gray.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 6.4 KiB

54
index.md Normal file
View File

@ -0,0 +1,54 @@
---
title: About
---
## About Rosette
Rosette is a solver-aided programming language that extends
[Racket](http://racket-lang.org/) with language constructs for program
synthesis, verification, and more. To verify or synthesize code,
Rosette compiles it to logical constraints solved with
off-the-shelf [SMT](http://smtlib.cs.uiowa.edu) solvers. By combining
virtualized access to solvers with Racket's metaprogramming, Rosette
makes it easy to develop synthesis and verification tools for new
languages. You simply write an interpreter for your language in
Rosette, and you get the tools for free!
```racket
#lang rosette
(define (interpret formula)
(match formula
[`(∧ ,expr ...) (apply && (map interpret expr))]
[`(∨ ,expr ...) (apply || (map interpret expr))]
[`(¬ ,expr) (! (interpret expr))]
[lit (constant lit boolean?)]))
; This implements a SAT solver.
(define (SAT formula)
(solve (assert (interpret formula))))
(SAT `(∧ r o (∨ s e (¬ t)) t (¬ e)))
```
To learn more, take a look at [The Rosette Guide](https://docs.racket-lang.org/rosette-guide/index.html),
[this talk](https://www.youtube.com/watch?v=KpDyuMIb_E0&index=25&list=PLZdCLR02grLp4W4ySd1sHPOsK83gvqBQp),
[applications](apps.html), [courses](courses.html), or [publications](pubs.html).
### Acknowledgments
This research was supported in part by awards from the National Science
Foundation (NSF CCF [1651225][], [1337415][], [1139138][], and [0916351][]), the
Department of Energy (DOE DE-SC0005136 and DOE FOA-0000619), and gifts from
Intel, Nokia, and Samsung. Rosette extends the [Racket](http://racket-lang.org/)
programming language, and uses the [Z3](https://github.com/Z3Prover/z3) solver
from Microsoft Research. Many thanks to the authors of these systems for making
them freely available, and to Rosette users for many helpful comments and
suggestions.
[0916351]: https://www.nsf.gov/awardsearch/showAward?AWD_ID=0916351
[1139138]: https://www.nsf.gov/awardsearch/showAward?AWD_ID=1139138
[1337415]: https://www.nsf.gov/awardsearch/showAward?AWD_ID=1337415
[1651225]: https://www.nsf.gov/awardsearch/showAward?AWD_ID=1651225

31
info.rkt
View File

@ -1,31 +0,0 @@
#lang info
(define collection 'multi)
(define deps '("custom-load"
"sandbox-lib"
"scribble-lib"
("racket" #:version "8.1")
"r6rs-lib"
"rfc6455"
"net-lib"
"web-server-lib"
"rackunit-lib"
"slideshow-lib"
"gui-lib"
"base"))
(define build-deps '("rackunit-doc"
"draw-lib"
"errortrace-lib"
"pict-lib"
"pict-doc"
"scribble-lib"
"racket-doc"
"gui-doc"
"errortrace-doc"))
(define test-omit-paths (if (getenv "PLT_PKG_BUILD_SERVICE") 'all '()))
(define pkg-desc "Rosette solver-aided host language")
(define version "4.0")

95
js/site.js Normal file
View File

@ -0,0 +1,95 @@
// http://getskeleton.com/js/site.js
$(document).ready(function() {
// Variables
var $codeSnippets = $('.code-example-body'),
$nav = $('.navbar'),
$body = $('body'),
$window = $(window),
$popoverLink = $('[data-popover]'),
navOffsetTop = $nav.offset().top,
$document = $(document),
entityMap = {
"&": "&amp;",
"<": "&lt;",
">": "&gt;",
'"': '&quot;',
"'": '&#39;',
"/": '&#x2F;'
}
function init() {
$window.on('scroll', onScroll)
$window.on('resize', resize)
$popoverLink.on('click', openPopover)
$document.on('click', closePopover)
$('a[href^="#"]').on('click', smoothScroll)
buildSnippets();
}
function smoothScroll(e) {
e.preventDefault();
$(document).off("scroll");
var target = this.hash,
menu = target;
$target = $(target);
$('html, body').stop().animate({
'scrollTop': $target.offset().top-40
}, 0, 'swing', function () {
window.location.hash = target;
$(document).on("scroll", onScroll);
});
}
function openPopover(e) {
e.preventDefault()
closePopover();
var popover = $($(this).data('popover'));
popover.toggleClass('open')
e.stopImmediatePropagation();
}
function closePopover(e) {
if($('.popover.open').length > 0) {
$('.popover').removeClass('open')
}
}
$("#button").click(function() {
$('html, body').animate({
scrollTop: $("#elementtoScrollToID").offset().top
}, 2000);
});
function resize() {
$body.removeClass('has-docked-nav')
navOffsetTop = $nav.offset().top
onScroll()
}
function onScroll() {
if(navOffsetTop < $window.scrollTop() && !$body.hasClass('has-docked-nav')) {
$body.addClass('has-docked-nav')
}
if(navOffsetTop > $window.scrollTop() && $body.hasClass('has-docked-nav')) {
$body.removeClass('has-docked-nav')
}
}
function escapeHtml(string) {
return String(string).replace(/[&<>"'\/]/g, function (s) {
return entityMap[s];
});
}
function buildSnippets() {
$codeSnippets.each(function() {
var newContent = escapeHtml($(this).html())
$(this).html(newContent)
})
}
init();
});

12
pubs.md Normal file
View File

@ -0,0 +1,12 @@
---
title: Papers
---
## Papers
<ul class="bibliography">
{% for pub in site.data.bib %}<li id="{{ pub.key }}">[{{ forloop.index0 | plus: 1}}] {{ pub.author }}. {{ pub.title }}. {{ pub.booktitle }}, {{ pub.year }}.
{%- if pub.award %} <b>{{ pub.award }}</b>.{% endif -%}
{%- if pub.url or pub.preprint or pub.web %} ({% if pub.url %}<a href="{{ pub.url }}">DOI</a>{% endif %}{% if pub.preprint %}{% if pub.url %}, {% endif %}<a href="{{ pub.preprint }}">PDF</a>{% endif %}{% if pub.web %}{% if pub.url or pub.preprint %}, {% endif %}<a href="{{ pub.web }}">Web</a>{% endif %}){% endif -%}</li>
{% endfor %}
</ul>

54
rosette/base/adt/box.rkt
View File

@ -1,54 +0,0 @@
#lang racket
(require (for-syntax racket/syntax "../core/lift.rkt") racket/provide
"../core/safe.rkt" "generic.rkt"
(only-in "../core/store.rkt" store!)
(only-in "../core/type.rkt" define-lifted-type type-cast)
(only-in "../core/equality.rkt" @eq? @equal?)
(only-in "../core/bool.rkt" instance-of? && ||)
(only-in "../core/union.rkt" union)
(only-in "../core/merge.rkt" merge merge*))
(provide (filtered-out with@ (all-defined-out))
(rename-out [box @box] [box-immutable @box-immutable]))
(define-lifted-type @box?
#:base box?
#:is-a? (instance-of? box? @box?)
#:methods
[(define (type-eq? self u v)
(or (eq? u v)
(and (immutable? u) (immutable? v) (@eq? (unbox u) (unbox v)))))
(define (type-equal? self u v) (@equal? (unbox u) (unbox v)))
(define (type-cast self v [caller 'type-cast]) (adt-type-cast v #:type box? #:lifted @box? #:caller caller))
(define (type-compress self force? ps)
(let*-values ([(immutable mutable) (partition (compose1 immutable? cdr) ps)])
(append (unsafe/compress box-immutable immutable)
(if force? (unsafe/compress box mutable) mutable))))
(define (type-construct self vals) (box (car vals)))
(define (type-deconstruct self val) (list (unbox val)))])
(define (unsafe/compress box ps)
(match ps
[(list) ps]
[(list _) ps]
[_ (cons (apply || (map car ps))
(box (apply merge* (for/list ([p ps]) (cons (car p) (unbox (cdr p)))))))]))
(define (@unbox b)
(match (type-cast @box? b 'unbox)
[(box v) v]
[(union vs) (apply merge* (for/list ([gv vs]) (cons (car gv) (unbox (cdr gv)))))]))
(define (box-ref x idx) (unbox x)) ; For the purpose of tracking mutations to the store,
(define (box-set! x idx v) (set-box! x v)) ; boxes are treated as 1-element vectors that ignore the index argument.
(define (@set-box! b v)
(match (type-cast @box? b 'set-box!)
[(? box? x)
(store! x 0 v box-ref box-set!)]
[(union vs)
(for ([gv vs])
(let ([x (cdr gv)])
(store! x 0 (merge (car gv) v (unbox x)) box-ref box-set!)))]))

161
rosette/base/adt/bvseq.rkt
View File

@ -1,161 +0,0 @@
#lang racket
(require
(only-in "list.rkt" @list?)
(only-in "vector.rkt" @vector? @vector-set!)
(only-in "../core/lift.rkt" lift-id)
(only-in "../core/forall.rkt" for/all for*/all)
(only-in "../core/term.rkt" get-type type-cast term?)
"../core/union.rkt"
"../core/bitvector.rkt"
"../core/merge.rkt"
"../core/safe.rkt")
(provide @list-ref-bv @list-set-bv
@take-bv @take-right-bv
@drop-bv @drop-right-bv @list-tail-bv
@split-at-bv @split-at-right-bv
@length-bv
@vector-ref-bv @vector-set!-bv @vector-length-bv)
(define (bv-lit-or-term? v)
(or (bv? v) (and (term? v) (bitvector? (get-type v)))))
(define-syntax-rule (lift-body #:with (id xs idx seq-length) #:type t #:max n #:body body ...)
(let* ([t (get-type idx)]
[2^k (expt 2 (bitvector-size t))]
[sz (seq-length xs)]
[n (min sz 2^k)])
(when (>= (- 2^k 1) sz)
(assert (@bvult idx (@integer->bitvector sz t))
(index-too-large-error 'id xs idx)))
body ...))
(define-syntax (define-lift-bv stx)
(syntax-case stx ()
[(_ (proc-bv xs idx arg ...) @seq? seq?)
#`(define-lift-bv #,(lift-id #'proc-bv) (proc-bv xs idx arg ...) @seq? seq?)]
[(_ @proc-bv (proc-bv xs idx arg ...) @seq? seq?)
#'(define (@proc-bv xs idx arg ...)
(if (and (seq? xs) (bv-lit-or-term? idx))
(proc-bv xs idx arg ...)
(match* ((type-cast @seq? xs 'proc-bv)
(bvcoerce idx 'proc-bv))
[((? seq? xs) (? bv-lit-or-term? idx))
(proc-bv xs idx arg ...)]
[(xs idx)
(for*/all ([xs xs][idx idx])
(proc-bv xs idx arg ...))])))]))
(define-syntax (define-length-bv stx)
(syntax-case stx ()
[(_ length-bv @seq? seq? seq-length)
#`(begin
(define (length-bv xs t) ; (-> seq bitvector? @bv?)
(@integer->bitvector (seq-length xs) t))
(define (#,(lift-id #'length-bv) xs t)
(match (type-cast @seq? xs 'length-bv)
[(? seq? xs) (length-bv xs t)]
[xs (for/all ([xs xs]) (length-bv xs t))])))]))
(define-syntax-rule (define-ref-bv ref-bv @seq? seq? seq-ref seq-length)
(begin
(define (ref-bv xs idx) ; (-> type? bv-lit-or-term? any/c)
(if (bv? idx)
(seq-ref xs (@bitvector->natural idx))
(lift-body
#:with (ref-bv xs idx seq-length)
#:type t
#:max n
#:body
(apply
merge*
(for/list ([x xs] [i n])
(cons (@bveq (bv i t) idx) x))))))
(define-lift-bv (ref-bv xs idx) @seq? seq?)))
; ---- list bv procedures ---- ;
(define-length-bv length-bv @list? list? length)
(define-ref-bv list-ref-bv @list? list? list-ref length)
(define (list-set-bv xs idx v)
(if (bv? idx)
(list-set xs (@bitvector->natural idx) v)
(lift-body
#:with (list-set-bv xs idx length)
#:type t
#:max n
#:body (for/list ([(x i) (in-indexed xs)])
(if (< i n)
(merge (@bveq (bv i t) idx) v x)
x)))))
(define-lift-bv (list-set-bv xs idx v) @list? list?)
(define (pair-length ps bound)
(if (list? ps)
(min (length ps) bound)
(let loop ([ps ps] [acc 0])
(if (and (pair? ps) (< acc bound))
(loop (cdr ps) (add1 acc))
acc))))
(define-syntax (define-get-bv stx)
(syntax-case stx ()
[(_ get-bv seq-get)
#`(begin
(define (get-bv xs idx)
(if (bv? idx)
(seq-get xs (@bitvector->natural idx))
(let* ([t (get-type idx)]
[2^k (expt 2 (bitvector-size t))]
[sz (pair-length xs (sub1 2^k))])
(when (> (- 2^k 1) sz)
(assert (@bvule idx (@integer->bitvector sz t))
(index-too-large-error 'id xs idx)))
(apply
merge*
(for/list ([i (add1 sz)])
(cons (@bveq (bv i t) idx)
(seq-get xs i)))))))
(define (#,(lift-id #'get-bv) xs idx)
(if (and (not (union? xs)) (bv-lit-or-term? idx))
(get-bv xs idx)
(match* (xs (bvcoerce idx 'get-bv))
[((not (? union? xs)) (? bv-lit-or-term? idx))
(get-bv xs idx)]
[(xs idx)
(for*/all ([xs xs][idx idx])
(get-bv xs idx))]))))]))
(define-get-bv take-bv take)
(define-get-bv take-right-bv take-right)
(define-get-bv drop-bv drop)
(define-get-bv drop-right-bv drop-right)
(define-get-bv list-tail-bv list-tail)
(define (@split-at-bv xs idx)
(values (@take-bv xs idx) (@drop-bv xs idx)))
(define (@split-at-right-bv xs idx)
(values (@drop-right-bv xs idx) (@take-right-bv xs idx)))
; ---- vector bv procedures ---- ;
(define (vector-set!-bv xs idx v)
(if (bv? idx)
(@vector-set! xs (@bitvector->natural idx) v)
(lift-body
#:with (vector-set!-bv xs idx vector-length)
#:type t
#:max n
#:body
(for ([x xs] [i n])
(@vector-set! xs i (merge (@bveq (bv i t) idx) v x))))))
(define-length-bv vector-length-bv @vector? vector? vector-length)
(define-ref-bv vector-ref-bv @vector? vector? vector-ref vector-length)
(define-lift-bv (vector-set!-bv xs idx v) @vector? vector?)

34
rosette/base/adt/generic.rkt
View File

@ -1,34 +0,0 @@
#lang racket
(require (only-in "../core/union.rkt" union union-filter union-guards union-contents)
(only-in "../core/type.rkt" subtype?)
(only-in "../core/bool.rkt" ||)
(only-in "../core/safe.rkt" assert argument-error))
(provide adt-type-cast)
; This macro takes the form:
; * (adt-type-cast value #:type racket-type? #:lifted symbolic-type? #:caller caller)
; The form expands into an expression that casts the given
; value to the type specified by the primitive Racket
; predicate and its corresponding lifted Rosette type?. The cast
; asserts a @boolean? that is true iff the cast is valid,
; and it returns the result of casting the input value to symbolic-type?.
; This macro assumes that the only possible non-concrete value of
; such a type is a symbolic union.
(define-syntax-rule (adt-type-cast v #:type adt-type? #:lifted symbolic-type? #:caller caller)
(match v
[(? adt-type?) v]
[(union xs t)
(cond [(subtype? t symbolic-type?) v]
[(subtype? symbolic-type? t)
(match (union-filter v symbolic-type?)
[(union (list (cons g u)) _)
(assert g (argument-error caller (~a adt-type?) v))
u]
[u
(unless (= (length xs) (length (union-contents u)))
(assert (apply || (union-guards u)) (argument-error caller (~a adt-type?) v)))
u])]
[else (assert #f (argument-error caller (~a adt-type?) v))])]
[_ (assert #f (argument-error caller (~a adt-type?) v))]))

578
rosette/base/adt/list.rkt
View File

@ -1,578 +0,0 @@
#lang racket
(require (for-syntax racket/syntax "../core/lift.rkt")
racket/provide racket/splicing racket/stxparam
"../core/safe.rkt" "../core/lift.rkt" "seq.rkt" "generic.rkt"
(only-in "../form/control.rkt" @if @and @or @cond)
(only-in "../core/term.rkt" term? define-lifted-type @any/c)
(only-in "../core/equality.rkt" @eq? @equal?)
(only-in "../core/bool.rkt" instance-of? and-&& && || =>)
(only-in "../core/real.rkt" @integer? @<= @< @= @> @+)
(only-in "../core/union.rkt" union union?)
(only-in "../core/merge.rkt" merge merge*)
(only-in "../core/type.rkt" subtype? type-cast))
(provide (filtered-out with@ (all-defined-out))
(rename-out [list @list] [null @null]))
(define-lifted-type @pair?
#:base pair?
#:is-a? (instance-of? pair? @pair?)
#:methods
[(define (type-eq? self u v) (pair=? @eq? u v))
(define (type-equal? self u v) (pair=? @equal? u v))
(define (type-cast self v [caller 'type-cast])
; We have to special-case the cast for pairs, because all lists
; except for the empty list are also pairs. Therefore, the generic
; adt-type-cast that relies on subtypes can't be used for pairs (since
; list? is not a subtype of pair?).
(match v
[(? pair?) v]
[(union (list (cons _ (? pair?)) ...) _) v]
[(union gvs (or (== @any/c) (== @list?)))
(match (for/list ([gv gvs] #:when (pair? (cdr gv))) gv)
[(list (cons g u))
(assert g (argument-error caller "pair?" v))
u]
[gps
(cond [(= (length gps) (length gvs)) v]
[else
(assert (apply || (map car gps)) (argument-error caller "pair?" v))
(apply union gps)])])]
[_ (assert #f (argument-error caller "pair?" v))]))
(define (type-compress self force? ps)
(match ps
[(list _ ) ps]
[(list (cons g (cons x y)) (cons h (cons u v)))
(list (cons (|| g h) (cons (merge* (cons g x) (cons h u))
(merge* (cons g y) (cons h v)))))]
[_ (list (cons (apply || (map car ps))
(cons (apply merge* (for/list ([p ps]) (cons (car p) (cadr p))))
(apply merge* (for/list ([p ps]) (cons (car p) (cddr p)))))))]))
(define (type-construct self vals)
(match vals [(list a b) (cons a b)]))
(define (type-deconstruct self val)
(match val [(cons a b) (list a b)]))])
(define-lifted-type @list?
#:base list?
#:is-a? (instance-of? list? @list?)
#:methods
[(define (type-eq? self u v) (list=? @eq? u v))
(define (type-equal? self u v) (list=? @equal? u v))
(define (type-cast self v [caller 'type-cast])
(adt-type-cast v #:type list? #:lifted @list? #:caller caller))
(define (type-compress self force? ps)
(seq-compress ps length map : [(for/seq head body) (for/list head body)]))
(define (type-construct self vals) vals)
(define (type-deconstruct self val) val)])
;; Pair and List Predicates
(define (pair=? =? x y)
(and-&& (not (null? x)) (not (null? y)) (=? (car x) (car y)) (=? (cdr x) (cdr y))))
(define (list=? =? xs ys)
(and (= (length xs) (length ys))
(let loop ([xs xs] [ys ys] [eqs '()])
(if (null? xs)
(apply && eqs)
(let ([eq (=? (car xs) (car ys))])
(and eq (loop (cdr xs) (cdr ys) (cons eq eqs))))))))
;; Pair Constructors and Selectors
(define/lift (car cdr) :: pair? -> @pair?)
(define @null?
(match-lambda [(? null?) #t]
[(union vs (? (curry subtype? @list?)))
(apply || (for/list ([gv vs] #:when (null? (cdr gv))) (car gv)))]
[_ #f]))
(define @cons
(match-lambda** [(x (union ys)) (merge** ys (cons x _))]
[(x y) (cons x y)]))
;; List Operations
(define/lift (length reverse) :: list? -> @list?)
(define/lift/ref list-ref : (list? length) -> @list?)
(define/lift/append append : (list? list) -> @list?)
;; List Iteration
(define (bad-lengths-error name . args)
(argument-error name "lists of equal length" (map ~.a args)))
(define (lengths xs)
(match xs
[(? list?) (set (length xs))]
[(union vs) (apply set (map (compose length cdr) vs))]))
(define (cast-length xs len)
(match xs
[(? list?) (values (= (length xs) len) xs)]
[(union (list _ ... (cons g (and (? list? vs) (app length (== len)))) _ ...)) (values g vs)]
[_ (values #f xs)]))
(define-syntax (define/lift/iterator stx)
(syntax-case stx ()
[(_ iterator init ...)
#`(define #,(lift-id #'iterator)
(case-lambda
[(proc init ... xs)
(assert-arity-includes proc (+ (length (list init ...)) 1) (quote iterator))
(lift/apply/higher-order iterator proc init ... xs : list? -> @list?)]
[(proc init ... xs . rest)
(assert-arity-includes proc (+ (length (list init ...)) 1 (length rest)) (quote iterator))
(define name (quote iterator))
(let ([vs (cons (type-cast @list? xs name)
(for/list ([r rest]) (type-cast @list? r name)))])
(if (andmap list? vs)
(apply iterator proc init ... vs)
(match (apply set-intersect (map lengths vs))
[(? set-empty?) (assert #f (apply bad-lengths-error name xs rest))]
[lens (let loop ([lens (sort (set->list lens) <)])
(match lens
[(list len)
(let-values ([(gs ys) (for/lists (gs ys) ([v vs]) (cast-length v len))])
(assert (apply && gs) (apply bad-lengths-error name xs rest))
(apply iterator proc init ... ys))]
[(list len rest (... ...))
(let-values ([(gs ys) (for/lists (gs ys) ([v vs]) (cast-length v len))])
(@if (apply && gs)
(apply iterator proc init ... ys)
(loop rest)))]))])))]))]))
(define/lift/iterator map)
(define/lift/iterator for-each)
(define/lift/iterator foldl init)
(define/lift/iterator foldr init)
(define-syntax-parameter iterator-next (syntax-rules ()))
(define-syntax-rule (define-iterator id rule ...)
(define id
(syntax-parameterize
([iterator-next (syntax-rules () rule ...)])
(case-lambda
[(f l)
(assert-arity-includes f 1 (quote id))
(if (null? l)
(iterator-next)
(let loop ([l l])
(iterator-next l (f (car l)) (loop (cdr l)))))]
[(f l1 l2)
(assert-arity-includes f 2 (quote id))
(assert (= (length l1) (length l2)) (bad-lengths-error (quote id) l1 l2))
(if (null? l1)
(iterator-next)
(let loop ([l1 l1][l2 l2])
(iterator-next l1 (f (car l1) (car l2)) (loop (cdr l1) (cdr l2)))))]
[(f l . args)
(assert-arity-includes f (add1 (length args)) (quote id))
(let ([len (length l)])
(assert (for/and ([arg args]) (= len (length arg)))
(apply bad-lengths-error (quote id) l args)))
(if (null? l)
(iterator-next)
(let loop ([l l] [args args])
(iterator-next l (apply f (car l) (map car args)) (loop (cdr l) (map cdr args)))))]))))
(splicing-local
[(define-iterator andmap [(_) (@and)] [(_ l cur rest) (@if (null? (cdr l)) cur (@and cur rest))])
(define-iterator ormap [(_) (@or)] [(_ l cur rest) (@if (null? (cdr l)) cur (@or cur rest))])
(define-iterator filter-map [(_) null] [(_ l cur rest) (@if (null? l)
null
(let ([x cur])
(@if x (@cons x rest) rest)))])]
(define/lift/iterator andmap)
(define/lift/iterator ormap)
(define/lift/iterator filter-map))
;; List Filtering
(define-syntax (define/lift/applicator stx)
(syntax-case stx ()
[(_ id #:name name #:using (applicator arg ... xs))
#`(define (id name arg ... xs)
(lift/apply/higher-order applicator arg ... xs : name : list? -> @list?))]
[(_ applicator arg ... xs)
#`(define (#,(lift-id #'applicator) arg ... xs)
(lift/apply/higher-order applicator arg ... xs : list? -> @list?))]))
(splicing-local
[(define (filter f list)
(assert-arity-includes f 1 'filter)
(let loop ([l list] [result null])
(@if (null? l)
(@reverse result)
(loop (cdr l) (@if (f (car l)) (@cons (car l) result) result)))))
(define (filter-not f list)
(assert-arity-includes f 1 'filter)
(let loop ([l list] [result null])
(@if (null? l)
(@reverse result)
(loop (cdr l) (@if (f (car l)) result (@cons (car l) result))))))]
(define/lift/applicator filter f list)
(define/lift/applicator filter-not f list))
(splicing-local
[(define (do-remove equal? item list)
(let loop ([list list])
(@cond [(null? list) null]
[(equal? item (car list)) (cdr list)]
[else (@cons (car list) (loop (cdr list)))])))
(define/lift/applicator @do-remove #:name name #:using (do-remove equal? item list))]
(define @remove
(case-lambda
[(item list) (@do-remove 'remove @equal? item list)]
[(item list equal?) (assert-arity-includes equal? 2 'remove)
(@do-remove 'remove equal? item list)]))
(define (@remq item list)
(@do-remove 'remq @eq? item list)))
(splicing-local
[(define (do-remove* equal? l r)
(let rloop ([r r])
(@cond
[(null? r) null]
[else (let ([first-r (car r)])
(let loop ([l-rest l])
(@cond
[(null? l-rest) (@cons first-r (rloop (cdr r)))]
[(equal? (car l-rest) first-r) (rloop (cdr r))]
[else (loop (cdr l-rest))])))])))
(define (@do-remove* name equal? l r)
(match* ((type-cast @list? l name) (type-cast @list? r name))
[((? list? vs) (? list? ws)) (do-remove* equal? vs ws)]
[((? list? vs) (union ws))
(higher-order/for [ws] #:lift (do-remove* equal? vs) #:enforce @list? #:name name)]
[((union ws) vs)
(let loop ([ws ws])
(match ws
[(list (cons g ys))
(assert g (type-error name @list? ys))
(@do-remove* name equal? ys vs)]
[(list (cons g ys) rest ...)
(@if g (@do-remove* name equal? ys vs) (loop rest))]))]))]
(define @remove*
(case-lambda
[(l r) (@do-remove* 'remove* @equal? l r)]
[(l r equal?) (assert-arity-includes equal? 2 'remove)
(@do-remove* 'remove* equal? l r)]))
(define (@remq* l r)
(@do-remove* 'remq* @eq? l r)))
(splicing-local
[(define (concrete? less? keys)
(match keys
[(or (list) (list _)) #t]
[(list key rest ...) (and (for/and ([r rest])
(let ([lt (less? key r)])
(not (or (term? lt) (union? lt)))))
(concrete? less? rest))]))
(define (rank-sort less? getkey cache-keys? xs)
(define key-of (cond [(and getkey cache-keys?) (curry hash-ref (for/hash ([x xs]) (values x (getkey x))))]
[(not getkey) identity]
[else getkey]))
(cond [(concrete? less? (map key-of xs)) (fast-sort less? getkey cache-keys? xs)]
[else
(define len (length xs))
(let* ([ranked>? (lambda (x i y j) (@or (@and (@equal? x y) (> i j)) (less? y x)))]
[ranks (for/list ([(x i) (in-indexed xs)])
(for/fold ([rank 0]) ([(y j) (in-indexed xs)] #:unless (= i j))
(@+ rank (@if (ranked>? (key-of x) i (key-of y) j) 1 0))))])
(for/list ([i len])
(for/fold ([v 0]) ([x xs] [r ranks]) (merge (@= i r) x v))))]))
(define (fast-sort less? getkey cache-keys? xs)
(sort xs less? #:key getkey #:cache-keys? cache-keys?))
(define/lift/applicator fast-sort less? getkey cache-keys? xs)
(define/lift/applicator rank-sort less? getkey cache-keys? xs)]
(define (@sort xs less? #:key [getkey #f] #:cache-keys? [cache-keys? #f] #:ignore-symbolic? [ignore-term? #f])
(cond [ignore-term? (@fast-sort less? getkey cache-keys? xs)]
[else (assert-arity-includes less? 2 'sort)
(when getkey (assert-arity-includes getkey 1 'sort))
(@rank-sort less? getkey cache-keys? xs)])))
;; List Searching
(splicing-local
[(define (memf f list)
(assert-arity-includes f 1 'memf)
(let loop ([l list])
(@cond
[(null? l) #f]
[(not (pair? l)) (assert #f (type-error 'memf @list? list))]
[else (@if (f (car l)) l (loop (cdr l)))])))
(define (findf f list)
(assert-arity-includes f 1 'findf)
(let loop ([l list])
(@cond
[(null? l) #f]
[(not (pair? l)) (assert #f (type-error 'findf @list? list))]
[else (let ([a (car l)]) (@if (f a) a (loop (cdr l))))])))]
(define/lift/applicator memf f list)
(define/lift/applicator findf f list)
(define (@member x xs [is-equal? @equal?]) (@memf (curry is-equal? x) xs))
(define (@memq x xs) (@memf (curry @eq? x) xs))
(define @assoc (case-lambda [(x xs) (@findf (compose (curry @equal? x) @car) xs)]
[(x xs eq?) (assert-arity-includes eq? 2 'assoc)
(@findf (compose (curry eq? x) @car) xs)]))
(define (@assq x xs) (@assoc x xs @eq?))
(define (@assf proc xs) (@findf (compose proc car) xs)))
;; Pair and List Accessor Shorthands
(define (@caar x) (@car (@car x)))
(define (@cdar x) (@cdr (@car x)))
(define (@cadr x) (@car (@cdr x)))
(define (@cddr x) (@cdr (@cdr x)))
(define (@caaar x) (@car (@car (@car x))))
(define (@cdaar x) (@cdr (@car (@car x))))
(define (@caadr x) (@car (@car (@cdr x))))
(define (@cdadr x) (@cdr (@car (@cdr x))))
(define (@cadar x) (@car (@cdr (@car x))))
(define (@cddar x) (@cdr (@cdr (@car x))))
(define (@caddr x) (@car (@cdr (@cdr x))))
(define (@cdddr x) (@cdr (@cdr (@cdr x))))
(define (@caaaar x) (@car (@car (@car (@car x)))))
(define (@cdaaar x) (@cdr (@car (@car (@car x)))))
(define (@caaadr x) (@car (@car (@car (@cdr x)))))
(define (@cdaadr x) (@cdr (@car (@car (@cdr x)))))
(define (@caadar x) (@car (@car (@cdr (@car x)))))
(define (@cdadar x) (@cdr (@car (@cdr (@car x)))))
(define (@caaddr x) (@car (@car (@cdr (@cdr x)))))
(define (@cdaddr x) (@cdr (@car (@cdr (@cdr x)))))
(define (@cadaar x) (@car (@cdr (@car (@car x)))))
(define (@cddaar x) (@cdr (@cdr (@car (@car x)))))
(define (@cadadr x) (@car (@cdr (@car (@cdr x)))))
(define (@cddadr x) (@cdr (@cdr (@car (@cdr x)))))
(define (@caddar x) (@car (@cdr (@cdr (@car x)))))
(define (@cdddar x) (@cdr (@cdr (@cdr (@car x)))))
(define (@cadddr x) (@car (@cdr (@cdr (@cdr x)))))
(define (@cddddr x) (@cdr (@cdr (@cdr (@cdr x)))))
(define/lift (last-pair) : pair? -> @pair?)
(define/lift (first rest last) : (and/c list? (not/c empty?)) -> @list?)
(define/lift second : (flat-pattern-contract (list _ __2)) -> @list?)
(define/lift third : (flat-pattern-contract (list _ __3)) -> @list?)
(define/lift fourth : (flat-pattern-contract (list _ __4)) -> @list?)
(define/lift fifth : (flat-pattern-contract (list _ __5)) -> @list?)
(define/lift sixth : (flat-pattern-contract (list _ __6)) -> @list?)
(define/lift seventh : (flat-pattern-contract (list _ __7)) -> @list?)
(define/lift eighth : (flat-pattern-contract (list _ __8)) -> @list?)
(define/lift ninth : (flat-pattern-contract (list _ __9)) -> @list?)
(define/lift tenth : (flat-pattern-contract (list _ __10)) -> @list?)
;; Additional List Functions and Synonyms
(define (extract vs idx proc guard)
(apply merge* (let loop ([i 0] [out '()])
(with-handlers ([exn:fail? (lambda (e)
(assert (=> guard (&& (@<= 0 idx) (@< idx i)))
(index-too-large-error (object-name proc) vs idx))
out)])
(loop (add1 i) (cons (cons (@= i idx) (proc vs i)) out))))))
(define-syntax (define/lift/extractor stx)
(syntax-case stx ()
[(_ (id0 id ...))
#'(begin (define/lift/extractor id0)
(define/lift/extractor id) ...)]
[(_ proc)
#`(define (#,(lift-id #'proc) xs pos)
(define name (object-name proc))
(match* (xs (type-cast @integer? pos name))
[((union vs) (? number? idx))
(assert-bound [0 <= idx] name)
(apply merge* (assert-some
(let loop ([vs vs] [out '()])
(match vs
[(list) out]
[(list (cons g v) rest (... ...))
(with-handlers ([exn:fail? (lambda (e) (loop rest out))])
(loop rest (cons (cons g (proc v idx)) out)))]))
#:unless (length vs)
(index-too-large-error name vs idx)))]
[((union vs) idx)
(apply merge* (for/list ([v vs])
(cons (car v) (extract (cdr v) idx proc (car v)))))]
[(vs (? number? idx))
(proc vs idx)]
[(vs idx)
(extract vs idx proc #t)]))]))
(define/lift/extractor (list-tail take drop take-right drop-right))
(define/lift/split split-at @take @drop)
(define/lift/split split-at-right @drop-right @take-right)
(define/lift (shuffle) :: list? -> @list?)
(define @empty? @null?)
(define @cons? @pair?)
(define @flatten
(match-lambda [(union vs) (merge** vs @flatten)]
[(cons x y) (@append (@flatten x) (@flatten y))]
[other (flatten other)]))
(define @append*
(case-lambda [(ls) (@apply @append ls)] ; optimize common case
[(l1 l2) (@apply @append l1 l2)]
[(l1 l2 l3) (@apply @append l1 l2 l3)]
[(l1 l2 l3 l4) (@apply @append l1 l2 l3 l4)]
[(l . lss) (@apply @apply @append l lss)]))
(define (@add-between l x #:splice? [sp? #f] #:before-first [bf '()] #:before-last [bl x] #:after-last [al '()])
(if (list? l)
(add-between l x #:splice? sp? #:before-first bf #:before-last bl #:after-last al)
(match (type-cast @list? l 'add-between)
[(? list? vs) (add-between vs x #:splice? sp? #:before-first bf #:before-last bl #:after-last al)]
[(union vs) (merge** vs (add-between _ x #:splice? sp? #:before-first bf #:before-last bl #:after-last al))])))
(define @apply
(case-lambda [() (assert #f (argument-error 'apply "at least 2 arguments" 0))]
[(proc) (assert #f (argument-error 'apply "at least 2 arguments" 1))]
[(proc xs) (lift/apply/higher-order apply proc xs : list? -> @list?)]
[(proc x0 xs) (lift/apply/higher-order apply proc x0 xs : list? -> @list?)]
[(proc x0 x1 xs) (lift/apply/higher-order apply proc x0 x1 xs : list? -> @list?)]
[(proc x0 x1 x2 xs) (lift/apply/higher-order apply proc x0 x1 x2 xs : list? -> @list?)]
[(proc x0 x1 x2 x3 xs) (lift/apply/higher-order apply proc x0 x1 x2 x3 xs : list? -> @list?)]
[(proc . xss) (@apply (apply curry proc (take xss (- (length xss) 1))) (last xss))]))
(define @append-map
(case-lambda [(f l) (@apply @append (@map f l))]
[(f l1 l2) (@apply @append (@map f l1 l2))]
[(f l . ls) (@apply @append (apply @map f l ls))]))
(define @count
(case-lambda [(f l) (@apply @+ (@map (lambda (v) (@if (f v) 1 0)) l))]
[(f l1 l2) (@apply @+ (@map (lambda (v1 v2) (@if (f v1 v2) 1 0)) l1 l2))]
[(f l . ls) (@apply @+ (apply @map (lambda (v . vs) (@if (apply f v vs) 1 0)) l ls))]))
(splicing-local
[(define (remove-dups =? key l)
(let loop ([l l] [seen null])
(@if (null? l)
l
(let* ([x (car l)] [k (key x)] [l (cdr l)])
(@if (@memf (curry =? k) seen)
(loop l seen)
(@cons x (loop l (@cons k seen))))))))
(define/lift/applicator remove-dups =? key l)]
(define (@remove-duplicates l [=? @equal?] #:key [key identity])
(@remove-dups =? key l)))
(define (@partition pred lst) (values (@filter pred lst) (@filter-not pred lst)))
(splicing-local
[(define (mk-min cmp name f xs)
(assert-arity-includes f 1 name)
(assert (@pair? xs) (argument-error name "(and/c list? (not/c empty?))" xs))
(let ([init-min-var (type-cast @integer? (f (car xs)) name)])
(let loop ([min (car xs)]
[min-var init-min-var]
[xs (cdr xs)])
(@if (null? xs)
min
(let ([new-min (type-cast @integer? (f (car xs)) name)])
(@if (cmp new-min min-var)
(loop (car xs) new-min (cdr xs))
(loop min min-var (cdr xs))))))))
(define/lift/applicator mk-min cmp name f xs)]
(define (@argmin f xs) (@mk-min @< 'argmin f xs))
(define (@argmax f xs) (@mk-min @> 'argmax f xs)))
(splicing-local
[(define (insert xs i v)
(let-values ([(left right) (split-at xs i)])
(append left (cons v right))))
(define (insert* xs i v)
(apply merge*
(cons (@= i (length xs)) (append xs (list v)))
(for/list ([(x idx) (in-indexed xs)])
(cons (@= i idx) (insert xs idx v)))))]
(define (@insert xs i v)
(or (and (list? xs) (number? i) (insert xs i v))
(match* ((type-cast @list? xs 'insert) (type-cast @integer? i 'insert))
[((? list? xs) (? number? i)) (insert xs i v)]
[((? list? xs) i)
(assert-bound [0 @<= i @<= (length xs)] 'insert)
(insert* xs i v)]
[((union ys) (? number? i))
(assert-bound [0 <= i] 'insert)
(apply merge* (assert-some
(for/list ([y ys] #:when (<= i (length (cdr y))))
(cons (car y) (insert (cdr y) i v)))
#:unless (length ys)
(index-too-large-error 'insert xs i)))]
[((union ys) i)
(assert-bound [0 @<= i @<= (@length xs)] 'insert)
(merge** ys (insert* _ i v))]))))
(splicing-local
[(define ($list-set xs i v)
(for/list ([(x idx) (in-indexed xs)])
(merge (@= i idx) v x)))]
(define (@list-set xs i v)
(or (and (list? xs) (number? i) (list-set xs i v))
(match* ((type-cast @list? xs 'list-set) (type-cast @integer? i 'list-set))
[((? list? xs) (? number? i)) (list-set xs i v)]
[((? list? xs) i)
(assert-bound [0 @<= i @< (length xs)] 'list-set)
($list-set xs i v)]
[((union ys) (? number? i))
(assert-bound [0 <= i] 'list-set)
(apply merge* (assert-some
(for/list ([y ys] #:when (< i (length (cdr y))))
(cons (car y) (list-set (cdr y) i v)))
#:unless (length ys)
(index-too-large-error 'list-set xs i)))]
[((union ys) i)
(assert-bound [0 @<= i @< (@length xs)] 'list-set)
(merge** ys ($list-set _ i v))]))))
#|
(define (test iterator size)
(define-symbolic* n @integer?)
(define r (@if (@= n 3) (build-list size identity) (build-list (* 2 size) add1)))
(define p (@if (@= n 2) (build-list size add1) (build-list (* 2 size) identity)))
(time (iterator r p)))
(define-symbolic* n @integer?)
(@andmap identity (list (@= 3 n) 4 (@= 5 n) 6))
(require (only-in "bool.rkt" @boolean?))
(define-symbolic* b c @boolean?)
(@andmap identity (list b c 1))
|#
#|
(require rosette/base/define)
(require (only-in "bool.rkt" @boolean?))
(define-symbolic b @boolean?)
(define-symbolic i @integer?)
(define xs '(a b c d e f g h i j k l))
(define ys '(n q))
(define v 'm)
(define (test-insert)
(displayln (@insert xs (length xs) v))
(displayln (@insert ys i v))
(for ([i 4])
(displayln (@insert (@if b xs ys) 0 v)))
(displayln (@insert (@if b xs ys) i v)))
(define (test-replace)
(displayln (@replace xs (sub1 (length xs)) v))
(displayln (@replace ys i v))
(for ([i 4])
(displayln (@replace (@if b xs ys) 0 v)))
(displayln (@replace (@if b xs ys) i v)))
(define (compare-inserts xs i v)
(time (begin (@insert xs i v) (void)))
(time (begin (let-values ([(left right) (@split-at xs i)])
(@append left (@cons v right)))
(void))))|#

139
rosette/base/adt/seq.rkt
View File

@ -1,139 +0,0 @@
#lang racket
(require (for-syntax racket/syntax "../core/lift.rkt")
racket/splicing racket/stxparam
(only-in racket/unsafe/ops [unsafe-car car] [unsafe-cdr cdr])
"../core/safe.rkt" "../core/lift.rkt"
(only-in "../core/type.rkt" type-cast)
(only-in "../core/bool.rkt" && or-|| ||)
(only-in "../core/real.rkt" @integer? @= @< @<=)
(only-in "../core/union.rkt" union union?)
(only-in "../core/merge.rkt" merge merge* unsafe-merge*)
(only-in "../core/forall.rkt" guard-apply))
(provide seq-compress
lift/apply/higher-order higher-order/for
define/lift/ref define/lift/append define/lift/split)
(define-syntax-rule
(higher-order/for (vs) #:lift (applicator proc arg ...) #:enforce rosette-contract? #:name name)
(guard-apply (lambda (v) (applicator proc arg ... v)) vs))
(define-syntax lift/apply/higher-order
(syntax-rules (: ->)
[(_ applicator proc arg ... seq : name : racket-contract? -> rosette-contract?)
(match (type-cast rosette-contract? seq name)
[(? racket-contract? vs) (applicator proc arg ... vs)]
[(union vs) (higher-order/for (vs) #:lift (applicator proc arg ...) #:enforce rosette-contract? #:name name)])]
[(_ applicator proc arg ... seq : racket-contract? -> rosette-contract?)
(lift/apply/higher-order applicator proc arg ... seq : (quote applicator) : racket-contract? -> rosette-contract?)]))
(define (@ref vs idx)
;(printf "@ref ~a ~a\n" (if (vector? vs) 'vector 'list) idx)
(apply merge* (for/list ([(v i) (in-indexed vs)])
(cons (@= i idx) v))))
(define-syntax (define/lift/ref stx)
(syntax-case stx (: ->)
[(_ proc : (racket-contract? racket-length) -> rosette-contract?)
#`(define (#,(lift-id #'proc) xs idx)
(if (and (racket-contract? xs) (number? idx))
(proc xs idx)
(match* ((type-cast rosette-contract? xs (quote proc))
(type-cast @integer? idx (quote proc)))
[((? racket-contract? vs) (? number? idx))
(proc vs idx)]
[((? racket-contract? vs) idx)
(assert-bound [0 @<= idx @< (racket-length vs)] (quote proc))
(@ref vs idx)]
[((union vs) (? number? idx))
(assert-bound [0 <= idx] (quote proc))
(apply merge* (assert-some
(for/list ([v vs] #:when (< idx (racket-length (cdr v))))
(cons (car v) (proc (cdr v) idx)))
#:unless (length vs)
(index-too-large-error (quote proc) xs idx)))]
[((union vs) idx)
(assert-bound [0 @<= idx @< (merge** vs racket-length)] (quote proc))
(merge** vs (@ref _ idx))])))]))
(define-syntax (define/lift/append stx)
(syntax-case stx (:)
[(_ proc : (racket-contract? racket-constructor) -> rosette-contract?)
#`(splicing-local
[(define (unsafe/append xs ys)
(match* (xs ys)
[((? racket-contract?) (? racket-contract?)) (proc xs ys)]
[((racket-constructor) _) ys]
[(_ (racket-constructor)) xs]
[((? racket-contract?) (union vs)) (unsafe-merge** vs (proc xs _))]
[((union vs) (? racket-contract?)) (unsafe-merge** vs (proc _ ys))]
[((union vs) (union ws))
(apply unsafe-merge*
(assert-some
(for*/list ([v vs] [w ws] [g (in-value (&& (car v) (car w)))] #:when g)
(cons g (proc (cdr v) (cdr w))))
#:unless (* (length vs) (length ws))
(arguments-error (quote proc) (format "expected ~a ~a" rosette-contract? rosette-contract?)
"first argument" vs "second argument" ws)))]))]
(define #,(lift-id #'proc)
(case-lambda
[() (racket-constructor)]
[(xs) (type-cast rosette-contract? xs (quote proc))]
[(xs ys) (unsafe/append (type-cast rosette-contract? xs (quote proc))
(type-cast rosette-contract? ys (quote proc)))]
[xss (for/fold ([out (racket-constructor)])
([xs (for/list ([ys xss]) (type-cast rosette-contract? ys (quote proc)))])
(unsafe/append out xs))])))]))
(define-syntax (define/lift/split stx)
(syntax-case stx ()
[(_ proc left right)
#`(define (#,(lift-id #'proc) xs idx)
(if (and (not (union? xs)) (number? idx))
(proc xs idx)
(match* (xs (type-cast @integer? idx (quote proc)))
[((not (? union?)) (? number? idx)) (proc xs idx)]
[(_ idx) (values (left xs idx) (right xs idx))])))]))
(define-syntax-rule (all-same? proc a b ...)
(let ([v (proc a)])
(and (eq? v (proc b)) ...)))
(define-syntax-parameter for/seq (syntax-rules ()))
(define-syntax (do-compress stx)
(syntax-case stx ()
[(_ (g vs) ...)
(with-syntax ([(v ...) (generate-temporaries #'(vs ...))])
#'(cons (or-|| g ...) (for/seq ([v vs] ...) (merge* (cons g v) ...))))]))
; Compresses a list of guarded sequences, merging all sequences of the
; same length into a single sequence with guarded entries (forced merge).
(define-syntax seq-compress
(syntax-rules (:)
[(seq-compress ps seq-length seq-map : for/sequence)
(syntax-parameterize
([for/seq (syntax-rules () for/sequence)])
(match ps
[(list _) ps]
[(list (cons g xs) (cons h ys))
(if (all-same? seq-length xs ys) (list (do-compress [g xs] [h ys])) ps)]
[_ (let loop ([ps (sort ps < #:key (compose seq-length cdr))] [len #f] [acc '()])
(match ps
[(list)
(for/list ([group acc])
(match group
[(list elt) elt]
[(list (cons g xs) (cons h ys)) (do-compress [g xs] [h ys])]
[(list (cons g xs) (cons h ys) (cons f zs)) (do-compress [g xs] [h ys] [f zs])]
[(list (cons g xs) (cons h ys) (cons f zs) (cons k vs)) (do-compress [g xs] [h ys] [f zs] [k vs])]
[_ (cons (apply || (map car group))
(apply seq-map merge* (for/list ([g group])
(seq-map (curry cons (car g)) (cdr g)))))]))]
[(list (and (cons _ (app seq-length (== len))) p) rest (... ...))
(loop rest len (cons (cons p (car acc)) (cdr acc)))]
[(list p rest (... ...))
(loop rest (seq-length (cdr p)) (cons (list p) acc))]))]))]))

168
rosette/base/adt/vector.rkt
View File

@ -1,168 +0,0 @@
#lang racket
(require (for-syntax racket/syntax "../core/lift.rkt")
racket/provide
(only-in racket/unsafe/ops [unsafe-car car] [unsafe-cdr cdr])
"../core/safe.rkt" "../core/lift.rkt" "seq.rkt" "../core/forall.rkt" "generic.rkt"
(only-in "list.rkt" @list?)
(only-in "../form/control.rkt" @when)
(only-in "../core/store.rkt" store!)
(only-in "../core/term.rkt" define-lifted-type @any/c type-cast)
(only-in "../core/equality.rkt" @eq? @equal?)
(only-in "../core/bool.rkt" instance-of? && ||)
(only-in "../core/real.rkt" @integer? @= @<= @< @- @+)
(only-in "../core/union.rkt" union)
(only-in "../core/merge.rkt" merge))
(provide (filtered-out with@ (all-defined-out))
(rename-out [vector @vector] [vector-immutable @vector-immutable]))
(define-lifted-type @vector?
#:base vector?
#:is-a? (instance-of? vector? @vector?)
#:methods
[(define (type-eq? self xs ys)
(or (eq? xs ys)
(and (immutable? xs) (immutable? ys) (vector=? @eq? xs ys))))
(define (type-equal? self xs ys) (vector=? @equal? xs ys))
(define (type-cast self v [caller 'type-cast])
(adt-type-cast v #:type vector? #:lifted @vector? #:caller caller))
(define (type-compress self force? ps)
(let-values ([(immutable mutable) (partition (compose1 immutable? cdr) ps)])
(append (for/list ([p (unsafe/compress immutable)])
(cons (car p) (vector->immutable-vector (cdr p))))
(if force? (unsafe/compress mutable) mutable))))
(define (type-construct self vals) (list->vector vals))
(define (type-deconstruct self val) (vector->list val))])
(define (vector=? =? xs ys)
(let ([len (vector-length xs)])
(and (= len (vector-length ys))
(let loop ([i 0] [eqs '()])
(if (= i len)
(apply && eqs)
(let ([eq (=? (vector-ref xs i) (vector-ref ys i))])
(and eq (loop (add1 i) (cons eq eqs)))))))))
(define (unsafe/compress ps)
(seq-compress ps vector-length vector-map :
[(for/seq ([x vec] rest ...) body)
(for/vector #:length (vector-length vec)
([x vec] rest ...) body)]))
(define/lift (vector-length vector->list vector->immutable-vector) :: vector? -> @vector?)
(define/lift (list->vector) :: list? -> @list?)
(define/lift/ref vector-ref : (vector? vector-length) -> @vector?)
(define/lift/append vector-append : (vector? vector) -> @vector?)
(define (merge-set! vec idx val guard)
(for ([i (in-range (vector-length vec))])
(store! vec i (merge (&& guard (@= i idx)) val (vector-ref vec i)) vector-ref vector-set!)))
(define (@vector-set! vec idx val)
;(printf "vector-set! ~a ~a ~a\n" (eq-hash-code vec) idx val)
(if (and (vector? vec) (number? idx))
(store! vec idx val vector-ref vector-set!)
(match* ((type-cast @vector? vec 'vector-set!) (type-cast @integer? idx 'vector-set!))
[((? vector? vs) (? number? idx))
(store! vs idx val vector-ref vector-set!)]
[((? vector? vs) idx)
(assert-bound [0 @<= idx @< (vector-length vs)] 'vector-set!)
(merge-set! vs idx val #t)]
[((union vs) (? number? idx))
(assert-bound [0 <= idx] 'vector-set!)
(assert-|| (for/list ([v vs] #:when (< idx (vector-length (cdr v))))
(let ([guard (car v)]
[vec (cdr v)])
(store! vec idx (merge guard val (vector-ref vec idx)) vector-ref vector-set!)
guard))
#:unless (length vs)
(index-too-large-error 'vector-set! vec idx))]
[((union vs) idx)
(assert-bound [0 @<= idx @< (merge** vs vector-length)] 'vector-set!)
(for ([v vs])
(merge-set! (cdr v) idx val (car v)))])))
(define (@vector-fill! vec val)
(match (type-cast @vector? vec 'vector-fill!)
[(? vector? vs)
(for ([i (in-range (vector-length vs))])
(store! vs i val vector-ref vector-set!))]
[(union vs)
(for ([v vs])
(let ([guard (car v)]
[vec (cdr v)])
(for ([i (in-range (vector-length vec))])
(store! vec i (merge guard val (vector-ref vec i)) vector-ref vector-set!))))]))
; Vector copy helper procedure. Requires dest and src to be
; vectors (rather than unions of vectors), and dest-start, src-start
; and len to be concrete in-range numbers.
(define (concrete/vector-copy! dest dest-start src src-start len)
(for ([idx len])
(@vector-set! dest (+ dest-start idx) (vector-ref src (+ src-start idx)))))
(define-syntax-rule (in-concrete nat max-nat)
(if (number? nat) (in-value nat) (in-range max-nat)))
(define @vector-copy!
(case-lambda
[(dest dest-start src)
(@vector-copy! dest dest-start src 0)]
[(dest dest-start src src-start)
(let ([dest (type-cast @vector? dest 'vector-copy!)]
[dest-start (type-cast @integer? dest-start 'vector-copy!)]
[src (type-cast @vector? src 'vector-copy!)]
[src-start (type-cast @integer? src-start 'vector-copy!)])
(for*/all ([d dest] [s src])
(@vector-copy! d dest-start s src-start (vector-length s))))]
[(dest dest-start src src-start src-end)
(let ([dest (type-cast @vector? dest 'vector-copy!)]
[dest-start (type-cast @integer? dest-start 'vector-copy!)]
[src (type-cast @vector? src 'vector-copy!)]
[src-start (type-cast @integer? src-start 'vector-copy!)]
[src-end (type-cast @integer? src-end 'vector-copy!)])
(assert-bound [0 @<= dest-start] 'vector-copy)
(assert-bound [0 @<= src-start @<= src-end] 'vector-copy!)
(define len (@- src-end src-start))
(define dest-end (@+ dest-start len))
(for*/all ([d dest] [s src])
(let ([dest-len (vector-length d)]
[src-len (vector-length s)])
(assert-bound [dest-end @<= dest-len] 'vector-copy!)
(assert-bound [src-end @<= src-len] 'vector-copy!)
(cond
[(equal? 0 len) (void)]
[(and (number? dest-start) (number? src-start) (number? len))
(concrete/vector-copy! d dest-start s src-start len)]
[(number? len)
(for* ([concrete-dest-start (in-concrete dest-start (add1 (- dest-len len)))]
[concrete-src-start (in-concrete src-start (add1 (- src-len len)))])
(@when (&& (@= dest-start concrete-dest-start)
(@= src-start concrete-src-start))
(concrete/vector-copy! d concrete-dest-start s concrete-src-start len)))]
[else
(for* ([concrete-len (add1 (min (if (number? dest-start) (- dest-len dest-start) dest-len)
(if (number? src-start) (- src-len src-start) src-len)))]
[concrete-dest-start (in-concrete dest-start (add1 (- dest-len concrete-len)))]
[concrete-src-start (in-concrete src-start (add1 (- src-len concrete-len)))])
(@when (&& (@= len concrete-len)
(@= dest-start concrete-dest-start)
(@= src-start concrete-src-start))
(concrete/vector-copy! d concrete-dest-start s concrete-src-start concrete-len)))]))))]))

188
rosette/base/base.rkt
View File

@ -1,188 +0,0 @@
#lang racket
;; ------ Rosette (lifted) syntax and procedures ------ ;;
(require
(for-syntax racket/syntax (only-in "core/lift.rkt" drop@))
racket/provide
"core/bool.rkt" "core/real.rkt" "core/numerics.rkt" "core/bitvector.rkt" "core/bvlib.rkt"
"core/function.rkt"
"core/procedure.rkt" "core/equality.rkt" "core/distinct.rkt" "core/reflect.rkt"
"adt/box.rkt" "adt/list.rkt" "adt/vector.rkt" "adt/bvseq.rkt"
"struct/struct.rkt" "struct/generics.rkt"
"form/define.rkt" "form/control.rkt" "form/module.rkt" "form/app.rkt")
(provide
(rename-out [@|| ||]) ; The character sequence || does not play nicely with the filtered-out form.
(filtered-out drop@
(combine-out
; core/bool.rkt
vc with-vc clear-vc! vc? vc-true? vc-true vc-assumes vc-asserts
@assert @assume
@boolean? @false? @! @&& @=> @<=> @forall @exists
; core/real.rkt
@integer? @real? @= @< @<= @>= @>
@+ @* @- @/ @quotient @remainder @modulo @abs
@integer->real @real->integer @int?
; core/numerics.rkt
@number? @positive? @negative? @zero? @even? @odd?
@add1 @sub1 @sgn @truncate @floor @ceiling @min @max
@exact->inexact @inexact->exact @expt
; core/bitvector.rkt
bv @bv? bitvector bitvector-size bitvector?
@bveq @bvslt @bvsgt @bvsle @bvsge @bvult @bvugt @bvule @bvuge
@bvnot @bvor @bvand @bvxor @bvshl @bvlshr @bvashr
@bvneg @bvadd @bvsub @bvmul @bvudiv @bvsdiv @bvurem @bvsrem @bvsmod
@concat @extract @sign-extend @zero-extend
@z3_ext_rotate_left @z3_ext_rotate_right
@integer->bitvector @bitvector->integer @bitvector->natural
; core/bvlib.rkt
bit lsb msb bvzero? bvadd1 bvsub1
bvsmin bvsmax bvumin bvumax
rotate-left rotate-right bvrol bvror
bool->bitvector bitvector->bool bitvector->bits
; core/function.rkt
@fv? ~> function?
; core/distinct.rkt
@distinct?
; core/equality.rkt
@eq? @equal?
; core/reflect.rkt
symbolics type? solvable? @any/c type-of type-cast for/all for*/all
symbolic? concrete?
term? constant? expression?
term expression constant term-type
term=? term->datum
terms terms-count terms-ref with-terms clear-terms! gc-terms!
union? union union-contents union-guards union-values
union-filter in-union in-union* in-union-guards in-union-values
result? result-value result-state normal normal? failed failed?
; adt/box.rkt
@box @box-immutable @box? @unbox @set-box!
; adt/list.rkt : Pair Constructors and Selectors
@pair? @null? @cons @car @cdr @null @list? @list
; adt/list.rkt : List Operations
@length @list-ref @list-tail @append @reverse
; adt/list.rkt : List Iteration
@map @andmap @ormap @for-each @foldl @foldr
; adt/list.rkt : List Filtering
@filter @remove @remq @remove* @remq* @sort
; adt/list.rkt : List Searching
@member @memq @memf @findf @assoc @assq @assf
; adt/list.rkt : Pair Accessor Shorthands
@caar @cadr @cdar @cddr
@caaar @caadr @cadar @caddr @cdaar @cdadr @cddar @cdddr
@caaaar @caaadr @caadar @caaddr @cadaar @cadadr @caddar @cadddr
@cdaaar @cdaadr @cdadar @cdaddr @cddaar @cddadr @cdddar @cddddr
; adt/list.rkt : Additional List Functions and Synonyms
@cons? @empty? @first @rest @second @third @fourth @fifth @sixth @seventh @eighth @ninth @tenth
@last @last-pair
@take @drop @split-at @take-right @drop-right @split-at-right
@add-between @append* @flatten @remove-duplicates
@filter-map @count @partition @append-map @filter-not @shuffle
@argmin @argmax @list-set
; adt/list.rkt : Non-Standard Functions
@insert
; adt/vector.rkt : Basic Functions
@vector? @vector @vector-immutable
@vector-length @vector-ref @vector-set! @vector->list @list->vector @vector->immutable-vector
@vector-fill! @vector-copy!
; adt/vector.rkt : Additional Vector Functions
@vector-append
; adt/procedure.rkt
@procedure? @apply @procedure-rename @negate @void?
; adt/bvseq.rkt
@list-ref-bv @list-set-bv @length-bv
@take-bv @take-right-bv
@drop-bv @drop-right-bv @list-tail-bv
@split-at-bv @split-at-right-bv
@vector-ref-bv @vector-set!-bv @vector-length-bv
; struct/struct.rkt
struct struct-field-index define/generic define-struct
; struct/generics.rkt
@define-generics @make-struct-type-property
; form/define.rkt
define-symbolic define-symbolic*
; form/control.rkt
@if @and @or @not @nand @nor @xor @implies
@unless @when @cond @case else
; form/module.rkt
@#%module-begin @#%top-interaction @module @module* @module+
; form/app.rkt
#%app #%plain-app
)))
;; ------ Racket syntax and procedures that can be used without being lifted ------ ;;
(require racket/local)
;; Racket syntax and procedures that can be used without being lifted
(provide
; require and provide forms
require
only-in except-in prefix-in rename-in
combine-in relative-in only-meta-in
lib file planet submod
provide
all-defined-out all-from-out rename-out except-out
prefix-out struct-out combine-out protect-out
for-meta for-syntax for-template for-label
; literals
quote #%datum
; expression wrapper
#%expression
; variable references and #%top
#%top
; procedure expressions
lambda case-lambda λ #%plain-lambda
; local binding
let let* letrec
let-values let*-values letrec-values
let-syntax letrec-syntax let-syntaxes letrec-syntaxes
letrec-syntaxes+values
; local definitions
local
; definitions
define define-values define-syntax define-syntaxes
define-for-syntax define-values-for-syntax
; sequencing
begin begin0 begin-for-syntax
; assignment: this is handled by whole-module rewriting (see module.rkt)
set! set!-values
; quasiquoting
quasiquote unquote unquote-splicing
; syntax-quoting
quote-syntax
; booleans
true false
; numbers
pi
; procedures
identity const thunk thunk* curry curryr compose compose1
; void
void
; structs
prop:procedure gen:equal+hash gen:custom-write
; macros
syntax-case syntax-case* with-syntax
syntax quasisyntax unsyntax unsyntax-splicing
syntax/loc quasisyntax/loc quote-syntax/prune
syntax-rules syntax-id-rules
define-syntax define-syntax-rule ... _
local-expand expand expand-syntax expand-once
expand-syntax-once expand-to-top-form
expand-syntax-to-top-form
; input and output
read read-syntax
write display print writeln displayln println fprintf printf eprintf format newline
pretty-print pretty-write pretty-display pretty-format
call-with-input-file
current-input-port current-output-port current-error-port eof
; operating system
time current-seconds current-milliseconds
)

930
rosette/base/core/bitvector.rkt
View File

@ -1,930 +0,0 @@
#lang racket
(require racket/stxparam racket/stxparam-exptime
(for-syntax racket/syntax syntax/transformer))
(require "term.rkt" "union.rkt" "bool.rkt" "polymorphic.rkt"
"merge.rkt" "safe.rkt" "lift.rkt" "forall.rkt")
(require (only-in "real.rkt" @>= @> @= @integer? T*->integer?))
(provide
(rename-out [lift-op bvlift-op]) bvcoerce
(rename-out [@bv bv]) @bv? bv? bv-value bv-type
(rename-out [@bitvector bitvector]) bitvector-size bitvector?
@bveq @bvslt @bvsgt @bvsle @bvsge @bvult @bvugt @bvule @bvuge
@bvnot @bvor @bvand @bvxor @bvshl @bvlshr @bvashr
@bvneg @bvadd @bvsub @bvmul @bvudiv @bvsdiv @bvurem @bvsrem @bvsmod
@concat @extract @sign-extend @zero-extend
@z3_ext_rotate_left @z3_ext_rotate_right
@integer->bitvector @bitvector->integer @bitvector->natural)
;; ----------------- Bitvector Types ----------------- ;;
; Cache of all bitvector types constructed so far, mapping sizes to types.
(define bitvector-types (make-hasheq))
; Returns the bitvector type of the given size.
(define (bitvector-type size)
(assert (and (exact-positive-integer? size) (fixnum? size))
(argument-error 'bitvector "(and/c exact-positive-integer? fixnum?)" size))
(hash-ref! bitvector-types size (λ () (bitvector size))))
; Represents a bitvector type.
(struct bitvector (size)
#:transparent
#:property prop:procedure ; Recognizes bitvector values of this type.
(lambda (self v)
(match v
[(bv _ (== self)) #t]
[(term _ (== self)) #t]
[(union vs t)
(and (subtype? self t)
(match vs
[(list _ ... (cons g (and (? typed?) (app get-type (== self)))) _ ...) g]
[_ #f]))]
[_ #f]))
#:methods gen:type
[(define (least-common-supertype self other) (if (equal? self other) self @any/c))
(define (type-name self) (string->symbol (format "bitvector~a?" (bitvector-size self))))
(define (type-applicable? self) #f)
(define (type-cast self v [caller 'type-cast])
(match v
[(bv _ (== self)) v]
[(term _ (== self)) v]
[(union (list _ ... (cons gt (and (? typed? vt) (app get-type (== self)))) _ ...) _)
(assert gt (type-error caller self v))
vt]
[_ (assert #f (type-error caller self v))]))
(define (type-eq? self u v) (@bveq u v))
(define (type-equal? self u v) (@bveq u v))
(define (type-compress self f? ps) (generic-merge* ps))
(define (type-construct self vs) (car vs))
(define (type-deconstruct self v) (list v))]
#:methods gen:solvable
[(define (solvable-default self) (bv 0 self))
(define (solvable-domain self) null)
(define (solvable-range self) self)]
#:methods gen:custom-write
[(define (write-proc self port m)
(fprintf port "(bitvector ~a)" (bitvector-size self)))])
; Pattern matching for bitvector types.
(define-match-expander @bitvector
(syntax-rules ()
[(_ sz) (bitvector sz)])
(make-variable-like-transformer #'bitvector-type))
(define (bvsmin t) (- (expt 2 (- (bitvector-size t) 1))))
(define (bvsmin? b) (and (bv? b) (= (bv-value b) (bvsmin (bv-type b)))))
(define (bvsmax t) (- (expt 2 (- (bitvector-size t) 1)) 1))
(define (bvsmax? b) (and (bv? b) (= (bv-value b) (bvsmax (bv-type b)))))
(define (is-bitvector? v) (and (typed? v) (bitvector? (get-type v))))
;; ----------------- Bitvector Literals ----------------- ;;
; Represents a bitvector literal.
(struct bv (value type)
#:transparent
#:methods gen:typed
[(define (get-type self) (bv-type self))]
#:property prop:custom-print-quotable 'never
#:methods gen:custom-write
[(define (write-proc self port mode)
(match self
[(bv v (bitvector bw))
(let*-values ([(q r) (quotient/remainder bw 4)]
[(p b mw) (if (zero? r) (values "x" 16 q) (values "b" 2 bw))])
(fprintf port "(bv #~a~a ~a)"
p
(~r (ufinitize v bw) #:base b #:pad-string "0" #:min-width mw)
bw))]))])
; Returns a signed representation of the given number, using the specified bitwidth.
; Assumes that val is a real, non-infinite, non-NaN number.
(define (sfinitize val bitwidth)
(let* ([mask (arithmetic-shift -1 bitwidth)]
[masked (bitwise-and (bitwise-not mask) (exact-truncate val))])
(if (bitwise-bit-set? masked (- bitwidth 1))
(bitwise-ior mask masked)
masked)))
; Returns an unsigned representation of the given number, using the specified bitwidth.
; Assumes that val is a real, non-infinite, non-NaN number.
(define (ufinitize val bitwidth)
(let* ([mask (arithmetic-shift -1 bitwidth)]
[masked (bitwise-and (bitwise-not mask) (exact-truncate val))])
masked))
; Returns a bitvector that best represents the given concrete number
; with respect to the given precision specifier. The specifier may
; be either an exact-positive-integer? or a bitvector type.
; The number may be a real, non-infinite, non-NaN concrete value.
(define (make-bv val precision)
(assert (and (real? val) (not (infinite? val)) (not (nan? val)))
(arguments-error 'bv "expected a real, non-infinite, non-NaN number" "value" val))
(cond [(exact-positive-integer? precision)
(bv (sfinitize val precision) (bitvector-type precision))]
[(bitvector? precision)
(bv (sfinitize val (bitvector-size precision)) precision)]
[else
(assert #f (arguments-error 'bv "exact-positive-integer? or bitvector? type" "precision" precision))]))
; Pattern matching for bitvector literals.
(define-match-expander @bv
(syntax-rules ()
[(_ val-pat type-pat) (bv val-pat type-pat)])
(make-variable-like-transformer #'make-bv))
(define (@bv? v)
(match v
[(? bv?) #t]
[(term _ (? bitvector?)) #t]
[(union _ (? bitvector?)) #t]
[(union xs (== @any/c))
(apply || (for/list ([gv xs] #:when (@bv? (cdr gv))) (car gv)))]
[_ #f]))
;; ----------------- Lifitng Utilities ----------------- ;;
(define (lift-op op)
(case (procedure-arity op)
[(1) (lambda (x) (safe-apply-1 op x))]
[(2) (lambda (x y) (safe-apply-2 op x y))]
[else (case-lambda [(x) (safe-apply-1 op x)]
[(x y) (safe-apply-2 op x y)]
[(x . xs) (safe-apply-n op (cons x xs))])]))
(define (bitvector-type-error name . args)
(arguments-error name "expected bitvectors of same length" "arguments" args))
(define (safe-apply-1 op x)
(match x
[(? is-bitvector?) (op x)]
[(union xs _)
(merge+
(let loop ([xs xs])
(match xs
[(list) '()]
[(list (cons gx (? is-bitvector? vx)) rest ...)
(cons (cons gx (op vx)) (loop rest))]
[(list _ rest ...) (loop rest)]))
#:unless (length xs)
#:error (bitvector-type-error (object-name op) x))]
[_ (assert #f (bitvector-type-error (object-name op) x))]))
(define (safe-apply-2 op x y)
(assert (and (typed? x) (typed? y)) (bitvector-type-error (object-name op) x y))
(match* (x y)
[((app get-type (? bitvector? tx)) _)
(if (equal? tx (get-type y))
(op x y)
(op x (type-cast tx y (object-name op))))]
[(_ (app get-type (? bitvector? ty)))
(op (type-cast ty x (object-name op)) y)]
[((union xs _) (union ys _))
(merge+
(let loop ([xs xs])
(match xs
[(list) '()]
[(list (cons gx (and (? typed? vx) (app get-type (? bitvector? tx)))) rest ...)
(match ys
[(list _ ... (cons gy (and (? typed? vy) (app get-type (== tx)))) _ ...)
(match (&& gx gy)
[#f (loop rest)]
[g (cons (cons g (op vx vy)) (loop rest))])]
[_ (loop rest)])]
[(list _ rest ...)
(loop rest)]))
#:error (bitvector-type-error (object-name op) x y))]
[(_ _) (assert #f (bitvector-type-error (object-name op) x y))]))
(define (safe-apply-n op xs)
(assert (for/and ([x xs]) (typed? x)) (apply bitvector-type-error (object-name op) xs))
(match xs
[(list _ ... (app get-type (? bitvector? t)) _ ...)
(apply op (for/list ([x xs])
(if (equal? (get-type x) t) x (type-cast t x (object-name op)))))]
[(list (union vs _) (union ws _) ...)
(merge+
(let loop ([vs vs])
(match vs
[(list) '()]
[(list (cons gx (and (? typed? vx) (app get-type (? bitvector? tx)))) rest ...)
(match ws
[(list (list _ ... (cons gy (and (? typed? vy) (app get-type (== tx)))) _ ...) ...)
(match (apply && gx gy)
[#f (loop rest)]
[g (cons (cons g (apply op vx vy)) (loop rest))])]
[_ (loop rest)])]
[(list _ rest ...)
(loop rest)]))
#:error (apply bitvector-type-error (object-name op) xs))]
[_ (assert #f (apply bitvector-type-error (object-name op) xs))]))
(define-syntax-parameter finitize
(syntax-rules () [(_ e t) e]))
(define-syntax-rule (define-lifted-operator @bvop bvop type)
(define-operator @bvop
#:identifier 'bvop
#:range type
#:unsafe bvop
#:safe (lift-op bvop)))
;; ----------------- Bitvector Comparison Operators ----------------- ;;
(define (bveq x y)
(match* (x y)
[((bv u _) (bv v _)) (= u v)]
[(_ (== x)) #t]
[((expression (== ite) a (bv b _) (bv c _)) (bv d _))
(|| (&& a (= b d)) (&& (! a) (= c d)))]
[((bv d t) (expression (== ite) a (bv b _) (bv c _)))
(|| (&& a (= b d)) (&& (! a) (= c d)))]
[((expression (== ite) a (bv b t) (bv c _)) (expression (== ite) d (bv e _) (bv f _)))
(let ([b=e (= b e)]
[b=f (= b f)]
[c=e (= c e)]
[c=f (= c f)])
(or (and b=e b=f c=e c=f)
(|| (&& a d b=e) (&& a (! d) b=f) (&& (! a) d c=e) (&& (! a) (! d) c=f))))]
[(_ _) (sort/expression @bveq x y)]))
(define bvslt
(bitwise-comparator (x y) < @bvslt
[(_ (== x)) #f]
[(_ (? bvsmax?)) (! (bveq x y))]
[((? bvsmax?) _) #f]
[(_ (? bvsmin?)) #f]
[((? bvsmin?) _) (! (bveq x y))]))
(define bvsle
(bitwise-comparator (x y) <= @bvsle
[(_ (== x)) #t]
[(_ (? bvsmax?)) #t]
[((? bvsmax?) _) (bveq x y)]
[(_ (? bvsmin?)) (bveq x y)]
[((? bvsmin?) _) #t]))
(define-values (bvult bvule)
(syntax-parameterize
([finitize (syntax-rules () [(_ e t) (ufinitize e (bitvector-size t))])])
(values
(bitwise-comparator (x y) < @bvult
[(_ (== x)) #f]
[(_ (bv -1 _)) (! (bveq x y))]
[((bv -1 _) _) #f]
[(_ (bv 0 _)) #f]
[((bv 0 _) _) (! (bveq x y))])
(bitwise-comparator (x y) <= @bvule
[(_ (== x)) #t]
[(_ (bv -1 _)) #t]
[((bv -1 _) _) (bveq x y)]
[(_ (bv 0 _)) (bveq x y)]
[((bv 0 _) _) #t]))))
(define (bvsgt x y) (bvslt y x))
(define (bvsge x y) (bvsle y x))
(define (bvugt x y) (bvult y x))
(define (bvuge x y) (bvule y x))
(define-lifted-operator @bveq bveq T*->boolean?)
(define-lifted-operator @bvslt bvslt T*->boolean?)
(define-lifted-operator @bvsgt bvsgt T*->boolean?)
(define-lifted-operator @bvsle bvsle T*->boolean?)
(define-lifted-operator @bvsge bvsge T*->boolean?)
(define-lifted-operator @bvult bvult T*->boolean?)
(define-lifted-operator @bvugt bvugt T*->boolean?)
(define-lifted-operator @bvule bvule T*->boolean?)
(define-lifted-operator @bvuge bvuge T*->boolean?)
;; ----------------- Bitvector Bitwise Operators ----------------- ;;
(define bvnot (bitwise-negation bitwise-not bvnot @bvnot))
(define bvand (bitwise-connective bitwise-and bvand @bvand @bvor -1 0))
(define bvor (bitwise-connective bitwise-ior bvor @bvor @bvand 0 -1))
(define bvxor (bitwise-adder bitwise-xor bvxor @bvxor simplify-bvxor))
(define/match (max-shift? b)
[((bv a (bitvector size))) (>= (ufinitize a size) size)]
[(_) #f])
(define (bvshl x y)
(match* (x y)
[((bv a (and (bitvector size) t)) (bv b _))
(bv (sfinitize (arithmetic-shift a (min (ufinitize b size) size)) size) t)]
[(_ (bv 0 _)) x]
[((bv 0 _) _) x]
[(_ (? max-shift?)) (bv 0 (get-type x))]
[(_ _) (expression @bvshl x y)]))
(define (bvlshr x y)
(match* (x y)
[((bv a (and (bitvector size) t)) (bv b _))
(bv (sfinitize (arithmetic-shift (ufinitize a size) (- (min (ufinitize b size) size))) size) t)]
[(_ (bv 0 _)) x]
[((bv 0 _) _) x]
[(_ (? max-shift?)) (bv 0 (get-type x))]
[(_ _) (expression @bvlshr x y)]))
(define (bvashr x y)
(match* (x y)
[((bv a (and (bitvector size) t)) (bv b _))
(bv (sfinitize (arithmetic-shift a (- (min (ufinitize b size) size))) size) t)]
[(_ (bv 0 _)) x]
[((bv 0 _) _) x]
[((bv -1 _) _) x]
[((app get-type t) (? max-shift?))
(ite (bveq (bv 0 t) (bvand x (bv (bvsmin t) t))) (bv 0 t) (bv -1 t))]
[(_ _) (expression @bvashr x y)]))
(define (z3_ext_rotate_left x y)
(expression @z3_ext_rotate_left x y))
(define (z3_ext_rotate_right x y)
(expression @z3_ext_rotate_right x y))
(define-lifted-operator @bvnot bvnot T*->T)
(define-lifted-operator @bvand bvand T*->T)
(define-lifted-operator @bvor bvor T*->T)
(define-lifted-operator @bvxor bvxor T*->T)
(define-lifted-operator @bvshl bvshl T*->T)
(define-lifted-operator @bvlshr bvlshr T*->T)
(define-lifted-operator @bvashr bvashr T*->T)
(define-lifted-operator @z3_ext_rotate_left z3_ext_rotate_left T*->T)
(define-lifted-operator @z3_ext_rotate_right z3_ext_rotate_right T*->T)
;; ----------------- Simplification ruules for bitwise operators ----------------- ;;
; Simplification rules for bvxor.
(define (simplify-bvxor x y)
(match* (x y)
[((bv u t) (bv v _)) (bv (bitwise-xor u v) t)]
[(_ (== x)) (bv 0 (get-type x))]
[(_ (bv 0 _)) x]
[((bv 0 _) _) y]
[(_ (bv -1 _)) (@bvnot x)]
[((bv -1 _) _) (@bvnot y)]
[(_ (expression (== @bvnot) (== x))) (bv -1 (get-type x))]
[((expression (== @bvnot) (== y)) _) (bv -1 (get-type x))]
[(_ _) #f]))
;; ----------------- Bitvector Arithmetic Operators ----------------- ;;
(define-values (bvneg bvadd)
(syntax-parameterize
([finitize (syntax-rules () [(_ e t) (sfinitize e (bitvector-size t))])])
(values (bitwise-negation - bvneg @bvneg)
(bitwise-adder + bvadd @bvadd simplify-bvadd))))
(define bvsub
(case-lambda [(x) (bvneg x)]
[(x y) (bvadd x (bvneg y))]
[(x . xs) (apply bvadd x (map bvneg xs))]))
(define bvmul
(case-lambda
[(x) x]
[(x y) (or
(simplify-bvmul x y)
(sort/expression @bvmul x y))]
[(x . xs)
(let*-values ([(lits terms) (partition bv? (cons x xs))]
[(t) (get-type x)]
[(lit) (sfinitize
(for/fold ([out 1]) ([lit lits])
(* out (bv-value lit)))
(bitvector-size t))])
(if (or (= lit 0) (null? terms))
(bv lit t)
(match (simplify* (if (null? lits)
terms
(cons (bv lit t) terms))
simplify-bvmul)
[(list y) y]
[(list a ... (? bv? b) c ...)
(apply expression @bvmul b (sort (append a c) term<?))]
[ys (apply expression @bvmul (sort ys term<?))])))]))
(define (bvudiv x y)
(match* (x y)
[(_ (bv 0 t)) (bv -1 t)]
[(_ (bv 1 _)) x]
[((bv a (and t (bitvector size))) (bv b _))
(bv (sfinitize (quotient (ufinitize a size) (ufinitize b size)) size) t)]
[(_ (bv -1 t)) (ite (bveq x y) (bv 1 t) (bv 0 t))]
[((bv 0 t) _) (ite (bveq x y) (bv -1 t) x)]
[((app get-type t) (== x)) (ite (bveq y (bv 0 t)) (bv -1 t) (bv 1 t))]
[((expression (== ite) c (? bv? a) (? bv? b)) (? bv? d))
(ite c (bvudiv a d) (bvudiv b d))]
[((? bv? d) (expression (== ite) c (? bv? a) (? bv? b)))
(ite c (bvudiv d a) (bvudiv d b))]
[(_ _) (expression @bvudiv x y)]))
(define (bvsdiv x y)
(match* (x y)
[(_ (bv 1 _)) x]
[((bv a (and t (bitvector size))) (bv b _))
(if (= b 0)
(if (< a 0) (bv 1 t) (bv -1 t))
(bv (sfinitize (quotient a b) size) t))]
[(_ (bv 0 t)) (ite (bvslt x y) (bv 1 t) (bv -1 t))]
[(_ (bv -1 t)) (bvneg x)]
[(_ (and (bv _ t) (? bvsmin?))) (ite (bveq x y) (bv 1 t) (bv 0 t))]
[((bv 0 t) _) (ite (bveq x y) (bv -1 t) x)]
[((app get-type t) (== x)) (ite (bveq y (bv 0 t)) (bv -1 t) (bv 1 t))]
[((app get-type t) (expression (== @bvneg) (== x))) (ite (bveq x (bv (bvsmin t) t)) (bv 1 t) (bv -1 t))]
[((expression (== @bvneg) (== y)) (app get-type t)) (ite (bveq y (bv (bvsmin t) t)) (bv 1 t) (bv -1 t))]
[((expression (== ite) c (? bv? a) (? bv? b)) (? bv? d))
(ite c (bvsdiv a d) (bvsdiv b d))]
[((? bv? d) (expression (== ite) c (? bv? a) (? bv? b)))
(ite c (bvsdiv d a) (bvsdiv d b))]
[(_ _) (expression @bvsdiv x y)]))
(define (bvurem x y)
(match* (x y)
[(_ (bv 0 _)) x]
[((bv 0 t) _) x]
[(_ (bv 1 t)) (bv 0 t)]
[((bv a (and t (bitvector size))) (bv b _))
(bv (sfinitize (remainder (ufinitize a size) (ufinitize b size)) size) t)]
[(_ (bv -1 t)) (ite (bveq x y) (bv 0 t) x)]
[((app get-type t) (== x)) (bv 0 t)]
[((expression (== ite) c (? bv? a) (? bv? b)) (? bv? d))
(ite c (bvurem a d) (bvurem b d))]
[((? bv? d) (expression (== ite) c (? bv? a) (? bv? b)))
(ite c (bvurem d a) (bvurem d b))]
[(_ _) (expression @bvurem x y)]))
(define bvsrem
(bitwise-signed-remainder (x y) remainder bvsrem @bvsrem
[(_ (and (bv _ t) (? bvsmin?))) (ite (bveq x y) (bv 0 t) x)]))
(define bvsmod (bitwise-signed-remainder (x y) modulo bvsmod @bvsmod))
(define-lifted-operator @bvneg bvneg T*->T)
(define-lifted-operator @bvadd bvadd T*->T)
(define-lifted-operator @bvsub bvsub T*->T)
(define-lifted-operator @bvmul bvmul T*->T)
(define-lifted-operator @bvudiv bvudiv T*->T)
(define-lifted-operator @bvsdiv bvsdiv T*->T)
(define-lifted-operator @bvurem bvurem T*->T)
(define-lifted-operator @bvsrem bvsrem T*->T)
(define-lifted-operator @bvsmod bvsmod T*->T)
;; ----------------- Simplification rules for arithmetic operators ----------------- ;;
; Simplification rules for bvadd.
(define (simplify-bvadd x y)
(match* (x y)
[((bv a t) (bv b _)) (bv (sfinitize (+ a b) (bitvector-size t)) t)]
[((bv 0 _) _) y]
[(_ (bv 0 _)) x]
[((? expression?) (? expression?)) (or (simplify-bvadd:expr/term x y)
(simplify-bvadd:expr/term y x))]
[((? expression?) _) (simplify-bvadd:expr/term x y)]
[(_ (? expression?)) (simplify-bvadd:expr/term y x)]
[(_ _) #f]))
(define (simplify-bvadd:expr/term x y)
(match* (x y)
[((expression (== @bvneg) (== y)) _) (bv 0 (get-type x))]
[((expression (== @bvneg) (expression (== @bvadd) (== y) z)) _) (bvneg z)]
[((expression (== @bvneg) (expression (== @bvadd) z (== y))) _) (bvneg z)]
[((expression (== @bvadd) (expression (== @bvneg) (== y)) z) _) z]
[((expression (== @bvadd) z (expression (== @bvneg) (== y))) _) z]
[((expression (== @bvadd) (bv a _) b) (bv (app - a) _)) b]
[((expression (== @bvadd) (? bv? a) b) (? bv?)) (@bvadd (@bvadd a y) b)]
[((expression (== @bvadd) a b) (expression (== @bvneg) a)) b]
[((expression (== @bvadd) a b) (expression (== @bvneg) b)) a]
[((expression (== ite) a (? bv? b) (? bv? c)) (? bv?)) (ite a (bvadd b y) (bvadd c y))]
[((expression (== @bvadd) a ...) (expression (== @bvadd) b ...))
(let ([alen (length a)]
[blen (length b)])
(and (<= alen blen) (<= (- blen alen) 1)
(let* ([-a (map bvneg a)]
[-a (if (bv? (car -a))
(cons (car -a) (sort (cdr -a) term<?))
(sort -a term<?))])
(and (sublist? -a b)
(if (= alen blen)
(bv 0 (get-type x))
(car (remove* -a b)))))))]
[((expression (== @bvmul) (? bv? a) b) (expression (== @bvmul) (? bv? c) b))
(bvmul (bvadd a c) b)]
[((expression (== @bvmul) a b) (expression (== @bvmul) c d))
(let-values ([(u v w) (cond [(equal? a c) (values a b d)]
[(equal? a d) (values a b c)]
[(equal? b c) (values b a d)]
[(equal? b d) (values b a c)]
[else (values #f #f #f)])])
(and u
(match (simplify-bvadd v w)
[#f #f]
[z (bvmul z u)])))]
[(_ _) #f]))
; Simplification rules for bvmul.
(define (simplify-bvmul x y)
(match* (x y)
[((bv a t) (bv b _)) (bv (sfinitize (* a b) (bitvector-size t)) t)]
[((bv 0 _) _) x]
[((bv 1 _) _) y]
[((bv -1 _) _) (bvneg y)]
[(_ (bv 0 _)) y]
[(_ (bv 1 _)) x]
[(_ (bv -1 _)) (bvneg x)]
[((expression (== @bvmul) (? bv? a) b) (? bv? c))
(bvmul (bvmul a c) b)]
[((? bv? c) (expression (== @bvmul) (? bv? a) b))
(bvmul (bvmul a c) b)]
[(_ _) #f]))
;; ----------------- Concatenation and Extraction ----------------- ;;
(define (bvcoerce x [caller 'bvcoerce])
(assert (typed? x) (type-error caller 'bitvector? x))
(match x
[(app get-type (? bitvector?)) x]
[(union xs) (merge+ (for/list ([gx xs] #:when (is-bitvector? (cdr gx))) gx)
#:unless (length xs)
#:error (type-error caller 'bitvector? x))]
[_ (assert #f (type-error caller 'bitvector? x))]))
(define concat
(case-lambda
[(x) x]
[(x y)
(match* (x y)
[((bv a (bitvector size-a)) (bv b (bitvector size-b)))
(bv (bitwise-ior (arithmetic-shift a size-b) (ufinitize b size-b)) (bitvector-type (+ size-a size-b)))]
[((expression (== @extract) i j e) (expression (== @extract) k n e))
(if (= j (add1 k)) (extract i n e) (expression @concat x y))]
[(_ _) (expression @concat x y)])]
[(x . ys) (for/fold ([out x]) ([y ys]) (concat out y))]))
(define-operator @concat
#:identifier 'concat
#:range (lambda xs (bitvector-type (for/sum ([x xs]) (bitvector-size (get-type x)))))
#:unsafe concat
#:safe (case-lambda
[(x) (bvcoerce x 'concat)]
[(x y)
(match* ((bvcoerce x 'concat) (bvcoerce y 'concat))
[((union xs) (union ys))
(merge+ (for*/list ([gx xs] [gy ys] [g (in-value (&& (car gx) (car gy)))] #:when g)
(cons g (concat (cdr gx) (cdr gy))))
#:unless (* (length xs) (length ys))
#:error (arguments-error 'concat "infeasible arguments" "x" x "y" y))]
[((union xs) y) (merge** xs (concat _ y))]
[(x (union ys)) (merge** ys (concat x _))]
[(x y) (concat x y)])]
[(x . ys) (for/fold ([out x]) ([y ys]) (@concat out y))]))
; i and j must be concrete integers with bw > i >= j > 0, where bw is the bitwidth of x
(define (extract i j x)
(define len (add1 (- i j)))
(match* (i j x)
[((== (sub1 (bitvector-size (get-type x)))) 0 _) x]
[(_ _ (bv b _))
(bv (sfinitize (bitwise-and (bitwise-not (arithmetic-shift -1 len)) (arithmetic-shift b (- j))) len)
(bitvector-type len))]
[(_ _ (expression (== @extract) _ k a)) (extract (+ i k) (+ j k) a)]
[(_ _ (expression (== @concat) _ (and (? typed? (app get-type (bitvector size))) a)))
#:when (< i size)
(extract i j a)]
[(_ _ (expression (== @concat) a (? typed? (app get-type (bitvector size)))))
#:when (>= j size)
(extract (- i size) (- j size) a)]
[(_ 0 (expression (and @bvop (or (== @sign-extend) (== @zero-extend)))
(and (? typed? (app get-type (bitvector size))) a)
_))
(if (< i size)
(extract i j a)
(expression @bvop a (bitvector-type (add1 i))))]
[(_ _ _) (expression @extract i j x)]))
(define-operator @extract
#:identifier 'extract
#:range (lambda (i j x) (bitvector-type (add1 (- i j))))
#:unsafe extract
#:safe
(local [(define-syntax-rule (extract*-err x i j)
(arguments-error 'extract "expected (size-of x) > i >= j >= 0" "x" x "i" i "j" j))
(define (extract* i j x)
(define size (bitvector-size (get-type x)))
(assert (@> size i) (arguments-error 'extract "expected (size-of x) > i" "x" x "i" i))
(match* (i j)
[((? number?) (? number?)) (extract i j x)]
[(_ (? number?)) (merge+ (for/list ([n (in-range j size)])
(cons (@= n i) (extract n j x)))
#:unless (- size j) #:error (extract*-err x i j))]
[((? number?) _) (merge+ (for*/list ([k (in-range i -1 -1)])
(cons (@= k j) (extract i k x)))
#:unless (+ i 1) #:error (extract*-err x i j))]
[(_ _)
(if (equal? i j)
(merge+ (for*/list ([n size])
(cons (&& (@= n i) (@= n j)) (extract n n x)))
#:unless size #:error (extract*-err x i j))
(merge+ (for*/list ([n size] [k (add1 n)])
(cons (&& (@= n i) (@= k j)) (extract n k x)))
#:unless (+ size (/ (* size (- size 1)) 2)) #:error (extract*-err x i j)))]))]
(lambda (@i @j @x)
(define i (type-cast @integer? @i 'extract))
(define j (type-cast @integer? @j 'extract))
(define x (bvcoerce @x 'extract))
(assert (or (integer? i) (term? i)) (arguments-error 'extract "expected an integer i" "i" i))
(assert (or (integer? j) (term? j)) (arguments-error 'extract "expected an integer j" "j" j))
(assert (@>= i j) (arguments-error 'extract "expected i >= j" "i" i "j" j))
(assert (@>= j 0) (arguments-error 'extract "expected j >= 0" "j" j))
(match x
[(? union?) (for/all ([y x]) (extract* i j y))]
[_ (extract* i j x)]))))
;; ----------------- Extension and Coercion ----------------- ;;
; Assumes that (bitvector-size t) >= (bitvector-size (get-type v))
(define (extend v t finitize @bvop)
(match* (v t)
[((app get-type (== t)) _) v]
[((bv a (bitvector s)) _) (bv (finitize a s) t)]
[((expression (== @bvop) x _) _) (expression @bvop x t)]
[(_ _) (expression @bvop v t)]))
(define-syntax-rule (@extend-err v t)
(arguments-error 'extend "expected (bitvector-size t) >= (bitvector-size (get-type v))" "v" v "t" t))
(define-syntax-rule (@extend extend)
(lambda (@v @t)
(match* ((bvcoerce @v 'extend) @t)
[((union vs) (union ts))
(merge+ (for*/list ([gt ts] #:when (bitvector? (cdr gt))
[gv vs] #:when (<= (bitvector-size (get-type (cdr gv))) (bitvector-size (cdr gt))))
(cons (&& (car gt) (car gv)) (extend (cdr gv) (cdr gt))))
#:unless (* (length vs) (length ts)) #:error (@extend-err @v @t))]
[((union vs) (bitvector st))
(merge+ (for/list ([gv vs] #:when (<= (bitvector-size (get-type (cdr gv))) st))
(cons (car gv) (extend (cdr gv) @t)))
#:unless (length vs) #:error (@extend-err @v @t))]
[((and (app get-type (bitvector sv)) v) (union ts))
(merge+ (for/list ([gt ts] #:when (and (bitvector? (cdr gt)) (<= sv (bitvector-size (cdr gt)))))
(cons (car gt) (extend v (cdr gt))))
#:unless (length ts) #:error (@extend-err @v @t))]
[((and (app get-type (bitvector sv)) v) (bitvector st))
(assert (<= sv st) (@extend-err @v @t))
(extend v @t)]
[(_ _) (assert #f (@extend-err @v @t))])))
(define (coercion-type v t) t)
(define (sign-extend v t) (extend v t sfinitize @sign-extend))
(define (zero-extend v t) (extend v t ufinitize @zero-extend))
(define-operator @sign-extend
#:identifier 'sign-extend
#:range coercion-type
#:unsafe sign-extend
#:safe (@extend sign-extend))
(define-operator @zero-extend
#:identifier 'zero-extend
#:range coercion-type
#:unsafe zero-extend
#:safe (@extend zero-extend))
(define (integer->bitvector v t)
(match v
[(? integer?) (@bv v t)]
; This optimization is valid only when integer bitwidth >= (bitvector-size t).
;[(expression (== @bitvector->integer) (and (app get-type (== t)) x)) x]
[_ (expression @integer->bitvector v t)]))
(define (bitvector->integer v)
(match v
[(bv a _) a]
[_ (expression @bitvector->integer v)]))
(define (bitvector->natural v)
(match v
[(bv a (bitvector sz)) (ufinitize a sz)]
[_ (expression @bitvector->natural v)]))
(define-syntax-rule (@bv->* bvop)
(lambda (@v)
(match (bvcoerce @v 'bvop)
[(union vs) (merge** vs bvop)]
[v (bvop v)])))
(define-operator @integer->bitvector
#:identifier 'integer->bitvector
#:range coercion-type
#:unsafe integer->bitvector
#:safe
(lambda (@v @t)
(match* ((type-cast @integer? @v 'integer->bitvector) @t)
[(v (union ts))
(merge+ (for/list ([gt ts] #:when (bitvector? (cdr gt)))
(cons (car gt) (integer->bitvector v (cdr gt))))
#:unless (length ts) #:error (arguments-error 'integer->bitvector "expected a bitvector type t" "t" @t))]
[(v (? bitvector? t)) (integer->bitvector v t)]
[(_ _) (assert #f (arguments-error 'integer->bitvector "expected a bitvector type t" "t" @t))])))
(define-operator @bitvector->integer
#:identifier 'bitvector->integer
#:range T*->integer?
#:unsafe bitvector->integer
#:safe (@bv->* bitvector->integer))
(define-operator @bitvector->natural
#:identifier 'bitvector->natural
#:range T*->integer?
#:unsafe bitvector->natural
#:safe (@bv->* bitvector->natural))
;; ----------------- Shared lifting procedures and templates ----------------- ;;
; Partial rules for negators (bvnot and bvneg).
(define-syntax-rule (bitwise-negation op bvop @bvop)
(lambda (x)
(match x
[(bv v t) (bv (finitize (op v) t) t)]
[(expression (== @bvop) v) v]
[_ (expression @bvop x)])))
; Partial evaluation rules for connectives (bvand and bvor).
; The terms iden and !iden should be numeric literals.
(define-syntax-rule (bitwise-connective op bvop @bvop @bvco iden !iden)
(case-lambda
[(x) x]
[(x y)
(match* (x y)
[((bv u t) (bv v _)) (bv (op u v) t)]
[((bv iden _) _) y]
[(_ (bv iden _)) x]
[((bv !iden _) _) x]
[(_ (bv !iden _)) y]
[(_ _)
(or
(simplify-connective @bvop @bvco (bv !iden (get-type x)) x y)
(sort/expression @bvop x y))])]
[(x . xs)
(let*-values ([(lits terms) (partition bv? (cons x xs))]
[(lit) (for/fold ([out iden]) ([lit lits])
(op out (bv-value lit)))]
[(t) (get-type x)])
(if (or (= lit !iden) (null? terms))
(bv lit t)
(match (simplify-connective* @bvop @bvco (bv !iden t) (remove-duplicates terms))
[(list (bv u _)) (bv (op lit u) t)]
[(list y) (bvop (bv lit t) y)]
[ys (if (= lit iden)
(apply expression @bvop (sort ys term<?))
(apply expression @bvop (bv lit t) (sort ys term<?)))])))]))
; Simplification rules for bitwise and/or. Assumes that
; neither x nor y are iden or !iden.
(define (simplify-connective op co !iden x y)
(cond [(equal? x y) x]
[(expression? x)
(cond [(expression? y)
(or (simplify-connective:expr/term op co !iden x y)
(simplify-connective:expr/term op co !iden y x)
(match* (x y)
[((expression (== op) xs ...) (expression (== op) ys ...))
(for*/or ([a xs][b ys])
(match* (a b)
[(_ (expression (== @bvnot) (== a))) !iden]
[((expression (== @bvnot) (== b)) _) !iden]
[((bv x _) (bv y _)) (and (= x (bitwise-not y)) !iden)]
[(_ _) #f]))]
[((expression (== co) xs ...) (expression (== co) ys ...))
(cond [(sublist? xs ys) x]
[(sublist? ys xs) y]
[else #f])]
[(_ _) #f]))]
[(constant? y) (simplify-connective:expr/term op co !iden x y)]
[else (simplify-connective:expr/lit op co !iden x y)])]
[(expression? y)
(cond [(constant? x) (simplify-connective:expr/term op co !iden y x)]
[else (simplify-connective:expr/lit op co !iden y x)])]
[else #f]))
(define (simplify-connective:expr/term op co !iden x y)
(match x
[(expression (== @bvnot) (== y)) !iden]
[(expression (== co) _ ... (== y) _ ...) y]
[(expression (== op) _ ... (== y) _ ...) x]
[(expression (== op) _ ... (expression (== @bvnot) (== y)) _ ...) !iden]
[(expression (== @bvnot) (expression (== co) _ ... (== y) _ ...)) !iden]
[(expression (== @bvnot) (expression (== co) _ ... (expression (== @bvnot) (== y)) _ ...)) x]
[(expression (== @bvnot) (expression (== op) _ ... (expression (== @bvnot) (== y)) _ ...)) y]
[(expression (== @bvnot) a)
(match y
[(expression (== op) _ ... (== a) _ ...) !iden]
[_ #f])]
[_ #f]))
(define (simplify-connective:expr/lit op co !iden x y)
(define !y (bvnot y))
(match x
[(expression (== co) (== y) _ ...) y]
[(expression (== op) (== y) _ ...) x]
[(expression (== op) (== !y) _ ...) !iden]
[(expression (== @bvnot) (expression (== co) (== y) _ ...)) !iden]
[(expression (== @bvnot) (expression (== co) (== !y) _ ...)) x]
[(expression (== @bvnot) (expression (== op) (== !y) _ ...)) y]
[_ #f]))
; Simplification rules for bitwise and/or, applied to fix point.
; Assumes that the xs list contains no literals, only terms.
(define (simplify-connective* op co !iden xs)
(or
(let-values ([(!ys ys) (for/fold ([!ys '()][ys '()]) ([x xs])
(match x
[(expression (== @bvnot) y) (values (cons y !ys) ys)]
[_ (values !ys (cons x ys))]))])
(for/first ([!y !ys] #:when (member !y ys)) (list !iden)))
(and (> (length xs) 100) xs)
(let outer ([xs xs])
(match xs
[(list x rest ..1)
(let inner ([head rest] [tail '()])
(match head
[(list) (match (outer tail)
[(and (list (== !iden)) t) t]
[t (cons x t)])]
[(list y ys ...)
(match (simplify-connective op co !iden x y)
[#f (inner ys (cons y tail))]
[(== !iden) (list !iden)]
[v (outer (cons v (append ys tail)))])]))]
[_ xs]))))
; Partial evaluation rules for adders (bvxor and bvadd).
(define-syntax-rule (bitwise-adder op bvop @bvop simplify-bvop)
(case-lambda
[(x) x]
[(x y) (or (simplify-bvop x y)
(sort/expression @bvop x y))]
[(x . xs)
(let*-values ([(lits terms) (partition bv? (cons x xs))]
[(lit) (for/fold ([out 0]) ([lit lits]) (op out (bv-value lit)))]
[(t) (get-type x)])
(if (null? terms)
(bv (finitize lit t) t)
(match (simplify* (if (null? lits)
terms
(cons (bv (finitize lit t) t) terms))
simplify-bvop)
[(list y) y]
[(list a (... ...) (? bv? b) c (... ...))
(apply expression @bvop b (sort (append a c) term<?))]
[ys (apply expression @bvop (sort ys term<?))])))]))
; Partial evaluation rules for comparators (bvslt, bvsle, bvult, bule).
(define-syntax-rule (bitwise-comparator (x y) op @bvop expr ...)
(lambda (x y)
(match* (x y)
[((bv a t) (bv b _)) (op (finitize a t) (finitize b t))]
expr ...
[((expression (== ite) a (bv b t) (bv c _)) (bv d _))
(|| (&& a (op (finitize b t) (finitize d t)))
(&& (! a) (op (finitize c t) (finitize d t))))]
[((bv d t) (expression (== ite) a (bv b _) (bv c _)))
(|| (&& a (op (finitize d t) (finitize b t)))
(&& (! a) (op (finitize d t) (finitize c t))))]
[((expression (== ite) a (bv b t) (bv c _)) (expression (== ite) d (bv e _) (bv f _)))
(let ([b<e (op (finitize b t) (finitize e t))]
[b<f (op (finitize b t) (finitize f t))]
[c<e (op (finitize c t) (finitize e t))]
[c<f (op (finitize c t) (finitize f t))])
(or (and b<e b<f c<e c<f)
(|| (&& a d b<e) (&& a (! d) b<f) (&& (! a) d c<e) (&& (! a) (! d) c<f))))]
[(_ _) (expression @bvop x y)])))
; Partial evaluation rules for signed remainder / modulo (bvsrem, bvsmod).
(define-syntax-rule (bitwise-signed-remainder (x y) op bvop @bvop expr ...)
(lambda (x y)
(match* (x y)
[(_ (bv 1 t)) (bv 0 t)]
[(_ (bv -1 t)) (bv 0 t)]
[(_ (bv 0 t)) x]
[((bv 0 t) _) x]
[((bv a (and t (bitvector size))) (bv b _)) (bv (sfinitize (op a b) size) t)]
expr ...
[((app get-type t) (== x)) (bv 0 t)]
[((app get-type t) (expression (== @bvneg) (== x))) (bv 0 t)]
[((expression (== @bvneg) (== y)) (app get-type t)) (bv 0 t)]
[((expression (== ite) c (? bv? a) (? bv? b)) (? bv? d))
(ite c (bvop a d) (bvop b d))]
[((? bv? d) (expression (== ite) c (? bv? a) (? bv? b)))
(ite c (bvop d a) (bvop d b))]
[(_ _) (expression @bvop x y)])))

477
rosette/base/core/bool.rkt
View File

@ -1,477 +0,0 @@
#lang racket
(require "term.rkt" "union.rkt" "exn.rkt" "result.rkt" "reporter.rkt")
(provide
;; ---- lifted boolean? operations ---- ;;
@boolean? @false? @true?
! && || => <=> @! @&& @|| @=> @<=> @exists @forall
and-&& or-|| instance-of? T*->boolean?
;; ---- VC generation ---- ;;
@assert @assume $assert $assume
(rename-out [get-vc vc]) clear-vc! merge-vc! with-vc
vc? vc-assumes vc-asserts
vc-true vc-true?)
;; ----------------- Boolean type ----------------- ;;
(define-lifted-type @boolean?
#:base boolean?
#:is-a? (instance-of? boolean? @boolean?)
#:methods
[(define (solvable-default self) #f)
(define (type-eq? self u v) (<=> u v))
(define (type-equal? self u v) (<=> u v))
(define (type-cast self v [caller 'type-cast])
(match v
[(? boolean?) v]
[(term _ (== self)) v]
[(union : [g (and (or (? boolean?) (term _ (== self))) u)] _ ...)
($assert g (argument-error caller "boolean?" v))
u]
[_ ($assert #f (argument-error caller "boolean?" v))]))
(define (type-compress self force? ps)
(match ps
[(list _) ps]
[(list (cons g v) (cons u w)) (list (cons (|| g u) (|| (&& g v) (&& u w))))]
[_ (list (cons (apply || (map car ps))
(apply || (for/list ([p ps]) (&& (car p) (cdr p))))))]))])
;; ----------------- Lifting utilities ----------------- ;;
(define (lift-op op)
(define caller (object-name op))
(case (procedure-arity op)
[(1) (lambda (x) (op (type-cast @boolean? x caller)))]
[(2) (lambda (x y) (op (type-cast @boolean? x caller) (type-cast @boolean? y caller)))]
[else (case-lambda [() (op)]
[(x) (op (type-cast @boolean? x caller))]
[(x y) (op (type-cast @boolean? x caller) (type-cast @boolean? y caller))]
[xs (apply op (for/list ([x xs]) (type-cast @boolean? x caller)))])]))
; A generic typing procedure for a lifted operator that takes N >= 0 arguments of type T
; and returns a @boolean?. See term.rkt.
(define (T*->boolean? . xs) @boolean?)
(define-syntax-rule (define-lifted-operator @op $op)
(define-operator @op
#:identifier '$op
#:range T*->boolean?
#:unsafe $op
#:safe (lift-op $op)))
(define-syntax-rule (define-quantifier $op @op)
(begin
(define $op (quantifier @op))
(define-operator @op
#:identifier '$op
#:range T*->boolean?
#:unsafe $op
#:safe
(lambda (@vars @body)
(match* (@vars (type-cast @boolean? @body '$op))
[((list (constant _ (? primitive-solvable?)) (... ...)) body)
($op @vars body)]
[(_ _)
($assert
#f
(argument-error '$op "list of symbolic constants of primitive solvable types" @vars))])))))
;; ----------------- Basic boolean operators ----------------- ;;
(define (! x)
(match x
[(? boolean?) (not x)]
[(expression (== @!) y) y]
[_ (expression @! x)]))
(define && (logical-connective @&& @|| #t #f))
(define || (logical-connective @|| @&& #f #t))
(define (=> x y) ; (|| (! x) y))
(cond
[(equal? x y) #t]
[(eq? x #f) #t]
[(eq? y #t) #t]
[(eq? x #t) y]
[(eq? y #f) (! x)]
[(cancel? x y) y]
[else
(match y
[(expression (== @||) _ ... (== x) _ ...) #t]
[(expression (== @&&) (== x) b) (=> x b)]
[(expression (== @&&) b (== x)) (=> x b)]
[(expression (== @&&) (expression (== @||) _ ... (== x) _ ...) b) (=> x b)]
[(expression (== @&&) b (expression (== @||) _ ... (== x) _ ...)) (=> x b)]
[(expression (== @<=>) (== x) b) (=> x b)]
[(expression (== @<=>) b (== x)) (=> x b)]
[_ (|| (! x) y)])]))
(define (<=> x y)
(cond [(equal? x y) #t]
[(boolean? x) (if x y (! y))]
[(boolean? y) (if y x (! x))]
[(cancel? x y) #f]
[(term<? x y) (expression @<=> x y)]
[else (expression @<=> y x)]))
(define-lifted-operator @! !)
(define-lifted-operator @&& &&)
(define-lifted-operator @|| ||)
(define-lifted-operator @=> =>)
(define-lifted-operator @<=> <=>)
(define (@false? v)
(match v
[#f #t]
[(term _ (== @boolean?)) (! v)]
[(union xs (== @any/c))
(let loop ([xs xs])
(match xs
[(list) #f]
[(list (cons g (and (or (? boolean?) (term _ (== @boolean?))) u)) _ ...)
(&& g (! u))]
[_ (loop (cdr xs))]))]
[_ #f]))
(define (@true? v)
(or (eq? #t v) (! (@false? v))))
(define-quantifier exists @exists)
(define-quantifier forall @forall)
;; ----------------- Additional operators and utilities ----------------- ;;
(define-syntax and-&&
(syntax-rules ()
[(_) #t]
[(_ v0) v0]
[(_ v0 #:rest (r ...)) (let ([t0 v0]) (and t0 (@&& r ... t0)))]
[(_ v0 v ... #:rest (r ...)) (let ([t0 v0]) (and t0 (and-&& v ... #:rest (r ... t0))))]
[(_ v0 v ...) (let ([t0 v0]) (and t0 (and-&& v ... #:rest (t0))))]))
(define-syntax or-||
(syntax-rules ()
[(_) #f]
[(_ v0) v0]
[(_ v0 #:rest (r ...)) (let ([t0 v0]) (or (equal? #t t0) (@|| r ... t0)))]
[(_ v0 v ... #:rest (r ...)) (let ([t0 v0]) (or (equal? #t t0) (or-|| v ... #:rest (r ... t0))))]
[(_ v0 v ...) (let ([t0 v0]) (or (equal? #t t0) (or-|| v ... #:rest (t0))))]))
(define-syntax-rule (instance-of? primitive-type ... symbolic-type)
(match-lambda [(? primitive-type) #t] ...
[(and (? typed? v) (app get-type t))
(or (and t (subtype? t symbolic-type))
(and (union? v) (apply || (for/list ([g (in-union-guards v symbolic-type)]) g))))]
[_ #f]))
(define ⊥ (void))
(define-syntax first-term-or-bool
(syntax-rules ()
[(_ e) e]
[(_ e0 e ...) (let ([v e0])
(if (void? v)
(first-term-or-bool e ...)
v))]))
;; ----------------- Partial evaluation rules for ∀ and ∃ ----------------- ;;
(define-syntax-rule (quantifier @op)
(lambda (vars body)
(match* (vars body)
[((list) _) body]
[(_ (? boolean?)) body]
[(_ _) (expression @op vars body)])))
;; ----------------- Partial evaluation rules for && and || ----------------- ;;
(define-syntax-rule (logical-connective op co iden !iden)
(case-lambda
[() iden]
[(x) x]
[(x y)
(match* (x y)
[((== iden) _) y]
[(_ (== iden)) x]
[((== !iden) _) !iden]
[(_ (== !iden)) !iden]
[(_ _)
(first-term-or-bool
(simplify-connective op co !iden x y)
(if (term<? x y) (expression op x y) (expression op y x)))])]
[xs
(cond [(member !iden xs) !iden]
[else
(match (simplify-fp op co !iden (remove-duplicates (filter term? xs)))
[(list) iden]
[(list x) x]
[ys (apply expression op (sort ys term<?))])])]))
(define (simplify-connective op co !iden x y)
(match* (x y)
[(_ (== x)) x]
[((? expression?) (? expression?))
(first-term-or-bool
(if (term<? y x)
(simplify-connective:expr/any op co !iden x y)
(simplify-connective:expr/any op co !iden y x))
(simplify-connective:expr/expr op co !iden x y))]
[((? expression?) _)
(if (term<? y x) (simplify-connective:expr/any op co !iden x y) ⊥)]
[(_ (? expression?))
(if (term<? x y) (simplify-connective:expr/any op co !iden y x) ⊥)]
[(_ _) ⊥]))
(define (simplify-connective:expr/any op co !iden x y)
(match x
[(expression (== @!) (== y)) !iden]
[(expression (== co) _ ... (== y) _ ...) y]
[(expression (== op) _ ... (== y) _ ...) x]
[(expression (== op) _ ... (expression (== @!) (== y)) _ ...) !iden]
[(expression (== @!) (expression (== co) _ ... (== y) _ ...)) !iden]
[_ ⊥]))
(define (simplify-connective:expr/expr op co !iden a b)
(match* (a b)
[((expression (== op) _ ... x _ ...) (expression (== @!) x)) !iden]
[((expression (== @!) x) (expression (== op) _ ... x _ ...)) !iden]
[((expression (== op) xs ...) (expression (== op) ys ...))
(cond [(sublist? xs ys) b]
[(sublist? ys xs) a]
[(for*/or ([x xs][y ys]) (cancel? x y)) !iden]
[else ⊥])]
[((expression (== co) xs ...) (expression (== co) ys ...))
(cond [(sublist? xs ys) a]
[(sublist? ys xs) b]
[else ⊥])]
[((expression (== op) xs ...) (expression (== co) ys ...))
(cond [(for*/or ([x xs][y ys]) (equal? x y)) a]
[else ⊥])]
[((expression (== co) xs ...) (expression (== op) ys ...))
(cond [(for*/or ([y ys][x xs]) (equal? x y)) b]
[else ⊥])]
[(_ _) ⊥]))
(define (simplify-fp op co !iden xs)
(or
(and (> (length xs) 10) xs)
(let-values ([(!ys ys) (for/fold ([!ys '()][ys '()]) ([x xs])
(match x
[(expression (== @!) y) (values (cons y !ys) ys)]
[_ (values !ys (cons x ys))]))])
(for/first ([!y !ys] #:when (member !y ys)) (list !iden)))
(let outer ([xs xs])
(match xs
[(list x rest ..1)
(let inner ([head rest] [tail '()])
(match head
[(list) (match (outer tail)
[(and (list (== !iden)) t) t]
[t (cons x t)])]
[(list y ys ...)
(match (simplify-connective op co !iden x y)
[(== ⊥) (inner ys (cons y tail))]
[(== !iden) (list !iden)]
[v (outer (cons v (append ys tail)))])]))]
[_ xs]))))
(define (cancel? a b)
(match* (a b)
[(_ (expression (== @!) (== a))) #t]
[((expression (== @!) (== b)) _) #t]
[(_ _) #f]))
;; ----------------- VC generation ----------------- ;;
; A verification condition (VC) consists of two @boolean?
; values representing assumptions and assertions issued
; during execution. A VC is legal if at least one of its
; constituent fields is true under all models.
(struct vc (assumes asserts) #:transparent)
; The true verification condition.
(define vc-true (vc #t #t))
(define (vc-true? s) (equal? s vc-true))
; Returns (vc (s.assumes && (s.asserts => g)) s.asserts).
(define (assuming s g) ; g must be a symbolic or concrete boolean
(vc (&& (vc-assumes s) (=> (vc-asserts s) g)) (vc-asserts s)))
; Returns (vc s.assumes (s.asserts && (s.assumes => g))).
(define (asserting s g) ; g must be a symbolic or concrete boolean
(vc (vc-assumes s) (&& (vc-asserts s) (=> (vc-assumes s) g))))
; The current-vc parameter keeps track of the current verification condition,
; which is an instance of vc?. The default value for this parameter is vc-true.
(define current-vc
(make-parameter
vc-true
(lambda (v) (unless (vc? v) (raise-argument-error 'vc "vc?" v)) v)))
; Returns the current vc, without exposing the parameter outside the module.
(define (get-vc) (current-vc))
; Clears the current vc by setting it to the true spec.
(define (clear-vc!) (current-vc vc-true))
; Returns #t if x && (g => y) is equivalent to x according to the embedded
; rewrite rules. Otherwise returns #f.
(define (merge-absorbs? x g y)
(match y
[(== x) #t] ; x && (g => x)
[(expression (== @&&) (== x) (== g)) #t] ; x && (g => (x && g))
[(expression (== @&&) (== g) (== x)) #t] ; x && (g => (x && g))
[(expression (== @&&) (== x) (expression (== @||) _ ... (== g) _ ...)) #t] ; x && (g => (x && (_ => g)))
[(expression (== @&&) (expression (== @||) _ ... (== g) _ ...) (== x)) #t] ; x && (g => ((_ => g) && x))
[_ #f]))
; Returns (field x) && (gs[0] => (field ys[0])) ... && (gs[n-1] => (field gs[n-1])).
(define (merge-field field x gs ys)
(define xf (field x))
(apply && xf
(for*/list ([(g y) (in-parallel gs ys)]
[yf (in-value (field y))]
#:unless (merge-absorbs? xf g yf))
(=> g yf))))
;; Returns (field x) && (gs[0] => (field ys[0])) ... && (gs[n-1] => (field gs[n-1])).
;; Assumes that ys[i] => x for all i, and at most one gs evaluates to true in any model.
;(define (merge-field field x gs ys)
; (define xf (field x))
; (define gs=>ys
; (for*/list ([(g y) (in-parallel gs ys)]
; [yf (in-value (field y))]
; #:unless (merge-absorbs? xf g yf))
; (=> g yf)))
; (match gs=>ys
; [(list) xf]
; [(list gy) (&& xf gy)]
; [(or (list (expression (== @||) _ ... g _ ...) (expression (== @||) _ ... (expression (== @!) g) _ ...))
; (list (expression (== @||) _ ... (expression (== @!) g) _ ...) (expression (== @||) _ ... g _ ...)))
; (apply && gs=>ys)]
; [_ (apply && xf gs=>ys)]))
; Takes as input a list of n guards and n vcs and sets the current vc
; to (current-vc) && (vc-guard guard1 vc1) && ... && (vc-guard guardn vcn).
; Then, it checks if either the assumes or the asserts of the resulting vc
; are false? and if so, throws either an exn:fail:svm:assume? or
; exn:fail:svm:assert? exception. This procedure makes the following assumptions:
; * at most one of the given guards is true in any model,
; * (vc-assumes vcs[i]) => (vc-assumes (current-vc)) for all i, and
; * (vc-asserts vcs[i]) => (vc-asserts (current-vc)) for all i.
(define (merge-vc! guards vcs)
(unless (null? vcs)
(define vc*
(vc (merge-field vc-assumes (current-vc) guards vcs)
(merge-field vc-asserts (current-vc) guards vcs)))
(current-vc vc*)
(when (false? (vc-assumes vc*))
(raise-exn:fail:svm:assume:core "contradiction"))
(when (false? (vc-asserts vc*))
(raise-exn:fail:svm:assert:core "contradiction"))))
; Sets the current vc to (vc-proc (current-vc) g) where g is (@true? val).
; If g is #f or the resulting vc's vc-field value is #f,
; uses raise-exn throws an exn:fail:svm exception.
(define-syntax-rule (vc-set! val msg vc-proc vc-field raise-exn)
(let* ([guard (@true? val)]
[vc* (vc-proc (current-vc) guard)])
(current-vc vc*)
(when (false? guard)
(raise-exn msg))
(when (false? (vc-field vc*))
(raise-exn "contradiction"))))
; Sets the current vc to (asserting (current-vc) g) where g is (@true? val).
; If g is #f or the resulting vc's asserts field is #f, throws an
; exn:fail:svm:assert exception of the given kind.
(define-syntax-rule (vc-assert! val msg raise-kind)
(vc-set! val msg asserting vc-asserts raise-kind))
; Sets the current vc to (assuming (current-vc) g) where g is (@true? val).
; If g is #f or the resulting vc's assumes field is #f, throws an
; exn:fail:svm:assume exception of the given kind.
(define-syntax-rule (vc-assume! val msg raise-kind)
(vc-set! val msg assuming vc-assumes raise-kind))
; The $assert form has three variants: ($assert val), ($assert val msg),
; and ($assert val msg kind), where val is the value being asserted, msg
; is the failure message, and kind is a procedure that returns a subtype of
; exn:fail:svm:assert. Default values for msg and kind are #f and
; raise-exn:fail:svm:assert:core, respectively.
; The first two variants of this form are used for issuing assertions from
; within the Rosette core. The third variant is used to implement the @assert
; form that is exposed to user code. An $assert call modifies the current vc to
; reflect the issued assertion. If the issued assertion or the vc-assert of the
; current vc reduce to #f, the call throws an exception of the given kind after
; updating the vc.
(define-syntax ($assert stx)
(syntax-case stx ()
[(_ val) (syntax/loc stx ($assert val #f raise-exn:fail:svm:assert:core))]
[(_ val msg) (syntax/loc stx ($assert val msg raise-exn:fail:svm:assert:core))]
[(_ val msg kind) (syntax/loc stx (vc-assert! val msg kind))]))
; Analogous to the $assert form, except that it modifies the current vc to
; reflect the issued assumption.
(define-syntax ($assume stx)
(syntax-case stx ()
[(_ val) (syntax/loc stx ($assume val #f raise-exn:fail:svm:assume:core))]
[(_ val msg) (syntax/loc stx ($assume val msg raise-exn:fail:svm:assume:core))]
[(_ val msg kind) (syntax/loc stx (vc-assume! val msg kind))]))
; The @assert form modifies the current vc to reflect the issued assertion.
; The form has two variants (@assert val) and (@assert val msg), where val
; is the value being asserted and msg is the optional error message in case
; val is #f. This form is exposed to user code.
(define-syntax (@assert stx)
(syntax-case stx ()
[(_ val) (syntax/loc stx ($assert val #f raise-exn:fail:svm:assert:user))]
[(_ val msg) (syntax/loc stx ($assert val msg raise-exn:fail:svm:assert:user))]))
; The @assume form modifies the current vc to reflect the issued assumption.
; The form has two variants (@assume val) and (@assume val msg), where val
; is the value being assume and msg is the optional error message in case
; val is #f. This form is exposed to user code.
(define-syntax (@assume stx)
(syntax-case stx ()
[(_ val) (syntax/loc stx ($assume val #f raise-exn:fail:svm:assume:user))]
[(_ val msg) (syntax/loc stx ($assume val msg raise-exn:fail:svm:assume:user))]))
(define (halt-svm ex)
(define result (failed ex (current-vc)))
((current-reporter) 'exception result)
result)
(define (halt-err ex) ; Treat an exn:fail? error as an assertion failure.
(define result
(failed (make-exn:fail:svm:assert:err (exn-message ex) (exn-continuation-marks ex))
(asserting (current-vc) #f)))
((current-reporter) 'exception result)
result)
; The with-vc form has two variants, (with-vc body) and (with-vc vc0 body).
; The former expands into (with-vc (current-vc) body). The latter sets the current
; vc to vc0, evaluates the given body, returns the result, and reverts current-vc
; to the value it held before the call to with-vc.
;
; If the evaluation of the body terminates normally, (with-vc vc0 body)
; outputs (normal v vc*) where v is the value computed by the body, and vc* is
; the vc (i.e., assumes and asserts) generated during the evaluation,
; with vc0 as the initial vc.
;
; If the evaluation of the body terminates abnormally with an exn:fail? exception,
; (with-vc vc0 body) outputs (failed v vc*) where v is an exn:fail:svm? exception
; that represents the cause of the abnormal termination, and vc* is the vc
; generated during the evaluation, with vc0 as the initial vc.
(define-syntax (with-vc stx)
(syntax-case stx ()
[(_ body) (syntax/loc stx (with-vc (current-vc) body))]
[(_ vc0 body)
(syntax/loc stx
(parameterize ([current-vc vc0])
(with-handlers ([exn:fail:svm? halt-svm]
[exn:fail? halt-err])
(normal (let () body) (current-vc)))))]))

93
rosette/base/core/bvlib.rkt
View File

@ -1,93 +0,0 @@
#lang racket
(require
(only-in racket/splicing splicing-let)
"bitvector.rkt" "merge.rkt" "safe.rkt" "term.rkt" "bool.rkt" "forall.rkt" "lift.rkt"
(only-in "real.rkt" @integer? @> @>= @=)
(only-in "numerics.rkt" extreme))
(provide bit lsb msb bvzero? bvadd1 bvsub1
bvsmin bvsmax bvumin bvumax
rotate-left rotate-right bvrol bvror
bool->bitvector bitvector->bool bitvector->bits)
(define-syntax (define-lifted stx)
(syntax-case stx ()
[(_ (id arg ...) expr ...)
#'(define-lifted id (lambda (arg ...) expr ...))]
[(_ id impl)
#'(define id (procedure-rename (bvlift-op impl) 'id))]))
(define (bit i x)
(@extract i i x))
(define (lsb x) (bit 0 x))
(define-lifted (msb x)
(let ([pos (sub1 (bitvector-size (get-type x)))])
(bit pos x)))
(define-lifted bvsmin (curry extreme @bvsle))
(define-lifted bvsmax (curry extreme @bvsge))
(define-lifted bvumin (curry extreme @bvule))
(define-lifted bvumax (curry extreme @bvuge))
(define (bool->bitvector x [t 1])
(merge (@false? x) (bv 0 t) (bv 1 t)))
(define (bitvector->bool x)
(! (bvzero? x)))
(define-lifted (bvzero? x)
(@bveq x (bv 0 (get-type x))))
(define-lifted (bvadd1 x)
(@bvadd x (bv 1 (get-type x))))
(define-lifted (bvsub1 x)
(@bvsub x (bv 1 (get-type x))))
(define-lifted (bitvector->bits v)
(for/list ([i (bitvector-size (get-type v))])
(bit i v)))
(define-syntax-rule (define-rotate id proc)
(splicing-let ([dir proc])
(define (id @i @x)
(define i (type-cast @integer? @i 'id))
(define x (bvcoerce @x id))
(match i
[0 x]
[_
(assert (@>= i 0) (arguments-error 'id "expected i >= 0" "i" i))
(for/all ([x x])
(let ([sz (bitvector-size (get-type x))])
(assert (@> sz i) (arguments-error 'id "expected (size-of x) > i" "x" x "i" i))
(if (integer? i)
(dir i sz x)
(merge+ (cons (cons (@= i 0) x)
(for/list ([n (in-range 1 sz)])
(cons (@= n i)
(dir n sz x))))
#:unless sz
#:error (arguments-error 'id "expected (size-of x) > i >= 0" "x" x "i" i)))))]))))
(define-rotate rotate-left
(lambda (i sz x)
(@concat (@extract (- sz i 1) 0 x) (@extract (- sz 1) (- sz i) x))))
(define-rotate rotate-right
(lambda (i sz x)
(@concat (@extract (- i 1) 0 x) (@extract (- sz 1) i x))))
; x and y must be bitvectors (not unions) of the same length.
; shift1 and shift2 are shift operators.
(define-syntax-rule (bvrotate x y shift1 shift2)
(let* ([sz (bitvector-size (get-type y))]
[n (bv sz sz)]
[amount (@bvurem y n)])
(@bvor (shift1 x amount) (shift2 x (@bvsub n amount)))))
(define-lifted (bvrol x y) (bvrotate x y @bvshl @bvlshr))
(define-lifted (bvror x y) (bvrotate x y @bvlshr @bvshl))

53
rosette/base/core/distinct.rkt
View File

@ -1,53 +0,0 @@
#lang racket
(require "term.rkt" "bool.rkt" "real.rkt" "bitvector.rkt" "equality.rkt")
(provide @distinct?)
; Returns true iff all of the given argument values are non-equal to each other
; (i.e., pairwise distinct).
(define distinct?
(case-lambda
[() #t]
[(x) #t]
[(x y) (! (@equal? x y))]
[xs
(define t (apply type-of xs))
(match t
[(== @boolean?)
(distinct-primitive-solvable? t 2 => xs)]
[(or (== @integer?) (== @real?))
(distinct-primitive-solvable? t +inf.0 < xs)]
[(bitvector sz)
(distinct-primitive-solvable? t (expt 2 sz) (operator-unsafe @bvslt) xs)]
[_
(define x (car xs))
(and-&&
(apply &&
(let loop ([ys (cdr xs)])
(cond [(null? ys) null]
[else (match (! (@equal? x (car ys)))
[#t (loop (cdr ys))]
[#f (list #f)]
[t (cons t (loop (cdr ys)))])])))
(apply distinct? (cdr xs)))])]))
(define-operator @distinct?
#:identifier 'distinct?
#:range T*->boolean?
#:unsafe distinct?
#:safe distinct?)
; Returns true iff all of the given argument values are non-equal to each other
; (i.e., pairwise distinct). This procedure assumes that each x in xs is a value
; of type t; that t is primitive-solvable?; that c is the cardinality of type t;
; and that t<? is a strict total order over literals of type t.
(define (distinct-primitive-solvable? t c t<? xs)
(and (<= (length xs) c)
(let ([xs (for/list ([x xs]) (type-cast t x 'distinct?))])
(and (= (length xs) (set-count (list->set xs)))
(let-values ([(terms lits) (partition term? xs)])
(or (null? terms)
(apply expression @distinct? (append (sort lits t<?) (sort terms term<?)))))))))

73
rosette/base/core/equality.rkt
View File

@ -1,73 +0,0 @@
#lang racket
(require "term.rkt" "union.rkt" "bool.rkt")
(provide @eq? ; (-> any/c any/c @boolean?)
@equal?) ; (-> any/c any/c @boolean?)
; We must use identity-based hashing and comparison of user-provided values,
; because user-defined structs can override equal/hash and cause unexpected
; errors when the overriden equal? is repeatedly called by a hash map. We also
; have to use (below) identity-based comparisons for shortcircuiting for the
; same reason---equal? might be overriden by a user-defined struct.
(struct key (x y)
#:transparent
#:methods gen:equal+hash
[(define (equal-proc a b equal?-recur)
(and (eq? (key-x a) (key-x b))
(eq? (key-y a) (key-y b))))
(define (hash-proc a hash-recur)
(hash-recur (cons (eq-hash-code (key-x a)) (eq-hash-code (key-y a)))))
(define (hash2-proc a hash2-recur)
(hash2-recur (cons (eq-hash-code (key-y a)) (eq-hash-code (key-x a)))))])
(define-syntax-rule (define-equality-predicate @=? type=? @cache @make-hash)
(define (@=? x y)
(let* ([cache (@cache)]
[toplevel? (false? cache)]
[k (key x y)])
(when toplevel?
(set! cache (@make-hash))
(@cache cache))
(if (hash-has-key? cache k)
(hash-ref cache k)
(begin
(hash-set! cache k #t)
(let ([result
(cond [(eq? x y) #t] ; We must use identity-based comparisons for short-circuiting.
[(union? x) (if (union? y)
(union=union? x y @=?)
(union=value? x y @=?))]
[(union? y) (union=value? y x @=?)]
[else (type=? (type-of x y) x y)])])
(if toplevel?
(@cache #f)
(hash-set! cache k result))
result))))))
(define equal-cache (make-parameter #f))
(define eq-cache (make-parameter #f))
(define-equality-predicate @equal? type-equal? equal-cache make-hash)
(define-equality-predicate @eq? type-eq? eq-cache make-hash)
; (-> union? union? (-> any/c any/c @boolean?) @boolean?)
(define (union=union? x y =?)
(match* (x y)
[((union vs t) (union ws s))
(and (or (subtype? t s) (subtype? s t))
(apply || (for*/list ([v vs] [w ws])
(and-&&
(=? (cdr v) (cdr w))
(car v)
(car w)))))]))
; (-> union? (not/c union?) (-> any/c any/c @boolean?) @boolean?)
(define (union=value? x y =?)
(match* (x y)
[((union vs t) (app type-of s))
(and (or (subtype? t s) (subtype? s t))
(apply || (for/list ([v vs]) (and-&& (=? y (cdr v)) (car v)))))]))

61
rosette/base/core/eval.rkt
View File

@ -1,61 +0,0 @@
#lang racket
(require
(only-in "bool.rkt" with-vc $assume merge-vc!)
"exn.rkt" "result.rkt" "store.rkt" "merge.rkt")
(provide eval-assuming eval-guarded!)
; Takes as input a concrete or symbolic boolean and a thunk,
; evaluates thunk under the assumption that the guard holds,
; and returns the result. This result takes one of two forms.
;
; If the evaluation of the thunk terminates normally, the result
; is (normal (normal v st) vc*) where v is the value computed by the
; thunk, st captures all stores mutations performed during evaluation,
; and vc* captures the verification condition generated during the
; evaluation, starting from the current vc.
;
; If the thunk terminates abnormally, the result is (failed ex vc*),
; where ex is an exn:fail:svm? exception that represents the cause
; of the abnormal termination, and vc* captures the verification
; condition generated during the evaluation, starting from the current vc.
;
; Neither the current store nor the current vc are modified after
; eval-assuming returns.
(define (eval-assuming guard thunk)
(with-vc
(begin
($assume guard)
(with-store (thunk)))))
; Takes as input a list of n guards and n thunks, evaluates each thunk
; under its guard using eval-assuming, merges the resulting vcs into
; the current vc, merges the resulting stores (if any) into the current
; store, and merges the resulting values (if any) before returning them
; as output. If all of the thunks fail under their guards, eval-guarded
; raises an exn:fail:svm:merge exception after the specs are merged into
; the current vc.
; This procedure makes the following assumptions, based on the Lean
; formalization:
; (1) At most one guard evaluates to true under any model.
; (2) For all models m under which (vc) evaluates to vc-true, there is
; exactly one guard in guards that evaluates to #t under m.
; (3) For all models m under which (vc) doesn't evaluate to vc-true,
; every vc produced by evaluating the given thunks evaluates to
; the same spec as (vc) under m.
(define (eval-guarded! guards thunks)
(define results (map eval-assuming guards thunks))
(merge-vc! guards (map result-state results))
(define-values (gs rs)
(for/lists (gs rs) ([g guards][r results] #:when (normal? r))
(values g (result-value r))))
(if (null? rs)
(raise-exn:fail:svm:merge)
(begin
(merge-stores! gs (map result-state rs))
(apply merge* (for/list ([g gs][r rs])
(cons g (result-value r)))))))

107
rosette/base/core/exn.rkt
View File

@ -1,107 +0,0 @@
#lang racket
(require (only-in racket/string string-split)
(for-syntax racket/syntax racket/string)
racket/provide)
(provide (matching-identifiers-out #px"^exn:fail:svm.*\\?$" (all-defined-out))
(matching-identifiers-out #px"^make\\-exn:fail:svm.*$" (all-defined-out))
(matching-identifiers-out #px"^raise\\-exn:fail:svm.*$" (all-defined-out))
exn:fatal? fatal
argument-error arguments-error type-error contract-error index-too-large-error)
;; --------------- Exceptions --------------- ;;
; Four kinds of failures can happen during symbolic evaluation:
; (1) the execution reaches (assert e) where e evaluates to #f, or asserting e reduces vc's asserts to #f;
; (2) the execution reaches (assume e) where e evaluates to #f, or assuming e reduces vc's assumes to #f;
; (3) the execution reaches e where e raises an exn:fail? exception; and
; (4) all paths at a given merge point led to a failure.
; Within the first two types of failures, we distinguish between
; assertions and assumptions issued by user code and core (Rosette) code.
; The third type of failure is treated as an assertion failure for the
; purposes of verification condition generation. Finally,
; the fourth type of failure is tracked via exn:fail:svm:merge.
; The top of the exception hierarchy for failures raised
; during symbolic evaluation.
(struct exn:fail:svm exn:fail ())
; An assert exception can be one of the following kinds:
; * :core represents an assertion failure raised in Rosette code,
; * :user represents an assertion failure raised in user code, and
; * :err indicates that an exn:fail? exception was raised during evaluation.
(struct exn:fail:svm:assert exn:fail:svm ())
(struct exn:fail:svm:assert:core exn:fail:svm:assert ())
(struct exn:fail:svm:assert:user exn:fail:svm:assert ())
(struct exn:fail:svm:assert:err exn:fail:svm:assert ())
; An assume exception can be one of the following kinds:
; * :core represents an assumption failure raised in Rosette code, and
; * :user represents an assumption failure raised in user code.
(struct exn:fail:svm:assume exn:fail:svm ())
(struct exn:fail:svm:assume:core exn:fail:svm:assume ())
(struct exn:fail:svm:assume:user exn:fail:svm:assume ())
; An merge exception is raised when all paths at a branching point lead to a failure.
(struct exn:fail:svm:merge exn:fail:svm ())
(define-syntax (define-make-and-raise stx)
(syntax-case stx ()
[(_ id)
(with-syntax ([make-id (format-id #'id "make-~a" (syntax-e #'id))]
[raise-id (format-id #'id "raise-~a" (syntax-e #'id))]
[prefix (list-ref (string-split (symbol->string (syntax-e #'id)) ":") 3)])
#'(begin
(define (make-id [msg #f] [cont-marks #f])
(id (format "[~a] ~a" prefix (or msg "failed"))
(or cont-marks (current-continuation-marks))))
(define (raise-id [msg #f] [cont-marks #f])
(raise (make-id msg cont-marks)))))]
[(_ id ...)
#'(begin (define-make-and-raise id) ...)]))
; Creates two procedures make-* and raise-* for each exception type that
; creates and raises an exception of the given type, respectively.
(define-make-and-raise
exn:fail:svm:assert:core
exn:fail:svm:assert:user
exn:fail:svm:assert:err
exn:fail:svm:assume:core
exn:fail:svm:assume:user
exn:fail:svm:merge)
;; --------------- Messages --------------- ;;
; Fatal errors indicate bugs in the Rosette implementation.
; Since Rosette only catches and handles errors of subtype exn:fail?,
; exn:fatal is a subtype of exn and hence will not be caught as part
; of symbolic evaluation.
(struct exn:fatal exn ())
(define (fatal msg) (raise (exn:fatal msg (current-continuation-marks))))
(define (argument-error name expected given)
(format "~a: contract violation\n expected: ~a\n given: ~a"
name expected given))
(define (arguments-error name message . field-value)
(define o (open-output-string))
(fprintf o "~a: ~a" name message)
(let loop ([fvs field-value])
(match fvs
[(list) (get-output-string o)]
[(list f) (fatal (format "arguments-error: missing value after field string ~a" f))]
[(list f v rest ...)
(fprintf o "\n ~a: ~a" f v)
(loop rest)])))
(define (type-error name expected given)
(argument-error name (format "~a" expected) given))
(define (contract-error name contract given)
(argument-error name (format "~a" (contract-name contract)) given))
(define (index-too-large-error who xs idx)
(arguments-error who "index is too large" "index" idx "in" xs))

104
rosette/base/core/forall.rkt
View File

@ -1,104 +0,0 @@
#lang racket
(require racket/splicing (for-syntax racket/syntax)
syntax/parse/define
(only-in racket/unsafe/ops [unsafe-car car] [unsafe-cdr cdr])
(only-in "merge.rkt" merge merge* merge-same)
(only-in "bool.rkt" ! || &&)
(only-in "union.rkt" union union?)
(only-in "term.rkt" expression)
(only-in "polymorphic.rkt" guarded guarded-test guarded-value ite ite*)
(only-in "equality.rkt" @equal?)
"safe.rkt" "../core/eval.rkt" "../core/store.rkt" "../core/result.rkt")
(provide for/all for*/all guard-apply)
; This macro is equivalent to a nested use of
; for/all. For example,
; (for*/all ([v0 val0] [v1 val1]) expr)
; is equivalent to
; (for/all ([v0 val0])
; (for/all ([v1 val1])
; expr))
(define-syntax-parser for*/all
#:disable-colon-notation
[(_ () e ...+) (syntax/loc this-syntax (begin e ...))]
[(_ (v0:gv0 v:gv ...) e ...+)
(syntax/loc this-syntax
(for/all (v0:gv0)
(for*/all (v:gv ...) e ...)))])
; This macro takes the following form:
; (for/all ([v val]) expr)
; where v is an identifier that can be used in expr,
; and val is a Rosette value. If the provided value
; is a symbolic reference, the macro evaluates the
; expression for all possible v's to which that
; symbolic reference could point. If the provided
; value is not a symbolic reference, then the expression
; is simply evaluated with v bound to the value itself.
(define-syntax-parser for/all
[(_ ([v:id val]) e ...+)
(syntax/loc this-syntax
(let ([proc (lambda (v) e ...)])
(match val
[(union gvs) (guard-apply proc gvs)]
[other (proc other)])))]
[(_ ([v:id val #:exhaustive]) e ...+)
#:with ooo (quote-syntax ...)
(syntax/loc this-syntax
(let ([proc (lambda (v) e ...)])
(match val
[(or (? union? sym) (and (expression (or (== ite) (== ite*)) _ ooo) sym))
(guard-apply proc (flatten-guarded sym))]
[other (proc other)])))]
[(_ ([v:id val concrete]) e ...+)
(syntax/loc this-syntax (for/all ([v val concrete @equal?]) e ...))]
[(_ ([v:id val concrete ==]) e ...+)
(syntax/loc this-syntax
(let ([sym val] [=== ==])
(guard-apply
(lambda (v) e ...)
(for/list ([c concrete]) (cons (=== sym c) c)))))])
(define (flatten-guarded v)
(merge-same
(let loop ([guards '()][val v])
(match val
[(expression (== ite) c t e)
(append (loop (cons c guards) t)
(loop (cons (! c) guards) e))]
[(expression (== ite*) gvs ...)
(apply append
(for/list ([gv gvs])
(loop (cons (guarded-test gv) guards)
(guarded-value gv))))]
[(union gvs)
(apply append
(for/list ([gv gvs])
(loop (cons (car gv) guards)
(cdr gv))))]
[_ (list (cons (apply && guards) val))]))))
; Applies the given procedure to each of the guarded values,
; given as guard/value structures. The application of the procedure
; to each value is done under the value's guard, and so are all
; the state updates performed during the evaluation. The result
; of this procedure is the result of this evaluation process.
; The guard-apply procedure also merges any state updates resulting
; from successful guarded evaluations of proc on the given values.
;
; At most one of the given guards may be true under any model.
(define (guard-apply proc guarded-values [guard-of car] [value-of cdr])
; If any of the guarded-values has #t as its guard, it's executed
; directly, since all the guards must be #f under all models.
(define gv (findf (lambda (gv) (eq? (guard-of gv) #t)) guarded-values))
(cond
[gv (proc (value-of gv))]
[else (eval-guarded! (map guard-of guarded-values)
(map (lambda (gv) (thunk (proc (value-of gv)))) guarded-values))]))

116
rosette/base/core/function.rkt
View File

@ -1,116 +0,0 @@
#lang racket
(require racket/generic
(for-syntax syntax/transformer)
"term.rkt" "bool.rkt" "safe.rkt" "union.rkt" "equality.rkt" "merge.rkt"
(only-in "procedure.rkt" @procedure?))
(provide (rename-out [fv-stx fv]) @fv? fv? fv-type
~> function function? function-domain function-range)
#|-----------------------------------------------------------------------------------|#
; A function type is a solvable applicable type. That is, it implements the solvable?
; interface and its type-applicable? method returns true. The domain of a function type
; is a non-empty list of primitive-solvable? types, and its range is a primitive-solvable?
; type.
;
; The only values that have function types are instances of the fv struct.
; An fv value is a procedure and can be directly applied to values
; (symbolic, concrete, or a mix of the two).
#|-----------------------------------------------------------------------------------|#
; Represents a function type.
(struct function (domain range)
#:transparent
#:guard (lambda (dom ran name)
(when (null? dom)
(error name "expected a non-empty list of domain types"))
(for ([t dom] #:unless (primitive-solvable? t))
(raise-arguments-error name "expected a list of primitive solvable types" "domain" dom))
(unless (primitive-solvable? ran)
(raise-arguments-error name "expected a primitive solvable type" "range" ran))
(values dom ran))
#:property prop:procedure ; Recognizes functions of this type.
(lambda (self v)
(match v
[(? typed? (app get-type (== self))) #t]
[(union _ (or (== @procedure?) (== @any/c)))
(apply || (for/list ([g (in-union-guards v self)]) g))]
[_ #f]))
#:methods gen:type
[(define (least-common-supertype self other)
(cond [(equal? self other) self]
[(type-applicable? other) @procedure?]
[else @any/c]))
(define (type-name self) (string->symbol (~a self)))
(define (type-applicable? self) #t)
(define (type-cast self v [caller 'type-cast])
(match v
[(? typed? (app get-type (== self))) v]
[(union _ (or (== @procedure?) (== @any/c)))
(match (union-filter v self)
[(union (list (cons g u)))
(assert g (argument-error caller (~a self) v))
u]
[u
(assert (apply || (union-guards u)) (argument-error caller (~a self) v))
u])]
[_ (assert #f (argument-error caller (~a self) v))]))
(define (type-eq? self u v) (eq? u v))
(define (type-equal? self u v) (equal? u v))
(define (type-compress self force? ps) ps)
(define (type-construct self vs) (car vs))
(define (type-deconstruct self v) (list v))]
#:methods gen:solvable
[(define/generic generic-solvable-default solvable-default)
(define (solvable-default self)
(fv self (procedure-reduce-arity
(lambda args (generic-solvable-default (function-range self)))
(length (function-domain self)))))
(define (solvable-domain self) (function-domain self))
(define (solvable-range self) (function-range self))]
#:methods gen:custom-write
[(define (write-proc self port m)
(match-define (function dom ran) self)
(for ([t dom]) (fprintf port "~a~a" t "~>"))
(fprintf port "~a" ran))])
(define ~>
(case-lambda
[(d r) (function (list d) r)]
[(d0 d1 r) (function (list d0 d1) r)]
[(d0 d1 . rest) (function `(,d0 ,d1 ,@(drop-right rest 1)) (last rest))]))
; Represents a function value.
(struct fv (type λ)
#:property prop:procedure
[struct-field-index λ]
#:methods gen:typed
[(define (get-type self) (fv-type self))]
#:methods gen:custom-write
[(define (write-proc self port m)
(fprintf port "(fv ~a)" (fv-type self)))])
(define (make-fv type proc)
(fv type
(procedure-reduce-arity
(lambda args
(apply proc
(for/list ([a args] [t (function-domain type)])
(type-cast t a))))
(length (function-domain type)))))
(define-match-expander fv-stx
(lambda (stx)
(syntax-case stx ()
[(_ pat ...) #'(fv pat ... _)]))
(make-variable-like-transformer #'make-fv))
(define (@fv? v)
(match v
[(? fv?) #t]
[(term _ (? function?)) #t]
[(union _ (? function?)) #t]
[(union xs (or (== @procedure?) (== @any/c)))
(apply || (for/list ([gv xs] #:when (@fv? (cdr gv))) (car gv)))]
[_ #f]))

98
rosette/base/core/lift.rkt
View File

@ -1,98 +0,0 @@
#lang racket
(require racket/splicing (for-syntax racket/syntax) racket/stxparam
(only-in racket/unsafe/ops [unsafe-car car] [unsafe-cdr cdr])
(only-in "merge.rkt" merge* unsafe-merge*)
(only-in "union.rkt" union)
(only-in "type.rkt" type-cast)
"safe.rkt")
(provide define/lift (for-syntax lift-id) merge+ merge** unsafe-merge** flat-pattern-contract
with@ drop@ add@)
(define (with@ name)
(and (regexp-match? #rx"^@.+$" name) name))
(define (drop@ name)
(if (regexp-match? #rx"^@.+$" name)
(regexp-replace #rx"@" name "")
name))
(define (add@ name)
(if (regexp-match? #rx"^@.+$" name)
name
(string-append "@" name)))
(define-syntax distribute
(syntax-rules (_)
[(distribute variant ps (proc arg ... _))
(apply variant (for/list ([p ps]) (cons (car p) (proc arg ... (cdr p)))))]
[(distribute variant ps (proc _ arg ...))
(apply variant (for/list ([p ps]) (cons (car p) (proc (cdr p) arg ...))))]
[(distribute variant ps proc)
(apply variant (for/list ([p ps]) (cons (car p) (proc (cdr p)))))]))
(define-syntax merge**
(syntax-rules (_)
[(merge** ps (proc arg ... _)) (distribute merge* ps (proc arg ... _))]
[(merge** ps (proc _ arg ...)) (distribute merge* ps (proc _ arg ...))]
[(merge** ps proc) (distribute merge* ps proc)]))
(define-syntax unsafe-merge**
(syntax-rules (_)
[(unsafe-merge** ps (proc arg ... _)) (distribute unsafe-merge* ps (proc arg ... _))]
[(unsafe-merge** ps (proc _ arg ...)) (distribute unsafe-merge* ps (proc _ arg ...))]
[(unsafe-merge** ps proc) (distribute unsafe-merge* ps proc)]))
(define-syntax merge+
(syntax-rules ()
[(_ expr #:error err) (apply merge* (assert-some expr err))]
[(_ expr #:unless size #:error err) (apply merge* (assert-some expr #:unless size err))]))
(define-syntax (define/lift stx)
(syntax-case stx (: :: ->)
[(_ (id0 id ...) :: contracted? -> rosette-type?)
(or (identifier? #'contracted?) (raise-argument-error "identifier?" #'contracted?))
#'(begin
(define/lift id0 :: contracted? -> rosette-type?)
(define/lift id :: contracted? -> rosette-type?) ...)]
[(_ id :: contracted? -> rosette-type?) ; repeated from (_ id : contracted? -> rosette-type?) - params don't work
(or (identifier? #'contracted?) (raise-argument-error "identifier?" #'contracted?))
#`(define (#,(lift-id #'id) val)
(if (contracted? val)
(id val)
(match (type-cast rosette-type? val (quote id))
[(? contracted? v) (id v)]
[(union vs) (apply merge* (assert-some
(for/list ([v vs] #:when (contracted? (cdr v)))
(cons (car v) (id (cdr v))))
(contract-error (quote id) contracted? val)))]
[_ (assert #f (contract-error (quote id) contracted? val))])))]
[(_ (id0 id ...) : racket-contract? -> rosette-type?)
#'(splicing-let ([contracted? racket-contract?])
(define/lift id0 : contracted? -> rosette-type?)
(define/lift id : contracted? -> rosette-type?) ...)]
[(_ id : contracted? -> rosette-type?)
(identifier? #'contracted?)
#`(define (#,(lift-id #'id) val)
(if (contracted? val)
(id val)
(match (type-cast rosette-type? val (quote id))
[(? contracted? v) (id v)]
[(union vs) (apply merge* (assert-some
(for/list ([v vs] #:when (contracted? (cdr v)))
(cons (car v) (id (cdr v))))
(contract-error (quote id) contracted? val)))]
[_ (assert #f (contract-error (quote id) contracted? val))])))]
[(_ id : racket-contract? -> rosette-type?)
#`(splicing-let ([contracted? racket-contract?])
(define/lift id : contracted? -> rosette-type?))]))
(define-for-syntax (lift-id id)
(format-id id "@~a" (syntax-e id) #:source id #:props id))
(define-syntax-rule (flat-pattern-contract pattern)
(flat-named-contract (quote pattern)
(match-lambda [pattern #t]
[_ #f])))

89
rosette/base/core/merge.rkt
View File

@ -1,89 +0,0 @@
#lang racket
(require (only-in racket/unsafe/ops [unsafe-car car] [unsafe-cdr cdr])
"term.rkt" "union.rkt" "bool.rkt" "reporter.rkt")
(provide merge merge* unsafe-merge* merge-same)
(define (merge b x y)
(match* (b x y)
[(#t _ _) x]
[(#f _ _) y]
[(_ _ (== x eq?)) x]
[(_ _ _) (merge* (cons b x) (cons (! b) y))]))
; Returns a value that joins the provided values
; according to their guards. In particular, this
; procedure assumes that the guards are constrained
; in such a way that *at most one* of them is true
; in any model of the overall problem.
(define (merge* . ps)
(do-merge* #f ps))
; Returns a value that joins the provided values
; according to their guards. In particular, this
; procedure assumes that the guards are constrained
; in such a way that *at most one* of them is true
; in any model of the overall problem. Unlike, merge*
; unsafe-merge* forces merging of mutable values whenever
; possible.
(define (unsafe-merge* . ps)
(do-merge* #t ps))
(define-syntax-rule (do-merge* force? ps)
(let ([simp (simplify ps)])
((current-reporter) 'merge (length simp))
(match (compress force? simp)
[(list (cons g v)) v]
[(list _ (... ...) (cons #t v) _ (... ...)) v]
[vs (apply union vs)])))
(define (guard g gvs)
(for*/list ([gv gvs]
[gg (in-value (&& g (car gv)))]
#:when gg)
(cons gg (cdr gv))))
(define (simplify ps)
(match ps
[(list _ ... (and (cons #t _) p) _ ...)
(list p)]
[_ (for/fold ([out '()]) ([p ps])
(match p
[(cons #f _) out]
[(cons g (union (and (not (? null?)) gvs)))
(append (guard g gvs) out)]
[_ (cons p out)]))]))
(define (type-of-value gv) (type-of (cdr gv)))
(define (compress force? ps)
(match ps
[(list _) ps]
[(list (cons _ (app type-of t)) (cons _ (app type-of t)))
(type-compress t force? (merge-same ps))]
[(list _ _) ps]
[_ (append-map
(lambda (group)
(type-compress
(type-of (cdar group))
force?
(merge-same group)))
(group-by type-of-value ps))]))
(define (merge-same ps)
(match ps
[(or (list) (list _)) ps]
[(list (cons g v) (cons h u))
(if (eq? v u) (list (cons (|| g h) v)) ps)]
[_ (let loop ([ps (group-by cdr ps eq?)] [out '()])
(match ps
[(list) out]
[(list (list gv) rest ...)
(loop rest (cons gv out))]
[(list group rest ...)
(let ([g (apply || (map car group))]
[v (cdar group)])
(if (eq? g #t)
(list (cons g v))
(loop rest (cons (cons g v) out))))]))]))

79
rosette/base/core/numerics.rkt
View File

@ -1,79 +0,0 @@
#lang racket
(require "term.rkt" "polymorphic.rkt"
"real.rkt" "bool.rkt"
"merge.rkt" "safe.rkt")
(provide @number? @positive? @negative? @zero? @even? @odd?
@add1 @sub1 @sgn @truncate @floor @ceiling @min @max
@exact->inexact @inexact->exact @expt
extreme)
(define (@number? v) (or (number? v) (@real? v)))
(define (@positive? x) (@> x 0))
(define (@negative? x) (@< x 0))
(define (@zero? x) (@= x 0))
(define (@even? x) (@zero? (@remainder x 2)))
(define (@odd? x) (! (@even? x)))
(define (@add1 x) (@+ x 1))
(define (@sub1 x) (@- x 1))
(define (@sgn x)
(if (number? x)
(sgn x)
(merge* (cons (@positive? x) 1)
(cons (@negative? x) -1)
(cons (@zero? x) 0))))
(define ($truncate x)
(match x
[(? real?) (truncate x)]
[(term _ (== @integer?)) x]
[(term _ (== @real?))
(let ([xi (@real->integer x)])
(merge (@< x 0) (@+ xi 1) xi))]))
(define @truncate (lift-op $truncate))
(define (@floor x) (@real->integer x))
(define ($ceiling x)
(match x
[(? real?) (ceiling x)]
[(term _ (== @integer?)) x]
[(term _ (== @real?))
(let* ([xi (@real->integer x)])
(merge (@<= x xi) xi (@+ xi 1)))]))
(define @ceiling (lift-op $ceiling))
(define extreme
(case-lambda
[(op x) x]
[(op x y) (merge (op x y) x y)]
[(op x y . z) (apply extreme op (extreme op x y) z)]))
(define @min (lift-op (curry extreme @<=)))
(define @max (lift-op (curry extreme @>=)))
(define (@exact->inexact x)
(if (number? x)
(exact->inexact x)
(numeric-coerce x 'exact->inexact)))
(define (@inexact->exact x)
(if (number? x)
(inexact->exact x)
(numeric-coerce x 'inexact->exact)))
(define (@expt z w)
(match* (z w)
[((? number?) (? number?)) (expt z w)]
[(_ 0)
(assert (@real? z) (arguments-error 'expt "expected a number?" "z" z))
1]
[(_ (? integer?))
(if (positive? w)
(apply @* (make-list w z))
(@/ 1 (@* (make-list (- w) z))))]
[(_ _) (expt z w)]))

189
rosette/base/core/polymorphic.rkt
View File

@ -1,189 +0,0 @@
#lang racket
(require "term.rkt" "union.rkt" "bool.rkt")
(provide
ite ite* ⊢ guarded guarded-test guarded-value =?
generic-merge generic-merge*
T*->T T*->boolean?
sort/expression
simplify*)
; A generic typing procedure for a lifted operator that takes N > 0 arguments of type T
; and returns a value of type T. Specifically, it assumes that at least one value passed
; to it is typed, and it returns the type T of the first given typed value. See term.rkt.
(define T*->T
(case-lambda
[(x) (get-type x)]
[(x y) (or (and (typed? x) (get-type x)) (get-type y))]
[xs (for/first ([x xs] #:when (typed? x)) (get-type x))]))
; Polymorphic operators and procedures that are shared by
; multiple primitive types.
(define-operator =?
#:identifier '=?
#:range T*->boolean?
#:unsafe (lambda (x y)
(match* (x y)
[((not (? term?)) (not (? term?))) (eq? x y)]
[((not (? term?)) (? term?)) (expression =? x y)]
[((? term?) (not (? term?))) (expression =? y x)]
[((? term?) (? term?)) (or (equal? x y)
(if (term<? x y)
(expression =? x y)
(expression =? y x)))])))
; A generic ite operator that takes a boolean condition and
; two values v1 and v2. The values v1 and vn must be of the same
; primitive type T. That is, (type-of v1 v2) = T for some pritimive
; type T. This operator is intended only for internal use and should not
; be called by client code.
(define-operator ite
#:identifier 'ite
#:range (lambda (b t f) (type-of t f))
#:unsafe (lambda (b t f)
(match* (b t f)
[((? boolean?) _ _) (if b t f)]
[(_ _ (== t)) t]
[(_ (expression (== ite) (== b) x _) _) (ite b x f)]
[(_ (expression (== ite) (== (! b)) _ y) _) (ite b y f)]
[(_ _ (expression (== ite) (== b) _ y)) (ite b t y)]
[(_ _ (expression (== ite) (== (! b)) x _)) (ite b t x)]
[(_ _ _) (expression ite b t f)])))
; A generic operator that takes a boolean condition and a value, and it evaluates
; to that value if the condition is true. Otherwise, its output is undefined.
(define (make-guarded g v) (expression ⊢ g v))
(define-operator ⊢
#:identifier '⊢
#:range (lambda (g v) (type-of v))
#:unsafe make-guarded)
(define-match-expander guarded
(lambda (stx)
(syntax-case stx ()
[(_ g-pat v-pat) #'(expression (== ⊢) g-pat v-pat)]))
(syntax-id-rules ()
[(_ g v) (make-guarded g v)]
[_ make-guarded]))
(define (guarded-test gv)
(match gv [(expression (== ⊢) g _) g]))
(define (guarded-value gv)
(match gv [(expression (== ⊢) _ v) v]))
; A generic ite* operator that takes one or more guard-value pairs,
; (g1 . v1) ... (gn . vn), and merges them into a single value
; of the form (ite* (guarded g1 v1) ...(guarded g1 v1)). All guards must be
; symbolic @boolean? terms. All values v1 ... vn must be of the same
; primitive type T. That is, (type-of v1 ... vn) = T for some pritimive
; type T. This operator is intended only for internal use and should not
; be called by client code. The operator simply sorts its arguments by
; guard and wraps the resulting list into an expression with ite* as the
; operator.
(define-operator ite*
#:identifier 'ite*
#:range (lambda gvs (apply type-of gvs))
#:unsafe (lambda gvs
(match gvs
[(list (cons _ a)) a]
[(list (cons a b) (cons (expression (== @!) a) c)) (ite a b c)]
[(list (cons (expression (== @!) a) c) (cons a b)) (ite a b c)]
[(list (app simplify-ite (cons a b)) (app simplify-ite (cons c d)))
(cond [(equal? b d) b]
[(term<? a c) (expression ite* (guarded a b) (guarded c d))]
[else (expression ite* (guarded c d) (guarded a b) )])]
[(list (app simplify-ite (cons a b)) (app simplify-ite cs) ...)
(cond [(for/and ([c cs]) (equal? b (cdr c))) b]
[else (apply
expression
ite*
(sort (cons (guarded a b) (for/list ([c cs]) (guarded (car c) (cdr c))))
term<?
#:key guarded-test))])])))
; A generic eager merging procedure that takes a list of guard-value pairs,
; ps = '((g1 . v1) ... (gn . vn)), and merges them into a single value
; of the form (ite* (guarded g1 v1) ... (guarded g1 v1)). All guards must be
; symbolic @boolean? terms. All values v1 ... vn must be of the same
; type T. That is, (type-of v1 ... vn ∅) = T for some primitive type T.
(define (generic-merge* ps)
(match ps
[(list _) ps]
[(list (cons a _) (cons b _)) (list (cons (|| a b) (apply ite* ps)))]
[(list (cons a _) ...) (list (cons (apply || a) (apply ite* ps)))]))
; A generic eager merging procedure that takes a list of guard-value pairs,
; ps = '((g1 . v1) ... (gn . vn)), and merges them into a single value
; of the form (⊕ (ite g1 v1 ∅) ... (ite gn vn ∅)). All guards must be
; symbolic @boolean? terms. All values v1 ... vn must be of the same
; type T, which is also the type of the empty value ∅. That is,
; (type-of v1 ... vn ∅) = T. The procedure ⊕ must be an op? with the
; signature (op/-> (#:rest T) T).
(define (generic-merge ⊕ ∅ ps)
(match ps
[(list _) ps]
[(list (cons g a) (cons (expression (== @!) g) b)) (list (cons #t (ite g a b)))]
[(list (cons (expression (== @!) g) b) (cons g a)) (list (cons #t (ite g a b)))]
[(or (list (cons (expression (== @&&) g h) x) (cons (expression (== @&&) g f) y))
(list (cons (expression (== @&&) g h) x) (cons (expression (== @&&) f g) y))
(list (cons (expression (== @&&) h g) x) (cons (expression (== @&&) g f) y))
(list (cons (expression (== @&&) h g) x) (cons (expression (== @&&) f g) y)))
(list (cons g (match* (h f)
[(_ (expression (== @!) h)) (ite h x y)]
[((expression (== @!) f) _) (ite f y x)]
[(_ _) (⊕ (ite h x ∅) (ite f y ∅))])))]
[(list (app simplify-ite (cons g x)) (app simplify-ite (cons h y)))
(list (cons (|| g h) (if (equal? x y) x (⊕ (ite g x ∅) (ite h y ∅)))))]
[(list (app simplify-ite (cons a x)) (app simplify-ite (cons b y)) ...)
(list (cons (apply || a b)
(if (for/and ([z y]) (equal? x z))
x
(apply ⊕ (ite a x ∅) (map (curryr ite ∅) b y)))))]))
(define (simplify-ite p)
(match* ((car p) (cdr p))
[(a (expression (== ite) a x _)) (cons a x)]
[(a (expression (== ite) (expression (== @!) a) _ x)) (cons a x)]
[((and (expression (== @!) a) !a) (expression (== ite) a _ x)) (cons !a x)]
[(_ _) p]))
; Sorts the arguments to the given binary operator and returns the resulting expression.
(define (sort/expression @op x y)
(cond [(not (term? x)) (expression @op x y)]
[(not (term? y)) (expression @op y x)]
[(term<? x y) (expression @op x y)]
[else (expression @op y x)]))
; Applies the given simplification function to the given list until
; no more simplifications can be made. The simplification function should
; take as input 2 values and return either #f (if no simplification is possible)
; or the simplified result of applying f to those values. The optional limit
; value determines when the list is too big for simplification---in which case,
; simplify* acts as the identity function on xs. The limit is 100 by default.
(define (simplify* xs f [limit 100])
(if (> (length xs) limit)
xs
(let ([out (let outer ([xs xs])
(match xs
[(list x rest ..1)
(let inner ([head rest] [tail '()])
(match head
[(list) (cons x (outer tail))]
[(list y ys ...)
(match (f x y)
[#f (inner ys (cons y tail))]
[v (outer (cons v (append ys tail)))])]))]
[_ xs]))])
(if (= (length out) (length xs)) out (simplify* out f)))))

93
rosette/base/core/procedure.rkt
View File

@ -1,93 +0,0 @@
#lang racket
(require
racket/provide
(for-syntax racket/syntax (only-in "lift.rkt" with@))
(only-in "type.rkt" define-lifted-type type-cast typed? get-type subtype? type-applicable? @any/c)
(only-in "bool.rkt" || @false?)
(only-in "union.rkt" union union? in-union-guards union-filter union-guards)
(only-in "safe.rkt" assert argument-error)
(only-in "forall.rkt" guard-apply))
(provide (filtered-out with@ (all-defined-out)))
(define-lifted-type @procedure?
#:base procedure?
#:is-a? (match-lambda [(and (? typed?) (app get-type t) v)
(or (subtype? t @procedure?)
(and (union? v)
(subtype? @procedure? t)
(apply || (for/list ([g (in-union-guards v @procedure?)]) g))))]
[(? procedure?) #t]
[_ #f])
#:methods
[(define (least-common-supertype self other)
(if (or (equal? other @procedure?) (type-applicable? other))
@procedure?
@any/c))
(define (type-applicable? self) #t)
(define (type-eq? self v0 v1) (eq? v0 v1))
(define (type-cast self v [caller 'type-cast])
(match v
[(union _ (== @procedure?)) v]
[(union _ (? (curryr subtype? @procedure?))) v]
[(union vs (? (curry subtype? @procedure?)))
(match (union-filter v @procedure?)
[(union (list (cons g u)))
(assert g (argument-error caller "procedure?" v))
u]
[r
(assert (apply || (union-guards r)) (argument-error caller "procedure?" v))
r])]
[(? procedure?) v]
[_ (assert #f (argument-error caller "procedure?" v))]))
(define (type-compress self force? ps)
(if force? (procedure/unsafe-compress ps) ps))])
(define (accepts-keywords? guarded-proc)
(let-values ([(required accepted) (procedure-keywords (cdr guarded-proc))])
(not (null? accepted))))
(define (common-arity guarded-procs)
(let ([arity (procedure-arity (cdr (car guarded-procs)))])
(and (integer? arity)
(for/and ([p (cdr guarded-procs)])
(equal? arity (procedure-arity (cdr p))))
arity)))
(define (procedure/unsafe-compress ps)
(define good (apply || (map car ps)))
(cond [(ormap accepts-keywords? ps)
(make-keyword-procedure
(lambda (kws kw-args . rest)
(assert good)
(guard-apply (lambda (p) (keyword-apply p kws kw-args rest)) ps)))]
[else
(case (common-arity ps)
[(0) (lambda () (assert good) (guard-apply (lambda (p) (p)) ps))]
[(1) (lambda (x) (assert good) (guard-apply (lambda (p) (p x)) ps))]
[(2) (lambda (x y) (assert good) (guard-apply (lambda (p) (p x y)) ps))]
[(3) (lambda (x y z) (assert good) (guard-apply (lambda (p) (p x y z)) ps))]
[else (lambda xs (assert good) (guard-apply (lambda (p) (apply p xs)) ps))])]))
(define (@procedure-rename proc name)
(match proc
[(union gvs) (guard-apply (curryr procedure-rename name) gvs)]
[(? procedure?) (procedure-rename proc name)]))
(define (@negate p)
(define f (type-cast @procedure? p 'negate))
(let-values ([(arity) (procedure-arity f)] [(_ kwds) (procedure-keywords f)])
(case (and (null? kwds) arity) ; optimize some simple cases
[(0) (lambda () (@false? (f)))]
[(1) (lambda (x) (@false? (f x)))]
[(2) (lambda (x y) (@false? (f x y)))]
[else (compose1 @false? f)])))
(define (@void? v)
(match v
[(? void?) #t]
[(union vs) (apply || (for/list ([gv vs] #:when (void? (cdr gv))) (car gv)))]
[_ #f]))

505
rosette/base/core/real.rkt
View File

@ -1,505 +0,0 @@
#lang racket
(require (for-syntax racket/syntax) racket/stxparam racket/stxparam-exptime)
(require "term.rkt" "union.rkt" "bool.rkt" "polymorphic.rkt"
"merge.rkt" "safe.rkt" "lift.rkt" "forall.rkt")
(provide @integer? @real? @= @< @<= @>= @> @+ @* @- @/ @quotient @remainder @modulo @abs
@integer->real @real->integer @int?
lift-op numeric-coerce T*->integer? T*->real?)
;; ----------------- Integer and Real Types ----------------- ;;
(define (int? v)
(match v
[(? integer?) #t]
[(term _ (== @integer?)) #t]
[(term _ (== @real?)) (expression @int? v)]
[(union xs (or (== @real?) (== @any/c)))
(let-values ([(i r) (guarded-numbers xs)])
(match* (i r)
[((cons g _) #f) g]
[(#f (cons g x)) (&& g (int? x))]
[((cons gi _) (cons gr xr)) (|| gi (&& gr (int? xr)))]
[(_ _) #f]))]
[_ #f]))
(define-lifted-type @real?
#:base real?
#:is-a? (instance-of? real? @real?)
#:methods
[(define (least-common-supertype self t)
(if (or (equal? self t) (equal? @integer? t)) self @any/c))
(define (solvable-default self) 0)
(define (type-eq? self u v) ($= u v))
(define (type-equal? self u v) ($= u v))
(define (type-cast self v [caller 'type-cast])
(match v
[(? real?) v]
[(term _ (== self)) v]
[(term _ (== @integer?)) (integer->real v)]
[(union xs (or (== @real?) (== @any/c)))
(let-values ([(i r) (guarded-numbers xs)])
(match* (i r)
[((cons g x) #f)
(assert g (numeric-type-error caller @real? v))
(integer->real x)]
[(#f (cons g x))
(assert g (numeric-type-error caller @real? v))
x]
[((cons gi xi) (cons gr _))
(unless (= (length xs) 2)
(assert (|| gi gr) (numeric-type-error caller @real? v)))
(ite* (cons gi (integer->real xi)) r)]
[(_ _)
(assert #f (numeric-type-error caller @real? v))]))]
[_ (assert #f (numeric-type-error caller @real? v))]))
(define (type-compress self force? ps) (generic-merge* ps))])
(define-lifted-type @integer?
#:base integer?
#:is-a? int?
#:methods
[(define (least-common-supertype self t)
(if (or (equal? self t) (equal? @real? t)) t @any/c))
(define (solvable-default self) 0)
(define (type-eq? self u v) ($= u v))
(define (type-equal? self u v) ($= u v))
(define (type-cast self v [caller 'type-cast])
(match v
[(? integer?) v]
[(term _ (== self)) v]
[(term _ (== @real?))
(assert (int? v) (numeric-type-error caller @integer? v))
(real->integer v)]
[(union xs (or (== @real?) (== @any/c)))
(let-values ([(i r) (guarded-numbers xs)])
(match* (i r)
[((cons g x) #f)
(assert g (numeric-type-error caller @integer? v))
x]
[(#f (cons g x))
(assert (&& g (int? x)) (numeric-type-error caller @integer? v))
(real->integer x)]
[((cons gi xi) (cons gr xr))
(let ([gr (&& (int? xr) gr)])
(assert (|| gi gr) (numeric-type-error caller @integer? v))
(merge* i (cons gr (real->integer xr))))]
[(_ _) (assert #f (numeric-type-error caller @integer? v))]))]
[_ (assert #f (numeric-type-error caller @integer? v))]))
(define (type-compress self force? ps) (generic-merge* ps))])
;; ----------------- Lifting Utilities ----------------- ;;
(define (guarded-numbers xs)
(for/fold ([i #f][r #f]) ([gx xs])
(match (cdr gx)
[(or (? integer?) (term _ (== @integer?))) (values gx r)]
[(or (? real?) (term _ (== @real?))) (values i gx)]
[_ (values i r)])))
(define-match-expander ≈
(lambda (stx)
(syntax-case stx ()
[(_ v) #`(or v #,(exact->inexact (syntax->datum #'v)))])))
(define (numeric-coerce v [caller 'numeric-coerce])
(match v
[(? real?) v]
[(term _ (or (== @integer?) (== @real?))) v]
[(union xs (or (== @real?) (== @any/c)))
(let-values ([(i r) (guarded-numbers xs)])
(match* (i r)
[((cons g x) #f)
(assert g (numeric-type-error caller @real? v))
x]
[(#f (cons g x))
(assert g (numeric-type-error caller @real? v))
x]
[((cons gi _) (cons gr _))
(cond [(= (length xs) 2) v]
[else (assert (|| gi gr) (numeric-type-error caller @real? v))
(merge* i r)])]
[(_ _) (assert #f (numeric-type-error caller @real? v))]))]
[_ (assert #f (numeric-type-error caller @real? v))]))
(define (numeric-type-error name t . args)
(arguments-error name (format "expected ~a arguments" t) "arguments" args))
(define (safe-apply-1 op x)
(match (numeric-coerce x (object-name op))
[(union (list (cons ga a) (cons gb b)))
(merge* (cons ga (op a)) (cons gb (op b)))]
[a (op a)]))
(define (int-primitive? v)
(or (integer? v) (and (term? v) (equal? (get-type v) @integer?))))
(define (real-primitive? v)
(or (real? v) (and (term? v) (equal? (get-type v) @real?))))
(define (safe-apply-2 op x y)
(define caller (object-name op))
(define a (numeric-coerce x caller))
(define b (numeric-coerce y caller))
(match* (a b)
[((? int-primitive?)(? int-primitive?)) (op a b)]
[((? real-primitive?)(? real-primitive?)) (op a b)]
[(_ _) (op (type-cast @real? a caller) (type-cast @real? b caller))]))
(define (safe-apply-n op xs)
(define caller (object-name op))
(define ys (for/list ([x xs]) (numeric-coerce x caller)))
(match ys
[(or (list (? int-primitive?) ...) (list (? real-primitive?) ...)) (apply op ys)]
[_ (apply op (for/list ([y ys]) (type-cast @real? y caller)))]))
(define (lift-op op)
(case (procedure-arity op)
[(1) (lambda (x) (safe-apply-1 op x))]
[(2) (lambda (x y) (safe-apply-2 op x y))]
[else (case-lambda [() (op)]
[(x) (safe-apply-1 op x)]
[(x y) (safe-apply-2 op x y)]
[xs (safe-apply-n op xs)])]))
(define-syntax-rule (define-lifted-operator @op $op type)
(define-operator @op
#:identifier (string->symbol (substring (symbol->string '@op) 1))
#:range type
#:unsafe $op
#:safe (lift-op $op)))
;; ----------------- Predicates ----------------- ;;
(define-operator @int?
#:identifier 'int?
#:range T*->boolean?
#:unsafe int?
#:safe int?)
(define $= (compare @= $= = sort/expression #t))
(define $<= (compare @<= $<= <= expression #t))
(define $< (compare @< $< < expression #f))
(define $>= (case-lambda [(x y) ($<= y x)] [xs (apply $<= (reverse xs))]))
(define $> (case-lambda [(x y) ($< y x)] [xs (apply $< (reverse xs))]))
(define-syntax-rule (compare @op $op op expr same=true?)
(case-lambda
[(x y)
(match* (x y)
[((? real?) (? real?)) (op x y)]
[(_ (== x)) same=true?]
[((expression (== ite) a (? real? b) (? real? c)) (? real? d)) (merge a (op b d) (op c d))]
[((? real? d) (expression (== ite) a (? real? b) (? real? c))) (merge a (op d b) (op d c))]
[((expression (== ite) a (? real? b) (? real? c))
(expression (== ite) d (? real? e) (? real? f)))
(let ([b~e (op b e)]
[b~f (op b f)]
[c~e (op c e)]
[c~f (op c f)])
(or (and b~e b~f c~e c~f)
(|| (&& a d b~e) (&& a (! d) b~f) (&& (! a) d c~e) (&& (! a) (! d) c~f))))]
[(a (expression (== @+) (? real? r) a)) (op 0 r)]
[((expression (== @+) (? real? r) a) a) (op r 0)]
[(_ _) (expr @op x y)])]
[(x y . zs)
(apply && ($op x y) (for/list ([a (in-sequences (in-value y) zs)][b zs]) ($op a b)))]))
(define-lifted-operator @= $= T*->boolean?)
(define-lifted-operator @<= $<= T*->boolean?)
(define-lifted-operator @>= $>= T*->boolean?)
(define-lifted-operator @< $< T*->boolean?)
(define-lifted-operator @> $> T*->boolean?)
;; ----------------- Int and Real Operators ----------------- ;;
(define $+
(case-lambda
[() 0]
[(x) x]
[(x y) (or (simplify-+ x y) (sort/expression @+ x y))]
[xs
(let*-values ([(lits terms) (partition real? xs)]
[(lit) (apply + lits)])
(if (null? terms)
lit
(match (simplify* (if (= 0 lit) terms (cons lit terms)) simplify-+)
[(list y) y]
[(list a ... (? real? b) c ...) (apply expression @+ b (sort (append a c) term<?))]
[ys (apply expression @+ (sort ys term<?))])))]))
(define $*
(case-lambda
[() 1]
[(x) x]
[(x y) (or (simplify-* x y) (sort/expression @* x y))]
[xs
(let*-values ([(lits terms) (partition real? xs)]
[(lit) (apply * lits)])
(if (or (zero? lit) (null? terms))
lit
(match (simplify* (if (= 1 lit) terms (cons lit terms)) simplify-*)
[(list y) y]
[(list a ... (? real? b) c ...) (apply expression @* b (sort (append a c) term<?))]
[ys (apply expression @* (sort ys term<?))])))]))
(define $-
(case-lambda
[(x) (match x
[(? real?) (- x)]
[(expression (== @-) a) a]
[(expression (== @*) (? real? c) a) ($* (- c) a)]
[_ (expression @- x)])]
[(x y) ($+ x ($- y))]
[(x . xs) (apply $+ x (map $- xs))]))
(define ($abs x)
(match x
[(? real?) (abs x)]
[(expression (== @abs) _) x]
[_ (expression @abs x)]))
(define-lifted-operator @+ $+ T*->T)
(define-lifted-operator @* $* T*->T)
(define-lifted-operator @- $- T*->T)
(define-lifted-operator @abs $abs T*->T)
;; ----------------- Int Operators ----------------- ;;
(define $quotient (div @quotient $quotient quotient))
(define-syntax-rule (define-remainder $op op @op)
(define ($op x y)
(match* (x y)
[((? integer?) (? integer?)) (op x y)]
[(_ (≈ 1)) 0]
[(_ (≈ -1)) 0]
[((≈ 0) _) 0]
[(_ (== x)) 0]
[(_ (expression (== @-) (== x))) 0]
[((expression (== @-) (== y)) _) 0]
[((expression (== @*) _ (... ...) (== y) _ (... ...)) _) 0]
[((expression (== ite) a (? real? b) (? real? c)) (? real?))
(merge a (op b y) (op c y))]
[((? real?) (expression (== ite) a
(and b (? real?) (not (? zero?)))
(and c (? real?) (not (? zero?)))))
(merge a (op x b) (op x c))]
[(_ _) (expression @op x y)])))
(define-remainder $remainder remainder @remainder)
(define-remainder $modulo modulo @modulo)
(define T*->integer? (const @integer?))
(define (undefined-for-zero-error name)
(arguments-error name "undefined for 0"))
(define-syntax-rule (define-lifted-int-operator @op $op op)
(define-operator @op
#:identifier 'op
#:range T*->integer?
#:unsafe $op
#:safe (lambda (x y)
(let ([a (type-cast @integer? x 'op)]
[b (type-cast @integer? y 'op)])
(assert (! ($= b 0)) (undefined-for-zero-error 'op))
($op a b)))))
(define-lifted-int-operator @quotient $quotient quotient)
(define-lifted-int-operator @remainder $remainder remainder)
(define-lifted-int-operator @modulo $modulo modulo)
;; ----------------- Real Operators ----------------- ;;
(define $/ (div @/ $/ /))
(define T*->real? (const @real?))
(define-operator @/
#:identifier '/
#:range T*->real?
#:unsafe $/
#:safe (case-lambda
[(x) (@/ 1 x)]
[(x y) (let ([a (type-cast @real? x '/)]
[b (type-cast @real? y '/)])
(assert (! ($= 0 b)) (undefined-for-zero-error '/))
($/ a b))]
[(x . ys) (let ([z (type-cast @real? x '/)]
[zs (for/list ([y ys]) (type-cast @real? y '/))])
(for ([z zs])
(assert (! ($= z 0)) (undefined-for-zero-error '/)))
($/ x (apply $* zs)))]))
;; ----------------- Coercion Operators ----------------- ;;
(define (integer->real i)
(match i
[(? integer?) i]
[(? term?) (expression @integer->real i)]))
(define (real->integer r)
(match r
[(? real?) (floor r)]
[(expression (== @integer->real) x) x]
[(expression (== ite) a
(expression (== @integer->real) x)
(expression (== @integer->real) y)) (ite a x y)]
[(expression (== ite) a (expression (== @integer->real) x) y) (ite a x (real->integer y))]
[(expression (== ite) a x (expression (== @integer->real) y)) (ite a (real->integer x) y)]
[(? term?) (expression @real->integer r)]))
(define-operator @integer->real
#:identifier 'integer->real
#:range T*->real?
#:unsafe integer->real
#:safe (lambda (n) (integer->real (type-cast @integer? n 'integer->real))))
(define-operator @real->integer
#:identifier 'real->integer
#:range T*->integer?
#:unsafe real->integer
#:safe (lambda (n) (real->integer (type-cast @real? n 'real->integer))))
;; ----------------- Simplification rules for operators ----------------- ;;
(define (simplify-+ x y)
(match* (x y)
[((? real?) (? real?)) (+ x y)]
[(_ (≈ 0)) x]
[((≈ 0) _) y]
[((? expression?) (? expression?))
(or (simplify-+:expr/term x y) (simplify-+:expr/term y x))]
[((? expression?) _) (simplify-+:expr/term x y)]
[(_ (? expression?)) (simplify-+:expr/term y x)]
[(_ _) #f]))
(define (simplify-+:expr/term x y)
(match* (x y)
[((expression (== @-) (== y)) _) 0]
[((expression (== @-) (expression (== @+) (== y) z)) _) ($- z)]
[((expression (== @-) (expression (== @+) z (== y))) _) ($- z)]
[((expression (== @+) (expression (== @-) (== y)) z) _) z]
[((expression (== @+) z (expression (== @-) (== y))) _) z]
[((expression (== @+) (? real? a) b) (? real?)) ($+ (+ a y) b)]
[((expression (== ite) a (? real? b) (? real? c)) (? real?)) (ite a (+ b y) (+ c y))]
[((expression (== @*) (? real? a) (== y)) _) ($* (+ a 1) y)]
[((expression (== @*) (? real? a) b) (expression (== @*) (? real? c) b)) ($* (+ a c) b)]
[((expression (== @+) a b) (expression (== @-) a)) b]
[((expression (== @+) a b) (expression (== @-) b)) a]
[((expression (== @+) as ...) (expression (== @+) bs ...))
(let ([alen (length as)]
[blen (length bs)])
(and (<= alen blen) (<= (- blen alen) 1)
(match (cancel+ as bs)
[(list) 0]
[(list b) b]
[#f #f])))]
[(_ _) #f]))
(define (cancel+ xs ys)
(and ys
(match xs
[(list) ys]
[(list x rest ...)
(cancel+ rest
(match* (x ys)
[((? real?) (list (? real? a) b ...)) (and (zero? (+ x a)) b)]
[((? term?) (list a ... (expression (== @-) (== x)) b ...)) (append a b)]
[((expression (== @-) y) (list a ... y b ...)) (append a b)]
[((expression (== @*) (? real? a) b)
(list c ... (expression (== @*) (and (? real?) (app - a)) b) d ...))
(append c d)]
[(_ _) #f]))])))
(define (simplify-* x y)
(match* (x y)
[((? real?) (? real?)) (* x y)]
[((≈ 0) _) 0]
[((≈ 1) _) y]
[((≈ -1) _) ($- y)]
[(_ (≈ 0)) 0]
[(_ (≈ 1)) x]
[(_ (≈ -1)) ($- x)]
[((? expression?) (? expression?))
(or (simplify-*:expr/term x y) (simplify-*:expr/term y x))]
[((? expression?) _) (simplify-*:expr/term x y)]
[(_ (? expression?)) (simplify-*:expr/term y x)]
[(_ _) #f]))
(define (simplify-*:expr/term x y)
(match* (x y)
[((expression (== @/) a (== y)) _) a]
[((expression (== @/) a (expression (== @*) (== y) z)) _) ($/ a z)]
[((expression (== @/) a (expression (== @*) z (== y))) _) ($/ a z)]
[((expression (== @/) (? real? a) b) (? real?)) ($/ (* a y) b)]
[((expression (== @*) (expression (== @/) a (== y)) z) _) ($* a z)]
[((expression (== @*) z (expression (== @/) a (== y))) _) ($* a z)]
[((expression (== @*) (? real? a) b) (? real?)) ($* (* a y) b)]
[((expression (== ite) a (? real? b) (? real? c)) (? real?)) (ite a (* b y) (* c y))]
[((expression (== @*) a b) (expression (== @/) c a)) ($* b c)]
[((expression (== @*) a b) (expression (== @/) c b)) ($* a c)]
[((expression (== @*) as ...) (expression (== @*) bs ...))
(let ([alen (length as)]
[blen (length bs)])
(and (<= alen blen) (<= (- blen alen) 1)
(match (cancel* as bs)
[(list) 1]
[(list b) b]
[#f #f])))]
[(_ _) #f]))
(define (cancel* xs ys) ;(printf "cancel* ~a ~a\n" xs ys)
(and ys
(match xs
[(list) ys]
[(list x rest ...)
(cancel* rest
; Pattern matching broken in 6.1 when the first rule is in the third position.
; TODO: place the first rule in 3rd position and test with 6.2.
(match* (x ys)
[((expression (== @/) (≈ 1) c) (list a ... c b ...))
(append a b)]
[((? term?) (list a ... (expression (== @/) 1 (== x)) b ...)) (append a b)]
[((? real?) (list (? real? a) b ...)) (and (= 1 (* x a)) b)]
[(_ _) #f]))])))
(define-syntax-rule (div @op $op op)
(lambda (x y)
(match* (x y)
[((? real?) (? real?)) (op x y)]
[((≈ 0) _) 0]
[(_ (≈ 1)) x]
[(_ (≈ -1)) ($- x)]
[(_ (== x)) 1]
[(_ (expression (== @-) (== x))) -1]
[((expression (== @-) (== y)) _) -1]
[((expression (== ite) a (? real? b) (? real? c)) (? real?))
(merge a (op b y) (op c y))]
[((? real?) (expression (== ite) a
(and b (? real?) (not (? zero?)))
(and c (? real?) (not (? zero?)))))
(merge a (op x b) (op x c))]
[((expression (== @op) a (? real? b)) (? real?)) ($op a (* b y))]
[((expression (== @*) a (... ...) (== y) b (... ...)) _) (apply $* (append a b))]
[((expression (== @*) as (... ...)) (expression (== @*) bs (... ...)))
(or (and (<= (length bs) (length as))
(let ([cs (cancel-div bs as)])
(and cs (apply $* cs))))
(expression @op x y))]
[(_ _) (expression @op x y)])))
(define (cancel-div xs ys)
(and ys
(match xs
[(list) ys]
[(list x rest ...)
(cancel-div rest
(match* (x ys)
[((? real?) (list (== x) b ...)) b]
[(_ (list a ... (== x) b ...)) (append a b)]
[(_ _) #f]))])))

84
rosette/base/core/reflect.rkt
View File

@ -1,84 +0,0 @@
#lang racket
(require (only-in "forall.rkt" for/all for*/all)
"term.rkt" "union.rkt" "result.rkt")
(provide type? solvable? @any/c type-of type-cast for/all for*/all
term? constant? expression?
term expression constant
term-type term=? term->datum
terms terms-count terms-ref with-terms clear-terms! gc-terms!
union? union union-contents union-guards union-values
union-filter in-union in-union* in-union-guards in-union-values
(struct-out normal) (struct-out failed) result? result-value result-state
symbolics concrete? symbolic?)
(define (term=? s0 s1)
(and (term? s0) (term? s1) (equal? s0 s1)))
(define (symbolics vs)
(match vs
[(list (? constant?) ...) (remove-duplicates vs)]
[(? constant?) (list vs)]
[_ (let ([terms (mutable-set)]
[objs (mutable-set)]
[result '()])
(let loop ([datum vs])
(if (term? datum)
(let ([id (term-id datum)])
(unless (set-member? terms id)
(set-add! terms id)
(match datum
[(expression _ x ...) (for-each loop x)]
[(? constant?) (set! result (cons datum result))])))
(unless (set-member? objs datum)
(set-add! objs datum)
(match datum
[(union (list (cons guard value) ...))
(for-each loop guard) (for-each loop value)]
[(box v) (loop v)]
[(? list?) (for-each loop datum)]
[(cons x y) (loop x) (loop y)]
[(vector v ...) (for-each loop v)]
[(and (? typed?) (app get-type t))
(match (type-deconstruct t datum)
[(list (== datum)) (void)]
[components (for-each loop components)])]
[_ (void)]))))
(reverse result))]))
(define (concrete? val)
(define objs (mutable-set))
(let all-concrete? ([val val])
(and (not (term? val))
(not (union? val))
(or
(set-member? objs val)
(begin
(set-add! objs val)
(match val
[(box v) (all-concrete? v)]
[(? list?) (for/and ([v val]) (all-concrete? v))]
[(cons x y) (and (all-concrete? x) (all-concrete? y))]
[(? vector?) (for/and ([v val]) (all-concrete? v))]
[(and (? typed?) (app get-type t))
(match (type-deconstruct t val)
[(list (== val)) #t]
[components (for/and ([v components]) (all-concrete? v))])]
[_ #t]))))))
(define (symbolic? val) (not (concrete? val)))
(define (term->datum val)
(let convert ([val val] [cache (make-hash)])
(if (hash-has-key? cache val)
(hash-ref cache val)
(let ([datum
(match val
[(? constant?) (string->symbol (format "~a" val))]
[(expression op child ...) `(,(string->symbol (~s op))
,@(for/list ([e child]) (convert e cache)))]
[_ val])])
(hash-set! cache val datum)
datum))))

14
rosette/base/core/reporter.rkt
View File

@ -1,14 +0,0 @@
#lang racket
(provide (all-defined-out))
; The reporter is called when "interesting"
; events happen during symbolic execution; for example,
; when a merge occurs or a new term is created.
(define current-reporter
(make-parameter
void
(lambda (new-reporter)
(unless (procedure? new-reporter)
(raise-argument-error 'current-reporder "procedure?" new-reporter))
new-reporter)))

17
rosette/base/core/result.rkt
View File

@ -1,17 +0,0 @@
#lang racket
(provide (struct-out normal) (struct-out failed)
result? result-value result-state)
; Represents the result of symbolic evaluation,
; which includes an output value and a representation
; of some aspect of the symbolic state.
(struct result (value state) #:transparent)
; Represents the result of a normally terminated evaluation.
(struct normal result () #:transparent)
; Represents the result of an evaluation that resulted in
; an exn:fail? exception being raised. In this case,
; the result-value field stores the exception that was raised.
(struct failed result () #:transparent)

61
rosette/base/core/safe.rkt
View File

@ -1,61 +0,0 @@
#lang racket
(require "bool.rkt" "exn.rkt")
(provide argument-error arguments-error type-error contract-error index-too-large-error
assert assert-some assert-|| assert-bound assert-arity-includes)
(define-syntax (assert stx)
(syntax-case stx ()
[(_ expr) (syntax/loc stx ($assert expr #f))]
[(_ expr msg) (syntax/loc stx ($assert expr msg))]))
(define-syntax assert-some
(syntax-rules ()
[(_ expr #:unless size msg)
(let* ([val expr])
(unless (= size (length val))
(assert (apply || (map car val)) msg))
val)]
[(_ expr #:unless size)
(assert-some expr #:unless size #f)]
[(_ expr msg)
(let* ([val expr])
(assert (apply || (map car val)) msg)
val)]
[(_ expr)
(assert-some expr #f)]))
(define-syntax assert-||
(syntax-rules ()
[(_ expr #:unless size msg)
(let ([val expr])
(unless (= size (length val))
(assert (apply || val) msg)))]
[(_ expr #:unless size) (assert-|| expr #:unless size #f)]))
(define-syntax assert-bound
(syntax-rules ()
[(_ [limit cmp expr] name)
(let ([low limit]
[high expr])
(assert (cmp low high)
(argument-error name (format "~.a ~.a ~.a" low cmp (syntax-e #'expr)) low)))]
[(_ [lowLimit cmpLow expr cmpHigh highLimit] name)
(let ([low lowLimit]
[val expr]
[high highLimit])
(assert (cmpLow low val)
(argument-error name (format "~.a ~.a ~.a" low cmpLow (syntax-e #'expr)) val))
(assert (cmpHigh val high)
(argument-error name (format "~.a ~.a ~.a" (syntax-e #'expr) cmpHigh high) val)))]))
(define-syntax (assert-arity-includes stx)
(syntax-case stx ()
[(_ f val name) (syntax/loc stx
(assert (and (procedure? f) (procedure-arity-includes? f val))
(argument-error name
(format "procedure arity includes ~a" val)
f)))]))

181
rosette/base/core/store.rkt
View File

@ -1,181 +0,0 @@
#lang racket
(require "result.rkt" "merge.rkt")
(provide with-store store! merge-stores!
location? location-base location-offset
location-ref location-set!)
; The current-store parameter contains a store that
; maps (abstract) memory locations to values. Each mapped
; location identifies a storage cell that has been the mutated
; via a store! call in the dynamic extent of a call to
; with-store. The store maps each such location to the value
; that was stored at that location before the current call
; to with-store.
(define current-store (make-parameter #f))
; A store maps abstract memory locations to their initial values.
; An abstract memory location identifies a storage cell that holds
; a single value; locations consist of a base object (e.g., a vector)
; and an offset value (e.g., the index 0) that identifies a
; storage cell within that object.
;
; A store uses a refs set, as returned by make-refs, to keep track
; of the locations that have been mutated via store! calls.
; The initial value of each mutated location is held in the store's
; vals list. This list maps locations to the values they held prior
; to the current call to with-store.
(struct store (refs [vals #:mutable]) #:transparent)
; Returns an empty store.
(define (make-store) (store (make-refs) (list)))
; Returns an empty set of base/offset pairs.
(define (make-refs) (make-hasheq))
; Adds the given base/offset pair to rs if not
; already present. Returns #t if rs changed as
; a result of this operation; otherwise returns #f.
(define (refs-add! rs base offset)
(define bits (hash-ref rs base 0))
(and (not (bitwise-bit-set? bits offset))
(hash-set! rs base (bitwise-ior bits (arithmetic-shift 1 offset)))
#t))
; Extends the store s with a mapping from the location
; (loc base offset getter setter) to its current value,
; unless s already contains a mapping for this location.
(define (store-add! s base offset getter setter)
(when (refs-add! (store-refs s) base offset)
(let ([l (location base offset getter setter)]
[vals (store-vals s)])
(set-store-vals! s (cons (cons l (location-ref l)) vals)))))
; Performs the mutation to the storage
; cell at the location (loc base offset getter setter),
; and if this cell has not been mutated before, its
; initial value is added to current-store.
; The getter and setter procedures should read / write
; the cell's value when applied to its base and offset.
(define (store! base offset val getter setter)
(let ([s (current-store)])
(when s
(store-add! s base offset getter setter)))
;(printf "store! ~a ~a ~a ~a ~a, ~a\n" base offset val getter setter (current-store))
(setter base offset val))
; Returns true if the store s is empty.
(define (store-empty? s)
(zero? (length (store-vals s))))
; Represents the location of a single mutable storage cell.
; A cell location consists of a base object (e.g., a vector)
; and an offset value (e.g., 0) that identifies a
; storage cell within that object. Locations
; also include getter and setter procedures that can be
; used to read from and write to the referenced cell.
; Two locations are equal? iff their base and offset
; are both eq? to one another.
(struct location (base offset accessor mutator)
#:transparent
#:methods gen:equal+hash
[(define (equal-proc l1 l2 rec-equal?)
(and (eq? (location-base l1) (location-base l2))
(eq? (location-offset l1) (location-offset l2))))
(define (hash-proc l rec-equal-hash)
(equal-hash-code (cons (eq-hash-code (location-base l)) (eq-hash-code (location-offset l)))))
(define (hash2-proc l rec-equal-hash2)
(equal-secondary-hash-code (cons (eq-hash-code (location-base l)) (eq-hash-code (location-offset l)))))])
; Returns the current value stored at the location l.
(define (location-ref l)
((location-accessor l) (location-base l) (location-offset l)))
; Stores the value v at the location l.
(define (location-set! l v)
(store! (location-base l) (location-offset l) v (location-accessor l) (location-mutator l)))
; Rollbacks the contents of all mutated storage cells to their initial
; values, as given in (current-store), and raises the exception e.
; The current-store is assumed to contain the values that
; mutated cells held before the current call to with-store.
; This procedure can be called only in the dynamic extent of a
; with-store call.
(define (rollback-exn! e)
;(printf "exn: ~a\n" e)
(for ([lv (store-vals (current-store))])
(match-define (cons (location base offset _ setter) init) lv)
(setter base offset init))
(raise e))
; Rollbacks the contents of all mutated storage cells to their initial
; values, as given in (current-store), and returns a list of pairs
; that maps a reference to each mutated cell to its current value.
; The current-store is assumed to contain the values that
; mutated cells held before the current call to with-store.
; This procedure can be called only in the dynamic extent of a
; with-store call.
(define (rollback-capture!)
;(printf "capture: ~a\n" (store-vals (current-store)))
(for/list ([lv (store-vals (current-store))])
(match-define (cons (location base offset getter setter) init) lv)
(define fin (getter base offset))
(setter base offset init)
(cons (car lv) fin)))
; The with-store form takes as input an expression, evaluates it,
; and reverts each mutated memory location to its pre-state
; (i.e., the value it held before the call to with-store).
;
; If the evaluation of the body terminates normally, (with-store body)
; outputs a result (normal v s) where v is the value computed by the body,
; and s is an association list that maps each mutated location? to its
; post-state (i.e., the value it held after the evaluation of the body).
; In essence, evaluating the body in the current environment has the
; same effect on memory as evaluating (with-store body) and then setting
; the returned memory locations to their post-state value.
;
; If the evaluation of the body terminates abnormally with an exn:fail?
; exception, with-store reverts all mutated locations to their pre-state
; and re-raises the same exception.
(define-syntax-rule (with-store body)
(parameterize ([current-store (make-store)])
(with-handlers ([exn:fail? rollback-exn!])
(let ([out body])
(normal out (rollback-capture!))))))
; Takes as input a list of n guards and a list of n stores, where
; each store is a list of location/value pairs. For each location l
; occurring in the stores, merge-store mutates l to contain the value
; m = (merge* ... (cons gi vi) ...), where gi = guards[i] and
; vi = stores[i][l] if stores[i] has a binding for l; otherwise,
; vi = (location-ref l). The procedure assumes that no store contains a
; duplicate binding for any location.
;
; This store merging procedure is correct under the assumption that
; (1) the guards are disjoint under all models (i.e., at most one
; is ever true), and (2) the verification conditions force at least
; one guard to be true under all models that satisfy both the
; asserts and the assumes.
(define (merge-stores! guards stores)
(match stores
[(list (list) ...) (void)] ; Nothing to merge.
[(list s) (for ([lv s]) ; If given only one store, just apply its effects
(location-set! (car lv) (cdr lv)))] ; since its guard must be true under the current spec.
[_ (define hash-stores (map make-hash stores))
(for ([lv (remove-duplicates (apply append stores) equal? #:key car)])
(define loc (car lv))
(define val (location-ref loc))
(location-set! loc
(apply merge*
(for/list ([g guards] [hs hash-stores])
(cons g (if (hash-has-key? hs loc)
(hash-ref hs loc)
val))))))]))

296
rosette/base/core/term.rkt
View File

@ -1,296 +0,0 @@
#lang racket
(require racket/syntax (for-syntax racket racket/syntax syntax/parse)
racket/generic syntax/parse
"type.rkt" "reporter.rkt")
(provide
terms terms-count terms-ref with-terms clear-terms! gc-terms!
term? constant? expression?
(rename-out [a-term term] [an-expression expression] [a-constant constant] [term-ord term-id])
term-type term<? sublist? @app
define-operator operator? operator-unsafe
(all-from-out "type.rkt"))
#|-----------------------------------------------------------------------------------|#
; The current-terms cache stores terms for the purposes of partial cannonicalization.
; That is, it ensures that no syntactically identical terms are created.
; The current-index parameter is used to assign unique IDs (creation timestamps) to terms.
; These IDs are never reused, and they are used to impose an ordering on the children
; of expressions with commutative operators.
#|-----------------------------------------------------------------------------------|#
;; Initialize with #f so that the hash table cooperates with garbage collector.
;; See #247
(define current-terms (make-parameter #f))
(current-terms (make-hash))
(define current-index (make-parameter 0))
; Clears the entire term cache if invoked with #f (default), or
; it clears all terms reachable from the given set of leaf terms.
(define (clear-terms! [terms #f])
(if (false? terms)
(hash-clear! (current-terms))
(let ([cache (current-terms)]
[evicted (list->mutable-set terms)])
(for ([t terms])
(hash-remove! cache (term-val t)))
(let loop ()
(define delta
(for/list ([(k t) cache] #:when (and (list? k) (for/or ([c k]) (set-member? evicted c))))
t))
(unless (null? delta)
(for ([t delta])
(hash-remove! cache (term-val t))
(set-add! evicted t))
(loop))))))
; Sets the current term cache to a garbage-collected (weak) hash.
; The setting preserves all reachable terms from (current-terms).
(define (gc-terms!)
(unless (hash-weak? (current-terms)) ; Already a weak hash.
(define cache
(impersonate-hash
(make-weak-hash)
(lambda (h k)
(values k (lambda (h k e) (ephemeron-value e #f))))
(lambda (h k v)
(values k (make-ephemeron k v)))
(lambda (h k) k)
(lambda (h k) k)
hash-clear!))
(for ([(k v) (current-terms)])
(hash-set! cache k v))
(current-terms cache)))
; Returns the term from current-terms that has the given contents. If
; no such term exists, failure-result is returned, unless it is a procedure.
; If failure-result is a procedure, it is called and its result is returned instead.
(define (terms-ref contents [failure-result (lambda () (error 'terms-ref "no term for ~a" contents))])
(hash-ref (current-terms) contents failure-result))
; Returns a list of all terms in the current-term scache, in an unspecified order.
(define (terms)
(hash-values (current-terms)))
; Returns the size of the current-terms cache.
(define (terms-count)
(hash-count (current-terms)))
; Evaluates expr with (terms) set to terms-expr, returns the result, and
; restores (terms) to its old value. If terms-expr is not given, it defaults to
; (terms), so (with-terms expr) is equivalent to (with-terms (terms) expr).
(define-syntax (with-terms stx)
;; Parameterize with #f so that the hash table cooperates with garbage collector.
;; See #247
(syntax-parse stx
[(_ expr)
#'(let ([orig-terms (current-terms)])
(parameterize ([current-terms #f])
(current-terms (hash-copy orig-terms))
expr))]
[(_ terms-expr expr)
#'(let ([orig-terms (current-terms)])
(parameterize ([current-terms #f])
(current-terms (hash-copy-clear orig-terms))
(let ([ts terms-expr]
[cache (current-terms)])
(for ([t ts])
(hash-set! cache (term-val t) t))
expr)))]))
#|-----------------------------------------------------------------------------------|#
; The term structure defines a symbolic value, which can be a variable or an expression.
; The val field of a constant is its unique identifier, and it can be anything. The val
; field of an expression is a list, in which the first argument is always a function.
; That function can be interpreted (that is, an operator), or uninterpreted (that is,
; its interpretation is determined by the solver). Terms are totally ordered and a
; subterm is guaranteed to be term<? than its parent.
#|-----------------------------------------------------------------------------------|#
(struct term
(val ; (or/c any/c (cons/c function? (non-empty-listof any/c)))
type ; type?
ord) ; integer?
#:methods gen:typed
[(define (get-type v) (term-type v))]
#:property prop:custom-print-quotable 'never
#:methods gen:custom-write
[(define (write-proc self port mode)
(fprintf port "~a" (term->string self)))])
(struct constant term ())
(struct λconstant constant (procedure)
#:property prop:procedure [struct-field-index procedure])
(struct expression term ())
(define (term<? s1 s2) (< (term-ord s1) (term-ord s2)))
(define-syntax-rule (make-term term-constructor args type rest ...)
(let ([val args]
[ty type])
(define cached (hash-ref (current-terms) val #f))
(cond
[cached
(unless (equal? (term-type cached) ty)
(error 'define-symbolic "type should remain unchanged"))
cached]
[else
(define ord (current-index))
(define out (term-constructor val ty ord rest ...))
(current-index (add1 ord))
((current-reporter) 'new-term out)
(hash-set! (current-terms) val out)
out])))
(define (make-const id t)
(unless (and (type? t) (solvable? t))
(error 'constant "expected a solvable type, given ~a" t))
(if (type-applicable? t)
(letrec ([c (make-term λconstant id t
(procedure-reduce-arity
(lambda args (apply @app c args))
(length (solvable-domain t))))])
c)
(make-term constant id t)))
(define (make-expr op . vs)
(define ran (operator-range op))
(make-term expression (cons op vs) (apply ran vs)))
(define-match-expander a-constant
(lambda (stx)
(syntax-case stx ()
[(_ id-pat type-pat) #'(constant id-pat type-pat _)]))
(syntax-id-rules ()
[(_ id type) (make-const id type)]
[_ make-const]))
(define-match-expander an-expression
(lambda (stx)
(syntax-case stx ()
[(_ op-pat elts-pat ...) #'(expression (list op-pat elts-pat ...) _ _)]))
(syntax-id-rules ()
[(_ op elts ...) (make-expr op elts ...)]
[_ make-expr]))
(define-match-expander a-term
(syntax-rules ()
[(_ val-pat type-pat) (term val-pat type-pat _)]))
#|-----------------------------------------------------------------------------------|#
; An operator is a special kind of procedure that can appear as the first element of
; a term expression. The range of an operator is given by a procedure that takes as input
; as many arguments as the operator and that returns the type? of the resulting value.
;
; All operators have a 'safe' and 'unsafe' version. The 'safe' version checks that
; the operator's arguments are in its domain (by emitting appropriate assertions),
; while the 'unsafe' version assumes that all of its arguments are properly typed and
; that all of its preconditions are met. Client code sees only the 'safe' version.
; The 'unsafe' variant is used internally by Rosette for efficiency.
#|-----------------------------------------------------------------------------------|#
(struct operator (identifier range safe unsafe)
#:property prop:procedure
(struct-field-index safe)
#:property prop:object-name
(struct-field-index identifier)
#:methods gen:custom-write
[(define (write-proc self port mode)
(fprintf port "~a" (id->string (operator-identifier self))))])
(define (make-operator #:unsafe unsafe #:safe [safe unsafe]
#:range ran #:identifier [name (object-name unsafe)] )
(operator (string->symbol (~s name)) ran safe unsafe))
(define-syntax-rule (define-operator id arg ...)
(define id (make-operator arg ...)))
(define-operator @app
#:identifier 'app
#:range (lambda (f . args)
(solvable-range (get-type f)))
#:unsafe (lambda (f . args)
(if (constant? f)
(apply make-expr @app f args)
(apply f args)))
#:safe (lambda (f . args)
(if (constant? f)
(let ([name (string->symbol (~a f))])
(apply make-expr @app f
(for/list ([a args][t (solvable-domain (get-type f))])
(type-cast t a name))))
(apply f args))))
#|-----------------------------------------------------------------------------------|#
; The following procedures convert symbolic values to strings.
#|-----------------------------------------------------------------------------------|#
(define (term->string val [max-length (error-print-width)])
(let ([output-str (open-output-string)])
(parameterize ([current-output-port output-str])
(print-rec val (make-hash) max-length))
(get-output-string output-str)))
(define (any->datum x)
(if (identifier? x) (syntax->datum x) x))
(define (id->string val)
(if (list? val)
(for/fold ([s (format "~a" (any->datum (car val)))])
([r (cdr val)])
(format "~a$~a" s (any->datum r)))
(format "~a" (any->datum val))))
(define (print-const val cache max-length)
(display (id->string (term-val val))))
(define (print-expr val cache max-length)
(match-let ([o (current-output-port)]
[(an-expression op child ...) val])
(display "(")
(display (id->string (operator-identifier op)))
(display " ")
(let ([n (for/sum ([(e i) (in-indexed child)]
#:break (>= (file-position o) max-length))
(print-rec e cache max-length)
(unless (= i (sub1 (length child)))
(display " "))
1)])
(when (< n (length child))
(display "...")))
(display ")")))
(define (print-rec val cache max-length)
(let ([str (if (hash-has-key? cache val)
(hash-ref cache val)
(let* ([output-str (open-output-string)]
[current-pos (file-position (current-output-port))]
[output-port (relocate-output-port output-str #f #f current-pos)])
(parameterize ([current-output-port output-port])
(cond [(constant? val) (print-const val cache max-length)]
[(expression? val) (print-expr val cache max-length)]
[else (display val)]))
(let ([str (get-output-string output-str)])
(hash-set! cache val str)
str)))])
(display str)))
#|-----------------------------------------------------------------------------------|#
; Utilities for working with terms.
#|-----------------------------------------------------------------------------------|#
; Returns #t if ys contains all elements of xs, in the order
; in which they occur in xs. Otherwise returns #f.
(define (sublist? xs ys)
(and (<= (length xs) (length ys))
(match xs
[(list) #t]
[(list x xs ...)
(match ys
[(list _ ... (== x) ys ...) (sublist? xs ys)]
[_ #f])])))

156
rosette/base/core/type.rkt
View File

@ -1,156 +0,0 @@
#lang racket
(require racket/generic)
(provide
gen:typed typed? get-type
gen:type
type? type-name type-cast
type-applicable?
type-eq? type-equal?
type-compress
type-construct type-deconstruct
least-common-supertype
subtype?
gen:solvable
solvable? solvable-default solvable-domain solvable-range
primitive-solvable?
type-of @any/c lifted-type define-lifted-type)
#|-----------------------------------------------------------------------------------|#
; The type generic interface defines a symbolic type. Each value has a type.
; Structures that implement the typed? generic interface attach type information
; directly to their instances. Types of other values are calculated on the fly.
;
; The solvable generic interface acts as a marker for types that are supported by
; the underlying constraint solver. The solvable-default method of a solvable type T
; returns a default value of type T that may be used for binding constants that are
; otherwise unconstrained. The solvable-domain method returns a list of solvable?
; types that are not applicable; that is, (type-applicable? T) returns #f. The
; solvable-range method returns a single solvable? non-applicable type. If the type
; T is not applicable, then solvable-range returns T itself and solvable-domain returns
; the empty list.
#|-----------------------------------------------------------------------------------|#
(define-generics typed
[get-type typed]) ; (-> typed? type?)
(define-generics type
[least-common-supertype type other] ; (-> type? type? type?)
[type-cast type val [caller]] ; (-> type? any/c symbol? any/c)
[type-name type] ; (-> type? symbol?)
[type-applicable? type] ; (-> type? boolean?)
[type-eq? type u v] ; (-> type? any/c any/c @boolean?)
[type-equal? type u v] ; (-> type? any/c any/c @boolean?)
[type-compress type force? ps] ; (-> type? (listof (cons @boolean? any/c)) (listof (cons @boolean? any/c)))
[type-construct type vals] ; (-> type? (listof any/c) any/c)
[type-deconstruct type val]) ; (-> type? any/c (listof any/c))
(define (subtype? t0 t1)
(eq? t1 (least-common-supertype t0 t1)))
(define-generics solvable
[solvable-default solvable] ; (-> (and/c solvable? type?) any/c)
[solvable-domain solvable] ; (-> (and/c solvable? type?) (listof primitive-solvable?))
[solvable-range solvable]) ; (-> (and/c solvable? type?) primitive-solvable?)
(define (primitive-solvable? t)
(and (solvable? t) (type? t) (not (type-applicable? t))))
; Defines a new lifted type for the given Racket built-in type, using the
; following arguments:
; id ; Identifier for the lifted type.
; #:base base ; Racket type being lifted.
; #:is-a? is-a? ; Predicate that recognizes concrete and symbolic values of the lifted type.
; #:methods ([method-id expr] ...) ; Definitions of gen:type methods, including at least cast. This can
; ; optionally include gen:solvable methods.
; A given Racket type cannot be lifted more than once. That is, multiple attempts to
; call define-lifted-type with the same base type as argument will result in an error.
; Only these Racket types are expected to be lifted:
; boolean?, integer?, real?, list?, pair?, procedure?, vector?, and box?.
(define-syntax (define-lifted-type stx)
(syntax-case stx ()
[(_ id #:base base #:is-a? is-a? #:methods defs)
#`(begin
(unless (hash-has-key? types base)
(error 'lift "Cannot lift ~a.\nExpected one of ~a." base (hash-keys types)))
(unless (eq? @any/c (hash-ref types base))
(error 'lift "Type already lifted: ~a." base))
(define id (make-lifted-type #:base base #:is-a? is-a? #:methods defs))
(hash-set! types base id))]))
(define-syntax (make-lifted-type stx)
(syntax-case stx ()
[(_ #:base base #:is-a? is-a? #:methods defs)
(let* ([methods (for/hash ([expr (syntax->list #'defs)])
(with-syntax ([(define (method arg ...) body ...) expr])
(values (syntax->datum #'method) #'(lambda (arg ...) body ...))))]
[required (lambda (m) (or (hash-ref methods m #f)
(raise-syntax-error
'define-lifted-type
(format "missing required method definition ~a" m))))])
#`(let ()
(struct lifted (pred)
#:property prop:procedure [struct-field-index pred]
#:methods gen:custom-write
[(define (write-proc self port mode) (fprintf port "~a" 'base))]
#,@(if (hash-has-key? methods 'solvable-default)
#`(#:methods gen:solvable
[(define solvable-default #,(hash-ref methods 'solvable-default))
(define solvable-domain #,(hash-ref methods 'solvable-domain #'(lambda (self) null)))
(define solvable-range #,(hash-ref methods 'solvable-range #'(lambda (self) self)))])
#`())
#:methods gen:type
[(define least-common-supertype #,(hash-ref methods 'least-common-supertype
#'(lambda (self other) (if (equal? self other) self @any/c))))
(define type-cast #,(required 'type-cast))
(define type-name #,(hash-ref methods 'type-name #'(lambda (self) 'base)))
(define type-applicable? #,(hash-ref methods 'type-applicable? #'(lambda (self) #f)))
(define type-eq? #,(hash-ref methods 'type-eq? #'(lambda (self u v) (eq? u v))))
(define type-equal? #,(hash-ref methods 'type-equal? #'(lambda (self u v) (equal? u v))))
(define type-compress #,(hash-ref methods 'type-compress #'(lambda (self force? ps) ps)))
(define type-construct #,(hash-ref methods 'type-construct #'(lambda (self vals) (car vals))))
(define type-deconstruct #,(hash-ref methods 'type-deconstruct #'(lambda (self val) (list val))))])
(lifted is-a?)))]))
; Universal type that accepts all Racket and Rosette values. The least-common-supertype
; method of every type must return #t when given @any? as the argument.
(define @any/c
(make-lifted-type
#:base any/c
#:is-a? (const #t)
#:methods
[(define (least-common-supertype self other) self)
(define (type-cast self v [caller 'type-cast]) v)]))
; Binds liftable Racket built-in type predicates to their corresponding Rosette types.
; Initially, all liftable types are bound to @any/c. See the make-type-of macro.
(define types (make-hash))
; Returns the lifted Rosette type corresponding to the given liftable Racket built-in predicate.
(define (lifted-type pred) (hash-ref types pred))
; This is a hacked type-of implementation to allow testing Int and Real theories
; before they are properly integrated. The current-bitwidth parameter controls
; whether we are using the old int/real semantics (default) or not.
(define-syntax-rule (typechecker #:base id ...)
(begin
(hash-set! types id @any/c) ...
(case-lambda
[(v) (cond [(typed? v) (get-type v)]
[(id v) (hash-ref types id)] ...
[else @any/c])]
[(v u) (least-common-supertype (type-of v) (type-of u))]
[vs (for/fold ([t (type-of (car vs))]) ([v (cdr vs)] #:break (eq? t @any/c))
(least-common-supertype t (type-of v)))])))
; The type-of procedure a type t that accepts the given values, and there is no t'
; such that t' != t, (subtype? t' t), and t' also accepts the given values.
(define type-of
(typechecker
#:base boolean? integer? real? list? pair? procedure? vector? box?))

104
rosette/base/core/union.rkt
View File

@ -1,104 +0,0 @@
#lang racket
(require "term.rkt" "reporter.rkt")
(provide union? (rename-out [a-union union])
union-contents union-type union-guards union-values union-filter
in-union in-union* in-union-guards in-union-values)
; Represents a symbolic union of guarded values that evaluates either to a
; single value of a given type, or no value at all.
; A union evaluates to the value, if any, whose corresponding guard is true
; in a given execution.
; If no such guard exists, the union is an empty (invalid) value.
; The guards must be constrained by the semantics of the
; program so that at most one of them is true in any given execution. A
; union that is not a λunion cannot contain a procedure as one of its values.
(struct union (contents type)
#:transparent
#:methods gen:typed
[(define (get-type self) (union-type self))]
#:methods gen:custom-write
[(define (write-proc self port mode)
(fprintf port "(union")
(case mode
[(#t #f)
(fprintf port " #:size ~a #:hash ~a" (length (union-contents self)) (equal-hash-code self))]
[else
(let ([vs (union-contents self)])
(unless (null? vs)
(parameterize ([error-print-width (max 4 (quotient (error-print-width) (* 2 (length vs))))])
(for ([v vs])
(fprintf port " ")
(fprintf-entry port v mode)))))])
(fprintf port ")"))])
(define (fprintf-entry port p mode)
(fprintf port "[")
(fprintf port "~a" (car p))
(fprintf port " ")
(fprintf port "~a" (cdr p))
(fprintf port "]"))
(define nil (union '() @any/c))
; A λunion is a symoblic union that must contain a procedure object. Every
; λunion is itself an applicable procedure.
(struct λunion union (procedure)
#:transparent
#:property prop:procedure [struct-field-index procedure])
(define (make-union . vs)
((current-reporter) 'new-union (length vs))
(match vs
[(list) nil]
[_
(let ([vs (sort vs term<? #:key car)]
[t (apply type-of (map cdr vs))])
(cond [(type-applicable? t)
(λunion vs t (type-compress (lifted-type procedure?) #t vs))]
[else
(let ([ps (for/list ([v vs] #:when (procedure? (cdr v))) v)])
(if (null? ps)
(union vs t)
(λunion vs t (type-compress (lifted-type procedure?) #t ps))))]))]))
(define (union-filter r type)
(if (or (eq? r nil) (subtype? (union-type r) type))
r
(match (for/list ([v (in-union r type)]) v)
[(list) nil]
[vs (union vs type)])))
(define (union-guards r) (map car (union-contents r)))
(define (union-values r) (map cdr (union-contents r)))
(define in-union
(case-lambda [(r) (in-list (union-contents r))]
[(r type) (sequence-filter (compose type cdr) (in-union r))]))
(define in-union*
(case-lambda [(r) (in-parallel (in-union-guards r) (in-union-values r))]
[(r type) (in-parallel (in-union-guards r type) (in-union-values r type))]))
(define in-union-guards
(case-lambda [(r) (sequence-map car (in-union r))]
[(r type) (sequence-map car (in-union r type))]))
(define in-union-values
(case-lambda [(r) (sequence-map cdr (in-union r))]
[(r type) (sequence-map cdr (in-union r type))]))
(define-match-expander a-union
(syntax-rules (:)
[(_) (== nil)]
[(_ vals-pat type-pat) (union vals-pat type-pat)]
[(_ vals-pat) (union vals-pat _)]
[(_ : (guard-pat val-pat) ...)
(union (list-no-order (cons guard-pat val-pat) ...) _)]
[(_ : (guard-pat val-pat) ...+ lvp ...)
(union (list-no-order (cons guard-pat val-pat) ...+ lvp ...) _)])
(syntax-id-rules (set!)
[(a-union v ...) (make-union v ...)]
[a-union make-union]))

11
rosette/base/form/app.rkt
View File

@ -1,11 +0,0 @@
#lang racket
(require (for-syntax racket/syntax)
racket/stxparam racket/stxparam-exptime)
(provide app (rename-out [app #%app] [app #%plain-app]))
(define-syntax-parameter app
(syntax-rules ()
[(_ proc arg ...) (#%app proc arg ...)]))

85
rosette/base/form/control.rkt
View File

@ -1,85 +0,0 @@
#lang racket
(require "../core/eval.rkt" "../core/store.rkt" "../core/result.rkt"
"../core/term.rkt" "../core/equality.rkt"
"../core/merge.rkt" "../core/bool.rkt")
(provide @if @and @or @not @nand @nor @xor @implies
@unless @when @cond @case else)
(define-syntax (@if stx)
(syntax-case stx ()
[(_ test-expr then-expr else-expr)
(quasisyntax/loc stx
(branch-and-merge test-expr
(thunk then-expr)
(thunk else-expr)))]))
(define (branch-and-merge test-expr then-branch else-branch)
(define test (@true? test-expr))
(cond [(eq? test #t) (then-branch)]
[(eq? test #f) (else-branch)]
[else (eval-guarded! (list test (! test)) (list then-branch else-branch))]))
(define-syntax (@and stx)
(syntax-case stx ()
[(_) (syntax/loc stx #t)]
[(_ arg) (syntax/loc stx arg)]
[(_ arg0 arg ...) (syntax/loc stx (@if arg0 (@and arg ...) #f))]))
(define-syntax (@or stx)
(syntax-case stx ()
[(_) (syntax/loc stx #f)]
[(_ arg) (syntax/loc stx arg)]
[(_ arg0 arg ...)
(quasisyntax/loc stx (let ([val arg0]) (@if val val (@or arg ...))))]))
(define @not @false?)
(define-syntax (@implies stx)
(syntax-case stx ()
[(_ x y) (syntax/loc stx (@if x y #t))]))
(define-syntax (@nor stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (@not (@or expr ...)))]))
(define-syntax (@nand stx)
(syntax-case stx ()
[(_ expr ...) (syntax/loc stx (@not (@and expr ...)))]))
(define (@xor a b)
(@if a (@if b #f a) b))
(define-syntax (@unless stx)
(syntax-case stx ()
[(_ test body ...) (syntax/loc stx (@if test (void) (let () body ...)))]))
(define-syntax (@when stx)
(syntax-case stx ()
[(_ test body ...) (syntax/loc stx (@if test (let () body ...) (void)))]))
(define-syntax (@cond stx)
(syntax-case stx (else)
[(_) (syntax/loc stx (void))]
[(_ [else else-val ...]) (syntax/loc stx (let () else-val ...))]
[(_ [then0 then0-val ...] [then then-val ...] ...)
(syntax/loc stx (@if then0
(let () then0-val ...)
(@cond [then then-val ...] ...)))]))
(define-syntax (@case stx)
(syntax-case stx (else)
[(_ expr
[(then-val ...) then-expr ...] ...
[else else-expr ...])
(syntax/loc stx
(let ([tmp expr])
(@cond [(@or (@equal? tmp (quote then-val)) ...) then-expr ...] ...
[else else-expr ...])))]
[(_ expr
[(then-val ...) then-expr ...] ...)
(syntax/loc stx
(@case expr
[(then-val ...) then-expr ...] ...
[else (void)]))]))

48
rosette/base/form/define.rkt
View File

@ -1,48 +0,0 @@
#lang racket
(require syntax/parse (for-syntax syntax/parse racket)
"../core/term.rkt")
(provide define-symbolic define-symbolic*)
(define-for-syntax (module-or-top? . args)
(case (syntax-local-context)
[(module top-level) #t]
[else #f]))
(define-for-syntax (static? k)
(with-handlers ([exn:fail? module-or-top?])
(natural? (eval k))))
(define-syntax (define-symbolic stx)
(syntax-parse stx
[(_ var:id type)
#'(define var (constant #'var type))]
[(_ var:id type #:length k)
#:declare k (expr/c #'natural? #:name "length argument")
#:fail-unless (static? #'k) "expected a natural? for #:length"
#'(define var
(for/list ([i k.c])
(constant (list #'var i) type)))]
[(_ var:id ...+ type)
#'(begin (define-symbolic var type) ...)]))
(define current-index (make-parameter 0))
(define (index!)
(define idx (current-index))
(current-index (add1 idx))
idx)
(define-syntax (define-symbolic* stx)
(syntax-parse stx
[(_ var:id type)
#'(define var (constant (list #'var (index!)) type))]
[(_ var:id type #:length k)
#:declare k (expr/c #'natural? #:name "length argument")
#'(define var
(for/list ([i k.c])
(define-symbolic* var type)
var))]
[(_ var:id ...+ type)
#'(begin (define-symbolic* var type) ...)]))

269
rosette/base/form/module.rkt
View File

@ -1,269 +0,0 @@
#lang racket
(require (for-syntax racket/dict syntax/parse syntax/parse/define syntax/id-table (only-in racket pretty-print)
(only-in "../core/lift.rkt" drop@))
racket/require racket/undefined
(filtered-in drop@ "../adt/box.rkt")
(for-syntax (only-in "../struct/struct.rkt" [struct @struct]) (only-in "../struct/generics.rkt" @define-generics))
(only-in "../struct/struct.rkt" [struct @struct]) (only-in "../struct/generics.rkt" @define-generics)
(only-in racket/splicing splicing-let splicing-let-values))
(provide @#%module-begin @#%top-interaction
(rename-out [module @module] [module* @module*] [module+ @module+]))
(define-for-syntax orig-insp (variable-reference->module-declaration-inspector (#%variable-reference)))
(define-syntax (@#%module-begin stx)
(syntax-case stx ()
[(_ forms ...)
(let* ([core (local-expand #'(#%plain-module-begin forms ...) 'module-begin (list #'module*))]
[vars (find-mutated-vars core)]
[transformed (box-mutated-vars core vars)])
;(printf "vars:~a\n" (dict->list vars))
;(printf "core:\n") (pretty-print (syntax->datum core))
;(call-with-output-file "bad.rkt"
; (lambda (out) (parameterize ([current-output-port out])
;(printf "transformed:\n")
; (pretty-print (syntax->datum transformed))))
; #:mode 'text
; #:exists 'replace)
transformed)]))
(define-syntax (@#%top-interaction stx)
(syntax-case stx ()
[(_ . (id rest ...))
(and (identifier? #'id) (free-identifier=? #'id #'@define-generics))
(syntax/loc stx (id rest ...))]
[(_ . (id e ...))
(and (identifier? #'id) (free-identifier=? #'id #'begin))
(syntax/loc stx (begin (@#%top-interaction . e) ...))]
[(_ . form)
(let* ([core (local-expand #'form 'top-level (list))]
[vars (find-mutated-vars core #f)]
[top-vars (for/list ([(var mutated?) (in-dict vars)]
#:unless (or (not mutated?)
(equal? 'lexical (identifier-binding var))))
var)]
[transformed
(begin (unless (null? top-vars)
(raise-syntax-error
'set!
"assignment disallowed;\n cannot set top-level variables" #'form #f top-vars))
(box-mutated-vars core vars))])
;(printf "core:\n~a\n" core)
;(printf "mutated vars\n~a\n" (dict->list vars))
;(printf "transformed: ~a\n" transformed)
transformed)]))
(define-for-syntax (find-mutated-vars form [define=>mutable? #f] [tbl (make-free-id-table)])
(define (fmv/list lstx) (for ([stx (syntax->list lstx)]) (fmv stx)))
(define (fmv stx)
(syntax-parse
stx
#:literal-sets (kernel-literals)
[(set! v e)
(fmv #'e)
(dict-set! tbl #'v #t)]
;; forms with expression subforms
[(define-values vars expr)
(fmv #'expr)
(when define=>mutable?
(for ([v (syntax->list #'vars)])
(dict-set! tbl v #t)))]
[(#%expression e) (fmv #'e)]
[(#%plain-app . rest) (fmv/list #'rest)]
[(begin . rest) (fmv/list #'rest)]
[(begin0 . rest) (fmv/list #'rest)]
[(#%plain-lambda _ . rest) (fmv/list #'rest)]
[(case-lambda (_ rest ...) ...) (fmv/list #'(rest ... ...))]
[(if . es) (fmv/list #'es)]
[(with-continuation-mark . es) (fmv/list #'es)]
[(let-values ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
[(letrec-values ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
[(letrec-syntaxes+values _ ([_ e] ...) b ...) (fmv/list #'(b ... e ...))]
[(#%plain-module-begin . forms) (fmv/list #'forms)]
;; all the other forms don't have any expression subforms (like #%top)
[_ (void)]))
(fmv form)
tbl)
(define-for-syntax (lexical? id) (eq? (identifier-binding id) 'lexical))
(define-for-syntax (formals->identifiers stx)
(syntax-parse
stx
[var:id (list stx)]
[(var:id ...) (syntax->list stx)]
[(var:id ... . rest:id) (syntax->list #'(var ... rest))]))
(begin-for-syntax
(define-simple-macro (quasisyntax* orig-stx new-stx)
(let ([orig-stx* orig-stx]
[new-stx* (quasisyntax new-stx)])
(datum->syntax new-stx* (syntax-e new-stx*) orig-stx* orig-stx*))))
(define-for-syntax (box-mutated-vars form tbl)
(define varref-tbl (make-free-id-table))
(define (mutated? id) (free-id-table-ref tbl id #f))
(define (any-mutated? ids) (for/or ([id ids]) (mutated? id)))
(define (bmv/list lstx)
(let* ([stxs (syntax->list lstx)]
[fs (map bmv stxs)])
(values (equal? fs stxs) fs)))
(define (bmv/rest stx lit lstx)
(let-values ([(pure? forms) (bmv/list lstx)])
(if pure? stx (quasisyntax* stx (#,lit #,@forms)))))
(define (bmv/proc-body formals rest)
(let-values ([(pure? fs) (bmv/list rest)]
[(vs) (formals->identifiers formals)])
(cond [(any-mutated? vs)
#`(#,@(for/list ([v vs] #:when (mutated? v))
#`(set! #,v (box #,v)))
#,@fs)]
[pure? rest]
[else fs])))
(define (bmv stx)
(syntax-parse
(syntax-disarm stx orig-insp)
#:literal-sets (kernel-literals)
[var:id
(cond [(and (mutated? #'var) (lexical? #'var)) (quasisyntax* stx (unbox var))]
[else #'var])]
[(set! var expr)
(let ([e (bmv #'expr)])
(cond [(lexical? #'var) (quasisyntax* stx (set-box! var #,e))]
[(eq? e #'expr) stx]
[else (quasisyntax* stx (set! var #,e))]))]
[(define-values (var) expr)
(let ([e (bmv #'expr)])
(cond [(mutated? #'var)
(with-syntax ([(loc) (generate-temporaries #'(var))])
(dict-set! varref-tbl #'var #'loc)
(quasisyntax* stx
(begin
(define loc (box #,e))
(define-syntax var
(syntax-id-rules (set!)
[(set! var val) (set-box! loc val)]
[(var . arg) ((unbox loc) . arg)]
[var (unbox loc)])))))]
[(eq? e #'expr) stx]
[else (quasisyntax* stx (define-values (var) #,e))]))]
[(define-values (var ...) expr)
(let ([e (bmv #'expr)]
[vs (syntax->list #'(var ...))])
(cond [(any-mutated? vs)
(let ([locs (generate-temporaries vs)])
(for ([v (in-list vs)]
[loc (in-list locs)]
#:when (mutated? v))
(dict-set! varref-tbl v loc))
(quasisyntax* stx
(begin
(define-values #,locs #,e)
#,@(for/list ([v vs][loc locs] #:when (mutated? v))
#`(set! #,loc (box #,loc)))
#,@(for/list ([v vs][loc locs])
(if (mutated? v)
#`(define-syntax #,v
(syntax-id-rules (set!)
[(set! #,v val) (set-box! #,loc val)]
[(#,v . arg) ((unbox #,loc) . arg)]
[#,v (unbox #,loc)]))
#`(define-values (#,v) #,loc))))))]
[(eq? e #'expr) stx]
[else (quasisyntax* stx (define-values (var ...) #,e))]))]
[(let-values ([(var ...) expr] ...) body ...)
(let-values ([(pure-es? es) (bmv/list #'(expr ...))]
[(pure-fs? fs) (bmv/list #'(body ...))]
[(vs) (syntax->list #'(var ... ...))])
(cond [(any-mutated? vs)
(with-syntax ([(e ...) es])
(quasisyntax* stx
(let-values ([(var ...) e] ...)
#,@(for/list ([v vs] #:when (mutated? v))
#`(set! #,v (box #,v)))
#,@fs)))]
[(and pure-es? pure-fs?) stx]
[else
(with-syntax ([(e ...) es])
(quasisyntax* stx
(let-values ([(var ...) e] ...)
#,@fs)))]))]
[(letrec-values ([(var ...) expr] ...) body ...)
(let-values ([(pure-es? es) (bmv/list #'(expr ...))]
[(pure-fs? fs) (bmv/list #'(body ...))]
[(vs) (syntax->list #'(var ... ...))])
(cond [(any-mutated? vs)
(let ([ves (syntax->list #'((var ...) ...))])
(quasisyntax* stx
(letrec-values ([#,vs (apply values (make-list #,(length vs) undefined))])
#,@(for/list ([v vs] #:when (mutated? v))
#`(set! #,v (box #,v)))
#,@(for/fold ([result '()]) ([ve ves] [e es])
`(,@result
,#`(set!-values #,ve #,e)
,@(for/list ([v (syntax->list ve)] #:when (mutated? v))
#`(set! #,v (box #,v)))))
#,@fs)))]
[(and pure-es? pure-fs?) stx]
[else
(with-syntax ([(e ...) es])
(quasisyntax* stx
(letrec-values ([(var ...) e] ...)
#,@fs)))]))]
[(letrec-syntaxes+values stx-decls ([(var ...) expr] ...) body ...)
(let*-values ([(pure-es? es) (bmv/list #'(expr ...))]
[(pure-fs? fs) (bmv/list #'(body ...))]
[(vs) (syntax->list #'(var ... ...))])
(cond [(any-mutated? vs)
(let ([ves (syntax->list #'((var ...) ...))])
(quasisyntax* stx
(letrec-syntaxes+values stx-decls ([#,vs (apply values (make-list #,(length vs) undefined))])
#,@(for/list ([v vs] #:when (mutated? v))
#`(set! #,v (box #,v)))
#,@(for/fold ([result '()]) ([ve ves] [e es])
`(,@result
,#`(set!-values #,ve #,e)
,@(for/list ([v (syntax->list ve)] #:when (mutated? v))
#`(set! #,v (box #,v)))))
#,@fs)))]
[(and pure-es? pure-fs?) stx]
[else
(with-syntax ([(e ...) es])
(quasisyntax* stx
(letrec-syntaxes+values stx-decls ([(var ...) e] ...)
#,@fs)))]))]
[(#%plain-lambda formals . rest)
(let ([body (bmv/proc-body #'formals #'rest)])
(cond [(eq? body #'rest) stx]
[else (quasisyntax* stx (#%plain-lambda formals #,@body))]))]
[(case-lambda . rest)
(let* ([r (syntax->list #'rest)]
[fs (for/list ([fb r])
(with-syntax ([(f . b) fb])
(let ([body (bmv/proc-body #'f #'b)])
(if (eq? body #'b)
fb
(quasisyntax* fb (f #,@body))))))])
(cond [(equal? r fs) stx]
[else (quasisyntax* stx (case-lambda #,@fs))]))]
[(if . rest) (bmv/rest stx #'if #'rest)]
[(#%expression . rest) (bmv/rest stx #'#%expression #'rest)]
[(#%plain-app . rest) (bmv/rest stx #'#%plain-app #'rest)]
[(begin . rest) (bmv/rest stx #'begin #'rest)]
[(begin0 . rest) (bmv/rest stx #'begin0 #'rest)]
[(with-continuation-mark . rest) (bmv/rest stx #'with-continuation-mark #'rest)]
[(#%plain-module-begin . rest) (quasisyntax* stx (#%module-begin #,@(map bmv (syntax->list #'rest))))]
[(#%variable-reference x)
#`(#%variable-reference
#,(free-id-table-ref varref-tbl #'x (λ () #'x)))]
[_ stx]))
(bmv form))

246
rosette/base/struct/generics.rkt
View File

@ -1,246 +0,0 @@
#lang racket
(require (for-syntax (only-in racket/syntax
format-id wrong-syntax generate-temporary
current-syntax-context)
(only-in syntax/stx stx-pair? stx-car stx-cdr))
(only-in racket/generic define-generics)
(only-in "../core/forall.rkt" for/all)
"../core/union.rkt")
(provide @define-generics @make-struct-type-property)
(begin-for-syntax
;; parse is copied from racket/generic
;; One modification (marked below): If the #:defined-predicate option
;; is not present, it returns #f instead of (generate-temporary)
(define (parse stx [options (hasheq)])
(syntax-case stx ()
[(#:defined-predicate name . args)
(identifier? #'name)
(if (hash-ref options 'support #f)
(wrong-syntax (stx-car stx)
"duplicate #:defined-predicate specification")
(parse #'args (hash-set options 'support #'name)))]
[(#:defined-predicate . other)
(wrong-syntax (stx-car stx) "invalid #:defined-predicate specification")]
[(#:defined-table name . args)
(identifier? #'name)
(if (hash-ref options 'table #f)
(wrong-syntax (stx-car stx)
"duplicate #:defined-table specification")
(parse #'args (hash-set options 'table #'name)))]
[(#:defined-table . other)
(wrong-syntax (stx-car stx) "invalid #:defined-table specification")]
[(#:defaults (clause ...) . args)
(if (hash-ref options 'defaults #f)
(wrong-syntax (stx-car stx) "duplicate #:defaults specification")
(let loop ([defaults '()]
[clauses (reverse (syntax->list #'(clause ...)))])
(if (pair? clauses)
(syntax-case (car clauses) ()
[(pred #:dispatch disp defn ...)
(loop (cons #'[pred disp defn ...] defaults)
(cdr clauses))]
[(pred defn ...)
(with-syntax ([name (generate-temporary #'pred)])
(loop (cons #'[pred #:same defn ...] defaults)
(cdr clauses)))]
[clause
(wrong-syntax #'clause "invalid #:defaults specification")])
(parse #'args
(hash-set* options 'defaults defaults)))))]
[(#:defaults . other)
(wrong-syntax (stx-car stx) "invalid #:defaults specification")]
[(#:fast-defaults (clause ...) . args)
(if (hash-ref options 'fast-defaults #f)
(wrong-syntax (stx-car stx)
"duplicate #:fast-defaults specification")
(let loop ([fast-defaults '()]
[clauses (reverse (syntax->list #'(clause ...)))])
(if (pair? clauses)
(syntax-case (car clauses) ()
[(pred #:dispatch disp defn ...)
(loop (cons #'[pred disp defn ...] fast-defaults)
(cdr clauses))]
[(pred defn ...)
(with-syntax ([name (generate-temporary #'pred)])
(loop (cons #'[pred #:same defn ...] fast-defaults)
(cdr clauses)))]
[clause
(wrong-syntax #'clause
"invalid #:fast-defaults specification")])
(parse #'args
(hash-set* options
'fast-defaults fast-defaults)))))]
[(#:fast-defaults . other)
(wrong-syntax (stx-car stx) "invalid #:fast-defaults specification")]
[(#:fallbacks [fallback ...] . args)
(if (hash-ref options 'fallbacks #f)
(wrong-syntax (stx-car stx) "duplicate #:fallbacks specification")
(parse #'args (hash-set options 'fallbacks #'[fallback ...])))]
[(#:fallbacks . other)
(wrong-syntax (stx-car stx) "invalid #:fallbacks specification")]
[(#:derive-property prop impl . args)
(parse #'args
(hash-set options
'derived
(cons (list #'prop #'impl)
(hash-ref options 'derived '()))))]
[(#:derive-property . other)
(wrong-syntax (stx-car stx) "invalid #:derive-property specification")]
[(kw . args)
(keyword? (syntax-e #'kw))
(wrong-syntax #'kw "invalid keyword argument")]
[((_ . _) . args)
(if (hash-ref options 'methods #f)
(wrong-syntax (stx-car stx) "duplicate methods list specification")
(let loop ([methods (list (stx-car stx))] [stx #'args])
(syntax-case stx ()
[((_ . _) . args) (loop (cons (stx-car stx) methods) #'args)]
[_ (parse stx (hash-set options 'methods (reverse methods)))])))]
[(other . args)
(wrong-syntax #'other
"expected a method identifier with formal arguments")]
[() (values (hash-ref options 'methods '())
;; MODIFICATION: Third argument to hash-ref changed
;; from generate-temporary to #f
(hash-ref options 'support #f)
(hash-ref options 'table #f)
(hash-ref options 'fast-defaults '())
(hash-ref options 'defaults '())
(hash-ref options 'fallbacks '())
(hash-ref options 'derived '()))]
[other
(wrong-syntax #'other
"expected a list of arguments with no dotted tail")]))
(define (index-of name-stx formals-stx)
(let loop ([i 0] [formals formals-stx])
(unless (stx-pair? formals)
(wrong-syntax
formals-stx
"did not find the generic name ~a among the required, by-position arguments"
(syntax->datum name-stx)))
(define c (stx-car formals))
(cond [(identifier? c)
(if (free-identifier=? name-stx (stx-car formals))
(datum->syntax name-stx i)
(loop (+ i 1) (stx-cdr formals)))]
[(keyword? (syntax->datum c)) ; count only by-position required arguments
(loop i (stx-cdr (stx-cdr formals)))]
[else
(wrong-syntax c "required arguments must precede optional arguments")]))))
(define-syntax (@define-generics stx)
(syntax-case stx ()
[(_ id . rest)
(parameterize ([current-syntax-context stx])
(unless (identifier? #'id)
(wrong-syntax #'id "expected an identifier"))
(define-values
(methods support table fasts defaults fallbacks derived)
(parse #'rest))
(when table
(wrong-syntax table
"#:defined-table option is not supported in Rosette"))
(with-syntax ([id? (format-id #'id "~a?" #'id #:source #'id)]
[((method-name . method-args) ...) methods]
[support-name support])
(with-syntax ([(method-index ...)
(map (lambda (args) (index-of #'id args))
(syntax-e #'(method-args ...)))])
(syntax/loc stx
(begin
(define-generics id . rest)
(lift-if-exists id? 0)
(lift-if-exists support-name 0)
(lift-if-exists method-name method-index) ...)))))]))
(define (@make-struct-type-property name [guard #f] [supers null] [can-impersonate? #f])
(define-values (prop:p p? p-ref)
(make-struct-type-property name guard supers can-impersonate?))
(values prop:p (lift p? 0) (lift p-ref 0)))
(define-syntax (lift-if-exists stx)
(syntax-case stx ()
[(_ proc receiver-index)
(if (syntax->datum #'proc)
(syntax/loc stx
(set! proc (lift proc receiver-index)))
(syntax/loc stx
(void)))]))
(define (lift proc receiver-index)
(define-values (required-kws allowed-kws) (procedure-keywords proc))
(define arity (procedure-arity proc))
(procedure-rename
(if (null? allowed-kws)
(procedure-reduce-arity
(lambda args
(define receiver (list-ref args receiver-index))
(if (union? receiver)
(for/all ([r receiver])
(apply proc (list-set args receiver-index r)))
(apply proc args)))
arity)
(procedure-reduce-keyword-arity
(make-keyword-procedure
(lambda (kws kw-args . args)
(define receiver (list-ref args receiver-index))
(if (union? receiver)
(for/all ([r receiver])
(keyword-apply proc kws kw-args (list-set args receiver-index r)))
(keyword-apply proc kws kw-args args))))
arity
required-kws
allowed-kws))
(or (object-name proc) 'lifted)))
#|
; sanity check
(@define-generics foo [some foo])
some
(struct bar (arg)
#:methods gen:foo
[(define (some self) (bar-arg self))])
(some (bar 'yes))
(require (only-in rosette/base/form/define define-symbolic)
(only-in rosette/base/core/bool @boolean?)
(only-in rosette/base/core/real @* @+))
(define-symbolic b @boolean?)
(some (@if b (bar 'yes) (bar 'no)))
(foo? (@if b (bar 'yes) (bar 'no)))
(@define-generics xyzzy
(h xyzzy))
(@define-generics variadic
(f variadic . x)
(g variadic))
(struct multiplier (y) #:transparent
#:methods gen:variadic
[(define (f self . x) (foldl @* (multiplier-y self) x))
(define (g self) 'g-mult)]
#:methods gen:xyzzy
[(define (h self) 42)])
(struct adder (z) #:transparent
#:methods gen:variadic
[(define (f self . x) (foldl @+ (adder-z self) x))
(define (g self) 'g-add)])
(define thing (@if b (multiplier 3) (adder 3)))
(variadic? thing)
thing
(f thing 2 5)
(g thing)
(h thing)|#

221
rosette/base/struct/struct-type.rkt
View File

@ -1,221 +0,0 @@
#lang racket
(require (for-syntax "../core/lift.rkt" racket/syntax)
(only-in racket/private/generic-methods generic-property)
(only-in "../core/store.rkt" store!)
"../core/term.rkt" "../core/lift.rkt" "../core/safe.rkt"
(only-in "../core/bool.rkt" || && and-&&)
(only-in "../core/type.rkt" @any/c type-cast gen:typed get-type)
(only-in "../core/procedure.rkt" @procedure?)
(only-in "../core/merge.rkt" merge merge*)
(only-in "../core/union.rkt" union union? in-union-guards)
(only-in "../core/equality.rkt" @equal? @eq?)
(only-in "../adt/generic.rkt" adt-type-cast))
(provide @make-struct-type
@make-struct-field-accessor
@make-struct-field-mutator)
(define (@make-struct-type
name super-type init-field-cnt auto-field-cnt
[auto-v #f]
[props '()]
[inspector (current-inspector)]
[proc-spec #f]
[immutables '()]
[guard #f]
[constructor-name #f])
; (printf "@make-struct-type:\n")
; (printf " name: ~a\n" name)
; (printf " super-type: ~a\n" super-type)
; (printf " init-field-cnt: ~a\n" init-field-cnt)
; (printf " auto-field-cnt: ~a\n" auto-field-cnt)
; (printf " props: ~a\n" props)
; (printf " inspector: ~a\n" inspector)
; (printf " proc-spec: ~a\n" proc-spec)
; (printf " immutables: ~a\n" immutables)
(define-values (struct:t make-t t? t-ref t-set!)
(make-struct-type
name super-type init-field-cnt auto-field-cnt auto-v
(cons (cons (generic-property gen:typed)
(vector (lambda (self) @struct:t)))
props) ; all struct values are typed
inspector proc-spec immutables
guard constructor-name))
(define (@t? v)
(match v
[(? t?) #t]
[(and (? typed? v) (app get-type t))
(or (and t (subtype? t @struct:t))
(and (union? v) (apply || (for/list ([g (in-union-guards v @struct:t)]) g))))]
[_ #f]))
(define super (and super-type (typed? super-type) (get-type super-type)))
(define field-count (+ init-field-cnt auto-field-cnt))
(define immutable? (and (= init-field-cnt (length immutables)) (zero? auto-field-cnt)))
(define transparent? (not inspector))
(define equal+hash (let ([e+h (assoc (generic-property gen:equal+hash) props)])
(and e+h (cdr e+h))))
(define procedure? (or proc-spec (not (false? (assoc prop:procedure props)))))
; (printf " super: ~a\n" super)
; (printf " field-count: ~a\n" field-count)
; (printf " immutable?: ~a\n" immutable?)
; (printf " transparent?: ~a\n" transparent?)
; (printf " procedure?: ~a\n" procedure?)
; (printf " equal+hash: ~a\n" equal+hash)
(define @struct:t
(struct-type
(procedure-rename @t? (object-name t?))
super t? make-t t-ref t-set! field-count
(and immutable? (implies super (struct-type-immutable? super)))
(and transparent? (implies super (struct-type-transparent? super)))
(or procedure? (and super (struct-type-procedure? super)))
equal+hash))
(values struct:t make-t @struct:t t-ref t-set!))
(define (struct-field-accessor-name @struct:t i field-id)
(if field-id
(format "~a-~a" (object-name (struct-type-make @struct:t)) field-id)
(format "~a-field~a" (object-name (struct-type-make @struct:t)) i)))
(define (struct-field-mutator-name @struct:t i field-id)
(format "set-~a!" (struct-field-accessor-name @struct:t i field-id)))
(define (@make-struct-field-mutator struct:t i field-id)
(let* ([@struct:t (get-type struct:t)]
[native? (struct-type-native? @struct:t)]
[name (string->symbol (struct-field-mutator-name @struct:t i field-id))]
[setter (struct-type-set! @struct:t)]
[getter (struct-type-ref @struct:t)])
(procedure-rename
(lambda (receiver value)
(if (native? receiver)
(store! receiver i value getter setter)
(match (type-cast @struct:t receiver name)
[(? native? r) (store! r i value getter setter)]
[(union rs) (for ([r rs])
(store! (cdr r) i (merge (car r) value (getter (cdr r) i)) getter setter))])))
name)))
(define (@make-struct-field-accessor struct:t i field-id)
(let* ([@struct:t (get-type struct:t)]
[native? (struct-type-native? @struct:t)]
[name (string->symbol (struct-field-accessor-name @struct:t i field-id))]
[getter (struct-type-ref @struct:t)])
(procedure-rename
(lambda (receiver)
(if (native? receiver)
(getter receiver i)
(match (type-cast @struct:t receiver name)
[(? native? r) (getter r i)]
[(union r) (merge** r (getter _ i))])))
name)))
(struct struct-type (pred super native? make ref set! fields immutable? transparent? procedure? equal+hash)
#:property prop:procedure
[struct-field-index pred]
#:methods gen:type
[(define (least-common-supertype type other)
(or (and (eq? type other) type)
(and (eq? other @procedure?) (struct-type-procedure? type) @procedure?)
(and (not (struct-type? other)) @any/c)
(least-common-super-struct-type type other)
(and (struct-type-procedure? type) (struct-type-procedure? other) @procedure?)
@any/c))
(define (type-name type)
(object-name (struct-type-native? type)))
(define (type-applicable? type)
(struct-type-procedure? type))
(define (type-eq? type u v)
(or (eq? u v)
(and (struct-type-immutable? type)
(struct-type-transparent? type)
(not (struct-type-equal+hash type))
(struct=? type u v @eq?))))
(define (type-equal? type u v)
(struct=? type u v @equal?))
(define (type-cast self v [caller 'type-cast])
(adt-type-cast v #:type (struct-type-native? self) #:lifted self #:caller caller))
(define (type-compress type force? ps)
(if (or force? (and (struct-type-immutable? type)
(struct-type-transparent? type)
(not (struct-type-equal+hash type))))
(struct-compress type ps)
ps))
(define (type-construct type vals)
(apply (struct-type-make type) vals))
(define (type-deconstruct type val)
(struct->list type val))]
#:methods gen:custom-write
[(define (write-proc self port mode)
(fprintf port "~a" (type-name self)))])
(define (struct->list type val)
(let* ([getter (struct-type-ref type)]
[vals (for/list ([i (struct-type-fields type)]) (getter val i))]
[super (struct-type-super type)])
(if super (append (struct->list super val) vals) vals)))
(define (merge*-all getter ps fields)
(for/list ([i (in-range fields)])
(apply merge* (for/list ([p ps])
(cons (car p) (getter (cdr p) i))))))
(define (struct-compress pred ps)
(if (null? (cdr ps))
ps
(list (cons (apply || (map car ps))
(apply (struct-type-make pred)
(let loop ([type pred] [out '()])
(if type
(loop (struct-type-super type)
(append (merge*-all (struct-type-ref type)
ps
(struct-type-fields type))
out))
out)))))))
; Assumes that (subtype? (get-type v) type) and (equal? type (get-type u)).
(define (struct=? type u v =?)
(let ([e+h (equal+hash type)])
(if e+h
((vector-ref e+h 0) u v =?)
(and (struct-type-transparent? type)
(eq? type (get-type u))
(eq? type (get-type v))
(let loop ([type type])
(or (false? type)
(let ([getter (struct-type-ref type)])
(and-&&
(apply && (for/list ([i (struct-type-fields type)])
(=? (getter u i) (getter v i))))
(loop (struct-type-super type))))))))))
(define (equal+hash type)
(and type (or (struct-type-equal+hash type)
(equal+hash (struct-type-super type)))))
(define (least-common-super-struct-type type other)
(let outer ([t0 type])
(and t0
(or (let inner ([t1 other])
(and t1 (or (and (eq? t0 t1) t0)
(inner (struct-type-super t1)))))
(outer (struct-type-super t0))))))

952
rosette/base/struct/struct.rkt
View File

@ -1,952 +0,0 @@
#lang racket/base
;; Copied (with modifications) from racket/private/define-struct and racket/private/struct
(require racket/stxparam "struct-type.rkt"
(only-in "../core/type.rkt" gen:typed get-type)
racket/private/generic-methods; (except-in racket/private/generic-methods define/generic)
(for-syntax racket/base racket/struct-info racket/syntax
racket/private/procedure-alias "struct-type.rkt"))
(provide struct define/generic (rename-out [define-struct* define-struct]))
(define-syntax (struct stx)
(define (config-has-name? config)
(cond
[(syntax? config) (config-has-name? (syntax-e config))]
[(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name)
(eq? (syntax-e (car config)) '#:extra-constructor-name)
(config-has-name? (cdr config)))]
[else #f]))
(with-syntax ([orig stx])
(syntax-case stx ()
[(_ id super-id fields . config)
(and (identifier? #'id)
(identifier? #'super-id))
(if (not (config-has-name? #'config))
(syntax/loc stx
(define-struct/derived orig (id super-id) fields #:constructor-name id . config))
(syntax/loc stx
(define-struct/derived orig (id super-id) fields . config)))]
[(_ id fields . config)
(identifier? #'id)
(if (not (config-has-name? #'config))
(syntax/loc stx
(define-struct/derived orig id fields #:constructor-name id . config))
(syntax/loc stx
(define-struct/derived orig id fields . config)))]
[(_ id . rest)
(identifier? #'id)
(syntax/loc stx
(define-struct/derived orig id . rest))]
[(_ thing . _)
(raise-syntax-error #f
"expected an identifier for the structure type name"
stx
#'thing)])))
(#%provide define-struct*
define-struct/derived
struct-field-index
struct-copy
(for-syntax
(rename checked-struct-info-rec? checked-struct-info?)))
(define-values-for-syntax
(struct:struct-auto-info
make-struct-auto-info
struct-auto-info-rec?
struct-auto-info-ref
struct-auto-info-set!)
(make-struct-type 'struct-auto-info struct:struct-info
1 0 #f
(list (cons prop:struct-auto-info
(lambda (rec)
(struct-auto-info-ref rec 0))))))
(define-values-for-syntax
(struct:checked-struct-info
make-checked-struct-info
checked-struct-info-rec?
checked-struct-info-ref
checked-struct-info-set!)
(make-struct-type 'checked-struct-info struct:struct-auto-info
0 0 #f
null (current-inspector)
(lambda (v stx)
(raise-syntax-error
#f
"bad syntax;\n identifier for static struct-type information cannot be used as an expression"
stx))
null
(lambda (proc autos info)
(if (and (procedure? proc)
(procedure-arity-includes? proc 0))
(values proc autos)
(raise-argument-error 'make-struct-info
"(procedure-arity-includes/c 0)"
proc)))))
(define-for-syntax (self-ctor-transformer orig stx)
(define (transfer-srcloc orig stx)
(datum->syntax orig (syntax-e orig) stx orig))
(syntax-case stx ()
[(self arg ...) (datum->syntax stx
(cons
(syntax-property
(syntax-property (transfer-srcloc orig #'self)
'constructor-for
(syntax-local-introduce #'self))
alias-of (syntax-local-introduce #'self))
(syntax-e (syntax (arg ...))))
stx
stx)]
[self (identifier? #'self)
(syntax-property
(syntax-property (transfer-srcloc orig #'self)
'constructor-for
(syntax-local-introduce #'self))
alias-of (syntax-local-introduce #'self))]
[_ (transfer-srcloc orig stx)]))
(define-values-for-syntax (make-self-ctor-struct-info)
(letrec-values ([(struct: make- ? ref set!)
(make-struct-type 'self-ctor-struct-info struct:struct-auto-info
1 0 #f
(list (cons prop:procedure
(lambda (v stx)
(self-ctor-transformer ((ref v 0)) stx))))
(current-inspector) #f '(0))])
make-))
(define-values-for-syntax (make-self-ctor-checked-struct-info)
(letrec-values ([(struct: make- ? ref set!)
(make-struct-type 'self-ctor-checked-struct-info struct:checked-struct-info
1 0 #f
(list (cons prop:procedure
(lambda (v stx)
(self-ctor-transformer ((ref v 0)) stx))))
(current-inspector) #f '(0))])
make-))
(define-syntax-parameter struct-field-index
(lambda (stx)
(raise-syntax-error #f "allowed only within a structure type definition" stx)))
(define-for-syntax (make-struct-field-index fields)
(lambda (stx)
(syntax-case stx ()
[(_ id)
(identifier? #'id)
(let loop ([pos 0] [fields (syntax->list fields)])
(cond
[(null? fields)
(raise-syntax-error #f "no such field" stx #'name)]
[(free-identifier=? #'id (car fields))
(datum->syntax #'here pos stx)]
[else (loop (add1 pos) (cdr fields))]))])))
(define (check-struct-type name what)
(when what
(unless (struct-type? what)
(raise-argument-error name "(or/c struct-type? #f)" what)))
what)
(define (check-inspector name what)
(when what
(unless (inspector? what)
(raise-argument-error name "(or/c inspector? #f)" what)))
what)
(define (check-reflection-name name what)
(unless (symbol? what)
(raise-argument-error name "symbol?" what))
what)
(define-syntax (define-struct* stx)
(syntax-case stx ()
[(_ . rest)
(with-syntax ([stx stx])
#'(define-struct/derived stx . rest))]))
(define-syntax (define-struct/derived full-stx)
(define make-field list)
(define field-id car)
(define field-default-value cadr)
(define field-auto? caddr)
(define field-mutable? cadddr)
(define (build-name id . parts)
(datum->syntax
id
(string->symbol
(apply string-append
(map (lambda (p)
(if (syntax? p)
(symbol->string (syntax-e p))
p))
parts)))
id))
(define (bad why kw where . alt)
(raise-syntax-error
#f
(format "~a ~a specification~a"
why
(if (string? kw)
kw
(syntax-e kw))
where)
stx
(if (null? alt) kw (car alt))))
(define (check-exprs orig-n ps what)
(let loop ([nps (cdr ps)][n orig-n])
(unless (zero? n)
(unless (and (pair? nps)
(not (keyword? (syntax-e (car nps)))))
(raise-syntax-error
#f
(format "bad syntax;\n expected ~a ~a~a after keyword~a"
orig-n
(or what "expression")
(if (= orig-n 1) "" "s")
(if (pair? nps)
", found a keyword"
""))
stx
(car ps)))
(loop (cdr nps) (sub1 n)))))
;; Parse one field with a sequence of keyword-based specs:
(define (parse-field f)
(syntax-case f ()
[id
(identifier? #'id)
(make-field #'id #f #f #f)]
[(id p ...)
(identifier? #'id)
(let loop ([ps (syntax->list #'(p ...))]
[def-val #f]
[auto? #f]
[mutable? #f])
(cond
[(null? ps) (make-field #'id def-val auto? mutable?)]
[(eq? '#:mutable (syntax-e (car ps)))
(when mutable?
(bad "redundant" (car ps) " for field"))
(loop (cdr ps) def-val auto? #t)]
#;
[(eq? #:default (syntax-e (car ps)))
(check-exprs 1 ps #f)
(when def-val
(bad "multiple" (car ps) " for field"))
(loop (cddr ps) (cadr ps) auto? mutable?)]
[(eq? '#:auto (syntax-e (car ps)))
(when auto?
(bad "redundant" (car ps) " for field"))
(loop (cdr ps) def-val #t mutable?)]
[else
(raise-syntax-error
#f
(if (keyword? (syntax-e (car ps)))
"unrecognized field-specification keyword"
"expected a field-specification keyword")
stx
(car ps))]))]
[_else
(raise-syntax-error
#f
"bad syntax;\n expected a field identifier or a parenthesized identifier and field-specification sequence"
stx
f)]))
(define (lookup config s)
(cdr (assq s config)))
(define (extend-config config s val)
(cond
[(null? config) (error 'struct "internal error: can't find config element: ~s" s)]
[(eq? (caar config) s) (cons (cons s val) (cdr config))]
[else (cons (car config) (extend-config (cdr config) s val))]))
(define insp-keys
"#:inspector, #:transparent, or #:prefab")
;; Parse sequence of keyword-based struct specs
(define (parse-props fm p super-id)
(let loop ([p p]
[config '((#:super . #f)
(#:inspector . #f)
(#:auto-value . #f)
(#:props . ())
(#:mutable . #f)
(#:guard . #f)
(#:constructor-name . #f)
(#:reflection-name . #f)
(#:only-constructor? . #f)
(#:omit-define-values . #f)
(#:omit-define-syntaxes . #f))]
[nongen? #f])
(cond
[(null? p) config]
[(eq? '#:super (syntax-e (car p)))
(check-exprs 1 p #f)
(when (lookup config '#:super)
(bad "multiple" (car p) "s"))
(when super-id
(raise-syntax-error
#f
(string-append
"bad syntax;\n"
" #:super specification disallowed because a struct supertype id was\n"
" supplied with the struct type id")
stx
(car p)))
(loop (cddr p)
(extend-config config '#:super (cadr p))
nongen?)]
[(memq (syntax-e (car p))
'(#:guard #:auto-value))
(let ([key (syntax-e (car p))])
(check-exprs 1 p #f)
(when (lookup config key)
(bad "multiple" (car p) "s"))
(when (and nongen?
(eq? key '#:guard))
(bad "cannot provide" (car p) " for prefab structure type"))
(loop (cddr p)
(extend-config config key (cadr p))
nongen?))]
[(eq? '#:property (syntax-e (car p)))
(check-exprs 2 p #f)
(when nongen?
(bad "cannot use" (car p) " for prefab structure type"))
(loop (cdddr p)
(extend-config config
'#:props
(cons (cons (cadr p) (caddr p))
(lookup config '#:props)))
nongen?)]
[(eq? '#:methods (syntax-e (car p)))
;; #:methods gen:foo [(define (meth1 x ...) e ...) ...]
(check-exprs 2 p "argument")
(define gen-id (cadr p))
(define gen-defs (caddr p))
(define args (cdddr p))
(define gen-val
(and (identifier? gen-id)
(syntax-local-value gen-id (lambda () #f))))
(unless (generic-info? gen-val)
(bad "the first argument to the"
(car p)
" is not a name for a generic interface"
(cadr p)))
(loop (list* #'#:property
(quasisyntax/loc gen-id
(generic-property #,gen-id))
(quasisyntax/loc gen-id
(generic-method-table #,gen-id #,@gen-defs))
args)
config
nongen?)]
[(eq? '#:inspector (syntax-e (car p)))
(check-exprs 1 p #f)
(when (lookup config '#:inspector)
(bad "multiple" insp-keys "s" (car p)))
(loop (cddr p)
(extend-config config '#:inspector
#`(check-inspector '#,fm #,(cadr p)))
nongen?)]
[(eq? '#:transparent (syntax-e (car p)))
(when (lookup config '#:inspector)
(bad "multiple" insp-keys "s" (car p)))
(loop (cdr p)
(extend-config config '#:inspector #'#f)
nongen?)]
[(or (eq? '#:constructor-name (syntax-e (car p)))
(eq? '#:extra-constructor-name (syntax-e (car p))))
(check-exprs 1 p "identifier")
(when (lookup config '#:constructor-name)
(bad "multiple" "#:constructor-name or #:extra-constructor-name" "s" (car p)))
(unless (identifier? (cadr p))
(bad "need an identifier after" (car p) "" (cadr p)))
(loop (cddr p)
(extend-config (extend-config config '#:constructor-name (cadr p))
'#:only-constructor?
(eq? '#:constructor-name (syntax-e (car p))))
nongen?)]
[(eq? '#:reflection-name (syntax-e (car p)))
(check-exprs 1 p "expression")
(when (lookup config '#:reflection-name)
(bad "multiple" "#:reflection-name keys" (car p)))
(loop (cddr p)
(extend-config config '#:reflection-name (cadr p))
nongen?)]
[(eq? '#:prefab (syntax-e (car p)))
(when (lookup config '#:inspector)
(bad "multiple" insp-keys "s" (car p)))
(when (pair? (lookup config '#:props))
(bad "cannot use" (car p) " for a structure type with properties"))
(when (lookup config '#:guard)
(bad "cannot use" (car p) " for a structure type with a guard"))
(loop (cdr p)
(extend-config config '#:inspector #''prefab)
#t)]
[(memq (syntax-e (car p))
'(#:mutable #:omit-define-values #:omit-define-syntaxes))
(let ([key (syntax-e (car p))])
(when (lookup config key)
(bad "redundant" (car p) ""))
(loop (cdr p)
(extend-config config key #t)
nongen?))]
[else
(raise-syntax-error
#f
(if (keyword? (syntax-e (car p)))
"unrecognized struct-specification keyword"
"expected a struct-specification keyword")
stx
(car p))])))
(define stx (syntax-case full-stx ()
[(_ stx . _) #'stx]))
(syntax-case full-stx ()
[(_ (fm . _) id (field ...) prop ...)
(let-values ([(id super-id)
(if (identifier? #'id)
(values #'id #f)
(syntax-case #'id ()
[(id super-id)
(and (identifier? #'id)
(identifier? #'super-id))
(values #'id #'super-id)]
[else
(raise-syntax-error
#f
"bad syntax;\n expected <id> for structure-type name or (<id> <id>) for name and supertype\n name"
stx
#'id)]))])
(let-values ([(super-info super-autos super-info-checked?)
(if super-id
(let ([v (syntax-local-value super-id (lambda () #f))])
(if (struct-info? v)
(values (extract-struct-info v)
(if (struct-auto-info? v)
(struct-auto-info-lists v)
(list null null))
(checked-struct-info-rec? v))
(raise-syntax-error
#f
(format "parent struct type not defined~a"
(if v
";\n identifier does not name struct type information"
""))
stx
super-id)))
;; if there's no super type, it's like it was checked
(values #f #f #t))])
(when (and super-info
(not (car super-info)))
(raise-syntax-error
#f
"no structure type descriptor available for supertype"
stx
super-id))
(let* ([field-stxes (syntax->list #'(field ...))]
[fields (map parse-field field-stxes)]
[dup (check-duplicate-identifier (map field-id fields))])
(when dup
(raise-syntax-error
#f
"duplicate field identifier"
stx
dup))
(let ([auto-count
(let loop ([fields fields] [field-stxes field-stxes] [auto? #f])
(cond
[(null? fields) 0]
[(field-auto? (car fields))
(+ 1 (loop (cdr fields) (cdr field-stxes) #t))]
[auto?
(raise-syntax-error
#f
"non-auto field after an auto field disallowed"
stx
(car field-stxes))]
[else
(loop (cdr fields) (cdr field-stxes) #f)]))])
(let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only?
reflect-name-expr mutable?
omit-define-values? omit-define-syntaxes?)
(let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
(values (lookup config '#:inspector)
(lookup config '#:super)
(lookup config '#:props)
(lookup config '#:auto-value)
(lookup config '#:guard)
(lookup config '#:constructor-name)
(lookup config '#:only-constructor?)
(lookup config '#:reflection-name)
(lookup config '#:mutable)
(lookup config '#:omit-define-values)
(lookup config '#:omit-define-syntaxes)))]
[(self-ctor?)
(and ctor-name (bound-identifier=? id ctor-name))]
[(name-as-ctor?) (or self-ctor? (not ctor-only?))])
(when mutable?
(for-each (lambda (f f-stx)
(when (field-mutable? f)
(raise-syntax-error
#f
"redundant #:mutable specification in field"
stx
f-stx)))
fields field-stxes))
(let ([struct: (build-name id "struct:" id)]
[make- (if ctor-name
(if self-ctor?
(if omit-define-syntaxes?
ctor-name
(car (generate-temporaries (list id))))
ctor-name)
(build-name id "make-" id))]
[? (build-name id id "?")]
[sels (map (lambda (f)
(build-name id ; (field-id f)
id "-" (field-id f)))
fields)]
[super-struct: (if super-info
(or (car super-info)
(raise-syntax-error
#f
"no structure type descriptor available for supertype"
stx
super-id))
(and super-expr
#`(let ([the-super #,super-expr])
(if (struct-type? the-super)
the-super
(check-struct-type 'fm the-super)))))]
[prune (lambda (stx) (identifier-prune-lexical-context stx
(list (syntax-e stx) '#%top)))]
[reflect-name-expr (if reflect-name-expr
(quasisyntax (check-reflection-name 'fm #,reflect-name-expr))
(quasisyntax '#,id))])
(define struct-name-size (string-length (symbol->string (syntax-e id))))
(define struct-name/locally-introduced (syntax-local-introduce id))
(define struct-name-to-predicate-directive
(vector (syntax-local-introduce ?)
0
struct-name-size
struct-name/locally-introduced
0
struct-name-size))
(define struct-name-to-old-style-maker-directive
(if ctor-name
#f
(vector (syntax-local-introduce make-)
5
struct-name-size
struct-name/locally-introduced
0
struct-name-size)))
(define (struct-name-to-selector/mutator-directive id-stx selector?)
(vector (syntax-local-introduce id-stx)
(if selector? 0 4)
struct-name-size
struct-name/locally-introduced
0
struct-name-size))
(define (field-to-selector/mutator-directive field id-stx selector?)
(define fld-size (string-length (symbol->string (syntax-e (field-id field)))))
(vector (syntax-local-introduce id-stx)
(+ (if selector? 1 5) struct-name-size)
fld-size
(syntax-local-introduce (field-id field))
0
fld-size))
(define-values (sets field-to-mutator-directives)
(let loop ([fields fields])
(cond
[(null? fields) (values null null)]
[(not (or mutable? (field-mutable? (car fields))))
(loop (cdr fields))]
[else
(define-values (other-sets other-directives)
(loop (cdr fields)))
(define this-set
(build-name id ; (field-id (car fields))
"set-"
id
"-"
(field-id (car fields))
"!"))
(values (cons this-set other-sets)
(cons (field-to-selector/mutator-directive (car fields)
this-set
#f)
other-directives))])))
(define all-directives
(append
(list struct-name-to-predicate-directive)
(if struct-name-to-old-style-maker-directive
(list struct-name-to-old-style-maker-directive)
'())
field-to-mutator-directives
(map (λ (field sel)
(field-to-selector/mutator-directive field sel #t))
fields
sels)
(map (λ (sel)
(struct-name-to-selector/mutator-directive
sel
#t))
sels)
(map (λ (mut)
(struct-name-to-selector/mutator-directive
mut
#f))
sets)))
(let ([run-time-defns
(lambda ()
(quasisyntax/loc stx
(define-values (#,struct: #,make- #,? #,@sels #,@sets)
(let-values ([(struct: make- ? -ref -set!)
(syntax-parameterize ([struct-field-index
(make-struct-field-index (quote-syntax #,(map field-id fields)))])
(@make-struct-type #,reflect-name-expr
#,super-struct:
#,(- (length fields) auto-count)
#,auto-count
#,auto-val
#,(if (null? props)
#'null
#`(list #,@(map (lambda (p)
#`(cons #,(car p) #,(cdr p)))
props)))
#,(or inspector
#`(current-inspector))
#f
'#,(let loop ([i 0]
[fields fields])
(cond
[(null? fields) null]
[(field-auto? (car fields)) null]
[(not (or mutable? (field-mutable? (car fields))))
(cons i (loop (add1 i) (cdr fields)))]
[else (loop (add1 i) (cdr fields))]))
#,guard
'#,(if ctor-only? ctor-name id)))])
(values struct: make- ?
#,@(let loop ([i 0][fields fields])
(if (null? fields)
null
(cons #`(@make-struct-field-accessor struct: #,i '#,(field-id (car fields)))
(loop (add1 i) (cdr fields)))))
#,@(let loop ([i 0][fields fields])
(if (null? fields)
null
(if (not (or mutable? (field-mutable? (car fields))))
(loop (add1 i) (cdr fields))
(cons #`(@make-struct-field-mutator struct: #,i '#,(field-id (car fields)))
(loop (add1 i) (cdr fields)))))))))))]
[compile-time-defns
(lambda ()
(let* ([protect (lambda (sel)
(and sel
(if (syntax-e sel)
#`(quote-syntax #,(prune sel))
sel)))]
[include-autos? (or super-info-checked?
name-as-ctor?
(and super-autos
(or (pair? (car super-autos))
(pair? (cadr super-autos))))
(positive? auto-count))]
[mk-info (if super-info-checked?
(if name-as-ctor?
#'make-self-ctor-checked-struct-info
#'make-checked-struct-info)
(if name-as-ctor?
#'make-self-ctor-struct-info
(if include-autos?
#'make-struct-auto-info
#'make-struct-info)))])
(quasisyntax/loc stx
(define-syntaxes (#,id)
(#,mk-info
(lambda ()
(list
(quote-syntax #,(prune struct:))
(quote-syntax #,(prune (if (and ctor-name self-ctor?)
id
make-)))
(quote-syntax #,(prune ?))
(list
#,@(map protect (reverse sels))
#,@(if super-info
(map protect (list-ref super-info 3))
(if super-expr
'(#f)
null)))
(list
#,@(reverse
(let loop ([fields fields][sets sets])
(cond
[(null? fields) null]
[(not (or mutable? (field-mutable? (car fields))))
(cons #f (loop (cdr fields) sets))]
[else
(cons (protect (car sets))
(loop (cdr fields) (cdr sets)))])))
#,@(if super-info
(map protect (list-ref super-info 4))
(if super-expr
'(#f)
null)))
#,(if super-id
(protect super-id)
(if super-expr
#f
#t))))
#,@(if include-autos?
(list #`(list (list #,@(map protect
(list-tail sels (- (length sels) auto-count)))
#,@(if super-autos
(map protect (car super-autos))
null))
(list #,@(map protect
(list-tail sets (max 0 (- (length sets) auto-count))))
#,@(if super-autos
(map protect (cadr super-autos))
null))))
null)
#,@(if name-as-ctor?
(list #`(lambda () (quote-syntax #,make-)))
null))))))])
(let ([result
(cond
[(and (not omit-define-values?) (not omit-define-syntaxes?))
(if (eq? (syntax-local-context) 'top-level)
;; Top level: declare names to be bound by `define',
;; but put run-time expressions after `define-syntaxes'
;; to they can refer to bindings that are bound by
;; `define-syntaxes' (e.g. use of the constructor name
;; in the body of a property value that is a procedure)
#`(begin
(define-syntaxes (#,struct: #,make- #,? #,@sels #,@sets) (values))
#,(compile-time-defns)
#,(run-time-defns))
;; Other contexts: order should't matter:
#`(begin
#,(run-time-defns)
#,(compile-time-defns)))]
[omit-define-syntaxes?
(run-time-defns)]
[omit-define-values?
(compile-time-defns)]
[else #'(begin)])])
(syntax-protect
(syntax-property
(if super-id
(syntax-property result
'disappeared-use
(syntax-local-introduce super-id))
result)
'sub-range-binders
all-directives))))))))))]
[(_ _ id . _)
(not (or (identifier? #'id)
(and (syntax->list #'id)
(= 2 (length (syntax->list #'id)))
(andmap identifier? (syntax->list #'id)))))
(raise-syntax-error
#f
"bad syntax;\n expected <id> for structure-type name or (<id> <id>) for name and supertype\n name"
stx
#'id)]
[(_ _ id (field ...) . _)
(begin
(for-each parse-field (syntax->list #'(field ...)))
(raise-syntax-error
#f
"bad syntax after field sequence"
stx))]
[(_ _ id fields . _)
(raise-syntax-error
#f
"bad syntax;\n expected a parenthesized sequence of field descriptions"
stx
#'fields)]
[(_ _ id)
(raise-syntax-error
#f
"bad syntax;\n missing fields"
stx)]
[_
(raise-syntax-error
#f
"bad syntax"
stx)]))
(define-syntax (struct-copy stx)
(if (not (eq? (syntax-local-context) 'expression))
(quasisyntax/loc stx (#%expression #,stx))
(syntax-case stx ()
[(form-name info struct-expr field+val ...)
(let ([ans (syntax->list #'(field+val ...))])
;; Check syntax:
(unless (identifier? #'info)
(raise-syntax-error #f "not an identifier for structure type" stx #'info))
(for-each (lambda (an)
(syntax-case an ()
[(field val)
(unless (identifier? #'field)
(raise-syntax-error #f
"not an identifier for field name"
stx
#'field))]
[(field #:parent p val)
(unless (identifier? #'field)
(raise-syntax-error #f
"not an identifier for field name"
stx
#'field))
(unless (identifier? #'p)
(raise-syntax-error #f
"not an identifier for parent struct name"
stx
#'field))]
[_
(raise-syntax-error #f
(string-append
"bad syntax;\n"
" expected a field update of the form (<field-id> <expr>)\n"
" or (<field-id> #:parent <parent-id> <expr>)")
stx
an)]))
ans)
(let-values ([(construct pred accessors parent)
(let ([v (syntax-local-value #'info (lambda () #f))])
(unless (struct-info? v)
(raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
(let ([v (extract-struct-info v)])
(values (cadr v)
(caddr v)
(cadddr v)
(list-ref v 5))))])
(let* ([ensure-really-parent
(λ (id)
(let loop ([parent parent])
(cond
[(eq? parent #t)
(raise-syntax-error #f "identifier not bound to a parent struct" stx id)]
[(not parent)
(raise-syntax-error #f "parent struct information not known" stx id)]
[(free-identifier=? id parent) (void)]
[else
(let ([v (syntax-local-value parent (lambda () #f))])
(unless (struct-info? v)
(raise-syntax-error #f "unknown parent struct" stx id)) ;; probably won't happen(?)
(let ([v (extract-struct-info v)])
(loop (list-ref v 5))))])))]
[new-fields
(map (lambda (an)
(syntax-case an ()
[(field expr)
(list (datum->syntax #'field
(string->symbol
(format "~a-~a"
(syntax-e #'info)
(syntax-e #'field)))
#'field)
#'expr
(car (generate-temporaries (list #'field))))]
[(field #:parent id expr)
(begin
(ensure-really-parent #'id)
(list (datum->syntax #'field
(string->symbol
(format "~a-~a"
(syntax-e #'id)
(syntax-e #'field)))
#'field)
#'expr
(car (generate-temporaries (list #'field)))))]))
ans)]
;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
[new-binding-for
(lambda (f)
(ormap (lambda (new-field)
(and (free-identifier=? (car new-field) f)
(caddr new-field)))
new-fields))])
(unless construct
(raise-syntax-error #f
"constructor not statically known for structure type"
stx
#'info))
(unless pred
(raise-syntax-error #f
"predicate not statically known for structure type"
stx
#'info))
(unless (andmap values accessors)
(raise-syntax-error #f
"not all accessors are statically known for structure type"
stx
#'info))
(let ([dests
(map (lambda (new-field)
(or (ormap (lambda (f2)
(and f2
(free-identifier=? (car new-field) f2)
f2))
accessors)
(raise-syntax-error #f
"accessor name not associated with the given structure type"
stx
(car new-field))))
new-fields)])
;; Check for duplicates using dests, not as, because mod=? as might not be id=?
(let ((dupe (check-duplicate-identifier dests)))
(when dupe
(raise-syntax-error #f
"duplicate field assignment"
stx
;; Map back to an original field:
(ormap (lambda (nf)
(and nf
(free-identifier=? dupe (car nf))
(car nf)))
(reverse new-fields)))))
;; the actual result
#`(let ((the-struct struct-expr))
(if (#,pred the-struct)
(let #,(map (lambda (new-field)
#`[#,(caddr new-field) #,(cadr new-field)])
new-fields)
(#,construct
#,@(map
(lambda (field) (or (new-binding-for field)
#`(#,field the-struct)))
(reverse accessors))))
(raise-argument-error 'form-name
#,(format "~a?" (syntax-e #'info))
the-struct)))))))])))

469
rosette/guide/scribble/datatypes/bitvectors.scrbl
View File

@ -1,469 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/base/form/define
rosette/base/core/term
(only-in rosette/base/core/union union?)
(only-in rosette/base/base bv bv? bitvector bitvector? bitvector-size
bveq bvslt bvsgt bvsle bvsge bvult bvugt bvule bvuge
bvnot bvor bvand bvxor bvshl bvlshr bvashr
bvneg bvadd bvsub bvmul bvudiv bvsdiv bvurem bvsrem bvsmod
concat extract sign-extend zero-extend
integer->bitvector bitvector->integer bitvector->natural
bit lsb msb bvzero? bvadd1 bvsub1
bvsmin bvsmax bvumin bvumax
rotate-left rotate-right bvrol bvror
bool->bitvector bitvector->bool bitvector->bits
assert vc))
(for-label racket)
scribble/core scribble/html-properties scribble/examples racket/sandbox
"../util/lifted.rkt")
@(define rosette-eval (rosette-evaluator))
@title[#:tag "sec:bitvectors"]{Bitvectors}
@declare-exporting[rosette/base/base #:use-sources (rosette/base/base)]
Rosette extends Racket with a primitive bitvector datatype whose values are
fixed-size words---or, machine integers. Mainstream programming languages, such as
C or Java, support bitvector types with a few fixed sizes (e.g., 8 bits, 16 bits,
and 32 bits). Rosette supports bitvectors of arbitrary size, as well as both signed and
unsigned versions of various bitvector operations (such as comparisons, division, remainder, etc.).
Technically, Rosette's bitvector datatype embeds the
@hyperlink["http://smtlib.cs.uiowa.edu/logics-all.shtml#QF_BV"]{theory of bitvectors}
into a programming language.
@examples[#:eval rosette-eval
(code:line (bv 4 (bitvector 7)) (code:comment "A bitvector literal of size 7."))
(code:line (bv 4 7) (code:comment "A shorthand for the same literal."))
(code:line (define-symbolic x y (bitvector 7)) (code:comment "Symbolic bitvector constants."))
(code:line (bvslt (bv 4 7) (bv -1 7)) (code:comment "Signed 7-bit < comparison of 4 and -1."))
(code:line (bvult (bv 4 7) (bv -1 7)) (code:comment "Unsigned 7-bit < comparison of 4 and -1."))
(define-symbolic b boolean?)
(code:line (bvadd x (if b y (bv 3 4))) (code:comment "This typechecks only when b is true,"))
(code:line (vc) (code:comment "so Rosette emits a corresponding assertion."))]
@defproc[(bitvector [size (and/c integer? positive? (not/c term?) (not/c union?))]) bitvector?]{
Returns a type predicate that recognizes bitvectors of the given @racket[size].
Note that @racket[size] must be a concrete positive integer.
The type predicate itself is recognized by the @racket[bitvector?] predicate.
@examples[#:eval rosette-eval
(define bv6? (bitvector 6))
(bv6? 1)
(bv6? (bv 3 6))
(bv6? (bv 3 5))
(define-symbolic b boolean?)
(bv6? (if b (bv 3 6) #t))]
}
@defproc[(bitvector? [v any/c]) boolean?]{
Returns true if @racket[v] is a concrete type predicate that recognizes bitvector values.
@examples[#:eval rosette-eval
(define bv6? (bitvector 6))
(define bv7? (bitvector 7))
(define-symbolic b boolean?)
(code:line (bitvector? bv6?) (code:comment "A concrete bitvector type."))
(code:line (bitvector? (if b bv6? bv7?)) (code:comment "Not a concrete type."))
(code:line (bitvector? integer?) (code:comment "Not a bitvector type."))
(code:line (bitvector? 3) (code:comment "Not a type."))]}
@defproc[(bv [val (and/c integer? (not/c term?) (not/c union?))]
[size (and/c (or/c bitvector? (and/c integer? positive?))
(not/c term?) (not/c union?))]) bv?]{
Returns a bitvector literal of the given @racket[size], which may be given either as a
concrete @racket[bitvector?] type or a concrete positive integer.}
@defproc[(bv? [v any/c]) boolean?]{
Recognizes concrete or symbolic bitvector values of any size.
@examples[#:eval rosette-eval
(bv? 1)
(bv? (bv 1 1))
(bv? (bv 2 2))
(define-symbolic b boolean?)
(bv? (if b (bv 3 6) #t))]
}
@(rosette-eval '(clear-vc!))
@section{Comparison Operators}
@defproc*[([(bveq [x (bitvector n)] [y (bitvector n)]) boolean?]
[(bvslt [x (bitvector n)] [y (bitvector n)]) boolean?]
[(bvult [x (bitvector n)] [y (bitvector n)]) boolean?]
[(bvsle [x (bitvector n)] [y (bitvector n)]) boolean?]
[(bvule [x (bitvector n)] [y (bitvector n)]) boolean?]
[(bvsgt [x (bitvector n)] [y (bitvector n)]) boolean?]
[(bvugt [x (bitvector n)] [y (bitvector n)]) boolean?]
[(bvsge [x (bitvector n)] [y (bitvector n)]) boolean?]
[(bvuge [x (bitvector n)] [y (bitvector n)]) boolean?])]{
Compares two bitvector values of the same bitvector type.
Comparison relations include
equality (@racket[bveq]) and signed / unsigned versions of
<, <=, >, and >= (@racket[bvslt], @racket[bvult], @racket[bvsle], @racket[bvule],
@racket[bvsgt], and @racket[bvugt]).
@examples[#:eval rosette-eval
(code:line (define-symbolic u v (bitvector 7)) (code:comment "Symbolic bitvector constants."))
(code:line (bvslt (bv 4 7) (bv -1 7)) (code:comment "Signed 7-bit < comparison of 4 and -1."))
(code:line (bvult (bv 4 7) (bv -1 7)) (code:comment "Unsigned 7-bit < comparison of 4 and -1."))
(define-symbolic b boolean?)
(code:line (bvsge u (if b v (bv 3 4))) (code:comment "This typechecks only when b is true,"))
(code:line (vc) (code:comment "so Rosette emits a corresponding assertion."))]
}
@(rosette-eval '(clear-vc!))
@section{Bitwise Operators}
@defproc[(bvnot [x (bitvector n)]) (bitvector n)]{
Returns the bitwise negation of the given bitvector value.
@examples[#:eval rosette-eval
(bvnot (bv -1 4))
(bvnot (bv 0 4))
(define-symbolic b boolean?)
(code:line (bvnot (if b 0 (bv 0 4))) (code:comment "This typechecks only when b is false,"))
(code:line (vc) (code:comment "so Rosette emits a corresponding assertion."))]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(bvand [x (bitvector n)] ...+) (bitvector n)]
[(bvor [x (bitvector n)] ...+) (bitvector n)]
[(bvxor [x (bitvector n)] ...+) (bitvector n)])]{
Returns the bitwise ``and'', ``or'', ``xor'' of one or more bitvector values of the same type.
@examples[#:eval rosette-eval
(bvand (bv -1 4) (bv 2 4))
(bvor (bv 0 3) (bv 1 3))
(bvxor (bv -1 5) (bv 1 5))
(define-symbolic b boolean?)
(code:line
(bvand (bv -1 4)
(if b 0 (bv 2 4))) (code:comment "This typechecks only when b is false,"))
(code:line
(vc) (code:comment "so Rosette emits a corresponding assertion."))]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(bvshl [x (bitvector n)] [y (bitvector n)]) (bitvector n)]
[(bvlshr [x (bitvector n)] [y (bitvector n)]) (bitvector n)]
[(bvashr [x (bitvector n)] [y (bitvector n)]) (bitvector n)])]{
Returns the left, logical right, or arithmetic right shift of @racket[x] by
@racket[y] bits, where @racket[x] and @racket[y] are bitvector values of the same type.
@examples[#:eval rosette-eval
(bvshl (bv 1 4) (bv 2 4))
(bvlshr (bv -1 3) (bv 1 3))
(bvashr (bv -1 5) (bv 1 5))
(define-symbolic b boolean?)
(code:line (bvshl (bv -1 4)
(if b 0 (bv 2 4))) (code:comment "This typechecks only when b is false,"))
(code:line (vc) (code:comment "so Rosette emits a corresponding assertion."))]
}
@section{Arithmetic Operators}
@defproc[(bvneg [x (bitvector n)]) (bitvector n)]{
Returns the arithmetic negation of the given bitvector value.
@examples[#:eval rosette-eval
(bvneg (bv -1 4))
(bvneg (bv 0 4))
(define-symbolic z (bitvector 3))
(bvneg z)]
}
@(rosette-eval '(clear-vc!))
@(rosette-eval '(clear-terms!))
@defproc*[([(bvadd [x (bitvector n)] ...+) (bitvector n)]
[(bvsub [x (bitvector n)] ...+) (bitvector n)]
[(bvmul [x (bitvector n)] ...+) (bitvector n)])]{
Returns the sum, difference, or product of one or more bitvector values of the same type.
@examples[#:eval rosette-eval
(bvadd (bv -1 4) (bv 2 4))
(bvsub (bv 0 3) (bv 1 3))
(bvmul (bv -1 5) (bv 1 5))
(define-symbolic b boolean?)
(bvadd (bv -1 4) (bv 2 4) (if b (bv 1 4) "bad"))
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(bvsdiv [x (bitvector n)] [y (bitvector n)]) (bitvector n)]
[(bvudiv [x (bitvector n)] [y (bitvector n)]) (bitvector n)]
[(bvsrem [x (bitvector n)] [y (bitvector n)]) (bitvector n)]
[(bvurem [x (bitvector n)] [y (bitvector n)]) (bitvector n)]
[(bvsmod [x (bitvector n)] [y (bitvector n)]) (bitvector n)])]{
Returns (un)signed quotient, remainder, or modulo of two bitvector values of the same type.
All five operations are defined even when the second argument is zero.
@examples[#:eval rosette-eval
(bvsdiv (bv -3 4) (bv 2 4))
(bvudiv (bv -3 3) (bv 2 3))
(bvsmod (bv 1 5) (bv 0 5))
(define-symbolic b boolean?)
(bvsrem (bv -3 4) (if b (bv 2 4) "bad"))
(vc)]
}
@(rosette-eval '(clear-vc!))
@section{Conversion Operators}
@defproc[(concat [x bv?] ...+) bv?]{
Returns the bitwise concatenation of the given bitvector values.
@examples[#:eval rosette-eval
(concat (bv -1 4) (bv 0 1) (bv -1 3))
(define-symbolic b boolean?)
(concat (bv -1 4) (if b (bv 0 1) (bv 0 2)) (bv -1 3))]
}
@defproc[(extract [i integer?] [j integer?] [x (bitvector n)]) (bitvector (+ 1 (- i j)))]{
Extracts bits @racket[i] down to @racket[j] from a bitvector of size @racket[n], yielding a
bitvector of size i - j + 1. This procedure assumes that @racket[n] > @racket[i] >= @racket[j] >= 0.
@examples[#:eval rosette-eval
(extract 2 1 (bv -1 4))
(extract 3 3 (bv 1 4))
(define-symbolic i j integer?)
(extract i j (bv 1 2))
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(sign-extend [x bv?] [t (or/c bitvector? union?)]) bv?]
[(zero-extend [x bv?] [t (or/c bitvector? union?)]) bv?])]{
Returns a bitvector of type @racket[t] that represents the (un)signed
extension of the bitvector @racket[x].
Note that both @racket[x] and @racket[t] may be symbolic. The size of @racket[t]
must not be smaller than the size of @racket[x]'s type.
@examples[#:eval rosette-eval
(sign-extend (bv -3 4) (bitvector 6))
(zero-extend (bv -3 4) (bitvector 6))
(define-symbolic b c boolean?)
(zero-extend (bv -3 4) (if b (bitvector 5) (bitvector 6)))
(zero-extend (bv -3 4) (if b (bitvector 5) "bad"))
(vc)
(zero-extend (bv -3 4) (if c (bitvector 5) (bitvector 1)))
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(bitvector->integer [x bv?]) integer?]
[(bitvector->natural [x bv?]) integer?])]{
Returns the (un)signed integer value of the given bitvector.
@examples[#:eval rosette-eval
(bitvector->integer (bv -1 4))
(bitvector->natural (bv -1 4))
(define-symbolic b boolean?)
(bitvector->integer (if b (bv -1 3) (bv -3 4)))
(bitvector->integer (if b (bv -1 3) "bad"))
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(integer->bitvector [i integer?] [t (or/c bitvector? union?)]) bv?])]{
Returns a bitvector of type @racket[t] that represents the @var[k] lowest order bits
of the integer @racket[i], where @var[k] is the size of @racket[t].
Note that both @racket[i] and @racket[t] may be symbolic.
@examples[#:eval rosette-eval
(integer->bitvector 4 (bitvector 2))
(integer->bitvector 15 (bitvector 4))
(define-symbolic b c boolean?)
(integer->bitvector (if b pi 3) (if c (bitvector 5) (bitvector 6)))
(vc)]
}
@section{Additional Operators}
@(rosette-eval '(clear-vc!))
@defproc[(bit [i integer?] [x (bitvector n)]) (bitvector 1)]{
Extracts the @racket[i]th bit from the bitvector @racket[x] of size @racket[n], yielding a
bitvector of size 1. This procedure assumes that @racket[n] > @racket[i] >= 0.
@examples[#:eval rosette-eval
(bit 1 (bv 3 4))
(bit 2 (bv 1 4))
(define-symbolic i integer?)
(define-symbolic x (bitvector 4))
(bit i x)
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(lsb [x (bitvector n)]) (bitvector 1)]
[(msb [x (bitvector n)]) (bitvector 1)])]{
Returns the least or most significant bit of @racket[x].
@examples[#:eval rosette-eval
(lsb (bv 3 4))
(msb (bv 3 4))
(define-symbolic x (bitvector 4))
(define-symbolic y (bitvector 8))
(lsb (if b x y))
(msb (if b x y))
]
}
@(rosette-eval '(clear-vc!))
@defproc[(bvzero? [x (bitvector n)]) boolean?]{
Returns @racket[(bveq x (bv 0 n))].
@examples[#:eval rosette-eval
(define-symbolic x (bitvector 4))
(bvzero? x)
(define-symbolic y (bitvector 8))
(bvzero? y)
(define-symbolic b boolean?)
(bvzero? (if b x y))
]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(bvadd1 [x (bitvector n)]) (bitvector n)]
[(bvsub1 [x (bitvector n)]) (bitvector n)])]{
Returns @racket[(bvadd x (bv 1 n))] or @racket[(bvsub x (bv 1 n))].
@examples[#:eval rosette-eval
(define-symbolic x (bitvector 4))
(bvadd1 x)
(define-symbolic y (bitvector 8))
(bvsub1 y)
(define-symbolic b boolean?)
(bvadd1 (if b x y))
(bvsub1 (if b x y))
]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(bvsmin [x (bitvector n)] ...+) (bitvector n)]
[(bvumin [x (bitvector n)] ...+) (bitvector n)]
[(bvsmax [x (bitvector n)] ...+) (bitvector n)]
[(bvumax [x (bitvector n)] ...+) (bitvector n)])]{
Returns the (un)signed minimum or maximum of one or more bitvector values of the same type.
@examples[#:eval rosette-eval
(bvsmin (bv -1 4) (bv 2 4))
(bvumin (bv -1 4) (bv 2 4))
(bvsmax (bv -1 4) (bv 2 4))
(bvumax (bv -1 4) (bv 2 4))
(define-symbolic b boolean?)
(bvsmin (bv -1 4) (bv 2 4) (if b (bv 1 4) (bv 3 8)))
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(bvrol [x (bitvector n)] [y (bitvector n)]) (bitvector n)]
[(bvror [x (bitvector n)] [y (bitvector n)]) (bitvector n)])]{
Returns the left or right rotation of @racket[x] by @racket[(bvurem y n)] bits, where
@racket[x] and @racket[y] are bitvector values of the same type.
@examples[#:eval rosette-eval
(bvrol (bv 3 4) (bv 2 4))
(bvrol (bv 3 4) (bv -2 4))
(define-symbolic b boolean?)
(code:line
(bvror (bv 3 4)
(if b 0 (bv 2 4))) (code:comment "This typechecks only when b is false,"))
(code:line
(vc) (code:comment "so Rosette emits a corresponding assertion."))]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(rotate-left [i integer?] [x (bitvector n)]) (bitvector n)]
[(rotate-right [i integer?] [x (bitvector n)]) (bitvector n)])]{
Returns the left or right rotation of @racket[x] by @racket[i] bits.
These procedures assume that @racket[n] > @racket[i] >= 0. See @racket[bvrol]
and @racket[bvror] for an alternative way to perform rotations that usually
leads to faster solving times.
@examples[#:eval rosette-eval
(rotate-left 3 (bv 3 4))
(rotate-right 1 (bv 3 4))
(define-symbolic i integer?)
(define-symbolic b boolean?)
(rotate-left i (if b (bv 3 4) (bv 7 8)))
(vc)
]
}
@(rosette-eval '(clear-vc!))
@defproc[(bitvector->bits [x (bitvector n)]) (listof (bitvector 1))]{
Returns the bits of @racket[x] as a list, i.e., @racket[(list (bit 0 x) ... (bit (- n 1) x))].
@examples[#:eval rosette-eval
(bitvector->bits (bv 3 4))
(define-symbolic y (bitvector 2))
(bitvector->bits y)
(define-symbolic b boolean?)
(bitvector->bits (if b (bv 3 4) y)) ]
}
@defproc[(bitvector->bool [x (bitvector n)]) boolean?]{
Returns @racket[(not (bvzero? x))].
}
@(rosette-eval '(clear-vc!))
@defproc[(bool->bitvector [b any/c] [t (or/c positive-integer? (bitvector n)) (bitvector 1)]) bv?]{
Returns @racket[(bv 0 t)] if @racket[(false? b)] and otherwise returns @racket[(bv 1 t)], where
@racket[t] is @racket[(bitvector 1)] by default. If provided, @racket[t] must be a concrete positive
integer or a concrete bitvector type value.
@examples[#:eval rosette-eval
(bool->bitvector #f 3)
(bool->bitvector "non-false-value")
(define-symbolic b boolean?)
(bool->bitvector b)
]
}
@(kill-evaluator rosette-eval)

187
rosette/guide/scribble/datatypes/bools+ints+reals.scrbl
View File

@ -1,187 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/base/form/define rosette/query/form rosette/query/query rosette/solver/solution
rosette/base/core/term (only-in rosette/query/finitize current-bitwidth)
(only-in rosette/base/base ! && || => <=> exists forall function? assert vc with-vc
result-state result-value))
(except-in (for-label racket) =>)
scribble/core scribble/html-properties scribble/examples racket/sandbox racket/runtime-path
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "bools-log")))
@(define bools (select '(boolean? false? true false boolean=? not nand nor implies xor)))
@(define nums (select (remove* '(expt) '(number? complex? real? rational? integer? exact-integer? exact-nonnegative-integer? exact-positive-integer? inexact-real? fixnum? flonum? double-flonum? single-flonum? zero? positive? negative? even? odd? exact? inexact? inexact->exact exact->inexact real->single-flonum real->double-flonum + - * / quotient remainder quotient/ modulo add1 sub1 abs max min gcd lcm round floor ceiling truncate numerator denominator rationalize = < <= > >= sqrt integer-sqrt integer-sqrt/ expt exp log sin cos tan asin acos atan make-rectangular make-polar real-part imag-part magnitude angle bitwise-ior bitwise-and bitwise-xor bitwise-not bitwise-bit-set? bitwise-bit-field arithmetic-shift integer-length random random-seed make-pseudo-random-generator pseudo-random-generator? current-pseudo-random-generator pseudo-random-generator->vector vector->pseudo-random-generator vector->pseudo-random-generator! pseudo-random-generator-vector? number->string string->number real->decimal-string integer-bytes->integer integer->integer-bytes floating-point-bytes->real real->floating-point-bytes system-big-endian? pi pi.f degrees->radians radians->degrees sqr sgn conjugate sinh cosh tanh exact-round exact-floor exact-ceiling exact-truncate order-of-magnitude nan? infinite?))))
@title[#:tag "sec:bools+ints+reals"]{Booleans, Integers, and Reals}
@declare-exporting[rosette/base/base #:use-sources (rosette/base/base)]
Rosette lifts the following operations on booleans, integers, and reals:
@tabular[#:style (style #f (list (attributes '((id . "lifted")(class . "boxed")))))
(list (list @elem{Booleans} @bools)
(list @elem{Integers and Reals} @nums))]
Lifted boolean operations retain their Racket semantics on both concrete and symbolic values.
In particular, Rosette extends the intepretation of these operations to work on symbolic values in (logically) the
same way that they work on concrete values.
@examples[#:eval rosette-eval
(define-symbolic b boolean?)
(boolean? b)
(boolean? #t)
(boolean? #f)
(boolean? 1)
(code:line (not b) (code:comment "Produces a logical negation of b."))]
Lifted numeric operations, in contrast, match their Racket semantics
only when applied to concrete values. Their symbolic semantics depends on the
current @tech["reasoning precision"], as determined by the @racket[current-bitwidth]
parameter. In particular, if this parameter is set to @racket[#f], operations on symbolic numbers
retain their infinite-precision Racket semantics. However, because infinite-precision
reasoning is not efficiently (or at all) decidable for arbitrary numeric operations,
programs may need to set @racket[current-bitwidth] to a small positive integer @var[k].
With this setting, symbolic numbers are treated as signed @var[k]-bit integers. See
@secref{sec:reasoning-precision} for details and examples.
@section[#:tag "sec:extra-bools"]{Additional Logical Operators}
In addition to lifting Racket's operations on booleans,
Rosette supports the following logical operations:
conjunction (@racket[&&]), disjunction (@racket[||]),
implication (@racket[=>]), bi-implication (@racket[<=>]),
and negation (@racket[!]). These operations have their usual
logical meaning; e.g., unlike Racket's shortcircuiting
@racket[and] operator, the logical @racket[&&] operator
evaluates all of its arguments before taking their
conjunction.
@(rosette-eval '(clear-vc!))
@defproc[(! [v boolean?]) boolean?]{
Returns the negation of the given boolean value.
@examples[#:eval rosette-eval
(! #f)
(! #t)
(define-symbolic b boolean?)
(code:line (! (if b #f 3)) (code:comment "This typechecks only when b is true,"))
(code:line (vc) (code:comment "so Rosette emits a corresponding assertion."))]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(&& [v boolean?] ...) boolean?]
[(|| [v boolean?] ...) boolean?])]{
Returns the logical conjunction or disjunction of zero or more boolean values.
@examples[#:eval rosette-eval
(&&)
(||)
(code:line (&& #f (begin (displayln "hello") #t)) (code:comment "No shortcircuiting."))
(define-symbolic a b boolean?)
(code:line (&& a (if b #t 1)) (code:comment "This typechecks only when b is true,"))
(code:line (vc) (code:comment "so Rosette emits a corresponding assertion."))]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(=> [x boolean?] [y boolean?]) boolean?]
[(<=> [x boolean?] [y boolean?]) boolean?])]{
Returns the logical implication or bi-implication of two boolean values.
@examples[#:eval rosette-eval
(code:line (=> #f (begin (displayln "hello") #f)) (code:comment "No shortcircuiting."))
(define-symbolic a b boolean?)
(code:line (<=> a (if b #t 1)) (code:comment "This typechecks only when b is true,"))
(code:line (vc) (code:comment "so Rosette emits a corresponding assertion."))]
}
@section[#:tag "sec:quantifiers"]{Quantifiers}
Rosette also provides constructs for creating universally
(@racket[forall]) and existentially (@racket[exists])
quantified formulas. These differ from the usual logical
quantifiers in that the evaluation of a quantified formula's
body may have side effects (e.g., generate assertions). When
there are no side effects, however, these constructs have
their usual logical meaning.
@(rosette-eval '(clear-vc!))
@(rosette-eval '(current-bitwidth #f))
@defproc*[([(forall [vs (listof constant?)] [body boolean?]) boolean?]
[(exists [vs (listof constant?)] [body boolean?]) boolean?])]{
Returns a universally or existentially @deftech{quantified formula}, where the
symbolic constants @racket[vs] are treated as quantified variables.
Each constant in @racket[vs] must have a non-@racket[function?] @racket[solvable?] type.
The @racket[body] argument is a boolean value, which is usually a symbolic
boolean expression over the quantified variables @racket[vs] and,
optionally, over free symbolic (Skolem) constants. Any assertions and assumptions emitted during
the evaluation of @racket[body] are added to the current verification condition @racket[(vc)].
This may be the desired behavior in some circumstances but not in others, so to avoid
surprises, it is best to handle side effects separately and call quantifiers
with pure bodies, as shown below.
@examples[#:eval rosette-eval
(current-bitwidth #f)
(define-symbolic x y integer?)
(code:line
(exists (list x y) (= x y)) (code:comment "Pure body expression."))
(define-symbolic b boolean?)
(code:line
(forall (list b x y)
(= (+ (if b x 'x) 1) y)) (code:comment "Body emits a type assertion."))
(vc)
(clear-vc!)
(code:comment "To avoid surprises, capture assertions and assumptions using with-vc,")
(code:comment "and handle as desired, e.g.:")
(define out (with-vc (= (+ (if b x 'x) 1) y)))
out
(define out-val (result-value out))
(define out-vc (result-state out))
(forall (list b x y)
(=> (&& (vc-assumes out-vc) (vc-asserts out-vc)) out-val))
(vc)
]
The usual lexical scoping rules apply to quantified symbolics; if @racket[body] is
a quantified formula over a variable @var[v] in @racket[vs], then the
innermost quantification of @var[v] shadows any enclosing quantifications.
Quantified symbolics are not bound in a @racket[model], unless they also appear
freely in some formulas.
@examples[#:eval rosette-eval
(define-symbolic x y integer?)
(code:line
(define f
(forall (list x)
(exists (list y)
(= x (+ x y))))) (code:comment "x and y are not free in f,"))
(code:line
(solve (assert f)) (code:comment "so they are not bound in the model."))
(code:line
(define g
(forall (list x)
(= x (+ x y)))) (code:comment "y is free in g,"))
(code:line
(solve (assert g)) (code:comment "so it is bound in the model."))
(code:line
(define h
(exists (list x)
(forall (list x)
(= x (+ x x))))) (code:comment "The body of h refers to the innermost x,"))
(code:line
(solve (assert h)) (code:comment "so h is unsatisfiable."))
]
When executing queries over assertions that contain quantified formulas,
the @racket[current-bitwidth] parameter must be set to @racket[#f].
Quantified formulas may not appear in any assertion or assumption that is passed
to a @racket[synthesize] query.
}
@(kill-evaluator rosette-eval)

238
rosette/guide/scribble/datatypes/bools-log.txt
View File

@ -1,238 +0,0 @@
;; This file was created by make-log-based-eval
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((boolean? b) ((3) 0 () 0 () () (q values #t)) #"" #"")
((boolean? #t) ((3) 0 () 0 () () (q values #t)) #"" #"")
((boolean? #f) ((3) 0 () 0 () () (q values #t)) #"" #"")
((boolean? 1) ((3) 0 () 0 () () (q values #f)) #"" #"")
((not b)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(! b)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((! #f) ((3) 0 () 0 () () (q values #t)) #"" #"")
((! #t) ((3) 0 () 0 () () (q values #f)) #"" #"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((! (if b #f 3)) ((3) 0 () 0 () () (q values #t)) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t b)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((&&) ((3) 0 () 0 () () (q values #t)) #"" #"")
((||) ((3) 0 () 0 () () (q values #f)) #"" #"")
((&& #f (begin (displayln "hello") #t))
((3) 0 () 0 () () (q values #f))
#"hello\n"
#"")
((define-symbolic a b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((&& a (if b #t 1))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "a\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t b)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((=> #f (begin (displayln "hello") #f))
((3) 0 () 0 () () (q values #t))
#"hello\n"
#"")
((define-symbolic a b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((<=> a (if b #t 1))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "a\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t b)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((current-bitwidth #f) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((current-bitwidth #f) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x y integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((exists (list x y) (= x y))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(exists (x y) (= x y))\n"))))
#""
#"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((forall (list b x y) (= (+ (if b x 'x) 1) y))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(forall (b x y) (= y (+ 1 x)))\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t b)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define out (with-vc (= (+ (if b x 'x) 1) y)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(out
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(normal (= y (+ 1 x)) (vc #t b))\n"))))
#""
#"")
((define out-val (result-value out))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define out-vc (result-state out))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((forall
(list b x y)
(=> (&& (vc-assumes out-vc) (vc-asserts out-vc)) out-val))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(forall (b x y) (|| (! b) (= y (+ 1 x))))\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((define-symbolic x y integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define f (forall (list x) (exists (list y) (= x (+ x y)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((solve (assert f))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model)\n"))))
#""
#"")
((define g (forall (list x) (= x (+ x y))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((solve (assert g))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [y 0])\n"))))
#""
#"")
((define h (exists (list x) (forall (list x) (= x (+ x x)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((solve (assert h))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")

54
rosette/guide/scribble/datatypes/boxes-log.txt
View File

@ -1,54 +0,0 @@
;; This file was created by make-log-based-eval
((define v1 (box 1)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define v2 (box 1)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((eq? v1 v2) ((3) 0 () 0 () () (q values #f)) #"" #"")
((equal? v1 v2) ((3) 0 () 0 () () (q values #t)) #"" #"")
((define v3 (box-immutable 1)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define v4 (box-immutable 1)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((eq? v3 v4) ((3) 0 () 0 () () (q values #t)) #"" #"")
((equal? v1 v3) ((3) 0 () 0 () () (q values #t)) #"" #"")
((define-symbolic x integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define v1 (box x)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define v2 (if b v1 (box 3))) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define sol (solve (assert (= 4 (unbox v2)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(sol
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 4]\n [b #t])\n"))))
#""
#"")
((evaluate v1 sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'#&4\n"))))
#""
#"")
((evaluate v2 sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'#&4\n"))))
#""
#"")
((evaluate (eq? v1 v2) sol) ((3) 0 () 0 () () (q values #t)) #"" #"")

46
rosette/guide/scribble/datatypes/boxes.scrbl
View File

@ -1,46 +0,0 @@
#lang scribble/manual
@(require (for-label rosette/base/form/define rosette/query/query racket
(only-in rosette/base/base assert))
scribble/core scribble/html-properties scribble/examples racket/sandbox racket/runtime-path
"../util/lifted.rkt")
@(define box-ops (select '(box? box box-immutable unbox set-box! box-cas!)))
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "boxes-log")))
@title[#:tag "sec:box"]{Boxes}
A box is a single (im)mutable storage cell, which behaves like a one-element (im)mutable @seclink["sec:vec"]{vector}.
Like vectors, immutable boxes are treated as transparent immutable values: they are @racket[eq?] when their
contents are @racket[eq?]. Mutable boxes are references rather than values, so they are @racket[eq?] only when
they point to the same box object. Boxes can be concrete or symbolic, and they can contain both symbolic and concrete values.
@examples[#:eval rosette-eval
(define v1 (box 1))
(define v2 (box 1))
(eq? v1 v2)
(equal? v1 v2)
(define v3 (box-immutable 1))
(define v4 (box-immutable 1))
(eq? v3 v4)
(equal? v1 v3)
]
@examples[#:eval rosette-eval
(define-symbolic x integer?)
(define-symbolic b boolean?)
(code:line (define v1 (box x)) (code:comment "v1 is a box with symbolic contents."))
(code:line (define v2 (if b v1 (box 3))) (code:comment "v2 is a symbolic box."))
(define sol (solve (assert (= 4 (unbox v2)))))
sol
(evaluate v1 sol)
(evaluate v2 sol)
(evaluate (eq? v1 v2) sol)]
Lifted box operations are shown below.
@tabular[#:style (style #f (list (attributes '((id . "lifted")(class . "boxed")))))
(list (list @box-ops))]
@(kill-evaluator rosette-eval)

46
rosette/guide/scribble/datatypes/builtin-datatypes.scrbl
View File

@ -1,46 +0,0 @@
#lang scribble/manual
@(require (for-label racket)
(for-label rosette/base/form/define rosette/base/core/type))
@title[#:tag "ch:built-in-datatypes" #:style 'toc]{Built-In Datatypes}
The @seclink["ch:syntactic-forms"]{previous chapter} describes the
Racket syntax forms that are @tech[#:key "lifted constructs"]{lifted} by Rosette to
work on symbolic values.
This chapter describes the lifted datatypes and their corresponding operations. Most
lifted operations retain their Racket semantics, with the exception of
equality predicates (Section @seclink["sec:equality"]{4.1}) and
numeric operations (Section @seclink["sec:bools+ints+reals"]{4.2}).
Rosette distinguishes between two kinds of built-in datatypes:
@deftech[#:key "solvable type"]{solvable} and @deftech[#:key "unsolvable type"]{unsolvable}.
Solvable types are (efficiently) supported by SMT solvers, and they include booleans,
integers, reals, bitvectors, and uninterpreted functions. All other built-in types are
unsolvable---that is, not as well supported by SMT solvers.
Every lifted type is equipped with a predicate (e.g., @racket[boolean?]) that
recognizes values of that type. Solvable types are themselves recognized by
the @racket[solvable?] predicate. Lifted types include both concrete Racket
values and symbolic Rosette values, but only solvable types include
@tech[#:key "symbolic constant"]{symbolic constants},
as introduced by @seclink["sec:symbolic-constants"]{@code{define-symbolic[*]}}.
@(table-of-contents)
@include-section["equality.scrbl"]
@include-section["bools+ints+reals.scrbl"]
@include-section["bitvectors.scrbl"]
@include-section["uninterpreted.scrbl"]
@include-section["procedures.scrbl"]
@include-section["pairs.scrbl"]
@include-section["vectors.scrbl"]
@include-section["boxes.scrbl"]
@include-section["solvers+solutions.scrbl"]

114
rosette/guide/scribble/datatypes/defined-datatypes-log.txt
View File

@ -1,114 +0,0 @@
;; This file was created by make-log-based-eval
((struct point (x y) #:transparent)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((struct pt (x y)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((struct pnt (x y) #:mutable #:transparent)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((eq? (point 1 2) (point 1 2)) ((3) 0 () 0 () () (q values #t)) #"" #"")
((eq? (pt 1 2) (pt 1 2)) ((3) 0 () 0 () () (q values #f)) #"" #"")
((eq? (pnt 1 2) (pnt 1 2)) ((3) 0 () 0 () () (q values #f)) #"" #"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define p (if b (point 1 2) (point 3 4)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((point-x p)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(ite b 1 3)\n"))))
#""
#"")
((point-y p)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(ite b 2 4)\n"))))
#""
#"")
((define sol (solve (assert (= (point-x p) 3))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate p sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(point 3 4)\n"))))
#""
#"")
((define-generics viewable (view viewable))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((struct
square
(side)
#:methods
gen:viewable
((define (view self) (square-side self))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((struct
circle
(radius)
#:transparent
#:methods
gen:viewable
((define (view self) (circle-radius self))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define p (if b (square 2) (circle 3)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((view p)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(ite b 2 3)\n"))))
#""
#"")
((define sol (solve (assert (= (view p) 3))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate p sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(circle 3)\n"))))
#""
#"")

89
rosette/guide/scribble/datatypes/defined-datatypes.scrbl
View File

@ -1,89 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/base/form/define rosette/query/query
rosette/base/core/term (only-in rosette/base/base assert)
racket racket/generic)
scribble/core scribble/html-properties scribble/examples racket/sandbox racket/runtime-path
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "defined-datatypes-log")))
@(define prop-facilities (select '(make-struct-type-property struct-type-property? struct-type-property-accessor-procedure?)))
@(define props (select '(prop:arity-string prop:blame prop:chaperone-contract prop:chaperone-unsafe-undefined prop:checked-procedure prop:contract prop:contracted prop:custom-print-quotable prop:custom-write prop:dict prop:dict/contract prop:equal+hash prop:evt prop:exn:missing-module prop:exn:srclocs prop:flat-contract prop:impersonator-of prop:input-port prop:legacy-match-expander prop:liberal-define-context prop:match-expander prop:output-port prop:place-location prop:procedure prop:provide-pre-transformer prop:provide-transformer prop:rename-transformer prop:require-transformer prop:sequence prop:serializable prop:set!-transformer prop:stream prop:struct-auto-info prop:struct-info)))
@(define generics-facilities (select '(define-generics raise-support-error exn:fail:support define/generic generic-instance/c impersonate-generics chaperone-generics redirect-generics )))
@(define generics (select '(gen:custom-write gen:dict gen:equal+hash gen:set gen:stream)))
@title[#:tag "ch:programmer-defined-datatypes" #:style 'toc]{Structures}
In addition to @tech[#:key "lifted constructs"]{lifting} many
@seclink["ch:built-in-datatypes"]{built-in datatypes}
to work with symbolic values, Rosette also lifts Racket's
@racketlink[struct]{structures}.
As in Racket, a structure is an instance of a @deftech{structure type}---a
record datatype with zero or more fields.
Structure types are defined using the @racket[struct] syntax. Defining a
structure type in this way also defines the necessary procedures for
creating instances of that type and for accessing their fields.
@examples[#:eval rosette-eval #:label #f
(struct point (x y) #:transparent) (code:comment "Immutable transparent type.")
(struct pt (x y)) (code:comment "Opaque immutable type.")
(struct pnt (x y) #:mutable #:transparent) (code:comment "Mutable transparent type.")]
Rosette structures can be concrete or symbolic. Their semantics matches that of Racket,
with one important exception: immutable transparent structures are treated as values
rather than references. This @seclink["sec:equality"]{means} that two such structures are
@racket[eq?] if they belong to the same type and their corresponding field values are @racket[eq?].
Structures of opaque or mutable types are treated as references. Two such structures are
@racket[eq?] only if the point to the same instance of the same type.
@examples[#:eval rosette-eval #:label #f
(code:line (eq? (point 1 2) (point 1 2)) (code:comment "point structures are values."))
(code:line (eq? (pt 1 2) (pt 1 2)) (code:comment "pt structures are references."))
(code:line (eq? (pnt 1 2) (pnt 1 2)) (code:comment "pnt structures are references."))]
Like @tech[#:key "unsolvable type"]{unsolvable built-in datatypes},
symbolic structures cannot be created using @racket[define-symbolic]. Instead,
they are created implicitly, by, for example, using an @racket[if] expression
together with a symbolic value.
@examples[#:eval rosette-eval #:label #f
(define-symbolic b boolean?)
(code:line (define p (if b (point 1 2) (point 3 4))) (code:comment "p holds a symbolic structure."))
(point-x p)
(point-y p)
(define sol (solve (assert (= (point-x p) 3))))
(evaluate p sol)]
As well as lifting the @racket[struct] syntax, Rosette also lifts the following structure
properties, generic interfaces, and facilities for defining new properties and interfaces:
@tabular[#:style (style #f (list (attributes '((id . "lifted")(class . "boxed")))))
(list (list @elem{Defining Properties} @elem{@prop-facilities})
(list @elem{Lifted Properties} @elem{@props})
(list @elem{Defining Generics} @elem{@generics-facilities})
(list @elem{Lifted Generics} @elem{@generics} ))]
Lifted generics work as expected with symbolic values:
@examples[#:eval rosette-eval #:label #f
(define-generics viewable (view viewable))
(struct square (side)
#:methods gen:viewable
[(define (view self) (square-side self))])
(struct circle (radius)
#:transparent
#:methods gen:viewable
[(define (view self) (circle-radius self))])
(define-symbolic b boolean?)
(code:line (define p (if b (square 2) (circle 3))) (code:comment "p holds a symbolic structure."))
(view p)
(define sol (solve (assert (= (view p) 3))))
(evaluate p sol)]
@(kill-evaluator rosette-eval)

81
rosette/guide/scribble/datatypes/equality.scrbl
View File

@ -1,81 +0,0 @@
#lang scribble/manual
@(require (for-label rosette/base/form/define racket)
(for-label (only-in rosette/base/base function? distinct? ~> bv))
scribble/core scribble/html-properties scribble/examples racket/sandbox
"../util/lifted.rkt")
@(define rosette-eval (rosette-evaluator))
@title[#:tag "sec:equality"]{Equality}
@declare-exporting[rosette/base/base #:use-sources (rosette/base/base)]
Rosette supports two generic equality predicates, @racket[eq?] and @racket[equal?].
The @racket[equal?] predicate follows the Racket semantics, extended to work with symbolic values.
In particular, two values are @racket[equal?] only when they are @racket[eq?], unless a more permissive
notion of @racket[equal?] is specified for a particular datatype.
@examples[#:eval rosette-eval
(equal? 1 #t)
(equal? 1 1.0)
(equal? (list 1) (list 1.0))
(equal? (box 1) (box 1))
(equal? (list (box 1)) (list (box 1)))
(define-symbolic n integer?)
(equal? n 1)
(equal? (box n) (box 1))
(define-symbolic f g (~> integer? integer?))
(code:line (equal? f g) (code:comment "f and g are different procedures."))]
@(kill-evaluator rosette-eval)
@(set! rosette-eval (rosette-evaluator))
The @racket[eq?] predicate follows the Racket semantics for opaque or mutable datatypes,
such as procedures or vectors, but not for transparent immutable datatypes, such as
lists, or transparent solvable types, such as reals.
Rosette treats these transparent types as @emph{value types},
while Racket does not. Racket's @racket[eq?] may therefore return @racket[#f] when
given two instances of such a transparent type, regardless of their contents.
Rosette's @racket[eq?], in contrast, returns true when given two
transparent solvable values that are @racket[equal?],
or two transparent immutable values with @racket[eq?] contents.
@examples[#:eval rosette-eval
(eq? 1 #t)
(code:line (eq? 1 1.0) (code:comment "equal? transparent solvable values."))
(code:line (eq? (list 1) (list 1.0)) (code:comment "Transparent immutable values with eq? contents."))
(code:line (eq? (box 1) (box 1)) (code:comment "But boxes are mutable, so eq? follows Racket,"))
(eq? (list (box 1)) (list (box 1)))
(define-symbolic n integer?)
(eq? n 1)
(eq? (box n) (box 1))
(define-symbolic f g (~> integer? integer?))
(code:line (eq? f g) (code:comment "and procedures are opaque, so eq? follows Racket."))
(eq? f f)]
In addition to lifting Racket's equality predicates, Rosette also provides a @racket[distinct?] predicate
that returns true iff all of its arguments are distinct from each other. Invoking this predicate
on arbitrary values has the effect of performing O(@var[N]@superscript{2}) equality
comparisons. But when applied to symbolic values of a primitive
@tech[#:key "solvable type"]{solvable} type, @racket[distinct?] will produce a compact
symbolic value that can be directly solved by the underlying solver.
@(rosette-eval '(clear-vc!))
@defproc[(distinct? [v any/c] ...) boolean?]{
Returns true iff all of the given values @racket[v] are distinct---i.e., pairwise un-@racket[equal?]
to each other. If all values @racket[v] are of the same primitive (non-@racket[function?])
@tech[#:key "solvable type"]{solvable} type, this predicate produces a compact
constraint that can be more efficiently solved by the underlying solver. Otherwise, it performs, O(@var[N]@superscript{2}) inequality comparisons.
@examples[#:eval rosette-eval
(distinct?)
(distinct? 1)
(distinct? (list 1 2) (list 3) (list 1 2))
(define-symbolic x y z integer?)
(distinct? 3 z x y 2)
(define-symbolic b boolean?)
(distinct? 3 (bv 3 4) (list 1) (list x) y 2)]
}
@(kill-evaluator rosette-eval)

83
rosette/guide/scribble/datatypes/pairs-log.txt
View File

@ -1,83 +0,0 @@
;; This file was created by make-log-based-eval
((define-symbolic x y z n integer?)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define xs (take (list x y z) n))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define sol (solve (assert (null? xs))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate xs sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'()\n"))))
#""
#"")
((define sol
(solve
(begin
(assert (= (length xs) 2))
(assert (not (equal? xs (reverse xs))))
(assert (equal? xs (sort xs <))))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate xs sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'(-1 0)\n"))))
#""
#"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define p (if b (cons 1 2) (cons 4 #f)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define sol (solve (assert (boolean? (cdr p)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate p sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'(4 . #f)\n"))))
#""
#"")
((define sol (solve (assert (odd? (car p)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate p sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'(1 . 2)\n"))))
#""
#"")

193
rosette/guide/scribble/datatypes/pairs.scrbl
View File

@ -1,193 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/base/form/define rosette/query/query
rosette/base/core/term
(only-in rosette/base/base assert vc clear-vc! define-symbolic
length-bv list-ref-bv list-set-bv
take-bv take-right-bv
drop-bv drop-right-bv
list-tail-bv split-at-bv split-at-right-bv
union? bitvector bitvector? bv?
bitvector->natural integer->bitvector)
racket)
scribble/core scribble/html-properties scribble/examples racket/sandbox racket/runtime-path
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "pairs-log")))
@(define pairs:constructors+selectors (select '(pair? null? cons car cdr null list? list list* build-list)))
@(define list-operations (select '(length list-ref list-tail append reverse)))
@(define list-iteration (select '(map andmap ormap for-each foldl foldr)))
@(define list-filtering (select '(filter remove remq remv remove* remq* remv* sort)))
@(define list-searching (select '(member memv memq memf findf assoc assv assq assf)))
@(define more-pair-ops (select '(caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr)))
@(define more-list-ops (select '(empty cons? empty? first rest second third fourth fifth sixth seventh eighth ninth tenth last last-pair make-list take drop split-at takef dropf splitf-at take-right drop-right split-at-right takef-right dropf-right splitf-at-right add-between append* flatten remove-duplicates filter-map count partition range append-map filter-not shuffle permutations in-permutations argmin argmax list-set)))
@title[#:tag "sec:pair"]{Pairs and Lists}
A pair combines two values, and a list is either the
constant @racket[null] or a pair whose second
element is a list. Pairs and lists are transparent immutable values, and they may
be concrete or symbolic.
Two pairs or two lists are @racket[eq?] (resp. @racket[equal?])
if their corresponding elements are @racket[eq?] (resp. @racket[equal?]).
As values of @tech[#:key "unsolvable type"]{unsolvable types}, symbolic pairs
and lists cannot be created
via @seclink["sec:symbolic-constants"]{@code{define-symbolic[*]}}.
Instead, they are created by applying pair- or list-producing procedures to symbolic inputs,
or by controlling the application of such procedures with symbolic values. This
pattern for creating non-primitive symbolic values generalizes to all unsolvable datatypes.
@examples[#:eval rosette-eval
(define-symbolic x y z n integer?)
(code:line (define xs (take (list x y z) n)) (code:comment "(1) xs is a symbolic list."))
(define sol (solve (assert (null? xs))))
(evaluate xs sol)
(define sol
(solve (begin
(assert (= (length xs) 2))
(assert (not (equal? xs (reverse xs))))
(assert (equal? xs (sort xs <))))))
(evaluate xs sol)]
@examples[#:eval rosette-eval
(define-symbolic b boolean?)
(code:line (define p (if b (cons 1 2) (cons 4 #f))) (code:comment "(2) p is a symbolic pair."))
(define sol (solve (assert (boolean? (cdr p)))))
(evaluate p sol)
(define sol (solve (assert (odd? (car p)))))
(evaluate p sol)
]
@section{Lifted Operations on Pairs and Lists}
Rosette lifts the following operations on pairs and lists:
@tabular[#:style (style #f (list (attributes '((id . "lifted")(class . "boxed")))))
(list (list @elem{Pair Operations} @pairs:constructors+selectors)
(list @elem{List Operations} @list-operations)
(list @elem{List Iteration} @list-iteration)
(list @elem{List Filtering} @list-filtering)
(list @elem{List Searching} @list-searching)
(list @elem{Additional Pair Operations} @more-pair-ops)
(list @elem{Additional List Operations} @more-list-ops))]
@(kill-evaluator rosette-eval)
@(set! rosette-eval (rosette-evaluator))
@section{Additional Operations on Pairs and Lists}
Rosette provides the following procedures for operating on lists using @seclink["sec:bitvectors"]{bitvector} indices and lengths. These procedures produce symbolic values that avoid @racketlink[bitvector->natural]{casting} their bitvector arguments to integers, leading to @seclink["sec:notes"]{more efficiently solvable queries}.
@declare-exporting[rosette/base/base #:use-sources (rosette/base/base)]
@defproc[(length-bv [lst list?] [t (or/c bitvector? union?)]) bv?]{
Equivalent to @racket[(integer->bitvector (length lst) t)] but avoids the @racket[integer->bitvector] cast for better solving performance.
@examples[#:eval rosette-eval
(define-symbolic b boolean?)
(define xs (if b '(1 2) '(3 4 5 6)))
xs
(integer->bitvector (length xs) (bitvector 4))
(length-bv xs (bitvector 4))]
}
@defproc[(list-ref-bv [lst list?] [pos bv?]) any/c]{
Equivalent to @racket[(list-ref lst (bitvector->natural pos))] but avoids the @racket[bitvector->natural] cast for better solving performance.
@examples[#:eval rosette-eval
(define-symbolic p (bitvector 1))
(define xs '(1 2 3 4))
(code:comment "Uses a cast and generates a redundant assertion on the range of p:")
(list-ref xs (bitvector->natural p))
(vc)
(clear-vc!)
(code:comment "No cast and no redundant range assertion:")
(list-ref-bv xs p)
(vc)
(code:comment "But the range assertion is generated when needed:")
(define-symbolic q (bitvector 4))
(list-ref-bv xs q)
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc[(list-set-bv [lst list?] [pos bv?] [val any/c]) list?]{
Equivalent to @racket[(list-set lst (bitvector->natural pos) val)] but avoids the @racket[bitvector->natural] cast for better solving performance.
@examples[#:eval rosette-eval
(define-symbolic p (bitvector 1))
(define xs '(1 2 3 4))
(code:comment "Uses a cast and generates a redundant assertion on the range of p:")
(list-set xs (bitvector->natural p) 5)
(vc)
(clear-vc!)
(code:comment "No cast and no redundant range assertion:")
(list-set-bv xs p 5)
(vc)
(code:comment "But the range assertion is generated when needed:")
(define-symbolic q (bitvector 4))
(list-set-bv xs q 5)
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(take-bv [lst any/c] [pos bv?]) list?]
[(take-right-bv [lst any/c] [pos bv?]) any/c]
[(drop-bv [lst any/c] [pos bv?]) any/c]
[(drop-right-bv [lst any/c] [pos bv?]) list?]
[(list-tail-bv [lst any/c] [pos bv?]) any/c])]{
Equivalent to @racket[take], @racket[take-right],
@racket[drop], @racket[drop-right], or @racket[list-tail]
applied to @racket[lst] and
@racket[(bitvector->natural pos)], but avoids the
@racket[bitvector->natural] cast for better solving
performance.
@examples[#:eval rosette-eval
(define-symbolic p (bitvector 1))
(define xs (cons 1 (cons 2 (cons 3 4))))
(code:comment "Uses a cast and generates a redundant assertion on the range of p:")
(take xs (bitvector->natural p))
(vc)
(clear-vc!)
(code:comment "No cast and no redundant range assertion:")
(take-bv xs p)
(vc)
(code:comment "But the range assertion is generated when needed:")
(define-symbolic q (bitvector 4))
(take-bv xs q)
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc*[([(split-at-bv [lst any/c] [pos bv?]) (list? any/c)]
[(split-at-right-bv [lst any/c] [pos bv?]) (list? any/c)])]{
Equivalent to
@racket[(split-at lst (bitvector->natural pos))] or
@racket[(split-at-right lst (bitvector->natural pos))], but
avoids the @racket[bitvector->natural] cast for better
solving performance.
@examples[#:eval rosette-eval
(define-symbolic p (bitvector 1))
(define xs (cons 1 2))
(code:comment "Uses a cast and generates a redundant assertion on the range of p:")
(split-at xs (bitvector->natural p))
(vc)
(clear-vc!)
(code:comment "No cast and no redundant range assertion:")
(split-at-bv xs p)
(vc)
(code:comment "But the range assertion is generated when needed:")
(define-symbolic q (bitvector 4))
(split-at-bv xs q)
(vc)]}
@(kill-evaluator rosette-eval)

40
rosette/guide/scribble/datatypes/procedures-log.txt
View File

@ -1,40 +0,0 @@
;; This file was created by make-log-based-eval
((require (only-in racket string->symbol))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define p (if b * -)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define sol (synthesize #:forall (list x) #:guarantee (assert (= x (p x 1)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate p sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "*\n"))))
#""
#"")
((define sol (synthesize #:forall (list x) #:guarantee (assert (= x (p x 0)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate p sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "-\n"))))
#""
#"")

43
rosette/guide/scribble/datatypes/procedures.scrbl
View File

@ -1,43 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/base/form/define rosette/query/query
rosette/base/core/term
(only-in rosette/base/base assert)
racket)
scribble/core scribble/html-properties scribble/examples racket/sandbox racket/runtime-path
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "procedures-log")))
@(define proc-ops (select '(procedure? apply compose compose1 procedure-rename procedure->method procedure-closure-contents-eq? )))
@(define more-proc-ops (select '(identity const thunk thunk* negate curry curryr normalized-arity? normalize-arity arity=? arity-includes? prop:procedure)))
@title[#:tag "sec:proc"]{Procedures}
Rosette procedures are references to procedure objects, just like in Racket.
Two procedure references are @racket[eq?] and @racket[equal?] only if they point to the
same procedure object. Procedures may be concrete or symbolic. Symbolic procedures
may, in the worst case, take as much time to execute as the slowest concrete procedure to
which any symbolic procedure could @racket[evaluate] under any @racket[solution?].
@(rosette-eval '(require (only-in racket string->symbol)))
@examples[#:eval rosette-eval
(define-symbolic b boolean?)
(define-symbolic x integer?)
(code:line (define p (if b * -)) (code:comment "p is a symbolic procedure."))
(define sol (synthesize #:forall (list x)
#:guarantee (assert (= x (p x 1)))))
(evaluate p sol)
(define sol (synthesize #:forall (list x)
#:guarantee (assert (= x (p x 0)))))
(evaluate p sol)
]
Rosette lifts the following operations on procedures:
@tabular[#:style (style #f (list (attributes '((id . "lifted")(class . "boxed")))))
(list (list @elem{@proc-ops, @more-proc-ops}))]
@(kill-evaluator rosette-eval)

531
rosette/guide/scribble/datatypes/solvers+solutions.scrbl
View File

@ -1,531 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/solver/solver rosette/solver/solution
rosette/solver/smt/z3 rosette/solver/smt/cvc4
rosette/solver/smt/boolector
rosette/solver/smt/bitwuzla
rosette/solver/smt/cvc5
rosette/solver/smt/stp
rosette/solver/smt/yices
rosette/base/form/define rosette/query/query
rosette/base/core/term (only-in rosette/base/base bv?)
(only-in rosette/base/base assert)
racket)
scribble/core scribble/html-properties scribble/examples racket/sandbox racket/runtime-path
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "solvers-log")))
@title[#:tag "sec:solvers-and-solutions"]{Solvers and Solutions}
@declare-exporting[rosette/query/query
rosette/solver/solver
rosette/solver/solution
rosette/solver/smt/z3
rosette/solver/smt/cvc4
rosette/solver/smt/boolector
rosette/solver/smt/bitwuzla
rosette/solver/smt/cvc5
rosette/solver/smt/stp
rosette/solver/smt/yices
#:use-sources
(rosette/query/finitize
rosette/query/query
rosette/solver/solver
rosette/solver/solution
rosette/solver/smt/z3
rosette/solver/smt/cvc4
rosette/solver/smt/boolector
rosette/solver/smt/bitwuzla
rosette/solver/smt/cvc5
rosette/solver/smt/stp
rosette/solver/smt/yices)]
A @deftech{solver} is an automatic reasoning engine, used to answer
@seclink["sec:queries"]{queries} about Rosette programs. The result of
a solver invocation is a @deftech{solution}, containing either
a @tech{binding} of symbolic constants to concrete values, or
an @link["https://en.wikipedia.org/wiki/Unsatisfiable_core"]{unsatisfiable core}.
Solvers and solutions may not be symbolic. Two solvers (resp. solutions) are @racket[eq?]/@racket[equal?]
if they refer to the same object.
@section{The Solver Interface}
A solver contains a stack of assertions (boolean terms) to satisfy and a set of objectives (numeric terms) to optimize.
The assertion stack is partitioned into levels, with each level containing
a set of assertions. The bottom (0) assertion level cannot be removed, but more levels
can be created and removed using the @racket[solver-push] and @racket[solver-pop] procedures.
The @racket[solver-assert] procedure adds assertions to the top level of the assertion stack, while
the @racket[solver-minimize] and @racket[solver-maximize] procedures add new terms to the current set of optimization objectives.
The @racket[solver-check] procedure checks the satisfiability of all assertions in the assertion stack,
optimizing the resulting solution (if any) with respect to the provided objectives.
@defparam[current-solver solver solver?]{
The @racket[current-solver] parameter holds the solver object used for
answering solver-aided queries. Rosette's default solver is @racket[z3], although
new (SMT) solvers can be added as well. Rosette will work with any solver that implements the
@racket[gen:solver] generic interface.
@examples[#:eval rosette-eval
(current-solver)]
}
@defthing[gen:solver solver?]{
A @hyperlink["https://docs.racket-lang.org/reference/struct-generics.html"]{generic interface}
that specifies the procedures provided by a solver. These include
@racket[solver-assert],
@racket[solver-push],
@racket[solver-pop],
@racket[solver-clear],
@racket[solver-minimize],
@racket[solver-maximize],
@racket[solver-check],
@racket[solver-debug],
@racket[solver-shutdown], and
@racket[solver-features].
A solver may support a subset of this interface, which loosely follows
the @hyperlink["http://smtlib.cs.uiowa.edu/papers/smt-lib-reference-v2.5-r2015-06-28.pdf"]{SMTLib solver interface}.
}
@defproc[(solver? [v any/c]) boolean?]{
Returns true if @racket[v] is a concrete value that implements the @racket[gen:solver] interface.}
@defproc[(solver-assert [solver solver?] [constraints (listof boolean?)]) void?]{
Takes as input a list of boolean terms or values and
adds them to the current (top) level in the assertion stack.}
@defproc[(solver-push [solver solver?]) void?]{
Pushes a new level onto the solver's assertion stack. Subsequent calls to
@racket[solver-assert] will add assertions to this level.}
@defproc[(solver-pop [solver solver?] [levels integer?]) void?]{
Pops the given number of levels off the solver's assertion stack,
removing all the assertions at the popped levels. The number of @racket[levels] to
pop must be a positive integer that is no greater than the number of preceding
calls to @racket[solver-push].}
@defproc[(solver-clear [solver solver?]) void?]{
Clears the assertion stack of all levels and all assertions,
and removes all objectives from the current set of objectives to optimize.}
@defproc*[([(solver-minimize [solver solver?] [objs (listof (or/c integer? real? bv?))]) void?]
[(solver-maximize [solver solver?] [objs (listof (or/c integer? real? bv?))]) void?])]{
Adds the given optimization objectives to the given solver. These objectives take the form of
numeric terms whose value is to be minimized or maximized by subsequent calls to @racket[solver-check],
while satisfying all the boolean terms asserted via @racket[solver-assert].}
@defproc[(solver-check [solver solver?]) solution?]{
Searches for a binding from symbolic constants to concrete values that satisfies all
constraints (boolean terms) added to the solver via @racket[solver-assert].
If such a binding---or, a @racket[model]---exists,
it is returned in the form of a satisfiable (@racket[sat?]) solution, which optimizes
the objective terms added to the solver via @racket[solver-minimize] and @racket[solver-maximize].
Otherwise, an unsatisfiable (@racket[unsat?]) solution is returned, but without
computing an unsatisfiable @racket[core] (i.e., calling @racket[core] on the
resulting solution produces @racket[#f]).
}
@defproc[(solver-debug [solver solver?]) solution?]{
Searches for an unsatisfiable core of all constraints (boolean terms)
added to the solver via @racket[solver-assert] @emph{after} the most recent call to
@racket[clear] or @racket[solver-check] (if any).
If the constraints are satisfiable, or the given solver does
not support core extraction, an error is thrown. Otherwise, the result is an
@racket[unsat?] solution with a unsatisfiable @racket[core], expressed as a
list of boolean terms.
}
@defproc[(solver-shutdown [solver solver?]) void?]{
Terminates the current solving process (if any),
clears all added constraints, and releases all system resources associated
with the given solver instance. The solver must be able to reacquire these resources
if needed. That is, the solver should behave as though its state was merely cleared
(via @racket[solver-clear]) after a shutdown call.
}
@defproc[(solver-features [solver solver?]) (listof symbol?)]{
Returns the list of features supported by the solver.
The possible features, which correspond roughly to SMTLib @emph{logics},
extended with some additional options, are:
@itemize[
@item{@racket['qf_bv] (quantifier-free fixed-width bitvectors)}
@item{@racket['qf_uf] (quantifier-free uninterpreted functions and equality)}
@item{@racket['qf_lia] (quantifier-free linear integer arithmetic)}
@item{@racket['qf_nia] (quantifier-free non-linear integer arithmetic)}
@item{@racket['qf_lra] (quantifier-free linear real arithmetic)}
@item{@racket['qf_nra] (quantifier-free non-linear real arithmetic)}
@item{@racket['quantifiers] (quantified versions of the supported quantifier-free logics)}
@item{@racket['optimize] (support for objective function optimization)}
@item{@racket['unsat-cores] (unsatisfiable core generation)}
]
}
@defproc[(solver-options [solver solver?]) (hash/c symbol? any/c)]{
Returns the options the given solver is configured with
(as specified by the @racket[#:options] argument to solver constructors).
}
@defparam[output-smt on? (or/c boolean? path-string? output-port?)]{
Enables verbose output of generated SMT constraints.
When the @racket[output-smt] parameter is @racket[#t] or a @racket[path-string?],
Rosette will log the SMT encoding of all solver queries to temporary files.
A new temporary file is created for each solver process Rosette spawns.
Note that a single solver-aided query may spawn multiple solver processes,
and Rosette may reuse a solver process across several solver-aided queries.
When @racket[output-smt] is @racket[#t], the temporary files are created
in the system's temporary directory; otherwise,
the temporary files are created in the given path (which must be a directory).
The path to each temporary file is printed to @racket[current-error-port]
when it is first created.
When the @racket[output-smt] parameter is an @racket[output-port?],
Rosette will log the SMT encoding to that output port.
For example, setting @racket[output-smt] to @racket[(current-output-port)]
will print the SMT encoding to standard output.
All solvers will log to the same output port,
so several separate encodings may be interleaved when multiple solvers are in use.
Default value is @racket[#f].
}
@section{Supported Solvers}
Rosette supports several SMT solvers.
The @racket[current-solver] parameter controls the solver used for answering solver-aided queries.
Each supported solver is contained in a separate module
(e.g., @racketmodname[rosette/solver/smt/z3]),
which exports a constructor (e.g., @racket[z3])
to create a new solver instance.
@subsection{Z3}
@defmodule[rosette/solver/smt/z3 #:no-declare]
@defproc*[([(z3 [#:path path (or/c path-string? #f) #f]
[#:logic logic (or/c symbol? #f) #f]
[#:options options (hash/c symbol? any/c) (hash)]) solver?]
[(z3? [v any/c]) boolean?])]{
Returns a @racket[solver?] wrapper for the @hyperlink["https://github.com/Z3Prover/z3/"]{Z3} solver from Microsoft Research.
Rosette automatically installs a version of Z3;
the optional @racket[path] argument overrides this version with a path to a new Z3 binary.
The optional @racket[logic] argument specifies an SMT logic for the solver to use (e.g., @racket['QF_BV]).
Specifying a logic can improve solving performance, but Rosette makes no effort to check that
emitted constraints fall within the chosen logic. The default is @racket[#f],
which uses Z3's default logic.
The @racket[options] argument provides additional options that are sent to Z3
via the @tt{set-option} SMT command.
For example, setting @racket[options] to @racket[(hash ':smt.relevancy 0)]
will send the command @tt{(set-option :smt.relevancy 0)} to Z3 prior to solving.
}
@subsection{CVC4}
@defmodule[rosette/solver/smt/cvc4 #:no-declare]
@defproc*[([(cvc4 [#:path path (or/c path-string? #f) #f]
[#:logic logic (or/c symbol? #f) #f]
[#:options options (hash/c symbol? any/c) (hash)]) solver?]
[(cvc4? [v any/c]) boolean?])]{
Returns a @racket[solver?] wrapper for the @hyperlink["http://cvc4.cs.stanford.edu/web/"]{CVC4} solver from NYU and UIowa.
To use this solver, download and install CVC4 (version 1.8 or later),
and either add the @tt{cvc4} executable to your @tt{PATH}
or pass the path to the executable as the optional @racket[path] argument.
The optional @racket[logic] argument specifies an SMT logic for the solver to use (e.g., @racket['QF_BV]).
Specifying a logic can improve solving performance, but Rosette makes no effort to check that
emitted constraints fall within the chosen logic. The default is @racket[#f],
which uses CVC4's default logic.
The @racket[options] argument provides additional options that are sent to CVC4
via the @tt{set-option} SMT command.
For example, setting @racket[options] to @racket[(hash ':bv-propagate 'true)]
will send the command @tt{(set-option :bv-propagate true)} to CVC4 prior to solving.
}
@defproc[(cvc4-available?) boolean?]{
Returns true if the CVC4 solver is available for use (i.e., Rosette can locate a @tt{cvc4} binary).
If this returns @racket[#f], @racket[(cvc4)] will not succeed
without its optional @racket[path] argument.}
@subsection{Boolector}
@defmodule[rosette/solver/smt/boolector #:no-declare]
@defproc*[([(boolector [#:path path (or/c path-string? #f) #f]
[#:logic logic (or/c symbol? #f) #f]
[#:options options (hash/c symbol? any/c) (hash)]) solver?]
[(boolector? [v any/c]) boolean?])]{
Returns a @racket[solver?] wrapper for the @hyperlink["http://fmv.jku.at/boolector/"]{Boolector} solver from JKU.
To use this solver, download and install Boolector (version 2.4.1 or later),
and either add the @tt{boolector} executable to your @tt{PATH}
or pass the path to the executable as the optional @racket[path] argument.
The optional @racket[logic] argument specifies an SMT logic for the solver to use (e.g., @racket['QF_BV]).
Specifying a logic can improve solving performance, but Rosette makes no effort to check that
emitted constraints fall within the chosen logic. The default is @racket[#f],
which uses Boolector's default logic.
The @racket[options] argument provides additional options that are sent to Boolector
via the @tt{set-option} SMT command.
For example, setting @racket[options] to @racket[(hash ':seed 5)]
will send the command @tt{(set-option :seed 5)} to Boolector prior to solving.
}
@defproc[(boolector-available?) boolean?]{
Returns true if the Boolector solver is available for use (i.e., Rosette can locate a @tt{boolector} binary).
If this returns @racket[#f], @racket[(boolector)] will not succeed
without its optional @racket[path] argument.}
@subsection{Bitwuzla}
@defmodule[rosette/solver/smt/bitwuzla #:no-declare]
@defproc*[([(bitwuzla [#:path path (or/c path-string? #f) #f]
[#:logic logic (or/c symbol? #f) #f]
[#:options options (hash/c symbol? any/c) (hash)]) solver?]
[(bitwuzla? [v any/c]) boolean?])]{
Returns a @racket[solver?] wrapper for the @hyperlink["https://bitwuzla.github.io/"]{Bitwuzla} solver.
To use this solver, download prebuilt Bitwuzla or build it yourself,
and ensure the executable is on your @tt{PATH} or pass the path to the
executable as the optional @racket[path] argument.
Rosette currently tests Bitwuzla at commit
@tt{93a3d930f622b4cef0063215e63b7c3bd10bd663}.
The optional @racket[logic] argument specifies an SMT logic for the solver to use (e.g., @racket['QF_BV]).
Specifying a logic can improve solving performance, but Rosette makes no effort to check that
emitted constraints fall within the chosen logic. The default is @racket[#f],
which uses Bitwuzla's default logic.
The @racket[options] argument provides additional options that are sent to Bitwuzla
via the @tt{set-option} SMT command.
For example, setting @racket[options] to @racket[(hash ':seed 5)]
will send the command @tt{(set-option :seed 5)} to Bitwuzla prior to solving.
}
@defproc[(bitwuzla-available?) boolean?]{
Returns true if the Bitwuzla solver is available for use (i.e., Rosette can locate a @tt{bitwuzla} binary).
If this returns @racket[#f], @racket[(bitwuzla)] will not succeed
without its optional @racket[path] argument.}
@subsection{CVC5}
@defmodule[rosette/solver/smt/cvc5 #:no-declare]
@defproc*[([(cvc5 [#:path path (or/c path-string? #f) #f]
[#:logic logic (or/c symbol? #f) #f]
[#:options options (hash/c symbol? any/c) (hash)]) solver?]
[(cvc5? [v any/c]) boolean?])]{
Returns a @racket[solver?] wrapper for the @hyperlink["https://cvc5.github.io/"]{CVC5} solver.
To use this solver, download prebuilt CVC5 or build it yourself,
and ensure the executable is on your @tt{PATH} or pass the path to the
executable as the optional @racket[path] argument.
Rosette currently tests CVC5 at version 1.0.7.
The optional @racket[logic] argument specifies an SMT logic for the solver to use (e.g., @racket['QF_BV]).
Specifying a logic can improve solving performance, but Rosette makes no effort to check that
emitted constraints fall within the chosen logic. The default is @racket[#f],
which uses CVC5's default logic.
The @racket[options] argument provides additional options that are sent to CVC5
via the @tt{set-option} SMT command.
For example, setting @racket[options] to @racket[(hash ':seed 5)]
will send the command @tt{(set-option :seed 5)} to CVC5 prior to solving.
}
@defproc[(cvc5-available?) boolean?]{
Returns true if the CVC5 solver is available for use (i.e., Rosette can locate a @tt{cvc5} binary).
If this returns @racket[#f], @racket[(cvc5)] will not succeed
without its optional @racket[path] argument.}
@subsection{STP}
@defmodule[rosette/solver/smt/stp #:no-declare]
@defproc*[([(stp [#:path path (or/c path-string? #f) #f]
[#:logic logic (or/c symbol? #f) #f]
[#:options options (hash/c symbol? any/c) (hash)]) solver?]
[(stp? [v any/c]) boolean?])]{
Returns a @racket[solver?] wrapper for the @hyperlink["https://stp.github.io/"]{STP} solver.
To use this solver, download prebuilt STP or build it yourself,
and ensure the executable is on your @tt{PATH} or pass the path to the
executable as the optional @racket[path] argument.
Rosette currently tests STP at commit
@tt{0510509a85b6823278211891cbb274022340fa5c}.
Note that as of December 2023, the STP version on Mac Homebrew is too old to be
supported by Rosette.
The optional @racket[logic] argument specifies an SMT logic for the solver to use (e.g., @racket['QF_BV]).
Specifying a logic can improve solving performance, but Rosette makes no effort to check that
emitted constraints fall within the chosen logic. The default is @racket[#f],
which uses STP's default logic.
The @racket[options] argument provides additional options that are sent to STP
via the @tt{set-option} SMT command.
For example, setting @racket[options] to @racket[(hash ':seed 5)]
will send the command @tt{(set-option :seed 5)} to STP prior to solving.
}
@defproc[(stp-available?) boolean?]{
Returns true if the STP solver is available for use (i.e., Rosette can locate a @tt{stp} binary).
If this returns @racket[#f], @racket[(stp)] will not succeed
without its optional @racket[path] argument.}
@subsection{Yices2}
@defmodule[rosette/solver/smt/yices #:no-declare]
@defproc*[([(yices [#:path path (or/c path-string? #f) #f]
[#:logic logic (or/c symbol? #f) 'QF_BV]
[#:options options (hash/c symbol? any/c) (hash)]) solver?]
[(yices? [v any/c]) boolean?])]{
Returns a @racket[solver?] wrapper for the @hyperlink["https://yices.csl.sri.com/"]{Yices2} solver.
To use this solver, download prebuilt Yices2 or build it yourself,
and ensure the executable is on your @tt{PATH} or pass the path to the
executable as the optional @racket[path] argument.
Rosette specifically uses the @tt{yices-smt2} executable, which is the Yices2
solver with its SMTLIB2 frontend enabled.
Note that just building (without installing) Yices2 will produce an executable
named @tt{yices_smt2}. Running the installation step produces an executable
with the correct name. However, it is safe to skip the installation step and
simply rename or symlink the @tt{yices_smt2} executable to @tt{yices-smt2}.
Rosette currently tests Yices2 at commit
@tt{e27cf308cffb0ecc6cc7165c10e81ca65bc303b3}.
The optional @racket[logic] argument specifies an SMT logic for the solver to use (e.g., @racket['QF_BV]).
Specifying a logic can improve solving performance, but Rosette makes no effort to check that
emitted constraints fall within the chosen logic. Yices2 expects a logic to be
set; Rosette defaults to @racket['QF_BV].
The @racket[options] argument provides additional options that are sent to Yices2
via the @tt{set-option} SMT command.
For example, setting @racket[options] to @racket[(hash ':seed 5)]
will send the command @tt{(set-option :seed 5)} to Yices2 prior to solving.
}
@defproc[(yices-available?) boolean?]{
Returns true if the Yices2 solver is available for use (i.e., Rosette can locate a @tt{yices-smt2} binary).
If this returns @racket[#f], @racket[(yices)] will not succeed
without its optional @racket[path] argument.}
@section{Solutions}
A solution to a set of formulas may be satisfiable (@racket[sat?]), unsatisfiable (@racket[unsat?]),
or unknown (@racket[unknown?]).
A satisfiable solution can be used as a procedure: when applied to a bound symbolic constant, it returns
a concrete value for that constant; when applied to any other value, it returns
the value itself.
The solver returns an @racket[unknown?] solution if it cannot determine whether
the given constraints are satisfiable or not.
A solution supports the following operations:
@defproc[(solution? [v any/c]) boolean?]{
Returns true if @racket[v] is a solution.}
@defproc[(sat? [v any/c]) boolean?]{
Returns true if @racket[v] is a satisfiable solution.}
@defproc[(unsat? [v any/c]) boolean?]{
Returns true if @racket[v] is an unsatisfiable solution.}
@defproc[(unknown? [v any/c]) boolean?]{
Returns true if @racket[v] is an unknown solution.}
@defproc*[([(sat) sat?]
[(sat [binding (hash/c constant? any/c #:immutable #t)]) sat?])]{
Returns a satisfiable solution that holds the given binding from symbolic
constants to values, or that holds the empty binding. The provided hash must
bind every symbolic constant in its keyset to a concrete value of the same type.
}
@defproc*[([(unsat) unsat?]
[(unsat [constraints (listof boolean?)]) unsat?])]{
Returns an unsatisfiable solution. The @racket[constraints] list, if provided,
consist of boolean values that are collectively unsatisfiable. If no constraints
are provided, applying @racket[core] to the resulting solution produces @racket[#f],
indicating that there is no satisfying solution but
core extraction was not performed. (Core extraction is an expensive
operation that is not supported by all solvers; those that do support it
do not compute a core unless explicitly asked for one via @racket[solver-debug].)}
@defproc[(unknown) unknown?]{
Returns an unknown solution.}
@defproc[(model [sol sat?]) (hash/c constant? any/c #:immutable #t)]{
Returns the binding stored in the given satisfiable solution. The binding is an immutable
hashmap from symbolic constants to values.
}
@defproc[(core [sol unsat?]) (or/c (listof (and/c constant? boolean?)) #f)]{
Returns the unsatisfiable core stored in the given satisfiable solution. If the solution is
@racket[unsat?] and a core was computed, the result is a list of boolean values that
are collectively unsatisfiable. Otherwise, the result is @racket[#f].
}
@defproc[(evaluate [v any/c] [sol sat?]) any/c]{
Given a Rosette value and a satisfiable solution, @racket[evaluate] produces a
new value obtained by replacing every symbolic constant @var[c] in @racket[v]
with @racket[(sol #, @var[c])] and simplifying the result.
@examples[#:eval rosette-eval
(define-symbolic a b boolean?)
(define-symbolic x y integer?)
(define sol
(solve (begin (assert a)
(assert (= x 1))
(assert (= y 2)))))
(sat? sol)
(evaluate (list 4 5 x) sol)
(define vec (vector a))
(evaluate vec sol)
(code:line (eq? vec (evaluate vec sol)) (code:comment "Evaluation produces a new vector."))
(evaluate (+ x y) sol)
(evaluate (and a b) sol)
]}
@defproc[(complete-solution [sol solution?] [consts (listof constant?)]) solution?]{
Given a solution @racket[sol] and a list of symbolic
constants @racket[consts], returns a solution that is
complete with respect to the given list. In particular, if
@racket[sol] is satisfiable, the returned solution is also
satisfiable, and it extends the @racket[sol] model with
default bindings for all constants in @racket[consts] that
are not bound by @racket[sol]. Otherwise, @racket[sol]
itself is returned.
@examples[#:eval rosette-eval
(define-symbolic a boolean?)
(define-symbolic x integer?)
(define sol (solve (assert a)))
(code:line sol (code:comment "No binding for x."))
(complete-solution sol (list a x))
(complete-solution (solve (assert #f)) (list a x))
]}
@(kill-evaluator rosette-eval)

101
rosette/guide/scribble/datatypes/solvers-log.txt
View File

@ -1,101 +0,0 @@
;; This file was created by make-log-based-eval
((current-solver)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "#<z3>\n"))))
#""
#"")
((define-symbolic a b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x y integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define sol (solve (begin (assert a) (assert (= x 1)) (assert (= y 2)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((sat? sol) ((3) 0 () 0 () () (q values #t)) #"" #"")
((evaluate (list 4 5 x) sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'(4 5 1)\n"))))
#""
#"")
((define vec (vector a)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((evaluate vec sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'#(#t)\n"))))
#""
#"")
((eq? vec (evaluate vec sol)) ((3) 0 () 0 () () (q values #f)) #"" #"")
((evaluate (+ x y) sol) ((3) 0 () 0 () () (q values 3)) #"" #"")
((evaluate (and a b) sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "b\n"))))
#""
#"")
((define-symbolic a boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define sol (solve (assert a)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(sol
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [a #t])\n"))))
#""
#"")
((complete-solution sol (list a x))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [a #t]\n [x 0])\n"))))
#""
#"")
((complete-solution (solve (assert #f)) (list a x))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")

54
rosette/guide/scribble/datatypes/test.rkt
View File

@ -1,54 +0,0 @@
#lang rosette/safe
(struct point (x y) #:transparent)
(eq? (point 1 2) (point 1 2))
(struct pt (x y))
(eq? (pt 1 2) (pt 1 2))
(struct pnt (x y) #:mutable #:transparent)
(eq? (pnt 1 2) (pnt 1 2))
(define-symbolic b boolean?)
(define p (if b (point 1 2) (point 3 4)))
(point-x p)
(point-y p)
(define sol (solve (assert (= (point-x p) 3))))
(evaluate p sol)
(define-generics viewable (view viewable))
(struct square (side)
#:methods gen:viewable
[(define (view self) (square-side self))])
(struct circle (radius)
#:transparent
#:methods gen:viewable
[(define (view self) (circle-radius self))])
(define q (if b (square 2) (circle 3)))
(view q)
(define sol2 (solve (assert (= (view q) 3))))
(evaluate q sol2)
#|(define-values (prop:foo foo? foo-value) (make-struct-type-property 'foo))
(struct point (x y) #:transparent #:property prop:foo 3)
(define-symbolic b boolean?)
(define p (if b (point 1 2) (point 3 4)))
(foo? p)
(foo-value p)
(eq? (point 1 2) (point 1 2))
(evaluate p (solve (assert (= (point-x p) 3))))
(struct pt (x y))
(eq? (pt 1 2) (pt 1 2))
(struct farm (x)
#:methods gen:equal+hash
[(define (equal-proc self f rec) (and (rec (farm-x self) (farm-x f))))
(define (hash-proc self rec) 1)
(define (hash2-proc self rec) 2)])|#

193
rosette/guide/scribble/datatypes/uninterpreted-log.txt
View File

@ -1,193 +0,0 @@
;; This file was created by make-log-based-eval
((current-bitwidth #f) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic f (~> integer? boolean?))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((f 1)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(app f 1)\n"))))
#""
#"")
((define-symbolic x real?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((f x)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(app f (real->integer x))\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t (int? x))\n"))))
#""
#"")
((define sol (solve (assert (not (equal? (f x) (f 1))))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define g (evaluate f sol)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
(g
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(fv integer?~>boolean?)\n"))))
#""
#"")
((evaluate x sol) ((3) 0 () 0 () () (q values 0)) #"" #"")
((fv? f) ((3) 0 () 0 () () (q values #t)) #"" #"")
((fv? g) ((3) 0 () 0 () () (q values #t)) #"" #"")
((g 2) ((3) 0 () 0 () () (q values #t)) #"" #"")
((g x)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(ite (= 1 (real->integer x)) #f #t)\n"))))
#""
#"")
((define t (~> integer? real? boolean? (bitvector 4)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(t
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "integer?~>real?~>boolean?~>(bitvector 4)\n"))))
#""
#"")
((~> t integer?)
((3)
0
()
0
()
()
(q
exn
"function: expected a list of primitive solvable types\n domain: '(integer?~>real?~>boolean?~>(bitvector 4))"))
#""
#"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((~> integer? (if b boolean? real?))
((3)
0
()
0
()
()
(q
exn
"function: expected a primitive solvable type\n range: (union [b boolean?] [(! b) real?])"))
#""
#"")
((~> real?)
((3)
0
()
0
()
()
(q
exn
"~>: arity mismatch;\n the expected number of arguments does not match the given number\n expected: at least 2\n given: 1"))
#""
#"")
((define t0? (~> integer? real? boolean? (bitvector 4)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define t1? (~> integer? real?))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((function? t0?) ((3) 0 () 0 () () (q values #t)) #"" #"")
((function? t1?) ((3) 0 () 0 () () (q values #t)) #"" #"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((function? (if b t0? t1?)) ((3) 0 () 0 () () (q values #f)) #"" #"")
((function? integer?) ((3) 0 () 0 () () (q values #f)) #"" #"")
((function? 3) ((3) 0 () 0 () () (q values #f)) #"" #"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic f (~> boolean? boolean?))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((fv? f) ((3) 0 () 0 () () (q values #t)) #"" #"")
((fv? (lambda (x) x)) ((3) 0 () 0 () () (q values #f)) #"" #"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((fv? (if b f 1))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "b\n"))))
#""
#"")
((define sol (solve (begin (assert (not (f #t))) (assert (f #f)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define g (evaluate f sol)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
(g
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(fv boolean?~>boolean?)\n"))))
#""
#"")
((fv? g) ((3) 0 () 0 () () (q values #t)) #"" #"")
((verify (assert (equal? (g b) (not b))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")

109
rosette/guide/scribble/datatypes/uninterpreted.scrbl
View File

@ -1,109 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/base/form/define rosette/query/query rosette/solver/solution
rosette/base/core/term (only-in rosette/query/finitize current-bitwidth)
(only-in rosette/base/core/union union?)
(only-in rosette/base/core/function ~> function? fv?)
(only-in rosette/base/base bv bitvector assert vc clear-vc!))
(for-label racket) racket/runtime-path
scribble/core scribble/html-properties scribble/examples racket/sandbox
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "uninterpreted-log")))
@title[#:tag "sec:UF"]{Uninterpreted Functions}
@declare-exporting[rosette/base/base #:use-sources (rosette/base/core/function
rosette/query/finitize
rosette/base/base)]
In Rosette, functions are special kinds of @seclink["sec:proc"]{procedures} that are pure
(have no side effects) and total (defined on every input value).
A function type is recognized by the @racket[function?] predicate, and all
function types are @tech[#:key "solvable type"]{solvable}. The type of a
function specifies the function's domain and range, which are given as @racket[solvable?] non-@racket[function?] types. A value of a function type is recognized by
the @racket[fv?] (function value) predicate. Because
function types are solvable, they can be used in the @seclink["sec:symbolic-constants"]{@code{define-symbolic[*]}} form
to introduce a symbolic function constant. These symbolic function constants are
technically @deftech[#:key "uninterpreted function"]{uninterpreted functions}---they have
no fixed meaning. Their meaning (or interpretation) is determined by the underlying solver
as the result of a @seclink["sec:queries"]{solver-aided query}.
@examples[#:eval rosette-eval
(current-bitwidth #f)
(code:comment "An uninterpreted function from integers to booleans:")
(define-symbolic f (~> integer? boolean?))
(code:line (f 1) (code:comment "No built-in interpretation for 1."))
(define-symbolic x real?)
(code:line (f x) (code:comment "This typechecks when x is an integer,"))
(code:line (vc) (code:comment "so Rosette emits the corresponding assertion."))
(define sol (solve (assert (not (equal? (f x) (f 1))))))
(code:line (define g (evaluate f sol)) (code:comment "An interpretation of f."))
g
(evaluate x sol)
(code:line (fv? f) (code:comment "f is a function value,"))
(code:line (fv? g) (code:comment "and so is g."))
(code:line (g 2) (code:comment "We can apply g to concrete values"))
(code:line (g x) (code:comment "and to symbolic values."))]
@defproc[(~> [d (and/c solvable? (not/c function?))] ...+
[r (and/c solvable? (not/c function?))]) function?]{
Returns a type predicate for recognizing functions that take as input
values of types @racket[d...+] and produce values of type @racket[r].
The domain and range arguments must be concrete @racket[solvable?] types that are
not themselves functions. Note that @racket[~>] expects at least one domain
type to be given, disallowing zero-argument functions.
@examples[#:eval rosette-eval
(define t (~> integer? real? boolean? (bitvector 4)))
t
(eval:error (~> t integer?))
(define-symbolic b boolean?)
(eval:error (~> integer? (if b boolean? real?)))
(eval:error (~> real?))]
}
@defproc[(function? [v any/c]) boolean?]{
Returns true if @racket[v] is a concrete type predicate that recognizes function values.
@examples[#:eval rosette-eval
(define t0? (~> integer? real? boolean? (bitvector 4)))
(define t1? (~> integer? real?))
(function? t0?)
(function? t1?)
(define-symbolic b boolean?)
(code:line (function? (if b t0? t1?)) (code:comment "Not a concrete type."))
(code:line (function? integer?) (code:comment "Not a function type."))
(code:line (function? 3) (code:comment "Not a type."))]
}
@(rosette-eval '(clear-vc!))
@defproc[(fv? [v any/c]) boolean?]{
Returns true if @racket[v] is a concrete or symbolic function value.
@examples[#:eval rosette-eval
(define-symbolic f (~> boolean? boolean?))
(fv? f)
(fv? (lambda (x) x))
(define-symbolic b boolean?)
(fv? (if b f 1))
(define sol
(solve
(begin
(assert (not (f #t)))
(assert (f #f)))))
(define g (evaluate f sol))
(code:line g (code:comment "g implements logical negation."))
(fv? g)
(code:comment "Verify that g implements logical negation:")
(verify (assert (equal? (g b) (not b))))]
}
@(kill-evaluator rosette-eval)

327
rosette/guide/scribble/datatypes/vectors-log.txt
View File

@ -1,327 +0,0 @@
;; This file was created by make-log-based-eval
((define v1 (vector 1 2 #f)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define v2 (vector 1 2 #f)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((eq? v1 v2) ((3) 0 () 0 () () (q values #f)) #"" #"")
((equal? v1 v2) ((3) 0 () 0 () () (q values #t)) #"" #"")
((define v3 (vector-immutable 1 2 #f))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define v4 (vector-immutable 1 2 #f))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((eq? v3 v4) ((3) 0 () 0 () () (q values #t)) #"" #"")
((equal? v1 v3) ((3) 0 () 0 () () (q values #t)) #"" #"")
((define-symbolic x y z n integer?)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define xs (take (list x y z) n))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define vs (list->vector xs)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define sol
(solve (begin (assert (< n 3)) (assert (= 4 (vector-ref vs (sub1 n)))))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((evaluate n sol) ((3) 0 () 0 () () (q values 1)) #"" #"")
((evaluate (list x y z) sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'(4 0 0)\n"))))
#""
#"")
((evaluate vs sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'#(4)\n"))))
#""
#"")
((evaluate xs sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'(4)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define xs (if b (vector 1 2) (vector 3 4 5 6)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(xs
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(union [b #(1 2)] [(! b) #(3 4 5 6)])\n"))))
#""
#"")
((integer->bitvector (vector-length xs) (bitvector 4))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(integer->bitvector (ite b 2 4) (bitvector 4))\n"))))
#""
#"")
((vector-length-bv xs (bitvector 4))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(ite b (bv #x2 4) (bv #x4 4))\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic p (bitvector 1))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define xs (vector 1 2 3 4)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vector-ref xs (bitvector->natural p))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(ite*\n (⊢ (= 0 (bitvector->natural p)) 1)\n (⊢ (= 1 (bitvector->natural p)) 2)\n (⊢ (= 2 (bitvector->natural p)) 3)\n (⊢ (= 3 (bitvector->natural p)) 4))\n\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(vc #t (&& (<= 0 (bitvector->natural p)) (< (bitvector->natural p) 4)))\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vector-ref-bv xs p)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(ite* (⊢ (bveq (bv #b0 1) p) 1) (⊢ (bveq (bv #b1 1) p) 2))\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((define-symbolic q (bitvector 4))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((vector-ref-bv xs q)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(ite*\n (⊢ (bveq (bv #x0 4) q) 1)\n (⊢ (bveq (bv #x1 4) q) 2)\n (⊢ (bveq (bv #x2 4) q) 3)\n (⊢ (bveq (bv #x3 4) q) 4))\n\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t (bvult q (bv #x4 4)))\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic p (bitvector 1))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define xs (vector 1 2 3 4)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vector-set! xs (bitvector->natural p) 5)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(xs
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(vector\n (ite (= 0 (bitvector->natural p)) 5 1)\n (ite (= 1 (bitvector->natural p)) 5 2)\n (ite (= 2 (bitvector->natural p)) 5 3)\n (ite (= 3 (bitvector->natural p)) 5 4))\n\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(vc #t (&& (<= 0 (bitvector->natural p)) (< (bitvector->natural p) 4)))\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define xs (vector 1 2 3 4)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vector-set!-bv xs p 5) ((3) 0 () 0 () () (c values c (void))) #"" #"")
(xs
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(vector (ite (bveq (bv #b0 1) p) 5 1) (ite (bveq (bv #b1 1) p) 5 2) 3 4)\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((define-symbolic q (bitvector 4))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define xs (vector 1 2 3 4)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vector-set!-bv xs q 5) ((3) 0 () 0 () () (c values c (void))) #"" #"")
(xs
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(vector\n (ite (bveq (bv #x0 4) q) 5 1)\n (ite (bveq (bv #x1 4) q) 5 2)\n (ite (bveq (bv #x2 4) q) 5 3)\n (ite (bveq (bv #x3 4) q) 5 4))\n\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t (bvult q (bv #x4 4)))\n"))))
#""
#"")

135
rosette/guide/scribble/datatypes/vectors.scrbl
View File

@ -1,135 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/base/form/define rosette/query/query
rosette/base/core/term
rosette/solver/solution
(only-in rosette/base/base assert define-symbolic union?
vc clear-vc! bitvector bitvector? bv?
bitvector->natural integer->bitvector
vector-length-bv vector-ref-bv vector-set!-bv)
racket)
scribble/core scribble/html-properties scribble/examples racket/sandbox racket/runtime-path
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "vectors-log")))
@(define vector-ops (select '(vector? make-vector vector vector-immutable vector-length vector-ref vector-set! vector->list list->vector vector->immutable-vector vector-fill! vector-copy! vector->values build-vector immutable?)))
@(define more-vector-ops (select '(vector-set*! vector-map vector-map! vector-append vector-take vector-take-right vector-drop vector-drop-right vector-split-at vector-split-at-right vector-copy vector-filter vector-filter-not vector-count vector-argmin vector-argmax vector-member vector-memv vector-memq)))
@title[#:tag "sec:vec"]{Vectors}
A vector is a fixed-length (im)mutable array.
Vectors may be concrete or symbolic, and they may be accessed using concrete
or symbolic indices. A concrete vector supports constant-time access for
concrete slot indices, and linear-time access for symbolic slot indices.
A symbolic vector supports (worst-case) linear- and quadratic-time access for concrete and
symbolic indices, respectively. Access time for symbolic vectors is given with
respect to the longest possible concrete array to which any symbolic vector
could @racket[evaluate] under any @racket[solution?].
Like @seclink["sec:pair"]{pairs and lists}, immutable vectors are transparent immutable values:
two such vectors are @racket[eq?] if they have the same length and @racket[eq?] contents.
Mutable vectors are references rather than values, and two mutable vectors are @racket[eq?] if and only if they
point to the same array object. Two vectors (regardless of mutability) are @racket[equal?]
if they have the same length and @racket[equal?] contents.
@examples[#:eval rosette-eval
(define v1 (vector 1 2 #f))
(define v2 (vector 1 2 #f))
(eq? v1 v2)
(equal? v1 v2)
(define v3 (vector-immutable 1 2 #f))
(define v4 (vector-immutable 1 2 #f))
(eq? v3 v4)
(equal? v1 v3)
]
@examples[#:eval rosette-eval
(define-symbolic x y z n integer?)
(code:line (define xs (take (list x y z) n)) (code:comment "xs is a symbolic list."))
(code:line (define vs (list->vector xs)) (code:comment "vs is a symbolic vector."))
(define sol
(solve
(begin
(assert (< n 3))
(assert (= 4 (vector-ref vs (sub1 n)))))))
(evaluate n sol)
(evaluate (list x y z) sol)
(evaluate vs sol)
(evaluate xs sol)]
@section{Lifted Operations on Vectors}
The following vector operations are lifted to work on both concrete and symbolic values:
@tabular[#:style (style #f (list (attributes '((id . "lifted")(class . "boxed")))))
(list (list @elem{Vector Operations} @elem{@vector-ops, @more-vector-ops}))]
@(rosette-eval '(clear-vc!))
@section{Additional Operations on Vectors}
Rosette provides the following procedures for operating on vectors using @seclink["sec:bitvectors"]{bitvector} indices and lengths. These procedures produce symbolic values that avoid @racketlink[bitvector->natural]{casting} their bitvector arguments to integers, leading to @seclink["sec:notes"]{more efficiently solvable queries}.
@declare-exporting[rosette/base/base #:use-sources (rosette/base/base)]
@defproc[(vector-length-bv [vec vector?] [t (or/c bitvector? union?)]) bv?]{
Equivalent to @racket[(integer->bitvector (vector-length vec) t)] but avoids the @racket[integer->bitvector] cast for better solving performance.
@examples[#:eval rosette-eval
(define-symbolic b boolean?)
(define xs (if b (vector 1 2) (vector 3 4 5 6)))
xs
(integer->bitvector (vector-length xs) (bitvector 4))
(vector-length-bv xs (bitvector 4))]
}
@(rosette-eval '(clear-vc!))
@defproc[(vector-ref-bv [vec vector?] [pos bv?]) any/c]{
Equivalent to @racket[(vector-ref vec (bitvector->natural pos))] but avoids the @racket[bitvector->natural] cast for better solving performance.
@examples[#:eval rosette-eval
(define-symbolic p (bitvector 1))
(define xs (vector 1 2 3 4))
(code:comment "Uses a cast and generates a redundant assertion on the range of p:")
(vector-ref xs (bitvector->natural p))
(vc)
(clear-vc!)
(code:comment "No cast and no redundant range assertion:")
(vector-ref-bv xs p)
(vc)
(code:comment "But the range assertion is generated when needed:")
(define-symbolic q (bitvector 4))
(vector-ref-bv xs q)
(vc)]
}
@(rosette-eval '(clear-vc!))
@defproc[(vector-set!-bv [vec vector?] [pos bv?] [val any/c]) void?]{
Equivalent to @racket[(vector-set! vec (bitvector->natural pos) val)] but avoids the @racket[bitvector->natural] cast for better solving performance.
@examples[#:eval rosette-eval
(define-symbolic p (bitvector 1))
(define xs (vector 1 2 3 4))
(code:comment "Uses a cast and generates a redundant assertion on the range of p:")
(vector-set! xs (bitvector->natural p) 5)
xs
(vc)
(clear-vc!)
(code:comment "No cast and no redundant range assertion:")
(define xs (vector 1 2 3 4))
(vector-set!-bv xs p 5)
xs
(vc)
(code:comment "But the range assertion is generated when needed:")
(define-symbolic q (bitvector 4))
(define xs (vector 1 2 3 4))
(vector-set!-bv xs q 5)
xs
(vc)]
}

224
rosette/guide/scribble/error-tracing/error-tracer-log.txt
View File

@ -1,224 +0,0 @@
;; This file was created by make-log-based-eval
((require (only-in rosette/guide/scribble/util/lifted format-opaque))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define-symbolic xs integer? #:length 4)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define (sum xs) (foldl + xs)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((verify (assert (= (sum xs) (sum (filter-not zero? xs)))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model)\n"))))
#""
#"")
((define-symbolic opt boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((synthesize
#:forall
xs
#:guarantee
(assert (= (sum xs) (apply (if opt + -) xs))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((require rackunit) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define (post xs) (assert (= (sum xs) (sum (filter-not zero? xs)))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define (query xs) (verify (post xs)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define example-tests
(test-suite
"An example suite for a sum query."
#:before
clear-vc!
#:after
clear-vc!
(test-case
"Test sum with concrete values."
(check = (sum '()) 0)
(check = (sum '(-1)) -1)
(check = (sum '(-2 2)) 0)
(check = (sum '(-1 0 3)) 2))
(test-case
"Test query post for exceptions."
(before (clear-vc!) (check-not-exn (thunk (post xs)))))
(test-case
"Test query outcome."
(before (clear-vc!) (check-pred unsat? (query xs))))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((format-opaque "~a" (run-test example-tests))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(#<test-error> #<test-failure> #<test-failure>)\n"))))
#""
#"")
((define (sum xs)
(cond
((null? xs) 0)
((null? (cdr xs)) (car xs))
((andmap (curry = (car xs)) (cdr xs)) (* (length xs) (cdr xs)))
(else (apply + xs))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((assume (positive? (sum xs))) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((verify (assert (ormap positive? xs)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((define (pre xs) (assume (positive? (sum xs))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define (post xs) (assert (ormap positive? xs)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define (query xs) (pre xs) (verify (post xs)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define example-tests
(test-suite
"An example suite for a sum query."
#:before
clear-vc!
#:after
clear-vc!
(test-case
"Test sum with concrete values."
(check = (sum '()) 0)
(check = (sum '(-1)) -1)
(check = (sum '(-2 2)) 0)
(check = (sum '(-1 0 3)) 2))
(test-case
"Test query post for exceptions."
(before (clear-vc!) (check-not-exn (thunk (pre xs)))))
(test-case
"Test query post for exceptions."
(before (clear-vc!) (check-not-exn (thunk (post xs)))))
(test-case
"Test query outcome."
(before (clear-vc!) (check-pred unsat? (query xs))))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((format-opaque "~a" (run-test example-tests))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(#<test-success> #<test-success> #<test-success> #<test-success>)\n"))))
#""
#"")
((test-case "Test sum for any failures." (check-pred unsat? (verify (sum xs))))
((3) 0 () 0 () () (c values c (void)))
#""
#"--------------------\nTest sum for any failures.\nFAILURE\nname: check-pred\nlocation: eval:20:0\nparams:\n '(#<procedure:unsat?> (model\n [xs$0 0]\n [xs$1 0]\n [xs$2 0]\n [xs$3 0]))\n--------------------\n")
((verify (begin (assume (positive? (sum xs))) (assert (ormap positive? xs))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [xs$0 1]\n [xs$1 1]\n [xs$2 1]\n [xs$3 1])\n"))))
#""
#"")
((assume (positive? (sum xs))) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((verify (assert (ormap positive? xs)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((define (select xs n)
(cond
((empty? xs) (assert #f "unexpected empty list"))
(else
(define pivot (first xs))
(define non-pivot (rest xs))
(define <pivot (filter (λ (x) (< x pivot)) non-pivot))
(define >=pivot (filter (λ (x) (>= x pivot)) non-pivot))
(define len< (length <pivot))
(cond
((= n len<) pivot)
((< n len<) (select <pivot))
(else (select >=pivot (- n len< 1)))))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define-symbolic n k integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assume (and (<= 0 n (sub1 (length xs))) (= k (select xs n))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((verify (assert (= k (list-ref (sort xs <) n))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")

420
rosette/guide/scribble/error-tracing/error-tracing.scrbl
View File

@ -1,420 +0,0 @@
#lang scribble/manual
@(require scribble/core scribble/html-properties
scribble/bnf scribble/example
(for-label (except-in racket list-set) errortrace
rosette/base/core/term
rosette/base/form/define
rosette/query/form
rosette/base/core/union
(only-in rosette unsat model evaluate sat? unsat? clear-vc! current-bitwidth)
(only-in rosette/base/base assume assert vc clear-vc!)
rackunit)
racket/runtime-path
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "error-tracer-log") #f 'rosette))
@(define-runtime-path interface.png "interface.png")
@(define-runtime-path quickselect.png "quickselect.png")
@(rosette-eval '(require (only-in rosette/guide/scribble/util/lifted format-opaque)))
@title[#:tag "ch:error-tracing"]{Debugging}
Bugs in Rosette programs often manifest as runtime
exceptions. For example, calling a procedure with too few
arguments will cause a runtime exception in Rosette, just as
it would in Racket. But unlike Racket, Rosette treats
exceptions as assertion failures: it catches the exception,
updates the @tech{verification condition} to reflect the
failure, and proceeds with symbolic evaluation. This
treatment of exceptions ensures that the program's
@seclink["ch:syntactic-forms:rosette"]{ solver-aided
queries} correctly return a @racket[sat?] or @racket[unsat?]
solution, but it can also make solver-aided code tricky to
debug. This chapter describes common problems that are due
to intercepted exceptions, how to test for them, and how to
find them with the @code{symtrace} tool for error tracing.
@section[#:tag "sec:errors-in-rosette"]{Common Bugs in Solver-Aided Code}
Rosette intercepts exceptions in two places: within
solver-aided queries and within conditional expressions.
When converted to assertion failures, these exceptions can
lead to unexpected query results, as well as subtle logical
errors with no obvious manifestation. We illustrate both
kinds of problems next and show how to test for them.
@subsection[#:tag "sec:errors-under-queries"]{Bugs Due to Exceptions in Solver-Aided Queries}
When an exception is intercepted within a solver-aided
query, the query will often produce an unexpected result:
a model when we expect @racket[unsat], and vice versa.
As an example, consider the following verification query,
which tries to prove that the sum of a list of integers
remains the same when all zeros are removed from the list:
@examples[#:eval rosette-eval #:label #f
(define-symbolic xs integer? #:length 4)
(code:line (define (sum xs) (foldl + xs)) (code:comment "bug: missing 0 after +"))
(verify (assert (= (sum xs) (sum (filter-not zero? xs)))))
]
Because we expect this property to hold, we expect the query
to return @racket[unsat]. Instead, it returns the empty model.
To see why, note that the @racket[sum] procedure contains a
simple bug. We forgot to provide the initial value of 0 to
@racket[foldl], so @racket[foldl] is called with too few
arguments. This omission will cause every call to
@racket[sum] to raise an exception, including
@racket[(sum xs)] in the body of our query. Rosette
intercepts this exception and adds @racket[#f] to the
query's @tech{verification condition} because the exception
happens unconditionally (on all paths).
This false assertion then causes the query to return a
trivial counterexample, @racket[(model)], indicating that
@emph{any} binding of @racket[xs] to concrete integers leads
to an error.
As another example, consider the following synthesis query
involving @racket[sum]:
@examples[#:eval rosette-eval #:label #f
(define-symbolic opt boolean?)
(synthesize
#:forall xs
#:guarantee (assert (= (sum xs) (apply (if opt + -) xs))))
]
Here, the expected result is a model that binds @racket[opt]
to the value @racket[#t], and this is the outcome we see
once we fix the bug in @racket[sum]. The bug, however,
causes the @racket[#:guarantee] expression to fail
unconditionally. Rosette then intercepts the exception and
returns @racket[(unsat)] to indicate that no choice of
@racket[opt] can satisfy the specification.
Bugs of this kind can be found through testing. A good test
suite should check that queries produce expected results on
small inputs, and that query parts do not throw exceptions.
When possible, it is also good practice to test all
solver-aided code against concrete inputs and outputs. Here
is an example test suite for our first query that includes
all of these checks:
@examples[#:eval rosette-eval #:label #f
(eval:no-prompt
(require rackunit)
(define (post xs)
(assert (= (sum xs) (sum (filter-not zero? xs)))))
(define (query xs)
(verify (post xs)))
(define example-tests
(test-suite
"An example suite for a sum query."
#:before clear-vc!
#:after clear-vc!
(test-case
"Test sum with concrete values."
(check = (sum '()) 0)
(check = (sum '(-1)) -1)
(check = (sum '(-2 2)) 0)
(check = (sum '(-1 0 3)) 2))
(test-case
"Test query post for exceptions."
(before
(clear-vc!)
(check-not-exn (thunk (post xs)))))
(test-case
"Test query outcome."
(before
(clear-vc!)
(check-pred unsat? (query xs)))))))
(eval:alts
(run-test example-tests)
(format-opaque "~a" (run-test example-tests)))
]
All tests in this suite fail when invoked on the
buggy @racket[sum], and they all pass once the bug is fixed.
@subsection[#:tag "sec:errors-under-symbolic-eval"]{Bugs Due to Exceptions in Conditionals}
As we saw above, basic tests can easily uncover problems
caused by exceptions that are raised unconditionally, on all
paths. This is not surprising since such problems are also
easy to discover in concrete code---they correspond to
obvious bugs that cause an immediate crash on every input.
Catching bugs that raise exceptions only on some paths is
trickier, in both concrete and solver-aided code, as our next
example shows.
Consider the following buggy version of @racket[sum]:
@examples[#:eval rosette-eval #:label #f
(define (sum xs)
(cond
[(null? xs) 0]
[(null? (cdr xs)) (car xs)]
[(andmap (curry = (car xs)) (cdr xs))
(* (length xs) (cdr xs))] (code:comment "Bug: cdr should be car.")
[else (apply + xs)]))
]
This version of @racket[sum] implements three simple
optimizations. It returns 0 when given an empty list;
@code{xs[0]} when given a list of length 1; and
@code{|xs| * xs[0]} when given a list of identical elements.
This last optimization is buggy (it uses @racket[cdr] when
it should have used @racket[car]), and any execution path
that goes through it will end with an exception.
Suppose that we want to verify another simple property of
@racket[sum]: if it returns a positive integer, then at least
one element in the argument list must have been positive.
@examples[#:eval rosette-eval #:label #f
(assume (positive? (sum xs)))
(verify
(assert (ormap positive? xs)))]
This query returns @racket[(unsat)], as expected, despite
the bug in @racket[sum]. To see why, recall that
@racket[(verify #, @var{expr})] searches for an input that
violates an assertion in @var{expr}, while satisfying all
the assumptions and assertions accumulated in the
verification condition @racket[(vc)] before the call to
@racket[verify]. So, our query is @racket[unsat?] because
@racket[(ormap positive? xs)] holds whenever
@racket[(sum xs)] successfully computes a positive value.
A basic test suite, adapted from the
@seclink["sec:errors-under-queries"]{previous section}, will
not uncover this bug. If we run the tests against the new
@racket[sum], all the checks pass:
@examples[#:eval rosette-eval #:label #f
(eval:no-prompt
(define (pre xs)
(assume (positive? (sum xs))))
(define (post xs)
(assert (ormap positive? xs)))
(define (query xs)
(pre xs)
(verify (post xs)))
(define example-tests
(test-suite
"An example suite for a sum query."
#:before clear-vc!
#:after clear-vc!
(test-case
"Test sum with concrete values."
(check = (sum '()) 0)
(check = (sum '(-1)) -1)
(check = (sum '(-2 2)) 0)
(check = (sum '(-1 0 3)) 2))
(test-case
"Test query post for exceptions."
(before
(clear-vc!)
(check-not-exn (thunk (pre xs)))))
(test-case
"Test query post for exceptions."
(before
(clear-vc!)
(check-not-exn (thunk (post xs)))))
(test-case
"Test query outcome."
(before
(clear-vc!)
(check-pred unsat? (query xs)))))))
(eval:alts
(run-test example-tests)
(format-opaque "~a" (run-test example-tests)))
]
One way to detect bugs of this kind is to run a "unit
verification query" for each key procedure in the program,
searching for assertion failures where none are expected:
@examples[#:eval rosette-eval #:label #f
(test-case
"Test sum for any failures."
(check-pred unsat? (verify (sum xs))))
]
Another strategy is to avoid issuing any assumptions or
assertions outside of queries:
@examples[#:eval rosette-eval #:label #f
(verify
(begin
(assume (positive? (sum xs)))
(assert (ormap positive? xs))))]
But neither strategy is always possible, or
foolproof, for large programs. So, in addition to testing,
we recommend debugging all important queries with
@tech[#:key "error tracer"]{error tracing}.
@section[#:tag "sec:error-tracer"]{Error Tracer}
To help debug solver-aided code, Rosette provides an
@deftech[#:key "error tracer"]{error tracer} that tracks and
displays all exceptions raised during symbolic evaluation.
Some of these exceptions are due to bugs and some are
intentional, especially in the context of synthesis queries.
It is not possible to automatically distinguish between
these two, so the error tracer leaves that task to the
programmer.
To run the error tracer on a program file @nonterm{prog},
use the @exec{raco} command:
@commandline{raco symtrace @nonterm{prog}}
The error tracer will open a web browser and stream
all exceptions that Rosette intercepted. For instance,
here is the output from the error tracer when running our
last query on the buggy @racket[sum] example from the
@seclink["sec:errors-under-symbolic-eval"]{previous section}:
@examples[#:eval rosette-eval #:label #f #:no-prompt
(assume (positive? (sum xs)))
(verify
(assert (ormap positive? xs)))]
@(image interface.png #:scale 0.5)
The output shows a table of exceptions that Rosette
intercepted; here, there is one only exception, which is caused by our bug,
so there is only one row.
Each row consists of a shorter error message and an error location
(source file, line, and column). All rows can be expanded to show
more details: the full error message, the stack trace,
and the erroring (blamed) expression.
@subsection[#:tag "sec:symtrace:opts"]{Options and Caveats}
By default, the error tracer instruments only code that is
within a module with either @tt{rosette} or @tt{
rosette/safe} as its initial path. This default is inherited
from the symbolic profiler, and it means that only files
beginning with @tt{#lang rosette} or @tt{#lang rosette/safe}
will be instrumented. The shown call stacks and expressions
will not include non-instrumented files. To instrument
@emph{all} code, use the @DFlag{racket} flag described
below.
Similarly, by default, the error tracer instruments only code that
does not belong to installed packages. To instrument
given installed packages, use the @DFlag{pkg} flag described below.
The @exec{raco symtrace @nonterm{prog}} command accepts the following command-line flags:
@itemlist[
@item{@DFlag{module} @nonterm{module-name} --- run the
specified @nonterm{module-name} submodule of @nonterm{prog}
(defaults to the @tt{main} submodule).}
@item{@DFlag{racket} --- instrument code in any language, not
just those derived from Rosette.}
@;{@item{@DFlag{solver} --- do not show exceptions raised on
infeasible paths, using the solver to decide if paths are
feasible. This option can cause significant performance degradation.}}
@item{@DFlag{assert} --- do not show exceptions due to
assertion errors, which are usually expected exceptions.}
@item{@DFlag{pkg} @nonterm{pkg-name} --- instrument code in @nonterm{pkg-name}.}
]
Inside the web browser, the output can be customized further.
@itemlist[
@item{The @bold{Group similar rows} switch will @emph{heuristically}
group similar rows together, enabling easier navigation
when many exceptions originate from the same place and due to the same cause.}
@item{The @bold{Show Racket stacktrace} switch will display the top 32 entries of
the Racket stack trace in addition to the Rosette stack trace.
The Racket stack trace includes the details of evaluating Rosette's internal procedures,
which the Rosette trace omits. These details are usually not necessary for
understanding errors in Rosette code, so the switch is off by default.}
@item{The search box can be used to find rows that include the search string in their error message.}
]
@section{Walkthrough: Tracing Errors in Rosette}
To illustrate a typical error tracing process, consider
verifying the following buggy implementation of the
@link["https://en.wikipedia.org/wiki/Quickselect"]{
quickselect algorithm}.
@examples[#:eval rosette-eval #:label #f #:no-prompt
(define (select xs n)
(cond
[(empty? xs) (assert #f "unexpected empty list")]
[else (define pivot (first xs))
(define non-pivot (rest xs))
(define <pivot (filter (λ (x) (< x pivot)) non-pivot))
(define >=pivot (filter (λ (x) (>= x pivot)) non-pivot))
(define len< (length <pivot))
(cond
[(= n len<) pivot]
[(< n len<) (select <pivot)] (code:comment "Bug: should be (select <pivot n).")
[else (select >=pivot (- n len< 1))])]))
(define-symbolic n k integer?)
(assume
(and (<= 0 n (sub1 (length xs)))
(= k (select xs n))))
(verify
(assert (= k (list-ref (sort xs <) n))))
]
As before, the verification query succeeds despite the bug.
But unlike before, the bug is harder to detect. So we
run the error tracer on it and obtain the following output:
@(image quickselect.png #:scale 0.5)
The output from the error tracer includes 8 exceptions. Four
are arity mismatch exceptions that are due to the bug, and
the rest are benign assertion failures that cannot happen in
our example.
Because benign assertion failures are so common, the error
tracer provides an option to heuristically suppress them
from the output via the
@seclink["sec:symtrace:opts"]{@DFlag{assert}} flag. With the
flag enabled, the output contains only the four arity
mismatch exceptions.
Some assertion failures are bugs, however, so filtering with
@DFlag{assert} can end up hiding true positives and should
be used with this caveat in mind.

BIN
rosette/guide/scribble/error-tracing/interface.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 145 KiB

BIN
rosette/guide/scribble/error-tracing/quickselect.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 324 KiB

24
rosette/guide/scribble/error-tracing/select.rkt
View File

@ -1,24 +0,0 @@
#lang rosette
(define-symbolic xs integer? #:length 4)
(define-symbolic k integer?)
(define-symbolic n integer?)
(define (select xs n)
(cond
[(empty? xs) (assert #f "unexpected empty list")]
[else (define pivot (first xs))
(define non-pivot (rest xs))
(define <pivot (filter (λ (x) (< x pivot)) non-pivot))
(define >=pivot (filter (λ (x) (>= x pivot)) non-pivot))
(define len< (length <pivot))
(cond
[(= n len<) pivot]
[(< n len<) (select <pivot)]
[else (select >=pivot (- n len< 1))])]))
(assume (and (<= 0 n (sub1 (length xs)))
(= k (select xs n))))
(verify (assert (= k (list-ref (sort xs <) n))))

15
rosette/guide/scribble/error-tracing/sum.rkt
View File

@ -1,15 +0,0 @@
#lang rosette
(define (sum xs)
(cond
[(null? xs) 0]
[(null? (cdr xs)) (car xs)]
[(andmap (curry = (car xs)) (cdr xs))
(* (length xs) (cdr xs))]
[else (apply + xs)]))
(define-symbolic xs integer? #:length 4)
(assume (positive? (sum xs)))
(verify (assert (ormap positive? xs)))

96
rosette/guide/scribble/error-tracing/test.rkt
View File

@ -1,96 +0,0 @@
#lang rosette
(define (sum0 xs) (foldl + xs))
(define (sum1 xs) (foldl + 0 xs))
(define (sum2 xs)
(cond
[(null? xs) 0]
[(null? (cdr xs)) (car xs)]
[(andmap (curry = (car xs)) (cdr xs))
(* (length xs) (cdr xs))]
[else (apply + xs)]))
(define-symbolic xs integer? #:length 4)
(require rackunit)
(define (tests0 sum)
(define (post xs)
(assert (= (sum xs) (sum (filter-not zero? xs)))))
(define (query xs)
(verify (post xs)))
(test-suite
"An example suite for a sum query."
#:before clear-vc!
#:after clear-vc!
(test-case
"Test sum with concrete values."
(check = (sum '()) 0)
(check = (sum '(-1)) -1)
(check = (sum '(-2 2)) 0)
(check = (sum '(-1 0 3)) 2))
(test-case
"Test query post for exceptions."
(before
(clear-vc!)
(check-not-exn (thunk (post xs)))))
(test-case
"Test query outcome."
(before
(clear-vc!)
(check-pred unsat? (query xs))))))
(define (tests1 sum)
(define (pre xs)
(assume (positive? (sum xs))))
(define (post xs)
(assert (ormap positive? xs)))
(define (query xs)
(pre xs)
(verify (post xs)))
(test-suite
"An example suite for a sum query."
#:before clear-vc!
#:after clear-vc!
(test-case
"Test sum with concrete values."
(check = (sum '()) 0)
(check = (sum '(-1)) -1)
(check = (sum '(-2 2)) 0)
(check = (sum '(-1 0 3)) 2))
(test-case
"Test query post for exceptions."
(before
(clear-vc!)
(check-not-exn (thunk (pre xs)))))
(test-case
"Test query post for exceptions."
(before
(clear-vc!)
(check-not-exn (thunk (post xs)))))
(test-case
"Test query outcome."
(before
(clear-vc!)
(check-pred unsat? (query xs))))))
(run-test (tests0 sum0))
(run-test (tests0 sum1))
(run-test (tests0 sum2))
(run-test (tests1 sum2))

202
rosette/guide/scribble/essentials/bvmid.rkt
View File

@ -1,202 +0,0 @@
#lang rosette
(require (only-in racket/sandbox with-deep-time-limit))
(require rosette/solver/smt/z3)
(require rosette/guide/scribble/util/demo)
(require rosette/lib/synthax)
(provide (all-defined-out))
(define int32? (bitvector 32))
(define (int32 i)
(bv i int32?))
(define (bvmid lo hi)
(bvsdiv (bvadd lo hi) (int32 2)))
(define (bvmid-no-overflow lo hi)
(bvadd lo (bvsdiv (bvsub hi lo) (int32 2))))
(define (check-mid impl lo hi)
(assume (bvsle (int32 0) lo))
(assume (bvsle lo hi))
(define mi (impl lo hi))
(define diff
(bvsub (bvsub hi mi)
(bvsub mi lo)))
(assert (bvsle lo mi))
(assert (bvsle mi hi))
(assert (bvsle (int32 0) diff))
(assert (bvsle diff (int32 1))))
(define-symbolic l h int32?)
(define-grammar (fast-int32 x y)
[expr (choose
x y (?? int32?)
((bop) (expr) (expr))
((uop) (expr)))]
[bop (choose bvadd bvsub bvand bvor bvxor bvshl bvlshr bvashr)]
[uop (choose bvneg bvnot)])
(define (bvmid-fast lo hi)
(fast-int32 lo hi #:depth 2))
(define (bvmid-and? lo hi)
(equal? (fast-int32 l h #:depth 1) (fast-int32 l h #:depth 1)))
(define (check-sqrt impl n)
(assume (bvsle (int32 0) n))
(define √n (impl l))
(define √n+1 (bvadd √n (int32 1)))
(assert (bvule (bvmul √n √n) n))
(assert (bvult n (bvmul √n+1 √n+1))))
(define (check-mid-slow impl lo hi)
(assume (bvsle (int32 0) lo))
(assume (bvsle lo hi))
(assert
(equal?
(bitvector->integer (impl lo hi))
(quotient (+ (bitvector->integer lo) (bitvector->integer hi)) 2))))
(define-demo check-mid-demo
(demo (check-mid bvmid (int32 0) (int32 0)))
(demo (check-mid bvmid (int32 0) (int32 1)))
(demo (check-mid bvmid (int32 0) (int32 2)))
(demo (check-mid bvmid (int32 10) (int32 10000))))
(define-demo verify-demo
(define cex (time (verify (check-mid bvmid l h))))
(demo cex)
(define cl (evaluate l cex))
(define ch (evaluate h cex))
(demo cl)
(demo ch)
(demo (bvmid cl ch))
(demo (check-mid bvmid cl ch))
(demo (verify (check-mid bvmid-no-overflow l h))))
(define-demo synthesize-demo
(define sol
(time
(synthesize
#:forall (list l h)
#:guarantee (check-mid bvmid-fast l h))))
(demo (dict-count (model sol)))
(demo sol)
(demo (print-forms sol)))
(define-demo solve-demo
(define (bvmid-fast lo hi)
(bvlshr (bvadd hi lo) (bv #x00000001 32)))
(demo
(print-forms
(time
(synthesize
#:forall (list l h)
#:guarantee
(begin
(assume (not (equal? l h)))
(assume (bvsle (int32 0) l))
(assume (bvsle l h))
(assert
(<=> (bvmid-and? l h)
(equal? (bvand l h) (bvmid-fast l h))))))))))
(define-demo slowdown-demo
(demo (time (verify (check-mid bvmid l h))))
(demo (time (verify (check-mid-slow bvmid l h))))
(demo (time (verify (check-mid bvmid-no-overflow l h))))
(demo (with-deep-time-limit 10 (verify (check-mid-slow bvmid-no-overflow l h)))))
(define-demo current-bitwidth-64-demo
(parameterize ([current-bitwidth 64])
(demo (time (verify (check-mid-slow bvmid l h))))
(demo (time (verify (check-mid-slow bvmid-no-overflow l h))))))
(define-demo current-bitwidth-32-demo
(parameterize ([current-bitwidth 32])
(demo (time (verify (check-mid-slow bvmid l h))))
(demo (time (verify (check-mid-slow bvmid-no-overflow l h))))))
(define-demo solver-options-demo
(demo (current-solver (z3 #:logic 'QF_BV)))
(demo (time (verify (check-mid bvmid l h))))
(demo (time (verify (check-mid-slow bvmid l h))))
(current-solver (z3)))
(define-demo infinite-loop-demo
(define (bvsqrt n)
(cond
[(bvult n (int32 2)) n]
[else
(define s0 (bvshl (bvsqrt (bvlshr n (int32 2))) (int32 1)))
(define s1 (bvadd s0 (int32 1)))
(if (bvugt (bvmul s1 s1) n) s0 s1)]))
(demo (bvsqrt (int32 3)))
(demo (bvsqrt (int32 4)))
(demo (bvsqrt (int32 15)))
(demo (bvsqrt (int32 16)))
(demo (with-terms
(with-deep-time-limit 10 (bvsqrt l)))))
(define-demo sound-finitization-demo
(define fuel (make-parameter 5))
(define-syntax-rule
(define-bounded (id param ...) body ...)
(define (id param ...)
(assert (> (fuel) 0) "Out of fuel") ; <--- no false negatives
(parameterize ([fuel (sub1 (fuel))])
body ...)))
(define-bounded (bvsqrt n)
(cond
[(bvult n (int32 2)) n]
[else
(define s0 (bvshl (bvsqrt (bvlshr n (int32 2))) (int32 1)))
(define s1 (bvadd s0 (int32 1)))
(if (bvugt (bvmul s1 s1) n) s0 s1)]))
(demo (time (verify (check-sqrt bvsqrt l))))
(demo (fuel 16))
(demo (time (verify (check-sqrt bvsqrt l)))))
(define-demo complete-finitization-demo
(define fuel (make-parameter 5))
(define-syntax-rule
(define-bounded (id param ...) body ...)
(define (id param ...)
(assume (> (fuel) 0) "Out of fuel") ; <--- no false positives
(parameterize ([fuel (sub1 (fuel))])
body ...)))
(define-bounded (bvsqrt n)
(cond
[(bvult n (int32 2)) n]
[else
(define s0 (bvshl (bvsqrt (bvlshr n (int32 2))) (int32 1)))
(define s1 (bvadd s0 (int32 1)))
(if (bvugt (bvmul s1 s1) n) s0 s1)]))
(demo (time (verify (check-sqrt bvsqrt l))))
(demo (fuel 16))
(demo (time (verify (check-sqrt bvsqrt l)))))
(module+ main
(check-mid-demo)
(verify-demo)
(synthesize-demo)
(solve-demo)
(slowdown-demo)
(current-bitwidth-64-demo)
(current-bitwidth-32-demo)
(solver-options-demo)
(infinite-loop-demo)
(sound-finitization-demo)
(complete-finitization-demo))

787
rosette/guide/scribble/essentials/essentials-log.txt
View File

@ -1,787 +0,0 @@
;; This file was created by make-log-based-eval
((define-symbolic b boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
(b
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "b\n"))))
#""
#"")
((boolean? b) ((3) 0 () 0 () () (q values #t)) #"" #"")
((integer? b) ((3) 0 () 0 () () (q values #f)) #"" #"")
((vector b 1)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vector b 1)\n"))))
#""
#"")
((not b)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(! b)\n"))))
#""
#"")
((boolean? (not b)) ((3) 0 () 0 () () (q values #t)) #"" #"")
((define-symbolic* n integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define (static) (define-symbolic x boolean?) x)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define (dynamic) (define-symbolic* y integer?) y)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((eq? (static) (static)) ((3) 0 () 0 () () (q values #t)) #"" #"")
((eq? (dynamic) (dynamic))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(= y$1 y$2)\n"))))
#""
#"")
((define (yet-another-x) (define-symbolic x boolean?) x)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((eq? (static) (yet-another-x))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(<=> x x)\n"))))
#""
#"")
((assert #t) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assert #f) ((3) 0 () 0 () () (q exn "[assert] failed")) #"" #"")
((vc-asserts (vc)) ((3) 0 () 0 () () (q values #f)) #"" #"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc-asserts (vc)) ((3) 0 () 0 () () (q values #t)) #"" #"")
((assert (not b)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc-asserts (vc))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(! b)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assume #t) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc-assumes (vc)) ((3) 0 () 0 () () (q values #t)) #"" #"")
((assume #f) ((3) 0 () 0 () () (q exn "[assume] failed")) #"" #"")
((vc-assumes (vc)) ((3) 0 () 0 () () (q values #f)) #"" #"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic i j integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assume (> j 0)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc-assumes (vc))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(< 0 j)\n"))))
#""
#"")
((assert (< (- i j) i)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc-asserts (vc))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(|| (! (< 0 j)) (< (+ i (- j)) i))\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc (< 0 j) (|| (! (< 0 j)) (< (+ i (- j)) i)))\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define int32? (bitvector 32)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define (int32 i) (bv i int32?))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((int32? 1) ((3) 0 () 0 () () (q values #f)) #"" #"")
((int32? (int32 1)) ((3) 0 () 0 () () (q values #t)) #"" #"")
((int32 1)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x00000001 32)\n"))))
#""
#"")
((define (bvmid lo hi) (bvsdiv (bvadd lo hi) (int32 2)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define (check-mid impl lo hi)
(assume (bvsle (int32 0) lo))
(assume (bvsle lo hi))
(define mi (impl lo hi))
(define diff (bvsub (bvsub hi mi) (bvsub mi lo)))
(assert (bvsle lo mi))
(assert (bvsle mi hi))
(assert (bvsle (int32 0) diff))
(assert (bvsle diff (int32 1))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((check-mid bvmid (int32 0) (int32 0))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((check-mid bvmid (int32 0) (int32 1))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((check-mid bvmid (int32 0) (int32 2))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((check-mid bvmid (int32 10) (int32 10000))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define-symbolic l h int32?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define cex (verify (check-mid bvmid l h)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(cex
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [l (bv #x394f0402 32)]\n [h (bv #x529e7c00 32)])\n"))))
#""
#"")
((define cl (evaluate l cex)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define ch (evaluate h cex)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((list cl ch)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(list (bv #x394f0402 32) (bv #x529e7c00 32))\n"))))
#""
#"")
((define il (bitvector->integer cl))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define ih (bitvector->integer ch))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((list il ih)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "'(961479682 1386118144)\n"))))
#""
#"")
((define m (bvmid cl ch)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
(m
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #xc5f6c001 32)\n"))))
#""
#"")
((bitvector->integer m) ((3) 0 () 0 () () (q values -973684735)) #"" #"")
((quotient (+ il ih) 2) ((3) 0 () 0 () () (q values 1173798913)) #"" #"")
((int32 (quotient (+ il ih) 2))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x45f6c001 32)\n"))))
#""
#"")
((check-mid bvmid cl ch) ((3) 0 () 0 () () (q exn "[assert] failed")) #"" #"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((bvadd cl ch)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x8bed8002 32)\n"))))
#""
#"")
((bitvector->integer (bvadd cl ch))
((3) 0 () 0 () () (q values -1947369470))
#""
#"")
((+ il ih) ((3) 0 () 0 () () (q values 2347597826)) #"" #"")
((- (expt 2 31) 1) ((3) 0 () 0 () () (q values 2147483647)) #"" #"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define (bvmid-no-overflow lo hi) (bvadd lo (bvsdiv (bvsub hi lo) (int32 2))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((verify (check-mid bvmid-no-overflow l h))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((require rosette/lib/synthax) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-grammar
(fast-int32 x y)
(expr (choose x y (?? int32?) ((bop) (expr) (expr)) ((uop) (expr))))
(bop (choose bvadd bvsub bvand bvor bvxor bvshl bvlshr bvashr))
(uop (choose bvneg bvnot)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((require (only-in rosette/guide/scribble/essentials/bvmid bvmid-fast))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((require (only-in rosette/guide/scribble/util/demo print-forms-alt))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define sol
(synthesize #:forall (list l h) #:guarantee (check-mid bvmid-fast l h)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(sol
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(model\n [0$choose:bvmid:37:9$expr:bvmid:37:3$fast-int32:bvmid:45:3 #f]\n [1$choose:bvmid:37:9$expr:bvmid:37:3$fast-int32:bvmid:45:3 #f]\n [2$choose:bvmid:37:9$expr:bvmid:37:3$fast-int32:bvmid:45:3 #f]\n [3$choose:bvmid:37:9$expr:bvmid:37:3$fast-int32:bvmid:45:3 #t]\n ...)\n\n"))))
#""
#"")
((print-forms-alt sol)
((3) 0 () 0 () () (c values c (void)))
#"(define (bvmid-fast lo hi) (bvlshr (bvadd hi lo) (bv #x00000001 32)))\n"
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define (bvmid-fast lo hi) (bvlshr (bvadd hi lo) (bv 1 32)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define sol
(solve
(begin
(assume (not (equal? l h)))
(assume (bvsle (int32 0) l))
(assume (bvsle l h))
(assert (equal? (bvand l h) (bvmid-fast l h))))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(sol
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [l (bv #x3f761e94 32)]\n [h (bv #x3f761e95 32)])\n"))))
#""
#"")
((evaluate (bvand l h) sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x3f761e94 32)\n"))))
#""
#"")
((evaluate (bvmid-fast l h) sol)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x3f761e94 32)\n"))))
#""
#"")
((define (bvmid-and? lo hi) #f) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((void) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define (check-mid-slow impl lo hi)
(assume (bvsle (int32 0) lo))
(assume (bvsle lo hi))
(assert
(equal?
(bitvector->integer (impl lo hi))
(quotient (+ (bitvector->integer lo) (bitvector->integer hi)) 2))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((require (only-in racket error))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((time (verify (check-mid bvmid l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [l (bv #x394f0402 32)]\n [h (bv #x529e7c00 32)])\n"))))
#"cpu time: 0 real time: 38 gc time: 0\n"
#"")
((time (verify (check-mid-slow bvmid l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [l (bv #x2faef9a1 32)]\n [h (bv #x5eefb8dd 32)])\n"))))
#"cpu time: 1 real time: 172 gc time: 0\n"
#"")
((time (verify (check-mid bvmid-no-overflow l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#"cpu time: 0 real time: 160 gc time: 0\n"
#"")
((error 'call-with-deep-time-limit "out of time")
((3) 0 () 0 () () (q exn "call-with-deep-time-limit: out of time"))
#""
#"")
((current-bitwidth) ((3) 0 () 0 () () (q values #f)) #"" #"")
((current-bitwidth 64) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((time (verify (check-mid-slow bvmid l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [l (bv #x00000001 32)]\n [h (bv #x7fffffff 32)])\n"))))
#"cpu time: 0 real time: 23 gc time: 0\n"
#"")
((time (verify (check-mid-slow bvmid-no-overflow l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#"cpu time: 0 real time: 159 gc time: 0\n"
#"")
((current-bitwidth 32) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((time (verify (check-mid-slow bvmid l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#"cpu time: 0 real time: 0 gc time: 0\n"
#"")
((time (verify (check-mid-slow bvmid-no-overflow l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [l (bv #x71979fa3 32)]\n [h (bv #x76b91b88 32)])\n"))))
#"cpu time: 1 real time: 152 gc time: 0\n"
#"")
((current-bitwidth 512) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((time (verify (check-mid-slow bvmid l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [l (bv #x70000006 32)]\n [h (bv #x73fffffa 32)])\n"))))
#"cpu time: 1 real time: 385 gc time: 0\n"
#"")
((time (verify (check-mid-slow bvmid-no-overflow l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#"cpu time: 0 real time: 430 gc time: 0\n"
#"")
((current-bitwidth #f) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((require rosette/solver/smt/z3)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((current-solver (z3 #:logic 'QF_BV))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((time (verify (check-mid bvmid l h)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(model\n [l (bv #x394f0402 32)]\n [h (bv #x529e7c00 32)])\n"))))
#"cpu time: 3 real time: 33 gc time: 0\n"
#"")
((time (verify (check-mid-slow bvmid l h)))
((3)
0
()
0
()
()
(q
exn
"read-solution: unrecognized solver output: (error line 68 column 19: Invalid function definition: unknown sort 'Int')"))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((current-solver (z3)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define (bvsqrt n)
(cond
((bvult n (int32 2)) n)
(else
(define s0 (bvshl (bvsqrt (bvlshr n (int32 2))) (int32 1)))
(define s1 (bvadd s0 (int32 1)))
(if (bvugt (bvmul s1 s1) n) s0 s1))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((bvsqrt (int32 3))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x00000001 32)\n"))))
#""
#"")
((bvsqrt (int32 4))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x00000002 32)\n"))))
#""
#"")
((bvsqrt (int32 15))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x00000003 32)\n"))))
#""
#"")
((bvsqrt (int32 16))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bv #x00000004 32)\n"))))
#""
#"")
((error 'call-with-deep-time-limit "out of time")
((3) 0 () 0 () () (q exn "call-with-deep-time-limit: out of time"))
#""
#"")
((define n0 l) ((3) 0 () 0 () () (c values c (void))) #"" #"")
(n0
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "l\n"))))
#""
#"")
((define n1 (bvlshr n0 (int32 2)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(n1
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(bvlshr l (bv #x00000002 32))\n"))))
#""
#"")
((define n2 (bvlshr n1 (int32 2)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(n2
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(bvlshr (bvlshr l (bv #x00000002 32)) (bv #x00000002 32))\n"))))
#""
#"")
((define n3 (bvlshr n2 (int32 2)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
(n3
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0
(u
.
"(bvlshr\n (bvlshr (bvlshr l (bv #x00000002 32)) (bv #x00000002 32))\n (bv #x00000002 32))\n\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((require (only-in racket make-parameter parameterize))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define fuel (make-parameter 5))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define-syntax-rule
(define-bounded (id param ...) body ...)
(define (id param ...)
(assert (> (fuel) 0) "Out of fuel.")
(parameterize ((fuel (sub1 (fuel)))) body ...)))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define-bounded
(bvsqrt n)
(cond
((bvult n (int32 2)) n)
(else
(define s0 (bvshl (bvsqrt (bvlshr n (int32 2))) (int32 1)))
(define s1 (bvadd s0 (int32 1)))
(if (bvugt (bvmul s1 s1) n) s0 s1))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define (check-sqrt impl n)
(assume (bvsle (int32 0) n))
(define √n (impl l))
(define √n+1 (bvadd √n (int32 1)))
(assert (bvule (bvmul √n √n) n))
(assert (bvult n (bvmul √n+1 √n+1))))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((define cex (time (verify (check-sqrt bvsqrt l))))
((3) 0 () 0 () () (c values c (void)))
#"cpu time: 4 real time: 1143 gc time: 0\n"
#"")
((bvsqrt (evaluate l cex))
((3) 0 () 0 () () (q exn "[assert] Out of fuel."))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((fuel 16) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((time (verify (check-sqrt bvsqrt l)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#"cpu time: 4 real time: 67938 gc time: 0\n"
#"")

537
rosette/guide/scribble/essentials/essentials.scrbl
View File

@ -1,537 +0,0 @@
#lang scribble/manual
@(require (for-label
racket
(only-in racket/sandbox with-deep-time-limit)
rosette/base/form/define
rosette/query/query
rosette/solver/solution
(only-in rosette/base/base
assert assume vc vc-asserts vc-assumes clear-vc!
bv? bitvector
bvsdiv bvadd bvsle bvsub bvand
bvor bvxor bvshl bvlshr bvashr
bvnot bvneg)
rosette/lib/synthax))
@(require racket/sandbox racket/runtime-path scribble/core scribble/racket
scribble/example scribble/html-properties scriblib/footnote)
@(require (only-in "../refs.scrbl" ~cite rosette:onward13 rosette:pldi14)
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "essentials-log")))
@(define (symbolic s) @racketresultfont[s])
@(define-footnote footnote footnote-part)
@title[#:tag "ch:essentials"]{Rosette Essentials}
Rosette adds to Racket a collection of solver-aided facilities.
These facilities enable programmers to conveniently access a constraint solver
that can answer interesting questions about program behaviors. They are based on four
key concepts: @emph{symbolic values}, @emph{assertions}, @emph{assumptions}, and @emph{queries}.
We use assertions and assumptions to express desired program behaviors and symbolic values to
formulate queries about these behaviors.
This chapter illustrates the basics of solver-aided programming.
More advanced tutorials, featuring extended examples, can be found
in Section 2 of @~cite[rosette:onward13 rosette:pldi14].@footnote{Code examples in
these references are written in earlier versions of Rosette.
While Rosette 4 is not backward compatible with these versions,
they share the same conceptual core.}
The following chapters describe the subset
of Racket that can be @seclink["sec:langs"]{safely} used with solver-aided facilities, including the
supported datatypes (both @seclink["ch:built-in-datatypes"]{built-in}
and @seclink["ch:programmer-defined-datatypes"]{programmer-defined}),
@seclink["ch:syntactic-forms"]{syntactic forms}, and @seclink["ch:libraries"]{libraries}.
@section[#:tag "sec:symbolic-values"]{Symbolic Values}
The Rosette language includes two kinds of values: concrete and symbolic. Concrete values are plain Racket values (@racket[#t], @racket[#f], @racket[0], @racket[1], etc.), and Rosette programs that operate only on concrete values behave like Racket programs. Accessing the solver-aided features of Rosette---such as code synthesis or verification---requires the use of symbolic values.
@deftech[#:key "symbolic constant"]{Symbolic constants} are the simplest kind of symbolic value. They can be created using the @racket[define-symbolic] form:
@examples[#:eval rosette-eval #:label #f
(define-symbolic b boolean?)
b]
This generates a fresh symbolic constant of type boolean and binds it to the variable @racket[b].
You can think of a symbolic constant as a placeholder for a concrete constant of the same type. As we will see shortly, the solver, once called, determines which concrete value a given symbolic constant represents: it will tell us whether the constant @symbolic{b} is @racket[#t] or @racket[#f], depending on what question we ask about the behavior of a program (or a procedure) applied to @symbolic{b}.
Symbolic values, including constants, can be used just like concrete values of the same type. They can be stored in data structures or passed to procedures to obtain other values, either concrete or symbolic:
@examples[#:eval rosette-eval #:label #f
(boolean? b)
(integer? b)
(vector b 1)
(not b)
(boolean? (not b))]
In our example, all but the fourth expression produce concrete values. The fourth expression returns another symbolic value---specifically, a symbolic @emph{expression} of type boolean. This expression represents the negation of @symbolic{b}. If the solver determines that @symbolic{b} is @racket[#t], for example, then @symbolic{(! b)} will be interpreted as @racket[#f].
Rosette provides one more construct for creating symbolic constants besides @racket[define-symbolic]:
@examples[#:eval rosette-eval #:label #f #:no-prompt
(define-symbolic* n integer?)]
The two constructs differ in how they bind variables to constants when evaluated more than once.
The @racket[define-symbolic] form binds the variable to the same (unique) constant every time it is evaluated. The @racket[define-symbolic*] form, in contrast, creates a stream of (unique) constants, binding the variable to the next constant from its stream whenever the form is evaluated. The following example illustrates the difference:
@examples[#:eval rosette-eval #:label #f
(eval:no-prompt
(define (static)
(define-symbolic x boolean?) (code:comment "Creates the same constant when evaluated.")
x))
(eval:no-prompt
(define (dynamic)
(define-symbolic* y integer?) (code:comment "Creates a fresh constant when evaluated.")
y))
(eq? (static) (static))
(eq? (dynamic) (dynamic))]
Printed constant names, such as @symbolic{x} or @symbolic{b}, are just comments. Two constants created by evaluating two distinct @racket[define-symbolic] (or, @racket[define-symbolic*]) forms are distinct, even if they have the same printed name. They may still represent the same concrete value, but that is determined by the solver:
@examples[#:eval rosette-eval #:label #f
(eval:no-prompt
(define (yet-another-x)
(define-symbolic x boolean?)
x))
(eq? (static) (yet-another-x))]
@section[#:tag "sec:asserts"]{Assertions and Assumptions}
Like many languages, Rosette provides a construct for expressing @emph{assertions}---important properties of programs that are checked in every execution. Rosette assertions work just like Java or Racket assertions when given a concrete value: if the value is false, the execution terminates with a runtime exception. Otherwise, the execution proceeds normally.
@examples[#:eval rosette-eval #:label #f
(assert #t)
(eval:error (assert #f))]
When given a symbolic boolean value, however, a Rosette assertion has no immediate effect. Instead, the value is accumulated in the current @tech{verification condition} (VC), and the assertion's effect (whether it passes or fails) is eventually determined by the solver.
@examples[#:eval rosette-eval #:label #f
(code:line (vc-asserts (vc)) (code:comment "We asserted #f above, so the current VC reflects that."))
(code:line (clear-vc!) (code:comment "Clear the current VC."))
(vc-asserts (vc))
(code:line (assert (not b)) (code:comment "Add the assertion (not b) to the VC."))
(vc-asserts (vc))
(clear-vc!)]
Assertions express properties that a program must satisfy on all @emph{legal} inputs. In Rosette, as in other solver-aided frameworks, we use @emph{assumptions} to describe which inputs are legal. If a program violates an assertion on a legal input, we blame the program. But if it violates an assertion on an illegal input, we blame the caller. In other words, a program is considered incorrect only when it violates an assertion on a legal input.
Assumptions behave analogously to assertions on both concrete and symbolic values. In the concrete case, assuming @racket[#f] aborts the execution with a runtime exception, and assuming a true value is equivalent to calling @racket[(void)]. In the symbolic case, the assumed value is accumulated in the current VC.
@examples[#:eval rosette-eval #:label #f
(assume #t)
(vc-assumes (vc))
(eval:alts
(code:line (assume #f) (code:comment "Assuming #f aborts the execution with an exception."))
(eval:error (assume #f)))
(vc-assumes (vc))
(clear-vc!)
(define-symbolic i j integer?)
(code:line (assume (> j 0)) (code:comment "Add the assumption (> j 0) to the VC."))
(vc-assumes (vc))
(assert (< (- i j) i))
(code:line (vc-asserts (vc)) (code:comment "The assertions must hold when the assumptions hold."))
(code:line (vc) (code:comment "VC tracks the assumptions and the assertions."))]
@(rosette-eval '(clear-vc!))
@section[#:tag "sec:queries"]{Solver-Aided Queries}
The solver reasons about assumed and asserted properties only when we ask a question about them---for example, ``Does my program have an execution that violates an assertion while satisfying all the assumptions?'' We pose such @emph{solver-aided queries} with the help of constructs explained in the remainder of this chapter.
We will illustrate the queries on the following toy example. Suppose that we want to implement a
procedure @racket[bvmid] that takes as input two non-negative 32-bit integers, @racket[lo] ≤ @racket[hi],
and returns the midpoint of the interval [@racket[lo], @racket[hi]]. In C or Java, we would declare
the inputs and output of @racket[bvmid] to be of type ``int''. In Rosette, we model finite precision
(i.e., machine) integers as @seclink["sec:bitvectors"]{bitvectors} of length 32.
@examples[#:eval rosette-eval #:label #f #:no-prompt
(code:comment "int32? is a shorthand for the type (bitvector 32).")
(define int32? (bitvector 32))]
@examples[#:eval rosette-eval #:label #f #:no-prompt
(code:comment "int32 takes as input an integer literal and returns")
(code:comment "the corresponding 32-bit bitvector value.")
(define (int32 i)
(bv i int32?))]
@examples[#:eval rosette-eval #:label #f
(code:line (int32? 1) (code:comment "1 is not a 32-bit integer"))
(code:line (int32? (int32 1)) (code:comment "but (int32 1) is."))
(int32 1)]
Bitvectors support the usual operations on machine integers, and we can use them to implement @racket[bvmid] as follows:
@examples[#:eval rosette-eval #:label #f #:no-prompt
(code:comment "Returns the midpoint of the interval [lo, hi].")
(define (bvmid lo hi) (code:comment "(lo + hi) / 2")
(bvsdiv (bvadd lo hi) (int32 2)))]
As the above implementation suggests, we intend the midpoint to be the mathematical
integer @tt{mi = (lo + hi) / 2}, where @tt{/} stands for integer division. Assuming
that @tt{0 ≤ lo ≤ hi}, the midpoint @tt{mi} is fully characterized by two properties:
(1) @tt{lo ≤ mi ≤ hi} and (2) @tt{0 ≤ (hi - mi) - (mi - lo) ≤ 1}. We can use these
properties to define a generic correctness specification for any implementation of
@racket[bvmid] as follows:
@examples[#:eval rosette-eval #:label #f #:no-prompt
(code:line
(define (check-mid impl lo hi) (code:comment "Assuming that")
(assume (bvsle (int32 0) lo)) (code:comment "0 ≤ lo and")
(assume (bvsle lo hi)) (code:comment "lo ≤ hi,")
(define mi (impl lo hi)) (code:comment "and letting mi = impl(lo, hi) and")
(define diff (code:comment "diff = (hi - mi) - (mi - lo),")
(bvsub (bvsub hi mi)
(bvsub mi lo))) (code:comment "we require that")
(assert (bvsle lo mi)) (code:comment "lo ≤ mi,")
(assert (bvsle mi hi)) (code:comment "mi ≤ hi,")
(assert (bvsle (int32 0) diff)) (code:comment "0 ≤ diff, and")
(assert (bvsle diff (int32 1)))) (code:comment "diff ≤ 1."))]
This is not the only way to specify the behavior of @racket[bvmid], and we will see an
alternative specification later on. In general, there are many ways to describe what it
means for a program to be correct, and often, these descriptions are partial:
they constrain some aspects of the implementation (e.g., the output is positive)
without fully defining its behavior. In our example, @racket[check-mid] is a
@emph{full functional correctness specification} in that it admits exactly one output value for @racket[(impl lo hi)], namely, @tt{(lo + hi) / 2}.
Testing @racket[bvmid] against its specification on a few concrete legal inputs, we find
that it triggers no assertion failures, as expected:
@examples[#:eval rosette-eval #:label #f
(check-mid bvmid (int32 0) (int32 0))
(check-mid bvmid (int32 0) (int32 1))
(check-mid bvmid (int32 0) (int32 2))
(check-mid bvmid (int32 10) (int32 10000)) ]
But does it work correctly on @emph{all} legal inputs? The answer, as we will see below, is ``no''.
In fact, @racket[bvmid] reproduces @hyperlink["https://en.wikipedia.org/wiki/Binary_search_algorithm#Implementation_issues"]{a famous bug}
that lurked for years in widely used C and Java implementations of binary search.
@subsection[#:tag "sec:verify"]{Verification}
How can we check if @racket[bvmid] satisfies its specification on all legal inputs? One approach is to enumerate all pairs of 32-bit integers with @racket[0 ≤ lo ≤ hi] and apply @racket[(check-mid bvmid hi lo)] to each. This approach is sound (it is guaranteed to find a bug if one exists), but a quick calculation shows that it is impractical even for our toy example: @racket[bvmid] has roughly 2.3 × 10@superscript{18} legal inputs. A better approach is to delegate such checks to a constraint solver, which can search large input spaces much more effectively than naive enumeration. In Rosette, this is done with the help of the @racket[verify] query:
@examples[#:eval rosette-eval #:label #f
(eval:no-prompt (define-symbolic l h int32?))
(define cex (verify (check-mid bvmid l h)))
cex]
The @racket[(verify #, @var[expr])] form queries the solver for a @deftech{binding} from symbolic constants to concrete values that causes the evaluation of @var[expr] to violate an assertion, while satisfying all the assumptions, when the bound symbolic constants are replaced with the corresponding concrete values. If such a binding exists, as it does in our case, it is called a @emph{counterexample}.
Bindings are first-class values in Rosette, and they can be freely manipulated by programs. We can also interpret any Rosette value with respect to a binding using the built-in @racket[evaluate] procedure:
@examples[#:eval rosette-eval #:label #f
(define cl (evaluate l cex))
(define ch (evaluate h cex))
(list cl ch)
(code:comment "We can convert these values to integer? constants for debugging:")
(define il (bitvector->integer cl))
(define ih (bitvector->integer ch))
(list il ih)
(code:comment "Here is the computed midpoint:")
(define m (bvmid cl ch))
m
(bitvector->integer m)
(code:comment "This is clearly wrong. We expect (il + ih) / 2 instead:")
(quotient (+ il ih) 2)
(code:comment "Expressed as a 32-bit integer, the correct answer is:")
(int32 (quotient (+ il ih) 2))
(code:comment "So, check-mid fails on (bvmid cl ch):")
(eval:error (check-mid bvmid cl ch))]
@(rosette-eval '(clear-vc!))
In our example, evaluating @racket[l] and @racket[h] with respect to @racket[cex] reveals that @racket[bvmid] fails to return the correct midpoint value, thus causing the first assertion in the @racket[check-mid] procedure to fail. The bug is due to overflow:
the expression @racket[(bvadd lo hi)] in @racket[bvmid] produces a negative value in
the 32-bit representation when the sum of
@racket[lo] and @racket[hi] exceeds 2@\superscript{31}-1.
@examples[#:eval rosette-eval #:label #f
(bvadd cl ch)
(bitvector->integer (bvadd cl ch))
(+ il ih)
(- (expt 2 31) 1)]
@(rosette-eval '(clear-vc!))
A common @hyperlink["https://en.wikipedia.org/wiki/Binary_search_algorithm#Implementation_issues"]{solution}
to this problem is to calculate the midpoint as @tt{lo + ((hi - lo) / 2)}. It is easy to see that all intermediate values in this calculation are at most @racket[hi] when @racket[lo] and @racket[hi] are both non-negative, so no overflow can happen. We can also verify this with Rosette:
@examples[#:eval rosette-eval #:label #f
(eval:no-prompt
(define (bvmid-no-overflow lo hi)
(bvadd lo (bvsdiv (bvsub hi lo) (int32 2)))))
(verify (check-mid bvmid-no-overflow l h))]
@subsection[#:tag "sec:synthesize"]{Synthesis}
The solution given in @racket[bvmid-no-overflow] avoids the overflow problem in @racket[bvmid] at the cost of performing an additional arithmetic operation. Both implementations also rely on signed division, which is slow and expensive compared to addition, subtraction, and bitwise operations. So our ideal implementation would be correct, small, and composed of only cheap arithmetic and bitwise operations. Does such an implementation exist? To find out, we turn to Rosette's @racket[synthesize] query.
The synthesis query uses the solver to search for a correct program in a space of candidate implementations defined by a syntactic @deftech{sketch}. A sketch is a program with @deftech[#:key "hole"]{holes}, which the solver fills with expressions drawn from a specified set of options. For example, @racket[(?? int32?)] stands for a hole that can be filled with any 32-bit integer constant, so the sketch @racket[(bvadd x (?? int32?))] represents all 2@superscript{32} programs that add a 32-bit constant to the variable @racket[x]. Rosette also lets you define richer holes that can be filled with expressions from a given grammar. For example, here is a grammar of all @racket[int32?] expressions that consist of cheap arithmetic and bitwise operations:
@examples[#:eval rosette-eval #:label #f #:no-prompt
(code:line
(require rosette/lib/synthax) (code:comment "Require the sketching library."))
(code:line
(define-grammar (fast-int32 x y) (code:comment "Grammar of int32 expressions over two inputs:")
[expr
(choose x y (?? int32?) (code:comment "<expr> := x | y | <32-bit integer constant> |")
((bop) (expr) (expr)) (code:comment " (<bop> <expr> <expr>) |")
((uop) (expr)))] (code:comment " (<uop> <expr>)")
[bop
(choose bvadd bvsub bvand (code:comment "<bop> := bvadd | bvsub | bvand |")
bvor bvxor bvshl (code:comment " bvor | bvxor | bvshl |")
bvlshr bvashr)] (code:comment " bvlshr | bvashr")
[uop
(choose bvneg bvnot)]) (code:comment "<uop> := bvneg | bvnot"))]
Using this grammar, we can sketch a fast implementation of the midpoint calculation as follows:
@examples[#:eval rosette-eval #:label #f #:no-prompt
(eval:alts
(define (bvmid-fast lo hi)
(fast-int32 lo hi #:depth 2))
(require (only-in rosette/guide/scribble/essentials/bvmid bvmid-fast)))]
The above sketch describes the space of all expressions from the @racket[fast-int32] grammar that have parse trees of depth at most 2. The depth argument is optional. If ommitted, Rosette will use the value of the @racket[(current-grammar-depth)] parameter to bound the depth of the expressions drawn from the grammar.
At this point, it is worth noting that holes and sketches are not fundamental concepts in Rosette. Instead, they are macros defined in terms of the core constructs we have already seen, symbolic constants and assertions. For example, @racket[(?? int32?)] is syntactic sugar for @racket[(let () (define-symbolic #, @var[id] int32?) #, @var[id])], where @var[id] is an internally generated name. Similarly, @racket[(choose bvneg bvnot)] expands to @racket[(if (?? boolean?) bvneg bvnot)]. Finally, a grammar hole such as @racket[(fast-int32 lo hi #:depth 2)] inlines its productions @racket[#:depth] times to create a nested expression of the form @racket[(choose lo hi (?? int32?) ((choose bvadd ...) (choose ...) (choose ...)) ((choose bvneg bvnot) (choose ...)))]. Assigning concrete values to the symbolic constants generated by this expression has the effect of selecting a parse tree (of depth 2 in our example) from the hole's grammar. So, completing a sketch is a matter of finding a suitable binding for the symbolic constants generated by the holes.
With this in mind, we can query the solver for a completion of the @racket[bvmid-fast] sketch (if any) that satisfies our correctness specification:
@(rosette-eval '(require (only-in rosette/guide/scribble/util/demo print-forms-alt)))
@examples[#:eval rosette-eval #:label #f
(code:comment "Save the above definitions to a file before calling print-forms.")
(define sol
(synthesize
#:forall (list l h)
#:guarantee (check-mid bvmid-fast l h)))
sol
(eval:alts
(print-forms sol)
(print-forms-alt sol))]
The synthesis query takes the form @racket[(synthesize #:forall #, @var[input] #:guarantee #, @var[expr])], where @var[input] lists the symbolic constants that represent inputs to a sketched program, and @var[expr] gives the correctness specification for the sketch. The solver searches for a binding from the hole (i.e., non-@var[input]) constants to values such that @var[expr] satisfies its assertions on all legal @var[input]s. Passing this binding to @racket[print-forms] converts it to a syntactic representation of the completed sketch.@footnote{@racket[print-forms] works only on sketches that have been saved to disk.} In our example, the synthesized program implements the midpoint calculation using the logical shift operation, i.e., the midpoint between @racket[lo] and @racket[hi] is calculated as @tt{(lo + hi) >>@subscript{u} 1}.
@(rosette-eval '(clear-vc!))
@subsection[#:tag "sec:solve"]{Angelic Execution}
Rosette supports one more solver-aided query, which we call angelic execution. This query is the dual of verification. Given a program with symbolic values, it instructs the solver to find a binding for them that will cause the program to execute normally---that is, without any assumption or assertion failures.
Angelic execution can be used to solve puzzles, to run incomplete code, or to ``invert'' a program, by searching for inputs that produce a desired output. For example, we can ask the solver to search for two distinct legal inputs, @racket[l] and @racket[h], whose midpoint is the bitwise-and of their bits:
@examples[#:eval rosette-eval #:label #f
(define (bvmid-fast lo hi)
(bvlshr (bvadd hi lo) (bv #x00000001 32)))
(define sol
(solve
(begin
(assume (not (equal? l h)))
(assume (bvsle (int32 0) l))
(assume (bvsle l h))
(assert (equal? (bvand l h) (bvmid-fast l h))))))
sol
(evaluate (bvand l h) sol)
(evaluate (bvmid-fast l h) sol)]
As a fun exercise that builds on this result, try using program synthesis to discover the condition, @racket[(bvmid-and? l h)], that is both necessary and sufficient to ensure that @racket[bvand] and @racket[bvmid-fast] produce the same value on all distinct legal inputs @racket[l] and @racket[r]. (Hint: you can reuse the @racket[fast-int32] grammar from the previous section.)
@examples[#:eval rosette-eval #:label #f
(eval:no-prompt
(define (bvmid-and? lo hi)
#f (code:comment "<--- replace with your sketch\n")
))
(eval:alts
(print-forms
(synthesize
#:forall (list l h)
#:guarantee
(begin
(assume (not (equal? l h)))
(assume (bvsle (int32 0) l))
(assume (bvsle l h))
(assert
(<=> (bvmid-and? l h)
(equal? (bvand l h) (bvmid-fast l h)))))))
(void))]
@(rosette-eval '(clear-vc!))
@section[#:tag "sec:notes"]{Symbolic Reasoning}
We conclude this chapter with a quick overview of common patterns and anti-patterns for programming in Rosette. For more details, see Chapters @seclink["ch:unsafe"]{8}--@seclink["ch:error-tracing"]{10}.
@subsection{Mixing Theories}
Rosette implements solver-aided queries by translating them to the input language of an SMT solver. By default, this translation respects types: a symbolic constant of type @racket[integer?] will be translated to an SMT constant of the same type, i.e., an infinite precision mathematical integer. These types determine which @emph{theories} the solver will need to use to solve a query. As a rule of thumb, the theory of bitvectors tends to elicit fastest solving times, and mixing theories can lead to severe performance degradation. For that reason, it is best to use the types from the same theory throughout your program (e.g., bitvectors).
To illustrate the impact of mixing theories, consider the following mixed-theory specification for our midpoint example:
@examples[#:eval rosette-eval #:label #f #:no-prompt
(code:line
(define (check-mid-slow impl lo hi) (code:comment "Assuming that")
(assume (bvsle (int32 0) lo)) (code:comment "0 ≤ lo and")
(assume (bvsle lo hi)) (code:comment "lo ≤ hi,")
(assert (code:comment "we require that")
(equal?
(bitvector->integer (impl lo hi)) (code:comment "⌈impl(lo, hi)⌉ = ")
(quotient (code:comment "(⌈lo⌉ + ⌈hi⌉) / 2, where")
(+ (bitvector->integer lo) (code:comment "⌈e⌉ stands for the mathematical")
(bitvector->integer hi)) (code:comment "integer corresponding to the")
2)))) (code:comment "32-bit integer e."))]
This new specification uses both bitvectors and integers. Compared to @racket[check-mid], which uses only bitvectors, @racket[check-mid-slow] causes one of our verification queries to become an order of magnitude slower and the other to time out:
@(rosette-eval '(require (only-in racket error)))
@examples[#:eval rosette-eval #:label #f
(time (verify (check-mid bvmid l h)))
(time (verify (check-mid-slow bvmid l h)))
(time (verify (check-mid bvmid-no-overflow l h)))
(eval:alts
(with-deep-time-limit 600 (code:comment "Timeout after 10 minutes ...")
(verify (check-mid-slow bvmid-no-overflow l h)))
(eval:error (error 'call-with-deep-time-limit "out of time")))]
@subsection{Reasoning Precision}
While slower than bitvectors, integers are more convenient to use for demos, prototyping, and interfacing with Racket. To bridge this gap, Rosette provides the option of approximating symbolic integers (and reals) as bitvectors of length @var{k}, by setting the @racket[current-bitwidth] parameter to @var{k}. With this setting, integers (and reals) are treated as infinite precision values during evaluation, but when solving queries, they are translated to bitvectors of length @var{k} for better performance.
For example, our slow midpoint queries become orders-of-magnitude faster when allowed to approximate integers with bitvectors:
@examples[#:eval rosette-eval #:label #f
(code:comment "By default, current-bitwidth is set to #f, so Rosette translates")
(code:comment "integer? values precisely, using the SMT theory of integers.")
(current-bitwidth)
(code:comment "After we set current-bitwidth to 64, integer? values in")
(code:comment "check-mid-slow are translated to SMT bitvectors of length 64.")
(current-bitwidth 64)
(time (verify (check-mid-slow bvmid l h)))
(time (verify (check-mid-slow bvmid-no-overflow l h)))]
In this example, we have chosen @racket[current-bitwidth] carefully to ensure that the resulting approximation is both performant and sound---i.e., the approximate query returns a counterexample exactly when one would be returned by the corresponding integer query. But choosing the right bitwidth is difficult to do in general. If we underapproximate the number of bits that are needed to represent every integer value in a query, we lose soundness, and if we overapproximate it, we lose performance.
For instance, when we re-run the slow midpoint queries with @racket[current-bitwidth] set to 32, the buggy query fails to produce a counterexample and the correct query returns a bogus counterexample. Both results are correct for 32-bit machine integers but incorrect for (infinite-precision) mathematical integers:
@examples[#:eval rosette-eval #:label #f
(code:comment "The bitwidth is too low, so we get ...")
(current-bitwidth 32)
(code:comment "no counterexample to a buggy query, and")
(time (verify (check-mid-slow bvmid l h)))
(code:comment "a bogus counterexample to a correct query.")
(time (verify (check-mid-slow bvmid-no-overflow l h)))]
We can restore soundness by sacrificing performance and setting @racket[current-bitwidth] conservatively to a large value (e.g., 512). In our case, the queries are small so an order-of-magnitude slowdown is acceptable. For large queries, this would lead to timeouts:
@examples[#:eval rosette-eval #:label #f
(code:comment "The bitwidth is too high, so we get a 3-10X slowdown.")
(current-bitwidth 512)
(time (verify (check-mid-slow bvmid l h)))
(time (verify (check-mid-slow bvmid-no-overflow l h)))]
In practice, it is usually best to leave @racket[current-bitwidth] at its default setting (@racket[#f]), and limit the use of integers to code that will be evaluated concretely. This approach works especially well when the solver is configured to accept only bitvectors, so if any integers have made it into a query, the solver fails fast:
@examples[#:eval rosette-eval #:label #f
(current-bitwidth #f)
(require rosette/solver/smt/z3)
(code:line (current-solver (z3 #:logic 'QF_BV)) (code:comment "Allow only bitvectors."))
(code:line (time (verify (check-mid bvmid l h))) (code:comment "Accepted."))
(eval:alts
(code:line (time (verify (check-mid-slow bvmid l h))) (code:comment "Rejected."))
(eval:error (time (verify (check-mid-slow bvmid l h)))))]
@(rosette-eval '(clear-vc!))
@(rosette-eval '(current-solver (z3)))
@subsection{Symbolic Evaluation}
The process by which Rosette turns a query into an SMT constraint is called @deftech{symbolic evaluation}. At a high level, Rosette's symbolic evaluation works by executing @emph{all} paths through a program, and collecting all the assumptions and assertions on these paths into the current verification condition @racket[(vc)]. The resulting @racket[(vc)] is then translated to the SMT language and passed to the solver. This evaluation model has two practical implications on writing performant and terminating Rosette code.
First, if a program is slow or runs forever under standard (concrete) evaluation, it will perform at least as poorly under all-path (symbolic) evaluation. Second, if a program terminates quickly on all concrete inputs, it can still perform poorly or fail to terminate on symbolic inputs. So, extra care must be taken to ensure good performance and termination in the presence of symbolic values.
To illustrate, consider the procedure @racket[bvsqrt] for computing the @hyperlink["https://en.wikipedia.org/wiki/Integer_square_root#Using_bitwise_operations"]{integer square root} of non-negative 32-bit integers. This procedure terminates on all concrete values of @racket[n] but runs forever when given a symbolic input:
@examples[#:eval rosette-eval #:label #f
(eval:no-prompt
(define (bvsqrt n)
(cond
[(bvult n (int32 2)) n]
[else
(define s0 (bvshl (bvsqrt (bvlshr n (int32 2))) (int32 1)))
(define s1 (bvadd s0 (int32 1)))
(if (bvugt (bvmul s1 s1) n) s0 s1)])))
(bvsqrt (int32 3))
(bvsqrt (int32 4))
(bvsqrt (int32 15))
(bvsqrt (int32 16))
(eval:alts
(with-deep-time-limit 10 (code:comment "Timeout after 10 seconds ...")
(bvsqrt l))
(eval:error (error 'call-with-deep-time-limit "out of time")))]
The reason is simple: a call to @racket[bvsqrt] terminates when @racket[n] becomes less than 2. But if we start with a symbolic @racket[n], this never happens because Rosette right-shifts @racket[n] by 2 in each recursive call to generate a new symbolic value:
@examples[#:eval rosette-eval #:label #f
(define n0 l)
n0
(define n1 (bvlshr n0 (int32 2)))
n1
(define n2 (bvlshr n1 (int32 2)))
n2
(define n3 (bvlshr n2 (int32 2)))
n3]
In general, recursion terminates under symbolic evaluation only when the stopping condition is reached with concrete values.
We can force termination by placing a concrete bound @var{k} on the number of times @racket[bvsqrt] can call itself recursively. This approach is called @deftech{finitization}, and it is the standard way to handle unbounded loops and recursion under symbolic evaluation. The following code shows how to implement a @emph{sound} finitization policy. If a @racket[verify] query returns @racket[(unsat)] under a sound policy, we know that (1) the unrolling bound @var{k} is sufficient to execute all possible inputs to @racket[bvsqrt], and (2) all of these executions satisfy the query. If we pick a bound that is too small, the query will generate a counterexample input that needs a larger bound to compute the result. In our example, the bound of 16 is sufficient to verify the correctness of @racket[bvsqrt] on all inputs:
@(rosette-eval '(clear-vc!))
@(rosette-eval '(require (only-in racket make-parameter parameterize)))
@examples[#:eval rosette-eval #:label #f #:no-prompt
(code:comment "Parameter that controls the number of unrollings (5 by default).")
(define fuel (make-parameter 5))
(eval:no-prompt)
(code:comment "A simple macro for defining bounded procedures")
(code:comment "that use (fuel) to limit recursion.")
(define-syntax-rule
(define-bounded (id param ...) body ...)
(define (id param ...)
(assert (> (fuel) 0) "Out of fuel.")
(parameterize ([fuel (sub1 (fuel))])
body ...)))
(eval:no-prompt)
(code:comment "Computes bvsqrt taking at most (fuel) steps.")
(define-bounded (bvsqrt n)
(cond
[(bvult n (int32 2)) n]
[else
(define s0 (bvshl (bvsqrt (bvlshr n (int32 2))) (int32 1)))
(define s1 (bvadd s0 (int32 1)))
(if (bvugt (bvmul s1 s1) n) s0 s1)]))
(eval:no-prompt)
(code:comment "Correctness specification for bvsqrt:")
(code:line
(define (check-sqrt impl n)
(assume (bvsle (int32 0) n)) (code:comment "Assuming n ≥ 0,")
(define √n (impl l))
(define √n+1 (bvadd √n (int32 1))) (code:comment "we require that")
(assert (bvule (bvmul √n √n) n)) (code:comment "(√n)^2 ≤ n and")
(assert (bvult n (bvmul √n+1 √n+1)))) (code:comment "n < (√n + 1)^2."))]
@examples[#:eval rosette-eval #:label #f
(code:comment "Verification fails due to insufficient fuel.")
(define cex (time (verify (check-sqrt bvsqrt l))))
(eval:error (bvsqrt (evaluate l cex)))
(clear-vc!)
(code:comment "Verification succeeds with enough fuel.")
(fuel 16)
(time (verify (check-sqrt bvsqrt l)))]
Many other finitization policies can be defined in a similar way. For example, if we change @racket[define-bounded] to use @racket[assume] instead of @racket[assert], we obtain a finitization policy that ensures @emph{completeness}. If a @racket[verify] query returns a counterexample under a complete policy, we know that the program is buggy, and it violates a query assertion within @var{k} recursive calls. But if the query returns @racket[(unsat)], we know only that there are no bugs within @var[k] or fewer unrollings---we cannot conclude anything about longer executions. So a complete policy prevents false positives, while a sound one prevents false negatives. What kind of policy to use depends on the application, and Rosette leaves that choice to the programmer.
@(kill-evaluator rosette-eval)
@(footnote-part)

13
rosette/guide/scribble/forms/forms.scrbl
View File

@ -1,13 +0,0 @@
#lang scribble/manual
@(require (for-label racket))
@title[#:tag "ch:syntactic-forms" #:style 'toc]{Syntactic Forms}
The core of the Rosette language (@racketmodname[rosette/safe]) consists of two kinds of syntax forms: a set of basic forms @deftech[#:key "lifted constructs"]{lifted} from Racket, and a set of forms for @seclink["ch:essentials"]{solver-aided programming}. We use the term ``lifted'' to refer to parts of the Racket language that can be used with symbolic values and other solver-aided constructs.
@[table-of-contents]
@include-section["racket-forms.scrbl"]
@include-section["rosette-forms.scrbl"]

72
rosette/guide/scribble/forms/racket-forms.scrbl
View File

@ -1,72 +0,0 @@
#lang scribble/manual
@(require (for-label rosette/base/form/define)
(for-label racket)
scribble/core scribble/html-properties scribble/examples racket/sandbox
"../util/lifted.rkt")
@(define modules
(select '(module module* module+ #%module-begin #%printing-module-begin
#%plain-module-begin #%declare)))
@(define import/export
(select '(require only-in except-in prefix-in rename-in combine-in
relative-in only-meta-in lib file planet submod local-require provide
all-defined-out all-from-out rename-out except-out prefix-out struct-out
combine-out protect-out for-meta for-syntax for-template for-label
#%require #%provide )))
@(define literals (select '(quote #%datum)))
@(define wrappers (select '(#%expression #%top #%top-interaction)))
@(define apps (select '(#%app #%plain-app)))
@(define procs (select '(lambda λ case-lambda #%plain-lambda)))
@(define local-binding
(select '(let let* letrec let-values let*-values letrec-values let-syntax
letrec-syntax let-syntaxes letrec-syntaxes letrec-syntaxes+values)))
@(define local-defs (select '(local)))
@(define conditionals (select '(if and or)))
@(define dispatch (select '(case)))
@(define definitions
(select '(define define-values define-syntax define-syntaxes
define-for-syntax define-values-for-syntax)))
@(define sequencing (select '(begin begin0 begin-for-syntax)))
@(define guarded-eval (select '(when unless)))
@(define assignment (select '(set! set!-values)))
@(define quasiquoting (select '(quasiquote unquote)))
@(define syntax-quoting (select '(quote-syntax)))
@(define rosette-eval (rosette-evaluator))
@title[#:tag "ch:syntactic-forms:racket"]{Lifted Racket Forms}
Rosette lifts the following @seclink["syntax" #:doc '(lib "scribblings/reference/reference.scrbl")]{Racket forms}:
@tabular[#:style (style #f (list (attributes '((id . "lifted")(class . "boxed")))))
(list (list @elem{Modules} @modules)
(list @elem{Import and Export} @import/export)
(list @elem{Literals} @literals)
(list @elem{Wrappers} @wrappers)
(list @elem{Procedure Applications} @apps)
(list @elem{Procedure Expressions} @procs)
(list @elem{Local Binding} @local-binding)
(list @elem{Local Definitions} @local-defs)
(list @elem{Conditionals} (list @conditionals ", " @racket[cond] " with " @racket[[#, @var[test] #, @var[body] ...+]] " and " @racket[[else #, @var[body] ...+]] " clauses"))
(list @elem{Dispatch} @dispatch)
(list @elem{Definitions} @definitions)
(list @elem{Sequencing} @sequencing)
(list @elem{Guarded Evaluation} @guarded-eval)
(list @elem{Assignment} @assignment)
(list @elem{Quasiquoting} @quasiquoting)
(list @elem{Syntax Quoting} @syntax-quoting))]
Lifted forms have the same meaning in Rosette programs as they do in Racket programs. For example, the Racket expression @racket[(if #, @var[test-expr] #, @var[then-expr] #, @var[else-expr])] evaluates @var[test-expr] first and then, depending on the outcome, it returns the result of evaluating either @var[then-expr] or @var[else-expr]. Rosette preserves this interpretation of @racket[if] for concrete values, and also extends it to work with symbolic values:
@examples[#:eval rosette-eval #:label #f
(let ([y 0])
(if #t (void) (set! y 3))
(printf "y unchanged: ~a\n" y)
(if #f (set! y 3) (void))
(printf "y unchanged: ~a\n" y)
(define-symbolic x boolean?)
(if x (void) (set! y 3))
(printf "y symbolic: ~a\n" y))]
@(kill-evaluator rosette-eval)

838
rosette/guide/scribble/forms/rosette-forms-log.txt
View File

@ -1,838 +0,0 @@
;; This file was created by make-log-based-eval
((define (always-same) (define-symbolic x integer?) x)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((always-same)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "x\n"))))
#""
#"")
((always-same)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "x\n"))))
#""
#"")
((equal? (always-same) (always-same)) ((3) 0 () 0 () () (q values #t)) #"" #"")
((define (always-same-3) (define-symbolic y integer? #:length (+ 1 2)) y)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((always-same-3)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(list y$0 y$1 y$2)\n"))))
#""
#"")
((always-same-3)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(list y$0 y$1 y$2)\n"))))
#""
#"")
((equal? (always-same-3) (always-same-3))
((3) 0 () 0 () () (q values #t))
#""
#"")
((lambda (n) (define-symbolic y integer? #:length n) y)
((3)
0
()
0
()
()
(q
exn
"eval:9.0: define-symbolic: expected a natural? for #:length\n at: (define-symbolic y integer? #:length n)\n in: (define-symbolic y integer? #:length n)"))
#""
#"")
((define (always-different) (define-symbolic* x integer?) x)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((always-different)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "x$0\n"))))
#""
#"")
((always-different)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "x$1\n"))))
#""
#"")
((eq? (always-different) (always-different))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(= x$2 x$3)\n"))))
#""
#"")
((define (always-different-n n) (define-symbolic* y integer? #:length n) y)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((always-different-n 2)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(list y$4 y$5)\n"))))
#""
#"")
((always-different-n 3)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(list y$6 y$7 y$8)\n"))))
#""
#"")
((equal? (always-different-n 4) (always-different-n 4))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c
values
c
(0 (u . "(&& (= y$9 y$13) (= y$10 y$14) (= y$11 y$15) (= y$12 y$16))\n"))))
#""
#"")
((assert #t) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assert 1) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((define-symbolic x boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assert x) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t x)\n"))))
#""
#"")
((assert #f "bad value")
((3) 0 () 0 () () (q exn "[assert] bad value"))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #f)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((assume #t) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assume 1) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((define-symbolic x boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assume x) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc x #t)\n"))))
#""
#"")
((assume #f "bad value")
((3) 0 () 0 () () (q exn "[assume] bad value"))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #f #t)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((define-symbolic a b c d boolean?)
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((verify (assert a))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [a #f])\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((assume a) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assert b) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc a (|| b (! a)))\n"))))
#""
#"")
((verify (begin (assume c) (assert d)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [a #t]\n [b #t]\n [c #t]\n [d #f])\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc a (|| b (! a)))\n"))))
#""
#"")
((verify (assert a))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((verify (assert a))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [a #f])\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x c integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((synthesize
#:forall
(list x)
#:guarantee
(begin (assume (even? x)) (assert (odd? (+ x c)))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [c 1])\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((assume (odd? x)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc (! (= 0 (remainder x 2))) #t)\n"))))
#""
#"")
((synthesize #:forall (list x) #:guarantee (assert (odd? (+ x c))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [c 0])\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc (! (= 0 (remainder x 2))) #t)\n"))))
#""
#"")
((synthesize
#:forall
(list x)
#:guarantee
(begin (assume (even? x)) (assert (odd? (+ x c)))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((synthesize
#:forall
(list x)
#:guarantee
(begin (assume (even? x)) (assert (odd? (+ x c)))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [c 1])\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x y boolean?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((assume x) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc x #t)\n"))))
#""
#"")
((solve (assert y))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x #t]\n [y #t])\n"))))
#""
#"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc x #t)\n"))))
#""
#"")
((solve (assert (not x)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((vc)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(vc #t #t)\n"))))
#""
#"")
((solve (assert (not x)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x #f])\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x y integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define inc (solve+)) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((inc (< x y))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 0]\n [y 1])\n"))))
#""
#"")
((inc (> x 5))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 6]\n [y 7])\n"))))
#""
#"")
((inc (< y 4))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((inc 1)
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 6]\n [y 7])\n"))))
#""
#"")
((inc (< y 9))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 6]\n [y 7])\n"))))
#""
#"")
((inc 'shutdown) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((inc (> y 4))
((3)
0
()
0
()
()
(q
exn
"solver-push: contract violation:\n expected: solver?\n given: #f\n argument position: 1st"))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x y integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((optimize
#:maximize
(list (+ x y))
#:guarantee
(begin (assume (< x 2)) (assert (< (- y x) 1))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 1]\n [y 1])\n"))))
#""
#"")
((clear-vc!) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((current-bitwidth 5) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic x y real?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((define-symbolic f (~> real? real?))
((3) 0 () 0 () () (c values c (void)))
#""
#"")
((current-bitwidth 5) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((solve (assert (= x 3.5)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 3])\n"))))
#""
#"")
((solve (assert (= x 64)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 0])\n"))))
#""
#"")
((solve (assert (and (= x 64) (= x 0))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 0])\n"))))
#""
#"")
((solve (assert (forall (list x) (= x (+ x y)))))
((3)
0
()
0
()
()
(q
exn
"finitize: cannot use (current-bitwidth 5) with a quantified formula (forall (x) (= x (+ x y))); use (current-bitwidth #f) instead"))
#""
#"")
((solve (assert (= x (f x))))
((3)
0
()
0
()
()
(q
exn
"finitize: cannot use (current-bitwidth 5) with an uninterpreted function f; use (current-bitwidth #f) instead"))
#""
#"")
((current-bitwidth #f) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((solve (assert (= x 3.5)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 7/2])\n"))))
#""
#"")
((solve (assert (= x 64)))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 64])\n"))))
#""
#"")
((solve (assert (and (= x 64) (= x 0))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unsat)\n"))))
#""
#"")
((solve (assert (forall (list x) (= x (+ x y)))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [y 0])\n"))))
#""
#"")
((solve (assert (= x (f x))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(model\n [x 0]\n [f (fv real?~>real?)])\n"))))
#""
#"")
((define-symbolic i j integer?) ((3) 0 () 0 () () (c values c (void))) #"" #"")
((solve
(begin
(assert (> i 0))
(assert (> j 0))
(assert (or (= (/ i j) 2) (= (/ j i) 2)))))
((3)
1
(((lib "rosette/guide/scribble/util/lifted.rkt")
.
deserialize-info:opaque-v0))
0
()
()
(c values c (0 (u . "(unknown)\n"))))
#""
#"")

512
rosette/guide/scribble/forms/rosette-forms.scrbl
View File

@ -1,512 +0,0 @@
#lang scribble/manual
@(require (for-label
rosette/base/form/define rosette/query/query rosette/solver/solution
(only-in rosette/solver/solver solver?)
rosette/base/core/term
(only-in rosette/query/finitize current-bitwidth)
(only-in rosette/base/base
assert assume vc vc-asserts vc-assumes clear-vc!
bv? forall)
(only-in rosette/base/core/function function? ~>)
(only-in rosette/base/core/reflect symbolics))
(for-label racket)
scribble/core scribble/html-properties scribble/examples racket/sandbox racket/runtime-path
"../util/lifted.rkt")
@(define-runtime-path root ".")
@(define rosette-eval (rosette-log-evaluator (logfile root "rosette-forms-log")))
@title[#:tag "ch:syntactic-forms:rosette"]{Solver-Aided Forms}
The @seclink["ch:essentials"]{Essentials} chapter introduced
the key concepts of solver-aided programming. This section
describes the corresponding syntactic constructs in detail.
@declare-exporting[rosette/base/form/define
rosette/query/form
rosette/base/base
rosette/base/core/bool
rosette/query/finitize
#:use-sources
(rosette/base/form/define
rosette/query/form
rosette/base/base
rosette/base/core/bool
rosette/query/finitize)]
@section[#:tag "sec:symbolic-constants"]{Symbolic Constants}
@defform*[((define-symbolic id ...+ type)
(define-symbolic id type #:length k))
#:contracts
[(type (and/c solvable? type?))
(k natural?)]]{
The first form binds each provided identifier to a distinct
@tech["symbolic constant"] of the given
@tech["solvable type"]. The identifiers are bound to the
same constants every time the form is evaluated.
@examples[#:eval rosette-eval
(define (always-same)
(define-symbolic x integer?)
x)
(always-same)
(always-same)
(equal? (always-same) (always-same)) ]
The second form creates a list of @racket[k] distinct
constants and binds it to @racket[id]. The same constants
are bound to @racket[id] every time the form is evaluated.
The form requires @racket[k] to evaluate to a natural number
statically---i.e., at macro expansion time.
@examples[#:eval rosette-eval
(define (always-same-3)
(define-symbolic y integer? #:length (+ 1 2))
y)
(always-same-3)
(always-same-3)
(equal? (always-same-3) (always-same-3))
(eval:alts
(define (always-same-n n)
(define-symbolic y integer? #:length n)
y)
(eval:error (lambda (n) (define-symbolic y integer? #:length n) y)))]
}
@defform*[((define-symbolic* id ...+ type)
(define-symbolic* id type #:length k))
#:contracts
[(type (and/c solvable? type?))
(k natural?)]]{
The first form creates a stream of distinct
@tech["symbolic constant"]s of the given
@tech["solvable type"] for each identifier, binding the
identifier to the next element from its stream every time
the form is evaluated.
@examples[#:eval rosette-eval
(define (always-different)
(define-symbolic* x integer?)
x)
(always-different)
(always-different)
(eq? (always-different) (always-different))]
The second form binds @racket[id] to a list of the next
@racket[k] elements from its stream every time the form is
evaluated. The expression @racket[k] may produce different
natural numbers depending on the calling context.
@examples[#:eval rosette-eval
(define (always-different-n n)
(define-symbolic* y integer? #:length n)
y)
(always-different-n 2)
(always-different-n 3)
(equal? (always-different-n 4) (always-different-n 4))]}
@section[#:tag "sec:assertions"]{Assertions and Assumptions}
@defform*[((assert expr)
(assert expr msg))
#:contracts
[(msg string?)]]{
Checks that @racket[expr] produces a true value. Rosette
keeps track of all assertions and assumptions encountered
during symbolic evaluation in the current @tech{verification condition} (VC).
If @racket[expr] evaluates to @racket[#f],
the assertion adds @racket[#f] to the VC and throws an error
with the optional failure message @racket[msg]. If
@racket[expr] evaluates to a symbolic boolean value, this
value is added to the VC and execution continues. If
@racket[expr] evaluates to any other value, @racket[assert]
has no effect. The contents of the VC can be examined using
the @racket[(vc)] procedure, and they can be cleared using
the @racket[clear-vc!] procedure.
@examples[#:eval rosette-eval
(code:line (assert #t) (code:comment "No effect."))
(code:line (assert 1) (code:comment "No effect."))
(code:line (vc) (code:comment "The VC tracks assumptions and assertions."))
(define-symbolic x boolean?)
(assert x)
(code:line (vc) (code:comment "x is added to the VC's asserts."))
(eval:error (assert #f "bad value"))
(vc)
(code:line (clear-vc!) (code:comment "Clear the VC."))
(vc)]
}
@defform*[((assume expr)
(assume expr msg))
#:contracts
[(msg string?)]]{
Behaves like @racket[assert] except that it updates the
assumption component of the current verification condition
when @racket[expr] evaluates to @racket[#f] or to a
symbolic boolean.
@examples[#:eval rosette-eval
(vc)
(code:line (assume #t) (code:comment "No effect."))
(code:line (assume 1) (code:comment "No effect."))
(code:line (vc) (code:comment "The VC tracks assumptions and assertions."))
(define-symbolic x boolean?)
(assume x)
(code:line (vc) (code:comment "x is added to the VC's assumes."))
(eval:error (assume #f "bad value"))
(vc)
(code:line (clear-vc!) (code:comment "Clear the VC."))
(vc)]
}
@section{Verification}
@defform[(verify expr)]{
Searches for a binding of symbolic constants to concrete
values that satisfies all the assumptions and violates at
least one of the assertions encountered during the
evaluation of @racket[expr]. The binding must also satisfy
all the assumptions and assertions accumulated in the
verification condition @racket[(vc)] before the call to
@racket[verify]. If such a binding exists, the query returns
one as part of a satisfiable @racket[solution?]; otherwise,
the query returns @racket[(unsat)].
Formally,
@racket[(verify expr)] searches for a model of the formula
@racket[(vc-assumes #, @var{P})] ∧ @racket[(vc-asserts #, @var{P})] ∧
@racket[(vc-assumes #, @var{Q})] ∧ ¬ @racket[(vc-asserts #, @var{Q})],
where @var{P} is the verification condition before the
call to @racket[verify] and @var{Q} is the verification condition
generated by evaluating @racket[expr].
The @racket[verify]
query does not retain the assumptions and assertions generated
by @racket[expr], leaving the current verification condition
@racket[(vc)] unchanged after the query returns.
@examples[#:eval rosette-eval
(define-symbolic a b c d boolean?)
(vc)
(code:comment "This query forces a to be false:")
(verify (assert a))
(code:line (vc) (code:comment "VC is unchanged."))
(assume a)
(assert b)
(vc)
(code:comment "This query forces a, b, c to be true, and d to be false:")
(verify
(begin
(assume c)
(assert d)))
(vc)
(code:comment "This query has no solution because we assumed a above:")
(verify (assert a))
(code:comment "Clearing the VC gives the expected solution:")
(clear-vc!)
(vc)
(verify (assert a))]
}
@(rosette-eval '(clear-vc!))
@section{Synthesis}
@defform*[((synthesize input expr)
(synthesize #:forall input #:guarantee expr))]{
Taking @var{I} to be the set of symbolic constants @racket[(symbolics input)]
and @var{H} to be the complement of @var{I},
searches for a binding @var{B}@subscript{@var{H}}
from @var{H} to concrete values that
satisfies @racket[expr] as follows.
If @var{B}@subscript{@var{H}} is extended with any binding
@var{B}@subscript{@var{I}} from @var{I}
to concrete values, then the extended binding
@var{B}@subscript{@var{H}} ∪ @var{B}@subscript{@var{I}}
satisfies all the assertions generated by evaluating @racket[expr] whenever
it satisfies the assumptions generated by @racket[expr], as
well as the assumptions and assertions accumulated in the verification condition
@racket[(vc)] before @racket[expr] is evaluated. If such a binding
@var{B}@subscript{@var{H}} exists, the query returns one as part of a
satisfiable @racket[solution?]; otherwise, the query returns
@racket[(unsat)].
Formally, @racket[(synthesize input expr)] searches for a model of
the formula
∃ @var{H}. (∃ @var{I}. @var{pre}(@var{H}, @var{I})) ∧
(∀ @var{I}. @var{pre}(@var{H}, @var{I}) ⇒ @var{post}(@var{H}, @var{I})),
where @var{pre}(@var{H}, @var{I}) is @racket[(vc-assumes #, @var{P})] ∧
@racket[(vc-asserts #, @var{P})] ∧ @racket[(vc-assumes #, @var{Q})],
@var{post}(@var{H}, @var{I}) is @racket[(vc-asserts #, @var{Q})],
@var{P} is the verification condition accumulated before the evaluation of
@racket[expr], and @var{Q} is the verification condition
generated by evaluating @racket[expr]. This formula is stronger than the
classic synthesis formula
∃ @var{H}. ∀ @var{I}. @var{pre}(@var{H}, @var{I}) ⇒ @var{post}(@var{H}, @var{I}).
The additional constraint, ∃ @var{I}. @var{pre}(@var{H}, @var{I}), rules out
trivial solutions that allow @var{pre}(@var{H}, @var{I}) to
be false on all inputs @var{I}.
The formulas @var{pre}(@var{H}, @var{I}) and
@var{post}(@var{H}, @var{I}) are required to be free of quantifiers, so
no @tech[#:key "quantified formula"]{quantified formulas} can be part of
the assumptions or assertions that make up a synthesis query.
The @racket[synthesize] query does not retain the
assumptions and assertions generated by @racket[expr],
but it does retain the updates to @racket[(vc)], if any,
produced by evaluating @racket[input]. In other words,
@racket[(synthesize input expr)] is equivalent to
@racket[(let ([v input]) (synthesize v expr))], where @racket[v]
is a fresh variable.
@examples[#:eval rosette-eval
(define-symbolic x c integer?)
(vc)
(code:comment "This query finds a binding for c that works for all even x:")
(synthesize
#:forall (list x)
#:guarantee
(begin
(assume (even? x))
(assert (odd? (+ x c)))))
(code:line (vc) (code:comment "VC is unchanged."))
(assume (odd? x))
(vc)
(code:comment "This query finds a binding for c that works for all odd x:")
(synthesize
#:forall (list x)
#:guarantee (assert (odd? (+ x c))))
(vc)
(code:comment "This query has no solution because we assumed (odd? x) above:")
(synthesize
#:forall (list x)
#:guarantee
(begin
(assume (even? x))
(assert (odd? (+ x c)))))
(code:comment "Clearing the VC gives the expected solution:")
(clear-vc!)
(vc)
(synthesize
#:forall (list x)
#:guarantee
(begin
(assume (even? x))
(assert (odd? (+ x c)))))]
}
@(rosette-eval '(clear-vc!))
@section{Angelic Execution}
@defform[(solve expr)]{
Searches for a binding of symbolic constants to concrete
values that satisfies all the assumptions and assertions
encountered during the evaluation of @racket[expr], as well
as all the assumptions and assertions accumulated in the
verification condition @racket[(vc)] before the call to
@racket[solve]. If such a binding exists, the query returns
one as part of a satisfiable @racket[solution?]; otherwise,
the result is an unsatisfiable solution.
Formally,
@racket[(solve expr)] searches for a model of the formula
@racket[(vc-assumes #, @var{P})] ∧ @racket[(vc-asserts #, @var{P})] ∧
@racket[(vc-assumes #, @var{Q})] ∧ @racket[(vc-asserts #, @var{Q})],
where @var{P} is the verification condition before the
call to @racket[solve] and @var{Q} is the verification condition
generated by evaluating @racket[expr].
The @racket[solve]
query does not retain the assumptions and assertions generated
by @racket[expr], leaving the current verification condition
@racket[(vc)] unchanged after the query returns.
@examples[#:eval rosette-eval
(define-symbolic x y boolean?)
(assume x)
(code:line (vc) (code:comment "x is added to the VC's assumes."))
(code:comment "This query forces both x and y to be true.")
(solve (assert y))
(code:line (vc) (code:comment "VC is unchanged."))
(code:comment "This query has solution because we assumed (not x) above:")
(solve (assert (not x)))
(code:comment "Clearing the VC gives the expected solution:")
(clear-vc!)
(vc)
(solve (assert (not x)))]
}
@(rosette-eval '(clear-vc!))
@defproc[(solve+) procedure?]{
Returns a stateful procedure that uses a fresh @racket[solver?] instance
to incrementally solve a sequence of constraints.
The returned procedure consumes a constraint (i.e., a boolean value or @tech["symbolic term"]),
a positive integer, or the symbol @racket['shutdown].
If the argument is a constraint, it is pushed onto the solver's constraint stack and
a solution for all constraints on the stack is returned.
If the argument is a positive integer @var[k], then the top @var[k] constraints are popped
from the solver's constraint stack and the result is the solution to the remaining constraints.
If the argument is @racket['shutdown], all resources used by the procedure are released, and any
subsequent calls to the procedure throw an exception.
@examples[#:eval rosette-eval
(define-symbolic x y integer?)
(define inc (solve+))
(code:line (inc (< x y)) (code:comment "Push (< x y) and solve."))
(code:line (inc (> x 5)) (code:comment "Push (> x 5) and solve."))
(code:line (inc (< y 4)) (code:comment "Push (< y 4) and solve."))
(code:line (inc 1) (code:comment "Pop (< y 4) and solve."))
(code:line (inc (< y 9)) (code:comment "Push (< y 9) and solve."))
(code:line (inc 'shutdown) (code:comment "Release resources."))
(eval:alts
(code:line (inc (> y 4)) (code:comment "Unusable after shutdown."))
(eval:error (inc (> y 4))))]
}
@(rosette-eval '(clear-vc!))
@section{Optimization}
@defform[(optimize
maybe-minimize
maybe-maximize
#:guarantee expr)
#:grammar ([maybe-minimize (code:line) (code:line #:minimize min-expr)]
[maybe-maximize (code:line) (code:line #:maximize max-expr)])
#:contracts [(min-expr (listof (or/c integer? real? bv?)))
(max-expr (listof (or/c integer? real? bv?)))]]{
Searches for an optimal binding of symbolic constants to
concrete values that satisfies all the assumptions and
assertions encountered during the evaluation of
@racket[expr], as well as all the assumptions and assertions
accumulated in the verification condition @racket[(vc)]
before the evaluation of @racket[expr]. The binding is
optimal in that it minimizes the cost terms in
the @racket[min-expr] list and maximizes those in the
@racket[max-expr] list. If such a binding exists, the query
returns one as part of a satisfiable @racket[solution?]; otherwise,
the query returns @racket[(unsat)]. For more details on
solving optimization problems, see the
@hyperlink["https://rise4fun.com/Z3/tutorial/optimization"]{Z3 optimization tutorial}.
Formally,
@racket[(solve expr)] searches for an optimal model of the formula
@racket[(vc-assumes #, @var{P})] ∧ @racket[(vc-asserts #, @var{P})] ∧
@racket[(vc-assumes #, @var{Q})] ∧ @racket[(vc-asserts #, @var{Q})],
where @var{P} is the verification condition before the
evaluation of @racket[expr], @var{Q} is the verification condition
generated by evaluating @racket[expr], the cost terms @racket[min-expr] are
minimized, and the cost terms @racket[max-expr] are maximized.
The @racket[optimize] query does not retain the
assumptions and assertions generated by @racket[expr],
but it does retain the updates to @racket[(vc)], if any,
produced by evaluating @racket[min-expr] and @racket[max-expr]. In other words,
@racket[(optimize #:minimize min-expr #:maximize max-expr #:guarantee expr)] is
equivalent to
@racket[(let ([v min-expr] [w max-expr]) (optimize #:minimize v #:maximize w #:guarantee expr))],
where @racket[v] and @racket[w] are fresh variables.
@examples[#:eval rosette-eval
(define-symbolic x y integer?)
(code:comment "This query maximizes x + y while ensuring that y - x < 1 whenever x < 2:")
(optimize
#:maximize (list (+ x y))
#:guarantee
(begin
(assume (< x 2))
(assert (< (- y x) 1))))]
}
@(rosette-eval '(clear-vc!))
@(rosette-eval '(current-bitwidth 5))
@section[#:tag "sec:reasoning-precision"]{Reasoning Precision}
@defparam[current-bitwidth k (or/c #f positive-integer?)
#:value #f]{
A parameter that defines the current @deftech[#:key "reasoning precision"]{reasoning precision}
for solver-aided queries over @racket[integer?] and @racket[real?] constants.
Setting @racket[current-bitwidth] to a positive integer @racket[k] instructs Rosette to approximate
both reals and integers with signed @racket[k]-bit words. Setting it to @racket[#f] instructs Rosette to use
infinite precision for real and integer operations. As a general rule, @racket[current-bitwidth] should
be set once, before any solver-aided queries are issued.
When @racket[current-bitwidth] is @racket[#f], Rosette translates queries over
reals and integers into constraints in the
@hyperlink["http://rise4fun.com/z3/tutorial"]{theories of reals and integers}.
These theories are effectively decidable only for linear constraints,
so setting @racket[current-bitwidth] to a positive integer will lead to better
performance for programs that perform nonlinear arithmetic.
When @racket[current-bitwidth] is set to a positive integer @racket[k],
Rosette translates queries over reals and integers into constraints in the
@hyperlink["http://rise4fun.com/z3/tutorial"]{theory of bitvectors}
(of size @racket[k]), which can be decided efficiently in practice.
When this form of translation is used, however, solver-aided queries can produce
counterintuitive results due to arithmetic over- and under-flow, as demonstrated below.
Rosette sets @racket[current-bitwidth] to @racket[#f] by default for two reasons.
First, this setting is consistent with Racket's infinite-precision semantics for integers and reals,
avoiding counterintuitive query behavior.
Second, the @racket[current-bitwidth] parameter must be set to @racket[#f] when
executing queries over assertions that contain @tech[#:key "quantified formula"]{quantified formulas}
or @seclink["sec:UF"]{uninterpreted functions}.
Otherwise, such a query will throw an exception.
@examples[
#:eval rosette-eval
(define-symbolic x y real?)
(define-symbolic f (~> real? real?))
(code:line (current-bitwidth 5) (code:comment "Use 5 bits for integers and reals."))
(code:line (solve (assert (= x 3.5))) (code:comment "3.5 = 3 under 5-bit semantics."))
(code:line (solve (assert (= x 64))) (code:comment "0 = 64 under 5-bit semantics,"))
(code:line (solve (assert (and (= x 64) (= x 0)))) (code:comment "leading to counterintuitive results."))
(eval:alts
(solve (code:comment "Quantifiers are not supported,")
(assert (forall (list x) (= x (+ x y)))))
(eval:error (solve (assert (forall (list x) (= x (+ x y)))))))
(eval:alts
(solve (code:comment "and neither are uninterpreted functions.")
(assert (= x (f x))))
(eval:error (solve (assert (= x (f x))))))
(code:line (current-bitwidth #f) (code:comment "Use infinite-precision semantics ..."))
(code:line (solve (assert (= x 3.5))) (code:comment "to obtain the expected results."))
(solve (assert (= x 64)))
(solve (assert (and (= x 64) (= x 0))))
(solve (code:comment "Quantifiers work, and")
(assert (forall (list x) (= x (+ x y)))))
(code:line (solve (assert (= x (f x)))) (code:comment "so do uninterpreted functions."))
(define-symbolic i j integer?)
(solve (code:comment "But nonlinear integer arithmetic")
(begin (code:comment "is undecidable.")
(assert (> i 0))
(assert (> j 0))
(assert (or (= (/ i j) 2) (= (/ j i) 2)))))]
}
@(kill-evaluator rosette-eval)

BIN
rosette/guide/scribble/libs/browser-atomic.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 149 KiB

BIN
rosette/guide/scribble/libs/browser-compound.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 180 KiB

BIN
rosette/guide/scribble/libs/browser-expr.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 140 KiB

Some files were not shown because too many files have changed in this diff Show More