diff --git a/ag-test.scm b/ag-test.scm index 0e0cf97295b9f3fcea9d5b7040182b338be80899..2d9897972ee8009a3423dca80ab3d929b57ab9bf 100644 --- a/ag-test.scm +++ b/ag-test.scm @@ -11,15 +11,17 @@ (mquat utils) (mquat ilp) (mquat join) (mquat basic-ag) (mquat ast) (mquat constants) (mquat ast-generation) (mquat ui)) -;; Testing some attributes +;; Testing printing whole asts +;; num-pe=10, num-pe-subs=0, num-comp=3, impl-per-comp=4, mode-per-impl=5 (define (do-it . args) - (let* ([ast (create-system 3 0 1 2 2)] - [clause (car (->* (->Clause* (car (->* (->Mode* (car (->* (->Impl* (car (->* (->Comp* (->SWRoot ast)))))))))))))] + (let* ([ast (create-system 10 0 3 4 5)] +; [clause (car (->* (->Clause* (car (->* (->Mode* (car (->* (->Impl* (car (->* (->Comp* (->SWRoot ast)))))))))))))] [pe (car (->* (->SubResources (->HWRoot ast))))] [prov-clause (car (->* (->ProvClause* pe)))]) - (display (=ilp-eval-binvar clause pe)) - (rewrite-terminal 'value prov-clause (rand 1 3 0)) - (display (=ilp-eval-binvar clause pe)) - (rewrite-terminal 'value prov-clause (rand 1 3 0)) - (display (=ilp-eval-binvar clause pe))))) +; (display (=ilp-eval-binvar clause pe)) +; (rewrite-terminal 'value prov-clause (rand 1 3 0)) +; (display (=ilp-eval-binvar clause pe)) +; (rewrite-terminal 'value prov-clause (rand 1 3 0)) +; (display (=ilp-eval-binvar clause pe)) + (display-part ast)))) diff --git a/ast.scm b/ast.scm index 255562caf5a5516cad25341097a759b1f2eb8e45..2dad022a3fbb0e63a5c90644bdeea84faa247265 100644 --- a/ast.scm +++ b/ast.scm @@ -97,6 +97,6 @@ (ast-rule 'Property->) ; kind=static|runtime|derived. direction=decreasing|increasing. agg = sum|max. (ast-rule 'RealProperty:Property->name-unit-kind-direction-agg) - (ast-rule 'PropertyRef:Property->ref) + (ast-rule 'PropertyRef:Property->refname) (compile-ast-specifications 'Root)))) diff --git a/basic-ag.scm b/basic-ag.scm index 8173d5179da35f473f30eca8dea6cacccd21767f..1736b057f69167fd2177dd7cec01696f7c62ca8c 100644 --- a/basic-ag.scm +++ b/basic-ag.scm @@ -26,7 +26,10 @@ (define (=eval-on n pe) (att-value 'eval-on n pe)) (define (=hw? n) (att-value 'hw? n)) (define (<=impl n) (att-value 'get-impl n)) - (define (=lookup-clause n prop) (att-value 'lookup-clause n prop)) + (define (=lookup-clause n prop) + (att-value 'lookup-clause n prop)) + (define (=lookup-property n propname) + (att-value 'lookup-property n propname)) (define (=maximum n) (att-value 'maximum n)) (define (=max-help n arg0) (att-value 'max-help n arg0)) (define (=mode-to-use n) (att-value 'mode-to-use n)) @@ -40,6 +43,7 @@ (define (=req-comp-all n) (att-value 'req-comp-all n)) (define (<=request n) (att-value 'get-request n)) (define (=real n) (att-value 'real n)) + (define (<=root n) (att-value 'get-root n)) (define (=selected? n) (att-value 'selected? n)) (define (=every-pe n) (att-value 'every-pe n)) (define (=every-container n) (att-value 'every-container n)) @@ -60,6 +64,8 @@ (define (=value-attr n) (att-value 'value-attr n)) (define (=value-of n name) (att-value 'value-of n name)) + (define (find-prop propname subtree) (ast-find-child (lambda (i n) (string=? propname (->name n))) subtree)) + (define (add-basic-ags mquat-spec) (with-specification mquat-spec @@ -176,6 +182,19 @@ (Resource (lambda (n prop) (ast-find-child (lambda (i cl) (eq? (=real prop) (=real (->return-type cl)))) (->ProvClause* n)))) (Mode (lambda (n prop) (ast-find-child (lambda (i cl) (eq? (=real prop) (=real (->return-type cl)))) (->Clause* n))))) + ; =lookup-property: Given the name of the property, resolves to a RealProperty. Always invoke on Root. + (ag-rule + lookup-property + (Root (lambda (n propname) (or (=lookup-property (->SWRoot n) propname) (=lookup-property (->HWRoot n) propname) (error "Could not find " propname)))) + (SWRoot (lambda (n propname) (or (find-prop propname (->RealProperty* n)) + (ast-find-child (lambda (i c) (=lookup-property c propname)) (->Comp* n))))) + (Comp (lambda (n propname) (find-prop propname (->Property* n)))) + (HWRoot (lambda (n propname) (or (ast-find-child (lambda (i rt) (=lookup-property rt propname)) (->ResourceType* n)) + (ast-find-child (lambda (i r) (=lookup-property r propname)) (->SubResources n))))) + (ResourceType (lambda (n propname) (find-prop propname (->RealProperty* n)))) + (Resource (lambda (n propname) (or (find-prop propname (->Property* n)) + (ast-find-child (lambda (i sr) (=lookup-property sr propname)) (->SubResources n)))))) + ; <=impl: Get Impl in subtree of the Impl (ag-rule get-impl (Impl (lambda (n) n))) @@ -234,7 +253,7 @@ (ag-rule real (RealProperty (lambda (n) n)) - (PropertyRef (lambda (n) (=real (ast-child 'ref n))))) + (PropertyRef (lambda (n) (=real (=lookup-property (<=root n) (ast-child 'refname n)))))) ; =req-comp-map: Returns a associate list, mapping required components to a list of implementations requiring that component (ag-rule @@ -269,6 +288,9 @@ ; <=request: Get request from every node (ag-rule get-request (Root (lambda (n) (ast-child 'Request n)))) + ; <=root: Get Root from every node + (ag-rule get-root (Root (lambda (n) n))) + ; Returns all resources of the type (ag-rule resources-of (ResourceType (lambda (n) (filter (lambda (pe) (eq? n (->type pe))) (=every-pe n)))))