->i now evaluates the arguments in the proper order
This commit is contained in:
parent
d2894e7a8e
commit
3b431c6ff2
|
@ -75,13 +75,32 @@
|
|||
#:first-order (λ (ctc) (λ (x) #f)) ;; WRONG
|
||||
#:stronger (λ (this that) #f))) ;; WRONG
|
||||
|
||||
;; find-ordering : (listof arg) -> (listof (cons number arg))
|
||||
;; find-ordering : (listof arg) -> (values (listof arg) (listof number))
|
||||
;; sorts the arguments according to the dependency order.
|
||||
;; returns them in the reverse of that order, ie expressions that need
|
||||
;; to be evaluted first come later in the list.
|
||||
(define-for-syntax (find-ordering args)
|
||||
(values (reverse args)
|
||||
(reverse
|
||||
(for/list ([arg (in-list args)]
|
||||
[i (in-naturals)])
|
||||
i))))
|
||||
|
||||
(define (comes-before? x y)
|
||||
(cond
|
||||
[(depends-on? (car x) (car y)) #t]
|
||||
[(depends-on? (car y) (car x)) #f]
|
||||
[else (< (cdr x) (cdr y))]))
|
||||
|
||||
(define (depends-on? arg1 arg2)
|
||||
(and (arg-vars arg2)
|
||||
(ormap (λ (x) (free-identifier=? x (arg-var arg1)))
|
||||
(arg-vars arg2))))
|
||||
|
||||
(let* ([numbered (for/list ([arg (in-list args)]
|
||||
[i (in-naturals)])
|
||||
(cons arg i))]
|
||||
[sorted
|
||||
(sort
|
||||
numbered
|
||||
(λ (x y) (not (comes-before? x y))))])
|
||||
(values (map car sorted)
|
||||
(map cdr sorted))))
|
||||
|
||||
;; args/vars->arglist : (listof arg?) (vectorof identifier?) -> syntax
|
||||
;; (vector-length vars) = (length args)
|
||||
|
|
|
@ -2,23 +2,32 @@
|
|||
(require racket/contract
|
||||
racket/pretty)
|
||||
|
||||
#;
|
||||
(pretty-print
|
||||
(syntax->datum (expand-once
|
||||
#'(->i ([x number?] [y (x) (<=/c x)]) any))))
|
||||
|
||||
(pretty-print
|
||||
(syntax->datum (expand
|
||||
#'(->i ([x number?] [y number?] [z (x y) (if (<= x y) (<=/c x) (<=/c y))]) any))))
|
||||
|
||||
#'(->i ([x number?]
|
||||
[y (x z) (between/c x z)]
|
||||
[z number?])
|
||||
any))))
|
||||
|
||||
#;
|
||||
((contract (->i ([x number?] [y (x) (<=/c x)]) any)
|
||||
(λ (x y) (+ x y))
|
||||
(pretty-print
|
||||
(syntax->datum (expand
|
||||
#'(->i ([x number?]
|
||||
[y (x z) (between/c x z)]
|
||||
[z number?])
|
||||
any))))
|
||||
|
||||
|
||||
((contract (->i ([x number?]
|
||||
[y (x z) (between/c x z)]
|
||||
[z number?])
|
||||
any)
|
||||
(λ (x y z) (+ x y z))
|
||||
'pos 'neg)
|
||||
-1 -1)
|
||||
|
||||
1 2 3)
|
||||
;; => 6
|
||||
|
||||
#|
|
||||
;; timing tests:
|
||||
|
||||
(define f1
|
||||
|
@ -48,7 +57,7 @@
|
|||
|
||||
'f1 (tme f1)
|
||||
'f2 (tme f2)
|
||||
|
||||
|#
|
||||
|
||||
#|
|
||||
test cases:
|
||||
|
@ -158,5 +167,13 @@ test cases:
|
|||
[y (x) number?])
|
||||
;; => no syntax error
|
||||
|
||||
((contract (->i ([x number?]
|
||||
[y (x z) (between/c x z)]
|
||||
[z number?])
|
||||
any)
|
||||
(λ (x y z) (+ x y z))
|
||||
'pos 'neg)
|
||||
1 2 3)
|
||||
;; => 6
|
||||
|
||||
|#
|
||||
|
|
Loading…
Reference in New Issue
Block a user