Fix EXPT printing

cl-quil-tests.asd

@@ -25,6 +25,7 @@
                (:file "initial-rewiring-tests")
                (:file "lexer-tests")
                (:file "parser-tests")
+               (:file "printer-tests")
                (:file "classical-memory-tests")
                (:file "resource-tests")
                (:file "misc-tests")

cl-quil.asd

@@ -41,6 +41,7 @@
                 :components ((:static-file "stdgates.quil")))
                (:file "package")
                (:file "options")
+               (:file "types")
                (:file "utilities")
                (:file "relabeling")
                (:file "matrix-operations")

src/addresser/rewiring.lisp

@@ -8,14 +8,11 @@
 
 (in-package #:cl-quil)
 
-(defun integeropt-vector-p (v)
-  (and (vectorp v) (every (lambda (x) (or (not x) (integerp x))) v)))
-
 (defstruct (rewiring
             (:constructor init-rewiring)
             (:copier nil))
-  (l2p #() :type (satisfies integeropt-vector-p))
-  (p2l #() :type (satisfies integeropt-vector-p)))
+  (l2p #() :type integeropt-vector)
+  (p2l #() :type integeropt-vector))
 
 (defun inverse-matches-forward-p (forward inverse)
   "Checks that each non-NIL mapping in FORWARD has a corresponding inverse mapping in

src/ast.lisp

@@ -100,17 +100,17 @@ EXPRESSION should be an arithetic (Lisp) form which refers to LAMBDA-PARAMS."
 
 (defun make-delayed-expression (params lambda-params expression)
   "Make a DELAYED-EXPRESSION object initially with parameters PARAMS (probably a list of PARAM objects), lambda parameters LAMBDA-PARAMS, and the form EXPRESSION."
-  (assert (every #'symbolp lambda-params))
+  (check-type lambda-params symbol-list)
   (%delayed-expression :params params
                        :lambda-params lambda-params
                        :expression expression))
 
 (defun evaluate-delayed-expression (de &optional (memory-model-evaluator #'identity))
   "Evaluate the delayed expression DE to a numerical value (represented in a CONSTANT data structure). MEMORY-MODEL is an association list with keys MEMORY-REF structures and values the value stored at that location."
   (labels ((lookup-function (expr)
-             (case expr
-               ((+ - * / cos sin tan) expr)
-               (otherwise (error "Illegal function in arithmetic expression: ~a." expr))))
+             (if (valid-quil-function-or-operator-p expr)
+                 expr
+                 (error "Illegal function in arithmetic expression: ~a." expr)))
            (evaluate-parameter (param)
              (etypecase param
                (constant (constant-value param))
@@ -122,7 +122,7 @@ EXPRESSION should be an arithetic (Lisp) form which refers to LAMBDA-PARAMS."
                (cons
                 (let ((args (mapcar (lambda (e) (evaluate-expr params lambda-params e))
                                     (cdr expression))))
-                  (if (every (lambda (thing) (typep thing 'number)) args)
+                  (if (number-list-p args)
                       (apply (lookup-function (first expression)) args)
                       (cdr expression))))
                (symbol
@@ -152,9 +152,20 @@ EXPRESSION should be an arithetic (Lisp) form which refers to LAMBDA-PARAMS."
 
 ;;;;;;;;;;;;;;;;;;;;; Comment protocol for syntax tree objects  ;;;;;;;;;;;;;;;;;;;;
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun make-comment-table ()
+    "Return an empty weak hash table suitable for use as the CL-QUIL::**COMMENTS** table.
+
+This function can be used to re-initialize the **COMMENTS** table.
+
+Keys are tested with EQ."
+    (tg:make-weak-hash-table :test 'eq :weakness ':key)))
+
 (global-vars:define-global-var **comments**
-    (tg:make-weak-hash-table :test 'eq :weakness ':key)
-  "Weak hash table populated with comments associated to different parts of an AST.")
+    (make-comment-table)
+  "Weak hash table populated with comments associated to different parts of an AST.
+
+The keys are typically INSTRUCTION instances and associated values are STRINGs.")
 
 (defun comment (x)
   (values (gethash x **comments**)))
@@ -250,7 +261,7 @@ as a permutation."
 (defun make-gate-definition (name parameters entries)
   "Make a static or parameterized gate definition instance, depending on the existence of PARAMETERS."
   (check-type name string)
-  (assert (every #'symbolp parameters))
+  (check-type parameters symbol-list)
   (if parameters
       (make-instance 'parameterized-gate-definition
                     :name name
@@ -1151,11 +1162,11 @@ For example,
                     ((= (length expr) 3)
                      (format stream "(~a~a~a)"
                              (print-delayed-expression (second expr) nil)
-                             (first expr)
+                             (lisp-symbol->quil-infix-operator (first expr))
                              (print-delayed-expression (third expr) nil)))
                     ((= (length expr) 2)
                      (format stream "~a(~a)"
-                             (first expr)
+                             (lisp-symbol->quil-function-or-prefix-operator (first expr))
                              (print-delayed-expression (second expr) nil)))))
                  (number
                   (format stream "(~/cl-quil:complex-fmt/)" expr))

src/chip-reader.lisp

@@ -54,15 +54,12 @@
   (:documentation "This condition can be signaled when the chip reader fails to find an ISA layer.")
   (:report "Invalid QPU description file: missing required ISA layer or sub-layer."))
 
-(defun integer-list-p (list)
-  (every #'integerp list))
-
 (defun expand-key-to-integer-list (key)
   "Expands a string of the form \"n1-...-nm\" to the list of integers (list n1 ... nm)."
   (etypecase key
     (string
      (mapcar #'parse-integer (split-sequence:split-sequence #\- key)))
-    ((and list (satisfies integer-list-p))
+    (integer-list
      key)))
 
 (defun dead-qubit-hash-table ()

src/clifford/clifford.lisp

@@ -80,7 +80,7 @@ qubits."
 (declaim (ftype (function (t) simple-vector) basis-map))
 (defstruct (clifford (:include qubit-algebra))
   "An element of the Clifford group on NUM-QUBITS qubits."
-  (num-qubits 0 :type unsigned-fixnum)
+  (num-qubits 0 :type quil::unsigned-fixnum)
   (basis-map nil :type simple-vector))
 
 (defmethod num-qubits ((c clifford))
@@ -236,7 +236,7 @@ NOTE: THERE IS NO CHECKING OF THE VALIDITY OF THE MAP. ANTICOMMUTATIVITY IS NOT
   (declare (type clifford c))
   (declare (inline pauli-hash))
   (sxhash
-   (loop :with h :of-type unsigned-fixnum := 0
+   (loop :with h :of-type quil::unsigned-fixnum := 0
          :for p :of-type pauli :across (basis-map c)
          :do (setf h (hash-mix h (pauli-hash p)))
          :finally (return h))))

src/clifford/pauli.lisp

@@ -27,7 +27,7 @@
     (1- (length (pauli-components p))))
 
   (defun make-components (num-qubits)
-    (declare (type unsigned-fixnum num-qubits))
+    (declare (type quil::unsigned-fixnum num-qubits))
     (make-array (1+ num-qubits) :element-type 'base4
                                 :initial-element 0))
 
@@ -265,7 +265,7 @@ hash-function."
   (declare (optimize speed (safety 0) (debug 0) (space 0))
            (type pauli p))
   (sxhash
-   (loop :with h :of-type unsigned-fixnum := 0
+   (loop :with h :of-type quil::unsigned-fixnum := 0
          :for x :across (pauli-components p)
          :do (setf h (hash-mix h x))
          :finally (return h))))

src/clifford/qubit-algebra.lisp

@@ -8,9 +8,6 @@
 ;;; algebras", corresponding to algebras that have some correspondence
 ;;; with collections of qubits.
 
-(deftype unsigned-fixnum ()
-  `(and fixnum unsigned-byte))
-
 (defstruct (qubit-algebra (:conc-name nil))
   "A generic algebra involving objects specialized to NUM-QUBITS qubits.")
 

src/compilers/approx.lisp

@@ -162,7 +162,7 @@
 ;; special-orthogonal, we have to correct this behavior manually.
 (defun find-real-spanning-set (vectors)
   "VECTORS is a list of complex vectors in C^n (which, here, are of type LIST).  When possible, computes a set of vectors with real coefficients that span the same complex subspace of C^n as VECTORS."
-  (assert (a:proper-list-p vectors))
+  (check-type vectors a:proper-list)
   (let* ((coeff-matrix (magicl:make-complex-matrix
                         (length (first vectors))
                         (* 2 (length vectors))

src/define-pragma.lisp

@@ -79,16 +79,6 @@ elements to ELT-TYPE.
     (alexa:lexer-match-error (c)
       (quil-parse-error "Lexer failure: ~A" c))))
 
-(defun integer-sequence-p (object)
-  (and (typep object 'sequence)
-       (every #'integerp object)))
-
-(deftype integer-vector ()
-  `(and vector (satisfies integer-sequence-p)))
-
-(deftype integer-list ()
-  `(and list (satisfies integer-sequence-p)))
-
 
 ;;;;;;;;;;;;;;;;;;;; Macroexpansion-time checking ;;;;;;;;;;;;;;;;;;;;
 

src/gates.lisp

@@ -322,7 +322,7 @@
            (entries (gate-definition-entries gate-def))
            (params (gate-definition-parameters gate-def))
            (dim (isqrt (length entries))))
-      (assert (every #'symbolp params))
+      (check-type params symbol-list)
       (make-instance 'parameterized-gate
                      :name name
                      :dimension dim

src/parser.lisp

@@ -1515,25 +1515,113 @@ INPUT-STRING that triggered the condition."
                   (token-payload tok))))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (a:define-constant +quil<->lisp-functions+
+      '(("SIN"  . cl:sin)
+        ("COS"  . cl:cos)
+        ("SQRT" . cl:sqrt)
+        ("EXP"  . cl:exp)
+        ("CIS"  . cl:cis))
+    :test #'equal
+    :documentation
+    "Functions usable from within Quil, and their associated Lisp function symbols.")
+
+  ;;; If you add a new arithmetic operator to +QUIL<->LISP-PREFIX-ARITHMETIC-OPERATORS+ or
+  ;;; +QUIL<->LISP-INFIX-ARITHMETIC-OPERATORS+, you must also add it to *ARITHMETIC-GRAMMAR*, below.
+  (a:define-constant +quil<->lisp-prefix-arithmetic-operators+
+      '(("-" . cl:-))
+    :test #'equal
+    :documentation
+    "Prefix arithmetic operators usable from within Quil, and their associated Lisp function symbols.")
+
+  (a:define-constant +quil<->lisp-infix-arithmetic-operators+
+      '(("+" . cl:+)
+        ("-" . cl:-)
+        ("/" . cl:/)
+        ("*" . cl:*)
+        ("^" . cl:expt))
+    :test #'equal
+    :documentation
+    "Infix arithmetic operators usable from within Quil, and their associated Lisp function symbols.")
+
+  (defun %lisp->quil (lisp-symbol alist)
+    (check-type lisp-symbol symbol)
+    (a:when-let ((found (rassoc lisp-symbol alist :test #'eq)))
+      (car found)))
+
+  (defun %quil->lisp (quil-string alist)
+    (check-type quil-string string)
+    (a:when-let ((found (assoc quil-string alist :test #'string-equal)))
+      (cdr found)))
+
+  ;;; The following functions handle conversion between Quil's arithmetic operators/functions and
+  ;;; the corresponding lisp symbols (fbound to lisp functions) that are used in CL-QUIL for
+  ;;; evaluating Quil's arithmetic expressions. The mapping from lisp->Quil and Quil->lisp is
+  ;;; determined by the above tables, namely: +QUIL<->LISP-FUNCTIONS+,
+  ;;; +QUIL<->LISP-PREFIX-ARITHMETIC-OPERATORS+, and +QUIL<->LISP-INFIX-ARITHMETIC-OPERATORS+.
+  ;;;
+  ;;; For example, the Quil infix operator "/" in an expression like "pi/8" maps to the Common Lisp
+  ;;; symbol CL:/ and vice versa. Likewise for the prefix operator "-" in "-%theta" which maps to
+  ;;; CL:-.
+  ;;;
+  ;;; The purpose of the following functions is to provide a layer of abstraction around the
+  ;;; conversion to/from Quil<->lisp and to act as a single source of truth for such conversions.
+  ;;;
+  ;;; Here is a glossary of the terms used in the following function names:
+  ;;;
+  ;;; lisp-symbol:
+  ;;;     a SYMBOL which is fbound to a lisp function appropriate for evaluating the corresponding
+  ;;;     Quil function or arithmetic operator.
+  ;;;
+  ;;; quil-function:
+  ;;;     a STRING that denotes a Quil arithmetic function. For example "SIN", "COS", "EXP", etc.
+  ;;;     See the table +QUIL<->LISP-FUNCTIONS+ for the list of valid functions.
+  ;;;
+  ;;; quil-prefix-operator:
+  ;;;     a STRING that denotes a Quil prefix (unary) arithmetic operator. For example, the "-" in
+  ;;;     the expression "-pi/2". See the table +QUIL<->LISP-PREFIX-ARITHMETIC-OPERATORS+ for the
+  ;;;     list of valid prefix operators.
+  ;;;
+  ;;; quil-infix-operator:
+  ;;;     a STRING that denotes a Quil infix (binary) arithmetic operator. For example, the "-" in
+  ;;;     the expression "COS(%x) - i * SIN(%x)". See +QUIL<->LISP-INFIX-ARITHMETIC-OPERATORS+ for
+  ;;;     the list of valid infix operators.
+
+  (defun lisp-symbol->quil-prefix-operator (symbol)
+    (%lisp->quil symbol +quil<->lisp-prefix-arithmetic-operators+))
+
+  (defun quil-prefix-operator->lisp-symbol (quil-prefix-operator)
+    (%quil->lisp quil-prefix-operator +quil<->lisp-prefix-arithmetic-operators+))
+
+  (defun lisp-symbol->quil-infix-operator (symbol)
+    (%lisp->quil symbol +quil<->lisp-infix-arithmetic-operators+))
+
+  (defun quil-infix-operator->lisp-symbol (quil-infix-operator)
+    (%quil->lisp quil-infix-operator +quil<->lisp-infix-arithmetic-operators+))
+
+  (defun lisp-symbol->quil-function (symbol)
+    (%lisp->quil symbol +quil<->lisp-functions+))
+
+  (defun quil-function->lisp-symbol (quil-function)
+    (%quil->lisp quil-function +quil<->lisp-functions+))
+
+  (defun lisp-symbol->quil-function-or-prefix-operator (symbol)
+    (or (lisp-symbol->quil-function symbol)
+        (lisp-symbol->quil-prefix-operator symbol)))
+
+  (defun valid-quil-function-or-operator-p (symbol)
+    (not (null (or (lisp-symbol->quil-function symbol)
+                   (lisp-symbol->quil-prefix-operator symbol)
+                   (lisp-symbol->quil-infix-operator symbol)))))
+
   (defun binary (head)
     (lambda (a i0 b)
       (declare (ignore i0))
       (list head a b)))
 
-  (defparameter *valid-functions*
-    '(("SIN"  cl:sin)
-      ("COS"  cl:cos)
-      ("SQRT" cl:sqrt)
-      ("EXP"  cl:exp)
-      ("CIS"  cl:cis))
-    "Functions usable from within Quil, and their associated Lisp function symbols.")
-
   (defun validate-function (func-name)
-    "Validate the function named FUNC-NAME against *VALID-FUNCTIONS*. Signal a QUIL-PARSE-ERROR if it's invalid."
-    (let ((found (assoc func-name *valid-functions* :test #'string-equal)))
-      (if found
-          (second found)
-          (quil-parse-error "Invalid function name: ~A" func-name))))
+    "Return the lisp symbol that corresponds to the Quil function named FUNC-NAME, or signal a QUIL-PARSE-ERROR if FUNC-NAME is invalid."
+    (or (quil-function->lisp-symbol func-name)
+        (quil-parse-error "Invalid function name: ~A" func-name)))
 
   (defun find-or-make-parameter-symbol (param)
     (let ((found (assoc (param-name param)
@@ -1563,18 +1651,20 @@ INPUT-STRING that triggered the condition."
   (:precedence ((:right :EXPT) (:left :TIMES :DIVIDE) (:left :PLUS :MINUS)))
 
   (expr
-   (expr :PLUS expr (binary 'cl:+))
-   (expr :MINUS expr (binary 'cl:-))
-   (expr :TIMES expr (binary 'cl:*))
-   (expr :DIVIDE expr (binary 'cl:/))
-   (expr :EXPT expr (binary 'cl:expt))
+   ;; If you add a new arithmetic operator here, you must also add it to
+   ;; +quil<->lisp-infix-arithmetic-operators+, above.
+   (expr :PLUS expr (binary (quil-infix-operator->lisp-symbol "+")))
+   (expr :MINUS expr (binary (quil-infix-operator->lisp-symbol "-")))
+   (expr :TIMES expr (binary (quil-infix-operator->lisp-symbol "*")))
+   (expr :DIVIDE expr (binary (quil-infix-operator->lisp-symbol "/")))
+   (expr :EXPT expr (binary (quil-infix-operator->lisp-symbol "^")))
    term)
 
   (term
    (:MINUS expr
            (lambda (i0 x)
              (declare (ignore i0))
-             (list 'cl:- x)))
+             (list (quil-prefix-operator->lisp-symbol "-") x)))
    (:NAME :LEFT-PAREN expr :RIGHT-PAREN
           (lambda (f i0 x i1)
             (declare (ignore i0 i1))