diff --git a/forge/froglet/lang/bsl-lang-specific-checks.rkt b/forge/froglet/lang/bsl-lang-specific-checks.rkt index a82440cf..0b465484 100644 --- a/forge/froglet/lang/bsl-lang-specific-checks.rkt +++ b/forge/froglet/lang/bsl-lang-specific-checks.rkt @@ -187,39 +187,39 @@ ;(hash-set! bsl-checker-hash node/formula/multiplicity check-node-formula-multiplicity) (hash-set! bsl-checker-hash 'empty-join err-empty-join) ;(hash-set! bsl-checker-hash 'relation-join err-relation-join) -(hash-set! bsl-checker-hash node/formula/op/in check-node-formula-op-in) -(hash-set! bsl-checker-hash node/formula/op/= check-node-formula-op-=) -(hash-set! bsl-checker-hash node/expr/op/+ check-node-expr-op-+) -(hash-set! bsl-checker-hash node/expr/op/- check-node-expr-op--) -(hash-set! bsl-checker-hash node/expr/op/& check-node-expr-op-&) -(hash-set! bsl-checker-hash node/expr/op/-> check-node-expr-op-->) -(hash-set! bsl-checker-hash node/expr/op/join check-node-expr-op-join) -(hash-set! bsl-checker-hash node/expr/op/^ check-node-expr-op-^) -(hash-set! bsl-checker-hash node/expr/op/* check-node-expr-op-*) -(hash-set! bsl-checker-hash node/expr/op/~ check-node-expr-op-~) +(hash-set! bsl-checker-hash node/formula/op-on-exprs/in check-node-formula-op-in) +(hash-set! bsl-checker-hash node/formula/op-on-exprs/= check-node-formula-op-=) +(hash-set! bsl-checker-hash node/expr/op-on-exprs/+ check-node-expr-op-+) +(hash-set! bsl-checker-hash node/expr/op-on-exprs/- check-node-expr-op--) +(hash-set! bsl-checker-hash node/expr/op-on-exprs/& check-node-expr-op-&) +(hash-set! bsl-checker-hash node/expr/op-on-exprs/-> check-node-expr-op-->) +(hash-set! bsl-checker-hash node/expr/op-on-exprs/join check-node-expr-op-join) +(hash-set! bsl-checker-hash node/expr/op-on-exprs/^ check-node-expr-op-^) +(hash-set! bsl-checker-hash node/expr/op-on-exprs/* check-node-expr-op-*) +(hash-set! bsl-checker-hash node/expr/op-on-exprs/~ check-node-expr-op-~) ;(hash-set! bsl-checker-hash node/fmla/pred-spacer check-node-fmla-pred-spacer) ;(hash-set! bsl-checker-hash node/expr/fun-spacer check-node-expr-fun-spacer) ;(hash-set! bsl-checker-hash node/formula/constant check-node-formula-constant) ;(hash-set! bsl-checker-hash node/formula/op check-node-formula-op) ;(hash-set! bsl-checker-hash node/formula/quantified check-node-formula-quantified) -;(hash-set! bsl-checker-hash node/formula/op/always check-node-formula-op-always) -;(hash-set! bsl-checker-hash node/formula/op/eventually check-node-formula-op-eventually) -;(hash-set! bsl-checker-hash node/formula/op/until check-node-formula-op-until) -;(hash-set! bsl-checker-hash node/formula/op/releases check-node-formula-op-releases) -;(hash-set! bsl-checker-hash node/formula/op/next_state check-node-formula-op-next_state) -;(hash-set! bsl-checker-hash node/formula/op/historically check-node-formula-op-historically) -;(hash-set! bsl-checker-hash node/formula/op/once check-node-formula-op-once) -;(hash-set! bsl-checker-hash node/formula/op/prev_state check-node-formula-op-prev_state) -;(hash-set! bsl-checker-hash node/formula/op/since check-node-formula-op-since) -;(hash-set! bsl-checker-hash node/formula/op/triggered check-node-formula-op-triggered) -;(hash-set! bsl-checker-hash node/formula/op/&& check-node-formula-op-&&) -;(hash-set! bsl-checker-hash node/formula/op/|| check-node-formula-op-||) -;(hash-set! bsl-checker-hash node/formula/op/=> check-node-formula-op-=>) -;(hash-set! bsl-checker-hash node/formula/op/! check-node-formula-op-!) -;(hash-set! bsl-checker-hash node/formula/op/int> check-node-formula-op-int>) -;(hash-set! bsl-checker-hash node/formula/op/int< check-node-formula-op-int<) -;(hash-set! bsl-checker-hash node/formula/op/int= check-node-formula-op-int=) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/always check-node-formula-op-always) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/eventually check-node-formula-op-eventually) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/until check-node-formula-op-until) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/releases check-node-formula-op-releases) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/next_state check-node-formula-op-next_state) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/historically check-node-formula-op-historically) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/once check-node-formula-op-once) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/prev_state check-node-formula-op-prev_state) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/since check-node-formula-op-since) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/triggered check-node-formula-op-triggered) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/&& check-node-formula-op-&&) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/|| check-node-formula-op-||) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/=> check-node-formula-op-=>) +;(hash-set! bsl-checker-hash node/formula/op-on-formulas/! check-node-formula-op-!) +;(hash-set! bsl-checker-hash node/formula/op-on-ints/int> check-node-formula-op-int>) +;(hash-set! bsl-checker-hash node/formula/op-on-ints/int< check-node-formula-op-int<) +;(hash-set! bsl-checker-hash node/formula/op-on-ints/int= check-node-formula-op-int=) ;(hash-set! bsl-checker-hash node/expr/relation check-node-expr-relation) ;(hash-set! bsl-checker-hash node/expr/atom check-node-expr-atom) ;(hash-set! bsl-checker-hash node/expr/ite check-node-expr-ite) @@ -227,8 +227,8 @@ ;(hash-set! bsl-checker-hash node/expr/op check-node-expr-op) ;(hash-set! bsl-checker-hash node/expr/quantifier-var check-node-expr-quantifier-var) ;(hash-set! bsl-checker-hash node/expr/comprehension check-node-expr-comprehension) -;(hash-set! bsl-checker-hash node/expr/op/prime check-node-expr-op-prime) -;(hash-set! bsl-checker-hash node/expr/op/sing check-node-expr-op-sing) +;(hash-set! bsl-checker-hash node/expr/op-on-exprs/prime check-node-expr-op-prime) +;(hash-set! bsl-checker-hash node/expr/op-on-ints/sing check-node-expr-op-sing) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -319,14 +319,14 @@ (define bsl-ast-checker-hash (make-hash)) (hash-set! bsl-ast-checker-hash 'field-decl bsl-field-decl-func) -(hash-set! bsl-ast-checker-hash node/formula/op/= check-args-node-formula-op-=) -(hash-set! bsl-ast-checker-hash node/expr/op/-> check-args-node-expr-op-->) -(hash-set! bsl-ast-checker-hash node/expr/op/+ check-args-node-expr-op-+) -(hash-set! bsl-ast-checker-hash node/expr/op/- check-args-node-expr-op--) -(hash-set! bsl-ast-checker-hash node/expr/op/& check-args-node-expr-op-&) -(hash-set! bsl-ast-checker-hash node/expr/op/^ check-args-node-expr-op-^) -(hash-set! bsl-ast-checker-hash node/expr/op/* check-args-node-expr-op-*) -(hash-set! bsl-ast-checker-hash node/expr/op/~ check-args-node-expr-op-~) +(hash-set! bsl-ast-checker-hash node/formula/op-on-exprs/= check-args-node-formula-op-=) +(hash-set! bsl-ast-checker-hash node/expr/op-on-exprs/-> check-args-node-expr-op-->) +(hash-set! bsl-ast-checker-hash node/expr/op-on-exprs/+ check-args-node-expr-op-+) +(hash-set! bsl-ast-checker-hash node/expr/op-on-exprs/- check-args-node-expr-op--) +(hash-set! bsl-ast-checker-hash node/expr/op-on-exprs/& check-args-node-expr-op-&) +(hash-set! bsl-ast-checker-hash node/expr/op-on-exprs/^ check-args-node-expr-op-^) +(hash-set! bsl-ast-checker-hash node/expr/op-on-exprs/* check-args-node-expr-op-*) +(hash-set! bsl-ast-checker-hash node/expr/op-on-exprs/~ check-args-node-expr-op-~) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Partial instances and example instance blocks @@ -344,5 +344,5 @@ ; (define loc (nodeinfo-loc (node-info formula-node))) ; (raise-bsl-relational-error "\"in\"" formula-node loc))) -;(hash-set! bsl-inst-checker-hash node/formula/op/in inst-check-node-formula-op-in) +;(hash-set! bsl-inst-checker-hash node/formula/op-on-exprs/in inst-check-node-formula-op-in) (provide bsl-inst-checker-hash) diff --git a/forge/lang/ast.rkt b/forge/lang/ast.rkt index f0dcc963..c8dc2ecd 100644 --- a/forge/lang/ast.rkt +++ b/forge/lang/ast.rkt @@ -26,8 +26,8 @@ ; * node/expr (arity) -- expressions ; * node/expr/fun-spacer -- no-op spacer to record location where a fun substitution was done ; * node/expr/op (children) -- simple operators -; * node/expr/op/+ -; * node/expr/op/- +; * node/expr/op-on-exprs/+ +; * node/expr/op-on-exprs/- ; * ... ; * node/expr/comprehension (decls formula) -- set comprehension ; * node/expr/relation (name typelist-thunk parent is-variable) -- leaf relation @@ -46,7 +46,7 @@ ; * node/int -- integer expression ; * node/int/sum-quant -- sum "quantified" form ; * node/int/op (children) -; * node/int/op/add +; * node/int/op-on-ints/add ; * ... ; * node/int/constant (value) -- int constant ;; ----------------------------------------------------------------------------- @@ -130,7 +130,7 @@ ; if somehow the user has provided something ill-typed that wasn't caught elsewhere. (define (intexpr->expr/maybe a-node #:op functionname #:info info) ;(@-> (or/c node? integer?) #:op symbol? #:info nodeinfo? node/expr?) - (cond [(node/int? a-node) (node/expr/op/sing (update-annotation (node-info a-node) 'automatic-int-conversion #t) 1 (list a-node))] + (cond [(node/int? a-node) (node/expr/op-on-ints/sing (update-annotation (node-info a-node) 'automatic-int-conversion #t) 1 (list a-node))] [(integer? a-node) (intexpr->expr/maybe (int a-node) #:op functionname #:info info)] [(node/expr? a-node) a-node] [else @@ -144,7 +144,7 @@ (cond [(and (node/expr? a-node) (equal? (node/expr-arity a-node) 1)) ; If arity 1, this node/expr can be converted automatically to a node/int - (node/int/op/sum (update-annotation (node-info a-node) 'automatic-int-conversion #t) (list a-node))] + (node/int/op-on-exprs/sum (update-annotation (node-info a-node) 'automatic-int-conversion #t) (list a-node))] [(node/expr? a-node) ; Otherwise, this node/expr has the wrong arity for auto-conversion to a node/int (raise-forge-error @@ -291,7 +291,18 @@ ;; -- operators ---------------------------------------------------------------- ; Should never be directly instantiated -(struct node/expr/op node/expr (children) #:transparent) +(struct node/expr/op node/expr () #:transparent) + +; Intermediate structs grouping operators by child type (for Typed Racket support) +; Each intermediate declares children with the appropriate type constraint +(struct node/expr/op-on-exprs node/expr/op (children) #:transparent) ; children are node/expr +(struct node/expr/op-on-ints node/expr/op (children) #:transparent) ; children are node/int + +; Generic accessor for backward compatibility (returns Listof node) +(define (node/expr/op-children op) + (cond [(node/expr/op-on-exprs? op) (node/expr/op-on-exprs-children op)] + [(node/expr/op-on-ints? op) (node/expr/op-on-ints-children op)] + [else (raise-forge-error #:msg "Unknown node/expr/op subtype" #:context op)])) ;; if-then-else *expression*, which is different from an if-then-else formula ; The formula version is just sugar, the expression version is a basic expr type @@ -350,27 +361,40 @@ ; lifted operators are defaults, for when the types aren't as expected ; parent: the node struct type that is the parent of this new one ; arity: the arity of the new node, in terms of the arities of its children + +; Helper to derive the intermediate parent suffix based on child type +; Used at compile time to generate hierarchical struct names +(begin-for-syntax + (define (childtype->suffix childtype-stx) + (define ct (syntax->datum childtype-stx)) + (cond [(equal? ct 'node/expr?) "-on-exprs"] + [(equal? ct 'node/int?) "-on-ints"] + [(equal? ct 'node/formula?) "-on-formulas"] + ; For custom type predicates (e.g., breakers), use empty suffix (old behavior) + [else ""]))) + (define-syntax (define-node-op stx) (syntax-case stx () [(_ id parent arity checks ... #:lift @op #:type childtype #:elim-unary? elim-unary?) ;(printf "define-node-op defn case: ~a~n" stx) - (with-syntax ([name (format-id #'id "~a/~a" #'parent #'id)] + (with-syntax ([intermediate (format-id #'id "~a~a" #'parent (childtype->suffix #'childtype))] + [name (format-id #'id "~a~a/~a" #'parent (childtype->suffix #'childtype) #'id)] [parentname (format-id #'id "~a" #'parent)] [functionname (format-id #'id "~a/func" #'id)] [macroname/info-help (format-id #'id "~a/info-help" #'id)] [macroname/info (format-id #'id "~a/info" #'id)] [child-accessor (format-id #'id "~a-children" #'parent)] - [key (format-id #'id "~a/~a" #'parent #'id)] + [key (format-id #'id "~a~a/~a" #'parent (childtype->suffix #'childtype) #'id)] [display-id (if (equal? '|| (syntax->datum #'id)) "||" #'id)] [ellip '...]) ; otherwise ... is interpreted as belonging to the outer macro (syntax/loc stx (begin - (struct name parent () #:transparent #:reflection-name 'id + (struct name intermediate () #:transparent #:reflection-name 'id #:methods gen:equal+hash - [(define equal-proc (make-robust-node-equal-syntax parentname)) - (define hash-proc (make-robust-node-hash-syntax parentname 0)) - (define hash2-proc (make-robust-node-hash-syntax parentname 3))] + [(define equal-proc (make-robust-node-equal-syntax intermediate)) + (define hash-proc (make-robust-node-hash-syntax intermediate 0)) + (define hash2-proc (make-robust-node-hash-syntax intermediate 3))] #:methods gen:custom-write [(define (write-proc self port mode) ; all of the /op nodes have their children in a field named "children" @@ -711,7 +735,18 @@ ;; -- operators ---------------------------------------------------------------- -(struct node/int/op node/int (children) #:transparent) +(struct node/int/op node/int () #:transparent) + +; Intermediate structs grouping operators by child type (for Typed Racket support) +; Each intermediate declares children with the appropriate type constraint +(struct node/int/op-on-ints node/int/op (children) #:transparent) ; children are node/int +(struct node/int/op-on-exprs node/int/op (children) #:transparent) ; children are node/expr + +; Generic accessor for backward compatibility (returns Listof node) +(define (node/int/op-children op) + (cond [(node/int/op-on-ints? op) (node/int/op-on-ints-children op)] + [(node/int/op-on-exprs? op) (node/int/op-on-exprs-children op)] + [else (raise-forge-error #:msg "Unknown node/int/op subtype" #:context op)])) (define-node-op add node/int/op #f #:min-length 2 #:type node/int?) (define-node-op subtract node/int/op #f #:min-length 2 #:type node/int?) @@ -825,7 +860,20 @@ ;; -- operators ---------------------------------------------------------------- ; Should never be directly instantiated -(struct node/formula/op node/formula (children) #:transparent) +(struct node/formula/op node/formula () #:transparent) + +; Intermediate structs grouping operators by child type (for Typed Racket support) +; Each intermediate declares children with the appropriate type constraint +(struct node/formula/op-on-formulas node/formula/op (children) #:transparent) ; children are node/formula +(struct node/formula/op-on-exprs node/formula/op (children) #:transparent) ; children are node/expr +(struct node/formula/op-on-ints node/formula/op (children) #:transparent) ; children are node/int + +; Generic accessor for backward compatibility (returns Listof node) +(define (node/formula/op-children op) + (cond [(node/formula/op-on-formulas? op) (node/formula/op-on-formulas-children op)] + [(node/formula/op-on-exprs? op) (node/formula/op-on-exprs-children op)] + [(node/formula/op-on-ints? op) (node/formula/op-on-ints-children op)] + [else (raise-forge-error #:msg "Unknown node/formula/op subtype" #:context op)])) (define-node-op in node/formula/op #f #:same-arity? #t #:max-length 2 #:type node/expr?) @@ -874,7 +922,7 @@ (require (prefix-in @ (only-in racket ->))) (define/contract (maybe-and->list fmla) (@-> node/formula? (listof node/formula?)) - (cond [(node/formula/op/&&? fmla) + (cond [(node/formula/op-on-formulas/&&? fmla) (apply append (map maybe-and->list (node/formula/op-children fmla)))] [else (list fmla)])) diff --git a/forge/lang/deparse.rkt b/forge/lang/deparse.rkt index ea00ae46..1cf69272 100644 --- a/forge/lang/deparse.rkt +++ b/forge/lang/deparse.rkt @@ -67,7 +67,7 @@ (define (deparse-formula-op formula parent-priority) (match formula - [(? node/formula/op/&&?) + [(? node/formula/op-on-formulas/&&?) ; Sometimes && nodes need to contain 0 or 1 arguments (cond [(equal? 0 (length (node/formula/op-children formula))) "true"] @@ -79,107 +79,107 @@ (if (@< PRIORITY-AND parent-priority) (format "(~a && ~a)" left-child right-child) (format "~a && ~a" left-child right-child)))])] - [(? node/formula/op/||?) + [(? node/formula/op-on-formulas/||?) (let ([left-child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-OR)] [right-child (deparse-formula (second (node/formula/op-children formula)) PRIORITY-OR)]) (if (@< PRIORITY-OR parent-priority) (format "(~a || ~a)" left-child right-child) (format "~a || ~a" left-child right-child)))] - [(? node/formula/op/=>?) + [(? node/formula/op-on-formulas/=>?) (let ([left-child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-IMPLIES)] [right-child (deparse-formula (second (node/formula/op-children formula)) PRIORITY-IMPLIES)]) (if (@< PRIORITY-IMPLIES parent-priority) (format "(~a => ~a)" left-child right-child) (format "~a => ~a" left-child right-child)))] - [(? node/formula/op/always?) + [(? node/formula/op-on-formulas/always?) (let ([child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-ALWAYS)]) (if (@< PRIORITY-ALWAYS parent-priority) (format "(always ~a)" child) (format "always ~a" child)))] - [(? node/formula/op/eventually?) + [(? node/formula/op-on-formulas/eventually?) (let ([child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-EVENTUALLY)]) (if (@< PRIORITY-EVENTUALLY parent-priority) (format "(eventually ~a)" child) (format "eventually ~a" child)))] - [(? node/formula/op/next_state?) + [(? node/formula/op-on-formulas/next_state?) (let ([child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-AFTER)]) (if (@< PRIORITY-AFTER parent-priority) (format "(next_state ~a)" child) (format "next_state ~a" child)))] - [(? node/formula/op/historically?) + [(? node/formula/op-on-formulas/historically?) (let ([child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-HISTORICALLY)]) (if (@< PRIORITY-HISTORICALLY parent-priority) (format "(historically ~a)" child) (format "historically ~a" child)))] - [(? node/formula/op/once?) + [(? node/formula/op-on-formulas/once?) (let ([child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-ONCE)]) (if (@< PRIORITY-ONCE parent-priority) (format "(once ~a)" child) (format "once ~a" child)))] - [(? node/formula/op/prev_state?) + [(? node/formula/op-on-formulas/prev_state?) (let ([child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-BEFORE)]) (if (@< PRIORITY-BEFORE parent-priority) (format "(prev_state ~a)" child) (format "prev_state ~a" child)))] - [(? node/formula/op/releases?) + [(? node/formula/op-on-formulas/releases?) (let ([left-child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-RELEASES)] [right-child (deparse-formula (second (node/formula/op-children formula)) PRIORITY-RELEASES)]) (if (@<= PRIORITY-RELEASES parent-priority) (format "(~a releases ~a)" left-child right-child) (format "~a releases ~a" left-child right-child)))] - [(? node/formula/op/until?) + [(? node/formula/op-on-formulas/until?) (let ([left-child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-UNTIL)] [right-child (deparse-formula (second (node/formula/op-children formula)) PRIORITY-UNTIL)]) (if (@<= PRIORITY-UNTIL parent-priority) (format "(~a until ~a)" left-child right-child) (format "~a until ~a" left-child right-child)))] - [(? node/formula/op/since?) + [(? node/formula/op-on-formulas/since?) (let ([left-child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-SINCE)] [right-child (deparse-formula (second (node/formula/op-children formula)) PRIORITY-SINCE)]) (if (@<= PRIORITY-SINCE parent-priority) (format "(~a since ~a)" left-child right-child) (format "~a since ~a" left-child right-child)))] - [(? node/formula/op/triggered?) + [(? node/formula/op-on-formulas/triggered?) (let ([left-child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-TRIGGERED)] [right-child (deparse-formula (second (node/formula/op-children formula)) PRIORITY-TRIGGERED)]) (if (@<= PRIORITY-TRIGGERED parent-priority) (format "(~a releases ~a)" left-child right-child) (format "~a releases ~a" left-child right-child)))] - [(? node/formula/op/in?) + [(? node/formula/op-on-exprs/in?) (let ([left-child (deparse-expr (first (node/formula/op-children formula)) PRIORITY-COMPAREOP)] [right-child (deparse-expr (second (node/formula/op-children formula)) PRIORITY-COMPAREOP)]) (if (@< PRIORITY-COMPAREOP parent-priority) (format "(~a in ~a)" left-child right-child) (format "~a in ~a" left-child right-child)))] - [(? node/formula/op/=?) + [(? node/formula/op-on-exprs/=?) (let ([left-child (deparse-expr (first (node/formula/op-children formula)) PRIORITY-COMPAREOP)] [right-child (deparse-expr (second (node/formula/op-children formula)) PRIORITY-COMPAREOP)]) (if (@<= PRIORITY-COMPAREOP parent-priority) (format "(~a = ~a)" left-child right-child) (format "~a = ~a" left-child right-child)))] - [(? node/formula/op/!?) + [(? node/formula/op-on-formulas/!?) (let ([child (deparse-formula (first (node/formula/op-children formula)) PRIORITY-NEG)]) (if (@< PRIORITY-NEG parent-priority) (format "(not ~a)" child) (format "not ~a" child)))] - [(? node/formula/op/int>?) + [(? node/formula/op-on-ints/int>?) (let ([left-child (deparse-int (first (node/formula/op-children formula)) PRIORITY-COMPAREOP)] [right-child (deparse-int (second (node/formula/op-children formula)) PRIORITY-COMPAREOP)]) (if (@<= PRIORITY-COMPAREOP parent-priority) (format "(~a > ~a)" left-child right-child) (format "~a > ~a" left-child right-child)))] - [(? node/formula/op/int?) + [(? node/expr/op-on-exprs/->?) (let ([left-child (deparse-expr (first (node/expr/op-children expr)) PRIORITY-CROSSPROD)] [right-child (deparse-expr (second (node/expr/op-children expr)) PRIORITY-CROSSPROD)]) (if (@<= PRIORITY-CROSSPROD parent-priority) (format "(~a->~a)" left-child right-child) (format "~a->~a" left-child right-child)))] - [(? node/expr/op/prime?) + [(? node/expr/op-on-exprs/prime?) (let ([child (deparse-expr (first (node/expr/op-children expr)) PRIORITY-PRIME)]) (if (@< PRIORITY-PRIME parent-priority) (format "(~a')" child) (format "~a'" child)))] - [(? node/expr/op/join?) + [(? node/expr/op-on-exprs/join?) (let ([left-child (deparse-expr (first (node/expr/op-children expr)) PRIORITY-JOIN)] [right-child (deparse-expr (second (node/expr/op-children expr)) PRIORITY-JOIN)]) (if (@< PRIORITY-JOIN parent-priority) (format "(~a.~a)" left-child right-child) (format "~a.~a" left-child right-child)))] - [(? node/expr/op/^?) + [(? node/expr/op-on-exprs/^?) (let ([child (deparse-expr (first (node/expr/op-children expr)) PRIORITY-EXP)]) (if (@< PRIORITY-EXP parent-priority) (format "(^~a)" child) (format "^~a" child)))] - [(? node/expr/op/*?) + [(? node/expr/op-on-exprs/*?) (let ([child (deparse-expr (first (node/expr/op-children expr)) PRIORITY-CROSSPROD)]) (if (@< PRIORITY-CROSSPROD parent-priority) (format "(*~a)" child) (format "*~a" child)))] - [(? node/expr/op/~?) + [(? node/expr/op-on-exprs/~?) (let ([child (deparse-expr (first (node/expr/op-children expr)) PRIORITY-TILDE)]) (if (@< PRIORITY-TILDE parent-priority) (format "(~a ~a)" '~~ child) (format "~a ~a" '~~ child)))] - [(? node/expr/op/sing?) + [(? node/expr/op-on-ints/sing?) (let ([child (deparse-int (first (node/expr/op-children expr)) 0)]) (format "sing[~a]" child))])) @@ -310,7 +310,7 @@ "Int"] [(node/expr/constant info arity type) (format "~a " type)] - [(node/expr/op info arity args) + [(? node/expr/op?) (deparse-expr-op expr parent-priority)] [(node/expr/quantifier-var info arity sym name) (format "~a" name)] @@ -327,7 +327,7 @@ (match expr [(node/int/constant info value) (format "~a" value)] - [(node/int/op info args) + [(? node/int/op?) (deparse-int-op expr parent-priority)] [(node/int/sum-quant info decls int-expr) (format "sum ~a | { ~a }" @@ -346,25 +346,25 @@ (define (deparse-int-op expr parent-priority) (match expr - [(node/int/op/add info args) + [(node/int/op-on-ints/add info args) (format-nary-call "add" args)] - [(node/int/op/subtract info args) + [(node/int/op-on-ints/subtract info args) (format-nary-call "subtract" args)] - [(node/int/op/multiply info args) + [(node/int/op-on-ints/multiply info args) (format-nary-call "multiply" args)] - [(node/int/op/divide info args) + [(node/int/op-on-ints/divide info args) (format-nary-call "divide" args)] - [(node/int/op/sum info args) + [(node/int/op-on-exprs/sum info args) (format "sum[~a]" (deparse-expr (first args) 0))] - [(node/int/op/card info args) + [(node/int/op-on-exprs/card info args) (format "#~a" (deparse-expr (first args) PRIORITY-CARD))] - [(node/int/op/remainder info args) + [(node/int/op-on-ints/remainder info args) (format "remainder[~a, ~a]" (deparse-int (car args) 0) (deparse-int (cdr args) 0))] - [(node/int/op/abs info args) + [(node/int/op-on-ints/abs info args) (format "abs[~a]" (deparse-int (first args) 0))] - [(node/int/op/sign info args) + [(node/int/op-on-ints/sign info args) (format "sign[~a]" (deparse-int (first args) 0))] [(node/int/sum-quant info decls int-expr) (format "sum ~a | { ~a }" diff --git a/forge/lang/expander.rkt b/forge/lang/expander.rkt index f91070a9..c23e60be 100644 --- a/forge/lang/expander.rkt +++ b/forge/lang/expander.rkt @@ -1623,17 +1623,17 @@ ; Annoyingly, structs aren't polymorphic in the way we need. This is not elegant, but: ; join, transpose, +, -, &, ^, *, ->, sing, ', ++ - [(node/expr/op/join? astnode) (rebuild-expr-op node/expr/op/join astnode new-info)] - [(node/expr/op/~? astnode) (rebuild-expr-op node/expr/op/~ astnode new-info)] - [(node/expr/op/+? astnode) (rebuild-expr-op node/expr/op/+ astnode new-info)] - [(node/expr/op/-? astnode) (rebuild-expr-op node/expr/op/- astnode new-info)] - [(node/expr/op/&? astnode) (rebuild-expr-op node/expr/op/& astnode new-info)] - [(node/expr/op/^? astnode) (rebuild-expr-op node/expr/op/^ astnode new-info)] - [(node/expr/op/*? astnode) (rebuild-expr-op node/expr/op/* astnode new-info)] - [(node/expr/op/->? astnode) (rebuild-expr-op node/expr/op/-> astnode new-info)] - [(node/expr/op/sing? astnode) (rebuild-expr-op node/expr/op/sing astnode new-info)] - [(node/expr/op/prime? astnode) (rebuild-expr-op node/expr/op/prime astnode new-info)] - [(node/expr/op/++? astnode) (rebuild-expr-op node/expr/op/++ astnode new-info)] + [(node/expr/op-on-exprs/join? astnode) (rebuild-expr-op node/expr/op-on-exprs/join astnode new-info)] + [(node/expr/op-on-exprs/~? astnode) (rebuild-expr-op node/expr/op-on-exprs/~ astnode new-info)] + [(node/expr/op-on-exprs/+? astnode) (rebuild-expr-op node/expr/op-on-exprs/+ astnode new-info)] + [(node/expr/op-on-exprs/-? astnode) (rebuild-expr-op node/expr/op-on-exprs/- astnode new-info)] + [(node/expr/op-on-exprs/&? astnode) (rebuild-expr-op node/expr/op-on-exprs/& astnode new-info)] + [(node/expr/op-on-exprs/^? astnode) (rebuild-expr-op node/expr/op-on-exprs/^ astnode new-info)] + [(node/expr/op-on-exprs/*? astnode) (rebuild-expr-op node/expr/op-on-exprs/* astnode new-info)] + [(node/expr/op-on-exprs/->? astnode) (rebuild-expr-op node/expr/op-on-exprs/-> astnode new-info)] + [(node/expr/op-on-ints/sing? astnode) (rebuild-expr-op node/expr/op-on-ints/sing astnode new-info)] + [(node/expr/op-on-exprs/prime? astnode) (rebuild-expr-op node/expr/op-on-exprs/prime astnode new-info)] + [(node/expr/op-on-exprs/++? astnode) (rebuild-expr-op node/expr/op-on-exprs/++ astnode new-info)] [(node/expr/ite? astnode) (node/expr/ite new-info (node/expr-arity astnode) diff --git a/forge/lang/lang-specific-checks.rkt b/forge/lang/lang-specific-checks.rkt index 312b74d2..9d9fa612 100644 --- a/forge/lang/lang-specific-checks.rkt +++ b/forge/lang/lang-specific-checks.rkt @@ -22,25 +22,25 @@ ;; (hash-set! forge-checker-hash node/formula/op check-node-formula-op) ;; (hash-set! forge-checker-hash node/formula/multiplicity check-node-formula-multiplicity) ;; (hash-set! forge-checker-hash node/formula/quantified check-node-formula-quantified) -;; (hash-set! forge-checker-hash node/formula/op/always check-node-formula-op-always) -;; (hash-set! forge-checker-hash node/formula/op/eventually check-node-formula-op-eventually) -;; (hash-set! forge-checker-hash node/formula/op/until check-node-formula-op-until) -;; (hash-set! forge-checker-hash node/formula/op/releases check-node-formula-op-releases) -;; (hash-set! forge-checker-hash node/formula/op/next_state check-node-formula-op-next_state) -;; (hash-set! forge-checker-hash node/formula/op/historically check-node-formula-op-historically) -;; (hash-set! forge-checker-hash node/formula/op/once check-node-formula-op-once) -;; (hash-set! forge-checker-hash node/formula/op/prev_state check-node-formula-op-prev_state) -;; (hash-set! forge-checker-hash node/formula/op/since check-node-formula-op-since) -;; (hash-set! forge-checker-hash node/formula/op/triggered check-node-formula-op-triggered) -;; (hash-set! forge-checker-hash node/formula/op/&& check-node-formula-op-&&) -;; (hash-set! forge-checker-hash node/formula/op/|| check-node-formula-op-||) -;; (hash-set! forge-checker-hash node/formula/op/=> check-node-formula-op-=>) -;; (hash-set! forge-checker-hash node/formula/op/in check-node-formula-op-in) -;; (hash-set! forge-checker-hash node/formula/op/= check-node-formula-op-=) -;; (hash-set! forge-checker-hash node/formula/op/! check-node-formula-op-!) -;; (hash-set! forge-checker-hash node/formula/op/int> check-node-formula-op-int>) -;; (hash-set! forge-checker-hash node/formula/op/int< check-node-formula-op-int<) -;; (hash-set! forge-checker-hash node/formula/op/int= check-node-formula-op-int=) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/always check-node-formula-op-always) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/eventually check-node-formula-op-eventually) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/until check-node-formula-op-until) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/releases check-node-formula-op-releases) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/next_state check-node-formula-op-next_state) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/historically check-node-formula-op-historically) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/once check-node-formula-op-once) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/prev_state check-node-formula-op-prev_state) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/since check-node-formula-op-since) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/triggered check-node-formula-op-triggered) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/&& check-node-formula-op-&&) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/|| check-node-formula-op-||) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/=> check-node-formula-op-=>) +;; (hash-set! forge-checker-hash node/formula/op-on-exprs/in check-node-formula-op-in) +;; (hash-set! forge-checker-hash node/formula/op-on-exprs/= check-node-formula-op-=) +;; (hash-set! forge-checker-hash node/formula/op-on-formulas/! check-node-formula-op-!) +;; (hash-set! forge-checker-hash node/formula/op-on-ints/int> check-node-formula-op-int>) +;; (hash-set! forge-checker-hash node/formula/op-on-ints/int< check-node-formula-op-int<) +;; (hash-set! forge-checker-hash node/formula/op-on-ints/int= check-node-formula-op-int=) ;; (hash-set! forge-checker-hash node/expr/relation check-node-expr-relation) ;; (hash-set! forge-checker-hash node/expr/atom check-node-expr-atom) ;; (hash-set! forge-checker-hash node/expr/ite check-node-expr-ite) @@ -48,13 +48,13 @@ ;; (hash-set! forge-checker-hash node/expr/op check-node-expr-op) ;; (hash-set! forge-checker-hash node/expr/quantifier-var check-node-expr-quantifier-var) ;; (hash-set! forge-checker-hash node/expr/comprehension check-node-expr-comprehension) -;; (hash-set! forge-checker-hash node/expr/op/prime check-node-expr-op-prime) -;; (hash-set! forge-checker-hash node/expr/op/+ check-node-expr-op-+) -;; (hash-set! forge-checker-hash node/expr/op/- check-node-expr-op--) -;; (hash-set! forge-checker-hash node/expr/op/& check-node-expr-op-&) -;; (hash-set! forge-checker-hash node/expr/op/-> check-node-expr-op-->) -;; (hash-set! forge-checker-hash node/expr/op/join check-node-expr-op-join) -;; (hash-set! forge-checker-hash node/expr/op/^ check-node-expr-op-^) -;; (hash-set! forge-checker-hash node/expr/op/* check-node-expr-op-*) -;; (hash-set! forge-checker-hash node/expr/op/~ check-node-expr-op-~) -;; (hash-set! forge-checker-hash node/expr/op/sing check-node-expr-op-sing) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/prime check-node-expr-op-prime) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/+ check-node-expr-op-+) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/- check-node-expr-op--) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/& check-node-expr-op-&) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/-> check-node-expr-op-->) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/join check-node-expr-op-join) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/^ check-node-expr-op-^) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/* check-node-expr-op-*) +;; (hash-set! forge-checker-hash node/expr/op-on-exprs/~ check-node-expr-op-~) +;; (hash-set! forge-checker-hash node/expr/op-on-ints/sing check-node-expr-op-sing) diff --git a/forge/last-checker.rkt b/forge/last-checker.rkt index 67e9f904..d8533787 100644 --- a/forge/last-checker.rkt +++ b/forge/last-checker.rkt @@ -120,11 +120,11 @@ (check-helper-args run-or-state 'predicate name args arg-types domain-types) (checkFormula run-or-state expanded quantvars checker-hash)] - [(node/formula/op info args) + [(? node/formula/op? op) (check-and-output formula node/formula/op checker-hash - (checkFormulaOp run-or-state formula quantvars args checker-hash))] + (checkFormulaOp run-or-state formula quantvars (node/formula/op-children op) checker-hash))] [(node/formula/multiplicity info mult expr) (define expr-type (checkExpression run-or-state expr quantvars checker-hash)) @@ -190,94 +190,94 @@ (match formula ; TEMPORAL OPERATORS - [(? node/formula/op/always?) + [(? node/formula/op-on-formulas/always?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/always + node/formula/op-on-formulas/always checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/eventually?) + [(? node/formula/op-on-formulas/eventually?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/eventually + node/formula/op-on-formulas/eventually checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/until?) + [(? node/formula/op-on-formulas/until?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/until + node/formula/op-on-formulas/until checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/releases?) + [(? node/formula/op-on-formulas/releases?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/releases + node/formula/op-on-formulas/releases checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/next_state?) + [(? node/formula/op-on-formulas/next_state?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/next_state + node/formula/op-on-formulas/next_state checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/historically?) + [(? node/formula/op-on-formulas/historically?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/historically + node/formula/op-on-formulas/historically checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/once?) + [(? node/formula/op-on-formulas/once?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/once + node/formula/op-on-formulas/once checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/prev_state?) + [(? node/formula/op-on-formulas/prev_state?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/prev_state + node/formula/op-on-formulas/prev_state checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/since?) + [(? node/formula/op-on-formulas/since?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/since + node/formula/op-on-formulas/since checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] - [(? node/formula/op/triggered?) + [(? node/formula/op-on-formulas/triggered?) (check-temporal-mode run-or-state formula) (check-and-output formula - node/formula/op/triggered + node/formula/op-on-formulas/triggered checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] ; AND - [(? node/formula/op/&&?) + [(? node/formula/op-on-formulas/&&?) (check-and-output formula - node/formula/op/&& + node/formula/op-on-formulas/&& checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] ; OR - [(? node/formula/op/||?) + [(? node/formula/op-on-formulas/||?) (check-and-output formula - node/formula/op/|| + node/formula/op-on-formulas/|| checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] ; IMPLIES - [(? node/formula/op/=>?) + [(? node/formula/op-on-formulas/=>?) (check-and-output formula - node/formula/op/=> + node/formula/op-on-formulas/=> checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] ; IN (atomic fmla) - [(? node/formula/op/in?) + [(? node/formula/op-on-exprs/in?) (define child-types (map (lambda (x) (checkExpression run-or-state x quantvars checker-hash)) args)) (check-and-output formula - node/formula/op/in + node/formula/op-on-exprs/in checker-hash ;(for-each (lambda (x) (expression-type-type (checkExpression run-or-state x quantvars checker-hash))) args) (void) @@ -285,25 +285,25 @@ )] ; EQUALS - [(? node/formula/op/=?) + [(? node/formula/op-on-exprs/=?) (define child-types (map (lambda (x) (checkExpression run-or-state x quantvars checker-hash)) args)) (check-and-output formula - node/formula/op/= + node/formula/op-on-exprs/= checker-hash (void) child-types)] ; NEGATION - [(? node/formula/op/!?) + [(? node/formula/op-on-formulas/!?) (check-and-output formula - node/formula/op/! + node/formula/op-on-formulas/! checker-hash (for-each (lambda (x) (checkFormula run-or-state x quantvars checker-hash)) args))] ; INTEGER >, <, = - [(or (? node/formula/op/int>?) - (? node/formula/op/int?) + (? node/formula/op-on-ints/int (length args) 1) (expression-type-type (checkExpression run-or-state (second args) quantvars checker-hash))) (check-and-output expr - node/expr/op/- + node/expr/op-on-exprs/- checker-hash ; A-B should have only 2 children. B may be empty. (let ([a-type (first child-types)]) @@ -683,10 +683,10 @@ child-types))] ; INTERSECTION - [(? node/expr/op/&?) + [(? node/expr/op-on-exprs/&?) (define sub-results (map (lambda (x) (checkExpression run-or-state x quantvars checker-hash)) args)) (check-and-output expr - node/expr/op/& + node/expr/op-on-exprs/& checker-hash (expression-type (foldl (lambda (x acc) (keep-only (expression-type-type x) acc)) @@ -702,10 +702,10 @@ sub-results)] ; PRODUCT - [(? node/expr/op/->?) + [(? node/expr/op-on-exprs/->?) (define child-types (map (lambda (x) (checkExpression run-or-state x quantvars checker-hash)) args)) (check-and-output expr - node/expr/op/-> + node/expr/op-on-exprs/-> checker-hash (let* ([child-values (map (lambda (x) (expression-type-type x)) child-types)] [all-singleton (andmap (lambda (x) (equal? 'one (expression-type-multiplicity x))) child-types)] @@ -718,10 +718,10 @@ child-types)] ; JOIN - [(? node/expr/op/join?) + [(? node/expr/op-on-exprs/join?) (define child-types (map (lambda (x) (checkExpression run-or-state x quantvars checker-hash)) args)) (check-and-output expr - node/expr/op/join + node/expr/op-on-exprs/join checker-hash (let* ([join-result (check-join (map expression-type-type child-types))] [join-top-level (check-join (map (lambda (x) (list (expression-type-top-level-types x))) child-types))]) @@ -749,10 +749,10 @@ child-types)] ; TRANSITIVE CLOSURE - [(? node/expr/op/^?) + [(? node/expr/op-on-exprs/^?) (define child-types (map (lambda (x) (checkExpression run-or-state x quantvars checker-hash)) args)) (check-and-output expr - node/expr/op/^ + node/expr/op-on-exprs/^ checker-hash (expression-type (let* ([child-values (map (lambda (x) (expression-type-type x)) child-types)]) (check-closure (first child-values))) @@ -762,10 +762,10 @@ (get-top-levels (check-closure (first child-values)) run-or-state))))] ; REFLEXIVE-TRANSITIVE CLOSURE - [(? node/expr/op/*?) + [(? node/expr/op-on-exprs/*?) (define child-types (map (lambda (x) (checkExpression run-or-state x quantvars checker-hash)) args)) (check-and-output expr - node/expr/op/* + node/expr/op-on-exprs/* checker-hash ; includes iden, so might contain any arity-2 tuple (expression-type (let ([prims (primify run-or-state 'univ)]) @@ -777,10 +777,10 @@ child-types)] ; TRANSPOSE: ~(r); r must be arity 2. reverse all types of r - [(? node/expr/op/~?) + [(? node/expr/op-on-exprs/~?) (define child-types (map (lambda (x) (checkExpression run-or-state x quantvars checker-hash)) args)) (check-and-output expr - node/expr/op/~ + node/expr/op-on-exprs/~ checker-hash (expression-type (map reverse (expression-type-type (first child-types))) 'set ; TODO @@ -795,7 +795,7 @@ ; Need to check that the left sub-expression has arity at least 2 ; Need to check the the left and right sub-expressions have the same types ; (which is much easier thanks to the AST checking that they have the same arity) - [(? node/expr/op/++?) + [(? node/expr/op-on-exprs/++?) ;; TODO: check-and-output for this case (let ([left-arity (node/expr-arity (first args))] [left-tuples (expression-type-type (checkExpression run-or-state (first args) quantvars checker-hash))] @@ -821,11 +821,11 @@ (get-top-levels (remove-duplicates (append left-tuples right-tuples)) run-or-state))))] ; SINGLETON (typecast number to 1x1 relation with that number in it) - [(? node/expr/op/sing?) + [(? node/expr/op-on-ints/sing?) ; descend into the integer-expression within and confirm no literals are unsafe (checkInt run-or-state (first (node/expr/op-children expr)) quantvars checker-hash) (check-and-output expr - node/expr/op/sing + node/expr/op-on-ints/sing checker-hash (expression-type (list (list 'Int)) 'one (get-temporal-variance run-or-state expr quantvars args checker-hash) (list 'Int)) diff --git a/forge/pardinus-cli/server/kks.rkt b/forge/pardinus-cli/server/kks.rkt index 1c1ebfe5..c77c0201 100755 --- a/forge/pardinus-cli/server/kks.rkt +++ b/forge/pardinus-cli/server/kks.rkt @@ -11,7 +11,8 @@ (only-in racket thunk ~a)) (provide configure declare-ints print-cmd print-cmd-cont print-eoi cmd declare-univ - declare-rel declare-target read-solution solve v r x tupleset (rename-out [-> product])) + declare-rel declare-target read-solution solve v r x tupleset (rename-out [-> product]) + pardinus-port) (provide assert e f i a define-const) (provide read-evaluation read-ack) (provide clear) diff --git a/forge/run-tests.sh b/forge/run-tests.sh index 05e00baf..31a0b103 100755 --- a/forge/run-tests.sh +++ b/forge/run-tests.sh @@ -18,8 +18,8 @@ testDir=$1 # In "basic" regular expressions, use the backslashed versions of "(", ")", and "|" # Also, apply the pattern deeper than just one directory level (handle error/loc/*.frg) #doNotTestPattern="\(error\|srclocs\)/[^/]*\\.frg" -doNotTestPattern="\(error\|srclocs\)/.*\\.frg" -# ^ these tests get checked by tests/error/main.rkt +doNotTestPattern="\(error\|srclocs\|helpers\)/.*\\.frg" +# ^ error/srclocs: checked by tests/error/main.rkt; helpers: imported by other tests, not run directly smtTestPattern=".*/smtlibtor/.*" diff --git a/forge/send-to-solver.rkt b/forge/send-to-solver.rkt index 40940b5c..07730b72 100644 --- a/forge/send-to-solver.rkt +++ b/forge/send-to-solver.rkt @@ -12,122 +12,8 @@ (require/typed forge/last-checker [checkFormula (-> Run-spec node/formula (Listof Any) (HashTable Any Any) Void)]) -;; TYPES TODO: the contracts are more refined. should we combine the two? - -(require/typed forge/server/modelToXML - [solution-to-XML-string (->* ((U Sat Unsat Unknown) (HashTable Symbol node/expr/relation) Symbol String String Integer String) - (#:tuple-annotations (HashTable Any Any) - #:run-options (HashTable Symbol Any)) - String)]) - -(require/typed syntax/srcloc - [source-location-source (-> Any Path)]) - -(require/typed forge/sigs-structs - [#:struct Sat ( - [instances : Any] ; list of hashes - [stats : Any] ; association list - [metadata : Any])] ; association list) - [#:struct Unsat ( - [core : (U False (Listof Any))] ; list-of-Formula-string-or-formulaID - [stats : Any] ; association list - [kind : Symbol] ; symbol - )] - [#:struct Unknown ( - [stats : Any] ; data on performance, translation, etc. - [metadata : Any] ; any solver-specific data provided about the unknown result - )] - [#:struct Kodkod-current ( - [formula : Integer] - [expression : Integer] - [int : Integer])] - [#:struct (Relation node/expr/relation) ( - [name : Symbol] ; symbol? - [sigs-thunks : (Listof (-> Sig))] - [breaker : (U node/breaking/break False)] - )] - [#:struct Server-ports ( - [stdin : Output-Port] - [stdout : Input-Port] - [stderr : Input-Port] - [shutdown : (-> Void)] - [is-running? : (-> Boolean)])] - [#:struct (Sig node/expr/relation) ( - [name : Symbol] ; symbol? - [one : Boolean] ; boolean? - [lone : Boolean] ; boolean? - [abstract : Boolean] ; boolean? - [extends : (U Sig False)] ; (or/c Sig? #f) - )] - [#:struct Run-spec ( - [state : State] ; Model state at the point of this run - [preds : (Listof node/formula)] ; predicates to run, conjoined - [scope : Scope] ; Numeric scope(s) - [bounds : Bound] ; set-based upper and lower bounds - [target : Any] ;(or/c Target? #f) ; target-oriented model finding - )] - [#:struct Bound ( - ; pbindings: partial (but complete) bindings for a given relation - [pbindings : (HashTable node/expr/relation sbound)] - ; tbindings: total (and complete) bindings for a given relation; also known as an exact bound. - [tbindings : (HashTable node/expr/relation Any)] - ; incomplete bindings for a given relation, indexed by first column - [piecewise : PiecewiseBounds] - ; original AST nodes, for improving errors, indexed by relation - [orig-nodes : (HashTable node/expr/relation (Listof node))] - )] - [#:struct PiecewiseBound ( - [tuples : (Listof Tuple)] ; first element is the indexed atom in the original piecewise bounds - [atoms : (Listof FAtom)] ; which atoms have been bound? (distinguish "given none" from "none given") - [operator : (U '= 'in 'ni)])] ; which operator mode? - [#:struct State ( - [sigs : (HashTable Symbol Sig)] - [sig-order : (Listof Symbol)] - [relations : (HashTable Symbol Relation)] - [relation-order : (Listof Symbol)] - [pred-map : (HashTable Symbol node/formula)] ;(hash/c symbol? (or/c (unconstrained-domain-> node/formula?) node/formula?)) - [fun-map : (HashTable Symbol node)] ; (hash/c symbol? (unconstrained-domain-> node?)) - [const-map : (HashTable Symbol node)] - [inst-map : (HashTable Symbol Any)] ; (hash/c symbol? Inst?) - [options : (HashTable Symbol Any)] - [runmap : (HashTable Symbol Run)])] - [#:struct Run ( - [name : Symbol] - [command : Syntax] - [run-spec : Run-spec] - [result : Any] ;tree:node - [server-ports : Any] ;Server-ports?] - [atoms : (Listof FAtom)] - [kodkod-currents : Any] ; Kodkod-current?] - [kodkod-bounds : (Listof Any)] - [last-sterling-instance : Any ])] ; (box/c (or/c Sat? Unsat? Unknown? false/c)) - [#:struct Range ( - [lower : (U Integer False)] - [upper : (U Integer False)])] - [#:struct Scope ( - [default-scope : (U Range False)] - [bitwidth : (U Integer False)] - [sig-scopes : (HashTable Symbol Range)])] - [get-relations (-> (U Run State Run-spec) (Listof Relation))] - [get-sigs (->* ((U Run State Run-spec)) ((U False node/expr/relation)) (Listof Sig))] - [get-sig (-> (U Run State Run-spec) (U Symbol node/expr/relation) (U Sig False))] - [get-option (case-> - (-> (U Run State Run-spec) 'backend Symbol) - (-> (U Run State Run-spec) 'solver (U String Symbol)) - (-> (U Run State Run-spec) 'java_exe_location (U False Path-String)) - (-> (U Run State Run-spec) 'problem_type Symbol) - (-> (U Run State Run-spec) Symbol Any))] - [get-state (-> (U Run Run-spec State) State)] - [get-bitwidth (-> (U Run-spec Scope) Integer)] - [get-children (-> (U Run State Run-spec) Sig (Listof Sig))] - [DEFAULT-SIG-SCOPE Range] - [get-top-level-sigs (-> (U Run State Run-spec) (Listof Sig))] - ;; TODO TYPES: these are macros, but they has no parameters, so they are being immediately - ;; expanded here to the relations they denote. - [Int Sig] - [succ Relation] - [get-relation-map (-> (U Run Run-spec) (HashTable Symbol node/expr/relation))] -) +;; Since sigs-structs.rkt is now typed, we can import directly +(require forge/sigs-structs) (require forge/breaks) (require forge/lang/bounds) @@ -346,35 +232,50 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Backend=Kodkod; server isn't active/running [(equal? backend 'kodkod) - (raise "Pure Kodkod backend is no longer supported; please use `pardinus` backend instead.")] + (raise-forge-error #:msg "Pure Kodkod backend is no longer supported; please use `pardinus` backend instead." #:context run-command)] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Backend=smtlibtor; server isn't active/running [(equal? backend 'smtlibtor) (printf "Will use SMT-LIB-v2 output. This is experimental functionality. Please ensure that cvc5 is on your path.~n") - (smtlib:start-server 'stepper (get-option run-spec 'problem_type))] + (define problem-type-smt (get-option run-spec 'problem_type)) + (unless (symbol? problem-type-smt) + (raise-forge-error #:msg "problem_type option must be a symbol" #:context run-command)) + (smtlib:start-server 'stepper problem-type-smt)] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Backend=Pardinus; server isn't active/running [(equal? backend 'pardinus) (when (>= (get-verbosity) VERBOSITY_HIGH) (printf "Starting/restarting Pardinus server (prior state=~a)...~n" (unbox server-state))) + (define problem-type-pard (get-option run-spec 'problem_type)) + (unless (symbol? problem-type-pard) + (raise-forge-error #:msg "problem_type option must be a symbol" #:context run-command)) + (define java-loc (get-option run-spec 'java_exe_location)) + (define java-exe : (U False Path-String) + (cond [(not java-loc) #f] + [(path-string? java-loc) java-loc] + [else (raise-forge-error #:msg "java_exe_location must be #f or a path" #:context run-command)])) (pardinus:start-server 'stepper ; always a stepper problem (there is a "next" button) ; 'default, 'temporal, or 'target (tells Pardinus which solver to load, ; and affects parsing so needs to be known at invocation time) - (get-option run-spec 'problem_type) + problem-type-pard ; control version of java used (by path string) - (get-option run-spec 'java_exe_location))] + java-exe)] - [else (raise (format "Invalid backend: ~a" backend))])) + [else (raise-forge-error #:msg (format "Invalid backend: ~a" backend) #:context run-command)])) ; Confirm that if the user is invoking a custom solver, that custom solver exists - (define solver-option (get-option run-spec 'solver)) + (define solver-opt (get-option run-spec 'solver)) + (define solver-option : (U Symbol String) + (cond [(symbol? solver-opt) solver-opt] + [(string? solver-opt) solver-opt] + [else (raise-forge-error #:msg "solver option must be a symbol or string" #:context run-command)])) (define solverspec (cond [(symbol? solver-option) solver-option] [else (string-append "\"" solver-option "\"")])) (unless (symbol? solver-option) (unless (file-exists? solver-option) - (raise-user-error (format "option solver specified custom solver (via string): ~a, but file did not exist." + (raise-user-error (format "option solver specified custom solver (via string): ~a, but file did not exist." solver-option)))) ; Print configure and declare univ size @@ -416,41 +317,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Beginning to send to solver. All type-checking must be complete _before_ this point. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (: maybe-log-wrap (-> (U Sat Unsat Unknown) (U Sat Unsat Unknown))) - (define (maybe-log-wrap soln) - ; Potentially log this solution in XML form. - (when (log-to-file-enabled?) - (define filepath (if (source-location-source run-command) - (path->string (source-location-source run-command)) - "/no-name.frg")) - (define soln-string - (solution-to-XML-string soln - (get-relation-map run-spec) - run-name - (format "~a" (syntax->datum run-command)) - filepath - (get-bitwidth run-spec) - forge-version - #:tuple-annotations (hash) - #:run-options (State-options (Run-spec-state run-spec)))) - (define result (cond [(Sat? soln) "Sat"] [(Unsat? soln) "Unsat"] [(Unknown? soln) "Unknown"])) - (log-forge-event 'debug (string->symbol result) result (remove-newlines soln-string))) - soln) (define get-next-model (cond [(equal? backend 'smtlibtor) (begin (define-values (all-rels core-map) (send-to-cvc5-tor run-name run-spec bitwidth all-atoms solverspec total-bounds bound-lower bound-upper run-constraints stdin stdout stderr)) - (lambda ([mode : String]) (maybe-log-wrap (get-next-cvc5-tor-model is-running? run-name all-rels all-atoms core-map stdin stdout stderr mode - #:run-command run-command))))] + (lambda ([mode : String]) (get-next-cvc5-tor-model is-running? run-name all-rels all-atoms core-map stdin stdout stderr mode + #:run-command run-command)))] [(equal? backend 'pardinus) (begin (define-values (all-rels core-map) (send-to-kodkod run-name run-spec bitwidth all-atoms solverspec total-bounds bound-lower bound-upper run-constraints stdin stdout stderr)) - (lambda ([mode : String]) (maybe-log-wrap (get-next-kodkod-model is-running? run-name all-rels all-atoms core-map stdin stdout stderr mode))))] - [else (raise (format "Invalid backend: ~a" backend))])) + (lambda ([mode : String]) (get-next-kodkod-model is-running? run-name all-rels all-atoms core-map stdin stdout stderr mode)))] + [else (raise-forge-error #:msg (format "Invalid backend: ~a" backend) #:context run-command)])) diff --git a/forge/server/eval-model.rkt b/forge/server/eval-model.rkt index a8f7fcac..2ae73239 100644 --- a/forge/server/eval-model.rkt +++ b/forge/server/eval-model.rkt @@ -94,30 +94,30 @@ (printf "evaluating expr : ~v~n" exp)) (define result (match exp ; Conversion from int values - [(ast:node/expr/op/sing _ _ `(,ix1)) + [(ast:node/expr/op-on-ints/sing _ _ `(,ix1)) (int-atom (eval-int-expr ix1 bind bitwidth))] ; Binary set operations ; Union should support n-ary - [(ast:node/expr/op/+ _ _ (list exp1 exps ...)) + [(ast:node/expr/op-on-exprs/+ _ _ (list exp1 exps ...)) (apply append (map (lambda (exp) (eval-exp exp bind bitwidth safe)) (cons exp1 exps)))] - [(ast:node/expr/op/- _ _ `(,exp-1 ,exp-2)) + [(ast:node/expr/op-on-exprs/- _ _ `(,exp-1 ,exp-2)) (set->list (set-subtract (list->set (eval-exp exp-1 bind bitwidth safe)) (list->set (eval-exp exp-2 bind bitwidth safe))))] - [(ast:node/expr/op/& _ _ `(,exp-1 ,exp-2)) + [(ast:node/expr/op-on-exprs/& _ _ `(,exp-1 ,exp-2)) (set->list (set-intersect (list->set (eval-exp exp-1 bind bitwidth safe)) (list->set (eval-exp exp-2 bind bitwidth safe))))] - [(ast:node/expr/op/-> _ _ `(,exp-1 ,exp-2)) + [(ast:node/expr/op-on-exprs/-> _ _ `(,exp-1 ,exp-2)) (map flatten (foldl append '() (map (lambda (x) (map (lambda (y) `(,x ,y)) (eval-exp exp-2 bind bitwidth safe))) (eval-exp exp-1 bind bitwidth safe))))] - [(ast:node/expr/op/++ _ _ `(,exp-1 ,exp-2)) + [(ast:node/expr/op-on-exprs/++ _ _ `(,exp-1 ,exp-2)) (let* ([right-tuples (eval-exp exp-2 bind bitwidth safe)] [to-override (map (lambda (t) (first t)) right-tuples)] [left-tuples (eval-exp exp-1 bind bitwidth safe)] @@ -125,7 +125,7 @@ (filter (lambda (t) (not (member (first t) right-tuples))) left-tuples)]) (append left-after-removal right-tuples))] - [(ast:node/expr/op/join _ _ `(,exp-1 ,exp-2)) + [(ast:node/expr/op-on-exprs/join _ _ `(,exp-1 ,exp-2)) (foldl append '() (map (lambda (x) @@ -135,11 +135,11 @@ (eval-exp exp-2 bind bitwidth safe)))) (eval-exp exp-1 bind bitwidth safe)))] ; Unary set operations - [(ast:node/expr/op/^ _ _ `(,child-exp)) + [(ast:node/expr/op-on-exprs/^ _ _ `(,child-exp)) (tc (eval-exp child-exp bind bitwidth safe))] - [(ast:node/expr/op/* _ _ `(,child-exp)) + [(ast:node/expr/op-on-exprs/* _ _ `(,child-exp)) (append (build-iden bind) (tc (eval-exp child-exp bind bitwidth safe)))] - [(ast:node/expr/op/~ _ _ `(,child-exp)) + [(ast:node/expr/op-on-exprs/~ _ _ `(,child-exp)) (map reverse (eval-exp child-exp bind bitwidth safe))] ; Set comprehension - TODO (do we need this? Thomas says no) #;[`(set ,var ,lst ,form) (filter (lambda (x) (eval-form form (hash-set bind var (list x)) bitwidth)) @@ -311,30 +311,30 @@ (foldl (λ (x res) (+ res (eval-int-expr ie (hash-set bind var (list x)) bitwidth))) 0 (eval-exp lst bind bitwidth))] - [(ast:node/int/op/sum _ `(,child-exp)) + [(ast:node/int/op-on-exprs/sum _ `(,child-exp)) (wraparound (let ([expr-val (eval-exp child-exp bind bitwidth)]) (foldl (λ (x ret) (if (and (= (length x) 1) (int-atom? (first x))) (+ ret (int-atom-n (first x))) ret)) 0 expr-val)) bitwidth)] - [(ast:node/int/op/card _ `(,child-exp)) + [(ast:node/int/op-on-exprs/card _ `(,child-exp)) (wraparound (length (eval-exp child-exp bind bitwidth)) bitwidth)] - [(ast:node/int/op/add _ `(,ix1 ,ix2)) + [(ast:node/int/op-on-ints/add _ `(,ix1 ,ix2)) (wraparound (+ (eval-int-expr ix1 bind bitwidth) (eval-int-expr ix2 bind bitwidth)) bitwidth)] - [(ast:node/int/op/subtract _ `(,ix1 ,ix2)) + [(ast:node/int/op-on-ints/subtract _ `(,ix1 ,ix2)) (wraparound (- (eval-int-expr ix1 bind bitwidth) (eval-int-expr ix2 bind bitwidth)) bitwidth)] - [(ast:node/int/op/multiply _ `(,ix1 ,ix2)) + [(ast:node/int/op-on-ints/multiply _ `(,ix1 ,ix2)) (wraparound (* (eval-int-expr ix1 bind bitwidth) (eval-int-expr ix2 bind bitwidth)) bitwidth)] - [(ast:node/int/op/divide _ `(,ix1 ,ix2)) + [(ast:node/int/op-on-ints/divide _ `(,ix1 ,ix2)) (wraparound (quotient (eval-int-expr ix1 bind bitwidth) (eval-int-expr ix2 bind bitwidth)) bitwidth)] - [(ast:node/int/op/remainder _ `(,ix1 ,ix2)) + [(ast:node/int/op-on-ints/remainder _ `(,ix1 ,ix2)) (wraparound (remainder (eval-int-expr ix1 bind bitwidth) (eval-int-expr ix2 bind bitwidth)) bitwidth)] - [(ast:node/int/op/abs _ `(,ix1)) + [(ast:node/int/op-on-ints/abs _ `(,ix1)) (let ([ix1-val (eval-int-expr ix1 bind bitwidth)]) (wraparound (racket-abs ix1-val) bitwidth))] - [(ast:node/int/op/sign _ `(,ix1)) + [(ast:node/int/op-on-ints/sign _ `(,ix1)) (let ([ix1-val (eval-int-expr ix1 bind bitwidth)]) (wraparound (cond [(> ix1-val 0) 1] [(= ix1-val 0) 0] diff --git a/forge/sigs-functional.rkt b/forge/sigs-functional.rkt index 785172b5..796383d2 100644 --- a/forge/sigs-functional.rkt +++ b/forge/sigs-functional.rkt @@ -310,23 +310,23 @@ ; no rel, one rel, two rel, lone rel [(node/formula/multiplicity info mult rel) ; is it safe to use the info from above here? - (let ([rel-card (node/int/op/card info (list rel))]) + (let ([rel-card (node/int/op-on-exprs/card info (list rel))]) (do-bind (match mult - ['no (node/formula/op/= info (list rel none))] - ['one (node/formula/op/int= info (list rel-card 1))] - ['two (node/formula/op/int= info (list rel-card 2))] + ['no (node/formula/op-on-exprs/= info (list rel none))] + ['one (node/formula/op-on-ints/int= info (list rel-card 1))] + ['two (node/formula/op-on-ints/int= info (list rel-card 2))] ['lone - (node/formula/op/|| info - (list (node/formula/op/int< info (list rel-card 1)) - (node/formula/op/int= info (list rel-card 1))))]) + (node/formula/op-on-formulas/|| info + (list (node/formula/op-on-ints/int< info (list rel-card 1)) + (node/formula/op-on-ints/int= info (list rel-card 1))))]) scope bound))] ; (= (card rel) n) - [(node/formula/op/int= eq-info (list left right)) + [(node/formula/op-on-ints/int= eq-info (list left right)) (match left - [(node/int/op/card c-info (list left-rel)) + [(node/int/op-on-exprs/card c-info (list left-rel)) (let* ([exact (safe-fast-eval-int-expr right (Bound-tbindings bound) SUFFICIENT-INT-BOUND)] [new-scope (if (equal? (relation-name left-rel) "Int") (update-bitwidth scope exact) @@ -335,26 +335,26 @@ [_ (fail "int=")])] ; (<= (card rel) upper) - [(node/formula/op/|| or-info - (list (node/formula/op/int< lt-info (list lt-left lt-right)) - (node/formula/op/int= eq-info (list eq-left eq-right)))) + [(node/formula/op-on-formulas/|| or-info + (list (node/formula/op-on-ints/int< lt-info (list lt-left lt-right)) + (node/formula/op-on-ints/int= eq-info (list eq-left eq-right)))) (unless (and (equal? lt-left eq-left) (equal? lt-right eq-right)) (fail "int<=")) (match lt-left - [(node/int/op/card c-info (list left-rel)) + [(node/int/op-on-exprs/card c-info (list left-rel)) (let* ([upper-val (safe-fast-eval-int-expr lt-right (Bound-tbindings bound) SUFFICIENT-INT-BOUND)] [new-scope (update-int-bound scope left-rel (Range 0 upper-val))]) (values new-scope bound))] [_ (fail "int<=")])] ; (<= lower (card-rel)) - [(node/formula/op/|| or-info - (list (node/formula/op/int< lt-info (list lt-left lt-right)) - (node/formula/op/int= eq-info (list eq-left eq-right)))) + [(node/formula/op-on-formulas/|| or-info + (list (node/formula/op-on-ints/int< lt-info (list lt-left lt-right)) + (node/formula/op-on-ints/int= eq-info (list eq-left eq-right)))) (unless (and (equal? lt-left eq-left) (equal? lt-right eq-right)) (fail "int>=")) (match lt-right - [(node/int/op/card c-info (list right-rel)) + [(node/int/op-on-exprs/card c-info (list right-rel)) (let* ([lower-val (safe-fast-eval-int-expr lt-left (Bound-tbindings bound) SUFFICIENT-INT-BOUND)] [new-scope (update-int-bound scope right-rel (Range lower-val 0))]) (values new-scope bound))] @@ -368,7 +368,7 @@ [_ (fail "is")])) (match left [(? node/expr/relation?) (break-rel left right)] - [(node/expr/op/~ info arity (list left-rel)) + [(node/expr/op-on-exprs/~ info arity (list left-rel)) (break-rel left-rel (get-co right))] [_ (fail "is")]) (values scope bound)] @@ -378,14 +378,14 @@ ; rel = expr [absolute bound] ; (atom . rel) = expr [partial bound, indexed by atom] - [(node/formula/op/= info (list left right)) - (inst-check bind node/formula/op/=) + [(node/formula/op-on-exprs/= info (list left right)) + (inst-check bind node/formula/op-on-exprs/=) (cond [(node/expr/relation? left) (let ([tups (safe-fast-eval-exp right (Bound-tbindings bound) SUFFICIENT-INT-BOUND)]) (define new-scope scope) (define new-bound (update-bindings bound left tups tups #:node bind)) (values new-scope new-bound))] - [(and (node/expr/op/join? left) + [(and (node/expr/op-on-exprs/join? left) (list? (node/expr/op-children left)) (equal? 2 (length (node/expr/op-children left))) (node/expr/atom? (first (node/expr/op-children left))) @@ -402,8 +402,8 @@ ; expr in rel ; (atom . rel) in/ni expr [partial bound, indexed by atom] ; note: "ni" is handled by desugaring to "in" with reversed arguments. - [(node/formula/op/in info (list left right)) - (inst-check bind node/formula/op/in) + [(node/formula/op-on-exprs/in info (list left right)) + (inst-check bind node/formula/op-on-exprs/in) (cond ; rel in expr [(node/expr/relation? left) @@ -411,7 +411,7 @@ (define new-bound (update-bindings bound left (@set) tups #:node bind)) (values scope new-bound))] ; atom.rel in expr - [(and (node/expr/op/join? left) + [(and (node/expr/op-on-exprs/join? left) (list? (node/expr/op-children left)) (equal? 2 (length (node/expr/op-children left))) (node/expr/atom? (first (node/expr/op-children left))) @@ -427,7 +427,7 @@ (define new-bound (update-bindings bound right tups #:node bind)) (values scope new-bound))] ; atom.rel ni expr - [(and (node/expr/op/join? right) + [(and (node/expr/op-on-exprs/join? right) (list? (node/expr/op-children right)) (equal? 2 (length (node/expr/op-children right))) (node/expr/atom? (first (node/expr/op-children right))) diff --git a/forge/sigs-structs.rkt b/forge/sigs-structs.rkt index 4eb38f0f..07c0858e 100644 --- a/forge/sigs-structs.rkt +++ b/forge/sigs-structs.rkt @@ -1,24 +1,34 @@ -#lang racket/base +#lang typed/racket/base/optional ; Structures and helper functions for running Forge, along with some constants and ; configuration code (e.g., most options). -(require (except-in forge/lang/ast -> set) +(require forge/types/ast-adapter forge/lang/bounds forge/breaks - (only-in forge/shared get-verbosity VERBOSITY_HIGH)) -(require (prefix-in @ (only-in racket hash not +)) - (only-in racket nonnegative-integer? thunk curry) + forge/shared + ; Import AST constructors needed for macros and helpers + (only-in forge/lang/ast + &&/info ||/info =>/info !/info =/info in/info &/info ->/info + int>/info |int Any String)] + [deparse (-> Any String)]) +(require (prefix-in @ (only-in racket hash not +)) + (only-in racket thunk curry) (prefix-in @ racket/set)) -(require racket/contract - racket/match +(require racket/match racket/set racket/list) (require (for-syntax racket/base racket/syntax syntax/srcloc syntax/parse)) -(require (prefix-in tree: forge/utils/lazy-tree)) +(require forge/types/lazy-tree-adapter) (require syntax/srcloc) -(require (prefix-in pardinus: (only-in forge/pardinus-cli/server/kks clear cmd))) -(require (prefix-in cvc5: (only-in forge/solver-specific/smtlib-shared smtlib-display))) +; Typed imports for solver-specific functions +(require/typed forge/pardinus-cli/server/kks + [pardinus-port (Parameterof Output-Port)] + [(clear pardinus-clear) (-> Symbol Void)]) +(require/typed forge/solver-specific/smtlib-shared + [(smtlib-display cvc5-smtlib-display) (-> Output-Port String Void)]) (provide (all-defined-out)) @@ -31,27 +41,26 @@ ; Results from solver ; For a non-temporal result, just take the first element of instances -(struct/contract Sat ( - [instances any/c] ; list of hashes - [stats any/c] ; association list - [metadata any/c] ; association list +(struct Sat ( + [instances : Any] ; list of hashes + [stats : Any] ; association list + [metadata : Any] ; association list ) #:transparent) -(struct/contract Unsat ( - ;[core (or/c #f (listof any/c))]; list-of-Formula-string-or-formulaID)] +(struct Unsat ( ; If there's a core, there are two cases per component: ; (1) a node: a known formula ; (2) a string: an unknown formula (Kodkod couldn't map back this part of the core) - [core (or/c #f (listof (or/c node? string?)))] - [stats any/c] ; association list - [kind symbol?] ; symbol + [core : (U False (Listof (U node String)))] + [stats : Any] ; association list + [kind : Symbol] ; symbol ) #:transparent) ; For SMT backends only, may yield "unknown" -(struct/contract Unknown ( - [stats any/c] ; data on performance, translation, etc. - [metadata any/c] ; any solver-specific data provided about the unknown result - )#:transparent) +(struct Unknown ( + [stats : Any] ; data on performance, translation, etc. + [metadata : Any] ; any solver-specific data provided about the unknown result + ) #:transparent) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Sigs and Relations enrich the "relation" AST node with @@ -60,26 +69,20 @@ ; DO NOT EXTEND THIS STRUCT (struct Sig node/expr/relation ( - name ; symbol? - one ; boolean? - lone ; boolean? - abstract ; boolean? - extends ; (or/c Sig? #f) - ) #:transparent - #:methods gen:custom-write - [(define (write-proc self port mode) - (fprintf port "(Sig ~a)" (Sig-name self)))]) + [name : Symbol] + [one : Boolean] + [lone : Boolean] + [abstract : Boolean] + [extends : (U Sig False)] + ) #:transparent) ; DO NOT EXTEND THIS STRUCT ; TODO: really this should be called "Field", since it represents that at the surface/core level. (struct Relation node/expr/relation ( - name ; symbol? - sigs-thunks ; (listof (-> Sig?)) - breaker ; (or/c node/breaking/break? #f) - ) #:transparent - #:methods gen:custom-write - [(define (write-proc self port mode) - (fprintf port "(Relation ~a)" (Relation-name self)))]) + [name : Symbol] + [sigs-thunks : (Listof (-> Sig))] + [breaker : (U node/breaking/break False)] + ) #:transparent) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -106,18 +109,18 @@ ; the Bounds struct defined here. At some point, we can perhaps condense these into a single IR. ; A Range contains the minimum and maximum scope for a relation. -(struct/contract Range ( - [lower (or/c nonnegative-integer? #f)] - [upper (or/c nonnegative-integer? #f)] +(struct Range ( + [lower : (U Nonnegative-Integer False)] + [upper : (U Nonnegative-Integer False)] ) #:transparent) ; A Scope represents the numeric size limitations on sigs in a run. ; This includes the range of possible bitwidths, and a default range ; to use for sigs whose scope is undefined. -(struct/contract Scope ( - [default-scope (or/c Range? #f)] - [bitwidth (or/c nonnegative-integer? #f)] - [sig-scopes (hash/c symbol? Range?)] +(struct Scope ( + [default-scope : (U Range False)] + [bitwidth : (U Nonnegative-Integer False)] + [sig-scopes : (HashTable Symbol Range)] ) #:transparent) ; A PiecewiseBound represents an atom-indexed, incomplete partial bound. E.g., one might write: @@ -125,110 +128,110 @@ ; `Bob.father in `Charlie + `David ; Note that a piecewise bound is not the same as a "partial" bound; a partial bound is complete, ; in the sense that only one bind declaration is possible for that relation. -(struct/contract PiecewiseBound ( - [tuples (listof any/c)] ; first element is the indexed atom in the original piecewise bounds - [atoms (listof any/c)] ; which atoms have been bound? (distinguish "given none" from "none given") - [operator (one-of/c '= 'in 'ni)] ; which operator mode? +(struct PiecewiseBound ( + [tuples : (Listof Tuple)] ; first element is the indexed atom in the original piecewise bounds + [atoms : (Listof FAtom)] ; which atoms have been bound? (distinguish "given none" from "none given") + [operator : (U '= 'in 'ni)] ; which operator mode? ) #:transparent) -(define PiecewiseBounds/c (hash/c node/expr/relation? PiecewiseBound?)) +(define-type PiecewiseBounds (HashTable node/expr/relation PiecewiseBound)) ; A Bound represents the set-based size limitations on sigs and relations in a run. ; Information from Scope(s) and Bounds(s) will be combined only once a run executes. -(struct/contract Bound ( +(struct Bound ( ; pbindings: partial (but complete) bindings for a given relation - [pbindings (hash/c node/expr/relation? sbound?)] + [pbindings : (HashTable node/expr/relation sbound)] ; tbindings: total (and complete) bindings for a given relation; also known as an exact bound. - [tbindings (hash/c node/expr/relation? any/c)] + [tbindings : (HashTable node/expr/relation Any)] ; incomplete bindings for a given relation, indexed by first column - [piecewise PiecewiseBounds/c] + [piecewise : PiecewiseBounds] ; original AST nodes, for improving errors, indexed by relation - [orig-nodes (hash/c node/expr/relation? (listof node?))] + [orig-nodes : (HashTable node/expr/relation (Listof node))] ) #:transparent) - + ; An Inst function is an accumulator of bounds information. It doesn't (necessarily) ; contain the full information about a run's scope, bounds, etc. Rather, it allows for ; the aggregation of this info across multiple `inst` declarations. -(struct/contract Inst ( - [func (Scope? Bound? . -> . (values Scope? Bound?))] +(struct Inst ( + [func : (-> Scope Bound (Values Scope Bound))] ) #:transparent) ; A Target describes the goal of a target-oriented model-finding run. -(struct/contract Target ( - [target (or/c - ; Original forge/core partial-instance notation - (hash/c symbol? (listof (listof (or/c number? symbol?)))) - ; `inst` notation from #lang forge - Inst?)] +(define-type TargetMode (U 'close_noretarget 'far_noretarget 'close_retarget 'far_retarget 'hamming_cover)) +(struct Target ( + [target : (U (HashTable Symbol (Listof (Listof (U Number Symbol)))) Inst)] ; This is not the same as option target_mode, which provides a global default. ; Rather, this is per target. - [distance (or/c 'close_noretarget 'far_noretarget 'close_retarget 'far_retarget 'hamming_cover)] + [distance : TargetMode] ) #:transparent) -(struct/contract expression-type ( - [type (listof (listof symbol?))] - [multiplicity (or/c 'set 'lone 'one 'no 'func 'pfunc)] - [temporal-variance (or/c boolean? string?)] - [top-level-types (listof (or/c 'Int 'univ))] +(define-type Multiplicity (U 'set 'lone 'one 'no 'func 'pfunc)) +(struct expression-type ( + [type : (Listof (Listof Symbol))] + [multiplicity : Multiplicity] + [temporal-variance : (U Boolean String)] + [top-level-types : (Listof (U 'Int 'univ))] ) #:transparent) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; If adding new option fields, remember to update all of: -; -- DEFAULT_OPTIONS_HASH +; -- DEFAULT_OPTIONS ; -- option-types ; -- option-types-names -; -- state-set-option (in sigs.rkt, only if needed) - -(struct/contract State ( - [sigs (hash/c symbol? Sig?)] - [sig-order (listof symbol?)] - [relations (hash/c symbol? Relation?)] - [relation-order (listof symbol?)] - [pred-map (hash/c symbol? (or/c (unconstrained-domain-> node/formula?) - node/formula?))] - [fun-map (hash/c symbol? (unconstrained-domain-> node?))] - [const-map (hash/c symbol? node?)] - [inst-map (hash/c symbol? Inst?)] - [options (hash/c symbol? any/c)] - [runmap (hash/c symbol? any/c)] +; -- state-set-option (in sigs.rkt or sigs-functional.rkt) +; Options are stored as a hash for flexibility; type safety is provided +; via case-> typing on get-option for known option keys. + +(struct State ( + [sigs : (HashTable Symbol Sig)] + [sig-order : (Listof Symbol)] + [relations : (HashTable Symbol Relation)] + [relation-order : (Listof Symbol)] + [pred-map : (HashTable Symbol Any)] ; (or/c (unconstrained-domain-> node/formula?) node/formula?) + [fun-map : (HashTable Symbol Any)] ; (unconstrained-domain-> node?) + [const-map : (HashTable Symbol node)] + [inst-map : (HashTable Symbol Inst)] + [options : (HashTable Symbol Any)] ; hash-based options with case-> typed accessor + [runmap : (HashTable Symbol Any)] ; TODO: Any -> Run ) #:transparent) -(struct/contract Run-spec ( - [state State?] ; Model state at the point of this run - [preds (listof node/formula?)] ; predicates to run, conjoined - [scope Scope?] ; Numeric scope(s) - [bounds Bound?] ; set-based upper and lower bounds - [target (or/c Target? #f)] ; target-oriented model finding +(struct Run-spec ( + [state : State] ; Model state at the point of this run + [preds : (Listof node/formula)] ; predicates to run, conjoined + [scope : Scope] ; Numeric scope(s) + [bounds : Bound] ; set-based upper and lower bounds + [target : (U Target False)] ; target-oriented model finding ) #:transparent) (struct Server-ports ( - stdin - stdout - stderr - shutdown - is-running?) #:transparent) - -(struct/contract Kodkod-current ( - [[formula #:mutable] nonnegative-integer?] - [[expression #:mutable] nonnegative-integer?] - [[int #:mutable] nonnegative-integer?])) - -(struct/contract Run ( - [name symbol?] - [command syntax?] - [run-spec Run-spec?] + [stdin : Output-Port] + [stdout : Input-Port] + [stderr : Input-Port] + [shutdown : (-> Void)] + [is-running? : (-> Boolean)] + ) #:transparent) + +(struct Kodkod-current ( + [formula : Nonnegative-Integer] + [expression : Nonnegative-Integer] + [int : Nonnegative-Integer]) #:mutable) + +(struct Run ( + [name : Symbol] + [command : Syntax] + [run-spec : Run-spec] ; This is the *start* of the exploration tree. - [result tree:node?] - [server-ports Server-ports?] - [atoms (listof (or/c symbol? number?))] - [kodkod-currents Kodkod-current?] - [kodkod-bounds (listof any/c)] + [result : tree:node] + [server-ports : Server-ports] + [atoms : (Listof FAtom)] + [kodkod-currents : Kodkod-current] + [kodkod-bounds : (Listof Any)] ; This is Sterling's current cursor into the exploration tree. ; It is mutated whenever Sterling asks for a new instance. We keep this ; separately, since there may be multiple cursors into the lazy tree if ; the run is also being processed in a script, but the programmatic cursor - ; and the Sterling cursor should not interfere. - [last-sterling-instance (box/c (or/c Sat? Unsat? Unknown? false/c))] + ; and the Sterling cursor should not interfere. + [last-sterling-instance : (Boxof (U Sat Unsat Unknown False))] ) #:transparent) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -240,51 +243,54 @@ ; an engine_verbosity of 1 logs SEVERE level in the Java engine; ; this will send back info about crashes, but shouldn't spam (and possibly overfill) stderr. -(define DEFAULT-OPTIONS (hash 'eval-language 'surface - 'solver 'SAT4J - 'backend 'pardinus - 'sb 20 - 'coregranularity 0 - 'logtranslation 0 - 'min_tracelength 1 - 'max_tracelength 5 - 'problem_type 'default - 'target_mode 'close_noretarget - 'core_minimization 'fast - 'skolem_depth 0 - 'local_necessity 'off - 'run_sterling 'on - 'sterling_port 0 - 'engine_verbosity 1 - 'test_keep 'first - 'no_overflow 'false - 'java_exe_location #f - )) - - +(define DEFAULT-OPTIONS : (HashTable Symbol Any) + (hash 'eval-language 'surface + 'solver 'SAT4J + 'backend 'pardinus + 'sb 20 + 'coregranularity 0 + 'logtranslation 0 + 'min_tracelength 1 + 'max_tracelength 5 + 'problem_type 'default + 'target_mode 'close_noretarget + 'core_minimization 'fast + 'skolem_depth 0 + 'local_necessity 'off + 'run_sterling 'on + 'sterling_port 0 + 'engine_verbosity 1 + 'test_keep 'first + 'no_overflow 'false + 'java_exe_location #f)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; Constants ;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-syntax Int (lambda (stx) (syntax-case stx () - [val (identifier? (syntax val)) (quasisyntax/loc stx (Sig (nodeinfo #,(build-source-location stx) 'checklangplaceholder #f) 1 "Int" (thunk '("Int")) "univ" #f 'Int #f #f #f #f))]))) -(define-syntax succ (lambda (stx) (syntax-case stx () - [val (identifier? (syntax val)) (quasisyntax/loc stx (Relation (nodeinfo #,(build-source-location stx) 'checklangplaceholder #f) 2 "succ" (thunk '("Int" "Int")) "Int" #f 'succ (list (thunk Int) (thunk Int)) #f))]))) +; Built-in Int sig and succ relation - defined as values with empty nodeinfo +; (source location tracking not needed for built-in constants) +(define Int : Sig (Sig empty-nodeinfo 1 "Int" (thunk '("Int")) "univ" #f 'Int #f #f #f #f)) +(define succ : Relation (Relation empty-nodeinfo 2 "succ" (thunk '("Int" "Int")) "Int" #f 'succ (list (thunk Int) (thunk Int)) #f)) +; These use the typed AST functional interface +(: max (-> node/expr node/int)) (define (max s-int) - (sum (- s-int (join (^ succ) s-int)))) + (sum/func (-/func s-int (join/func (^/func succ) s-int)))) +(: min (-> node/expr node/int)) (define (min s-int) - (sum (- s-int (join s-int (^ succ))))) + (sum/func (-/func s-int (join/func s-int (^/func succ))))) +; Helper for option type checking - returns a predicate that checks membership +(: oneof-pred (-> (Listof Symbol) (-> Any Boolean))) (define (oneof-pred lst) - (lambda (x) (member x lst))) + (lambda ([x : Any]) (if (member x lst) #t #f))) (define VALID_BUILTIN_SOLVERS '(SAT4J Glucose MiniSat MiniSatProver PMaxSAT4J)) (define option-types (hash 'eval-language symbol? - ; allow for custom solver path given as a string - 'solver (lambda (x) (or (member x VALID_BUILTIN_SOLVERS) (string? x))) + ; allow for custom solver path given as a string + 'solver (lambda ([x : Any]) (or (member x VALID_BUILTIN_SOLVERS) (string? x))) 'backend symbol? ; 'verbosity exact-nonnegative-integer? 'sb exact-nonnegative-integer? @@ -305,8 +311,7 @@ 'engine_verbosity exact-nonnegative-integer? 'test_keep (oneof-pred '(first last)) 'no_overflow (oneof-pred '(false true)) - 'java_exe_location (lambda (x) (or (equal? x #f) (string? x))) - )) + 'java_exe_location (lambda (x) (or (equal? x #f) (string? x))))) (define option-types-names (hash 'eval-language "symbol" @@ -327,8 +332,7 @@ 'engine_verbosity "non-negative integer" 'test_keep "one of: first or last" 'no_overflow "one of: false or true" - 'java_exe_location "string" - )) + 'java_exe_location "string")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -339,11 +343,11 @@ (define init-sig-order (list 'Int)) (define init-relations (hash 'succ succ)) (define init-relation-order (list 'succ)) -(define init-pred-map (@hash)) -(define init-fun-map (@hash)) -(define init-const-map (@hash)) -(define init-inst-map (@hash)) -(define init-runmap (@hash)) +(define init-pred-map : (HashTable Symbol Any) (@hash)) +(define init-fun-map : (HashTable Symbol Any) (@hash)) +(define init-const-map : (HashTable Symbol node) (@hash)) +(define init-inst-map : (HashTable Symbol Inst) (@hash)) +(define init-runmap : (HashTable Symbol Any) (@hash)) (define init-options DEFAULT-OPTIONS) (define init-state (State init-sigs init-sig-order init-relations init-relation-order @@ -391,11 +395,14 @@ is-unsat? :: Run -> boolean Returns whether the given run resulted in sat or unsat, respectively. |# +; Type alias for common parameter type +(define-type Run-or-State (U Run Run-spec State)) + ; get-state :: Run-or-State -> State ; If run-or-state is a State, returns it; ; if it is a Run-spec or a Run, then returns its state. -(define/contract (get-state run-or-state) - (-> (or/c Run? State? Run-spec?) State?) +(: get-state (-> Run-or-State State)) +(define (get-state run-or-state) (cond [(Run? run-or-state) (Run-spec-state (Run-run-spec run-or-state))] [(Run-spec? run-or-state) @@ -404,6 +411,7 @@ Returns whether the given run resulted in sat or unsat, respectively. run-or-state])) ; get-run-spec :: Run-or-State -> Run-spec +(: get-run-spec (-> (U Run Run-spec) Run-spec)) (define (get-run-spec run-or-state) (cond [(Run? run-or-state) (Run-run-spec run-or-state)] @@ -412,8 +420,9 @@ Returns whether the given run resulted in sat or unsat, respectively. ; get-sig :: Run-or-State (|| Symbol Sig*) -> Sig ; Returns the Sig of a given name/ast-relation from a run/state. +(: get-sig (-> Run-or-State (U Symbol node/expr/relation) (U Sig False))) (define (get-sig run-or-state sig-name-or-rel) - (define sig-name + (define sig-name : Symbol (cond [(symbol? sig-name-or-rel) sig-name-or-rel] [(Sig? sig-name-or-rel) (Sig-name sig-name-or-rel)] @@ -428,54 +437,61 @@ Returns whether the given run resulted in sat or unsat, respectively. ; get-sigs :: Run-or-State, Relation*? -> List ; If a relation is provided, returns the column sigs; ; otherwise, returns the Sigs of the given relation in a run/state. +(: get-sigs (->* (Run-or-State) ((U False node/expr/relation)) (Listof Sig))) (define (get-sigs run-or-state [relation #f]) (define state (get-state run-or-state)) (if relation - (map (compose (curry get-sig state) (lambda (sig-thunk) (sig-thunk))) - (Relation-sigs-thunks (get-relation state relation))) - (map (curry hash-ref (State-sigs state)) + (map (lambda ([sig-thunk : (-> Sig)]) (assert (get-sig state (sig-thunk)) Sig?)) + (Relation-sigs-thunks (assert (get-relation state relation) Relation?))) + (map (lambda ([s : Symbol]) (hash-ref (State-sigs state) s)) (State-sig-order state)))) ; get-top-level-sigs :: Run-or-State -> List ; Returns the Sigs in a run/state that do not extend another Sig. +(: get-top-level-sigs (-> Run-or-State (Listof Sig))) (define (get-top-level-sigs run-or-state) - (filter (compose @not Sig-extends) (get-sigs run-or-state))) + (filter (lambda ([s : Sig]) (@not (Sig-extends s))) (get-sigs run-or-state))) ; get-fields :: Run-or-State Sig* -> List ; Returns the relations whose first sig is the given sig. +(: get-fields (-> Run-or-State (U Sig node/expr/relation) (Listof Relation))) (define (get-fields run-or-state sig-or-rel) (define state (get-state run-or-state)) (define sig (get-sig state sig-or-rel)) (define relations (get-relations state)) - (for/list ([relation relations] + (for/list ([relation : Relation relations] #:when (equal? (first (get-sigs state relation)) sig)) relation)) ; get-relation :: Run-or-State, (|| Symbol Relation*) -> Relation ; Returns the Relation of a given name/ast-relation from a run/state. +(: get-relation (-> Run-or-State (U Symbol node/expr/relation) (U Relation False))) (define (get-relation run-or-state relation-name-or-rel) - (define name + (define name : Symbol (cond [(symbol? relation-name-or-rel) relation-name-or-rel] [(node/expr/relation? relation-name-or-rel) (string->symbol (relation-name relation-name-or-rel))] [(Relation? relation-name-or-rel) - (Relation-name relation-name-or-rel)])) + (Relation-name relation-name-or-rel)] + [else (error "get-relation: unexpected input")])) (cond [(hash-has-key? (State-relations (get-state run-or-state)) name) (hash-ref (State-relations (get-state run-or-state)) name)] [else #f])) ; get-relations :: Run-or-State -> List ; Returns the Relations in a run/state. +(: get-relations (-> Run-or-State (Listof Relation))) (define (get-relations run-or-state) (define state (get-state run-or-state)) - (map (curry hash-ref (State-relations state) ) + (map (lambda ([s : Symbol]) (hash-ref (State-relations state) s)) (State-relation-order state))) ; get-pred :: Run-or-State, Symbol -> Predicate ; Gets a predicate by name from a given state ; Note that this will return the procedure, not the macro (no stx loc capture) +(: get-pred (-> Run-or-State Symbol Any)) (define (get-pred run-or-state name) (define state (get-state run-or-state)) (hash-ref (State-pred-map state) name)) @@ -483,57 +499,66 @@ Returns whether the given run resulted in sat or unsat, respectively. ; get-fun :: Run-or-State, Symbol -> Function ; Gets a function by name from a given state ; Note that this will return the procedure, not the macro (no stx loc capture) +(: get-fun (-> Run-or-State Symbol Any)) (define (get-fun run-or-state name) (define state (get-state run-or-state)) (hash-ref (State-fun-map state) name)) ; get-const :: Run-or-State, Symbol -> Constant ; Gets a constant by name from a given state +(: get-const (-> Run-or-State Symbol node)) (define (get-const run-or-state name) (define state (get-state run-or-state)) (hash-ref (State-const-map state) name)) ; get-inst :: Run-or-State, Symbol -> Inst ; Gets a inst by name from a given state +(: get-inst (-> Run-or-State Symbol Inst)) (define (get-inst run-or-state name) (define state (get-state run-or-state)) (hash-ref (State-inst-map state) name)) ; get-children :: Run-or-State, Sig* -> List ; Returns the children Sigs of a Sig. +(: get-children (-> Run-or-State (U Symbol Sig node/expr/relation) (Listof Sig))) (define (get-children run-or-state sig-or-rel) (define sigs (get-sigs run-or-state)) (define parent (get-sig run-or-state sig-or-rel)) - (filter (lambda (sig) (equal? (Sig-extends sig) parent)) sigs)) + (filter (lambda ([sig : Sig]) (equal? (Sig-extends sig) parent)) sigs)) ; get-result :: Run -> Stream ; Returns a stream of instances for the given run. +(: get-result (-> Run tree:node)) (define (get-result run) (Run-result run)) ; get-pbinding :: Run-spec, Sig -> (|| List> #f) ; Returns the partial binding in a given Run-spec ; for a given Sig, returning #f if none present. +(: get-sig-pbinding (-> Run-spec Sig Any)) (define (get-sig-pbinding run-spec sig) - (hash-ref (Bound-pbindings (Run-spec-bounds run-spec)) (Sig-name sig) #f)) + (hash-ref (Bound-pbindings (Run-spec-bounds run-spec)) sig #f)) ; get-pbinding :: Run-spec, Sig -> (|| List> #f) ; Returns the total binding in a given Run-spec ; for a given Sig, returning #f if none present. +(: get-sig-tbinding (-> Run-spec Sig Any)) (define (get-sig-tbinding run-spec sig) - (hash-ref (Bound-tbindings (Run-spec-bounds run-spec)) (Sig-name sig) #f)) + (hash-ref (Bound-tbindings (Run-spec-bounds run-spec)) sig #f)) ; get-pbinding :: Run-spec, Relation -> (|| List> #f) ; Returns the partial binding in a given Run-spec ; for a given Relation, returning #f if none present. +(: get-relation-pbinding (-> Run-spec Relation Any)) (define (get-relation-pbinding run-spec rel) - (hash-ref (Bound-pbindings (Run-spec-bounds run-spec)) (Relation-name rel) #f)) + (hash-ref (Bound-pbindings (Run-spec-bounds run-spec)) rel #f)) ; get-tbinding :: Run-spec, Relation -> (|| List> #f) ; Returns the total binding in a given Run-spec ; for a given Relation, returning #f if none present. +(: get-relation-tbinding (-> Run-spec Relation Any)) (define (get-relation-tbinding run-spec rel) - (hash-ref (Bound-tbindings (Run-spec-bounds run-spec)) (Relation-name rel) #f)) + (hash-ref (Bound-tbindings (Run-spec-bounds run-spec)) rel #f)) ; get-scope :: (|| Run-spec Scope), (|| Sig Symbol) -> Range ; Returns the run bound of a Sig, in order: @@ -541,14 +566,15 @@ Returns whether the given run resulted in sat or unsat, respectively. ; - if an explicit bound is given, returns it; ; - if a default bound is given; returns it; ; - return DEFAULT-SIG-BOUND +(: get-scope (-> (U Run-spec Scope) (U Sig Symbol) Range)) (define (get-scope run-spec-or-scope sig-or-name) - (define scope + (define scope : Scope (cond [(Scope? run-spec-or-scope) run-spec-or-scope] [(Run-spec? run-spec-or-scope) (Run-spec-scope run-spec-or-scope)])) - (define sig-name + (define sig-name : Symbol (cond [(Sig? sig-or-name) (Sig-name sig-or-name)] [(symbol? sig-or-name) @@ -556,18 +582,19 @@ Returns whether the given run resulted in sat or unsat, respectively. (if (equal? sig-name 'Int) (let* ([bitwidth (get-bitwidth scope)] - [num-ints (expt 2 bitwidth)]) + [num-ints (assert (expt 2 bitwidth) exact-nonnegative-integer?)]) (Range num-ints num-ints)) (let* ([scope-map (Scope-sig-scopes scope)] - [default-scope (or (Scope-default-scope scope) + [default-scope (or (Scope-default-scope scope) DEFAULT-SIG-SCOPE)]) - (hash-ref scope-map sig-name default-scope)))) + (hash-ref scope-map sig-name (lambda () default-scope))))) ; get-bitwidth :: (|| Run-spec Scope) -> int ; Returns the bitwidth for a run/scope, returning the ; DEFAULT-BITWIDTH if none is provided. +(: get-bitwidth (-> (U Run-spec Scope) Integer)) (define (get-bitwidth run-spec-or-scope) - (define scope + (define scope : Scope (cond [(Run-spec? run-spec-or-scope) (Run-spec-scope run-spec-or-scope)] [(Scope? run-spec-or-scope) @@ -579,11 +606,12 @@ Returns whether the given run resulted in sat or unsat, respectively. ; Returns a list of all sigs, then all relations, as ; their rels in the order they were defined; if given a Run, ; includes all of the additional relations used for individual -; atom access by the evaluator. +; atom access by the evaluator. ; Used for translate to kodkod-cli. +(: get-all-rels (-> (U Run Run-spec) (Listof node/expr/relation))) (define (get-all-rels run-or-spec) (cond [(Run-spec? run-or-spec) - + (let ([run-spec run-or-spec]) (append (get-sigs run-spec) @@ -597,46 +625,56 @@ Returns whether the given run resulted in sat or unsat, respectively. ; get-relation-map :: (|| Run Run-spec) -> Map ; Returns a map from names to AST-Relations. +(: get-relation-map (-> (U Run Run-spec) (HashTable String node/expr/relation))) (define (get-relation-map run-or-spec) - (for/hash ([rel (get-all-rels run-or-spec)]) + (for/hash : (HashTable String node/expr/relation) ([rel (get-all-rels run-or-spec)]) (values (relation-name rel) rel))) ; get-option :: Run-or-state Symbol -> Any +; Returns the value of an option from the state's options hash. +; Note: callers needing specific types should cast the result. +(: get-option (-> Run-or-State Symbol Any)) (define (get-option run-or-state option) (define state (get-state run-or-state)) (hash-ref (State-options state) option #f)) ; is-sat? :: Run -> boolean ; Checks if a given run result is 'sat +(: is-sat? (-> Run Boolean)) (define (is-sat? run) (define first-instance (tree:get-value (Run-result run))) (Sat? first-instance)) ; is-unsat? :: Run -> boolean ; Checks if a given run result is 'unsat +(: is-unsat? (-> Run Boolean)) (define (is-unsat? run) (define first-instance (tree:get-value (Run-result run))) (Unsat? first-instance)) ; is-unknown? :: Run -> boolean ; Checks if a given run result is 'unknown. This kind of result won't be given -; by all kinds of solver backends, but some do produce it. +; by all kinds of solver backends, but some do produce it. +(: is-unknown? (-> Run Boolean)) (define (is-unknown? run) (define first-instance (tree:get-value (Run-result run))) (Unknown? first-instance)) ; get-stdin :: Run -> input-port? +(: get-stdin (-> Run Output-Port)) (define (get-stdin run) (assert-is-running run) (Server-ports-stdin (Run-server-ports run))) ; get-stdout :: Run -> output-port? +(: get-stdout (-> Run Input-Port)) (define (get-stdout run) (assert-is-running run) (Server-ports-stdout (Run-server-ports run))) ; get-stderr :: Run -> output-port? +(: get-stderr (-> Run Input-Port)) (define (get-stderr run) (assert-is-running run) (Server-ports-stderr (Run-server-ports run))) @@ -645,20 +683,24 @@ Returns whether the given run resulted in sat or unsat, respectively. ; Per-run closed status ; Keep track of which runs have been closed via close-run +(: closed-run-names (Boxof (Listof Symbol))) (define closed-run-names (box (list))) ; Allows other modules to let this layer know a run is closed; this box ; is referenced by the instance generator for each run. +(: add-closed-run-name! (-> Symbol Void)) (define (add-closed-run-name! name) (set-box! closed-run-names (cons name (unbox closed-run-names)))) +(: is-run-closed? (-> (U Symbol Run) Boolean)) (define (is-run-closed? name-or-run) - (define (truthify x) (if x #t #f)) + (define (truthify [x : Any]) : Boolean (if x #t #f)) (truthify - (cond [(Run? name-or-run) + (cond [(Run? name-or-run) (member (Run-name name-or-run) (unbox closed-run-names))] [else (member name-or-run (unbox closed-run-names))]))) ; close-run :: Run -> void +(: close-run (-> Run Void)) (define (close-run run) (assert-is-running run) (when (>= (get-verbosity) VERBOSITY_HIGH) @@ -666,15 +708,17 @@ Returns whether the given run resulted in sat or unsat, respectively. ; Cut off this Run's ability to query the solver, since it's about to be closed ; This state is referenced in the instance-generator thunk (add-closed-run-name! (Run-name run)) - + ; Since we're using a single process now, send it instructions to clear this run ; Different backends will be cleared in different ways. (define backend (get-option (Run-run-spec run) 'backend)) (match backend ['pardinus - (pardinus:cmd [(get-stdin run)] (pardinus:clear (Run-name run)))] + (parameterize ([pardinus-port (get-stdin run)]) + (pardinus-clear (Run-name run)) + (flush-output (get-stdin run)))] ['smtlibtor - (cvc5:smtlib-display (get-stdin run) "(reset)")] + (cvc5-smtlib-display (get-stdin run) "(reset)")] [else (raise-forge-error #:msg (format "Unsupported backend when closing solver run: ~a" backend) #:context #f)])) @@ -682,9 +726,11 @@ Returns whether the given run resulted in sat or unsat, respectively. ; is-running :: Run -> Boolean ; This reports whether the _solver server_ is running; ; *NOT* whether an individual run is still open. +(: is-running? (-> Run Boolean)) (define (is-running? run) ((Server-ports-is-running? (Run-server-ports run)))) +(: assert-is-running (-> Run Void)) (define (assert-is-running run) (unless (is-running? run) (raise-user-error "Solver process is not running."))) @@ -737,24 +783,39 @@ Returns whether the given run resulted in sat or unsat, respectively. (=>/info (nodeinfo #,(build-source-location stx) 'checklangNoCheck #f) a b) (=>/info (nodeinfo #,(build-source-location stx) 'checklangNoCheck #f) b a)))])) +; Helper to convert int expressions to node/expr for ite +(: ensure-expr (-> Any nodeinfo node/expr)) +(define (ensure-expr x info) + (cond [(node/expr? x) (assert x node/expr?)] + [(node/int? x) (sing/func (assert x node/int?) #:info info)] + [(exact-integer? x) (sing/func (int/func x #:info info) #:info info)] + [else (raise-forge-error #:msg (format "Expected expression, got ~a" (pretty-type-of x)) + #:context info)])) + ; for ifte, use struct type to decide whether this is a formula (sugar) ; or expression form (which has its own AST node). Avoid exponential ; blowup from chained IFTEs by expanding to a chain of function calls. +; Uses typed AST functions for proper type safety. +(: ifte-disambiguator (-> nodeinfo Any Any Any (U node/formula node/expr))) (define (ifte-disambiguator info a b c) (unless (node/formula? a) (raise-forge-error - #:msg ("If-then-else needed a boolean-valued formula for its first argument; got ~a." (pretty-type-of a)) + #:msg (format "If-then-else needed a boolean-valued formula for its first argument; got ~a." (pretty-type-of a)) #:context a)) + ; Type narrowing: after the check above, a is known to be node/formula + (define a-fmla : node/formula (assert a node/formula?)) (cond - ; It's a formula if-then-else + ; It's a formula if-then-else: (a => b) && (!a => c) = (!a || b) && (a || c) [(and (node/formula? b) (node/formula? c)) - (&&/info info - (=>/info info a b) - (=>/info info (!/info info a) c))] + (define b-fmla : node/formula (assert b node/formula?)) + (define c-fmla : node/formula (assert c node/formula?)) + (&&/func (||/func (!/func a-fmla #:info info) b-fmla #:info info) + (||/func a-fmla c-fmla #:info info) + #:info info)] ; It's an expression if-then-else (note: mixing int-expr and rel-expr is OK) [(and (or (node/expr? b) (node/int? b) (integer? b)) (or (node/expr? c) (node/int? c) (integer? c))) - (ite/info info a b c)] + (ite/func info a-fmla (ensure-expr b info) (ensure-expr c info))] ; It's an error [else (raise-forge-error #:msg (format "If-then-else needed consistent types (either both formulas or both expressions) for its true and false branches, but got (~a) and (~a)." @@ -803,91 +864,93 @@ Returns whether the given run resulted in sat or unsat, respectively. (<:helper a b (nodeinfo #,(build-source-location stx) check-lang #f)))])) ; TODO: this only functions for binary relations +(: <:helper (-> node/expr node/expr nodeinfo node/expr)) (define (<:helper a b info) (domain-check<: a b (nodeinfo-loc info)) - (&/info info - b - (->/info info a univ))) + (&/func b (->/func a univ #:info info) #:info info)) -(define-syntax (:> stx) - (syntax-case stx () - [(_ a b) - (quasisyntax/loc stx +(define-syntax (:> stx) + (syntax-case stx () + [(_ a b) + (quasisyntax/loc stx (:>helper a b (nodeinfo #,(build-source-location stx) 'checklangNoCheck #f)))] - [(_ (#:lang check-lang) a b) - (quasisyntax/loc stx + [(_ (#:lang check-lang) a b) + (quasisyntax/loc stx (:>helper a b (nodeinfo #,(build-source-location stx) check-lang #f)))])) ; TODO: this only functions for binary relations +(: :>helper (-> node/expr node/expr nodeinfo node/expr)) (define (:>helper a b info) (domain-check:> a b (nodeinfo-loc info)) - (&/info info - a - (->/info info univ b))) + (&/func a (->/func univ b #:info info) #:info info)) -(define (domain-check<: a b loc) +(: domain-check<: (-> node/expr node/expr Any Void)) +(define (domain-check<: a b loc) (unless (equal? (node/expr-arity b) - (@+ 1 (node/expr-arity a))) + (@+ 1 (node/expr-arity a))) (raise-forge-error - #:msg (format "<: argument has incorrect arity (~a vs. ~a) in ~a <: ~a" + #:msg (format "<: argument has incorrect arity (~a vs. ~a) in ~a <: ~a" (node/expr-arity a) (node/expr-arity b) (deparse a) (deparse b)) #:context loc))) -(define (domain-check:> a b loc) +(: domain-check:> (-> node/expr node/expr Any Void)) +(define (domain-check:> a b loc) (unless (equal? (node/expr-arity a) - (@+ 1 (node/expr-arity b))) + (@+ 1 (node/expr-arity b))) (raise-forge-error - #:msg (format ":> argument has incorrect arity (~a vs. ~a) in ~a :> ~a" + #:msg (format ":> argument has incorrect arity (~a vs. ~a) in ~a :> ~a" (node/expr-arity a) (node/expr-arity b) (deparse a) (deparse b)) #:context loc))) -; A Field relation is functional if it has a functional breaker assigned. +; A Field relation is functional if it has a functional breaker assigned. +(: Relation-is-functional? (-> Any Boolean)) (define (Relation-is-functional? r) - (or (Relation-is? r '(pfunc func)))) + (if (Relation-is? r '(pfunc func)) #t #f)) +(: Relation-is? (-> Any (Listof Symbol) Boolean)) (define (Relation-is? r sym-list) (and (Relation? r) (node/breaking/break? (Relation-breaker r)) - (member (node/breaking/break-break (Relation-breaker r)) sym-list))) + (if (member (node/breaking/break-break (Relation-breaker r)) sym-list) #t #f))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; "Primification"-related utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Do not check integer literals with respect to bitwidth for these backends -(define UNBOUNDED_INT_BACKENDS '(smtlibtor)) +(define UNBOUNDED_INT_BACKENDS : (Listof Symbol) '(smtlibtor)) ; Turn signame into list of all primsigs it contains ; Note we use Alloy-style "_remainder" names here; these aren't necessarily embodied in Forge -(define/contract (primify run-or-state raw-signame) - (-> (or/c Run? State? Run-spec?) (or/c symbol? string?) (listof symbol?)) - (let ([signame (cond [(string? raw-signame) (string->symbol raw-signame)] - [(Sig? raw-signame) (Sig-name raw-signame)] - [else raw-signame])]) - (cond [(equal? 'Int signame) +(: primify (-> (U Run Run-spec State) (U Symbol String) (Listof Symbol))) +(define (primify run-or-state raw-signame) + (let ([signame : Symbol (cond [(string? raw-signame) (string->symbol raw-signame)] + [(Sig? raw-signame) (Sig-name raw-signame)] + [else raw-signame])]) + (cond [(equal? 'Int signame) '(Int)] [(equal? 'univ signame) - (if (member (get-option (get-run-spec run-or-state) 'backend) UNBOUNDED_INT_BACKENDS) - (remove-duplicates (flatten (map (lambda (n) (primify run-or-state n)) (remove 'Int (map Sig-name (get-sigs run-or-state)))))) - (remove-duplicates (flatten (map (lambda (n) (primify run-or-state n)) (cons 'Int (map Sig-name (get-sigs run-or-state)))))))] + (if (member (get-option (get-run-spec (assert run-or-state (lambda (x) (or (Run? x) (Run-spec? x))))) 'backend) UNBOUNDED_INT_BACKENDS) + (remove-duplicates (append* (map (lambda ([n : Symbol]) (primify run-or-state n)) (remove 'Int (map Sig-name (get-sigs run-or-state)))))) + (remove-duplicates (append* (map (lambda ([n : Symbol]) (primify run-or-state n)) (cons 'Int (map Sig-name (get-sigs run-or-state)))))))] [else (define the-sig (get-sig run-or-state signame)) - - (define all-primitive-descendants + + (define all-primitive-descendants : (Listof Symbol) (remove-duplicates - (flatten - (map (lambda (n) (primify run-or-state n)) + (append* + (map (lambda ([n : Sig]) (primify run-or-state (Sig-name n))) (get-children run-or-state signame))))) (cond - [(Sig-abstract the-sig) - + [(and the-sig (Sig-abstract the-sig)) + (if (empty? (get-children run-or-state signame)) (raise-forge-error #:msg (format "The abstract sig ~a is not extended by any children" (symbol->string signame)) #:context the-sig) all-primitive-descendants)] - [else (cons - (string->symbol (string-append (symbol->string signame) + [else (cons + (string->symbol (string-append (symbol->string signame) (if (empty? (get-children run-or-state signame)) "" "_remainder"))) @@ -900,8 +963,8 @@ Returns whether the given run resulted in sat or unsat, respectively. ; We assume that the list of sigs given is already primified; i.e., there are no non-primitive ; sig names (X_remainder counts as a primitive sig) being passed to this function. ; This version works only for lists of primified sig symbols, e.g. (A B C D_remainder) -(define/contract (deprimify run-or-state primsigs) - (-> (or/c Run? State? Run-spec?) (non-empty-listof symbol?) (non-empty-listof symbol?)) +(: deprimify (-> Run-or-State (Listof Symbol) (Listof Symbol))) +(define (deprimify run-or-state primsigs) (let ([all-sigs (map Sig-name (get-sigs run-or-state))]) (cond ; In case this is a singleton list, we can't improve anything @@ -909,13 +972,13 @@ Returns whether the given run resulted in sat or unsat, respectively. primsigs] ; In case all sigs are represented here, it's univ [(equal? (list->set primsigs) - (list->set (remove-duplicates (flatten (map (lambda (n) (primify run-or-state n)) (cons 'Int all-sigs)))))) + (list->set (remove-duplicates (flatten (map (lambda ([n : Symbol]) (primify run-or-state n)) (cons 'Int all-sigs)))))) '(univ)] ; Otherwise, compress as much as possible ; Use primify to handle the X_remainder cases. [else (define top-level (get-top-level-sigs run-or-state)) - (define pseudo-fold-lambda (lambda (sig acc) - (if (or (subset? (primify run-or-state (Sig-name sig)) (flatten primsigs)) + (define pseudo-fold-lambda (lambda ([sig : Sig] [acc : (Listof Symbol)]) + (if (or (subset? (list->set (primify run-or-state (Sig-name sig))) (list->set (flatten primsigs))) (equal? (list (car (primify run-or-state (Sig-name sig)))) (flatten primsigs))) ; the above check is added for when you have the parent sig, but are expecting the child (values (append acc (list (Sig-name sig))) #t) ; replace cons with values @@ -926,8 +989,9 @@ Returns whether the given run resulted in sat or unsat, respectively. ; Runs a DFS over the sigs tree, starting from sigs in . ; On each visited sig, is called to obtain a new accumulated value ; and whether the search should continue to that sig's children. +(: dfs-sigs (All (A) (-> Run-or-State (-> Sig A (Values A Boolean)) (Listof Sig) A A))) (define (dfs-sigs run-or-state func sigs init-acc) - (define (dfs-sigs-helper todo acc) + (define (dfs-sigs-helper [todo : (Listof Sig)] [acc : A]) : A (cond [(equal? (length todo) 0) acc] [else (define next (first todo)) (define-values (new-acc stop) @@ -940,6 +1004,7 @@ Returns whether the given run resulted in sat or unsat, respectively. (dfs-sigs-helper sigs init-acc)) ; maybe take in initial accumulator as well for more flexibility ; Be robust to callers who pass quantifier-vars as either (var . domain) or as '(var domain). +(: second/safe (-> (U (Listof Any) (Pairof Any Any)) Any)) (define (second/safe list-or-pair) (cond [(list? list-or-pair) (second list-or-pair)] [else (cdr list-or-pair)])) diff --git a/forge/sigs.rkt b/forge/sigs.rkt index 1637d821..20c124ac 100644 --- a/forge/sigs.rkt +++ b/forge/sigs.rkt @@ -107,7 +107,8 @@ (provide (prefix-out forge: relation-name)) (provide (prefix-out forge: curr-state) - (prefix-out forge: update-state!)) + (prefix-out forge: update-state!) + (prefix-out forge: current-options)) (provide (struct-out Sat) (struct-out Unsat)) @@ -196,7 +197,10 @@ [(or (equal? option 'verbosity) (equal? option 'verbose)) (set-verbosity value)] [else - (update-state! (state-set-option curr-state option value #:original-path original-path))])) + (define new-state (state-set-option curr-state option value #:original-path original-path)) + (update-state! new-state) + ; Also update the current-options parameter so tests can snapshot it + (current-options (State-options new-state))])) @@ -209,6 +213,10 @@ (define (update-state! new-state) (set! curr-state new-state)) +; Parameter for snapshotting options at test definition time. +; Tests capture this value when defined, then parameterize with it when executed. +(define current-options (make-parameter (State-options init-state))) + ; check-temporal-for-var :: Boolean String -> void ; raises an error if is-var is true and the problem_type option is 'temporal ; uses the given name in the error message @@ -497,7 +505,7 @@ ; maintain the invariant that helper functions are always rel-expression valued (define safe-result (cond [(node/int? result-once) - (node/expr/op/sing (node-info result-once) 1 (list result-once))] + (node/expr/op-on-ints/sing (node-info result-once) 1 (list result-once))] [else result-once])) ; - "fun spacer" added to record use of function along with original argument declarations etc. (node/expr/fun-spacer @@ -599,9 +607,9 @@ (~? 'target-distance 'close_noretarget)) #f)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; TODO: this _really_ ought to be a box. If the above calls update-state!, - ;; this is no longer aliased. - (define run-state curr-state) + ;; Use current-options parameter so tests can snapshot options at definition time. + ;; The state gets current sigs/preds/etc, but options from the parameter. + (define run-state (struct-copy State curr-state [options (current-options)])) (define run-command #'#,command) (define name (run-from-state run-state @@ -630,12 +638,29 @@ [(test name args ... #:expect expected) (syntax/loc stx (test name args ... #:expect expected #:expect-details #f))] [(test name args ... #:expect expected #:expect-details expected-details) - (add-to-execs - (with-syntax ([loc (build-source-location stx)] - [run-stx (syntax/loc stx (run name args ...))] - [check-stx (syntax/loc stx (check name args ...))]) - (quasisyntax/loc stx - (cond + ; Snapshot options at definition time, then parameterize at execution time + (with-syntax ([snapshot-id (generate-temporary 'options-snapshot)] + [loc (build-source-location stx)] + [run-stx (syntax/loc stx (run name args ...))] + [check-stx (syntax/loc stx (check name args ...))]) + (if (equal? (syntax-local-context) 'module) + ; At module level: capture options now, defer test with parameterize + (quasisyntax/loc stx + (begin + (define snapshot-id (current-options)) + (module+ execs + (parameterize ([current-options snapshot-id]) + #,(quasisyntax/loc stx (test-body name loc run-stx check-stx expected expected-details)))))) + ; Not at module level: just run directly + (quasisyntax/loc stx + (test-body name loc run-stx check-stx expected expected-details))))])) + +; Helper macro for test body - factored out to avoid duplication +(define-syntax (test-body stx) + (syntax-case stx () + [(test-body name loc run-stx check-stx expected expected-details) + (quasisyntax/loc stx + (cond ; TODO: isn't this known at expansion time? We'll have the value of . [(equal? 'expected 'forge_error) ; Expecting an error. If we receive one, do nothing. @@ -724,55 +749,97 @@ (raise-forge-error #:msg "The syntax 'is theorem' is deprecated and will be re-enabled in a future version for complete solver backends only; use 'is checked' instead." #:context loc)] - [else (raise-forge-error + [else (raise-forge-error #:msg (format "Illegal argument to test. Received ~a, expected sat, unsat, checked, or forge_error." 'expected) - #:context loc)]))))])) + #:context loc)]))])) -(define-syntax (example stx) +(define-syntax (example stx) (syntax-parse stx [(_ name:id pred bounds ...) - (add-to-execs - (with-syntax* ([double-check-name (format-id #'name "double-check_~a_~a" #'name (gensym))] - [run-stx (syntax/loc stx (run name #:preds [pred] #:bounds [bounds ...]))] - [double-check-run-stx (syntax/loc stx (run double-check-name #:preds [] #:bounds [bounds ...]))]) - (quasisyntax/loc stx (begin - (when (eq? 'temporal (get-option curr-state 'problem_type)) - (raise-forge-error - #:msg (format "example ~a: Can't have examples when problem_type option is temporal" 'name) - #:context #,(build-source-location stx))) - run-stx - (define first-instance (tree:get-value (Run-result name))) - (cond - [(Unsat? first-instance) - ; Run a second check to see if {} would have also failed, meaning this example - ; violates the sig/field declarations. - double-check-run-stx - (define double-check-instance (tree:get-value (Run-result double-check-name))) - (close-run double-check-name) ;; always close the double-check run immediately - - (cond - [(Sat? double-check-instance) - (report-test-failure #:name 'name #:msg (format "Invalid example '~a'; the instance specified does not satisfy the given predicate." 'name) - #:context #,(build-source-location stx) - #:instance first-instance - #:run name)] - [(Unsat? double-check-instance) - (report-test-failure #:name 'name #:msg (format (string-append "Invalid example '~a'; the instance specified is impossible. " - "This means that the specified bounds conflict with each other " - "or with the sig/field definitions.") - 'name) - #:context #,(build-source-location stx) - #:instance first-instance - #:run name)] - [(Unknown? double-check-instance) - (report-test-failure #:name 'name #:msg (format "Invalid example '~a'. Unable to determine if the instance given satisfies the sig/field definitions or specified bounds." 'name) - #:context #,(build-source-location stx) - #:instance first-instance - #:run name)])] - [else - (report-passing-test #:name 'name) - (close-run name)])))))])) + ; Snapshot options at definition time, then parameterize at execution time + (with-syntax* ([snapshot-id (generate-temporary 'options-snapshot)] + [double-check-name (format-id #'name "double-check_~a_~a" #'name (gensym))] + [run-stx (syntax/loc stx (run name #:preds [pred] #:bounds [bounds ...]))] + [double-check-run-stx (syntax/loc stx (run double-check-name #:preds [] #:bounds [bounds ...]))]) + (if (equal? (syntax-local-context) 'module) + (quasisyntax/loc stx + (begin + (define snapshot-id (current-options)) + (module+ execs + (parameterize ([current-options snapshot-id]) + (when (eq? 'temporal (get-option curr-state 'problem_type)) + (raise-forge-error + #:msg (format "example ~a: Can't have examples when problem_type option is temporal" 'name) + #:context #,(build-source-location stx))) + run-stx + (define first-instance (tree:get-value (Run-result name))) + (cond + [(Unsat? first-instance) + ; Run a second check to see if {} would have also failed, meaning this example + ; violates the sig/field declarations. + double-check-run-stx + (define double-check-instance (tree:get-value (Run-result double-check-name))) + (close-run double-check-name) ;; always close the double-check run immediately + + (cond + [(Sat? double-check-instance) + (report-test-failure #:name 'name #:msg (format "Invalid example '~a'; the instance specified does not satisfy the given predicate." 'name) + #:context #,(build-source-location stx) + #:instance first-instance + #:run name)] + [(Unsat? double-check-instance) + (report-test-failure #:name 'name #:msg (format (string-append "Invalid example '~a'; the instance specified is impossible. " + "This means that the specified bounds conflict with each other " + "or with the sig/field definitions.") + 'name) + #:context #,(build-source-location stx) + #:instance first-instance + #:run name)] + [(Unknown? double-check-instance) + (report-test-failure #:name 'name #:msg (format "Invalid example '~a'. Unable to determine if the instance given satisfies the sig/field definitions or specified bounds." 'name) + #:context #,(build-source-location stx) + #:instance first-instance + #:run name)])] + [else + (report-passing-test #:name 'name) + (close-run name)]))))) + ; Not at module level: just run directly (original behavior) + (quasisyntax/loc stx + (begin + (when (eq? 'temporal (get-option curr-state 'problem_type)) + (raise-forge-error + #:msg (format "example ~a: Can't have examples when problem_type option is temporal" 'name) + #:context #,(build-source-location stx))) + run-stx + (define first-instance (tree:get-value (Run-result name))) + (cond + [(Unsat? first-instance) + double-check-run-stx + (define double-check-instance (tree:get-value (Run-result double-check-name))) + (close-run double-check-name) + (cond + [(Sat? double-check-instance) + (report-test-failure #:name 'name #:msg (format "Invalid example '~a'; the instance specified does not satisfy the given predicate." 'name) + #:context #,(build-source-location stx) + #:instance first-instance + #:run name)] + [(Unsat? double-check-instance) + (report-test-failure #:name 'name #:msg (format (string-append "Invalid example '~a'; the instance specified is impossible. " + "This means that the specified bounds conflict with each other " + "or with the sig/field definitions.") + 'name) + #:context #,(build-source-location stx) + #:instance first-instance + #:run name)] + [(Unknown? double-check-instance) + (report-test-failure #:name 'name #:msg (format "Invalid example '~a'. Unable to determine if the instance given satisfies the sig/field definitions or specified bounds." 'name) + #:context #,(build-source-location stx) + #:instance first-instance + #:run name)])] + [else + (report-passing-test #:name 'name) + (close-run name)])))))])) ; Checks that some predicates are always true. (define-syntax (check stx) diff --git a/forge/solver-specific/to-smtlib-tor.rkt b/forge/solver-specific/to-smtlib-tor.rkt index ab69dd41..2ff862aa 100644 --- a/forge/solver-specific/to-smtlib-tor.rkt +++ b/forge/solver-specific/to-smtlib-tor.rkt @@ -52,8 +52,8 @@ (if type 'true 'false)] [(node/fmla/pred-spacer info name args expanded) (convert-formula run-or-state expanded relations atom-names quantvars quantvar-types bounds)] - [(node/formula/op info args) - (convert-formula-op run-or-state formula relations atom-names quantvars quantvar-types args bounds)] + [(? node/formula/op? op) + (convert-formula-op run-or-state formula relations atom-names quantvars quantvar-types (node/formula/op-children op) bounds)] [(node/formula/multiplicity info mult expr) (let ([processed-expr (convert-expr run-or-state expr relations atom-names quantvars quantvar-types bounds)]) (match mult @@ -179,60 +179,60 @@ (when (@>= (get-verbosity) VERBOSITY_HIGH) (printf "to-smtlib-tor: convert-formula-op: ~a~n" formula)) (match formula - [(node/formula/op/&& info children) + [(node/formula/op-on-formulas/&& info children) `(and ,@(process-children-formula run-or-state children relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/|| info children) + [(node/formula/op-on-formulas/|| info children) `(or ,@(process-children-formula run-or-state children relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/=> info children) + [(node/formula/op-on-formulas/=> info children) `(=> ,@(process-children-formula run-or-state children relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/always info children) + [(node/formula/op-on-formulas/always info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/eventually info children) + [(node/formula/op-on-formulas/eventually info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/next_state info children) + [(node/formula/op-on-formulas/next_state info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/releases info children) + [(node/formula/op-on-formulas/releases info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/until info children) + [(node/formula/op-on-formulas/until info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/historically info children) + [(node/formula/op-on-formulas/historically info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/once info children) + [(node/formula/op-on-formulas/once info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/prev_state info children) + [(node/formula/op-on-formulas/prev_state info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/since info children) + [(node/formula/op-on-formulas/since info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/triggered info children) + [(node/formula/op-on-formulas/triggered info children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context formula)] - [(node/formula/op/in info children) + [(node/formula/op-on-exprs/in info children) `(set.subset ,@(process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/= info children) - (if (for/or ([child children]) (if (node/int/op/card? child) #t #f)) + [(node/formula/op-on-exprs/= info children) + (if (for/or ([child children]) (if (node/int/op-on-exprs/card? child) #t #f)) (form-cardinality run-or-state formula relations atom-names quantvars quantvar-types children "=" bounds) `(= ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds)))] - [(node/formula/op/! info children) + [(node/formula/op-on-formulas/! info children) `(not ,@(process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/int> info children) - (if (for/or ([child children]) (if (node/int/op/card? child) #t #f)) + [(node/formula/op-on-ints/int> info children) + (if (for/or ([child children]) (if (node/int/op-on-exprs/card? child) #t #f)) (form-cardinality run-or-state formula relations atom-names quantvars quantvar-types children ">" bounds) `(> ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds #t)))] - [(node/formula/op/int< info children) - (if (for/or ([child children]) (if (node/int/op/card? child) #t #f)) + [(node/formula/op-on-ints/int< info children) + (if (for/or ([child children]) (if (node/int/op-on-exprs/card? child) #t #f)) (form-cardinality run-or-state formula relations atom-names quantvars quantvar-types children "<" bounds) `(< ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds #t)))] - [(node/formula/op/int= info children) - (if (for/or ([child children]) (if (node/int/op/card? child) #t #f)) + [(node/formula/op-on-ints/int= info children) + (if (for/or ([child children]) (if (node/int/op-on-exprs/card? child) #t #f)) (form-cardinality run-or-state formula relations atom-names quantvars quantvar-types children "=" bounds) `(= ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds #t)))])) @@ -346,8 +346,8 @@ (define (form-cardinality run-or-state formula relations atom-names quantvars quantvar-types children op bounds) ; Ensure that the child that is not a cardinality operator is an int constant. - (define int-expr (for/or ([child children] #:when (not (node/int/op/card? child))) child)) - (define card-expr (for/or ([child children] #:when (node/int/op/card? child)) (car (node/int/op-children child)))) + (define int-expr (for/or ([child children] #:when (not (node/int/op-on-exprs/card? child))) child)) + (define card-expr (for/or ([child children] #:when (node/int/op-on-exprs/card? child)) (car (node/int/op-children child)))) (define card-expr-type (expression-type-top-level-types (checkExpression run-or-state card-expr quantvar-types (make-hash)))) (define processed-card-expr (convert-expr run-or-state card-expr relations atom-names quantvars quantvar-types bounds)) (define value 0) @@ -468,8 +468,8 @@ [(node/expr/constant info arity type) (raise-forge-error #:msg (format "Unexpected node reached by to-smtlib-tor: node/expr/constant with type " type) #:context info)] - [(node/expr/op info arity args) - (convert-expr-op run-or-state expr relations atom-names quantvars quantvar-types args bounds)] + [(? node/expr/op? op) + (convert-expr-op run-or-state expr relations atom-names quantvars quantvar-types (node/expr/op-children op) bounds)] [(node/expr/quantifier-var info arity sym name) ; If this is an integer-unwrapping quantifier variable, it will be declared of sort Int, ; and should not be wrapped to make it a singleton-set-of-tuples. Otherwise, it must be @@ -489,32 +489,32 @@ (when (@>= (get-verbosity) VERBOSITY_HIGH) (printf "to-smtlib-tor: convert-expr-op: ~a~n" expr)) (match expr - [(node/expr/op/+ info arity children) + [(node/expr/op-on-exprs/+ info arity children) `(set.union ,@(process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/- info arity children) + [(node/expr/op-on-exprs/- info arity children) `(set.minus ,@(process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/& info arity children) + [(node/expr/op-on-exprs/& info arity children) `(set.inter ,@(process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/-> info arity children) + [(node/expr/op-on-exprs/-> info arity children) ; rel.product in CVC5 is _binary_, not nary, so need to chain this. (define child-strings (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds)) (define rest-string (for/fold ([acc (second child-strings)]) ([str (rest (rest child-strings))]) `(rel.product ,acc ,str))) `(rel.product ,(first child-strings) ,rest-string)] - [(node/expr/op/prime info arity children) + [(node/expr/op-on-exprs/prime info arity children) (raise-forge-error #:msg "Temporal operators are unsupported by SMT backend." #:context expr)] - [(node/expr/op/join info arity children) + [(node/expr/op-on-exprs/join info arity children) `(rel.join ,@(process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/^ info arity children) + [(node/expr/op-on-exprs/^ info arity children) `(rel.tclosure ,@(process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/* info arity children) + [(node/expr/op-on-exprs/* info arity children) `(set.union (rel.tclosure ,@(process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds)) (rel.iden (as set.universe (Relation Atom))))] - [(node/expr/op/~ info arity children) + [(node/expr/op-on-exprs/~ info arity children) `(rel.transpose ,@(process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/++ info arity children) + [(node/expr/op-on-exprs/++ info arity children) ; The relational-override expression R ++ (key -> B) is equivalent to: ; R - (key -> univ) + (key -> B) ; Note that `B` may be of arity > 1, it must be of arity 1 less than R. @@ -527,7 +527,7 @@ (define converted-RHS (convert-expr run-or-state RHS relations atom-names quantvars quantvar-types bounds)) `(set.union (set.minus ,converted-R ,converted-to-remove) ,converted-RHS)] - [(node/expr/op/sing info arity children) + [(node/expr/op-on-ints/sing info arity children) (let ([processed-form (process-children-int run-or-state children relations atom-names quantvars quantvar-types bounds #t)]) (form-int-op-comp run-or-state expr relations atom-names quantvars quantvar-types processed-form bounds))])) @@ -551,8 +551,8 @@ (define new-constraint `(assert (= (IntAtom-to-Int ,const-name) ,value))) (set-box! new-top-level-strings (append (list new-decl new-constraint) (get-new-top-level-strings))) (string->symbol (format "~a" const-name))])] - [(node/int/op info args) - (convert-int-op run-or-state expr relations atom-names quantvars quantvar-types args bounds)] + [(? node/int/op? op) + (convert-int-op run-or-state expr relations atom-names quantvars quantvar-types (node/int/op-children op) bounds)] [(node/int/sum-quant info decls int-expr) (define new-vs-decls (for/fold ([vs-decls (list quantvars '())]) @@ -574,15 +574,15 @@ (when (@>= (get-verbosity) VERBOSITY_HIGH) (printf "to-smtlib-tor: convert-int-op: ~a~n" expr)) (match expr - [(node/int/op/add info children) + [(node/int/op-on-ints/add info children) `(+ ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds #t))] - [(node/int/op/subtract info children) + [(node/int/op-on-ints/subtract info children) `(- ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds #t))] - [(node/int/op/multiply info children) + [(node/int/op-on-ints/multiply info children) `(* ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds #t))] - [(node/int/op/divide info children) + [(node/int/op-on-ints/divide info children) `(div ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds #t))] - [(node/int/op/sum info children) + [(node/int/op-on-exprs/sum info children) ; Since we are following the CRS/cvc4 work for integer-handling, the child must always be a singleton. ; This holds whether or not the "sum" was added automatically, but manual/auto affects the nature of the error. ;(printf "qv-types: ~a; qvs: ~a~n" quantvar-types quantvars) @@ -595,15 +595,15 @@ (raise-forge-error #:msg "SMT backend requires that this expression evaluates to a singleton integer, but could not infer this." #:context expr) (raise-forge-error #:msg "SMT backend does not currently support `sum` over multiple integer values, but could not infer safety." #:context expr))) `(IntAtom-to-Int (reconcile-int_atom ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds)))] - [(node/int/op/card info children) + [(node/int/op-on-exprs/card info children) (let ([processed-form (string->symbol (string-join (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds) " "))]) processed-form)] - [(node/int/op/remainder info children) + [(node/int/op-on-ints/remainder info children) ; TODO: do we need int-ctxt, or can it be inferred? `(mod ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds #t))] - [(node/int/op/abs info children) + [(node/int/op-on-ints/abs info children) `(abs ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/sign info children) + [(node/int/op-on-ints/sign info children) ; The Forge->SMT-LIB generator preamble defines a function "sign" `(sign ,@(process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] [(node/int/sum-quant info decls int-expr) @@ -618,7 +618,7 @@ (match expr [(node/expr/relation info arity name typelist-thunk parent is-var) (list expr)] - [(node/expr/op/join info 2 children) + [(node/expr/op-on-exprs/join info 2 children) (cons (first children) (join->list/right (second children)))] [else (raise-forge-error #:msg (format "join->list/right expected relation or right-chain of binary joins, got ~a" expr) #:context expr)])) \ No newline at end of file diff --git a/forge/solver-specific/translate-to-kodkod-cli.rkt b/forge/solver-specific/translate-to-kodkod-cli.rkt index 9f7a6733..3756231a 100644 --- a/forge/solver-specific/translate-to-kodkod-cli.rkt +++ b/forge/solver-specific/translate-to-kodkod-cli.rkt @@ -36,8 +36,8 @@ ( print-cmd-cont (format "~a " type))] [(node/fmla/pred-spacer info name args expanded) (interpret-formula run-or-state expanded relations atom-names quantvars)] - [(node/formula/op info args) - (interpret-formula-op run-or-state formula relations atom-names quantvars args)] + [(? node/formula/op? op) + (interpret-formula-op run-or-state formula relations atom-names quantvars (node/formula/op-children op))] [(node/formula/multiplicity info mult expr) ( print-cmd-cont (format "(~a " mult )) (interpret-expr run-or-state expr relations atom-names quantvars) @@ -71,85 +71,85 @@ (define (interpret-formula-op run-or-state formula relations atom-names quantvars args) (match formula - [(? node/formula/op/&&?) + [(? node/formula/op-on-formulas/&&?) ( print-cmd-cont "(&& ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/||?) + [(? node/formula/op-on-formulas/||?) ( print-cmd-cont "(|| ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/=>?) + [(? node/formula/op-on-formulas/=>?) ( print-cmd-cont "(=> ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/always?) + [(? node/formula/op-on-formulas/always?) ( print-cmd-cont "(always ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/eventually?) + [(? node/formula/op-on-formulas/eventually?) ( print-cmd-cont "(eventually ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/next_state?) + [(? node/formula/op-on-formulas/next_state?) ( print-cmd-cont "(after ") ; note name change (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/releases?) + [(? node/formula/op-on-formulas/releases?) ( print-cmd-cont "(releases ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/until?) + [(? node/formula/op-on-formulas/until?) ( print-cmd-cont "(until ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/historically?) + [(? node/formula/op-on-formulas/historically?) ( print-cmd-cont "(historically ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/once?) + [(? node/formula/op-on-formulas/once?) ( print-cmd-cont "(once ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/prev_state?) + [(? node/formula/op-on-formulas/prev_state?) ( print-cmd-cont "(before ") ; note name change (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/since?) + [(? node/formula/op-on-formulas/since?) ( print-cmd-cont "(since ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/triggered?) + [(? node/formula/op-on-formulas/triggered?) ( print-cmd-cont "(triggered ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/in?) + [(? node/formula/op-on-exprs/in?) (print-cmd-cont "(in ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) (print-cmd-cont ")")] - [(? node/formula/op/=?) + [(? node/formula/op-on-exprs/=?) (print-cmd-cont "(= ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) (print-cmd-cont ")")] - [(? node/formula/op/!?) + [(? node/formula/op-on-formulas/!?) (print-cmd-cont "(! ") (map (lambda (x) (interpret-formula run-or-state x relations atom-names quantvars)) args) (print-cmd-cont ")")] - [(? node/formula/op/int>?) + [(? node/formula/op-on-ints/int>?) ( print-cmd-cont "(> ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/formula/op/intstring (v sym))) (print-cmd-cont (symbol->string (v (get-sym expr)))) @@ -218,37 +218,37 @@ (define (interpret-expr-op run-or-state expr relations atom-names quantvars args) (match expr - [(? node/expr/op/+?) + [(? node/expr/op-on-exprs/+?) ( print-cmd-cont "(+ ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/expr/op/-?) + [(? node/expr/op-on-exprs/-?) ( print-cmd-cont "(- ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/expr/op/&?) + [(? node/expr/op-on-exprs/&?) ( print-cmd-cont "(& ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/expr/op/->?) + [(? node/expr/op-on-exprs/->?) ( print-cmd-cont "(-> ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/expr/op/prime?) + [(? node/expr/op-on-exprs/prime?) ( print-cmd-cont "(prime ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/expr/op/join?) + [(? node/expr/op-on-exprs/join?) ( print-cmd-cont "(. ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/expr/op/^?) + [(? node/expr/op-on-exprs/^?) ( print-cmd-cont "(^ ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/expr/op/*?) + [(? node/expr/op-on-exprs/*?) ; Since * involves iden, we need to intercede so univ is restricted to actual *used* universe (print-cmd-cont (format "(+ (& iden (-> ~a ~a)) (^ " @@ -256,15 +256,15 @@ (build-univ-string run-or-state))) (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) (print-cmd-cont "))")] - [(? node/expr/op/~?) + [(? node/expr/op-on-exprs/~?) (print-cmd-cont "(~a " '~) ; Likely '~ added this way because ~ would need to be escaped (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) (print-cmd-cont ")")] - [(? node/expr/op/++?) + [(? node/expr/op-on-exprs/++?) (print-cmd-cont "(++ ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) (print-cmd-cont ")")] - [(? node/expr/op/sing?) + [(? node/expr/op-on-ints/sing?) (print-cmd-cont "(lone ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars)) args) (print-cmd-cont ")") @@ -274,8 +274,8 @@ (match expr [(node/int/constant info value) (print-cmd-cont (format "~a " value))] - [(node/int/op info args) - (interpret-int-op run-or-state expr relations atom-names quantvars args)] + [(? node/int/op? op) + (interpret-int-op run-or-state expr relations atom-names quantvars (node/int/op-children op))] [(node/int/sum-quant info decls int-expr) (define var (car (car decls))) (let ([quantvars (cons var quantvars)]) @@ -289,39 +289,39 @@ (define (interpret-int-op run-or-state expr relations atom-names quantvars args) (match expr - [(? node/int/op/add?) + [(? node/int/op-on-ints/add?) ( print-cmd-cont "(+ ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/int/op/subtract?) + [(? node/int/op-on-ints/subtract?) ( print-cmd-cont "(- ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/int/op/multiply?) + [(? node/int/op-on-ints/multiply?) ( print-cmd-cont "(* ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/int/op/divide?) + [(? node/int/op-on-ints/divide?) ( print-cmd-cont "(/ ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars )) args) ( print-cmd-cont ")")] - [(? node/int/op/sum?) + [(? node/int/op-on-exprs/sum?) ( print-cmd-cont "(sum ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars )) args) ( print-cmd-cont ")")] - [(? node/int/op/card?) + [(? node/int/op-on-exprs/card?) ( print-cmd-cont "(# ") (map (lambda (x) (interpret-expr run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/int/op/remainder?) + [(? node/int/op-on-ints/remainder?) ( print-cmd-cont "(% ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/int/op/abs?) + [(? node/int/op-on-ints/abs?) ( print-cmd-cont "(abs ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] - [(? node/int/op/sign?) + [(? node/int/op-on-ints/sign?) ( print-cmd-cont "(sgn ") (map (lambda (x) (interpret-int run-or-state x relations atom-names quantvars)) args) ( print-cmd-cont ")")] diff --git a/forge/tests/forge-core/examples/ast-parsing/sub-test.rkt b/forge/tests/forge-core/examples/ast-parsing/sub-test.rkt index 61fcac03..590c24cc 100644 --- a/forge/tests/forge-core/examples/ast-parsing/sub-test.rkt +++ b/forge/tests/forge-core/examples/ast-parsing/sub-test.rkt @@ -42,7 +42,7 @@ ; I guess this weird way of creating the relation works, since the test passes.... ; This is helpful to now that rel is logically equivalent to Relation. ; TODO: what is the 'parent' field of a relation? -(define var-to-sub-2-2 (node/expr/op/join '() 2 (list quantvar-2 (node/expr/relation '() 1 'age (list 'Int) '() #f)))) +(define var-to-sub-2-2 (node/expr/op-on-exprs/join '() 2 (list quantvar-2 (node/expr/relation '() 1 'age (list 'Int) '() #f)))) (define quantified-for-int-result (substitute-formula run-statement quantified-for-int '() '() '() var-to-sub-2-1 var-to-sub-2-2)) (@check are-logically-equivalent/bounds? quantified-for-int-result int_pre) diff --git a/forge/tests/forge/other/helpers/import-asserts-B.frg b/forge/tests/forge/other/helpers/import-asserts-B.frg new file mode 100644 index 00000000..2b61fd53 --- /dev/null +++ b/forge/tests/forge/other/helpers/import-asserts-B.frg @@ -0,0 +1,6 @@ +#lang forge +// Helper file for import-asserts-A.frg - tests that assertions are NOT inherited +option run_sterling off +sig A {} +// This assertion WOULD FAIL if it ran - used to verify assertions aren't inherited on import +deliberate_fail: assert {no A and some A} is sat diff --git a/forge/tests/forge/other/helpers/import-examples-B.frg b/forge/tests/forge/other/helpers/import-examples-B.frg new file mode 100644 index 00000000..e80f3c69 --- /dev/null +++ b/forge/tests/forge/other/helpers/import-examples-B.frg @@ -0,0 +1,6 @@ +#lang forge +// Helper file for import-examples-A.frg - tests that examples are NOT inherited +option run_sterling off +sig A {} +// This example WOULD FAIL if it ran - used to verify examples aren't inherited on import +example badExample is {no A} for { A = A } diff --git a/forge/tests/forge/other/helpers/import-options-B.frg b/forge/tests/forge/other/helpers/import-options-B.frg new file mode 100644 index 00000000..a4b67f80 --- /dev/null +++ b/forge/tests/forge/other/helpers/import-options-B.frg @@ -0,0 +1,6 @@ +#lang forge +// Helper file for import-options-A.frg - tests that final option value is inherited +option run_sterling off +option no_overflow false // first value +sig A {} +option no_overflow true // final value - this should be inherited by importer diff --git a/forge/tests/forge/other/helpers/import-runs-B.frg b/forge/tests/forge/other/helpers/import-runs-B.frg new file mode 100644 index 00000000..acbcaec8 --- /dev/null +++ b/forge/tests/forge/other/helpers/import-runs-B.frg @@ -0,0 +1,5 @@ +#lang forge +// Helper file for import-runs-A.rkt - tests that runs ARE inherited +option run_sterling off +sig Thing {} +myRun: run { some Thing } diff --git a/forge/tests/forge/other/helpers/import-tests-B.frg b/forge/tests/forge/other/helpers/import-tests-B.frg new file mode 100644 index 00000000..fb7fe04e --- /dev/null +++ b/forge/tests/forge/other/helpers/import-tests-B.frg @@ -0,0 +1,6 @@ +#lang forge +// Helper file for import-tests-A.frg - tests that test expect blocks are NOT inherited +option run_sterling off +sig A {} +// This test WOULD FAIL if it ran - used to verify tests aren't inherited on import +test expect { deliberate_fail: {no A and some A} is sat } diff --git a/forge/tests/forge/other/import-asserts-A.frg b/forge/tests/forge/other/import-asserts-A.frg new file mode 100644 index 00000000..b78fab6e --- /dev/null +++ b/forge/tests/forge/other/import-asserts-A.frg @@ -0,0 +1,10 @@ +#lang forge +// Test that assertions (assert {...} is sat/unsat) are NOT inherited on import +// helpers/import-asserts-B.frg has a deliberately failing assertion +// If assertions were inherited, this file would fail +open "helpers/import-asserts-B.frg" +option run_sterling off + +// The fact that this test runs (and the file doesn't error) proves +// that B's failing assertion was not inherited +test expect { import_succeeded: {some A} is sat } diff --git a/forge/tests/forge/other/import-examples-A.frg b/forge/tests/forge/other/import-examples-A.frg new file mode 100644 index 00000000..3034bd9f --- /dev/null +++ b/forge/tests/forge/other/import-examples-A.frg @@ -0,0 +1,10 @@ +#lang forge +// Test that examples are NOT inherited on import +// helpers/import-examples-B.frg has a deliberately failing example +// If examples were inherited, this file would fail +open "helpers/import-examples-B.frg" +option run_sterling off + +// The fact that this test runs (and the file doesn't error) proves +// that B's failing example was not inherited +test expect { import_succeeded: {some A} is sat } diff --git a/forge/tests/forge/other/import-options-A.frg b/forge/tests/forge/other/import-options-A.frg new file mode 100644 index 00000000..5053e591 --- /dev/null +++ b/forge/tests/forge/other/import-options-A.frg @@ -0,0 +1,10 @@ +#lang forge +// Test that the FINAL option value from an imported module is inherited +// helpers/import-options-B.frg sets no_overflow to false, then true +// We should inherit no_overflow = true (the final value) +open "helpers/import-options-B.frg" + +// This pred requires integer overflow to be SAT +// With no_overflow = true, overflow is forbidden, so this should be UNSAT +pred needs_overflow { some i: Int | i > 0 and add[i,1] < 0 } +test expect { overflow_blocked: {needs_overflow} is unsat } diff --git a/forge/tests/forge/other/import-runs-A.rkt b/forge/tests/forge/other/import-runs-A.rkt new file mode 100644 index 00000000..a8db70a6 --- /dev/null +++ b/forge/tests/forge/other/import-runs-A.rkt @@ -0,0 +1,13 @@ +#lang forge/core +;; Test that runs ARE inherited on import +;; helpers/import-runs-B.frg defines a run called myRun +;; We verify that myRun exists in curr-state after importing + +(require "helpers/import-runs-B.frg") +(require (only-in rackunit check-true)) + +(set-option! 'verbose 0) +(set-option! 'run_sterling 'off) + +(check-true (hash-has-key? (forge:State-runmap forge:curr-state) 'myRun) + "myRun should be inherited from imported module") diff --git a/forge/tests/forge/other/import-tests-A.frg b/forge/tests/forge/other/import-tests-A.frg new file mode 100644 index 00000000..c28d8d9b --- /dev/null +++ b/forge/tests/forge/other/import-tests-A.frg @@ -0,0 +1,10 @@ +#lang forge +// Test that test expect blocks are NOT inherited on import +// helpers/import-tests-B.frg has a deliberately failing test +// If tests were inherited, this file would fail +open "helpers/import-tests-B.frg" +option run_sterling off + +// The fact that this test runs (and the file doesn't error) proves +// that B's failing test was not inherited +test expect { import_succeeded: {some A} is sat } diff --git a/forge/tests/forge/other/overwrite-options.frg b/forge/tests/forge/other/overwrite-options.frg new file mode 100644 index 00000000..6952110f --- /dev/null +++ b/forge/tests/forge/other/overwrite-options.frg @@ -0,0 +1,16 @@ +#lang forge +option verbose 0 +option run_sterling off + +// It should be possible to overwrite options between run commands. Most options +// have no semantic weight, so we can't test them via sat/unsat tests. However, +// some do. One of those is whether integer overflow is allowed. + +pred needs_overflow {some i: Int | i > 0 and add[i,1] < 0} + +option no_overflow false // default +test expect { overflow_allowed: {needs_overflow} is sat } + +option no_overflow true +test expect { overflow_forbidden: {needs_overflow} is unsat } + diff --git a/forge/types/ast-adapter.rkt b/forge/types/ast-adapter.rkt index 0bdb4725..aae11247 100644 --- a/forge/types/ast-adapter.rkt +++ b/forge/types/ast-adapter.rkt @@ -1,27 +1,97 @@ #lang typed/racket/base/optional -(provide +(provide (struct-out node) (struct-out node/expr) (struct-out node/expr/relation) + (struct-out node/expr/comprehension) + (struct-out node/expr/atom) + (struct-out node/expr/fun-spacer) + (struct-out node/expr/ite) + (struct-out node/expr/constant) (struct-out node/breaking) (struct-out node/breaking/break) + (struct-out node/breaking/op) + (struct-out node/breaking/op/is) (struct-out nodeinfo) (struct-out node/formula) + (struct-out node/formula/constant) + (struct-out node/fmla/pred-spacer) + (struct-out node/formula/quantified) + (struct-out node/formula/multiplicity) + (struct-out node/formula/sealed) (struct-out node/expr/quantifier-var) - (struct-out node/int) + (struct-out node/int) (struct-out node/int/constant) + (struct-out node/int/sum-quant) + ;; Operator hierarchies + (struct-out node/expr/op) + (struct-out node/expr/op-on-exprs) + (struct-out node/expr/op-on-exprs/+) + (struct-out node/expr/op-on-exprs/-) + (struct-out node/expr/op-on-exprs/&) + (struct-out node/expr/op-on-exprs/->) + (struct-out node/expr/op-on-exprs/prime) + (struct-out node/expr/op-on-exprs/join) + (struct-out node/expr/op-on-exprs/^) + (struct-out node/expr/op-on-exprs/*) + (struct-out node/expr/op-on-exprs/~) + (struct-out node/expr/op-on-exprs/++) + (struct-out node/expr/op-on-ints) + (struct-out node/expr/op-on-ints/sing) + (struct-out node/int/op) + (struct-out node/int/op-on-ints) + (struct-out node/int/op-on-ints/add) + (struct-out node/int/op-on-ints/subtract) + (struct-out node/int/op-on-ints/multiply) + (struct-out node/int/op-on-ints/divide) + (struct-out node/int/op-on-ints/remainder) + (struct-out node/int/op-on-ints/abs) + (struct-out node/int/op-on-ints/sign) + (struct-out node/int/op-on-exprs) + (struct-out node/int/op-on-exprs/sum) + (struct-out node/int/op-on-exprs/card) + (struct-out node/formula/op) + (struct-out node/formula/op-on-formulas) + (struct-out node/formula/op-on-formulas/&&) + (struct-out node/formula/op-on-formulas/||) + (struct-out node/formula/op-on-formulas/=>) + (struct-out node/formula/op-on-formulas/!) + (struct-out node/formula/op-on-formulas/always) + (struct-out node/formula/op-on-formulas/eventually) + (struct-out node/formula/op-on-formulas/next_state) + (struct-out node/formula/op-on-formulas/releases) + (struct-out node/formula/op-on-formulas/until) + (struct-out node/formula/op-on-formulas/historically) + (struct-out node/formula/op-on-formulas/once) + (struct-out node/formula/op-on-formulas/prev_state) + (struct-out node/formula/op-on-formulas/since) + (struct-out node/formula/op-on-formulas/triggered) + (struct-out node/formula/op-on-exprs) + (struct-out node/formula/op-on-exprs/in) + (struct-out node/formula/op-on-exprs/=) + (struct-out node/formula/op-on-ints) + (struct-out node/formula/op-on-ints/int>) + (struct-out node/formula/op-on-ints/int<) + (struct-out node/formula/op-on-ints/int=) + ;; Generic children accessors (return Listof node, for backward compatibility) + node/expr/op-children + node/int/op-children + node/formula/op-children + ;; Other exports relation-arity just-location-info quantified-formula multiplicity-formula empty-nodeinfo - join/func one/func build-box-join univ raise-forge-error &&/func &/func ||/func +/func + join/func one/func build-box-join univ none raise-forge-error &&/func &/func ||/func +/func -/func =/func */func iden ^/func set/func relation-name always/func maybe-and->list int=/func int/func - Decl Decls) + lone/func ->/func some/func !/func add/func sum/func sing/func var ite/func atom/func + Decl Decls ASTConstructor) (define-type Decl (Pairof node/expr/quantifier-var node/expr)) (define-type Decls (Listof Decl)) -(require/typed forge/lang/ast +(require racket/list) ; for rest, first + +(require/typed forge/lang/ast [#:struct nodeinfo ([loc : srcloc] [lang : Symbol] [annotations : (Option (Listof Any))])] [#:struct node ([info : nodeinfo])] [#:struct (node/int node) ()] @@ -29,29 +99,105 @@ [#:struct (node/expr node) ([arity : Number])] [#:struct (node/breaking node) ()] [#:struct (node/breaking/break node/breaking) ([break : Symbol])] + [#:struct (node/breaking/op node/breaking) ([children : (Listof Any)])] + [#:struct (node/breaking/op/is node/breaking/op) ()] [#:struct (node/formula node) ()] + [#:struct (node/formula/constant node/formula) ([type : Any])] + [#:struct (node/fmla/pred-spacer node/formula) ([name : Symbol] [args : (Listof node)] [expanded : node/formula])] [#:struct (node/expr/quantifier-var node/expr) ([sym : Symbol] [name : Symbol])] [#:struct (node/expr/relation node/expr) - ([name : String] - [typelist-thunk : (-> (Listof Any))] - [parent : Any] - [is-variable : Boolean])] - + ([name : String] + [typelist-thunk : (-> (Listof Any))] + [parent : Any] + [is-variable : (U String Boolean)])] + [#:struct (node/expr/comprehension node/expr) ([decls : Decls] [formula : node/formula])] + [#:struct (node/expr/atom node/expr) ([name : Any])] + [#:struct (node/expr/fun-spacer node/expr) ([name : Any] [args : (Listof node)] [codomain : Any] [expanded : node/expr])] + [#:struct (node/expr/ite node/expr) ([condition : node/formula] [thene : node/expr] [elsee : node/expr])] + [#:struct (node/expr/constant node/expr) ([type : Any])] + + ;; Formula structs with fields + [#:struct (node/formula/quantified node/formula) ([quantifier : Symbol] [decls : Decls] [formula : node/formula])] + [#:struct (node/formula/multiplicity node/formula) ([mult : Symbol] [expr : node/expr])] + [#:struct (node/formula/sealed node/formula) ()] + + ;; Integer structs with fields + [#:struct (node/int/sum-quant node/int) ([decls : Decls] [int-expr : node/int])] + + ;; Expression operator hierarchy + ;; Base struct has no children field - children are declared at intermediate level + [#:struct (node/expr/op node/expr) ()] + [#:struct (node/expr/op-on-exprs node/expr/op) ([children : (Listof node/expr)])] + [#:struct (node/expr/op-on-exprs/+ node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/- node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/& node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/-> node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/prime node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/join node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/^ node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/* node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/~ node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-exprs/++ node/expr/op-on-exprs) ()] + [#:struct (node/expr/op-on-ints node/expr/op) ([children : (Listof node/int)])] + [#:struct (node/expr/op-on-ints/sing node/expr/op-on-ints) ()] + + ;; Integer operator hierarchy + ;; Base struct has no children field - children are declared at intermediate level + [#:struct (node/int/op node/int) ()] + [#:struct (node/int/op-on-ints node/int/op) ([children : (Listof node/int)])] + [#:struct (node/int/op-on-ints/add node/int/op-on-ints) ()] + [#:struct (node/int/op-on-ints/subtract node/int/op-on-ints) ()] + [#:struct (node/int/op-on-ints/multiply node/int/op-on-ints) ()] + [#:struct (node/int/op-on-ints/divide node/int/op-on-ints) ()] + [#:struct (node/int/op-on-ints/remainder node/int/op-on-ints) ()] + [#:struct (node/int/op-on-ints/abs node/int/op-on-ints) ()] + [#:struct (node/int/op-on-ints/sign node/int/op-on-ints) ()] + [#:struct (node/int/op-on-exprs node/int/op) ([children : (Listof node/expr)])] + [#:struct (node/int/op-on-exprs/sum node/int/op-on-exprs) ()] + [#:struct (node/int/op-on-exprs/card node/int/op-on-exprs) ()] + + ;; Formula operator hierarchy + ;; Base struct has no children field - children are declared at intermediate level + [#:struct (node/formula/op node/formula) ()] + [#:struct (node/formula/op-on-formulas node/formula/op) ([children : (Listof node/formula)])] + [#:struct (node/formula/op-on-formulas/&& node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/|| node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/=> node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/! node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/always node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/eventually node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/next_state node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/releases node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/until node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/historically node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/once node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/prev_state node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/since node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-formulas/triggered node/formula/op-on-formulas) ()] + [#:struct (node/formula/op-on-exprs node/formula/op) ([children : (Listof node/expr)])] + [#:struct (node/formula/op-on-exprs/in node/formula/op-on-exprs) ()] + [#:struct (node/formula/op-on-exprs/= node/formula/op-on-exprs) ()] + [#:struct (node/formula/op-on-ints node/formula/op) ([children : (Listof node/int)])] + [#:struct (node/formula/op-on-ints/int> node/formula/op-on-ints) ()] + [#:struct (node/formula/op-on-ints/int< node/formula/op-on-ints) ()] + [#:struct (node/formula/op-on-ints/int= node/formula/op-on-ints) ()] + + ;; Generic accessor functions for backward compatibility (return Listof node) + [node/expr/op-children (-> node/expr/op (Listof node))] + [node/int/op-children (-> node/int/op (Listof node))] + [node/formula/op-children (-> node/formula/op (Listof node))] + ; (define (functionname #:info [info empty-nodeinfo] . raw-args) // and so on ; (apply &&/func #:info empty-nodeinfo (list true true true)) ; This by itself doesn't allow the type system to differentiate between ; the #t and #f modes, even when they are provided as literals. ;(->* (#:msg String #:context Any) (#:raise? Boolean) Void) ] - [raise-forge-error - (case-> - (->* () (#:msg String #:context Any #:raise? True) Nothing) - (->* () (#:msg String #:context Any #:raise? False) Void) - (->* () (#:msg String #:context Any) Nothing))] + [raise-forge-error (->* () (#:msg String #:context Any #:raise? Boolean) Nothing)] [relation-arity (-> Any Integer)] [relation-name (-> node/expr/relation String)] [just-location-info (-> (U srcloc #f) nodeinfo)] - [quantified-formula (-> nodeinfo Symbol (Listof Decl) node/formula node/formula)] + [quantified-formula (-> nodeinfo Symbol (Listof Decl) node/formula node/formula/quantified)] [multiplicity-formula (-> nodeinfo Symbol node/expr node/formula)] [empty-nodeinfo nodeinfo] ;; ?? which of these is correct? @@ -59,7 +205,9 @@ [one/func (->* (node/expr) (#:info nodeinfo) node/formula)] [lone/func (->* (node/expr) (#:info nodeinfo) node/formula)] [no/func (->* (node/expr) (#:info nodeinfo) node/formula)] + [some/func (->* (node/expr) (#:info nodeinfo) node/formula)] [&&/func (->* (node/formula) (#:info nodeinfo) #:rest node/formula node/formula)] + [!/func (->* (node/formula) (#:info nodeinfo) node/formula)] [||/func (->* (node/formula) (#:info nodeinfo) #:rest node/formula node/formula)] [&/func (->* (node/expr) (#:info nodeinfo) #:rest node/expr node/expr)] [->/func (->* (node/expr) (#:info nodeinfo) #:rest node/expr node/expr)] @@ -69,19 +217,26 @@ [in/func (->* (node/expr node/expr) (#:info nodeinfo) node/formula)] [*/func (->* (node/expr) (#:info nodeinfo) node/expr)] [^/func (->* (node/expr) (#:info nodeinfo) node/expr)] - [set/func (->* ((Listof Decl) node/formula) (#:info nodeinfo) node/expr)] + [set/func (->* ((Listof Decl) node/formula) (#:info nodeinfo) node/expr/comprehension)] [always/func (->* (node/formula) (#:info nodeinfo) node/formula)] [int=/func (->* (node/int node/int) (#:info nodeinfo) node/formula)] [int* (node/int node/int) (#:info nodeinfo) node/formula)] [int/func (->* (Integer) (#:info nodeinfo) node/int/constant)] - [card/func (->* (node/expr) (#:info nodeinfo) node/int/constant)] + [atom/func (->* (Symbol) (#:info nodeinfo) node/expr/atom)] + [card/func (->* (node/expr) (#:info nodeinfo) node/int)] + [add/func (->* (node/int node/int) (#:info nodeinfo) node/int)] + [sum/func (->* (node/expr) (#:info nodeinfo) node/int)] + [sing/func (->* (node/int) (#:info nodeinfo) node/expr)] + [var (->* () (Symbol #:info nodeinfo) node/expr/quantifier-var)] + [(ite/info-helper ite/func) (-> nodeinfo node/formula node/expr node/expr node/expr)] [build-box-join (-> node/expr (Listof node/expr) node/expr)] [maybe-and->list (-> node/formula (Listof node/formula))] [univ node/expr] [iden node/expr] + [none node/expr] ; Don't export these as-is. Potential conflict with existing Racket identifiers. [(true true-formula) node/formula] - [(false false-formula) node/formula] + [(false false-formula) node/formula] ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -92,7 +247,7 @@ (require/typed typed/racket [keyword-apply (All (PT RT) (-> (ASTConstructor PT RT) (Listof '#:info) (Listof nodeinfo) (Listof PT) RT))]) -(provide app-f app-e app-i) +(provide app-f app-e app-i fold-ast) (: app-f (-> (ASTConstructor node/formula node/formula) nodeinfo (Listof node/formula) node/formula)) (define (app-f func info nodes) @@ -104,6 +259,14 @@ (define (app-i func info nodes) (keyword-apply func '(#:info) (list info) nodes)) +;; Fold a non-empty list of AST nodes using a binary constructor. +;; E.g., (fold-ast +/func (list a b c)) produces (+/func a (+/func b c)) +(: fold-ast (All (T) (-> (ASTConstructor T T) (Listof T) T))) +(define (fold-ast constructor nodes) + (cond [(null? nodes) (error "fold-ast: empty list")] + [(null? (rest nodes)) (first nodes)] + [else (constructor (first nodes) (fold-ast constructor (rest nodes)))])) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/forge/types/lazy-tree-adapter.rkt b/forge/types/lazy-tree-adapter.rkt index deeeca41..bc8c3f19 100644 --- a/forge/types/lazy-tree-adapter.rkt +++ b/forge/types/lazy-tree-adapter.rkt @@ -1,19 +1,23 @@ #lang typed/racket/base/optional -(provide ; (struct-out computation) - ; (struct-out computation/delayed) +(provide ; (struct-out computation) + ; (struct-out computation/delayed) (prefix-out tree: (struct-out node)) (prefix-out tree: make-node/func) + tree:get-value + tree:get-child get-checker-hash) (require/typed forge/utils/lazy-tree ; [#:struct computation ()] ; [#:struct (computation/delayed computation) ([thnk : Any])] [make-node/func (-> (-> String Any) String (-> String Any) node)] + [(get-value tree:get-value) (-> node Any)] + [(get-child tree:get-child) (-> node Any Any)] [#:struct node ( - [datum : Any] - [child-generator : Any] - [children : Any] + [datum : Any] + [child-generator : Any] + [children : Any] [ancestors : Any])]) (require (only-in forge/utils/lazy-tree make-node)) diff --git a/forge/types/sigs-structs-adapter.rkt b/forge/types/sigs-structs-adapter.rkt new file mode 100644 index 00000000..12e1eebb --- /dev/null +++ b/forge/types/sigs-structs-adapter.rkt @@ -0,0 +1,118 @@ +#lang typed/racket/base/optional + +;; Typed adapter for forge/sigs-structs +;; Provides type definitions for structs from the untyped sigs-structs module + +(require forge/types/ast-adapter) +(require forge/types/lazy-tree-adapter) +(require forge/shared) ; provides FAtom and Tuple +(require forge/breaks) ; provides sbound + +(define-type PiecewiseBounds (HashTable node/expr/relation PiecewiseBound)) + +(require/typed forge/sigs-structs + [#:struct Sat ( + [instances : Any] ; list of hashes + [stats : Any] ; association list + [metadata : Any])] ; association list) + [#:struct Unsat ( + [core : (U False (Listof Any))] ; list-of-Formula-string-or-formulaID + [stats : Any] ; association list + [kind : Symbol] ; symbol + )] + [#:struct Unknown ( + [stats : Any] ; data on performance, translation, etc. + [metadata : Any] ; any solver-specific data provided about the unknown result + )] + [#:struct Kodkod-current ( + [formula : Integer] + [expression : Integer] + [int : Integer])] + [#:struct (Relation node/expr/relation) ( + [name : Symbol] ; symbol? + [sigs-thunks : (Listof (-> Sig))] + [breaker : (U node/breaking/break False)] + )] + [#:struct Server-ports ( + [stdin : Output-Port] + [stdout : Input-Port] + [stderr : Input-Port] + [shutdown : (-> Void)] + [is-running? : (-> Boolean)])] + [#:struct (Sig node/expr/relation) ( + [name : Symbol] ; symbol? + [one : Boolean] ; boolean? + [lone : Boolean] ; boolean? + [abstract : Boolean] ; boolean? + [extends : (U Sig False)] ; (or/c Sig? #f) + )] + [#:struct Run-spec ( + [state : State] ; Model state at the point of this run + [preds : (Listof node/formula)] ; predicates to run, conjoined + [scope : Scope] ; Numeric scope(s) + [bounds : Bound] ; set-based upper and lower bounds + [target : Any] ;(or/c Target? #f) ; target-oriented model finding + )] + [#:struct Bound ( + ; pbindings: partial (but complete) bindings for a given relation + [pbindings : (HashTable node/expr/relation sbound)] + ; tbindings: total (and complete) bindings for a given relation; also known as an exact bound. + [tbindings : (HashTable node/expr/relation Any)] + ; incomplete bindings for a given relation, indexed by first column + [piecewise : PiecewiseBounds] + ; original AST nodes, for improving errors, indexed by relation + [orig-nodes : (HashTable node/expr/relation (Listof node))] + )] + [#:struct PiecewiseBound ( + [tuples : (Listof Tuple)] ; first element is the indexed atom in the original piecewise bounds + [atoms : (Listof FAtom)] ; which atoms have been bound? (distinguish "given none" from "none given") + [operator : (U '= 'in 'ni)])] ; which operator mode? + [#:struct State ( + [sigs : (HashTable Symbol Sig)] + [sig-order : (Listof Symbol)] + [relations : (HashTable Symbol Relation)] + [relation-order : (Listof Symbol)] + [pred-map : (HashTable Symbol node/formula)] ;(hash/c symbol? (or/c (unconstrained-domain-> node/formula?) node/formula?)) + [fun-map : (HashTable Symbol node)] ; (hash/c symbol? (unconstrained-domain-> node?)) + [const-map : (HashTable Symbol node)] + [inst-map : (HashTable Symbol Any)] ; (hash/c symbol? Inst?) + [options : Any] ; Options? + [runmap : (HashTable Symbol Run)])] + [#:struct Run ( + [name : Symbol] + [command : Syntax] + [run-spec : Run-spec] + [result : Any] ;tree:node + [server-ports : Any] ;Server-ports?] + [atoms : (Listof FAtom)] + [kodkod-currents : Any] ; Kodkod-current?] + [kodkod-bounds : (Listof Any)] + [last-sterling-instance : Any ])] ; (box/c (or/c Sat? Unsat? Unknown? false/c)) + [#:struct Range ( + [lower : (U Integer False)] + [upper : (U Integer False)])] + [#:struct Scope ( + [default-scope : (U Range False)] + [bitwidth : (U Integer False)] + [sig-scopes : (HashTable Symbol Range)])] + [get-relations (-> (U Run State Run-spec) (Listof Relation))] + [get-sigs (->* ((U Run State Run-spec)) ((U False node/expr/relation)) (Listof Sig))] + [get-sig (-> (U Run State Run-spec) (U Symbol node/expr/relation) (U Sig False))] + [get-option (case-> + (-> (U Run State Run-spec) 'backend Symbol) + (-> (U Run State Run-spec) 'solver (U String Symbol)) + (-> (U Run State Run-spec) 'java_exe_location (U False Path-String)) + (-> (U Run State Run-spec) 'problem_type Symbol) + (-> (U Run State Run-spec) Symbol Any))] + [get-state (-> (U Run Run-spec State) State)] + [get-bitwidth (-> (U Run-spec Scope) Integer)] + [get-children (-> (U Run State Run-spec) Sig (Listof Sig))] + [DEFAULT-SIG-SCOPE Range] + [get-top-level-sigs (-> (U Run State Run-spec) (Listof Sig))] + ;; TODO TYPES: these are macros, but they has no parameters, so they are being immediately + ;; expanded here to the relations they denote. + [Int Sig] + [succ Relation] +) + +(provide (all-defined-out)) diff --git a/forge/utils/collector.rkt b/forge/utils/collector.rkt index bc02eab5..a9672af0 100644 --- a/forge/utils/collector.rkt +++ b/forge/utils/collector.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang typed/racket/base/optional ; A utility function that collects values corresponding to matching AST nodes ; and returns them in a list. The traversal order can be partly controlled: @@ -23,25 +23,22 @@ ; retained in the return value. The stop policy is separate from the matcher. ; The optional get-new-context argument is a lambda that returns a new context value to -; be passed to the recursive call on the current node's children, if they are visited. -; The default preserves the current context, if any. The optional context argument -; gives the initial value of that context, defaulting to #f. +; be passed to the recursive call on the current node's children, if they are visited. +; The default preserves the current context, if any. The optional context argument +; gives the initial value of that context, defaulting to #f. ; Also, the ordering of internal traversals is consistent, but not adjustable: ; e.g., a quantified formula will always produce -; (append ) +; (append ) ; Finally, duplicates will not be removed. E.g., collecting on (& iden iden) will ; produce `iden` twice in the resulting list unless the matcher prevents it. -(require - forge/sigs-structs - forge/lang/ast +(require + forge/types/ast-adapter forge/shared - (only-in racket index-of match string-join first second rest) - (only-in racket/contract define/contract or/c listof any/c one-of/c) - (prefix-in @ (only-in racket/contract -> ->*)) - (prefix-in @ (only-in racket/base >=))) + (only-in typed/racket match first second rest append apply map format cons equal?) + (prefix-in @ (only-in typed/racket >=))) (provide collect) @@ -50,20 +47,21 @@ ; portion of a spacer node; at the moment only actually-used-in-constraint nodes ; are visited. -(define/contract (collect node matcher #:order order +(: collect (->* (node (-> node Any Any) + #:order (U 'pre-order 'post-order)) + (#:stop (-> node Any Boolean) + #:context Any + #:get-new-context (-> node Any Any)) + (Listof Any))) +(define (collect node matcher #:order order #:stop [stop (lambda (n ctxt) #f)] #:context [context #f] #:get-new-context [get-new-context (lambda (n ctxt) ctxt)]) - (@->* (node? ; node being visited - (@-> node? any/c any/c) ; matcher function (node, context) -> collected-value - #:order (one-of/c 'pre-order 'post-order)) ; traversal order symbol - (#:stop (@-> node? any/c boolean?) ; (optional) stopper predicate (node, context) -> bool - #:context any/c ; (optional) current context value - #:get-new-context (@-> node? any/c any/c)) ; (optional) context-update function (node, context) -> context - (listof any/c)) ; result is an arbitrary list of collected values - (visit node '() matcher order '() stop context get-new-context)) +(: visit (-> node (Listof node/expr/quantifier-var) (-> node Any Any) Symbol + (Listof Any) (-> node Any Boolean) Any + (-> node Any Any) (Listof Any))) (define (visit node quantvars matcher order collected stop context get-new-context) (define matched? (matcher node context)) (define stop? (stop node context)) @@ -89,6 +87,9 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Translate a formula AST node +(: interpret-formula (-> node/formula (Listof node/expr/quantifier-var) (-> node Any Any) Symbol + (Listof Any) (-> node Any Boolean) Any + (-> node Any Any) (Listof Any))) (define (interpret-formula formula quantvars matcher order collected stop context get-new-context) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "collector: interpret-formula: ~a~n" formula)) @@ -97,69 +98,59 @@ '()] [(node/fmla/pred-spacer info name args expanded) (visit expanded quantvars matcher order collected stop context get-new-context)] - [(node/formula/op info args) - (interpret-formula-op formula quantvars args matcher order collected stop context get-new-context)] + [(? node/formula/op?) + (interpret-formula-op formula quantvars (node/formula/op-children formula) matcher order collected stop context get-new-context)] [(node/formula/multiplicity info mult expr) (visit expr quantvars matcher order collected stop context get-new-context)] [(node/formula/quantified info quantifier decls inner-form) (process-quant-shaped-node formula decls inner-form quantvars matcher order collected stop context get-new-context)] - [(node/formula/sealed info) - (visit info quantvars matcher order collected stop context get-new-context)] + ; node/formula/sealed smuggles the actual formula in its info field, which complicates typing. + ; Commenting out for now as it may no longer be used. + ;[(node/formula/sealed info) + ; (visit info quantvars matcher order collected stop context get-new-context)] [#t '()] [#f '()])) +(: interpret-formula-op (-> node/formula/op (Listof node/expr/quantifier-var) (Listof node) (-> node Any Any) Symbol + (Listof Any) (-> node Any Boolean) Any + (-> node Any Any) (Listof Any))) (define (interpret-formula-op formula quantvars args matcher order collected stop context get-new-context) + (: process-children (-> (Listof node) (Listof node/expr/quantifier-var) (Listof Any))) (define (process-children children quantvars) - (apply append (map (lambda (x) (visit x quantvars matcher order collected stop context get-new-context)) children))) + (apply append (map (lambda ([x : node]) (visit x quantvars matcher order collected stop context get-new-context)) children))) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "collector: interpret-formula-op: ~a~n" formula)) ; We could get away with only one case here, really, since there's no distinguishing ; but leaving the structure here for now in case we need it for any refinement. (match formula - [(node/formula/op/&& info children) - (process-children args quantvars)] - [(node/formula/op/|| info children) - (process-children args quantvars)] - [(node/formula/op/=> info children) - (process-children args quantvars)] - [(node/formula/op/always info children) - (process-children args quantvars)] - [(node/formula/op/eventually info children) - (process-children args quantvars)] - [(node/formula/op/next_state info children) - (process-children args quantvars)] - [(node/formula/op/releases info children) - (process-children args quantvars)] - [(node/formula/op/until info children) - (process-children args quantvars)] - [(node/formula/op/historically info children) - (process-children args quantvars)] - [(node/formula/op/once info children) - (process-children args quantvars)] - [(node/formula/op/prev_state info children) - (process-children args quantvars)] - [(node/formula/op/since info children) - (process-children args quantvars)] - [(node/formula/op/triggered info children) - (process-children args quantvars)] - [(node/formula/op/in info children) - (process-children args quantvars)] - [(node/formula/op/= info children) - (process-children args quantvars)] - [(node/formula/op/! info children) - (process-children args quantvars)] - [(node/formula/op/int> info children) - (process-children args quantvars)] - [(node/formula/op/int< info children) - (process-children args quantvars)] - [(node/formula/op/int= info children) - (process-children args quantvars)])) + [(? node/formula/op-on-formulas/&&?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/||?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/=>?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/always?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/eventually?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/next_state?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/releases?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/until?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/historically?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/once?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/prev_state?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/since?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/triggered?) (process-children args quantvars)] + [(? node/formula/op-on-exprs/in?) (process-children args quantvars)] + [(? node/formula/op-on-exprs/=?) (process-children args quantvars)] + [(? node/formula/op-on-formulas/!?) (process-children args quantvars)] + [(? node/formula/op-on-ints/int>?) (process-children args quantvars)] + [(? node/formula/op-on-ints/int node/expr (Listof node/expr/quantifier-var) (-> node Any Any) Symbol + (Listof Any) (-> node Any Boolean) Any + (-> node Any Any) (Listof Any))) (define (interpret-expr expr quantvars matcher order collected stop context get-new-context) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "collector: interpret-expr: ~a~n" expr)) @@ -179,63 +170,62 @@ '()] [(node/expr/constant info arity type) '()] - [(node/expr/op info arity args) - (interpret-expr-op expr quantvars args matcher order collected stop context get-new-context)] + [(? node/expr/op?) + (interpret-expr-op expr quantvars (node/expr/op-children expr) matcher order collected stop context get-new-context)] [(node/expr/quantifier-var info arity sym name) '()] [(node/expr/comprehension info len decls inner-form) (process-quant-shaped-node expr decls inner-form quantvars matcher order collected stop context get-new-context)])) +(: interpret-expr-op (-> node/expr/op (Listof node/expr/quantifier-var) (Listof node) (-> node Any Any) Symbol + (Listof Any) (-> node Any Boolean) Any + (-> node Any Any) (Listof Any))) (define (interpret-expr-op expr quantvars args matcher order collected stop context get-new-context) + (: process-children (-> (Listof node) (Listof node/expr/quantifier-var) (Listof Any))) (define (process-children children quantvars) - (apply append (map (lambda (x) (visit x quantvars matcher order collected stop context get-new-context)) children))) + (apply append (map (lambda ([x : node]) (visit x quantvars matcher order collected stop context get-new-context)) children))) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "collector: interpret-expr-op: ~a~n" expr)) ; We could get away with only one case here, really, since there's no distinguishing ; but leaving the structure here for now in case we need it for any refinement. (match expr - [(node/expr/op/+ info arity children) - (process-children args quantvars)] - [(node/expr/op/- info arity children) - (process-children args quantvars)] - [(node/expr/op/& info arity children) - (process-children args quantvars)] - [(node/expr/op/-> info arity children) - (process-children args quantvars)] - [(node/expr/op/prime info arity children) - (process-children args quantvars)] - [(node/expr/op/join info arity children) - (process-children args quantvars)] - [(node/expr/op/^ info arity children) - (process-children args quantvars)] - [(node/expr/op/* info arity children) - (process-children args quantvars)] - [(node/expr/op/~ info arity children) - (process-children args quantvars)] - [(node/expr/op/++ info arity children) - (process-children args quantvars)] - [(node/expr/op/sing info arity children) - (process-children args quantvars)])) + [(? node/expr/op-on-exprs/+?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/-?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/&?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/->?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/prime?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/join?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/^?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/*?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/~?) (process-children args quantvars)] + [(? node/expr/op-on-exprs/++?) (process-children args quantvars)] + [(? node/expr/op-on-ints/sing?) (process-children args quantvars)])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Integer expressions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(: interpret-int (-> node/int (Listof node/expr/quantifier-var) (-> node Any Any) Symbol + (Listof Any) (-> node Any Boolean) Any + (-> node Any Any) (Listof Any))) (define (interpret-int expr quantvars matcher order collected stop context get-new-context) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "collector: interpret-int: ~a~n" expr)) (match expr [(node/int/constant info value) '()] - [(node/int/op info args) - (interpret-int-op expr quantvars args matcher order collected stop context get-new-context)] + [(? node/int/op?) + (interpret-int-op expr quantvars (node/int/op-children expr) matcher order collected stop context get-new-context)] [(node/int/sum-quant info decls int-expr) (process-quant-shaped-node expr decls int-expr quantvars matcher order collected stop context get-new-context)])) +(: process-quant-shaped-node (-> node Decls node (Listof node/expr/quantifier-var) (-> node Any Any) Symbol + (Listof Any) (-> node Any Boolean) Any + (-> node Any Any) (Listof Any))) (define (process-quant-shaped-node node decls inner-node quantvars matcher order collected stop context get-new-context) (define new-vs-and-collected - (for/fold ([vs-and-collected (list '() '())]) + (for/fold ([vs-and-collected : (List (Listof node/expr/quantifier-var) (Listof Any)) (list '() '())]) ([decl decls]) (define curr-new-quantvars (first vs-and-collected)) (define new-quantvars (cons (car decl) curr-new-quantvars)) @@ -248,9 +238,13 @@ (define inner-collected (visit inner-node new-quantvars matcher order collected stop context get-new-context)) (append new-quantvars new-domain-collected inner-collected)) +(: interpret-int-op (-> node/int/op (Listof node/expr/quantifier-var) (Listof node) (-> node Any Any) Symbol + (Listof Any) (-> node Any Boolean) Any + (-> node Any Any) (Listof Any))) (define (interpret-int-op expr quantvars args matcher order collected stop context get-new-context) + (: process-children (-> (Listof node) (Listof node/expr/quantifier-var) (Listof Any))) (define (process-children children quantvars) - (apply append (map (lambda (x) (visit x quantvars matcher order collected stop context get-new-context)) children))) + (apply append (map (lambda ([x : node]) (visit x quantvars matcher order collected stop context get-new-context)) children))) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "collector: interpret-int-op: ~a~n" expr)) @@ -258,24 +252,15 @@ ; We could get away with only one case here, really, since there's no distinguishing ; but leaving the structure here for now in case we need it for any refinement. (match expr - [(node/int/op/add info children) - (process-children args quantvars)] - [(node/int/op/subtract info children) - (process-children args quantvars)] - [(node/int/op/multiply info children) - (process-children args quantvars)] - [(node/int/op/divide info children) - (process-children args quantvars)] - [(node/int/op/sum info children) - (process-children args quantvars)] - [(node/int/op/card info children) - (process-children args quantvars)] - [(node/int/op/remainder info children) - (process-children args quantvars)] - [(node/int/op/abs info children) - (process-children args quantvars)] - [(node/int/op/sign info children) - (process-children args quantvars)] + [(? node/int/op-on-ints/add?) (process-children args quantvars)] + [(? node/int/op-on-ints/subtract?) (process-children args quantvars)] + [(? node/int/op-on-ints/multiply?) (process-children args quantvars)] + [(? node/int/op-on-ints/divide?) (process-children args quantvars)] + [(? node/int/op-on-exprs/sum?) (process-children args quantvars)] + [(? node/int/op-on-exprs/card?) (process-children args quantvars)] + [(? node/int/op-on-ints/remainder?) (process-children args quantvars)] + [(? node/int/op-on-ints/abs?) (process-children args quantvars)] + [(? node/int/op-on-ints/sign?) (process-children args quantvars)] [(node/int/sum-quant info decls int-expr) (raise-forge-error #:msg "Reached expected unreachable code." #:context expr)])) @@ -287,29 +272,33 @@ ; Very basic smoke tests (module+ test - (require rackunit) + (require typed/rackunit) ; Get all nodes, post-order (check-equal? - (collect (some univ) (lambda (n ctxt) n) #:order 'post-order) - (list univ (some univ))) - + (collect (some/func univ) (lambda (n ctxt) n) #:order 'post-order) + (list univ (some/func univ))) + ; Get all nodes, pre-order (check-equal? - (collect (some univ) (lambda (n ctxt) n) #:order 'pre-order) - (list (some univ) univ)) - + (collect (some/func univ) (lambda (n ctxt) n) #:order 'pre-order) + (list (some/func univ) univ)) + ; Filter only expressions. Note that separate construction of quantifiers ; produces different variables, hence the let*. - (let* ([fmla (all ([x univ]) (some (& (-> x x) iden)))] + (let* ([varx (var 'x)] + [fmla (quantified-formula empty-nodeinfo 'all (list (cons varx univ)) + (some/func (&/func (->/func varx varx) iden)))] [v (car (first (node/formula/quantified-decls fmla)))]) (check-equal? (collect fmla (lambda (n ctxt) (if (node/expr? n) n #f)) #:order 'pre-order) - (list v univ (& (-> v v) iden) (-> v v) v v iden))) - + (list v univ (&/func (->/func v v) iden) (->/func v v) v v iden))) + ; Confirm that multi-decl extraction works for the complex quantifier-shaped cases ; which all invoke the process-quant-shaped-node helper - (let* ([expr (set ([x univ][y (& univ univ)]) (some (& (-> x y) iden)))] + (let* ([x (var 'x)] + [y (var 'y)] + [expr (set/func (list (cons x univ) (cons y (&/func univ univ))) (some/func (&/func (->/func x y) iden)))] [v1 (car (first (node/expr/comprehension-decls expr)))] [v2 (car (second (node/expr/comprehension-decls expr)))]) (check-equal? @@ -319,43 +308,43 @@ (collect expr (lambda (n ctxt) (if (node/expr? n) n #f)) #:order 'pre-order) (list expr v1 v2 - univ (& univ univ) univ univ - (& (-> v1 v2) iden) (-> v1 v2) v1 v2 iden))) + univ (&/func univ univ) univ univ + (&/func (->/func v1 v2) iden) (->/func v1 v2) v1 v2 iden))) ; Confirm that the stop policy is respected. ; (This should collect the outer conjunction and the inner atomic formula only.) ; Note that, since && and || will short-circuit in AST-node construction, this sort of test isn't well-suited to _those_ operators. (check-equal? - (collect (! (some (-> univ univ))) + (collect (!/func (some/func (->/func univ univ))) (lambda (n ctxt) n) #:order 'pre-order #:stop (lambda (n ctxt) (not (node/formula/op? n)))) - (list (! (some (-> univ univ))) - (some (-> univ univ)))) + (list (!/func (some/func (->/func univ univ))) + (some/func (->/func univ univ)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; Check context ;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;; - + ; Test: gather the outermost "sum" nodes (without a stop argument) ; Recall the need to wrap raw numbers in "int"... (check-equal? - (collect (add (int 1) (int 5)) + (collect (add/func (int/func 1) (int/func 5)) (lambda (n ctxt) - (if (and ctxt (node/int/op/sum? n)) n #f)) + (if (and ctxt (node/int/op-on-exprs/sum? n)) n #f)) #:order 'pre-order #:context #t - #:get-new-context (lambda (n ctxt) (if (node/int/op/sum? n) #f ctxt))) + #:get-new-context (lambda (n ctxt) (if (node/int/op-on-exprs/sum? n) #f ctxt))) (list )) ; Test: gather any immediate child of a "sum" node (check-equal? - (collect (add (sum (sing (sum (sing (int 1))))) (int 5)) + (collect (add/func (sum/func (sing/func (sum/func (sing/func (int/func 1))))) (int/func 5)) (lambda (n ctxt) (if ctxt n #f)) #:order 'pre-order #:context #f - #:get-new-context (lambda (n ctxt) (if (node/int/op/sum? n) #t #f))) - (list (sing (sum (sing (int 1)))) - (sing (int 1)))) + #:get-new-context (lambda (n ctxt) (if (node/int/op-on-exprs/sum? n) #t #f))) + (list (sing/func (sum/func (sing/func (int/func 1)))) + (sing/func (int/func 1)))) ) \ No newline at end of file diff --git a/forge/utils/identity.rkt b/forge/utils/identity.rkt index 7e545538..3ef21196 100644 --- a/forge/utils/identity.rkt +++ b/forge/utils/identity.rkt @@ -32,8 +32,8 @@ (node/formula/constant info type)] [(node/fmla/pred-spacer info name args expanded) (interpret-formula run-or-state expanded relations atom-names quantvars)] - [(node/formula/op info args) - (interpret-formula-op run-or-state formula relations atom-names quantvars args)] + [(? node/formula/op?) + (interpret-formula-op run-or-state formula relations atom-names quantvars (node/formula/op-children formula))] [(node/formula/multiplicity info mult expr) (let ([processed-expr (interpret-expr run-or-state expr relations atom-names quantvars)]) (node/formula/multiplicity info mult processed-expr))] @@ -70,44 +70,44 @@ (when (@>= (get-verbosity) 2) (printf "identity: interpret-formula-op: ~a~n" formula)) (match formula - [(node/formula/op/&& info children) - (node/formula/op/&& info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/|| info children) - (node/formula/op/|| info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/=> info children) - (node/formula/op/=> info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/always info children) - (node/formula/op/always info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/eventually info children) - (node/formula/op/eventually info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/next_state info children) - (node/formula/op/next_state info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/releases info children) - (node/formula/op/releases info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/until info children) - (node/formula/op/until info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/historically info children) - (node/formula/op/historically info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/once info children) - (node/formula/op/once info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/prev_state info children) - (node/formula/op/prev_state info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/since info children) - (node/formula/op/since info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/triggered info children) - (node/formula/op/triggered info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/in info children) - (node/formula/op/in info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/formula/op/= info children) - (node/formula/op/= info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/formula/op/! info children) - (node/formula/op/! info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/int> info children) - (node/formula/op/int> info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/formula/op/int< info children) - (node/formula/op/int< info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/formula/op/int= info children) - (node/formula/op/int= info (process-children-int run-or-state args relations atom-names quantvars))])) + [(node/formula/op-on-formulas/&& info children) + (node/formula/op-on-formulas/&& info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/|| info children) + (node/formula/op-on-formulas/|| info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/=> info children) + (node/formula/op-on-formulas/=> info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/always info children) + (node/formula/op-on-formulas/always info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/eventually info children) + (node/formula/op-on-formulas/eventually info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/next_state info children) + (node/formula/op-on-formulas/next_state info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/releases info children) + (node/formula/op-on-formulas/releases info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/until info children) + (node/formula/op-on-formulas/until info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/historically info children) + (node/formula/op-on-formulas/historically info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/once info children) + (node/formula/op-on-formulas/once info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/prev_state info children) + (node/formula/op-on-formulas/prev_state info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/since info children) + (node/formula/op-on-formulas/since info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/triggered info children) + (node/formula/op-on-formulas/triggered info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-exprs/in info children) + (node/formula/op-on-exprs/in info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-exprs/= info children) + (node/formula/op-on-exprs/= info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/! info children) + (node/formula/op-on-formulas/! info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-ints/int> info children) + (node/formula/op-on-ints/int> info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-ints/int< info children) + (node/formula/op-on-ints/int< info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-ints/int= info children) + (node/formula/op-on-ints/int= info (process-children-int run-or-state args relations atom-names quantvars))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Relational expressions @@ -132,8 +132,8 @@ (node/expr/constant info 1 'Int)] [(node/expr/constant info arity type) (node/expr/constant info arity type)] - [(node/expr/op info arity args) - (interpret-expr-op run-or-state expr relations atom-names quantvars args)] + [(? node/expr/op? op) + (interpret-expr-op run-or-state expr relations atom-names quantvars (node/expr/op-children op))] [(node/expr/quantifier-var info arity sym name) (node/expr/quantifier-var info arity sym name)] [(node/expr/comprehension info len decls form) @@ -155,28 +155,28 @@ (when (@>= (get-verbosity) 2) (printf "identity: interpret-expr-op: ~a~n" expr)) (match expr - [(node/expr/op/+ info arity children) - (node/expr/op/+ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/- info arity children) - (node/expr/op/- info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/& info arity children) - (node/expr/op/& info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/-> info arity children) - (node/expr/op/-> info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/prime info arity children) - (node/expr/op/prime info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/join info arity children) - (node/expr/op/join info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/^ info arity children) - (node/expr/op/^ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/* info arity children) - (node/expr/op/* info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/~ info arity children) - (node/expr/op/~ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/++ info arity children) - (node/expr/op/++ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/sing info arity children) - (node/expr/op/sing info arity (process-children-int run-or-state args relations atom-names quantvars))])) + [(node/expr/op-on-exprs/+ info arity children) + (node/expr/op-on-exprs/+ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/- info arity children) + (node/expr/op-on-exprs/- info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/& info arity children) + (node/expr/op-on-exprs/& info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/-> info arity children) + (node/expr/op-on-exprs/-> info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/prime info arity children) + (node/expr/op-on-exprs/prime info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/join info arity children) + (node/expr/op-on-exprs/join info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/^ info arity children) + (node/expr/op-on-exprs/^ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/* info arity children) + (node/expr/op-on-exprs/* info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/~ info arity children) + (node/expr/op-on-exprs/~ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/++ info arity children) + (node/expr/op-on-exprs/++ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-ints/sing info arity children) + (node/expr/op-on-ints/sing info arity (process-children-int run-or-state args relations atom-names quantvars))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Integer expressions @@ -188,8 +188,8 @@ (match expr [(node/int/constant info value) (node/int/constant info value)] - [(node/int/op info args) - (interpret-int-op run-or-state expr relations atom-names quantvars args)] + [(? node/int/op? op) + (interpret-int-op run-or-state expr relations atom-names quantvars (node/int/op-children op))] [(node/int/sum-quant info decls int-expr) (define new-vs-and-decls (for/fold ([vs-and-decls (list quantvars '())]) @@ -209,24 +209,24 @@ (when (@>= (get-verbosity) 2) (printf "identity: interpret-int-op: ~a~n" expr)) (match expr - [(node/int/op/add info children) - (node/int/op/add info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/subtract info children) - (node/int/op/subtract info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/multiply info children) - (node/int/op/multiply info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/divide info children) - (node/int/op/divide info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/sum info children) - (node/int/op/sum info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/int/op/card info children) - (node/int/op/card info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/int/op/remainder info children) - (node/int/op/remainder info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/abs info children) - (node/int/op/abs info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/sign info children) - (node/int/op/sign info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/add info children) + (node/int/op-on-ints/add info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/subtract info children) + (node/int/op-on-ints/subtract info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/multiply info children) + (node/int/op-on-ints/multiply info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/divide info children) + (node/int/op-on-ints/divide info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-exprs/sum info children) + (node/int/op-on-exprs/sum info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/int/op-on-exprs/card info children) + (node/int/op-on-exprs/card info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/remainder info children) + (node/int/op-on-ints/remainder info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/abs info children) + (node/int/op-on-ints/abs info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/sign info children) + (node/int/op-on-ints/sign info (process-children-int run-or-state args relations atom-names quantvars))] [(node/int/sum-quant info decls int-expr) (raise-forge-error #:msg "Reached expected unreachable code." #:context expr)] )) diff --git a/forge/utils/integer-converter.rkt b/forge/utils/integer-converter.rkt index 5b0d8470..d4d81744 100644 --- a/forge/utils/integer-converter.rkt +++ b/forge/utils/integer-converter.rkt @@ -35,8 +35,8 @@ (node/formula/constant info type)] [(node/fmla/pred-spacer info name args expanded) (interpret-formula run-or-state expanded relations atom-names quantvars)] - [(node/formula/op info args) - (interpret-formula-op run-or-state formula relations atom-names quantvars args)] + [(? node/formula/op?) + (interpret-formula-op run-or-state formula relations atom-names quantvars (node/formula/op-children formula))] [(node/formula/multiplicity info mult expr) (let ([processed-expr (interpret-expr run-or-state expr relations atom-names quantvars)]) (node/formula/multiplicity info mult processed-expr))] @@ -160,11 +160,11 @@ ; Use the collector for this. ; Collector lambda should return non-int-op nodes, since we're looking for relational->int ops. ; 7/17 - We don't want to stop on, or collect, 'sing' nodes - (define collector-lambda (lambda (n ctxt) (if (and (not (node/expr/op/sing? n)) (not (node/int? n))) n #f))) + (define collector-lambda (lambda (n ctxt) (if (and (not (node/expr/op-on-ints/sing? n)) (not (node/int? n))) n #f))) ; The collector also requires a stopping lambda, which should stop at the same condition as when we collect. ; This is because supposed we had sign[sum[join[sum x, y]]], we would want to stop at the join, ; since recursive descent will have already unwrapped the inner x and y. - (define stopping-lambda (lambda (n ctxt) (if (or (node/expr/op/sing? n) (node/int? n)) #f #t))) + (define stopping-lambda (lambda (n ctxt) (if (or (node/expr/op-on-ints/sing? n) (node/int? n)) #f #t))) ; Context? Not entirely sure (define lhs-relational-exprs (collect lhs collector-lambda #:order 'pre-order #:stop stopping-lambda)) (define rhs-relational-exprs (collect rhs collector-lambda #:order 'pre-order #:stop stopping-lambda)) @@ -183,12 +183,12 @@ (for/fold ([substituted-expr lhs]) ([rel-expr lhs-relational-exprs] [new-quantifier lhs-quantifiers]) (substitute-ambig run-or-state substituted-expr relations atom-names - quantvars (node/int/op/sum (node-info rel-expr) (list rel-expr)) new-quantifier)))) + quantvars (node/int/op-on-exprs/sum (node-info rel-expr) (list rel-expr)) new-quantifier)))) (define rhs-substituted (if (equal? rhs-relational-exprs '()) rhs (for/fold ([substituted-expr rhs]) ([rel-expr rhs-relational-exprs] [new-quantifier rhs-quantifiers]) (substitute-ambig run-or-state substituted-expr relations atom-names - quantvars (node/int/op/sum (node-info rel-expr) (list rel-expr)) new-quantifier)))) + quantvars (node/int/op-on-exprs/sum (node-info rel-expr) (list rel-expr)) new-quantifier)))) (define int-flag true) ; if both sides of the equality are equal to the empty list, both the 'in' and '=' case should NOT contain annotated-info. @@ -199,17 +199,17 @@ ; (4) Assemble a quantified formula, over those variables, with domain Int, with body ; a conjunction of (v1 = expr1) and ... and (vk = exprk) and subst(LHS) (operator) SUBST(RHS) (define lhs-equality-formulas (for/list ([lhs-quant lhs-quantifiers] [lhs-expr lhs-relational-exprs]) - (node/formula/op/= info (list lhs-quant lhs-expr)))) + (node/formula/op-on-exprs/= info (list lhs-quant lhs-expr)))) (define rhs-equality-formulas (for/list ([rhs-quant rhs-quantifiers] [rhs-expr rhs-relational-exprs]) - (node/formula/op/= info (list rhs-quant rhs-expr)))) + (node/formula/op-on-exprs/= info (list rhs-quant rhs-expr)))) (define new-fmla (match form - [(? node/formula/op/int? form) (node/formula/op/int> (if int-flag annotated-info info) (list lhs-substituted rhs-substituted))] - [(? node/formula/op/=? form) (node/formula/op/= (if int-flag annotated-info info) (list lhs-substituted rhs-substituted))] - [(? node/formula/op/in? form) (node/formula/op/in (if int-flag annotated-info info) (list lhs-substituted rhs-substituted))] + [(? node/formula/op-on-ints/int? form) (node/formula/op-on-ints/int> (if int-flag annotated-info info) (list lhs-substituted rhs-substituted))] + [(? node/formula/op-on-exprs/=? form) (node/formula/op-on-exprs/= (if int-flag annotated-info info) (list lhs-substituted rhs-substituted))] + [(? node/formula/op-on-exprs/in? form) (node/formula/op-on-exprs/in (if int-flag annotated-info info) (list lhs-substituted rhs-substituted))] ) ) @@ -221,7 +221,7 @@ (if (equal? var-int-pairs '()) new-fmla (node/formula/quantified info 'some var-int-pairs - (node/formula/op/&& info (cons new-fmla (append lhs-equality-formulas rhs-equality-formulas)))) + (node/formula/op-on-formulas/&& info (cons new-fmla (append lhs-equality-formulas rhs-equality-formulas)))) ) ) @@ -229,44 +229,44 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "integer-converter: interpret-formula-op: ~a~n" formula)) (match formula - [(node/formula/op/&& info children) - (node/formula/op/&& info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/|| info children) - (node/formula/op/|| info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/=> info children) - (node/formula/op/=> info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/always info children) - (node/formula/op/always info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/eventually info children) - (node/formula/op/eventually info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/next_state info children) - (node/formula/op/next_state info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/releases info children) - (node/formula/op/releases info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/until info children) - (node/formula/op/until info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/historically info children) - (node/formula/op/historically info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/once info children) - (node/formula/op/once info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/prev_state info children) - (node/formula/op/prev_state info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/since info children) - (node/formula/op/since info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/triggered info children) - (node/formula/op/triggered info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/in info children) - (node/formula/op/in info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/formula/op/= info children) - (node/formula/op/= info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/formula/op/! info children) - (node/formula/op/! info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/int> info children) - (reconcile-integer-expr run-or-state args relations atom-names quantvars info (node/formula/op/int> info children))] - [(node/formula/op/int< info children) - (reconcile-integer-expr run-or-state args relations atom-names quantvars info (node/formula/op/int< info children))] - [(node/formula/op/int= info children) - (reconcile-integer-expr run-or-state args relations atom-names quantvars info (node/formula/op/int= info children))])) + [(node/formula/op-on-formulas/&& info children) + (node/formula/op-on-formulas/&& info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/|| info children) + (node/formula/op-on-formulas/|| info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/=> info children) + (node/formula/op-on-formulas/=> info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/always info children) + (node/formula/op-on-formulas/always info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/eventually info children) + (node/formula/op-on-formulas/eventually info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/next_state info children) + (node/formula/op-on-formulas/next_state info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/releases info children) + (node/formula/op-on-formulas/releases info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/until info children) + (node/formula/op-on-formulas/until info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/historically info children) + (node/formula/op-on-formulas/historically info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/once info children) + (node/formula/op-on-formulas/once info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/prev_state info children) + (node/formula/op-on-formulas/prev_state info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/since info children) + (node/formula/op-on-formulas/since info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/triggered info children) + (node/formula/op-on-formulas/triggered info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-exprs/in info children) + (node/formula/op-on-exprs/in info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-exprs/= info children) + (node/formula/op-on-exprs/= info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/! info children) + (node/formula/op-on-formulas/! info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-ints/int> info children) + (reconcile-integer-expr run-or-state args relations atom-names quantvars info (node/formula/op-on-ints/int> info children))] + [(node/formula/op-on-ints/int< info children) + (reconcile-integer-expr run-or-state args relations atom-names quantvars info (node/formula/op-on-ints/int< info children))] + [(node/formula/op-on-ints/int= info children) + (reconcile-integer-expr run-or-state args relations atom-names quantvars info (node/formula/op-on-ints/int= info children))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Relational expressions @@ -291,8 +291,8 @@ (node/expr/constant info 1 'Int)] [(node/expr/constant info arity type) (node/expr/constant info arity type)] - [(node/expr/op info arity args) - (interpret-expr-op run-or-state expr relations atom-names quantvars args)] + [(? node/expr/op? op) + (interpret-expr-op run-or-state expr relations atom-names quantvars (node/expr/op-children op))] [(node/expr/quantifier-var info arity sym name) (node/expr/quantifier-var info arity sym name)] [(node/expr/comprehension info len decls form) @@ -314,28 +314,28 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "integer-converter: interpret-expr-op: ~a~n" expr)) (match expr - [(node/expr/op/+ info arity children) - (node/expr/op/+ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/- info arity children) - (node/expr/op/- info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/& info arity children) - (node/expr/op/& info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/-> info arity children) - (node/expr/op/-> info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/prime info arity children) - (node/expr/op/prime info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/join info arity children) - (node/expr/op/join info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/^ info arity children) - (node/expr/op/^ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/* info arity children) - (node/expr/op/* info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/~ info arity children) - (node/expr/op/~ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/++ info arity children) - (node/expr/op/++ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/sing info arity children) - (node/expr/op/sing info arity (process-children-int run-or-state args relations atom-names quantvars))])) + [(node/expr/op-on-exprs/+ info arity children) + (node/expr/op-on-exprs/+ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/- info arity children) + (node/expr/op-on-exprs/- info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/& info arity children) + (node/expr/op-on-exprs/& info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/-> info arity children) + (node/expr/op-on-exprs/-> info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/prime info arity children) + (node/expr/op-on-exprs/prime info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/join info arity children) + (node/expr/op-on-exprs/join info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/^ info arity children) + (node/expr/op-on-exprs/^ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/* info arity children) + (node/expr/op-on-exprs/* info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/~ info arity children) + (node/expr/op-on-exprs/~ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/++ info arity children) + (node/expr/op-on-exprs/++ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-ints/sing info arity children) + (node/expr/op-on-ints/sing info arity (process-children-int run-or-state args relations atom-names quantvars))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Integer expressions @@ -347,8 +347,8 @@ (match expr [(node/int/constant info value) (node/int/constant info value)] - [(node/int/op info args) - (interpret-int-op run-or-state expr relations atom-names quantvars args)] + [(? node/int/op? op) + (interpret-int-op run-or-state expr relations atom-names quantvars (node/int/op-children op))] [(node/int/sum-quant info decls int-expr) (define new-vs-and-decls (for/fold ([vs-and-decls (list quantvars '())]) @@ -368,24 +368,24 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "integer-converter: interpret-int-op: ~a~n" expr)) (match expr - [(node/int/op/add info children) - (node/int/op/add info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/subtract info children) - (node/int/op/subtract info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/multiply info children) - (node/int/op/multiply info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/divide info children) - (node/int/op/divide info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/sum info children) - (node/int/op/sum info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/int/op/card info children) - (node/int/op/card info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/int/op/remainder info children) - (node/int/op/remainder info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/abs info children) - (node/int/op/abs info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/sign info children) - (node/int/op/sign info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/add info children) + (node/int/op-on-ints/add info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/subtract info children) + (node/int/op-on-ints/subtract info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/multiply info children) + (node/int/op-on-ints/multiply info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/divide info children) + (node/int/op-on-ints/divide info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-exprs/sum info children) + (node/int/op-on-exprs/sum info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/int/op-on-exprs/card info children) + (node/int/op-on-exprs/card info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/remainder info children) + (node/int/op-on-ints/remainder info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/abs info children) + (node/int/op-on-ints/abs info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/sign info children) + (node/int/op-on-ints/sign info (process-children-int run-or-state args relations atom-names quantvars))] [(node/int/sum-quant info decls int-expr) (raise-forge-error #:msg "Reached expected unreachable code." #:context expr)] )) diff --git a/forge/utils/quantifier-grounding.rkt b/forge/utils/quantifier-grounding.rkt index aeb5ba6b..42395998 100644 --- a/forge/utils/quantifier-grounding.rkt +++ b/forge/utils/quantifier-grounding.rkt @@ -38,8 +38,8 @@ (node/formula/constant info type)] [(node/fmla/pred-spacer info name args expanded) formula] - [(node/formula/op info args) - (interpret-formula-op run-or-state formula relations atom-names quantvars quantvar-types args bounds)] + [(? node/formula/op?) + (interpret-formula-op run-or-state formula relations atom-names quantvars quantvar-types (node/formula/op-children formula) bounds)] [(node/formula/multiplicity info mult expr) (let ([processed-expr (interpret-expr run-or-state expr relations atom-names quantvars quantvar-types bounds)]) (node/formula/multiplicity info mult processed-expr))] @@ -109,7 +109,7 @@ ) (define inner-formula-list (inner-formula-recursive-helper vars-atoms (list new-inner-form))) - (define and-node (node/formula/op/&& info inner-formula-list)) + (define and-node (node/formula/op-on-formulas/&& info inner-formula-list)) and-node ) @@ -133,44 +133,44 @@ (when (@>= (get-verbosity) 2) (printf "quantifier-grounding: interpret-formula-op: ~a~n" formula)) (match formula - [(node/formula/op/&& info children) - (node/formula/op/&& info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/|| info children) - (node/formula/op/|| info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/=> info children) - (node/formula/op/=> info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/always info children) - (node/formula/op/always info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/eventually info children) - (node/formula/op/eventually info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/next_state info children) - (node/formula/op/next_state info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/releases info children) - (node/formula/op/releases info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/until info children) - (node/formula/op/until info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/historically info children) - (node/formula/op/historically info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/once info children) - (node/formula/op/once info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/prev_state info children) - (node/formula/op/prev_state info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/since info children) - (node/formula/op/since info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/triggered info children) - (node/formula/op/triggered info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/in info children) - (node/formula/op/in info (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/= info children) - (node/formula/op/= info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/! info children) - (node/formula/op/! info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/int> info children) - (node/formula/op/int> info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/int< info children) - (node/formula/op/int< info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/formula/op/int= info children) - (node/formula/op/int= info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))])) + [(node/formula/op-on-formulas/&& info children) + (node/formula/op-on-formulas/&& info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/|| info children) + (node/formula/op-on-formulas/|| info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/=> info children) + (node/formula/op-on-formulas/=> info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/always info children) + (node/formula/op-on-formulas/always info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/eventually info children) + (node/formula/op-on-formulas/eventually info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/next_state info children) + (node/formula/op-on-formulas/next_state info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/releases info children) + (node/formula/op-on-formulas/releases info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/until info children) + (node/formula/op-on-formulas/until info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/historically info children) + (node/formula/op-on-formulas/historically info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/once info children) + (node/formula/op-on-formulas/once info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/prev_state info children) + (node/formula/op-on-formulas/prev_state info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/since info children) + (node/formula/op-on-formulas/since info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/triggered info children) + (node/formula/op-on-formulas/triggered info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-exprs/in info children) + (node/formula/op-on-exprs/in info (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-exprs/= info children) + (node/formula/op-on-exprs/= info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-formulas/! info children) + (node/formula/op-on-formulas/! info (process-children-formula run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-ints/int> info children) + (node/formula/op-on-ints/int> info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-ints/int< info children) + (node/formula/op-on-ints/int< info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/formula/op-on-ints/int= info children) + (node/formula/op-on-ints/int= info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Relational expressions @@ -195,8 +195,8 @@ (node/expr/constant info 1 'Int)] [(node/expr/constant info arity type) (node/expr/constant info arity type)] - [(node/expr/op info arity args) - (interpret-expr-op run-or-state expr relations atom-names quantvars quantvar-types args bounds)] + [(? node/expr/op? op) + (interpret-expr-op run-or-state expr relations atom-names quantvars quantvar-types (node/expr/op-children op) bounds)] [(node/expr/quantifier-var info arity sym name) (node/expr/quantifier-var info arity sym name)] [(node/expr/comprehension info len decls form) @@ -218,28 +218,28 @@ (when (@>= (get-verbosity) 2) (printf "quantifier-grounding: interpret-expr-op: ~a~n" expr)) (match expr - [(node/expr/op/+ info arity children) - (node/expr/op/+ info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/- info arity children) - (node/expr/op/- info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/& info arity children) - (node/expr/op/& info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/-> info arity children) - (node/expr/op/-> info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/prime info arity children) - (node/expr/op/prime info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/join info arity children) - (node/expr/op/join info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/^ info arity children) - (node/expr/op/^ info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/* info arity children) - (node/expr/op/* info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/~ info arity children) - (node/expr/op/~ info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/++ info arity children) - (node/expr/op/++ info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/expr/op/sing info arity children) - (node/expr/op/sing info arity (process-children-int run-or-state args relations atom-names quantvars quantvar-types bounds))])) + [(node/expr/op-on-exprs/+ info arity children) + (node/expr/op-on-exprs/+ info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/- info arity children) + (node/expr/op-on-exprs/- info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/& info arity children) + (node/expr/op-on-exprs/& info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/-> info arity children) + (node/expr/op-on-exprs/-> info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/prime info arity children) + (node/expr/op-on-exprs/prime info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/join info arity children) + (node/expr/op-on-exprs/join info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/^ info arity children) + (node/expr/op-on-exprs/^ info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/* info arity children) + (node/expr/op-on-exprs/* info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/~ info arity children) + (node/expr/op-on-exprs/~ info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-exprs/++ info arity children) + (node/expr/op-on-exprs/++ info arity (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/expr/op-on-ints/sing info arity children) + (node/expr/op-on-ints/sing info arity (process-children-int run-or-state args relations atom-names quantvars quantvar-types bounds))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Integer expressions @@ -251,8 +251,8 @@ (match expr [(node/int/constant info value) (node/int/constant info value)] - [(node/int/op info args) - (interpret-int-op run-or-state expr relations atom-names quantvars quantvar-types args bounds)] + [(? node/int/op? op) + (interpret-int-op run-or-state expr relations atom-names quantvars quantvar-types (node/int/op-children op) bounds)] [(node/int/sum-quant info decls int-expr) (define new-vs-and-decls (for/fold ([vs-and-decls (list quantvars '())]) @@ -272,24 +272,24 @@ (when (@>= (get-verbosity) 2) (printf "quantifier-grounding: interpret-int-op: ~a~n" expr)) (match expr - [(node/int/op/add info children) - (node/int/op/add info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/subtract info children) - (node/int/op/subtract info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/multiply info children) - (node/int/op/multiply info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/divide info children) - (node/int/op/divide info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/sum info children) - (node/int/op/sum info (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/card info children) - (node/int/op/card info (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/remainder info children) - (node/int/op/remainder info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/abs info children) - (node/int/op/abs info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] - [(node/int/op/sign info children) - (node/int/op/sign info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-ints/add info children) + (node/int/op-on-ints/add info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-ints/subtract info children) + (node/int/op-on-ints/subtract info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-ints/multiply info children) + (node/int/op-on-ints/multiply info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-ints/divide info children) + (node/int/op-on-ints/divide info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-exprs/sum info children) + (node/int/op-on-exprs/sum info (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-exprs/card info children) + (node/int/op-on-exprs/card info (process-children-expr run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-ints/remainder info children) + (node/int/op-on-ints/remainder info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-ints/abs info children) + (node/int/op-on-ints/abs info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] + [(node/int/op-on-ints/sign info children) + (node/int/op-on-ints/sign info (process-children-ambiguous run-or-state args relations atom-names quantvars quantvar-types bounds))] [(node/int/sum-quant info decls int-expr) (raise-forge-error #:msg "Reached expected unreachable code." #:context expr)] )) diff --git a/forge/utils/substitutor.rkt b/forge/utils/substitutor.rkt index 9df03720..19f6ee54 100644 --- a/forge/utils/substitutor.rkt +++ b/forge/utils/substitutor.rkt @@ -1,15 +1,13 @@ -#lang racket/base +#lang typed/racket/base/optional -; This file is intended to take in the Forge AST and return an identity translation of it. +; This file performs variable substitution in Forge AST nodes. -(require - forge/sigs-structs - forge/lang/ast +(require + forge/types/ast-adapter + forge/types/sigs-structs-adapter forge/shared - (only-in racket index-of match string-join first second rest) - (only-in racket/contract define/contract or/c listof any/c) - (prefix-in @ (only-in racket/contract ->)) - (prefix-in @ (only-in racket/base >=))) + (only-in typed/racket match first second rest cons append list) + (prefix-in @ (only-in typed/racket >=))) (provide substitute-formula substitute-ambig) @@ -20,30 +18,25 @@ ; Translate a formula AST node ; target - the node to be replaced ; value - the node to replace the target with -(define/contract (substitute-formula run-or-state formula relations atom-names quantvars target value) - (@-> (or/c Run? State? Run-spec?) - node/formula? - list? - list? - list? - node? - node? - node?) +; relations and atom-names are currently unused (dead parameters) +; Types: relations = (Listof node/expr/relation), atom-names = (Listof FAtom) +(: substitute-formula (-> (U Run State Run-spec) node/formula (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) node node node/formula)) +(define (substitute-formula run-or-state formula relations atom-names quantvars target value) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "substitutor: interpret-formula: ~a~n" formula)) (match formula [(node/formula/constant info type) - (if (equal? formula target) value formula)] + (if (equal? formula target) (assert value node/formula?) formula)] [(node/fmla/pred-spacer info name args expanded) (substitute-formula run-or-state expanded relations atom-names quantvars target value)] - [(node/formula/op info args) - (substitute-formula-op run-or-state formula relations atom-names quantvars args target value)] + [(? node/formula/op?) + (substitute-formula-op run-or-state formula relations atom-names quantvars (node/formula/op-children formula) target value)] [(node/formula/multiplicity info mult expr) (let ([processed-expr (substitute-expr run-or-state expr relations atom-names quantvars target value)]) (node/formula/multiplicity info mult processed-expr))] [(node/formula/quantified info quantifier decls form) (define new-vs-and-decls - (for/fold ([vs-and-decls (list quantvars '())]) + (for/fold ([vs-and-decls : (List (Listof node/expr/quantifier-var) (Listof Decl)) (list quantvars '())]) ([decl decls]) (define curr-quantvars (first vs-and-decls)) (define curr-decls (second vs-and-decls)) @@ -61,87 +54,94 @@ [#f "false"] )) +(: process-children-formula (-> (U Run State Run-spec) (Listof node) (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) node node (Listof node/formula))) (define (process-children-formula run-or-state children relations atom-names quantvars target value) - (map (lambda (x) (substitute-formula run-or-state x relations atom-names quantvars target value)) children)) + (map (lambda ([x : node]) (substitute-formula run-or-state (assert x node/formula?) relations atom-names quantvars target value)) children)) +(: process-children-expr (-> (U Run State Run-spec) (Listof node) (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) node node (Listof node/expr))) (define (process-children-expr run-or-state children relations atom-names quantvars target value) - (map (lambda (x) (substitute-expr run-or-state x relations atom-names quantvars target value)) children)) + (map (lambda ([x : node]) (substitute-expr run-or-state (assert x node/expr?) relations atom-names quantvars target value)) children)) +(: process-children-int (-> (U Run State Run-spec) (Listof node) (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) node node (Listof node/int))) (define (process-children-int run-or-state children relations atom-names quantvars target value) - (map (lambda (x) (substitute-int run-or-state x relations atom-names quantvars target value)) children)) + (map (lambda ([x : node]) (substitute-int run-or-state (assert x node/int?) relations atom-names quantvars target value)) children)) +(: process-children-ambiguous (-> (U Run State Run-spec) (Listof node) (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) node node (Listof node))) (define (process-children-ambiguous run-or-state children relations atom-names quantvars target value) - (for/list ([child children]) + (for/list : (Listof node) ([child : node children]) (match child [(? node/formula? f) (substitute-formula run-or-state f relations atom-names quantvars target value)] [(? node/expr? e) (substitute-expr run-or-state e relations atom-names quantvars target value)] [(? node/int? i) (substitute-int run-or-state i relations atom-names quantvars target value)]))) +(: substitute-ambig (-> (U Run State Run-spec) node (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) node node node)) (define (substitute-ambig run-or-state formula relations atom-names quantvars target value) - (match formula + (match formula [(? node/formula? f) (substitute-formula run-or-state f relations atom-names quantvars target value)] [(? node/expr? e) (substitute-expr run-or-state e relations atom-names quantvars target value)] - [(? node/int? i) (substitute-int run-or-state i relations atom-names quantvars target value)] - ) -) + [(? node/int? i) (substitute-int run-or-state i relations atom-names quantvars target value)])) +(: substitute-formula-op (-> (U Run State Run-spec) node/formula/op (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) (Listof node) node node node/formula)) (define (substitute-formula-op run-or-state formula relations atom-names quantvars args target value) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "substitutor: interpret-formula-op: ~a~n" formula)) + ; Use the info from the formula and the args parameter for children + (define info (node-info formula)) (match formula - [(node/formula/op/&& info children) - (node/formula/op/&& info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/|| info children) - (node/formula/op/|| info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/=> info children) - (node/formula/op/=> info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/always info children) - (node/formula/op/always info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/eventually info children) - (node/formula/op/eventually info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/next_state info children) - (node/formula/op/next_state info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/releases info children) - (node/formula/op/releases info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/until info children) - (node/formula/op/until info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/historically info children) - (node/formula/op/historically info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/once info children) - (node/formula/op/once info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/prev_state info children) - (node/formula/op/prev_state info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/since info children) - (node/formula/op/since info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/triggered info children) - (node/formula/op/triggered info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/in info children) - (node/formula/op/in info (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/= info children) - (node/formula/op/= info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/! info children) - (node/formula/op/! info (process-children-formula run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/int> info children) - (node/formula/op/int> info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/int< info children) - (node/formula/op/int< info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/formula/op/int= info children) - (node/formula/op/int= info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))])) + [(? node/formula/op-on-formulas/&&?) + (node/formula/op-on-formulas/&& info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/||?) + (node/formula/op-on-formulas/|| info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/=>?) + (node/formula/op-on-formulas/=> info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/always?) + (node/formula/op-on-formulas/always info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/eventually?) + (node/formula/op-on-formulas/eventually info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/next_state?) + (node/formula/op-on-formulas/next_state info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/releases?) + (node/formula/op-on-formulas/releases info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/until?) + (node/formula/op-on-formulas/until info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/historically?) + (node/formula/op-on-formulas/historically info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/once?) + (node/formula/op-on-formulas/once info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/prev_state?) + (node/formula/op-on-formulas/prev_state info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/since?) + (node/formula/op-on-formulas/since info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/triggered?) + (node/formula/op-on-formulas/triggered info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-exprs/in?) + (node/formula/op-on-exprs/in info (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-exprs/=?) + (node/formula/op-on-exprs/= info (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-formulas/!?) + (node/formula/op-on-formulas/! info (process-children-formula run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-ints/int>?) + (node/formula/op-on-ints/int> info (process-children-int run-or-state args relations atom-names quantvars target value))] + [(? node/formula/op-on-ints/int (U Run State Run-spec) node/expr (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) node node node/expr)) (define (substitute-expr run-or-state expr relations atom-names quantvars target value) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "substitutor: interpret-expr: ~a~n" expr)) (if (equal? expr target) - value + (assert value node/expr?) (match expr [(node/expr/relation info arity name typelist-thunk parent isvar) - (if (equal? expr target) value expr)] + expr] ; Already checked target above [(node/expr/atom info arity name) - (if (equal? expr target) value expr)] + expr] ; Already checked target above [(node/expr/fun-spacer info arity name args result expanded) (let ([new-expanded (substitute-expr run-or-state expanded relations atom-names quantvars target value)]) (node/expr/fun-spacer info arity name args result new-expanded))] @@ -151,16 +151,16 @@ [processed-c (substitute-expr run-or-state c relations atom-names quantvars target value)]) (node/expr/ite info arity processed-a processed-b processed-c))] [(node/expr/constant info 1 'Int) - (if (equal? expr target) value expr)] + expr] ; Already checked target above [(node/expr/constant info arity type) - (if (equal? expr target) value expr)] - [(node/expr/op info arity args) - (substitute-expr-op run-or-state expr relations atom-names quantvars args target value)] - [(node/expr/quantifier-var info arity sym name) - (if (equal? expr target) value expr)] - [(node/expr/comprehension info len decls form) + expr] ; Already checked target above + [(? node/expr/op?) + (substitute-expr-op run-or-state expr relations atom-names quantvars (node/expr/op-children expr) target value)] + [(node/expr/quantifier-var info arity sym name) + expr] ; Already checked target above + [(node/expr/comprehension info len decls form) (define new-vs-and-decls - (for/fold ([vs-and-decls (list quantvars '())]) + (for/fold ([vs-and-decls : (List (Listof node/expr/quantifier-var) (Listof Decl)) (list quantvars '())]) ([decl decls]) (define curr-quantvars (first vs-and-decls)) (define curr-decls (second vs-and-decls)) @@ -173,87 +173,96 @@ (define new-decls (second new-vs-and-decls)) (node/expr/comprehension info len new-decls processed-form))]))) +(: substitute-expr-op (-> (U Run State Run-spec) node/expr/op (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) (Listof node) node node node/expr)) (define (substitute-expr-op run-or-state expr relations atom-names quantvars args target value) - (when (@>= (get-verbosity) VERBOSITY_DEBUG) - (printf "substitutor: interpret-expr-op: ~a~n" expr)) + (when (@>= (get-verbosity) VERBOSITY_DEBUG) + (printf "substitutor: interpret-expr-op: ~a~n" expr)) + ; Use accessors for info and arity + (define info (node-info expr)) + (define arity (node/expr-arity expr)) (match expr - [(node/expr/op/+ info arity children) - (node/expr/op/+ info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/- info arity children) - (node/expr/op/- info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/& info arity children) - (node/expr/op/& info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/-> info arity children) - (node/expr/op/-> info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/prime info arity children) - (node/expr/op/prime info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/join info arity children) - (node/expr/op/join info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/^ info arity children) - (node/expr/op/^ info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/* info arity children) - (node/expr/op/* info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/~ info arity children) - (node/expr/op/~ info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/++ info arity children) - (node/expr/op/++ info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/expr/op/sing info arity children) - (if (equal? (car children) target) value - (node/expr/op/sing info arity (process-children-ambiguous run-or-state args relations atom-names quantvars target value)))])) + [(? node/expr/op-on-exprs/+?) + (node/expr/op-on-exprs/+ info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/-?) + (node/expr/op-on-exprs/- info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/&?) + (node/expr/op-on-exprs/& info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/->?) + (node/expr/op-on-exprs/-> info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/prime?) + (node/expr/op-on-exprs/prime info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/join?) + (node/expr/op-on-exprs/join info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/^?) + (node/expr/op-on-exprs/^ info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/*?) + (node/expr/op-on-exprs/* info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/~?) + (node/expr/op-on-exprs/~ info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-exprs/++?) + (node/expr/op-on-exprs/++ info arity (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/expr/op-on-ints/sing?) + (if (equal? (car args) target) + (assert value node/expr?) + (node/expr/op-on-ints/sing info arity (process-children-int run-or-state args relations atom-names quantvars target value)))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Integer expressions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(: substitute-int (-> (U Run State Run-spec) node/int (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) node node node/int)) (define (substitute-int run-or-state expr relations atom-names quantvars target value) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "substitutor: interpret-int: ~a~n" expr)) ; TEMP fix to match int variables. Should probably modify process-children-int to handle constants. - (if (equal? expr target) value - (match expr - [(node/int/constant info value) - (if (equal? expr target) value expr)] - [(node/int/op info args) - (substitute-int-op run-or-state expr relations atom-names quantvars args target value)] - [(node/int/sum-quant info decls int-expr) - (define new-vs-and-decls - (for/fold ([vs-and-decls (list quantvars '())]) - ([decl decls]) + (if (equal? expr target) + (assert value node/int?) + (match expr + [(node/int/constant info val) + expr] ; Already checked target above + [(? node/int/op?) + (substitute-int-op run-or-state expr relations atom-names quantvars (node/int/op-children expr) target value)] + [(node/int/sum-quant info decls int-expr) + (define new-vs-and-decls + (for/fold ([vs-and-decls : (List (Listof node/expr/quantifier-var) (Listof Decl)) (list quantvars '())]) + ([decl decls]) (define curr-quantvars (first vs-and-decls)) (define curr-decls (second vs-and-decls)) (define new-quantvars (cons (car decl) quantvars)) (define new-decl-domain (substitute-expr run-or-state (cdr decl) relations atom-names new-quantvars target value)) (define new-decls (cons (cons (car decl) new-decl-domain) curr-decls)) (list new-quantvars new-decls))) - (define new-quantvars (first new-vs-and-decls)) - (let ([processed-int (substitute-int run-or-state int-expr relations atom-names new-quantvars target value)]) - (define new-decls (second new-vs-and-decls)) - (node/int/sum-quant info new-decls processed-int))]))) + (define new-quantvars (first new-vs-and-decls)) + (let ([processed-int (substitute-int run-or-state int-expr relations atom-names new-quantvars target value)]) + (define new-decls (second new-vs-and-decls)) + (node/int/sum-quant info new-decls processed-int))]))) +(: substitute-int-op (-> (U Run State Run-spec) node/int/op (Listof node/expr/relation) (Listof FAtom) (Listof node/expr/quantifier-var) (Listof node) node node node/int)) (define (substitute-int-op run-or-state expr relations atom-names quantvars args target value) (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "substitutor: interpret-int-op: ~a~n" expr)) + ; Use accessor for info + (define info (node-info expr)) (match expr - [(node/int/op/add info children) - (node/int/op/add info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/int/op/subtract info children) - (node/int/op/subtract info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/int/op/multiply info children) - (node/int/op/multiply info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/int/op/divide info children) - (node/int/op/divide info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/int/op/sum info children) - (if (equal? expr target) value (node/int/op/sum info (process-children-expr run-or-state args relations atom-names quantvars target value)))] - [(node/int/op/card info children) - (node/int/op/card info (process-children-expr run-or-state args relations atom-names quantvars target value))] - [(node/int/op/remainder info children) - (node/int/op/remainder info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/int/op/abs info children) - (node/int/op/abs info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] - [(node/int/op/sign info children) - (node/int/op/sign info (process-children-ambiguous run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-ints/add?) + (node/int/op-on-ints/add info (process-children-int run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-ints/subtract?) + (node/int/op-on-ints/subtract info (process-children-int run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-ints/multiply?) + (node/int/op-on-ints/multiply info (process-children-int run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-ints/divide?) + (node/int/op-on-ints/divide info (process-children-int run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-exprs/sum?) + (node/int/op-on-exprs/sum info (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-exprs/card?) + (node/int/op-on-exprs/card info (process-children-expr run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-ints/remainder?) + (node/int/op-on-ints/remainder info (process-children-int run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-ints/abs?) + (node/int/op-on-ints/abs info (process-children-int run-or-state args relations atom-names quantvars target value))] + [(? node/int/op-on-ints/sign?) + (node/int/op-on-ints/sign info (process-children-int run-or-state args relations atom-names quantvars target value))] [(node/int/sum-quant info decls int-expr) - (raise-forge-error #:msg "Reached expected unreachable code." #:context expr)] - )) + (raise-forge-error #:msg "Reached expected unreachable code." #:context expr)])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; \ No newline at end of file diff --git a/forge/utils/target-oriented.rkt b/forge/utils/target-oriented.rkt index f15d71bb..9bd8d79e 100644 --- a/forge/utils/target-oriented.rkt +++ b/forge/utils/target-oriented.rkt @@ -1,65 +1,101 @@ -#lang racket/base +#lang typed/racket/base/optional ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Helper module for gadgets related to target-oriented model finding ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require (prefix-in @ (only-in racket/base - +)) - forge/sigs-functional - (only-in forge/lang/ast atom -> + int) racket/list) +;; Import types and typed AST functions from the adapter +(require forge/types/ast-adapter) + +;; Import from sigs-structs (which is typed) +(require forge/sigs-structs) + +;; Typed imports from sigs-functional (untyped module) +(require/typed forge/sigs-functional + [make-sig (->* () (Symbol #:one Boolean #:lone Boolean #:abstract Boolean + #:is-var (U String Boolean) #:in (U Sig False) + #:extends (U Sig False) #:info (U nodeinfo False)) + Sig)] + [make-relation (->* ((U Symbol (Listof Sig))) + ((Listof (U Sig (-> Sig))) + #:is (U node/breaking/break False) + #:is-var (U String Boolean) + #:info (U nodeinfo False)) + Relation)] + [make-inst (-> (Listof Any) Inst)] + [get-sig (-> State Symbol (U Sig False))] + [get-relation (-> State Symbol (U Relation False))] + [Int Sig] + [DEFAULT-BITWIDTH Nonnegative-Integer]) + (provide build-int-opt-gadget) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Integer minimization/optimization ; -; Encode an integer-expression minimization problem as a relation -; minimization problem for Pardinus' target-oriented solver. The strategy +; Encode an integer-expression minimization problem as a relation +; minimization problem for Pardinus' target-oriented solver. The strategy ; works with the help of 3 hidden relations: ; ; (1) A sig `__K_HELPER_ATOM`, which contains exactly 2^{bitwidth} distinct ; new atoms. -; (2) A 2-ary relation `__OPT_K_HELPER` on (Int -> _K_HELPER_ATOM), mapping -; integer values within the current bitwidth to sets of helper atoms. +; (2) A 2-ary relation `__OPT_K_HELPER` on (Int -> _K_HELPER_ATOM), mapping +; integer values within the current bitwidth to sets of helper atoms. ; Each integer maps to a different set that contains the prior int's set -; (if any). The distinct min[Int] maps to the empty set. +; (if any). The distinct min[Int] maps to the empty set. ; (3) A sig `__OPT_K_COUNT_SET`, extending `__K_HELPER_ATOM`. ; ; We then add two new components to the solver problem: ; -; (A) A partial instance `__OPT_K_INST` that exact bounds `__K_HELPER_ATOM` -; and `__OPT_K_COUNT_SET` according to the current bitwidth. We could -; use constraints here, but using a partial instance will be more efficient. +; (A) A partial instance `__OPT_K_INST` that exact bounds `__K_HELPER_ATOM` +; and `__OPT_K_COUNT_SET` according to the current bitwidth. We could +; use constraints here, but using a partial instance will be more efficient. ; (B) A constraint that the contents of `__OPT_K_COUNT_SET` are equal to the join: ; ( . __OPT_K_HELPER) -; where is the minimization target. +; where is the minimization target. ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(: list-helper-atoms (-> Integer Integer (Listof node/expr))) (define (list-helper-atoms kmin kmax) ; E.g., from -8 to +7: `__HELPER0 through `__HELPER15 (build-list (@+ 1 (@- kmax kmin)) - (lambda (v) - (atom (string->symbol (format "__HELPER~a" v)))))) + (lambda ([v : Integer]) + (atom/func (string->symbol (format "__HELPER~a" v)))))) +(: list-helper-tuples (-> Integer Integer (Listof node/expr))) (define (list-helper-tuples kmin kmax) ; E.g., from -8 to +7: (-7 -> `__HELPER0) + (-6 -> (`__HELPER0 + `__HELPER1)) + ... ; min[Int] is represented by the empty set: "no (min[Int]).__OPT_K_HELPER)" holds. (build-list (@- kmax kmin) - (lambda (offset) - (-> (int (@+ kmin offset 1)) + (lambda ([offset : Integer]) + (->/func (sing/func (int/func (@+ kmin offset 1))) (if (eq? offset 0) - (atom (string->symbol "__HELPER0")) - (+ (build-list (@+ offset 1) - (lambda (atomnum) - (atom (string->symbol (format "__HELPER~a" atomnum))))))))))) + (atom/func (string->symbol "__HELPER0")) + (fold-ast +/func (build-list (@+ offset 1) + (lambda ([atomnum : Integer]) + (atom/func (string->symbol (format "__HELPER~a" atomnum))))))))))) ; Given an integer expression, generate a "gadget" in the form ; of additional partial bounds and additional constraints that ; will aid in translating the integer expression target to a ; standard relational target. +(: build-int-opt-gadget + (-> Any ; given-int-expr (node/int) + (U Scope (Listof Any)) ; run-scope + Any ; run-bounds + (Listof node/formula) ; run-preds + (-> State) ; get-curr-state + (-> State Void) ; update-state! + (-> State Symbol Sig Any State) ; state-add-sig + (-> State Symbol Relation State) ; state-add-relation + (Values (HashTable Symbol (Listof Any)) ; target hash + Inst ; augmented bounds + (Listof node/formula)))) ; augmented preds (define (build-int-opt-gadget given-int-expr run-scope run-bounds run-preds get-curr-state update-state! state-add-sig state-add-relation) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -69,115 +105,98 @@ ; Because the notion of the "state" is so entangled with the run pipeline, we'll ; enable these helper relations permanently as soon as Forge processes _one_ of ; these integer-optimization commands. This isn't ideal. - + ; The full set of possible helper atoms - (define __K_HELPER_ATOM + (define __K_HELPER_ATOM : Sig (cond [(get-sig (get-curr-state) '__K_HELPER_ATOM) - (get-sig (get-curr-state) '__K_HELPER_ATOM)] + => (lambda ([s : Sig]) s)] [else (let ([new-sig (make-sig '__K_HELPER_ATOM)]) (update-state! (state-add-sig (get-curr-state) '__K_HELPER_ATOM new-sig #f)) new-sig)])) - + ; The exact-bounded helper relation - (define __OPT_K_HELPER + (define __OPT_K_HELPER : Relation (cond [(get-relation (get-curr-state) '__OPT_K_HELPER) - (get-relation (get-curr-state) '__OPT_K_HELPER)] + => (lambda ([r : Relation]) r)] [else (let ([new-rel (make-relation '__OPT_K_HELPER (list Int __K_HELPER_ATOM))]) (update-state! (state-add-relation (get-curr-state) '__OPT_K_HELPER new-rel)) new-rel)])) - + ; The set of counting-helper atoms that are used in a given instance - (define __OPT_K_COUNT_SET + (define __OPT_K_COUNT_SET : Sig (cond [(get-sig (get-curr-state) '__OPT_K_COUNT_SET) - (get-sig (get-curr-state) '__OPT_K_COUNT_SET)] + => (lambda ([s : Sig]) s)] [else (let ([new-sig (make-sig '__OPT_K_COUNT_SET #:extends __K_HELPER_ATOM)]) (update-state! (state-add-sig (get-curr-state) '__OPT_K_COUNT_SET new-sig #f)) new-sig)])) - + + (: bind-k-helper-atom (-> Integer Integer node/formula)) (define (bind-k-helper-atom kmin kmax) - (= __K_HELPER_ATOM (+ (list-helper-atoms kmin kmax)))) - + (=/func __K_HELPER_ATOM (fold-ast +/func (list-helper-atoms kmin kmax)))) + + (: bind-opt-k-helper (-> Integer Integer node/formula)) (define (bind-opt-k-helper kmin kmax) - (= __OPT_K_HELPER (+ (list-helper-tuples kmin kmax)))) - + (=/func __OPT_K_HELPER (fold-ast +/func (list-helper-tuples kmin kmax)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Step 2: Use the bitwidth given by the actual Forge problem to ; generate bounds on the helper relations. We get this from the scope, - ; but this might be either a Scope struct or a list of size lists. + ; but this might be either a Scope struct or a list of size lists. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-values (bitwidth found?) - (cond [(Scope? run-scope) (Scope-bitwidth run-scope)] + (cond [(Scope? run-scope) + (values (or (Scope-bitwidth run-scope) DEFAULT-BITWIDTH) #t)] [(list? run-scope) - (for/fold ([bw DEFAULT-BITWIDTH] - [found? #f]) - ([sc run-scope]) - (cond [(and (equal? Int (first sc)) + (for/fold : (Values Nonnegative-Integer Boolean) + ([bw : Nonnegative-Integer DEFAULT-BITWIDTH] + [found? : Boolean #f]) + ([sc : Any run-scope]) + (cond [(and (list? sc) + (equal? Int (first sc)) (equal? (length sc) 2)) - (values (second sc) #t)] - [(and (equal? Int (first sc)) + (values (assert (second sc) exact-nonnegative-integer?) #t)] + [(and (list? sc) + (equal? Int (first sc)) (equal? (length sc) 3)) - (values (third sc) #t)] - [(equal? Int (first sc)) + (values (assert (third sc) exact-nonnegative-integer?) #t)] + [(and (list? sc) (equal? Int (first sc))) (raise-forge-error #:msg (format "Unexpected scope-list format: ~a~n" sc) #:context #f)] [else (if found? (values bw #t) (values DEFAULT-BITWIDTH #f))]))] [else - (raise-forge-error #:msg (format "Unexpected scope format: ~a~n") + (raise-forge-error #:msg (format "Unexpected scope format: ~a~n" run-scope) #:context #f)])) - - (define num-ints (expt 2 bitwidth)) - (define min-int (@- (/ num-ints 2))) - (define max-int (@- (/ num-ints 2) 1)) - - (define __OPT_K_INST + + (define num-ints : Integer (assert (expt 2 bitwidth) exact-integer?)) + (define min-int : Integer (@- (quotient num-ints 2))) + (define max-int : Integer (@- (quotient num-ints 2) 1)) + + (define __OPT_K_INST : Inst (make-inst (list (bind-k-helper-atom min-int max-int) (bind-opt-k-helper min-int max-int)))) - + ; ...will be the result of looking up the given-int-expr's value in the __OPT_K_HELPER table. - (define __OPT_K_WELLFORMED (= __OPT_K_COUNT_SET (join given-int-expr __OPT_K_HELPER))) + ; Convert given-int-expr (node/int) to a relational expression via sing/func + (define given-int-expr* : node/int (assert given-int-expr node/int?)) + (define __OPT_K_WELLFORMED : node/formula + (=/func __OPT_K_COUNT_SET (join/func (sing/func given-int-expr*) __OPT_K_HELPER))) (values ; the target, in hash-instance format (hash '__OPT_K_COUNT_SET '()) ; the augmented relational bounds - (or (and (Inst? run-bounds) (make-inst (list __OPT_K_INST run-bounds))) + (if (Inst? run-bounds) + (make-inst (list __OPT_K_INST run-bounds)) __OPT_K_INST) ; the augmented constraint set - (cons __OPT_K_WELLFORMED run-preds) - ; the two sigs - ;(list __OPT_K_COUNT_SET __K_HELPER_ATOM) - ; the one relation - ;(list __OPT_K_HELPER) - )) - - - - - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; Step 3: Create the run -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -; Note well: this excludes temporal mode -;(set-option! 'problem_type 'target) -; Note well: this isn't supported on all operating systems yet -;(set-option! 'solver 'PMaxSAT4J) - -; Overflows can make this look strange. E.g., at bitwidth 3, 8 edges, becomes "minimal" for #edges. -;(set-option! 'no_overflow 'true) -; We also need to make sure that the given bitwidth above actually matches the bitwidth of the run. - - + (cons __OPT_K_WELLFORMED run-preds))) diff --git a/forge/utils/to-nnf.rkt b/forge/utils/to-nnf.rkt index 17a047e8..6a595dbc 100644 --- a/forge/utils/to-nnf.rkt +++ b/forge/utils/to-nnf.rkt @@ -39,8 +39,8 @@ (node/formula/constant info type)] [(node/fmla/pred-spacer info name args expanded) (interpret-formula run-or-state expanded relations atom-names quantvars)] - [(node/formula/op info args) - (interpret-formula-op run-or-state formula relations atom-names quantvars args)] + [(? node/formula/op?) + (interpret-formula-op run-or-state formula relations atom-names quantvars (node/formula/op-children formula))] [(node/formula/multiplicity info mult expr) (let ([processed-expr (interpret-expr run-or-state expr relations atom-names quantvars)]) (node/formula/multiplicity info mult processed-expr))] @@ -84,16 +84,16 @@ (define (nnf-implies run-or-state children relations atom-names quantvars info) (let ([a (car children)] [b (cdr children)]) - (list (interpret-formula run-or-state (node/formula/op/! info (list a)) relations atom-names quantvars) + (list (interpret-formula run-or-state (node/formula/op-on-formulas/! info (list a)) relations atom-names quantvars) (interpret-formula run-or-state (car b) relations atom-names quantvars)))) (define (distribute-not run-or-state args relations atom-names quantvars info) - (map (lambda (x) (interpret-formula run-or-state (node/formula/op/! info (list x)) relations atom-names quantvars)) args)) + (map (lambda (x) (interpret-formula run-or-state (node/formula/op-on-formulas/! info (list x)) relations atom-names quantvars)) args)) (define (negate-quantifier run-or-state new-quantifier decls form relations atom-names quantvars info) ; Called in a context like !(some ...) ~~~> (all !...). ; NNF conversion thus needs to recur on the inner formula _including_ the negation. - (define negated-inner-form (node/formula/op/! info (list form))) + (define negated-inner-form (node/formula/op-on-formulas/! info (list form))) (define nnf-negated-inner-form (interpret-formula run-or-state negated-inner-form relations atom-names quantvars)) (node/formula/quantified info new-quantifier decls nnf-negated-inner-form)) @@ -101,44 +101,44 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "to-nnf: interpret-formula-op: ~a~n" formula)) (match formula - [(node/formula/op/&& info children) - (node/formula/op/&& info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/|| info children) - (node/formula/op/|| info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/=> info children) - (node/formula/op/|| info (nnf-implies run-or-state args relations atom-names quantvars info))] - [(node/formula/op/always info children) - (node/formula/op/always info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/eventually info children) - (node/formula/op/eventually info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/next_state info children) - (node/formula/op/next_state info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/releases info children) - (node/formula/op/releases info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/until info children) - (node/formula/op/until info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/historically info children) - (node/formula/op/historically info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/once info children) - (node/formula/op/once info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/prev_state info children) - (node/formula/op/prev_state info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/since info children) - (node/formula/op/since info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/triggered info children) - (node/formula/op/triggered info (process-children-formula run-or-state args relations atom-names quantvars))] - [(node/formula/op/in info children) - (node/formula/op/in info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/formula/op/= info children) - (node/formula/op/= info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/formula/op/! info children) + [(node/formula/op-on-formulas/&& info children) + (node/formula/op-on-formulas/&& info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/|| info children) + (node/formula/op-on-formulas/|| info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/=> info children) + (node/formula/op-on-formulas/|| info (nnf-implies run-or-state args relations atom-names quantvars info))] + [(node/formula/op-on-formulas/always info children) + (node/formula/op-on-formulas/always info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/eventually info children) + (node/formula/op-on-formulas/eventually info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/next_state info children) + (node/formula/op-on-formulas/next_state info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/releases info children) + (node/formula/op-on-formulas/releases info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/until info children) + (node/formula/op-on-formulas/until info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/historically info children) + (node/formula/op-on-formulas/historically info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/once info children) + (node/formula/op-on-formulas/once info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/prev_state info children) + (node/formula/op-on-formulas/prev_state info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/since info children) + (node/formula/op-on-formulas/since info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/triggered info children) + (node/formula/op-on-formulas/triggered info (process-children-formula run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-exprs/in info children) + (node/formula/op-on-exprs/in info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-exprs/= info children) + (node/formula/op-on-exprs/= info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-formulas/! info children) (match (car children) ; (not (a and b)) = (not a or not b) - [(node/formula/op/&& and-info and-children) (node/formula/op/|| and-info (distribute-not run-or-state and-children relations atom-names quantvars and-info))] + [(node/formula/op-on-formulas/&& and-info and-children) (node/formula/op-on-formulas/|| and-info (distribute-not run-or-state and-children relations atom-names quantvars and-info))] ; (not (a or b)) = (not a and not b) - [(node/formula/op/|| or-info or-children) (node/formula/op/&& or-info (distribute-not run-or-state or-children relations atom-names quantvars or-info))] + [(node/formula/op-on-formulas/|| or-info or-children) (node/formula/op-on-formulas/&& or-info (distribute-not run-or-state or-children relations atom-names quantvars or-info))] ; Remove double not (!(!a)) = a - [(node/formula/op/! not-info not-children) (interpret-formula run-or-state (car not-children) relations atom-names quantvars)] + [(node/formula/op-on-formulas/! not-info not-children) (interpret-formula run-or-state (car not-children) relations atom-names quantvars)] ; Converting quantifiers to NNF [(node/formula/quantified quant-info quantifier decls form) (match quantifier @@ -149,13 +149,13 @@ ['some (negate-quantifier run-or-state 'all decls form relations atom-names quantvars quant-info)] ; raise forge error if we hit something else [_ (raise-forge-error #:msg (format "Unexpected quantifier: ~a" quantifier) #:context formula)])] - [_ (node/formula/op/! info (process-children-formula run-or-state args relations atom-names quantvars))])] - [(node/formula/op/int> info children) - (node/formula/op/int> info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/formula/op/int< info children) - (node/formula/op/int< info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/formula/op/int= info children) - (node/formula/op/int= info (process-children-int run-or-state args relations atom-names quantvars))])) + [_ (node/formula/op-on-formulas/! info (process-children-formula run-or-state args relations atom-names quantvars))])] + [(node/formula/op-on-ints/int> info children) + (node/formula/op-on-ints/int> info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-ints/int< info children) + (node/formula/op-on-ints/int< info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/formula/op-on-ints/int= info children) + (node/formula/op-on-ints/int= info (process-children-int run-or-state args relations atom-names quantvars))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Relational expressions @@ -180,8 +180,8 @@ (node/expr/constant info 1 'Int)] [(node/expr/constant info arity type) (node/expr/constant info arity type)] - [(node/expr/op info arity args) - (interpret-expr-op run-or-state expr relations atom-names quantvars args)] + [(? node/expr/op? op) + (interpret-expr-op run-or-state expr relations atom-names quantvars (node/expr/op-children op))] [(node/expr/quantifier-var info arity sym name) (node/expr/quantifier-var info arity sym name)] [(node/expr/comprehension info len decls form) @@ -203,28 +203,28 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "to-nnf: interpret-expr-op: ~a~n" expr)) (match expr - [(node/expr/op/+ info arity children) - (node/expr/op/+ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/- info arity children) - (node/expr/op/- info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/& info arity children) - (node/expr/op/& info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/-> info arity children) - (node/expr/op/-> info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/prime info arity children) - (node/expr/op/prime info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/join info arity children) - (node/expr/op/join info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/^ info arity children) - (node/expr/op/^ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/* info arity children) - (node/expr/op/* info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/~ info arity children) - (node/expr/op/~ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/++ info arity children) - (node/expr/op/++ info arity (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/expr/op/sing info arity children) - (node/expr/op/sing info arity (process-children-int run-or-state args relations atom-names quantvars))])) + [(node/expr/op-on-exprs/+ info arity children) + (node/expr/op-on-exprs/+ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/- info arity children) + (node/expr/op-on-exprs/- info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/& info arity children) + (node/expr/op-on-exprs/& info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/-> info arity children) + (node/expr/op-on-exprs/-> info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/prime info arity children) + (node/expr/op-on-exprs/prime info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/join info arity children) + (node/expr/op-on-exprs/join info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/^ info arity children) + (node/expr/op-on-exprs/^ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/* info arity children) + (node/expr/op-on-exprs/* info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/~ info arity children) + (node/expr/op-on-exprs/~ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-exprs/++ info arity children) + (node/expr/op-on-exprs/++ info arity (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/expr/op-on-ints/sing info arity children) + (node/expr/op-on-ints/sing info arity (process-children-int run-or-state args relations atom-names quantvars))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Integer expressions @@ -236,8 +236,8 @@ (match expr [(node/int/constant info value) (node/int/constant info value)] - [(node/int/op info args) - (interpret-int-op run-or-state expr relations atom-names quantvars args)] + [(? node/int/op? op) + (interpret-int-op run-or-state expr relations atom-names quantvars (node/int/op-children op))] [(node/int/sum-quant info decls int-expr) (define new-vs-and-decls (for/fold ([vs-and-decls (list quantvars '())]) @@ -257,24 +257,24 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "to-nnf: interpret-int-op: ~a~n" expr)) (match expr - [(node/int/op/add info children) - (node/int/op/add info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/subtract info children) - (node/int/op/subtract info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/multiply info children) - (node/int/op/multiply info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/divide info children) - (node/int/op/divide info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/sum info children) - (node/int/op/sum info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/int/op/card info children) - (node/int/op/card info (process-children-expr run-or-state args relations atom-names quantvars))] - [(node/int/op/remainder info children) - (node/int/op/remainder info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/abs info children) - (node/int/op/abs info (process-children-int run-or-state args relations atom-names quantvars))] - [(node/int/op/sign info children) - (node/int/op/sign info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/add info children) + (node/int/op-on-ints/add info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/subtract info children) + (node/int/op-on-ints/subtract info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/multiply info children) + (node/int/op-on-ints/multiply info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/divide info children) + (node/int/op-on-ints/divide info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-exprs/sum info children) + (node/int/op-on-exprs/sum info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/int/op-on-exprs/card info children) + (node/int/op-on-exprs/card info (process-children-expr run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/remainder info children) + (node/int/op-on-ints/remainder info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/abs info children) + (node/int/op-on-ints/abs info (process-children-int run-or-state args relations atom-names quantvars))] + [(node/int/op-on-ints/sign info children) + (node/int/op-on-ints/sign info (process-children-int run-or-state args relations atom-names quantvars))] [(node/int/sum-quant info decls int-expr) (raise-forge-error #:msg "Reached expected unreachable code." #:context expr)] )) diff --git a/forge/utils/to-skolem.rkt b/forge/utils/to-skolem.rkt index 87e8dfe0..973b1406 100644 --- a/forge/utils/to-skolem.rkt +++ b/forge/utils/to-skolem.rkt @@ -39,7 +39,7 @@ (define join-rhs skolem-relation) (for/fold ([join-rhs join-rhs]) ([quantvar quantvars]) - (define new-join-expr (node/expr/op/join info 2 (list quantvar join-rhs))) + (define new-join-expr (node/expr/op-on-exprs/join info 2 (list quantvar join-rhs))) new-join-expr)) ; TODO: suspect some of these arguments are no longer needed @@ -194,8 +194,8 @@ (define-values (fmla bounds) (interpret-formula run-spec total-bounds expanded relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer)) (set! current-bounds bounds) fmla] - [(node/formula/op info args) - (interpret-formula-op run-spec total-bounds formula relations atom-names quantvars quantvar-types args #:tag-with-spacer tag-with-spacer)] + [(? node/formula/op?) + (interpret-formula-op run-spec total-bounds formula relations atom-names quantvars quantvar-types (node/formula/op-children formula) #:tag-with-spacer tag-with-spacer)] [(node/formula/multiplicity info mult expr) (let ([processed-expr (interpret-expr run-spec total-bounds expr relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer)]) (node/formula/multiplicity info mult processed-expr))] @@ -260,44 +260,44 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "to-skolem: interpret-formula-op: ~a~n" formula)) (match formula - [(node/formula/op/&& info children) - (node/formula/op/&& info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/|| info children) - (node/formula/op/|| info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/=> info children) - (node/formula/op/=> info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/always info children) - (node/formula/op/always info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/eventually info children) - (node/formula/op/eventually info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/next_state info children) - (node/formula/op/next_state info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/releases info children) - (node/formula/op/releases info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/until info children) - (node/formula/op/until info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/historically info children) - (node/formula/op/historically info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/once info children) - (node/formula/op/once info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/prev_state info children) - (node/formula/op/prev_state info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/since info children) - (node/formula/op/since info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/triggered info children) - (node/formula/op/triggered info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/in info children) - (node/formula/op/in info (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/= info children) - (node/formula/op/= info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/! info children) - (node/formula/op/! info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/int> info children) - (node/formula/op/int> info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/int< info children) - (node/formula/op/int< info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/formula/op/int= info children) - (node/formula/op/int= info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))])) + [(node/formula/op-on-formulas/&& info children) + (node/formula/op-on-formulas/&& info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/|| info children) + (node/formula/op-on-formulas/|| info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/=> info children) + (node/formula/op-on-formulas/=> info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/always info children) + (node/formula/op-on-formulas/always info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/eventually info children) + (node/formula/op-on-formulas/eventually info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/next_state info children) + (node/formula/op-on-formulas/next_state info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/releases info children) + (node/formula/op-on-formulas/releases info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/until info children) + (node/formula/op-on-formulas/until info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/historically info children) + (node/formula/op-on-formulas/historically info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/once info children) + (node/formula/op-on-formulas/once info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/prev_state info children) + (node/formula/op-on-formulas/prev_state info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/since info children) + (node/formula/op-on-formulas/since info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/triggered info children) + (node/formula/op-on-formulas/triggered info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-exprs/in info children) + (node/formula/op-on-exprs/in info (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-exprs/= info children) + (node/formula/op-on-exprs/= info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-formulas/! info children) + (node/formula/op-on-formulas/! info (process-children-formula run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-ints/int> info children) + (node/formula/op-on-ints/int> info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-ints/int< info children) + (node/formula/op-on-ints/int< info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/formula/op-on-ints/int= info children) + (node/formula/op-on-ints/int= info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Relational expressions @@ -323,8 +323,8 @@ (node/expr/constant info 1 'Int)] [(node/expr/constant info arity type) (node/expr/constant info arity type)] - [(node/expr/op info arity args) - (interpret-expr-op run-spec total-bounds expr relations atom-names quantvars quantvar-types args #:tag-with-spacer tag-with-spacer)] + [(? node/expr/op? op) + (interpret-expr-op run-spec total-bounds expr relations atom-names quantvars quantvar-types (node/expr/op-children op) #:tag-with-spacer tag-with-spacer)] [(node/expr/quantifier-var info arity sym name) (node/expr/quantifier-var info arity sym name)] [(node/expr/comprehension info len decls form) @@ -347,28 +347,28 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "to-skolem: interpret-expr-op: ~a~n" expr)) (match expr - [(node/expr/op/+ info arity children) - (node/expr/op/+ info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/- info arity children) - (node/expr/op/- info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/& info arity children) - (node/expr/op/& info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/-> info arity children) - (node/expr/op/-> info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/prime info arity children) - (node/expr/op/prime info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/join info arity children) - (node/expr/op/join info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/^ info arity children) - (node/expr/op/^ info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/* info arity children) - (node/expr/op/* info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/~ info arity children) - (node/expr/op/~ info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/++ info arity children) - (node/expr/op/++ info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/expr/op/sing info arity children) - (node/expr/op/sing info arity (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))])) + [(node/expr/op-on-exprs/+ info arity children) + (node/expr/op-on-exprs/+ info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/- info arity children) + (node/expr/op-on-exprs/- info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/& info arity children) + (node/expr/op-on-exprs/& info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/-> info arity children) + (node/expr/op-on-exprs/-> info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/prime info arity children) + (node/expr/op-on-exprs/prime info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/join info arity children) + (node/expr/op-on-exprs/join info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/^ info arity children) + (node/expr/op-on-exprs/^ info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/* info arity children) + (node/expr/op-on-exprs/* info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/~ info arity children) + (node/expr/op-on-exprs/~ info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-exprs/++ info arity children) + (node/expr/op-on-exprs/++ info arity (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/expr/op-on-ints/sing info arity children) + (node/expr/op-on-ints/sing info arity (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Integer expressions @@ -380,8 +380,8 @@ (match expr [(node/int/constant info value) (node/int/constant info value)] - [(node/int/op info args) - (interpret-int-op run-spec total-bounds expr relations atom-names quantvars quantvar-types args #:tag-with-spacer tag-with-spacer)] + [(? node/int/op? op) + (interpret-int-op run-spec total-bounds expr relations atom-names quantvars quantvar-types (node/int/op-children op) #:tag-with-spacer tag-with-spacer)] [(node/int/sum-quant info decls int-expr) (define new-vs-and-decls (for/fold ([vs-and-decls (list quantvars '())]) @@ -401,24 +401,24 @@ (when (@>= (get-verbosity) VERBOSITY_DEBUG) (printf "to-skolem: interpret-int-op: ~a~n" expr)) (match expr - [(node/int/op/add info children) - (node/int/op/add info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/int/op/subtract info children) - (node/int/op/subtract info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/int/op/multiply info children) - (node/int/op/multiply info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/int/op/divide info children) - (node/int/op/divide info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/int/op/sum info children) - (node/int/op/sum info (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/int/op/card info children) - (node/int/op/card info (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/int/op/remainder info children) - (node/int/op/remainder info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/int/op/abs info children) - (node/int/op/abs info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] - [(node/int/op/sign info children) - (node/int/op/sign info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-ints/add info children) + (node/int/op-on-ints/add info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-ints/subtract info children) + (node/int/op-on-ints/subtract info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-ints/multiply info children) + (node/int/op-on-ints/multiply info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-ints/divide info children) + (node/int/op-on-ints/divide info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-exprs/sum info children) + (node/int/op-on-exprs/sum info (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-exprs/card info children) + (node/int/op-on-exprs/card info (process-children-expr run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-ints/remainder info children) + (node/int/op-on-ints/remainder info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-ints/abs info children) + (node/int/op-on-ints/abs info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] + [(node/int/op-on-ints/sign info children) + (node/int/op-on-ints/sign info (process-children-ambiguous run-spec total-bounds args relations atom-names quantvars quantvar-types #:tag-with-spacer tag-with-spacer))] [(node/int/sum-quant info decls int-expr) (raise-forge-error #:msg "Reached expected unreachable code." #:context expr)] ))