diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index becb30d7eb..2d2d7bf9e9 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -1323,7 +1323,8 @@ (append (map (lambda (iface-spec) (send type-recs get-class-record iface-spec)) ifaces) iface-records)) (append (map (lambda (iface) (make-name (make-id (car iface) #f) (cdr iface) #f)) ifaces) - (map (lambda (iface) (make-name iface null #f)) iface-names))))) + (map (lambda (iface) + (if (name? iface) iface (make-name iface null #f))) iface-names))))) ;get-methods-need-implementing: (list method-record) -> (list method-record) (define (get-methods-need-implementing methods) diff --git a/collects/profj/comb-parsers/parser-units.scm b/collects/profj/comb-parsers/parser-units.scm index d6467e8445..e586070408 100644 --- a/collects/profj/comb-parsers/parser-units.scm +++ b/collects/profj/comb-parsers/parser-units.scm @@ -338,7 +338,7 @@ (define (new-class expr) (choose ((sequence (new name O_PAREN C_PAREN) id "class instantiation") - (sequence (new name O_PAREN (comma-sep expr "arguments") C_PAREN) id "class instantiation")) + (sequence (new name O_PAREN (comma-sep expression "arguments") C_PAREN) id "class instantiation")) "class instantiation")) (define (new-array type-name expr) @@ -838,7 +838,7 @@ (assignment (choose (identifier (sequence (expression field-access-end) id) - (sequence (expression array-access-end) id)) + (sequence (expression (array-access-end expression)) id)) "asignee") assignment-ops expression) (sequence (expression ++) id "unary mutation") diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index 29eb8fe87c..37ff7f4524 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -165,7 +165,8 @@ (unless (null? (check-list)) (check-defs (car (check-list)) level type-recs)) (remove-from-packages ast type-recs) - (order-cus (translate-program ast type-recs) + (reverse (translate-program ast type-recs)) + #;(order-cus (translate-program ast type-recs) type-recs)) (define (compile-to-ast port location type-recs file? level) @@ -194,7 +195,8 @@ (unless (null? (check-list)) (check-defs (car (check-list)) level type-recs)) (remove-from-packages ast type-recs) - (order-cus (translate-program ast type-recs) type-recs))) + (reverse (translate-program ast type-recs)) + #;(order-cus (translate-program ast type-recs) type-recs))) ;compile-interactions: port location type-records level -> syntax (define (compile-interactions port location type-recs level) diff --git a/collects/profj/graph-scc.ss b/collects/profj/graph-scc.ss new file mode 100644 index 0000000000..ae59b6eb1d --- /dev/null +++ b/collects/profj/graph-scc.ss @@ -0,0 +1,103 @@ +(module graph-scc mzscheme + + #;(require "ast.ss") + + (provide get-scc) + + (define (get-scc nodes get-successors for-each-node) + (letrec ([in-component (make-hash-table)] + [dpth-nums (make-hash-table)] + [root-of-node (make-hash-table)] + [counter 0] + [stack null] + [sccs null] + + ;node -> boolean + [visited? + (lambda (node) + (symbol? (hash-table-get in-component node #f)))] + ;node -> boolean + [in-component? + (lambda (node) + (eq? 'true (hash-table-get in-component node #f)))] + + ;node node -> node + [min-root + (lambda (old-min new-node) + #;(printf "~a <= ~a, ~a" (hash-table-get dpth-nums old-min) + (hash-table-get dpth-nums + (hash-table-get root-of-node new-node) + (lambda () (add1 counter))) counter) + (if (<= (hash-table-get dpth-nums old-min) + (hash-table-get dpth-nums + (hash-table-get root-of-node new-node) + (add1 counter))) + old-min + new-node))] + ;node -> void + [assign-depth-num + (lambda (node) + (unless (hash-table-get dpth-nums node #f) + (hash-table-put! dpth-nums node counter) + (set! counter (add1 counter))))] + + [push! (lambda (v) (set! stack (cons v stack)))] + [pop! (lambda () (begin0 (car stack) (set! stack (cdr stack))))] + + ;visit: node -> void + [visit + (lambda (node) + #;(printf "visit of ~a~n" (def-name node)) + (let ([root-v node]) + (hash-table-put! root-of-node node root-v) + (hash-table-put! in-component node 'false) + (assign-depth-num node) + (push! node) + (for-each-node + (lambda (successor) + (unless (visited? successor) (visit successor)) + #;(printf "finished visiting successor ~a on visit of ~a~n" + (def-name successor) (def-name node)) + (unless (in-component? successor) + #;(printf "old-root-v ~a~n" (def-name root-v)) + (set! root-v (min-root root-v successor)) + #;(printf "new-root-v ~a~n" (def-name root-v)))) + (get-successors node)) + #;(printf "root-v ~a for visit of ~a~n" (def-name root-v) + (def-name node)) + (hash-table-put! root-of-node node root-v) + (if (eq? root-v node) + (let loop ([w (pop!)] [scc null]) + #;(printf "~a ~a ~n" w scc) + (hash-table-put! in-component w 'true) + (if (eq? w node) + (set! sccs (cons (cons w scc) sccs)) + (loop (pop!) (cons w scc)))))))]) + + (for-each-node (lambda (node) + (set! counter 0) + (set! dpth-nums (make-hash-table)) + (unless (visited? node) (visit node))) + nodes) + + #;(printf "sccs: ~a~n" (map (lambda (scc) + (map def-name scc)) sccs)) + sccs)) + + #;(define-struct node (name points-to)(make-inspector)) + #;(define node-list + (list (make-node 'a '(b e)) + (make-node 'b '(c)) + (make-node 'c '(a d)) + (make-node 'd '(b)) + (make-node 'e '(f)) + (make-node 'f '(e)))) + #;(define (get-successors node) + (map (lambda (n) + (let loop ([nl node-list]) + (if (eq? n (node-name (car nl))) + (car nl) + (loop (cdr nl))))) + (node-points-to node))) + + ) \ No newline at end of file diff --git a/collects/profj/name-utils.scm b/collects/profj/name-utils.scm index 0b70c28f26..a95255cf51 100644 --- a/collects/profj/name-utils.scm +++ b/collects/profj/name-utils.scm @@ -5,6 +5,7 @@ (define (getter match-pattern replace-pattern) (lambda (name) (cond + [(symbol? name) name] [(regexp-match match-pattern name) (regexp-replace replace-pattern name "")] [else name]))) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 2910ac0aae..84f0f91e08 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -2,6 +2,7 @@ (require "ast.ss" "types.ss" "name-utils.scm" + "graph-scc.ss" "parameters.ss" (lib "class.ss") (lib "list.ss") @@ -250,7 +251,8 @@ (lambda (def) (filter (lambda (x) x) (map find (def-uses def))))) ) - (get-strongly-connected-components defs for-each-def get-requires))) + (get-scc defs get-requires for-each) + #;(get-strongly-connected-components defs for-each-def get-requires))) ;get-strongly-connected-components: GRAPH (GRAPH (NODE -> void) -> void) (NODE -> (list NODE)) -> (list (list NODE)) (define (get-strongly-connected-components graph for-each-node get-connected-nodes) @@ -265,8 +267,7 @@ (in-current-cycle? (lambda (n) (hash-table-get current-cycle n (lambda () #f)))) (current-cycle-memq - (lambda (nodes) - (ormap in-current-cycle? nodes))) + (lambda (nodes) (ormap in-current-cycle? nodes))) (add-to-current-cycle (lambda (n) (set! cur-cycle-length (add1 cur-cycle-length)) @@ -274,10 +275,15 @@ (retrieve-current-cycle (lambda () (hash-table-map current-cycle (lambda (key v) key)))) + ;; componetize : NODE (list NODE) bool -> void (componentize (lambda (node successors member?) (unless (already-in-cycle? node) - ;(printf "componentize ~a ~a ~a~n" node successors member?) + (printf "componentize ~a ~a ~a~n" + (id-string (def-name node)) + (map id-string (map def-name successors)) + (map id-string (map def-name (retrieve-current-cycle))) + ) (let ((added? #f) (cur-length cur-cycle-length) (old-mark (hash-table-get marks node))) @@ -291,7 +297,10 @@ (eq? 'in-progress (hash-table-get marks successor))) (componentize successor (get-connected-nodes successor) #f))) successors) - ;(printf "finished successors for ~a~n" node) + (printf "finished successors for ~a~n" (id-string (def-name node))) + (when (not (= cur-length cur-cycle-length)) + (add-to-current-cycle node)) + (if (or added? (= cur-length cur-cycle-length)) (hash-table-put! marks node old-mark) (componentize node successors #f))))))) @@ -300,14 +309,21 @@ (for-each-node graph (lambda (node) - ;(hash-table-for-each marks (lambda (key val) (printf "~a -> ~a~n" (eq-hash-code key) val))) - ;(printf "Working on ~a~n~n" (eq-hash-code node)) + #;(hash-table-for-each + marks + (lambda (key val) (printf "~a -> ~a~n" (eq-hash-code key) val))) + #;(printf "Working on ~a~n~n" (eq-hash-code node)) + #;(printf "node: ~a successors: ~a" (def-name node) (map def-name (get-connected-nodes node))) (when (eq? (hash-table-get marks node) 'no-info) (set! current-cycle (make-hash-table)) (add-to-current-cycle node) + (set! cur-cycle-length 0) + (printf "calling componetice ~a~n" (id-string (def-name node))) (for-each (lambda (node) (componentize node (get-connected-nodes node) #f)) (get-connected-nodes node)) - (set! strongly-connecteds (cons (retrieve-current-cycle) strongly-connecteds)) + (set! strongly-connecteds + (cons (retrieve-current-cycle) strongly-connecteds)) + (printf "~a~n~n" (map id-string (map def-name (car strongly-connecteds)))) (hash-table-for-each current-cycle (lambda (n v) (hash-table-put! marks n 'in-a-cycle)))))) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index adfc3c28b5..835b3ed7d4 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -635,6 +635,7 @@ (examples (if (testcase-ext?) (list (send execute-types get-test-classes) null) (find-examples compilation-units)))) + (printf "ProfJ compilation complete~n") (let ((name-to-require #f) (tests-run? #f)) (let loop ((mods (order compilation-units))