├── .gitignore ├── LICENSE ├── README.md ├── cl-smt-lib.asd ├── cl-smt-lib.lisp ├── fundamental-two-way-stream.lisp └── process-two-way-stream.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.lx64fsl 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019, GrammaTech Inc. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | * Redistributions of source code must retain the above copyright 7 | notice, this list of conditions and the following disclaimer. 8 | * Redistributions in binary form must reproduce the above copyright 9 | notice, this list of conditions and the following disclaimer in the 10 | documentation and/or other materials provided with the distribution. 11 | * Neither the name of the nor the 12 | names of its contributors may be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 16 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 17 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 18 | DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY 19 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 20 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 21 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 22 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 24 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CL-SMT-LIB -- Common Lisp SMT-Lib Integration 2 | 3 | CL-SMT-LIB is a minimal package providing an SMT object encapsulating 4 | any SMT solver process supporting 5 | [SMT-LIB](http://smtlib.cs.uiowa.edu/about.shtml) with input and 6 | output streams. CL-SMT-LIB provides a reader macro to support reading 7 | case sensitive SMT-LIB forms into lisp and writing these forms to an 8 | SMT solver process. 9 | 10 | The `make-smt` function takes a program name and command line 11 | arguments and returns an smt object holding the process and the input 12 | and output streams. This process may be read from and written to like 13 | any other stream. 14 | 15 | The `#!` reader macro, defined in the `:cl-smt-lib` read table using 16 | the [NAMED-READTABLES](https://github.com/melisgl/named-readtables) 17 | package, enables case-sensitive reading of forms into common lisp. 18 | 19 | The `write-to-smt` function facilitates writing case-sensitive forms 20 | to the solver. 21 | 22 | The following example demonstrates the use of CL-SMT-LIB to launch a 23 | solver process, write a query to the solver, and read back the 24 | results. 25 | 26 | ``` 27 | CL-SMT-LIB> (in-readtable :cl-smt-lib) 28 | T 29 | CL-SMT-LIB> (defparameter smt (make-smt "z3" "-in" "-smt2")) 30 | SMT 31 | CL-SMT-LIB> smt 32 | # 34 | :INPUT-STREAM # 35 | :OUTPUT-STREAM #> 36 | CL-SMT-LIB> (write-to-smt smt 37 | (let ((range 8)) 38 | #!`((set-option :produce-models true) 39 | (set-logic QF_BV) 40 | 41 | (define-fun hamming-weight ((bv (_ BitVec ,RANGE))) 42 | (_ BitVec ,RANGE) 43 | ,(REDUCE (LAMBDA (ACC N) 44 | `(bvadd ,ACC ((_ zero_extend ,(1- RANGE)) 45 | ((_ extract ,N ,N) bv)))) 46 | (LOOP :FOR I :UPFROM 1 :BELOW (1- RANGE) :COLLECT I) 47 | :INITIAL-VALUE 48 | `((_ zero_extend ,(1- RANGE)) ((_ extract 0 0) bv)))) 49 | (declare-const example1 (_ BitVec ,RANGE)) 50 | (declare-const example2 (_ BitVec ,RANGE)) 51 | (assert (= (_ bv3 ,RANGE) (hamming-weight example1))) 52 | (assert (= (_ bv3 ,RANGE) (hamming-weight example2))) 53 | (assert (distinct example1 example2)) 54 | (check-sat) 55 | (get-model)))) 56 | NIL 57 | CL-SMT-LIB> (read smt) 58 | SAT 59 | CL-SMT-LIB> (read smt) 60 | (MODEL (DEFINE-FUN EXAMPLE2 NIL (_ BITVEC 8) 44) 61 | (DEFINE-FUN EXAMPLE1 NIL (_ BITVEC 8) 97)) 62 | ``` 63 | 64 | Since `write-to-smt` takes any stream as its first argument you can 65 | preview the text sent to the smt solver by passing `t` as the first 66 | argument. 67 | ``` 68 | CL-SMT-LIB> (write-to-smt t 69 | (let ((range 8)) 70 | #!`((set-option :produce-models true) 71 | (set-logic QF_BV) 72 | 73 | (define-fun hamming-weight ((bv (_ BitVec ,RANGE))) 74 | (_ BitVec ,RANGE) 75 | ,(REDUCE (LAMBDA (ACC N) 76 | `(bvadd ,ACC ((_ zero_extend ,(1- RANGE)) 77 | ((_ extract ,N ,N) bv)))) 78 | (LOOP :FOR I :UPFROM 1 :BELOW (1- RANGE) :COLLECT I) 79 | :INITIAL-VALUE 80 | `((_ zero_extend ,(1- RANGE)) ((_ extract 0 0) bv)))) 81 | (declare-const example1 (_ BitVec ,RANGE)) 82 | (declare-const example2 (_ BitVec ,RANGE)) 83 | (assert (= (_ bv3 ,RANGE) (hamming-weight example1))) 84 | (assert (= (_ bv3 ,RANGE) (hamming-weight example2))) 85 | (assert (distinct example1 example2)) 86 | (check-sat) 87 | (get-model)))) 88 | (set-option :produce-models true) 89 | (set-logic QF_BV) 90 | (define-fun hamming-weight ((bv (_ BitVec 8))) (_ BitVec 8) 91 | (bvadd 92 | (bvadd 93 | (bvadd 94 | (bvadd 95 | (bvadd 96 | (bvadd ((_ zero_extend 7) ((_ extract 0 0) bv)) 97 | ((_ zero_extend 7) ((_ extract 1 1) bv))) 98 | ((_ zero_extend 7) ((_ extract 2 2) bv))) 99 | ((_ zero_extend 7) ((_ extract 3 3) bv))) 100 | ((_ zero_extend 7) ((_ extract 4 4) bv))) 101 | ((_ zero_extend 7) ((_ extract 5 5) bv))) 102 | ((_ zero_extend 7) ((_ extract 6 6) bv)))) 103 | (declare-const example1 (_ BitVec 8)) 104 | (declare-const example2 (_ BitVec 8)) 105 | (assert (= (_ bv3 8) (hamming-weight example1))) 106 | (assert (= (_ bv3 8) (hamming-weight example2))) 107 | (assert (distinct example1 example2)) 108 | (check-sat) 109 | (get-model) 110 | NIL 111 | CL-SMT-LIB> 112 | ``` 113 | 114 | The special variable `*smt-debug*` may be used to copy smt input and 115 | output to a stream for debugging. Set `*smt-debug*` to `t` to echo 116 | all input and output to STDOUT. 117 | 118 | The following options should work to define smt objects for popular 119 | SMT solvers. 120 | 121 | [Z3](https://github.com/Z3Prover/z3) 122 | : `(make-smt "z3" '("-in" "-smt2"))` 123 | 124 | [CVC4](http://cvc4.cs.stanford.edu/web/) 125 | : `(make-smt "cvc4" '("--lang=smt2"))` 126 | 127 | ## Acknowledgment 128 | 129 | The project or effort depicted was sponsored by the Air Force Research 130 | Laboratory (AFRL) and the Defense Advanced Research Projects Agency 131 | (DARPA) under contract no. FA8750-15-C-0113. Any opinions, findings, 132 | and conclusions or recommendations expressed in this material are 133 | those of the author(s) and do not necessarily reflect the views of 134 | AFRL or DARPA. 135 | -------------------------------------------------------------------------------- /cl-smt-lib.asd: -------------------------------------------------------------------------------- 1 | (defsystem "cl-smt-lib" 2 | :description 3 | "SMT object supporting SMT-LIB communication over input and output streams" 4 | :version "1.0.0" 5 | :author "Eric Schulte " 6 | :licence "BSD-3-Clause" 7 | :depends-on (:cl-smt-lib/cl-smt-lib) 8 | :class :package-inferred-system 9 | :defsystem-depends-on (:asdf-package-system)) 10 | -------------------------------------------------------------------------------- /cl-smt-lib.lisp: -------------------------------------------------------------------------------- 1 | ;;; cl-smt-lib.lisp --- Common Lisp SMT-Lib Integration 2 | (defpackage :cl-smt-lib/cl-smt-lib 3 | (:nicknames :cl-smt-lib) 4 | (:use :common-lisp :named-readtables :cl-smt-lib/process-two-way-stream) 5 | (:import-from :uiop/launch-program :terminate-process :wait-process) 6 | (:export 7 | :make-smt 8 | :smt-error 9 | :ignore-smt-error 10 | :return-smt-error 11 | :write-to-smt 12 | :read-from-smt 13 | :with-smt 14 | :*smt-debug* 15 | ;; smt accessors 16 | :smt-output-stream 17 | :smt-input-stream 18 | :smt-process)) 19 | (in-package :cl-smt-lib/cl-smt-lib) 20 | #+debug (declaim (optimize (debug 3))) 21 | 22 | (defvar *smt-debug* nil 23 | "Set to a stream to duplicate smt input and output to the *SMT-DEBUG*.") 24 | 25 | (defvar *print-nil-as-list* nil 26 | "When bound to non-nil print NIL as the empty list.") 27 | 28 | ;;; Implementation depends on if two-way-stream is a class or structure. 29 | 30 | (defclass smt (process-two-way-stream) () 31 | (:documentation "An SMT process with input and output streams.")) 32 | 33 | (defun make-smt (program &rest args) 34 | "Wrap PROCESS in an SMT object." 35 | (apply #'make-process-two-way-stream program args)) 36 | 37 | (define-condition smt-error (error) 38 | ((text :initarg :text :initform nil :reader text) 39 | (smt :initarg :smt :initform nil :reader smt)) 40 | (:report (lambda (condition stream) 41 | (format stream "SMT: ~a~%~S" 42 | (text condition) (smt condition))))) 43 | 44 | (defmethod print-object :around ((object (eql nil)) stream) 45 | (if *print-nil-as-list* 46 | (write-string "()" stream) 47 | (call-next-method))) 48 | 49 | (defun write-to-smt (smt forms) 50 | "Write FORMS to the process in SMT over it's STDIN. 51 | Sets READTABLE-CASE to :PRESERVE to ensure printing in valid 52 | case-sensitive smt libv2 format." 53 | (let ((*readtable* (copy-readtable nil)) 54 | (*print-nil-as-list* t) 55 | (format-string "~{~S~^~%~}~%")) 56 | (setf (readtable-case *readtable*) :preserve) 57 | (format smt format-string forms) 58 | (when *smt-debug* 59 | (format *smt-debug* "~&;; WRITE-TO-SMT~%") 60 | (format *smt-debug* format-string forms) 61 | (finish-output *smt-debug*)) 62 | (finish-output smt))) 63 | 64 | (defun read-from-smt (smt &optional preserve-case-p (eof-error-p t) eof-value) 65 | "Write FORMS to the process in SMT over it's STDIN. 66 | Sets READTABLE-CASE to :PRESERVE to ensure printing in valid 67 | case-sensitive smt libv2 format." 68 | (let ((*readtable* (copy-readtable nil))) 69 | (when preserve-case-p 70 | (setf (readtable-case *readtable*) :preserve)) 71 | (let ((value (read smt eof-error-p eof-value))) 72 | (when *smt-debug* 73 | (format *smt-debug* "~&;; READ-FROM-SMT~%") 74 | (write value :stream *smt-debug*) 75 | (finish-output *smt-debug*)) 76 | (restart-case 77 | (if (and (listp value) 78 | (equal (if preserve-case-p '|error| 'ERROR) (car value))) 79 | (error (make-condition 'smt-error 80 | :text (second value) 81 | :smt smt)) 82 | value) 83 | (ignore-smt-error () :report "Ignore SMT error." nil) 84 | (return-smt-error () :report "Return SMT error." value))))) 85 | 86 | (defmacro with-smt ((smt (program &rest args) &optional preserve-case-p) 87 | &body body) 88 | (declare (ignore preserve-case-p)) 89 | (let ((form (gensym)) 90 | (status (gensym))) 91 | `(with-open-stream (,smt (make-smt ,program ,@args)) 92 | (unwind-protect 93 | (progn 94 | ,@body 95 | (close (output ,smt)) 96 | (let ((,status (wait-process (process ,smt)))) 97 | (unless (zerop ,status) (error "SMT solver failed with exit status ~S" ,status))) 98 | (loop :for ,form = (read-from-smt ,smt t nil :eof) 99 | :while (not (equal :eof ,form)) 100 | :collect ,form)) 101 | ;; Ensure the process is terminated. 102 | (terminate-process (process ,smt)))))) 103 | 104 | (defun read-preserving-case (stream char n) 105 | (declare (ignorable char) (ignorable n)) 106 | (let ((*readtable* (copy-readtable nil))) 107 | (setf (readtable-case *readtable*) :preserve) 108 | (read stream t nil t))) 109 | 110 | (unless (find-readtable :cl-smt-lib) 111 | (defreadtable :cl-smt-lib 112 | (:merge :current) 113 | (:dispatch-macro-char #\# #\! #'read-preserving-case))) 114 | -------------------------------------------------------------------------------- /fundamental-two-way-stream.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-smt-lib/fundamental-two-way-stream 2 | (:use :cl :trivial-gray-streams) 3 | (:export :fundamental-two-way-stream :input :output)) 4 | (in-package :cl-smt-lib/fundamental-two-way-stream) 5 | 6 | (defclass fundamental-two-way-stream 7 | (fundamental-input-stream fundamental-output-stream) 8 | ((input :initarg :input :accessor input) 9 | (output :initarg :output :accessor output)) 10 | (:documentation 11 | "A two-way stream composed of fundamental-{input,output}-streams.")) 12 | 13 | ;;; Trivial-gray-stream generic function customization. 14 | (defmethod stream-read-char ((stream fundamental-two-way-stream)) 15 | (read-char (input stream) nil :eof)) 16 | 17 | (defmethod stream-read-char-no-hang ((stream fundamental-two-way-stream)) 18 | (read-char-no-hang (input stream))) 19 | 20 | (defmethod stream-read-line ((stream fundamental-two-way-stream)) 21 | (read-line (input stream))) 22 | 23 | (defmethod stream-read-sequence ((stream fundamental-two-way-stream) 24 | sequence start end &key &allow-other-keys) 25 | (read-sequence sequence (input stream) :start start :end end)) 26 | 27 | (defmethod stream-unread-char ((stream fundamental-two-way-stream) character) 28 | (unread-char character (input stream))) 29 | 30 | (defmethod stream-line-column ((stream fundamental-two-way-stream)) 0) 31 | 32 | (defmethod stream-write-char ((stream fundamental-two-way-stream) character) 33 | (write-char character (output stream))) 34 | 35 | (defmethod stream-write-sequence ((stream fundamental-two-way-stream) 36 | sequence start end &key &allow-other-keys) 37 | (write-sequence sequence (output stream) :start start :end end)) 38 | 39 | (defmethod stream-write-string 40 | ((stream fundamental-two-way-stream) string &optional (start 0) end) 41 | (write-string string (output stream) :start start :end end)) 42 | 43 | (defmethod stream-finish-output ((stream fundamental-two-way-stream)) 44 | (finish-output (output stream))) 45 | -------------------------------------------------------------------------------- /process-two-way-stream.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-smt-lib/process-two-way-stream 2 | (:use :cl :cl-smt-lib/fundamental-two-way-stream :uiop/launch-program) 3 | (:export :process-two-way-stream 4 | :make-process-two-way-stream 5 | :input 6 | :output 7 | :process)) 8 | (in-package :cl-smt-lib/process-two-way-stream) 9 | 10 | ;;; A process wrapped in a two-way stream. 11 | (defclass process-two-way-stream (fundamental-two-way-stream) 12 | ((process :initarg :process :initform (error "process argument is required") 13 | :reader process)) 14 | (:documentation 15 | "A fundamental-two-way-stream wrapping a single process' input and output.")) 16 | 17 | (defun make-process-two-way-stream (program &rest args) 18 | "Wrap PROCESS in an PROCESS-TWO-WAY-STREAM object." 19 | (let ((process (launch-program (format nil "~{~a~^ ~}" (cons program args)) 20 | :input :stream 21 | :output :stream 22 | :wait nil 23 | :search t))) 24 | (make-instance 'process-two-way-stream 25 | #+ALLEGRO :element-type #+ALLEGRO '(unsigned-byte 8) 26 | :input (process-info-output process) 27 | :output (process-info-input process) 28 | :process process))) 29 | --------------------------------------------------------------------------------