[WIP] ast-find-child with * to solve problems?

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

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))))

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

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)))