Set forgotten svn:eol-style to native
svn: r11095
This commit is contained in:
Jens Axel Soegaard
parent
302dae857e
commit
ac509e8b2d
|
|
@ -1,10 +1,10 @@
|
|||
;;;
|
||||
;;; COMPREHENSIONS
|
||||
;;;
|
||||
|
||||
(module comprehension-struct mzscheme
|
||||
(provide comprehension comprehension? comprehension-loop make-comprehension
|
||||
comprehension-payload)
|
||||
|
||||
(define-struct comprehension
|
||||
(name loop payload)))
|
||||
;;;
|
||||
;;; COMPREHENSIONS
|
||||
;;;
|
||||
|
||||
(module comprehension-struct mzscheme
|
||||
(provide comprehension comprehension? comprehension-loop make-comprehension
|
||||
comprehension-payload)
|
||||
|
||||
(define-struct comprehension
|
||||
(name loop payload)))
|
||||
|
|
|
|||
|
|
@ -1,404 +1,404 @@
|
|||
;;;
|
||||
;;; COMPREHENSIONS
|
||||
;;;
|
||||
|
||||
(module comprehensions mzscheme
|
||||
(provide (all-defined))
|
||||
|
||||
(require "generators.scm")
|
||||
(require-for-syntax "generators.scm")
|
||||
(require-for-syntax "expansion.scm")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
; This is the model comprehension
|
||||
|
||||
#;(define-syntax (list-ec stx)
|
||||
(syntax-case stx ()
|
||||
[(_ body)
|
||||
#'(list body)]
|
||||
[(_ clause ... body)
|
||||
(begin
|
||||
(check-all-clauses-are-generators-or-filters #'(clause ...) 'list-ec)
|
||||
(when (and (null? (syntax->list #'(clause (... ...))))
|
||||
(generator-clause? #'body))
|
||||
(raise-syntax-error
|
||||
'list-ec
|
||||
(string-append "Generator used in body position. "
|
||||
"Expected (list <generator-or-filter> ... <expr>), got: ")
|
||||
#'body))
|
||||
#`(let ([result '()])
|
||||
#,((expand-clauses #'(clause ...))
|
||||
#'(set! result (cons body result)))
|
||||
(reverse result)))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'name-ec
|
||||
"expected (list-ec <generator-or-filter> ... <expr>), got: "
|
||||
st)]))
|
||||
|
||||
(define-syntax (define-comprehension stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name-ec inserter body expansion)
|
||||
#'(define-syntax (name-ec st)
|
||||
(syntax-case st ()
|
||||
[(_ clause (... ...) body)
|
||||
(begin
|
||||
(check-all-clauses-are-generators-or-filters #'(clause (... ...)) 'name-ec)
|
||||
(when (and (null? (syntax->list #'(clause (... ...))))
|
||||
(generator-clause? #'body))
|
||||
(raise-syntax-error
|
||||
'name-ec (format
|
||||
(string-append
|
||||
"Generator used in body position. "
|
||||
"Expected (~a <generator-or-filter> ... <expr>), got: ")
|
||||
'name-ec)
|
||||
#'body))
|
||||
(let ([inserter (expand-clauses #'(clause (... ...)))])
|
||||
expansion))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'name-ec
|
||||
(format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
|
||||
st)]))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'define-comprehension
|
||||
"expected (define-comprehension <name> <inserter> <body> <expansion>) "
|
||||
stx)]))
|
||||
|
||||
|
||||
(define-comprehension list-ec
|
||||
insert-payload-in-loop body
|
||||
#`(let ([result '()])
|
||||
#,(insert-payload-in-loop
|
||||
#'(set! result (cons body result)))
|
||||
(reverse result)))
|
||||
|
||||
(define-comprehension do-ec
|
||||
insert-payload-in-loop body
|
||||
(insert-payload-in-loop
|
||||
#'body))
|
||||
|
||||
(define-syntax (define-derived-comprehension stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name-ec (literal ...) (pattern clauses-to-check template) ...)
|
||||
#'(define-syntax (name-ec st)
|
||||
(define (raise-error)
|
||||
(raise-syntax-error
|
||||
'name-ec
|
||||
(format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
|
||||
st))
|
||||
(syntax-case st ()
|
||||
[(name clause (... ...) body)
|
||||
(begin
|
||||
(syntax-case #'(name clause (... ...) body) (literal ...)
|
||||
[pattern
|
||||
(begin
|
||||
(check-all-clauses-are-generators-or-filters #'clauses-to-check 'name-ec)
|
||||
#'template)]
|
||||
...
|
||||
[_else (raise-error)]))]
|
||||
[_ (raise-error)]))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'define-derived-comprehension
|
||||
"expected (define-derived-comprehension name-ec (literal ...) (pattern template) ...), got: "
|
||||
stx)]))
|
||||
|
||||
(define-derived-comprehension append-ec ()
|
||||
((append-ec etc ... body)
|
||||
(etc ...)
|
||||
(apply append (list-ec etc ... body))))
|
||||
|
||||
(define-derived-comprehension string-ec ()
|
||||
((string-ec etc ... body)
|
||||
(etc ...)
|
||||
(list->string (list-ec etc ... body)) ))
|
||||
|
||||
(define-derived-comprehension string-append-ec ()
|
||||
((string-append-ec etc ... body)
|
||||
(etc ...)
|
||||
(apply string-append (list-ec etc ... body)) ))
|
||||
|
||||
(define-derived-comprehension vector-ec ()
|
||||
((vector-ec etc ... body)
|
||||
(etc ...)
|
||||
(list->vector (list-ec etc ... body)) ))
|
||||
|
||||
|
||||
(define-derived-comprehension vector-of-length-ec (nested)
|
||||
((vector-of-length-ec k (nested q1 ...) q etc1 etc ... body)
|
||||
(q1 ... q etc ... body)
|
||||
(vector-of-length-ec k (nested q1 ... q) etc1 etc ... body) )
|
||||
((vector-of-length-ec k q1 q2 etc1 etc ... body)
|
||||
(q1 q2 etc1 etc ... body)
|
||||
(vector-of-length-ec k (nested q1 q2) etc1 etc ... body) )
|
||||
((vector-of-length-ec k body)
|
||||
()
|
||||
(vector-of-length-ec k (nested) body) )
|
||||
((vector-of-length-ec k qualifier body)
|
||||
(qualifier)
|
||||
(let ((len k))
|
||||
(let ((vec (make-vector len))
|
||||
(i 0) )
|
||||
(do-ec qualifier
|
||||
(if (< i len)
|
||||
(begin (vector-set! vec i body)
|
||||
(set! i (+ i 1)) )
|
||||
(error "vector is too short for the comprehension") ))
|
||||
(if (= i len)
|
||||
vec
|
||||
(error "vector is too long for the comprehension") )))))
|
||||
|
||||
|
||||
(define-derived-comprehension fold3-ec (nested)
|
||||
((fold3-ec x0 (nested q1 ...) q etc ... expr f1 f2)
|
||||
(q1 ... q)
|
||||
(fold3-ec x0 (nested q1 ... q) etc ... expr f1 f2) )
|
||||
((fold3-ec x0 q1 q2 etc ... expr f1 f2)
|
||||
(q1 q2 etc ...)
|
||||
(fold3-ec x0 (nested q1 q2) etc ... expr f1 f2) )
|
||||
((fold3-ec x0 expression f1 f2)
|
||||
()
|
||||
(fold3-ec x0 (nested) expression f1 f2) )
|
||||
|
||||
((fold3-ec x0 qualifier expression f1 f2)
|
||||
(qualifier)
|
||||
(let ((result #f) (empty #t))
|
||||
(do-ec qualifier
|
||||
(let ((value expression)) ; don't duplicate
|
||||
(if empty
|
||||
(begin (set! result (f1 value))
|
||||
(set! empty #f) )
|
||||
(set! result (f2 value result)) )))
|
||||
(if empty x0 result) )))
|
||||
|
||||
(define-derived-comprehension fold-ec (nested)
|
||||
((fold-ec x0 (nested q1 ...) q etc1 etc ... body f2)
|
||||
(q q1 ... etc1 etc2 etc ...)
|
||||
(fold-ec x0 (nested q1 ... q) etc1 etc ... body f2) )
|
||||
((fold-ec x0 q1 q2 etc ... body f2)
|
||||
(q1 q2 etc ...)
|
||||
(fold-ec x0 (nested q1 q2) etc ... body f2) )
|
||||
((fold-ec x0 body f2)
|
||||
()
|
||||
(fold-ec x0 (nested) body f2) )
|
||||
((fold-ec x0 qualifier body f2)
|
||||
(qualifier)
|
||||
(let ((result x0))
|
||||
(do-ec qualifier (set! result (f2 body result)))
|
||||
result )))
|
||||
|
||||
(define-derived-comprehension sum-ec ()
|
||||
((sum-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold-ec (+) etc ... body +) ))
|
||||
|
||||
(define-derived-comprehension product-ec ()
|
||||
((product-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold-ec (*) etc ... body *) ))
|
||||
|
||||
|
||||
(define-syntax (min-ec2 stx)
|
||||
(define (check clauses body)
|
||||
(check-all-clauses-are-generators-or-filters clauses 'min-ec)
|
||||
(when (and (null? (syntax->list clauses))
|
||||
(generator-clause? body))
|
||||
(raise-syntax-error
|
||||
'min-ec (string-append
|
||||
"Generator used in body position. "
|
||||
"Expected (min-ec <generator-or-filter> ... <expr>), got: ")
|
||||
body)))
|
||||
|
||||
(syntax-case stx (on-new-min)
|
||||
[(_ clause ... (on-new-min on-min-expr ...) body)
|
||||
(begin
|
||||
(check #'(clause ...) #'body)
|
||||
(let ([insert-body (expand-clauses #'(clause ...))])
|
||||
#`(let ([minimum +inf.0])
|
||||
#,(insert-body
|
||||
#'(let ([x body])
|
||||
(when (< x minimum)
|
||||
(set! minimum x)
|
||||
on-min-expr ...
|
||||
x)))
|
||||
minimum)))]
|
||||
[(_ clause ... body)
|
||||
(syntax/loc stx (min-ec clause ... (on-new-min (void)) body))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'min-ec
|
||||
(format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
|
||||
stx)]))
|
||||
|
||||
#;(define-derived-comprehension min-ec ()
|
||||
((min-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold3-ec (min) etc ... body min min)))
|
||||
|
||||
(define-derived-comprehension min-ec (on-new-min)
|
||||
((min-ec etc ... (on-new-min on-expr ...) body)
|
||||
(etc ...)
|
||||
(fold3-ec (min) etc ... body min (lambda (new old)
|
||||
(if (< new old)
|
||||
(begin
|
||||
on-expr ...
|
||||
new)
|
||||
old))))
|
||||
((min-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold3-ec (min) etc ... body min min)))
|
||||
|
||||
(define-syntax (max-ec stx)
|
||||
(define (check clauses body)
|
||||
(check-all-clauses-are-generators-or-filters clauses 'max-ec)
|
||||
(when (and (null? (syntax->list clauses))
|
||||
(generator-clause? body))
|
||||
(raise-syntax-error
|
||||
'max-ec (string-append
|
||||
"Generator used in body position. "
|
||||
"Expected (min-ec <generator-or-filter> ... <expr>), got: ")
|
||||
body)))
|
||||
|
||||
(syntax-case stx (on-new-max)
|
||||
[(_ clause ... (on-new-max on-max-expr ...) body)
|
||||
(begin
|
||||
(check #'(clause ...) #'body)
|
||||
(let ([insert-body (expand-clauses #'(clause ...))])
|
||||
#`(let ([maximum -inf.0])
|
||||
#,(insert-body
|
||||
#'(let ([x body])
|
||||
(when (> x maximum)
|
||||
(set! maximum x)
|
||||
on-max-expr ...
|
||||
x)))
|
||||
maximum)))]
|
||||
[(_ clause ... body)
|
||||
(syntax/loc stx (max-ec clause ... (on-new-max (void)) body))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'max-ec
|
||||
(format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
|
||||
stx)]))
|
||||
|
||||
|
||||
#;(define-derived-comprehension max-ec ()
|
||||
((max-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold3-ec (max) etc ... body max max) ))
|
||||
|
||||
(define-derived-comprehension last-ec (nested)
|
||||
((last-ec default (nested q1 ...) q etc ... body)
|
||||
(q1 ... q etc ...)
|
||||
(last-ec default (nested q1 ... q) etc ... body) )
|
||||
((last-ec default q1 q2 etc ... body)
|
||||
(q1 q2 etc ...)
|
||||
(last-ec default (nested q1 q2) etc ... body) )
|
||||
((last-ec default body)
|
||||
()
|
||||
(last-ec default (nested) body) )
|
||||
|
||||
((last-ec default qualifier body)
|
||||
(qualifier)
|
||||
(let ((result default))
|
||||
(do-ec qualifier (set! result body))
|
||||
result )))
|
||||
|
||||
|
||||
(define-derived-comprehension first-ec (nested)
|
||||
((first-ec default (nested q1 ...) q etc ... body)
|
||||
(q1 ... q etc ...)
|
||||
(first-ec default (nested q1 ... q) etc ... body) )
|
||||
((first-ec default q1 q2 etc ... body)
|
||||
(q1 q2 etc ...)
|
||||
(first-ec default (nested q1 q2) etc ... body) )
|
||||
((first-ec default body)
|
||||
()
|
||||
(first-ec default (nested) body) )
|
||||
|
||||
((first-ec default qualifier body)
|
||||
(qualifier)
|
||||
(let ((result default) (stop #f))
|
||||
(ec-guarded-do-ec
|
||||
stop
|
||||
(nested qualifier)
|
||||
(begin (set! result body)
|
||||
(set! stop #t) ))
|
||||
result )))
|
||||
|
||||
; (ec-guarded-do-ec stop (nested q ...) cmd)
|
||||
; constructs (do-ec q ... cmd) where the generators gen in q ... are
|
||||
; replaced by (:until gen stop).
|
||||
|
||||
(define-derived-comprehension ec-guarded-do-ec (nested if not and or begin)
|
||||
((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
|
||||
(q1 ... q2 ...)
|
||||
(ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
|
||||
(q ...)
|
||||
(if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
|
||||
(q ...)
|
||||
(if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
|
||||
(q ...)
|
||||
(if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
|
||||
(q ...)
|
||||
(if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
|
||||
(q ...)
|
||||
(begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested gen q ...) cmd)
|
||||
(q ...)
|
||||
(do-ec
|
||||
(:until gen stop)
|
||||
(ec-guarded-do-ec stop (nested q ...) cmd) ))
|
||||
|
||||
((ec-guarded-do-ec stop (nested) cmd)
|
||||
()
|
||||
(do-ec cmd) ))
|
||||
|
||||
; ==========================================================================
|
||||
; The early-stopping comprehensions any?-ec every?-ec
|
||||
; ==========================================================================
|
||||
|
||||
(define-derived-comprehension any?-ec (nested)
|
||||
((any?-ec (nested q1 ...) q etc ... body)
|
||||
(q etc ...)
|
||||
(any?-ec (nested q1 ... q) etc ... body) )
|
||||
((any?-ec q1 q2 etc ... body)
|
||||
(q1 q2 etc ...)
|
||||
(any?-ec (nested q1 q2) etc ... body) )
|
||||
((any?-ec expression)
|
||||
()
|
||||
(any?-ec (nested) expression) )
|
||||
|
||||
((any?-ec qualifier expression)
|
||||
(qualifier)
|
||||
(first-ec #f qualifier (if expression) #t) ))
|
||||
|
||||
|
||||
(define-derived-comprehension every?-ec (nested)
|
||||
((every?-ec (nested q1 ...) q etc ... body)
|
||||
(q1 ... q etc ...)
|
||||
(every?-ec (nested q1 ... q) etc ... body) )
|
||||
((every?-ec q1 q2 etc ... body)
|
||||
(q1 q2 etc ...)
|
||||
(every?-ec (nested q1 q2) etc ... body) )
|
||||
((every?-ec expression)
|
||||
()
|
||||
(every?-ec (nested) expression) )
|
||||
|
||||
((every?-ec qualifier expression)
|
||||
(qualifier)
|
||||
(first-ec #t qualifier (if (not expression)) #f) ))
|
||||
|
||||
;;;
|
||||
;;; COMPREHENSIONS
|
||||
;;;
|
||||
|
||||
(module comprehensions mzscheme
|
||||
(provide (all-defined))
|
||||
|
||||
(require "generators.scm")
|
||||
(require-for-syntax "generators.scm")
|
||||
(require-for-syntax "expansion.scm")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
; This is the model comprehension
|
||||
|
||||
#;(define-syntax (list-ec stx)
|
||||
(syntax-case stx ()
|
||||
[(_ body)
|
||||
#'(list body)]
|
||||
[(_ clause ... body)
|
||||
(begin
|
||||
(check-all-clauses-are-generators-or-filters #'(clause ...) 'list-ec)
|
||||
(when (and (null? (syntax->list #'(clause (... ...))))
|
||||
(generator-clause? #'body))
|
||||
(raise-syntax-error
|
||||
'list-ec
|
||||
(string-append "Generator used in body position. "
|
||||
"Expected (list <generator-or-filter> ... <expr>), got: ")
|
||||
#'body))
|
||||
#`(let ([result '()])
|
||||
#,((expand-clauses #'(clause ...))
|
||||
#'(set! result (cons body result)))
|
||||
(reverse result)))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'name-ec
|
||||
"expected (list-ec <generator-or-filter> ... <expr>), got: "
|
||||
st)]))
|
||||
|
||||
(define-syntax (define-comprehension stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name-ec inserter body expansion)
|
||||
#'(define-syntax (name-ec st)
|
||||
(syntax-case st ()
|
||||
[(_ clause (... ...) body)
|
||||
(begin
|
||||
(check-all-clauses-are-generators-or-filters #'(clause (... ...)) 'name-ec)
|
||||
(when (and (null? (syntax->list #'(clause (... ...))))
|
||||
(generator-clause? #'body))
|
||||
(raise-syntax-error
|
||||
'name-ec (format
|
||||
(string-append
|
||||
"Generator used in body position. "
|
||||
"Expected (~a <generator-or-filter> ... <expr>), got: ")
|
||||
'name-ec)
|
||||
#'body))
|
||||
(let ([inserter (expand-clauses #'(clause (... ...)))])
|
||||
expansion))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'name-ec
|
||||
(format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
|
||||
st)]))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'define-comprehension
|
||||
"expected (define-comprehension <name> <inserter> <body> <expansion>) "
|
||||
stx)]))
|
||||
|
||||
|
||||
(define-comprehension list-ec
|
||||
insert-payload-in-loop body
|
||||
#`(let ([result '()])
|
||||
#,(insert-payload-in-loop
|
||||
#'(set! result (cons body result)))
|
||||
(reverse result)))
|
||||
|
||||
(define-comprehension do-ec
|
||||
insert-payload-in-loop body
|
||||
(insert-payload-in-loop
|
||||
#'body))
|
||||
|
||||
(define-syntax (define-derived-comprehension stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name-ec (literal ...) (pattern clauses-to-check template) ...)
|
||||
#'(define-syntax (name-ec st)
|
||||
(define (raise-error)
|
||||
(raise-syntax-error
|
||||
'name-ec
|
||||
(format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
|
||||
st))
|
||||
(syntax-case st ()
|
||||
[(name clause (... ...) body)
|
||||
(begin
|
||||
(syntax-case #'(name clause (... ...) body) (literal ...)
|
||||
[pattern
|
||||
(begin
|
||||
(check-all-clauses-are-generators-or-filters #'clauses-to-check 'name-ec)
|
||||
#'template)]
|
||||
...
|
||||
[_else (raise-error)]))]
|
||||
[_ (raise-error)]))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'define-derived-comprehension
|
||||
"expected (define-derived-comprehension name-ec (literal ...) (pattern template) ...), got: "
|
||||
stx)]))
|
||||
|
||||
(define-derived-comprehension append-ec ()
|
||||
((append-ec etc ... body)
|
||||
(etc ...)
|
||||
(apply append (list-ec etc ... body))))
|
||||
|
||||
(define-derived-comprehension string-ec ()
|
||||
((string-ec etc ... body)
|
||||
(etc ...)
|
||||
(list->string (list-ec etc ... body)) ))
|
||||
|
||||
(define-derived-comprehension string-append-ec ()
|
||||
((string-append-ec etc ... body)
|
||||
(etc ...)
|
||||
(apply string-append (list-ec etc ... body)) ))
|
||||
|
||||
(define-derived-comprehension vector-ec ()
|
||||
((vector-ec etc ... body)
|
||||
(etc ...)
|
||||
(list->vector (list-ec etc ... body)) ))
|
||||
|
||||
|
||||
(define-derived-comprehension vector-of-length-ec (nested)
|
||||
((vector-of-length-ec k (nested q1 ...) q etc1 etc ... body)
|
||||
(q1 ... q etc ... body)
|
||||
(vector-of-length-ec k (nested q1 ... q) etc1 etc ... body) )
|
||||
((vector-of-length-ec k q1 q2 etc1 etc ... body)
|
||||
(q1 q2 etc1 etc ... body)
|
||||
(vector-of-length-ec k (nested q1 q2) etc1 etc ... body) )
|
||||
((vector-of-length-ec k body)
|
||||
()
|
||||
(vector-of-length-ec k (nested) body) )
|
||||
((vector-of-length-ec k qualifier body)
|
||||
(qualifier)
|
||||
(let ((len k))
|
||||
(let ((vec (make-vector len))
|
||||
(i 0) )
|
||||
(do-ec qualifier
|
||||
(if (< i len)
|
||||
(begin (vector-set! vec i body)
|
||||
(set! i (+ i 1)) )
|
||||
(error "vector is too short for the comprehension") ))
|
||||
(if (= i len)
|
||||
vec
|
||||
(error "vector is too long for the comprehension") )))))
|
||||
|
||||
|
||||
(define-derived-comprehension fold3-ec (nested)
|
||||
((fold3-ec x0 (nested q1 ...) q etc ... expr f1 f2)
|
||||
(q1 ... q)
|
||||
(fold3-ec x0 (nested q1 ... q) etc ... expr f1 f2) )
|
||||
((fold3-ec x0 q1 q2 etc ... expr f1 f2)
|
||||
(q1 q2 etc ...)
|
||||
(fold3-ec x0 (nested q1 q2) etc ... expr f1 f2) )
|
||||
((fold3-ec x0 expression f1 f2)
|
||||
()
|
||||
(fold3-ec x0 (nested) expression f1 f2) )
|
||||
|
||||
((fold3-ec x0 qualifier expression f1 f2)
|
||||
(qualifier)
|
||||
(let ((result #f) (empty #t))
|
||||
(do-ec qualifier
|
||||
(let ((value expression)) ; don't duplicate
|
||||
(if empty
|
||||
(begin (set! result (f1 value))
|
||||
(set! empty #f) )
|
||||
(set! result (f2 value result)) )))
|
||||
(if empty x0 result) )))
|
||||
|
||||
(define-derived-comprehension fold-ec (nested)
|
||||
((fold-ec x0 (nested q1 ...) q etc1 etc ... body f2)
|
||||
(q q1 ... etc1 etc2 etc ...)
|
||||
(fold-ec x0 (nested q1 ... q) etc1 etc ... body f2) )
|
||||
((fold-ec x0 q1 q2 etc ... body f2)
|
||||
(q1 q2 etc ...)
|
||||
(fold-ec x0 (nested q1 q2) etc ... body f2) )
|
||||
((fold-ec x0 body f2)
|
||||
()
|
||||
(fold-ec x0 (nested) body f2) )
|
||||
((fold-ec x0 qualifier body f2)
|
||||
(qualifier)
|
||||
(let ((result x0))
|
||||
(do-ec qualifier (set! result (f2 body result)))
|
||||
result )))
|
||||
|
||||
(define-derived-comprehension sum-ec ()
|
||||
((sum-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold-ec (+) etc ... body +) ))
|
||||
|
||||
(define-derived-comprehension product-ec ()
|
||||
((product-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold-ec (*) etc ... body *) ))
|
||||
|
||||
|
||||
(define-syntax (min-ec2 stx)
|
||||
(define (check clauses body)
|
||||
(check-all-clauses-are-generators-or-filters clauses 'min-ec)
|
||||
(when (and (null? (syntax->list clauses))
|
||||
(generator-clause? body))
|
||||
(raise-syntax-error
|
||||
'min-ec (string-append
|
||||
"Generator used in body position. "
|
||||
"Expected (min-ec <generator-or-filter> ... <expr>), got: ")
|
||||
body)))
|
||||
|
||||
(syntax-case stx (on-new-min)
|
||||
[(_ clause ... (on-new-min on-min-expr ...) body)
|
||||
(begin
|
||||
(check #'(clause ...) #'body)
|
||||
(let ([insert-body (expand-clauses #'(clause ...))])
|
||||
#`(let ([minimum +inf.0])
|
||||
#,(insert-body
|
||||
#'(let ([x body])
|
||||
(when (< x minimum)
|
||||
(set! minimum x)
|
||||
on-min-expr ...
|
||||
x)))
|
||||
minimum)))]
|
||||
[(_ clause ... body)
|
||||
(syntax/loc stx (min-ec clause ... (on-new-min (void)) body))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'min-ec
|
||||
(format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
|
||||
stx)]))
|
||||
|
||||
#;(define-derived-comprehension min-ec ()
|
||||
((min-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold3-ec (min) etc ... body min min)))
|
||||
|
||||
(define-derived-comprehension min-ec (on-new-min)
|
||||
((min-ec etc ... (on-new-min on-expr ...) body)
|
||||
(etc ...)
|
||||
(fold3-ec (min) etc ... body min (lambda (new old)
|
||||
(if (< new old)
|
||||
(begin
|
||||
on-expr ...
|
||||
new)
|
||||
old))))
|
||||
((min-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold3-ec (min) etc ... body min min)))
|
||||
|
||||
(define-syntax (max-ec stx)
|
||||
(define (check clauses body)
|
||||
(check-all-clauses-are-generators-or-filters clauses 'max-ec)
|
||||
(when (and (null? (syntax->list clauses))
|
||||
(generator-clause? body))
|
||||
(raise-syntax-error
|
||||
'max-ec (string-append
|
||||
"Generator used in body position. "
|
||||
"Expected (min-ec <generator-or-filter> ... <expr>), got: ")
|
||||
body)))
|
||||
|
||||
(syntax-case stx (on-new-max)
|
||||
[(_ clause ... (on-new-max on-max-expr ...) body)
|
||||
(begin
|
||||
(check #'(clause ...) #'body)
|
||||
(let ([insert-body (expand-clauses #'(clause ...))])
|
||||
#`(let ([maximum -inf.0])
|
||||
#,(insert-body
|
||||
#'(let ([x body])
|
||||
(when (> x maximum)
|
||||
(set! maximum x)
|
||||
on-max-expr ...
|
||||
x)))
|
||||
maximum)))]
|
||||
[(_ clause ... body)
|
||||
(syntax/loc stx (max-ec clause ... (on-new-max (void)) body))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
'max-ec
|
||||
(format "expected (~a <generator-or-filter> ... <expr>), got: " 'name-ec)
|
||||
stx)]))
|
||||
|
||||
|
||||
#;(define-derived-comprehension max-ec ()
|
||||
((max-ec etc ... body)
|
||||
(etc ...)
|
||||
(fold3-ec (max) etc ... body max max) ))
|
||||
|
||||
(define-derived-comprehension last-ec (nested)
|
||||
((last-ec default (nested q1 ...) q etc ... body)
|
||||
(q1 ... q etc ...)
|
||||
(last-ec default (nested q1 ... q) etc ... body) )
|
||||
((last-ec default q1 q2 etc ... body)
|
||||
(q1 q2 etc ...)
|
||||
(last-ec default (nested q1 q2) etc ... body) )
|
||||
((last-ec default body)
|
||||
()
|
||||
(last-ec default (nested) body) )
|
||||
|
||||
((last-ec default qualifier body)
|
||||
(qualifier)
|
||||
(let ((result default))
|
||||
(do-ec qualifier (set! result body))
|
||||
result )))
|
||||
|
||||
|
||||
(define-derived-comprehension first-ec (nested)
|
||||
((first-ec default (nested q1 ...) q etc ... body)
|
||||
(q1 ... q etc ...)
|
||||
(first-ec default (nested q1 ... q) etc ... body) )
|
||||
((first-ec default q1 q2 etc ... body)
|
||||
(q1 q2 etc ...)
|
||||
(first-ec default (nested q1 q2) etc ... body) )
|
||||
((first-ec default body)
|
||||
()
|
||||
(first-ec default (nested) body) )
|
||||
|
||||
((first-ec default qualifier body)
|
||||
(qualifier)
|
||||
(let ((result default) (stop #f))
|
||||
(ec-guarded-do-ec
|
||||
stop
|
||||
(nested qualifier)
|
||||
(begin (set! result body)
|
||||
(set! stop #t) ))
|
||||
result )))
|
||||
|
||||
; (ec-guarded-do-ec stop (nested q ...) cmd)
|
||||
; constructs (do-ec q ... cmd) where the generators gen in q ... are
|
||||
; replaced by (:until gen stop).
|
||||
|
||||
(define-derived-comprehension ec-guarded-do-ec (nested if not and or begin)
|
||||
((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
|
||||
(q1 ... q2 ...)
|
||||
(ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
|
||||
(q ...)
|
||||
(if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
|
||||
(q ...)
|
||||
(if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
|
||||
(q ...)
|
||||
(if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
|
||||
(q ...)
|
||||
(if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
|
||||
(q ...)
|
||||
(begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
|
||||
|
||||
((ec-guarded-do-ec stop (nested gen q ...) cmd)
|
||||
(q ...)
|
||||
(do-ec
|
||||
(:until gen stop)
|
||||
(ec-guarded-do-ec stop (nested q ...) cmd) ))
|
||||
|
||||
((ec-guarded-do-ec stop (nested) cmd)
|
||||
()
|
||||
(do-ec cmd) ))
|
||||
|
||||
; ==========================================================================
|
||||
; The early-stopping comprehensions any?-ec every?-ec
|
||||
; ==========================================================================
|
||||
|
||||
(define-derived-comprehension any?-ec (nested)
|
||||
((any?-ec (nested q1 ...) q etc ... body)
|
||||
(q etc ...)
|
||||
(any?-ec (nested q1 ... q) etc ... body) )
|
||||
((any?-ec q1 q2 etc ... body)
|
||||
(q1 q2 etc ...)
|
||||
(any?-ec (nested q1 q2) etc ... body) )
|
||||
((any?-ec expression)
|
||||
()
|
||||
(any?-ec (nested) expression) )
|
||||
|
||||
((any?-ec qualifier expression)
|
||||
(qualifier)
|
||||
(first-ec #f qualifier (if expression) #t) ))
|
||||
|
||||
|
||||
(define-derived-comprehension every?-ec (nested)
|
||||
((every?-ec (nested q1 ...) q etc ... body)
|
||||
(q1 ... q etc ...)
|
||||
(every?-ec (nested q1 ... q) etc ... body) )
|
||||
((every?-ec q1 q2 etc ... body)
|
||||
(q1 q2 etc ...)
|
||||
(every?-ec (nested q1 q2) etc ... body) )
|
||||
((every?-ec expression)
|
||||
()
|
||||
(every?-ec (nested) expression) )
|
||||
|
||||
((every?-ec qualifier expression)
|
||||
(qualifier)
|
||||
(first-ec #t qualifier (if (not expression)) #f) ))
|
||||
|
||||
)
|
||||
|
|
@ -1,174 +1,174 @@
|
|||
;;;
|
||||
;;; DISPATCHING
|
||||
;;;
|
||||
|
||||
(module dispatching mzscheme
|
||||
(provide (all-defined))
|
||||
|
||||
(require-for-syntax "expansion.scm" "generators.scm")
|
||||
(require "expansion.scm" "generators.scm")
|
||||
|
||||
(define-generator (:dispatched form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) dispatch expr1 expr2 ...)
|
||||
#'(:parallel (:integers i)
|
||||
(:dispatched var dispatch expr1 expr2 ...))]
|
||||
[(_ var dispatch expr1 expr2 ...)
|
||||
#'(:do (let ([d dispatch]
|
||||
[args (list expr1 expr2 ...)]
|
||||
[g #f]
|
||||
[empty (list #f)])
|
||||
(set! g (d args))
|
||||
(if (not (procedure? g))
|
||||
(error "unrecognized arguments in dispatching"
|
||||
args (d '()))))
|
||||
((var (g empty)))
|
||||
(not (eq? var empty))
|
||||
(let ())
|
||||
#t
|
||||
((g empty)))]))
|
||||
|
||||
; Despite the name, this isn't a generator.
|
||||
; It's syntax used to make a first-order generator from generator syntax.
|
||||
; TODO: insert ec-simplify
|
||||
(define-syntax :generator-proc
|
||||
(lambda (form-stx)
|
||||
(syntax-case form-stx (:do let)
|
||||
[(_ (gen expr1 expr2 ...))
|
||||
(with-syntax ([(var) (generate-temporaries #'(empty))])
|
||||
(let ([loop (generator->loop #'(gen var expr1 expr2 ...))])
|
||||
(with-syntax
|
||||
([(obs (oc ...) ((lv li) ...)
|
||||
ne1? (((i ...) v) ...) (ic ...)
|
||||
ne2? (ls ...) )
|
||||
(loop-stx loop)])
|
||||
#'(let-values obs
|
||||
oc ...
|
||||
(let ((lv li) ... (ne2 #t))
|
||||
(let-values (((i) #f) ... ...) ; v not yet valid
|
||||
(lambda (empty)
|
||||
(if (and ne1? ne2)
|
||||
(begin
|
||||
(set!-values (i ...) v) ...
|
||||
ic ...
|
||||
(let ((value var))
|
||||
(if ne2?
|
||||
(begin (set! lv ls) ...)
|
||||
(set! ne2 #f) )
|
||||
value ))
|
||||
empty ))))))))])))
|
||||
|
||||
(define (dispatch-union d1 d2)
|
||||
(lambda (args)
|
||||
(let ((g1 (d1 args)) (g2 (d2 args)))
|
||||
(if g1
|
||||
(if g2
|
||||
(if (null? args)
|
||||
(append (if (list? g1) g1 (list g1))
|
||||
(if (list? g2) g2 (list g2)) )
|
||||
(error "dispatching conflict" args (d1 '()) (d2 '())) )
|
||||
g1 )
|
||||
(if g2 g2 #f) ))))
|
||||
|
||||
(define (make-initial-:-dispatch)
|
||||
(lambda (args)
|
||||
(case (length args)
|
||||
((0) 'SRFI42)
|
||||
((1) (let ((a1 (car args)))
|
||||
(cond
|
||||
((list? a1)
|
||||
(:generator-proc (:list a1)) )
|
||||
((string? a1)
|
||||
(:generator-proc (:string a1)) )
|
||||
((vector? a1)
|
||||
(:generator-proc (:vector a1)) )
|
||||
((and (integer? a1) (exact? a1))
|
||||
(:generator-proc (:range a1)) )
|
||||
((real? a1)
|
||||
(:generator-proc (:real-range a1)) )
|
||||
((input-port? a1)
|
||||
(:generator-proc (:port a1)) )
|
||||
(else
|
||||
#f ))))
|
||||
((2) (let ((a1 (car args)) (a2 (cadr args)))
|
||||
(cond
|
||||
((and (list? a1) (list? a2))
|
||||
(:generator-proc (:list a1 a2)) )
|
||||
((and (string? a1) (string? a1))
|
||||
(:generator-proc (:string a1 a2)) )
|
||||
((and (vector? a1) (vector? a2))
|
||||
(:generator-proc (:vector a1 a2)) )
|
||||
((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
|
||||
(:generator-proc (:range a1 a2)) )
|
||||
((and (real? a1) (real? a2))
|
||||
(:generator-proc (:real-range a1 a2)) )
|
||||
((and (char? a1) (char? a2))
|
||||
(:generator-proc (:char-range a1 a2)) )
|
||||
((and (input-port? a1) (procedure? a2))
|
||||
(:generator-proc (:port a1 a2)) )
|
||||
(else
|
||||
#f ))))
|
||||
((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
|
||||
(cond
|
||||
((and (list? a1) (list? a2) (list? a3))
|
||||
(:generator-proc (:list a1 a2 a3)) )
|
||||
((and (string? a1) (string? a1) (string? a3))
|
||||
(:generator-proc (:string a1 a2 a3)) )
|
||||
((and (vector? a1) (vector? a2) (vector? a3))
|
||||
(:generator-proc (:vector a1 a2 a3)) )
|
||||
((and (integer? a1) (exact? a1)
|
||||
(integer? a2) (exact? a2)
|
||||
(integer? a3) (exact? a3))
|
||||
(:generator-proc (:range a1 a2 a3)) )
|
||||
((and (real? a1) (real? a2) (real? a3))
|
||||
(:generator-proc (:real-range a1 a2 a3)) )
|
||||
(else
|
||||
#f ))))
|
||||
(else
|
||||
(letrec ((every?
|
||||
(lambda (pred args)
|
||||
(if (null? args)
|
||||
#t
|
||||
(and (pred (car args))
|
||||
(every? pred (cdr args)) )))))
|
||||
(cond
|
||||
((every? list? args)
|
||||
(:generator-proc (:list (apply append args))) )
|
||||
((every? string? args)
|
||||
(:generator-proc (:string (apply string-append args))) )
|
||||
((every? vector? args)
|
||||
(:generator-proc (:list (apply append (map vector->list args)))) )
|
||||
(else
|
||||
#f )))))))
|
||||
|
||||
(define :-dispatch
|
||||
(make-initial-:-dispatch) )
|
||||
|
||||
(define (:-dispatch-ref)
|
||||
:-dispatch )
|
||||
|
||||
(define (:-dispatch-set! dispatch)
|
||||
(if (not (procedure? dispatch))
|
||||
(error "not a procedure" dispatch) )
|
||||
(set! :-dispatch dispatch) )
|
||||
|
||||
(define-generator (: form-stx)
|
||||
(define (raise-error culprit)
|
||||
(raise-syntax-error
|
||||
'|: |
|
||||
"expected either (: <var> <expr>) or (: <var> (index <var>) <expr>), got:"
|
||||
form-stx culprit))
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) arg1 arg ...)
|
||||
(begin
|
||||
(unless (identifier? #'var) (raise-error #'var))
|
||||
(unless (identifier? #'i) (raise-error #'i))
|
||||
(syntax/loc form-stx
|
||||
(:dispatched var (index i) :-dispatch arg1 arg ...)))]
|
||||
[(_ var arg1 arg ...)
|
||||
(unless (identifier? #'var) (raise-error #'var))
|
||||
(syntax/loc form-stx
|
||||
(:dispatched var :-dispatch arg1 arg ...))]
|
||||
[_ (raise-error form-stx)]))
|
||||
|
||||
)
|
||||
;;;
|
||||
;;; DISPATCHING
|
||||
;;;
|
||||
|
||||
(module dispatching mzscheme
|
||||
(provide (all-defined))
|
||||
|
||||
(require-for-syntax "expansion.scm" "generators.scm")
|
||||
(require "expansion.scm" "generators.scm")
|
||||
|
||||
(define-generator (:dispatched form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) dispatch expr1 expr2 ...)
|
||||
#'(:parallel (:integers i)
|
||||
(:dispatched var dispatch expr1 expr2 ...))]
|
||||
[(_ var dispatch expr1 expr2 ...)
|
||||
#'(:do (let ([d dispatch]
|
||||
[args (list expr1 expr2 ...)]
|
||||
[g #f]
|
||||
[empty (list #f)])
|
||||
(set! g (d args))
|
||||
(if (not (procedure? g))
|
||||
(error "unrecognized arguments in dispatching"
|
||||
args (d '()))))
|
||||
((var (g empty)))
|
||||
(not (eq? var empty))
|
||||
(let ())
|
||||
#t
|
||||
((g empty)))]))
|
||||
|
||||
; Despite the name, this isn't a generator.
|
||||
; It's syntax used to make a first-order generator from generator syntax.
|
||||
; TODO: insert ec-simplify
|
||||
(define-syntax :generator-proc
|
||||
(lambda (form-stx)
|
||||
(syntax-case form-stx (:do let)
|
||||
[(_ (gen expr1 expr2 ...))
|
||||
(with-syntax ([(var) (generate-temporaries #'(empty))])
|
||||
(let ([loop (generator->loop #'(gen var expr1 expr2 ...))])
|
||||
(with-syntax
|
||||
([(obs (oc ...) ((lv li) ...)
|
||||
ne1? (((i ...) v) ...) (ic ...)
|
||||
ne2? (ls ...) )
|
||||
(loop-stx loop)])
|
||||
#'(let-values obs
|
||||
oc ...
|
||||
(let ((lv li) ... (ne2 #t))
|
||||
(let-values (((i) #f) ... ...) ; v not yet valid
|
||||
(lambda (empty)
|
||||
(if (and ne1? ne2)
|
||||
(begin
|
||||
(set!-values (i ...) v) ...
|
||||
ic ...
|
||||
(let ((value var))
|
||||
(if ne2?
|
||||
(begin (set! lv ls) ...)
|
||||
(set! ne2 #f) )
|
||||
value ))
|
||||
empty ))))))))])))
|
||||
|
||||
(define (dispatch-union d1 d2)
|
||||
(lambda (args)
|
||||
(let ((g1 (d1 args)) (g2 (d2 args)))
|
||||
(if g1
|
||||
(if g2
|
||||
(if (null? args)
|
||||
(append (if (list? g1) g1 (list g1))
|
||||
(if (list? g2) g2 (list g2)) )
|
||||
(error "dispatching conflict" args (d1 '()) (d2 '())) )
|
||||
g1 )
|
||||
(if g2 g2 #f) ))))
|
||||
|
||||
(define (make-initial-:-dispatch)
|
||||
(lambda (args)
|
||||
(case (length args)
|
||||
((0) 'SRFI42)
|
||||
((1) (let ((a1 (car args)))
|
||||
(cond
|
||||
((list? a1)
|
||||
(:generator-proc (:list a1)) )
|
||||
((string? a1)
|
||||
(:generator-proc (:string a1)) )
|
||||
((vector? a1)
|
||||
(:generator-proc (:vector a1)) )
|
||||
((and (integer? a1) (exact? a1))
|
||||
(:generator-proc (:range a1)) )
|
||||
((real? a1)
|
||||
(:generator-proc (:real-range a1)) )
|
||||
((input-port? a1)
|
||||
(:generator-proc (:port a1)) )
|
||||
(else
|
||||
#f ))))
|
||||
((2) (let ((a1 (car args)) (a2 (cadr args)))
|
||||
(cond
|
||||
((and (list? a1) (list? a2))
|
||||
(:generator-proc (:list a1 a2)) )
|
||||
((and (string? a1) (string? a1))
|
||||
(:generator-proc (:string a1 a2)) )
|
||||
((and (vector? a1) (vector? a2))
|
||||
(:generator-proc (:vector a1 a2)) )
|
||||
((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
|
||||
(:generator-proc (:range a1 a2)) )
|
||||
((and (real? a1) (real? a2))
|
||||
(:generator-proc (:real-range a1 a2)) )
|
||||
((and (char? a1) (char? a2))
|
||||
(:generator-proc (:char-range a1 a2)) )
|
||||
((and (input-port? a1) (procedure? a2))
|
||||
(:generator-proc (:port a1 a2)) )
|
||||
(else
|
||||
#f ))))
|
||||
((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
|
||||
(cond
|
||||
((and (list? a1) (list? a2) (list? a3))
|
||||
(:generator-proc (:list a1 a2 a3)) )
|
||||
((and (string? a1) (string? a1) (string? a3))
|
||||
(:generator-proc (:string a1 a2 a3)) )
|
||||
((and (vector? a1) (vector? a2) (vector? a3))
|
||||
(:generator-proc (:vector a1 a2 a3)) )
|
||||
((and (integer? a1) (exact? a1)
|
||||
(integer? a2) (exact? a2)
|
||||
(integer? a3) (exact? a3))
|
||||
(:generator-proc (:range a1 a2 a3)) )
|
||||
((and (real? a1) (real? a2) (real? a3))
|
||||
(:generator-proc (:real-range a1 a2 a3)) )
|
||||
(else
|
||||
#f ))))
|
||||
(else
|
||||
(letrec ((every?
|
||||
(lambda (pred args)
|
||||
(if (null? args)
|
||||
#t
|
||||
(and (pred (car args))
|
||||
(every? pred (cdr args)) )))))
|
||||
(cond
|
||||
((every? list? args)
|
||||
(:generator-proc (:list (apply append args))) )
|
||||
((every? string? args)
|
||||
(:generator-proc (:string (apply string-append args))) )
|
||||
((every? vector? args)
|
||||
(:generator-proc (:list (apply append (map vector->list args)))) )
|
||||
(else
|
||||
#f )))))))
|
||||
|
||||
(define :-dispatch
|
||||
(make-initial-:-dispatch) )
|
||||
|
||||
(define (:-dispatch-ref)
|
||||
:-dispatch )
|
||||
|
||||
(define (:-dispatch-set! dispatch)
|
||||
(if (not (procedure? dispatch))
|
||||
(error "not a procedure" dispatch) )
|
||||
(set! :-dispatch dispatch) )
|
||||
|
||||
(define-generator (: form-stx)
|
||||
(define (raise-error culprit)
|
||||
(raise-syntax-error
|
||||
'|: |
|
||||
"expected either (: <var> <expr>) or (: <var> (index <var>) <expr>), got:"
|
||||
form-stx culprit))
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) arg1 arg ...)
|
||||
(begin
|
||||
(unless (identifier? #'var) (raise-error #'var))
|
||||
(unless (identifier? #'i) (raise-error #'i))
|
||||
(syntax/loc form-stx
|
||||
(:dispatched var (index i) :-dispatch arg1 arg ...)))]
|
||||
[(_ var arg1 arg ...)
|
||||
(unless (identifier? #'var) (raise-error #'var))
|
||||
(syntax/loc form-stx
|
||||
(:dispatched var :-dispatch arg1 arg ...))]
|
||||
[_ (raise-error form-stx)]))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
(module ec-core mzscheme
|
||||
(require "expansion.scm"
|
||||
"generators.scm"
|
||||
"comprehensions.scm"
|
||||
"dispatching.scm")
|
||||
(provide (all-from "expansion.scm")
|
||||
(all-from "generators.scm")
|
||||
(all-from "comprehensions.scm")
|
||||
(all-from "dispatching.scm")))
|
||||
(module ec-core mzscheme
|
||||
(require "expansion.scm"
|
||||
"generators.scm"
|
||||
"comprehensions.scm"
|
||||
"dispatching.scm")
|
||||
(provide (all-from "expansion.scm")
|
||||
(all-from "generators.scm")
|
||||
(all-from "comprehensions.scm")
|
||||
(all-from "dispatching.scm")))
|
||||
|
|
|
|||
|
|
@ -1,52 +1,52 @@
|
|||
(module ec mzscheme
|
||||
(require "ec-core.scm" "extra-generators.scm")
|
||||
(provide
|
||||
;; generators.scm
|
||||
define-generator
|
||||
define-indexed-generator-with-append
|
||||
define-indexed-generator-without-append
|
||||
;; (the generators present in the reference implementation)
|
||||
:list :integers :string :bytes :vector
|
||||
:range :real-range :char-range
|
||||
:port
|
||||
:let :parallel :until :do :while
|
||||
|
||||
(all-from "extra-generators.scm")
|
||||
|
||||
;; comprehensions.scm
|
||||
|
||||
define-comprehension
|
||||
define-derived-comprehension
|
||||
|
||||
list-ec
|
||||
do-ec
|
||||
append-ec
|
||||
string-ec
|
||||
string-append-ec
|
||||
vector-ec
|
||||
vector-of-length-ec
|
||||
fold3-ec
|
||||
fold-ec
|
||||
sum-ec
|
||||
product-ec
|
||||
min-ec
|
||||
max-ec
|
||||
last-ec
|
||||
first-ec
|
||||
any?-ec
|
||||
every?-ec
|
||||
|
||||
;; dispatching.scm
|
||||
:dispatched
|
||||
:generator-proc
|
||||
dispatch-union
|
||||
make-initial-:-dispatch
|
||||
:-dispatch-ref
|
||||
:-dispatch-set!
|
||||
:
|
||||
|
||||
;; expansion.scm
|
||||
add-index
|
||||
)
|
||||
|
||||
)
|
||||
(module ec mzscheme
|
||||
(require "ec-core.scm" "extra-generators.scm")
|
||||
(provide
|
||||
;; generators.scm
|
||||
define-generator
|
||||
define-indexed-generator-with-append
|
||||
define-indexed-generator-without-append
|
||||
;; (the generators present in the reference implementation)
|
||||
:list :integers :string :bytes :vector
|
||||
:range :real-range :char-range
|
||||
:port
|
||||
:let :parallel :until :do :while
|
||||
|
||||
(all-from "extra-generators.scm")
|
||||
|
||||
;; comprehensions.scm
|
||||
|
||||
define-comprehension
|
||||
define-derived-comprehension
|
||||
|
||||
list-ec
|
||||
do-ec
|
||||
append-ec
|
||||
string-ec
|
||||
string-append-ec
|
||||
vector-ec
|
||||
vector-of-length-ec
|
||||
fold3-ec
|
||||
fold-ec
|
||||
sum-ec
|
||||
product-ec
|
||||
min-ec
|
||||
max-ec
|
||||
last-ec
|
||||
first-ec
|
||||
any?-ec
|
||||
every?-ec
|
||||
|
||||
;; dispatching.scm
|
||||
:dispatched
|
||||
:generator-proc
|
||||
dispatch-union
|
||||
make-initial-:-dispatch
|
||||
:-dispatch-ref
|
||||
:-dispatch-set!
|
||||
:
|
||||
|
||||
;; expansion.scm
|
||||
add-index
|
||||
)
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,195 +1,195 @@
|
|||
;;;
|
||||
;;; EXPANSION
|
||||
;;;
|
||||
|
||||
(module expansion mzscheme
|
||||
(provide (all-from "generator-struct.scm")
|
||||
(all-from "generator-definitions.scm")
|
||||
(all-from "loops.scm"))
|
||||
(provide generator->loop
|
||||
check-all-clauses-are-generators-or-filters
|
||||
expand-clauses
|
||||
generator-clause?
|
||||
filter-clause?
|
||||
add-index)
|
||||
|
||||
(require "generator-struct.scm"
|
||||
"loops.scm"
|
||||
"generator-definitions.scm")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(define current-introducer (make-parameter #f))
|
||||
|
||||
(define (generator-clause? clause-stx)
|
||||
(syntax-case clause-stx ()
|
||||
[(name . more)
|
||||
(and (identifier? #'name)
|
||||
(generator? (syntax-local-value #'name (lambda () #f))))]
|
||||
[_ #f]))
|
||||
|
||||
(require (lib "stx.ss" "syntax"))
|
||||
(define (filter-clause? clause-stx)
|
||||
(syntax-case* clause-stx (if not and or) module-or-top-identifier=?
|
||||
[(if . more) #t]
|
||||
[(not . more) #t]
|
||||
[(and . more) #t]
|
||||
[(or . more) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define (begin-clause? clause-stx)
|
||||
(syntax-case clause-stx (begin)
|
||||
[(begin . more) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define (nested-clause? clause-stx)
|
||||
(syntax-case clause-stx (nested)
|
||||
[(nested . more) #t]
|
||||
[_ #f]))
|
||||
|
||||
; generator->loop : clause-stx -> loop
|
||||
(define (generator->loop clause-stx)
|
||||
(define introduce (make-syntax-introducer))
|
||||
(define (mark s)
|
||||
(if (current-introducer) ; this is a subexpansion
|
||||
(introduce ((current-introducer) s))
|
||||
(introduce (syntax-local-introduce s))))
|
||||
(define (unmark s)
|
||||
(if (current-introducer) ; this is a subexpansion
|
||||
((current-introducer) (introduce s))
|
||||
(syntax-local-introduce (introduce s))))
|
||||
(syntax-case clause-stx ()
|
||||
[(gen-name . more)
|
||||
(begin
|
||||
(unless (generator-clause? clause-stx)
|
||||
(raise-syntax-error
|
||||
'generator->loop
|
||||
"expected a generator clause, got: "
|
||||
clause-stx ))
|
||||
(let* ([generator (syntax-local-value #'gen-name)]
|
||||
[marked-clause-stx (mark clause-stx)]
|
||||
[loop (parameterize ([current-introducer introduce])
|
||||
((generator-clause->loop generator)
|
||||
marked-clause-stx))])
|
||||
(cond
|
||||
[(loop? loop) (make-loop (unmark (loop-stx loop)))]
|
||||
[(generator-clause? (unmark loop)) (generator->loop (unmark loop))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'generator-loop
|
||||
(apply string-append
|
||||
(cons "generator expander returned neither a loop structure nor "
|
||||
(cons "a syntax-object representing a generator clause. "
|
||||
(if (syntax? loop)
|
||||
(syntax-case loop ()
|
||||
[(name . more)
|
||||
(identifier? #'name)
|
||||
(list (string-append "\nMaybe you forgot to define "
|
||||
(symbol->string (syntax-object->datum #'name))
|
||||
" to as a generator?"))]
|
||||
[_ '()])
|
||||
'()))))
|
||||
loop)])))]))
|
||||
|
||||
|
||||
|
||||
; expand-clauses : stx -> (stx -> stx)
|
||||
; Input: A syntax-object representing a list of clauses
|
||||
; Output: A procedure of one argument. The input of which is
|
||||
; a syntax-object representing the body (aka payload)
|
||||
; of the loop. The output is a fully expanded loop.
|
||||
; Note: This is used by comprehensions such as list-ec
|
||||
; to insert their payloads into the "middle" of the loop.
|
||||
(require (lib "stx.ss" "syntax"))
|
||||
|
||||
(define (expand-clauses clauses-stx)
|
||||
(syntax-case clauses-stx ()
|
||||
[()
|
||||
(lambda (body-stx) body-stx)]
|
||||
[(clause1 clause2 ...)
|
||||
(lambda (body-stx)
|
||||
(cond
|
||||
[(generator-clause? #'clause1)
|
||||
(let ([loop1 (generator->loop #'clause1)]
|
||||
[loop2... (expand-clauses #'(clause2 ...))])
|
||||
(loop->syntax #'clause1 loop1
|
||||
(loop2... body-stx)))]
|
||||
[(filter-clause? #'clause1)
|
||||
(let ([loop2... (expand-clauses #'(clause2 ...))])
|
||||
(syntax-case* #'clause1 (if not and or) module-or-top-identifier=? ; due to not
|
||||
[(if expr)
|
||||
#`(if expr #,(loop2... body-stx))]
|
||||
[(not expr)
|
||||
#`(if (not expr) #,(loop2... body-stx))]
|
||||
[(or expr ...)
|
||||
#`(if (or expr ...) #,(loop2... body-stx))]
|
||||
[(and expr ...)
|
||||
#`(if (and expr ...) #,(loop2... body-stx))]
|
||||
[_
|
||||
(raise-syntax-error 'expand-clauses
|
||||
"unimplemented <filter>" #'clause1)]))]
|
||||
[(begin-clause? #'clause1)
|
||||
(let ([loop2... (expand-clauses #'(clause2 ...))])
|
||||
(syntax-case #'clause1 ()
|
||||
[(_ expr1 ...)
|
||||
#`(begin expr1 ... #,(loop2... body-stx))]))]
|
||||
[(nested-clause? #'clause1)
|
||||
(syntax-case #'clause1 (nested)
|
||||
[(nested qualifier ...)
|
||||
((expand-clauses
|
||||
#`(qualifier ... clause2 ...))
|
||||
body-stx)]
|
||||
[_
|
||||
(error)])]
|
||||
[else
|
||||
(begin
|
||||
(display clauses-stx) (newline)
|
||||
(error 'expand-clauses "this should have been caught earlier"))]))]
|
||||
[else
|
||||
(error "huh")]))
|
||||
|
||||
(define (check-all-clauses-are-generators-or-filters clauses-stx caller)
|
||||
(syntax-case clauses-stx ()
|
||||
[(clause ...)
|
||||
(let loop ([cs (syntax->list #'(clause ...))])
|
||||
(cond
|
||||
[(null? cs) 'all-ok]
|
||||
[(generator-clause? (car cs)) (loop (cdr cs))]
|
||||
[(filter-clause? (car cs)) (loop (cdr cs))]
|
||||
[(begin-clause? (car cs)) (loop (cdr cs))]
|
||||
[(nested-clause? (car cs)) (loop (cdr cs))]
|
||||
[else (raise-syntax-error
|
||||
caller "<generator> or <filter> expected, got:" (car cs))]))]))
|
||||
|
||||
; add-index : loc-stx loop-or-stx var-stx -> loop
|
||||
; add a loop binding to the loop, s.t.
|
||||
; var-stx now counts the number of
|
||||
; elements produced
|
||||
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(define (add-index-proc l var-stx)
|
||||
(cond
|
||||
[(loop? l)
|
||||
(with-syntax ([var var-stx])
|
||||
(syntax-case (loop-stx l) ()
|
||||
[(ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'(ob* oc* ((var 0) . lb*)
|
||||
ne1 ib* ic* ne2 ((add1 var) . ls*)))]))]
|
||||
[(syntax? l)
|
||||
(add-index-proc (generator->loop l) var-stx)]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'add-index-proc "expected either a loop structure of a generator clause as first argument, got" l)]))
|
||||
|
||||
(define-syntax (add-index stx)
|
||||
(syntax-case stx (syntax)
|
||||
[(_ loc #'loop var-stx)
|
||||
#'(add-index-proc (syntax/loc loc loop) var-stx)]
|
||||
[(_ #'loop var-stx)
|
||||
(raise-syntax-error
|
||||
'add-index
|
||||
"you forgot to add location info"
|
||||
stx)]
|
||||
[_
|
||||
(raise-syntax-error 'add-index "think" stx)]))
|
||||
;;;
|
||||
;;; EXPANSION
|
||||
;;;
|
||||
|
||||
(module expansion mzscheme
|
||||
(provide (all-from "generator-struct.scm")
|
||||
(all-from "generator-definitions.scm")
|
||||
(all-from "loops.scm"))
|
||||
(provide generator->loop
|
||||
check-all-clauses-are-generators-or-filters
|
||||
expand-clauses
|
||||
generator-clause?
|
||||
filter-clause?
|
||||
add-index)
|
||||
|
||||
(require "generator-struct.scm"
|
||||
"loops.scm"
|
||||
"generator-definitions.scm")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(define current-introducer (make-parameter #f))
|
||||
|
||||
(define (generator-clause? clause-stx)
|
||||
(syntax-case clause-stx ()
|
||||
[(name . more)
|
||||
(and (identifier? #'name)
|
||||
(generator? (syntax-local-value #'name (lambda () #f))))]
|
||||
[_ #f]))
|
||||
|
||||
(require (lib "stx.ss" "syntax"))
|
||||
(define (filter-clause? clause-stx)
|
||||
(syntax-case* clause-stx (if not and or) module-or-top-identifier=?
|
||||
[(if . more) #t]
|
||||
[(not . more) #t]
|
||||
[(and . more) #t]
|
||||
[(or . more) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define (begin-clause? clause-stx)
|
||||
(syntax-case clause-stx (begin)
|
||||
[(begin . more) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define (nested-clause? clause-stx)
|
||||
(syntax-case clause-stx (nested)
|
||||
[(nested . more) #t]
|
||||
[_ #f]))
|
||||
|
||||
; generator->loop : clause-stx -> loop
|
||||
(define (generator->loop clause-stx)
|
||||
(define introduce (make-syntax-introducer))
|
||||
(define (mark s)
|
||||
(if (current-introducer) ; this is a subexpansion
|
||||
(introduce ((current-introducer) s))
|
||||
(introduce (syntax-local-introduce s))))
|
||||
(define (unmark s)
|
||||
(if (current-introducer) ; this is a subexpansion
|
||||
((current-introducer) (introduce s))
|
||||
(syntax-local-introduce (introduce s))))
|
||||
(syntax-case clause-stx ()
|
||||
[(gen-name . more)
|
||||
(begin
|
||||
(unless (generator-clause? clause-stx)
|
||||
(raise-syntax-error
|
||||
'generator->loop
|
||||
"expected a generator clause, got: "
|
||||
clause-stx ))
|
||||
(let* ([generator (syntax-local-value #'gen-name)]
|
||||
[marked-clause-stx (mark clause-stx)]
|
||||
[loop (parameterize ([current-introducer introduce])
|
||||
((generator-clause->loop generator)
|
||||
marked-clause-stx))])
|
||||
(cond
|
||||
[(loop? loop) (make-loop (unmark (loop-stx loop)))]
|
||||
[(generator-clause? (unmark loop)) (generator->loop (unmark loop))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'generator-loop
|
||||
(apply string-append
|
||||
(cons "generator expander returned neither a loop structure nor "
|
||||
(cons "a syntax-object representing a generator clause. "
|
||||
(if (syntax? loop)
|
||||
(syntax-case loop ()
|
||||
[(name . more)
|
||||
(identifier? #'name)
|
||||
(list (string-append "\nMaybe you forgot to define "
|
||||
(symbol->string (syntax-object->datum #'name))
|
||||
" to as a generator?"))]
|
||||
[_ '()])
|
||||
'()))))
|
||||
loop)])))]))
|
||||
|
||||
|
||||
|
||||
; expand-clauses : stx -> (stx -> stx)
|
||||
; Input: A syntax-object representing a list of clauses
|
||||
; Output: A procedure of one argument. The input of which is
|
||||
; a syntax-object representing the body (aka payload)
|
||||
; of the loop. The output is a fully expanded loop.
|
||||
; Note: This is used by comprehensions such as list-ec
|
||||
; to insert their payloads into the "middle" of the loop.
|
||||
(require (lib "stx.ss" "syntax"))
|
||||
|
||||
(define (expand-clauses clauses-stx)
|
||||
(syntax-case clauses-stx ()
|
||||
[()
|
||||
(lambda (body-stx) body-stx)]
|
||||
[(clause1 clause2 ...)
|
||||
(lambda (body-stx)
|
||||
(cond
|
||||
[(generator-clause? #'clause1)
|
||||
(let ([loop1 (generator->loop #'clause1)]
|
||||
[loop2... (expand-clauses #'(clause2 ...))])
|
||||
(loop->syntax #'clause1 loop1
|
||||
(loop2... body-stx)))]
|
||||
[(filter-clause? #'clause1)
|
||||
(let ([loop2... (expand-clauses #'(clause2 ...))])
|
||||
(syntax-case* #'clause1 (if not and or) module-or-top-identifier=? ; due to not
|
||||
[(if expr)
|
||||
#`(if expr #,(loop2... body-stx))]
|
||||
[(not expr)
|
||||
#`(if (not expr) #,(loop2... body-stx))]
|
||||
[(or expr ...)
|
||||
#`(if (or expr ...) #,(loop2... body-stx))]
|
||||
[(and expr ...)
|
||||
#`(if (and expr ...) #,(loop2... body-stx))]
|
||||
[_
|
||||
(raise-syntax-error 'expand-clauses
|
||||
"unimplemented <filter>" #'clause1)]))]
|
||||
[(begin-clause? #'clause1)
|
||||
(let ([loop2... (expand-clauses #'(clause2 ...))])
|
||||
(syntax-case #'clause1 ()
|
||||
[(_ expr1 ...)
|
||||
#`(begin expr1 ... #,(loop2... body-stx))]))]
|
||||
[(nested-clause? #'clause1)
|
||||
(syntax-case #'clause1 (nested)
|
||||
[(nested qualifier ...)
|
||||
((expand-clauses
|
||||
#`(qualifier ... clause2 ...))
|
||||
body-stx)]
|
||||
[_
|
||||
(error)])]
|
||||
[else
|
||||
(begin
|
||||
(display clauses-stx) (newline)
|
||||
(error 'expand-clauses "this should have been caught earlier"))]))]
|
||||
[else
|
||||
(error "huh")]))
|
||||
|
||||
(define (check-all-clauses-are-generators-or-filters clauses-stx caller)
|
||||
(syntax-case clauses-stx ()
|
||||
[(clause ...)
|
||||
(let loop ([cs (syntax->list #'(clause ...))])
|
||||
(cond
|
||||
[(null? cs) 'all-ok]
|
||||
[(generator-clause? (car cs)) (loop (cdr cs))]
|
||||
[(filter-clause? (car cs)) (loop (cdr cs))]
|
||||
[(begin-clause? (car cs)) (loop (cdr cs))]
|
||||
[(nested-clause? (car cs)) (loop (cdr cs))]
|
||||
[else (raise-syntax-error
|
||||
caller "<generator> or <filter> expected, got:" (car cs))]))]))
|
||||
|
||||
; add-index : loc-stx loop-or-stx var-stx -> loop
|
||||
; add a loop binding to the loop, s.t.
|
||||
; var-stx now counts the number of
|
||||
; elements produced
|
||||
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(define (add-index-proc l var-stx)
|
||||
(cond
|
||||
[(loop? l)
|
||||
(with-syntax ([var var-stx])
|
||||
(syntax-case (loop-stx l) ()
|
||||
[(ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'(ob* oc* ((var 0) . lb*)
|
||||
ne1 ib* ic* ne2 ((add1 var) . ls*)))]))]
|
||||
[(syntax? l)
|
||||
(add-index-proc (generator->loop l) var-stx)]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'add-index-proc "expected either a loop structure of a generator clause as first argument, got" l)]))
|
||||
|
||||
(define-syntax (add-index stx)
|
||||
(syntax-case stx (syntax)
|
||||
[(_ loc #'loop var-stx)
|
||||
#'(add-index-proc (syntax/loc loc loop) var-stx)]
|
||||
[(_ #'loop var-stx)
|
||||
(raise-syntax-error
|
||||
'add-index
|
||||
"you forgot to add location info"
|
||||
stx)]
|
||||
[_
|
||||
(raise-syntax-error 'add-index "think" stx)]))
|
||||
)
|
||||
|
|
@ -1,38 +1,38 @@
|
|||
(module generator-definitions mzscheme
|
||||
(provide define-generator)
|
||||
|
||||
(require-for-syntax "generator-struct.scm")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
; syntax
|
||||
; (define-generator name proc)
|
||||
; (define-generator (name arg) body ...)
|
||||
; The procedure takes a generator clause as input, and returns
|
||||
; either a loop structure or a syntax-object representing
|
||||
; a (simpler) generator clause.
|
||||
(define-syntax (define-generator stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name arg) body ...)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error
|
||||
'define-generator "expected (define-generator <id> <procedure>), got: " #'name))
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error
|
||||
'define-generator "expected (define-generator (<id> name) <body> ...), got: " #'name))
|
||||
#'(begin
|
||||
(define-for-syntax name (make-generator 'name (lambda (arg) body ...)))
|
||||
(define-syntax name (make-generator 'name (lambda (arg) body ...)))))]
|
||||
[(_ name proc)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error
|
||||
'define-generator "expected (define-generator <id> <procedure>), got: " #'name))
|
||||
#'(begin
|
||||
(define-for-syntax name (make-generator 'name proc))
|
||||
(define-syntax name (make-generator 'name proc))))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
'define-generator
|
||||
"expected either (define-generator <id> <proc>) or (define-generator (<id1> <id2>) <body> ... , got: "
|
||||
(module generator-definitions mzscheme
|
||||
(provide define-generator)
|
||||
|
||||
(require-for-syntax "generator-struct.scm")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
; syntax
|
||||
; (define-generator name proc)
|
||||
; (define-generator (name arg) body ...)
|
||||
; The procedure takes a generator clause as input, and returns
|
||||
; either a loop structure or a syntax-object representing
|
||||
; a (simpler) generator clause.
|
||||
(define-syntax (define-generator stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name arg) body ...)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error
|
||||
'define-generator "expected (define-generator <id> <procedure>), got: " #'name))
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error
|
||||
'define-generator "expected (define-generator (<id> name) <body> ...), got: " #'name))
|
||||
#'(begin
|
||||
(define-for-syntax name (make-generator 'name (lambda (arg) body ...)))
|
||||
(define-syntax name (make-generator 'name (lambda (arg) body ...)))))]
|
||||
[(_ name proc)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error
|
||||
'define-generator "expected (define-generator <id> <procedure>), got: " #'name))
|
||||
#'(begin
|
||||
(define-for-syntax name (make-generator 'name proc))
|
||||
(define-syntax name (make-generator 'name proc))))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
'define-generator
|
||||
"expected either (define-generator <id> <proc>) or (define-generator (<id1> <id2>) <body> ... , got: "
|
||||
stx)])))
|
||||
|
|
@ -1,17 +1,17 @@
|
|||
;;;
|
||||
;;; GENERATORS
|
||||
;;;
|
||||
|
||||
|
||||
(module generator-struct mzscheme
|
||||
(provide generator
|
||||
generator?
|
||||
generator-clause->loop
|
||||
make-generator)
|
||||
|
||||
; A GENERATOR has a name, and function form->loop,
|
||||
; that takes a syntax-object representing an instance
|
||||
; of a generator clause as input. For example
|
||||
; #'(:list x (list 1 2 3)). The function form->loop
|
||||
; returns a loop structure.
|
||||
;;;
|
||||
;;; GENERATORS
|
||||
;;;
|
||||
|
||||
|
||||
(module generator-struct mzscheme
|
||||
(provide generator
|
||||
generator?
|
||||
generator-clause->loop
|
||||
make-generator)
|
||||
|
||||
; A GENERATOR has a name, and function form->loop,
|
||||
; that takes a syntax-object representing an instance
|
||||
; of a generator clause as input. For example
|
||||
; #'(:list x (list 1 2 3)). The function form->loop
|
||||
; returns a loop structure.
|
||||
(define-struct generator (name clause->loop)))
|
||||
|
|
@ -1,458 +1,458 @@
|
|||
;;;
|
||||
;;; NORMAL GENERATORS
|
||||
;;;
|
||||
|
||||
|
||||
(module generators mzscheme
|
||||
(provide (all-defined))
|
||||
(require "expansion.scm")
|
||||
(require-for-syntax "expansion.scm")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
|
||||
(define-generator :list
|
||||
(lambda (form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) expr ...)
|
||||
(add-index form-stx #'(_ var expr ...) #'i)]
|
||||
[(_ var expr1 expr2 expr ...)
|
||||
; TODO IMPROVE: something better than append ?
|
||||
#'(_ var (append expr1 expr2 expr ...))]
|
||||
[(_ var expr)
|
||||
(begin
|
||||
(unless (identifier? #'var)
|
||||
(raise-syntax-error ':list "expected identifier, got " #'var))
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'(() () ((xs expr)) (not (null? xs))
|
||||
(((var) (car xs))) () #t ((cdr xs)))))]
|
||||
[_ (raise-syntax-error
|
||||
':list
|
||||
"Expected either (:list <expr> ...) or (:list (index <var>) expr ...), got: "
|
||||
form-stx)])))
|
||||
|
||||
(define-generator (:integers form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i))
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'(() () ((var 0)) #t (((i) var)) () #t ((add1 var))))]
|
||||
[(_ var)
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'(() () ((var 0)) #t () () #t ((add1 var))))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':integers
|
||||
"expected (:integers <var> (index <var>)) where (index <var>) is optional, got: "
|
||||
form-stx)]))
|
||||
|
||||
|
||||
(define (ec-:vector-filter vecs)
|
||||
; filter zero-length vectors
|
||||
(if (null? vecs)
|
||||
'()
|
||||
(if (zero? (vector-length (car vecs)))
|
||||
(ec-:vector-filter (cdr vecs))
|
||||
(cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
|
||||
|
||||
; The expansion below uses name-append to turn
|
||||
; (:name var expr1 expr2 ...)
|
||||
; into
|
||||
; (:name var (name-append expr1 expr2 ...))
|
||||
|
||||
; If your indexed sequence doesn't have an append operation
|
||||
; (or it is too expensive to use) then use
|
||||
; define-indexed-generator instead.
|
||||
|
||||
(define-syntax (define-indexed-generator-with-append stx)
|
||||
(syntax-case stx ()
|
||||
[(__ :name (name? name-ref name-length name-append name-type))
|
||||
#'(define-generator (:name form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) expr (... ...))
|
||||
(add-index form-stx #'(:name var expr (... ...)) #'i)]
|
||||
[(_ var expr)
|
||||
(begin
|
||||
(unless (identifier? #'var)
|
||||
(raise-syntax-error
|
||||
':name
|
||||
"expected a variable to bind"
|
||||
#'var))
|
||||
#'(:do (let ((seq expr) (len 0))
|
||||
(set! len (name-length seq)))
|
||||
((i 0))
|
||||
(< i len)
|
||||
(let ((var (name-ref seq i))))
|
||||
#t
|
||||
((+ i 1)) ))]
|
||||
[(_ var expr (... ...))
|
||||
#`(:name var (let ([es (list expr (... ...))])
|
||||
(unless (andmap name? es)
|
||||
(error
|
||||
':name
|
||||
(format "expected ~as, but got: ~~a " name-type)
|
||||
es))
|
||||
; TODO: use raise-syntax-error above (how?)
|
||||
(apply name-append es)))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':name
|
||||
(format "expected (~a <var> (index i) <expr> <expr> ...) where (index i) is optional, got: "
|
||||
':name)
|
||||
form-stx)]))]))
|
||||
|
||||
(define-indexed-generator-with-append :string
|
||||
(string? string-ref string-length string-append "string"))
|
||||
|
||||
(define-indexed-generator-with-append :bytes
|
||||
(bytes? bytes-ref bytes-length bytes-append "byte-string"))
|
||||
|
||||
; The expansion below basically turns
|
||||
; (:name var expr1 expr2 ...)
|
||||
; into (nested (: xs (list expr1 expr2 ...)
|
||||
; (:name var xs))
|
||||
; except we need to write it as a do-loop.
|
||||
|
||||
(define-syntax (define-indexed-generator-without-append stx)
|
||||
(syntax-case stx ()
|
||||
[(__ :name (name? name-ref name-length name-type))
|
||||
#'(define-generator (:name form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) expr (... ...))
|
||||
(add-index form-stx #'(:name var expr (... ...)) #'i)]
|
||||
[(_ var expr)
|
||||
(begin
|
||||
(unless (identifier? #'var)
|
||||
(raise-syntax-error
|
||||
':name
|
||||
"expected a variable to bind"
|
||||
#'var))
|
||||
#`(:do (let ((seq expr) (len 0))
|
||||
(set! len (name-length seq)))
|
||||
((i 0))
|
||||
(< i len)
|
||||
(let ((var #,(syntax/loc form-stx (name-ref seq i)))))
|
||||
#t
|
||||
((+ i 1)) ))]
|
||||
[(_ var expr (... ...))
|
||||
#'(:do (let ([es ; filter zero-length sequences away
|
||||
(let lp ([es (list expr (... ...))])
|
||||
(cond
|
||||
[(null? es) '()]
|
||||
[(zero? (name-length (car es))) (lp (cdr es))]
|
||||
[else (cons (car es) (lp (cdr es)))]))]
|
||||
[current #f]
|
||||
[current-length 0]))
|
||||
((k 0))
|
||||
(if (< k current-length)
|
||||
#t
|
||||
(if (null? es)
|
||||
#f
|
||||
(begin (set! current (car es))
|
||||
(set! es (cdr es))
|
||||
(set! current-length (name-length current))
|
||||
(set! k 0)
|
||||
#t)))
|
||||
(let ((var (name-ref current k))))
|
||||
#t
|
||||
((+ k 1)))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':name
|
||||
(format "expected (~a <var> (index i) <expr> <expr> ...) where (index i) is optional, got: "
|
||||
':name)
|
||||
form-stx)]))]))
|
||||
|
||||
(define-indexed-generator-without-append :vector
|
||||
(vector? vector-ref vector-length "vector"))
|
||||
|
||||
|
||||
(define-generator (:range form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
; handle index variable and add optional args
|
||||
((:range var (index i) arg1 arg ...)
|
||||
(add-index form-stx #'(:range var arg1 arg ...) #'i))
|
||||
((:range var arg1)
|
||||
#'(:range var 0 arg1 1) )
|
||||
((:range var arg1 arg2)
|
||||
#'(:range var arg1 arg2 1) )
|
||||
|
||||
; special cases (partially evaluated by hand from general case)
|
||||
((:range var 0 arg2 1)
|
||||
#'(:do (let ((b arg2))
|
||||
(if (not (and (integer? b) (exact? b)))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" 0 b 1 )))
|
||||
((var 0))
|
||||
(< var b)
|
||||
(let ())
|
||||
#t
|
||||
((+ var 1)) ))
|
||||
|
||||
((:range var 0 arg2 -1)
|
||||
#'(:do (let ((b arg2))
|
||||
(if (not (and (integer? b) (exact? b)))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" 0 b 1 )))
|
||||
((var 0))
|
||||
(> var b)
|
||||
(let ())
|
||||
#t
|
||||
((- var 1)) ))
|
||||
|
||||
((:range var arg1 arg2 1)
|
||||
#'(:do (let ((a arg1) (b arg2))
|
||||
(if (not (and (integer? a) (exact? a)
|
||||
(integer? b) (exact? b) ))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" a b 1 )) )
|
||||
((var a))
|
||||
(< var b)
|
||||
(let ())
|
||||
#t
|
||||
((+ var 1)) ))
|
||||
|
||||
((:range var arg1 arg2 -1)
|
||||
#'(:do (let ((a arg1) (b arg2) (s -1) (stop 0))
|
||||
(if (not (and (integer? a) (exact? a)
|
||||
(integer? b) (exact? b) ))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" a b -1 )) )
|
||||
((var a))
|
||||
(> var b)
|
||||
(let ())
|
||||
#t
|
||||
((- var 1)) ))
|
||||
|
||||
; the general case
|
||||
|
||||
((:range var arg1 arg2 arg3)
|
||||
#'(:do (let ((a arg1) (b arg2) (s arg3) (stop 0))
|
||||
(if (not (and (integer? a) (exact? a)
|
||||
(integer? b) (exact? b)
|
||||
(integer? s) (exact? s) ))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" a b s ))
|
||||
(if (zero? s)
|
||||
(error "step size must not be zero in :range") )
|
||||
(set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
|
||||
((var a))
|
||||
(not (= var stop))
|
||||
(let ())
|
||||
#t
|
||||
((+ var s)) ))))
|
||||
|
||||
|
||||
(define-generator (:real-range form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
; add optional args and index variable
|
||||
((:real-range var arg1)
|
||||
#'(:real-range var (index i) 0 arg1 1) )
|
||||
((:real-range var (index i) arg1)
|
||||
#'(:real-range var (index i) 0 arg1 1) )
|
||||
((:real-range var arg1 arg2)
|
||||
#'(:real-range var (index i) arg1 arg2 1) )
|
||||
((:real-range var (index i) arg1 arg2)
|
||||
#'(:real-range var (index i) arg1 arg2 1) )
|
||||
((:real-range var arg1 arg2 arg3)
|
||||
#'(:real-range var (index i) arg1 arg2 arg3) )
|
||||
|
||||
; the fully qualified case
|
||||
((:real-range var (index i) arg1 arg2 arg3)
|
||||
#'(:do (let ((a arg1) (b arg2) (s arg3) (istop 0))
|
||||
(if (not (and (real? a) (real? b) (real? s)))
|
||||
(error "arguments of :real-range are not real" a b s) )
|
||||
(if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
|
||||
(set! a (exact->inexact a)) )
|
||||
(set! istop (/ (- b a) s)) )
|
||||
((i 0))
|
||||
(< i istop)
|
||||
(let ((var (+ a (* s i)))))
|
||||
#t
|
||||
((+ i 1)) ))))
|
||||
|
||||
; Comment: The macro :real-range adapts the exactness of the start
|
||||
; value in case any of the other values is inexact. This is a
|
||||
; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
|
||||
|
||||
(define-generator (:char-range form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) expr1 expr2)
|
||||
(add-index form-stx #'(:char-range var expr1 expr2) #'i)]
|
||||
[(_ var expr1 expr2)
|
||||
#'(:do (let ((imax (char->integer expr2))))
|
||||
((i (char->integer expr1)))
|
||||
(<= i imax)
|
||||
(let ((var (integer->char i))))
|
||||
#t
|
||||
((+ i 1)) )]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':char-range
|
||||
"expected (:char-range <var> (index <var>) <expr> <expr>) where the index is optional, got: "
|
||||
form-stx)]))
|
||||
|
||||
(define-generator (:port form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
((:port var (index i) arg1 arg ...)
|
||||
(add-index form-stx #'(:port var arg1 arg ...) #'i))
|
||||
((:port var arg)
|
||||
#'(:port var arg read) )
|
||||
((:port var arg1 arg2)
|
||||
#'(:do (let ((port arg1) (read-proc arg2)))
|
||||
((var (read-proc port)))
|
||||
(not (eof-object? var))
|
||||
(let ())
|
||||
#t
|
||||
((read-proc port)) ))
|
||||
(_
|
||||
(raise-syntax-error
|
||||
':port
|
||||
"expected (:port <var> (index i) <reader-expr>) where index is optional, and the <reader-expr> defaults to read, got:"
|
||||
form-stx))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; SPECIAL GENERATORS
|
||||
;;;
|
||||
|
||||
(define-generator (:let form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
; ($ loop ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
[(_ var (index i) expr)
|
||||
(make-loop #'(() () ((var expr) (i 0)) #t () () #f ()))]
|
||||
[(_ var expr)
|
||||
(make-loop #'(() () ((var expr)) #t () () #f ()))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':let "expected (:let <var> <expr>) or (:let <var> (index <var>) <expr>), got:"
|
||||
form-stx)]))
|
||||
|
||||
(require-for-syntax (lib "match.ss"))
|
||||
|
||||
(define-generator (:parallel form-stx)
|
||||
; TODO: Check that all subforms are generators
|
||||
(syntax-case form-stx (index)
|
||||
[(_ (index i) q ...)
|
||||
(add-index form-stx #'(_ q ...) #'i)]
|
||||
[(_ gen)
|
||||
(generator->loop #'gen)]
|
||||
[(_ gen1 gen2)
|
||||
(syntax-case (list (loop-stx (generator->loop #'gen1))
|
||||
(loop-stx (generator->loop #'gen2))) ()
|
||||
[(((ob ...) (oc ...) (lb ...) ne1 (ib ...) (ic ...) ne2 (ls ...))
|
||||
((ob2 ...) (oc2 ...) (lb2 ...) ne12 (ib2 ...) (ic2 ...) ne22 (ls2 ...)))
|
||||
(make-loop
|
||||
#'((ob ... ob2 ...)
|
||||
(oc ... oc2 ...) (lb ... lb2 ...)
|
||||
(and ne1 ne12) (ib ... ib2 ...)
|
||||
(ic ... ic2 ...) (and ne2 ne22)
|
||||
(ls ... ls2 ...)))])]
|
||||
[(_ gen1 gen2 gen3 ...)
|
||||
#'(:parallel (:parallel gen1 gen2) gen3 ...)]))
|
||||
|
||||
(define-generator (:until form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ gen test-expr)
|
||||
(unless (generator-clause? #'gen)
|
||||
(raise-syntax-error
|
||||
':until "expected <generator> in " #'gen))
|
||||
(syntax-case (loop-stx (generator->loop #'gen)) ()
|
||||
[(obs ocs lbs ne1 ibs ics ne2 lss)
|
||||
(make-loop #'(obs ocs lbs ne1 ibs ics
|
||||
(and ne2 (not test-expr))
|
||||
lss))])]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':until "expected (:until <generator> <expression>), got: "
|
||||
form-stx)]))
|
||||
|
||||
|
||||
(define-generator (:do form-stx)
|
||||
(syntax-case form-stx (let let-values)
|
||||
; short form -> fill in default value
|
||||
[(_ ((lv le) ...) ne1? (expr ...))
|
||||
#'(:do (let ()) ((lv le) ...) ne1? (let ()) #t (expr ...))]
|
||||
; convert (let _) variants to (let-values _)
|
||||
[(_ (let ((on oe) ...) <oc> ...) (<lb> ...) <ne1?> (let ((in ie) ...) <ic> ...) <ne2?> (<ls> ...))
|
||||
#'(_ (let-values (((on) oe) ...) <oc> ...) (<lb> ...) <ne1?> (let-values ([(in) ie] ...) <ic> ...) <ne2?> (<ls> ...))]
|
||||
[(_ (let ((on oe) ...) <oc> ...) (<lb> ...) <ne1?> ilet <ne2?> (<ls> ...))
|
||||
#'(_ (let-values (((on) oe) ...) <oc> ...) (<lb> ...) <ne1?> ilet <ne2?> (<ls> ...))]
|
||||
[(_ olet (<lb> ...) <ne1?> (let ((in ie) ...) <ic> ...) <ne2?> (<ls> ...))
|
||||
#'(_ olet (<lb> ...) <ne1?> (let-values ([(in) ie] ...) <ic> ...) <ne2?> (<ls> ...))]
|
||||
|
||||
; now both outer bindings and inner bindings must be let-values bindings
|
||||
[(_ olet lbs ne1? ilet ne2? lss)
|
||||
(begin
|
||||
; check syntax of subforms
|
||||
(syntax-case #'olet (let-values)
|
||||
[(let-values (((i ...) e) ...) oc ...) 'ok]
|
||||
[_ (raise-syntax-error
|
||||
':do (string-append "expected (let ((<id> <expr>) ...) <command> ...) or\n"
|
||||
"(let-values ([(<id> ...) <expr>] ...) <command> ...) , got ")
|
||||
#'olet)])
|
||||
(syntax-case #'ilet (let-values)
|
||||
[(let-values (((i ...) e) ...) ic ...) 'ok]
|
||||
[_ (raise-syntax-error
|
||||
':do (string-append "expected (let ((<id> <expr>) ...) <command> ...) or\n"
|
||||
"(let-values ([(<id> ...) <expr>] ...) <command> ...), got ")
|
||||
#'ilet)])
|
||||
(syntax-case #'lbs ()
|
||||
[((i b) ...)
|
||||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error ':do "expected an identifier, got: " i)))
|
||||
(syntax->list #'(i ...)))]
|
||||
[_ (raise-syntax-error
|
||||
':do
|
||||
"expected loop bindings of the form ((<id> <expr>) ...), got: " #'lbs)])
|
||||
(syntax-case #'lss ()
|
||||
[(expr ...) 'ok]
|
||||
[_ (raise-syntax-error "expected loop steppers: (<expr> ...), got: " #'lss)])
|
||||
; everything is ok
|
||||
(syntax-case form-stx (let-values)
|
||||
[(_ (let-values ([(oi ...) oe] ...) oc ...) lbs ne1? (let-values ([(ii ...) ie] ...) ic ...) ne2? lss)
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'((((oi ...) oe) ...) (oc ...) lbs ne1? (((ii ...) ie) ...) (ic ...) ne2? lss))]))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':do
|
||||
"TODO fix message: expected (:do (let ((<id> <expr>) ...) <cmd> ...) <ne1?> (let ((<id> <expr>) ...) <cmd> ...) (<expr> ...)), got "
|
||||
form-stx)]))
|
||||
|
||||
(define-generator (:while form-stx)
|
||||
(syntax-case form-stx ()
|
||||
[(_ gen test)
|
||||
(begin
|
||||
(unless (generator-clause? #'gen)
|
||||
(raise-syntax-error
|
||||
':while "expected a generator clause, got: " #'gen))
|
||||
(let ([loop (generator->loop #'gen)])
|
||||
(syntax-case (loop-stx loop) ()
|
||||
[((ob ...) (oc ...) (lb ...) ne1 (((ib-var ...) ib-rhs) ...) (ic ...) ne2 (ls ...))
|
||||
(with-syntax ([(ib-tmp ...) (generate-temporaries #'(ib-var ... ...))]
|
||||
[(false ...) (map (lambda (x) #'f) (syntax->list #'(ib-var ... ...)))])
|
||||
; this trickery is neccessary to make ib-vars visible in test
|
||||
(make-loop #'((ob ... ((ib-tmp) #f) ...)
|
||||
(oc ...)
|
||||
(lb ...)
|
||||
(let ([ne1-val ne1])
|
||||
(and ne1-val
|
||||
(let-values ([(ib-var ...) ib-rhs] ...)
|
||||
ic ...
|
||||
(set! ib-tmp ib-var) ... ...
|
||||
(and ne1-val test))))
|
||||
(((ib-var ...) ib-tmp) ...)
|
||||
()
|
||||
ne2
|
||||
(ls ...))))])))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':while
|
||||
"expected (:while <generator> <expr>) got: "
|
||||
form-stx)]))
|
||||
|
||||
;;;
|
||||
;;; NORMAL GENERATORS
|
||||
;;;
|
||||
|
||||
|
||||
(module generators mzscheme
|
||||
(provide (all-defined))
|
||||
(require "expansion.scm")
|
||||
(require-for-syntax "expansion.scm")
|
||||
(require-for-template mzscheme)
|
||||
|
||||
|
||||
(define-generator :list
|
||||
(lambda (form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) expr ...)
|
||||
(add-index form-stx #'(_ var expr ...) #'i)]
|
||||
[(_ var expr1 expr2 expr ...)
|
||||
; TODO IMPROVE: something better than append ?
|
||||
#'(_ var (append expr1 expr2 expr ...))]
|
||||
[(_ var expr)
|
||||
(begin
|
||||
(unless (identifier? #'var)
|
||||
(raise-syntax-error ':list "expected identifier, got " #'var))
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'(() () ((xs expr)) (not (null? xs))
|
||||
(((var) (car xs))) () #t ((cdr xs)))))]
|
||||
[_ (raise-syntax-error
|
||||
':list
|
||||
"Expected either (:list <expr> ...) or (:list (index <var>) expr ...), got: "
|
||||
form-stx)])))
|
||||
|
||||
(define-generator (:integers form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i))
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'(() () ((var 0)) #t (((i) var)) () #t ((add1 var))))]
|
||||
[(_ var)
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'(() () ((var 0)) #t () () #t ((add1 var))))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':integers
|
||||
"expected (:integers <var> (index <var>)) where (index <var>) is optional, got: "
|
||||
form-stx)]))
|
||||
|
||||
|
||||
(define (ec-:vector-filter vecs)
|
||||
; filter zero-length vectors
|
||||
(if (null? vecs)
|
||||
'()
|
||||
(if (zero? (vector-length (car vecs)))
|
||||
(ec-:vector-filter (cdr vecs))
|
||||
(cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
|
||||
|
||||
; The expansion below uses name-append to turn
|
||||
; (:name var expr1 expr2 ...)
|
||||
; into
|
||||
; (:name var (name-append expr1 expr2 ...))
|
||||
|
||||
; If your indexed sequence doesn't have an append operation
|
||||
; (or it is too expensive to use) then use
|
||||
; define-indexed-generator instead.
|
||||
|
||||
(define-syntax (define-indexed-generator-with-append stx)
|
||||
(syntax-case stx ()
|
||||
[(__ :name (name? name-ref name-length name-append name-type))
|
||||
#'(define-generator (:name form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) expr (... ...))
|
||||
(add-index form-stx #'(:name var expr (... ...)) #'i)]
|
||||
[(_ var expr)
|
||||
(begin
|
||||
(unless (identifier? #'var)
|
||||
(raise-syntax-error
|
||||
':name
|
||||
"expected a variable to bind"
|
||||
#'var))
|
||||
#'(:do (let ((seq expr) (len 0))
|
||||
(set! len (name-length seq)))
|
||||
((i 0))
|
||||
(< i len)
|
||||
(let ((var (name-ref seq i))))
|
||||
#t
|
||||
((+ i 1)) ))]
|
||||
[(_ var expr (... ...))
|
||||
#`(:name var (let ([es (list expr (... ...))])
|
||||
(unless (andmap name? es)
|
||||
(error
|
||||
':name
|
||||
(format "expected ~as, but got: ~~a " name-type)
|
||||
es))
|
||||
; TODO: use raise-syntax-error above (how?)
|
||||
(apply name-append es)))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':name
|
||||
(format "expected (~a <var> (index i) <expr> <expr> ...) where (index i) is optional, got: "
|
||||
':name)
|
||||
form-stx)]))]))
|
||||
|
||||
(define-indexed-generator-with-append :string
|
||||
(string? string-ref string-length string-append "string"))
|
||||
|
||||
(define-indexed-generator-with-append :bytes
|
||||
(bytes? bytes-ref bytes-length bytes-append "byte-string"))
|
||||
|
||||
; The expansion below basically turns
|
||||
; (:name var expr1 expr2 ...)
|
||||
; into (nested (: xs (list expr1 expr2 ...)
|
||||
; (:name var xs))
|
||||
; except we need to write it as a do-loop.
|
||||
|
||||
(define-syntax (define-indexed-generator-without-append stx)
|
||||
(syntax-case stx ()
|
||||
[(__ :name (name? name-ref name-length name-type))
|
||||
#'(define-generator (:name form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) expr (... ...))
|
||||
(add-index form-stx #'(:name var expr (... ...)) #'i)]
|
||||
[(_ var expr)
|
||||
(begin
|
||||
(unless (identifier? #'var)
|
||||
(raise-syntax-error
|
||||
':name
|
||||
"expected a variable to bind"
|
||||
#'var))
|
||||
#`(:do (let ((seq expr) (len 0))
|
||||
(set! len (name-length seq)))
|
||||
((i 0))
|
||||
(< i len)
|
||||
(let ((var #,(syntax/loc form-stx (name-ref seq i)))))
|
||||
#t
|
||||
((+ i 1)) ))]
|
||||
[(_ var expr (... ...))
|
||||
#'(:do (let ([es ; filter zero-length sequences away
|
||||
(let lp ([es (list expr (... ...))])
|
||||
(cond
|
||||
[(null? es) '()]
|
||||
[(zero? (name-length (car es))) (lp (cdr es))]
|
||||
[else (cons (car es) (lp (cdr es)))]))]
|
||||
[current #f]
|
||||
[current-length 0]))
|
||||
((k 0))
|
||||
(if (< k current-length)
|
||||
#t
|
||||
(if (null? es)
|
||||
#f
|
||||
(begin (set! current (car es))
|
||||
(set! es (cdr es))
|
||||
(set! current-length (name-length current))
|
||||
(set! k 0)
|
||||
#t)))
|
||||
(let ((var (name-ref current k))))
|
||||
#t
|
||||
((+ k 1)))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':name
|
||||
(format "expected (~a <var> (index i) <expr> <expr> ...) where (index i) is optional, got: "
|
||||
':name)
|
||||
form-stx)]))]))
|
||||
|
||||
(define-indexed-generator-without-append :vector
|
||||
(vector? vector-ref vector-length "vector"))
|
||||
|
||||
|
||||
(define-generator (:range form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
; handle index variable and add optional args
|
||||
((:range var (index i) arg1 arg ...)
|
||||
(add-index form-stx #'(:range var arg1 arg ...) #'i))
|
||||
((:range var arg1)
|
||||
#'(:range var 0 arg1 1) )
|
||||
((:range var arg1 arg2)
|
||||
#'(:range var arg1 arg2 1) )
|
||||
|
||||
; special cases (partially evaluated by hand from general case)
|
||||
((:range var 0 arg2 1)
|
||||
#'(:do (let ((b arg2))
|
||||
(if (not (and (integer? b) (exact? b)))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" 0 b 1 )))
|
||||
((var 0))
|
||||
(< var b)
|
||||
(let ())
|
||||
#t
|
||||
((+ var 1)) ))
|
||||
|
||||
((:range var 0 arg2 -1)
|
||||
#'(:do (let ((b arg2))
|
||||
(if (not (and (integer? b) (exact? b)))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" 0 b 1 )))
|
||||
((var 0))
|
||||
(> var b)
|
||||
(let ())
|
||||
#t
|
||||
((- var 1)) ))
|
||||
|
||||
((:range var arg1 arg2 1)
|
||||
#'(:do (let ((a arg1) (b arg2))
|
||||
(if (not (and (integer? a) (exact? a)
|
||||
(integer? b) (exact? b) ))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" a b 1 )) )
|
||||
((var a))
|
||||
(< var b)
|
||||
(let ())
|
||||
#t
|
||||
((+ var 1)) ))
|
||||
|
||||
((:range var arg1 arg2 -1)
|
||||
#'(:do (let ((a arg1) (b arg2) (s -1) (stop 0))
|
||||
(if (not (and (integer? a) (exact? a)
|
||||
(integer? b) (exact? b) ))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" a b -1 )) )
|
||||
((var a))
|
||||
(> var b)
|
||||
(let ())
|
||||
#t
|
||||
((- var 1)) ))
|
||||
|
||||
; the general case
|
||||
|
||||
((:range var arg1 arg2 arg3)
|
||||
#'(:do (let ((a arg1) (b arg2) (s arg3) (stop 0))
|
||||
(if (not (and (integer? a) (exact? a)
|
||||
(integer? b) (exact? b)
|
||||
(integer? s) (exact? s) ))
|
||||
(error
|
||||
"arguments of :range are not exact integer "
|
||||
"(use :real-range?)" a b s ))
|
||||
(if (zero? s)
|
||||
(error "step size must not be zero in :range") )
|
||||
(set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
|
||||
((var a))
|
||||
(not (= var stop))
|
||||
(let ())
|
||||
#t
|
||||
((+ var s)) ))))
|
||||
|
||||
|
||||
(define-generator (:real-range form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
; add optional args and index variable
|
||||
((:real-range var arg1)
|
||||
#'(:real-range var (index i) 0 arg1 1) )
|
||||
((:real-range var (index i) arg1)
|
||||
#'(:real-range var (index i) 0 arg1 1) )
|
||||
((:real-range var arg1 arg2)
|
||||
#'(:real-range var (index i) arg1 arg2 1) )
|
||||
((:real-range var (index i) arg1 arg2)
|
||||
#'(:real-range var (index i) arg1 arg2 1) )
|
||||
((:real-range var arg1 arg2 arg3)
|
||||
#'(:real-range var (index i) arg1 arg2 arg3) )
|
||||
|
||||
; the fully qualified case
|
||||
((:real-range var (index i) arg1 arg2 arg3)
|
||||
#'(:do (let ((a arg1) (b arg2) (s arg3) (istop 0))
|
||||
(if (not (and (real? a) (real? b) (real? s)))
|
||||
(error "arguments of :real-range are not real" a b s) )
|
||||
(if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
|
||||
(set! a (exact->inexact a)) )
|
||||
(set! istop (/ (- b a) s)) )
|
||||
((i 0))
|
||||
(< i istop)
|
||||
(let ((var (+ a (* s i)))))
|
||||
#t
|
||||
((+ i 1)) ))))
|
||||
|
||||
; Comment: The macro :real-range adapts the exactness of the start
|
||||
; value in case any of the other values is inexact. This is a
|
||||
; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
|
||||
|
||||
(define-generator (:char-range form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ var (index i) expr1 expr2)
|
||||
(add-index form-stx #'(:char-range var expr1 expr2) #'i)]
|
||||
[(_ var expr1 expr2)
|
||||
#'(:do (let ((imax (char->integer expr2))))
|
||||
((i (char->integer expr1)))
|
||||
(<= i imax)
|
||||
(let ((var (integer->char i))))
|
||||
#t
|
||||
((+ i 1)) )]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':char-range
|
||||
"expected (:char-range <var> (index <var>) <expr> <expr>) where the index is optional, got: "
|
||||
form-stx)]))
|
||||
|
||||
(define-generator (:port form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
((:port var (index i) arg1 arg ...)
|
||||
(add-index form-stx #'(:port var arg1 arg ...) #'i))
|
||||
((:port var arg)
|
||||
#'(:port var arg read) )
|
||||
((:port var arg1 arg2)
|
||||
#'(:do (let ((port arg1) (read-proc arg2)))
|
||||
((var (read-proc port)))
|
||||
(not (eof-object? var))
|
||||
(let ())
|
||||
#t
|
||||
((read-proc port)) ))
|
||||
(_
|
||||
(raise-syntax-error
|
||||
':port
|
||||
"expected (:port <var> (index i) <reader-expr>) where index is optional, and the <reader-expr> defaults to read, got:"
|
||||
form-stx))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; SPECIAL GENERATORS
|
||||
;;;
|
||||
|
||||
(define-generator (:let form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
; ($ loop ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
[(_ var (index i) expr)
|
||||
(make-loop #'(() () ((var expr) (i 0)) #t () () #f ()))]
|
||||
[(_ var expr)
|
||||
(make-loop #'(() () ((var expr)) #t () () #f ()))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':let "expected (:let <var> <expr>) or (:let <var> (index <var>) <expr>), got:"
|
||||
form-stx)]))
|
||||
|
||||
(require-for-syntax (lib "match.ss"))
|
||||
|
||||
(define-generator (:parallel form-stx)
|
||||
; TODO: Check that all subforms are generators
|
||||
(syntax-case form-stx (index)
|
||||
[(_ (index i) q ...)
|
||||
(add-index form-stx #'(_ q ...) #'i)]
|
||||
[(_ gen)
|
||||
(generator->loop #'gen)]
|
||||
[(_ gen1 gen2)
|
||||
(syntax-case (list (loop-stx (generator->loop #'gen1))
|
||||
(loop-stx (generator->loop #'gen2))) ()
|
||||
[(((ob ...) (oc ...) (lb ...) ne1 (ib ...) (ic ...) ne2 (ls ...))
|
||||
((ob2 ...) (oc2 ...) (lb2 ...) ne12 (ib2 ...) (ic2 ...) ne22 (ls2 ...)))
|
||||
(make-loop
|
||||
#'((ob ... ob2 ...)
|
||||
(oc ... oc2 ...) (lb ... lb2 ...)
|
||||
(and ne1 ne12) (ib ... ib2 ...)
|
||||
(ic ... ic2 ...) (and ne2 ne22)
|
||||
(ls ... ls2 ...)))])]
|
||||
[(_ gen1 gen2 gen3 ...)
|
||||
#'(:parallel (:parallel gen1 gen2) gen3 ...)]))
|
||||
|
||||
(define-generator (:until form-stx)
|
||||
(syntax-case form-stx (index)
|
||||
[(_ gen test-expr)
|
||||
(unless (generator-clause? #'gen)
|
||||
(raise-syntax-error
|
||||
':until "expected <generator> in " #'gen))
|
||||
(syntax-case (loop-stx (generator->loop #'gen)) ()
|
||||
[(obs ocs lbs ne1 ibs ics ne2 lss)
|
||||
(make-loop #'(obs ocs lbs ne1 ibs ics
|
||||
(and ne2 (not test-expr))
|
||||
lss))])]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':until "expected (:until <generator> <expression>), got: "
|
||||
form-stx)]))
|
||||
|
||||
|
||||
(define-generator (:do form-stx)
|
||||
(syntax-case form-stx (let let-values)
|
||||
; short form -> fill in default value
|
||||
[(_ ((lv le) ...) ne1? (expr ...))
|
||||
#'(:do (let ()) ((lv le) ...) ne1? (let ()) #t (expr ...))]
|
||||
; convert (let _) variants to (let-values _)
|
||||
[(_ (let ((on oe) ...) <oc> ...) (<lb> ...) <ne1?> (let ((in ie) ...) <ic> ...) <ne2?> (<ls> ...))
|
||||
#'(_ (let-values (((on) oe) ...) <oc> ...) (<lb> ...) <ne1?> (let-values ([(in) ie] ...) <ic> ...) <ne2?> (<ls> ...))]
|
||||
[(_ (let ((on oe) ...) <oc> ...) (<lb> ...) <ne1?> ilet <ne2?> (<ls> ...))
|
||||
#'(_ (let-values (((on) oe) ...) <oc> ...) (<lb> ...) <ne1?> ilet <ne2?> (<ls> ...))]
|
||||
[(_ olet (<lb> ...) <ne1?> (let ((in ie) ...) <ic> ...) <ne2?> (<ls> ...))
|
||||
#'(_ olet (<lb> ...) <ne1?> (let-values ([(in) ie] ...) <ic> ...) <ne2?> (<ls> ...))]
|
||||
|
||||
; now both outer bindings and inner bindings must be let-values bindings
|
||||
[(_ olet lbs ne1? ilet ne2? lss)
|
||||
(begin
|
||||
; check syntax of subforms
|
||||
(syntax-case #'olet (let-values)
|
||||
[(let-values (((i ...) e) ...) oc ...) 'ok]
|
||||
[_ (raise-syntax-error
|
||||
':do (string-append "expected (let ((<id> <expr>) ...) <command> ...) or\n"
|
||||
"(let-values ([(<id> ...) <expr>] ...) <command> ...) , got ")
|
||||
#'olet)])
|
||||
(syntax-case #'ilet (let-values)
|
||||
[(let-values (((i ...) e) ...) ic ...) 'ok]
|
||||
[_ (raise-syntax-error
|
||||
':do (string-append "expected (let ((<id> <expr>) ...) <command> ...) or\n"
|
||||
"(let-values ([(<id> ...) <expr>] ...) <command> ...), got ")
|
||||
#'ilet)])
|
||||
(syntax-case #'lbs ()
|
||||
[((i b) ...)
|
||||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error ':do "expected an identifier, got: " i)))
|
||||
(syntax->list #'(i ...)))]
|
||||
[_ (raise-syntax-error
|
||||
':do
|
||||
"expected loop bindings of the form ((<id> <expr>) ...), got: " #'lbs)])
|
||||
(syntax-case #'lss ()
|
||||
[(expr ...) 'ok]
|
||||
[_ (raise-syntax-error "expected loop steppers: (<expr> ...), got: " #'lss)])
|
||||
; everything is ok
|
||||
(syntax-case form-stx (let-values)
|
||||
[(_ (let-values ([(oi ...) oe] ...) oc ...) lbs ne1? (let-values ([(ii ...) ie] ...) ic ...) ne2? lss)
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(make-loop #'((((oi ...) oe) ...) (oc ...) lbs ne1? (((ii ...) ie) ...) (ic ...) ne2? lss))]))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':do
|
||||
"TODO fix message: expected (:do (let ((<id> <expr>) ...) <cmd> ...) <ne1?> (let ((<id> <expr>) ...) <cmd> ...) (<expr> ...)), got "
|
||||
form-stx)]))
|
||||
|
||||
(define-generator (:while form-stx)
|
||||
(syntax-case form-stx ()
|
||||
[(_ gen test)
|
||||
(begin
|
||||
(unless (generator-clause? #'gen)
|
||||
(raise-syntax-error
|
||||
':while "expected a generator clause, got: " #'gen))
|
||||
(let ([loop (generator->loop #'gen)])
|
||||
(syntax-case (loop-stx loop) ()
|
||||
[((ob ...) (oc ...) (lb ...) ne1 (((ib-var ...) ib-rhs) ...) (ic ...) ne2 (ls ...))
|
||||
(with-syntax ([(ib-tmp ...) (generate-temporaries #'(ib-var ... ...))]
|
||||
[(false ...) (map (lambda (x) #'f) (syntax->list #'(ib-var ... ...)))])
|
||||
; this trickery is neccessary to make ib-vars visible in test
|
||||
(make-loop #'((ob ... ((ib-tmp) #f) ...)
|
||||
(oc ...)
|
||||
(lb ...)
|
||||
(let ([ne1-val ne1])
|
||||
(and ne1-val
|
||||
(let-values ([(ib-var ...) ib-rhs] ...)
|
||||
ic ...
|
||||
(set! ib-tmp ib-var) ... ...
|
||||
(and ne1-val test))))
|
||||
(((ib-var ...) ib-tmp) ...)
|
||||
()
|
||||
ne2
|
||||
(ls ...))))])))]
|
||||
[_
|
||||
(raise-syntax-error
|
||||
':while
|
||||
"expected (:while <generator> <expr>) got: "
|
||||
form-stx)]))
|
||||
|
||||
)
|
||||
|
|
@ -1,110 +1,110 @@
|
|||
;;;
|
||||
;;; LOOPS
|
||||
;;;
|
||||
|
||||
(module loops mzscheme
|
||||
(provide loop loop-stx
|
||||
loop->syntax
|
||||
(rename checked-make-loop make-loop)
|
||||
loop? )
|
||||
|
||||
; The structure of a loop is:
|
||||
|
||||
#;(let (<ob>*) ; outer bindings
|
||||
<oc>* ; outer commands
|
||||
(let loop (<lb>*) ; loop bindings
|
||||
(if <ne1?> ; not end (stop-before)
|
||||
(let (<ib>*) ; inner bindings
|
||||
<ic>* ; inner commands
|
||||
<payload> ; payload (from the comprehension)
|
||||
(if <ne2?> ; not end (stop-after)
|
||||
(loop <ls>*)))))) ; loop steppers
|
||||
|
||||
; A binding is a list consisting of two syntax-objects,
|
||||
; the first represents the variable, the other the expression.
|
||||
|
||||
; Actually for the inner and outer bindings we are using let-values instead of let.
|
||||
; The form (:do _) supports both (let _) and (let-values _) syntax for these bindings.
|
||||
; (let ((v e) ...) c ...)
|
||||
; == (let-values (((v) e) ...) c ...)
|
||||
|
||||
(define-struct loop (stx))
|
||||
; stx is a syntax-object representing:
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
|
||||
(define (checked-make-loop stx)
|
||||
(define (check-values-bindings stx)
|
||||
(syntax-case stx ()
|
||||
[(((name ...) expr) ...)
|
||||
(begin
|
||||
(unless (andmap identifier? (syntax->list #'(name ... ...)))
|
||||
(raise-syntax-error
|
||||
'make-loop "expected list of bindings, got: " stx)))]))
|
||||
(define (check-bindings stx)
|
||||
(syntax-case stx ()
|
||||
[((name expr) ...)
|
||||
(begin
|
||||
(unless (andmap identifier? (syntax->list #'(name ...)))
|
||||
(raise-syntax-error
|
||||
'make-loop "expected list of bindings, got: " stx)))]))
|
||||
(define (check-list-of stx what)
|
||||
(syntax-case stx ()
|
||||
[(x ...) 'ok]
|
||||
[_ (raise-syntax-error
|
||||
'make-loop (format "expected list of ~a, got: " what) stx)]))
|
||||
; checks
|
||||
(syntax-case stx ()
|
||||
[(ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(begin
|
||||
(check-values-bindings #'ob*)
|
||||
(check-values-bindings #'ib*)
|
||||
; (check-bindings #'lb*)
|
||||
(check-list-of #'oc* "outer commands")
|
||||
(check-list-of #'ic* "inner commands")
|
||||
(check-list-of #'ls* "loop steppers"))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
'make-loop
|
||||
"expected (ob* oc* lb* ne1 ib* ic* ne2 ls*), got: " stx)])
|
||||
; everything's ok
|
||||
(make-loop stx))
|
||||
|
||||
|
||||
; A simple loop has the structure:
|
||||
|
||||
#;(let loop (<lb>*)
|
||||
(if <ne1?>
|
||||
(loop <ls>*)))
|
||||
|
||||
(require-for-template mzscheme)
|
||||
(require-for-template "simplifier.scm")
|
||||
|
||||
; make-simple-loop : stx stx stx -> loop
|
||||
; build a loop from the simple pieces
|
||||
;(define (make-simple-loop lb* ne1 ls*)
|
||||
; (with-syntax ([lb* lb*] [ne1 ne1] [ls* ls*])
|
||||
; (make-loop #'(() () lb* ne1 () () #t ls*))))
|
||||
|
||||
; loop->syntax : src-stx loop stx -> stx
|
||||
; Turn the loop structure l into a
|
||||
; syntax-object containing a loop.
|
||||
; Use payload as the body of the load.
|
||||
; The src-location info is taken from src-stx.
|
||||
(define (loop->syntax src-stx l payload)
|
||||
(syntax-case (loop-stx l) ()
|
||||
[((ob ...) (oc ...) (lb ...) ne1 (ib ...) (ic ...) ne2 (ls ...))
|
||||
(with-syntax ([payload payload])
|
||||
(syntax/loc src-stx
|
||||
(let-values (ob ...)
|
||||
oc ...
|
||||
(let loop (lb ...)
|
||||
(ec-simplify
|
||||
(if ne1
|
||||
(let-values (ib ...)
|
||||
ic ...
|
||||
(ec-simplify payload)
|
||||
(ec-simplify
|
||||
(if ne2
|
||||
(loop ls ...))))))))))]))
|
||||
|
||||
;;;
|
||||
;;; LOOPS
|
||||
;;;
|
||||
|
||||
(module loops mzscheme
|
||||
(provide loop loop-stx
|
||||
loop->syntax
|
||||
(rename checked-make-loop make-loop)
|
||||
loop? )
|
||||
|
||||
; The structure of a loop is:
|
||||
|
||||
#;(let (<ob>*) ; outer bindings
|
||||
<oc>* ; outer commands
|
||||
(let loop (<lb>*) ; loop bindings
|
||||
(if <ne1?> ; not end (stop-before)
|
||||
(let (<ib>*) ; inner bindings
|
||||
<ic>* ; inner commands
|
||||
<payload> ; payload (from the comprehension)
|
||||
(if <ne2?> ; not end (stop-after)
|
||||
(loop <ls>*)))))) ; loop steppers
|
||||
|
||||
; A binding is a list consisting of two syntax-objects,
|
||||
; the first represents the variable, the other the expression.
|
||||
|
||||
; Actually for the inner and outer bindings we are using let-values instead of let.
|
||||
; The form (:do _) supports both (let _) and (let-values _) syntax for these bindings.
|
||||
; (let ((v e) ...) c ...)
|
||||
; == (let-values (((v) e) ...) c ...)
|
||||
|
||||
(define-struct loop (stx))
|
||||
; stx is a syntax-object representing:
|
||||
; (ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
|
||||
(define (checked-make-loop stx)
|
||||
(define (check-values-bindings stx)
|
||||
(syntax-case stx ()
|
||||
[(((name ...) expr) ...)
|
||||
(begin
|
||||
(unless (andmap identifier? (syntax->list #'(name ... ...)))
|
||||
(raise-syntax-error
|
||||
'make-loop "expected list of bindings, got: " stx)))]))
|
||||
(define (check-bindings stx)
|
||||
(syntax-case stx ()
|
||||
[((name expr) ...)
|
||||
(begin
|
||||
(unless (andmap identifier? (syntax->list #'(name ...)))
|
||||
(raise-syntax-error
|
||||
'make-loop "expected list of bindings, got: " stx)))]))
|
||||
(define (check-list-of stx what)
|
||||
(syntax-case stx ()
|
||||
[(x ...) 'ok]
|
||||
[_ (raise-syntax-error
|
||||
'make-loop (format "expected list of ~a, got: " what) stx)]))
|
||||
; checks
|
||||
(syntax-case stx ()
|
||||
[(ob* oc* lb* ne1 ib* ic* ne2 ls*)
|
||||
(begin
|
||||
(check-values-bindings #'ob*)
|
||||
(check-values-bindings #'ib*)
|
||||
; (check-bindings #'lb*)
|
||||
(check-list-of #'oc* "outer commands")
|
||||
(check-list-of #'ic* "inner commands")
|
||||
(check-list-of #'ls* "loop steppers"))]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
'make-loop
|
||||
"expected (ob* oc* lb* ne1 ib* ic* ne2 ls*), got: " stx)])
|
||||
; everything's ok
|
||||
(make-loop stx))
|
||||
|
||||
|
||||
; A simple loop has the structure:
|
||||
|
||||
#;(let loop (<lb>*)
|
||||
(if <ne1?>
|
||||
(loop <ls>*)))
|
||||
|
||||
(require-for-template mzscheme)
|
||||
(require-for-template "simplifier.scm")
|
||||
|
||||
; make-simple-loop : stx stx stx -> loop
|
||||
; build a loop from the simple pieces
|
||||
;(define (make-simple-loop lb* ne1 ls*)
|
||||
; (with-syntax ([lb* lb*] [ne1 ne1] [ls* ls*])
|
||||
; (make-loop #'(() () lb* ne1 () () #t ls*))))
|
||||
|
||||
; loop->syntax : src-stx loop stx -> stx
|
||||
; Turn the loop structure l into a
|
||||
; syntax-object containing a loop.
|
||||
; Use payload as the body of the load.
|
||||
; The src-location info is taken from src-stx.
|
||||
(define (loop->syntax src-stx l payload)
|
||||
(syntax-case (loop-stx l) ()
|
||||
[((ob ...) (oc ...) (lb ...) ne1 (ib ...) (ic ...) ne2 (ls ...))
|
||||
(with-syntax ([payload payload])
|
||||
(syntax/loc src-stx
|
||||
(let-values (ob ...)
|
||||
oc ...
|
||||
(let loop (lb ...)
|
||||
(ec-simplify
|
||||
(if ne1
|
||||
(let-values (ib ...)
|
||||
ic ...
|
||||
(ec-simplify payload)
|
||||
(ec-simplify
|
||||
(if ne2
|
||||
(loop ls ...))))))))))]))
|
||||
|
||||
)
|
||||
|
|
@ -1,93 +1,93 @@
|
|||
;;;
|
||||
;;; SIMPLIFIER
|
||||
;;;
|
||||
|
||||
(module simplifier mzscheme
|
||||
(provide ec-simplify)
|
||||
|
||||
; (ec-simplify <expression>)
|
||||
; generates potentially more efficient code for <expression>.
|
||||
; The macro handles if, (begin <command>*), and (let () <command>*)
|
||||
; and takes care of special cases.
|
||||
;
|
||||
; NOTE: Turns out the JIT optimizer doesn't handle (not (not x))
|
||||
; and (if (not x) expr1 expr2) => (if x expr2 expr1)
|
||||
; yet.
|
||||
|
||||
#;(define-syntax ec-simplify
|
||||
(syntax-rules ()
|
||||
[(_ . (more)) more]))
|
||||
|
||||
(require-for-syntax (lib "stx.ss" "syntax"))
|
||||
|
||||
(define-syntax (ec-simplify stx)
|
||||
(syntax-case* stx (if not let begin #%top #%app) module-or-top-identifier=?
|
||||
|
||||
; one- and two-sided if
|
||||
|
||||
; literal <test>
|
||||
((ec-simplify (if #t consequent))
|
||||
#'consequent )
|
||||
((ec-simplify (if #f consequent))
|
||||
#'(if #f #f) )
|
||||
((ec-simplify (if #t consequent alternate))
|
||||
#'consequent )
|
||||
((ec-simplify (if #f consequent alternate))
|
||||
#'alternate )
|
||||
|
||||
; (not (not <test>))
|
||||
((ec-simplify (if (not (not test)) consequent))
|
||||
#'(ec-simplify (if test consequent)) )
|
||||
|
||||
((ec-simplify (if (#%app not (not test)) consequent))
|
||||
#'(ec-simplify (if test consequent)) )
|
||||
|
||||
((ec-simplify (if (not (#%app not test)) consequent))
|
||||
#'(ec-simplify (if test consequent)) )
|
||||
|
||||
((ec-simplify (if (#%app not (#%app not test)) consequent))
|
||||
#'(ec-simplify (if test consequent)) )
|
||||
|
||||
((ec-simplify (if (not (not test)) consequent alternate))
|
||||
#'(ec-simplify (if test consequent alternate)) )
|
||||
|
||||
((ec-simplify (if (#%app not (not test)) consequent alternate))
|
||||
#'(ec-simplify (if test consequent alternate)) )
|
||||
|
||||
((ec-simplify (if (not (#%app not test)) consequent alternate))
|
||||
#'(ec-simplify (if test consequent alternate)) )
|
||||
|
||||
((ec-simplify (if (#%app not (#%app not test)) consequent alternate))
|
||||
#'(ec-simplify (if test consequent alternate)) )
|
||||
|
||||
|
||||
; (let () <command>*)
|
||||
|
||||
; empty <binding spec>*
|
||||
#;((ec-simplify (let () command ...))
|
||||
#'(ec-simplify (begin command ...)) )
|
||||
; NOTE: Removed. let introduces a new scope, begin doesn't
|
||||
|
||||
|
||||
; begin
|
||||
|
||||
; flatten use helper (ec-simplify 1 done to-do)
|
||||
((ec-simplify (begin command ...))
|
||||
#'(ec-simplify 1 () (command ...)) )
|
||||
((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
|
||||
#'(ec-simplify 1 done (to-do1 ... to-do2 ...)) )
|
||||
((ec-simplify 1 (done ...) (to-do1 to-do ...))
|
||||
#'(ec-simplify 1 (done ... to-do1) (to-do ...)) )
|
||||
|
||||
; exit helper
|
||||
((ec-simplify 1 () ())
|
||||
#'(if #f #f) )
|
||||
((ec-simplify 1 (command) ())
|
||||
#'command )
|
||||
((ec-simplify 1 (command1 command ...) ())
|
||||
#'(begin command1 command ...) )
|
||||
|
||||
; anything else
|
||||
|
||||
((ec-simplify expression)
|
||||
;;;
|
||||
;;; SIMPLIFIER
|
||||
;;;
|
||||
|
||||
(module simplifier mzscheme
|
||||
(provide ec-simplify)
|
||||
|
||||
; (ec-simplify <expression>)
|
||||
; generates potentially more efficient code for <expression>.
|
||||
; The macro handles if, (begin <command>*), and (let () <command>*)
|
||||
; and takes care of special cases.
|
||||
;
|
||||
; NOTE: Turns out the JIT optimizer doesn't handle (not (not x))
|
||||
; and (if (not x) expr1 expr2) => (if x expr2 expr1)
|
||||
; yet.
|
||||
|
||||
#;(define-syntax ec-simplify
|
||||
(syntax-rules ()
|
||||
[(_ . (more)) more]))
|
||||
|
||||
(require-for-syntax (lib "stx.ss" "syntax"))
|
||||
|
||||
(define-syntax (ec-simplify stx)
|
||||
(syntax-case* stx (if not let begin #%top #%app) module-or-top-identifier=?
|
||||
|
||||
; one- and two-sided if
|
||||
|
||||
; literal <test>
|
||||
((ec-simplify (if #t consequent))
|
||||
#'consequent )
|
||||
((ec-simplify (if #f consequent))
|
||||
#'(if #f #f) )
|
||||
((ec-simplify (if #t consequent alternate))
|
||||
#'consequent )
|
||||
((ec-simplify (if #f consequent alternate))
|
||||
#'alternate )
|
||||
|
||||
; (not (not <test>))
|
||||
((ec-simplify (if (not (not test)) consequent))
|
||||
#'(ec-simplify (if test consequent)) )
|
||||
|
||||
((ec-simplify (if (#%app not (not test)) consequent))
|
||||
#'(ec-simplify (if test consequent)) )
|
||||
|
||||
((ec-simplify (if (not (#%app not test)) consequent))
|
||||
#'(ec-simplify (if test consequent)) )
|
||||
|
||||
((ec-simplify (if (#%app not (#%app not test)) consequent))
|
||||
#'(ec-simplify (if test consequent)) )
|
||||
|
||||
((ec-simplify (if (not (not test)) consequent alternate))
|
||||
#'(ec-simplify (if test consequent alternate)) )
|
||||
|
||||
((ec-simplify (if (#%app not (not test)) consequent alternate))
|
||||
#'(ec-simplify (if test consequent alternate)) )
|
||||
|
||||
((ec-simplify (if (not (#%app not test)) consequent alternate))
|
||||
#'(ec-simplify (if test consequent alternate)) )
|
||||
|
||||
((ec-simplify (if (#%app not (#%app not test)) consequent alternate))
|
||||
#'(ec-simplify (if test consequent alternate)) )
|
||||
|
||||
|
||||
; (let () <command>*)
|
||||
|
||||
; empty <binding spec>*
|
||||
#;((ec-simplify (let () command ...))
|
||||
#'(ec-simplify (begin command ...)) )
|
||||
; NOTE: Removed. let introduces a new scope, begin doesn't
|
||||
|
||||
|
||||
; begin
|
||||
|
||||
; flatten use helper (ec-simplify 1 done to-do)
|
||||
((ec-simplify (begin command ...))
|
||||
#'(ec-simplify 1 () (command ...)) )
|
||||
((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
|
||||
#'(ec-simplify 1 done (to-do1 ... to-do2 ...)) )
|
||||
((ec-simplify 1 (done ...) (to-do1 to-do ...))
|
||||
#'(ec-simplify 1 (done ... to-do1) (to-do ...)) )
|
||||
|
||||
; exit helper
|
||||
((ec-simplify 1 () ())
|
||||
#'(if #f #f) )
|
||||
((ec-simplify 1 (command) ())
|
||||
#'command )
|
||||
((ec-simplify 1 (command1 command ...) ())
|
||||
#'(begin command1 command ...) )
|
||||
|
||||
; anything else
|
||||
|
||||
((ec-simplify expression)
|
||||
#'expression ))))
|
||||
Loading…
Reference in New Issue
Block a user