From 267e1e92ecf87e302bf7809ebecb6dfbcee81de6 Mon Sep 17 00:00:00 2001
From: rschoene <rene.schoene@tu-dresden.de>
Date: Tue, 3 May 2016 16:07:34 +0200
Subject: [PATCH] [WIP] ast-find-child with * to solve problems?
---
Makefile | 2 +-
ag-test.scm | 7 ++++++-
ast-generation.scm | 13 +++++++------
basic-ag.scm | 15 +++++++++------
4 files changed, 23 insertions(+), 14 deletions(-)
diff --git a/Makefile b/Makefile
index c1d0121..dc55a9c 100644
--- a/Makefile
+++ b/Makefile
@@ -42,4 +42,4 @@ clean:
rm -rf $(LARCENY_BUILD_DIR)/*
run: racket
- fab call_racket:cli.scm,ag | tee ast-output.txt | less
+ fab call_racket:cli.scm,ag 2>&1 | tee ast-output.txt | less
diff --git a/ag-test.scm b/ag-test.scm
index 2d98979..8a51952 100644
--- a/ag-test.scm
+++ b/ag-test.scm
@@ -14,6 +14,11 @@
;; Testing printing whole asts
;; num-pe=10, num-pe-subs=0, num-comp=3, impl-per-comp=4, mode-per-impl=5
+ (define (display-part2 node)
+ (define (print name) (cons name (lambda (v) v)))
+ (define printer (list (print 'remote-unit)))
+ (print-ast node printer (current-output-port)))
+
(define (do-it . args)
(let* ([ast (create-system 10 0 3 4 5)]
; [clause (car (->* (->Clause* (car (->* (->Mode* (car (->* (->Impl* (car (->* (->Comp* (->SWRoot ast)))))))))))))]
@@ -24,4 +29,4 @@
; (display (=ilp-eval-binvar clause pe))
; (rewrite-terminal 'value prov-clause (rand 1 3 0))
; (display (=ilp-eval-binvar clause pe))
- (display-part ast))))
+ (display-part2 ast))))
diff --git a/ast-generation.scm b/ast-generation.scm
index d9aed73..0b62dd9 100644
--- a/ast-generation.scm
+++ b/ast-generation.scm
@@ -48,10 +48,11 @@
(let ([entry (assq nr types-al)])
(if entry (cdr entry) (let ([new (make-type nr container?)]) (set! types-al (cons (cons nr new) types-al)) new))))
(define (create-hw-clause udfs name property)
- (let ([f (create-clause udfs default-hw-clause-gen name)])
- (if f (let ([args (f (->name property))])
- (if (eq? args #t) (set! args (default-hw-clause-gen (->name property))))
- (if args ((car args) property (cadr args) (caddr args)) #f))
+ (let ([f (create-clause udfs default-hw-clause-gen name)]
+ [property-name (if (ast-subtype? property 'RealProperty) (->name property) (ast-child 'refname property))])
+ (if f (let ([args (f property-name)])
+ (if (eq? args #t) (set! args (default-hw-clause-gen property-name)))
+ (if args ((car args) property-name (cadr args) (caddr args)) #f))
#f)))
(define (default-hw-clause-gen property-name)
(cond
@@ -137,13 +138,13 @@
(cons sw-root (car (prop last-comp-nr)))))
(define (create-request target-property)
- (let* ([make-req (lambda (p maxVal digits offset) (:ReqClause mquat-spec p comp-min-eq (rand maxVal digits offset)))]
+ (let* ([make-req (lambda (propname maxVal digits offset) (:ReqClause mquat-spec (:PropertyRef mquat-spec propname) comp-min-eq (rand maxVal digits offset)))]
[target (<<- target-property)])
(debug "create-request: target-property = " target-property)
(:Request
mquat-spec
(list (:MetaParameter mquat-spec mp-name ((rand 100 2 0))))
- target (list (make-req target-property 1 2 0)) #f))) ;TODO: check type of target-property (terminal?, Property?)
+ target (list (make-req (->name (=real target-property)) 1 2 0)) #f))) ;TODO: check type of target-property (terminal?, Property?)
; Creates a new system.
; num-pe: total number of resources
diff --git a/basic-ag.scm b/basic-ag.scm
index 5b4663e..469778d 100644
--- a/basic-ag.scm
+++ b/basic-ag.scm
@@ -64,7 +64,7 @@
(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 (find-prop propname subtree) (ast-find-child* (lambda (i n) (string=? propname (->name n))) subtree))
(define (add-basic-ags mquat-spec)
(with-specification
@@ -187,13 +187,13 @@
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)))))
+ (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)))))
+ (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))))))
+ (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)))
@@ -253,7 +253,7 @@
(ag-rule
real
(RealProperty (lambda (n) n))
- (PropertyRef (lambda (n) (info n ", refname=" (ast-child 'refname n) ", hasParent=" (ast-has-parent? n)) (=real (=lookup-property (<=root n) (ast-child 'refname n))))))
+ (PropertyRef (lambda (n) (debug n ", refname=" (ast-child 'refname n) ", hasParent=" (ast-has-parent? n)) (=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
@@ -315,6 +315,9 @@
; =selected?: Returns #t, if the Implementation is selected by its component
(ag-rule selected? (Impl (lambda (n) (eq? (->selected-impl (<<- n)) n))))
+ ; =remote-unit: Returns the unit of the RealProperty the PropertyRef is pointing to
+ (ag-rule remote-unit (PropertyRef (lambda (n) (->unit (=real n)))))
+
; =value-of: Given a metaparameter name, return the value of the according metaparameter
(ag-rule value-of (Request (lambda (n name)
(ast-find-child* (lambda (i child) (and (string=? (->name child) name) (->value child)))
--
GitLab