From ac509e8b2d9da404be10acefccf90a8587c5c788 Mon Sep 17 00:00:00 2001 From: Jens Axel Soegaard Date: Tue, 5 Aug 2008 22:24:56 +0000 Subject: [PATCH] Set forgotten svn:eol-style to native svn: r11095 --- collects/srfi/42/comprehension-struct.scm | 20 +- collects/srfi/42/comprehensions.scm | 806 +++++++++--------- collects/srfi/42/dispatching.scm | 348 ++++---- collects/srfi/42/ec-core.scm | 18 +- collects/srfi/42/ec.scm | 104 +-- collects/srfi/42/expansion.scm | 388 ++++----- collects/srfi/42/generator-definitions.scm | 74 +- collects/srfi/42/generator-struct.scm | 32 +- collects/srfi/42/generators.scm | 914 ++++++++++----------- collects/srfi/42/loops.scm | 218 ++--- collects/srfi/42/simplifier.scm | 184 ++--- 11 files changed, 1553 insertions(+), 1553 deletions(-) diff --git a/collects/srfi/42/comprehension-struct.scm b/collects/srfi/42/comprehension-struct.scm index d210d4452a..812edf887e 100644 --- a/collects/srfi/42/comprehension-struct.scm +++ b/collects/srfi/42/comprehension-struct.scm @@ -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))) diff --git a/collects/srfi/42/comprehensions.scm b/collects/srfi/42/comprehensions.scm index 252558622a..c2776152ed 100644 --- a/collects/srfi/42/comprehensions.scm +++ b/collects/srfi/42/comprehensions.scm @@ -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 ... ), got: ") - #'body)) - #`(let ([result '()]) - #,((expand-clauses #'(clause ...)) - #'(set! result (cons body result))) - (reverse result)))] - [_ - (raise-syntax-error - 'name-ec - "expected (list-ec ... ), 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 ... ), got: ") - 'name-ec) - #'body)) - (let ([inserter (expand-clauses #'(clause (... ...)))]) - expansion))] - [_ - (raise-syntax-error - 'name-ec - (format "expected (~a ... ), got: " 'name-ec) - st)]))] - [else - (raise-syntax-error - 'define-comprehension - "expected (define-comprehension ) " - 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 ... ), 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 ... ), 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 ... ), 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 ... ), 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 ... ), 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 ... ), got: ") + #'body)) + #`(let ([result '()]) + #,((expand-clauses #'(clause ...)) + #'(set! result (cons body result))) + (reverse result)))] + [_ + (raise-syntax-error + 'name-ec + "expected (list-ec ... ), 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 ... ), got: ") + 'name-ec) + #'body)) + (let ([inserter (expand-clauses #'(clause (... ...)))]) + expansion))] + [_ + (raise-syntax-error + 'name-ec + (format "expected (~a ... ), got: " 'name-ec) + st)]))] + [else + (raise-syntax-error + 'define-comprehension + "expected (define-comprehension ) " + 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 ... ), 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 ... ), 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 ... ), 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 ... ), 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 ... ), 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) )) + ) \ No newline at end of file diff --git a/collects/srfi/42/dispatching.scm b/collects/srfi/42/dispatching.scm index b31710934e..d73348a1c9 100644 --- a/collects/srfi/42/dispatching.scm +++ b/collects/srfi/42/dispatching.scm @@ -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 (: ) or (: (index ) ), 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 (: ) or (: (index ) ), 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)])) + + ) diff --git a/collects/srfi/42/ec-core.scm b/collects/srfi/42/ec-core.scm index 0a964e7e3a..703bc5bf44 100644 --- a/collects/srfi/42/ec-core.scm +++ b/collects/srfi/42/ec-core.scm @@ -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"))) diff --git a/collects/srfi/42/ec.scm b/collects/srfi/42/ec.scm index d2a232d656..cf940a1389 100644 --- a/collects/srfi/42/ec.scm +++ b/collects/srfi/42/ec.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 + ) + + ) diff --git a/collects/srfi/42/expansion.scm b/collects/srfi/42/expansion.scm index 18bae2de6f..e06475b4b5 100644 --- a/collects/srfi/42/expansion.scm +++ b/collects/srfi/42/expansion.scm @@ -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 " #'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 " or 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 " #'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 " or 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)])) ) \ No newline at end of file diff --git a/collects/srfi/42/generator-definitions.scm b/collects/srfi/42/generator-definitions.scm index 541c176a4e..94d6b32037 100644 --- a/collects/srfi/42/generator-definitions.scm +++ b/collects/srfi/42/generator-definitions.scm @@ -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 ), got: " #'name)) - (unless (identifier? #'name) - (raise-syntax-error - 'define-generator "expected (define-generator ( name) ...), 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 ), 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 ) or (define-generator ( ) ... , 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 ), got: " #'name)) + (unless (identifier? #'name) + (raise-syntax-error + 'define-generator "expected (define-generator ( name) ...), 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 ), 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 ) or (define-generator ( ) ... , got: " stx)]))) \ No newline at end of file diff --git a/collects/srfi/42/generator-struct.scm b/collects/srfi/42/generator-struct.scm index 68f77e76b5..b104e80987 100644 --- a/collects/srfi/42/generator-struct.scm +++ b/collects/srfi/42/generator-struct.scm @@ -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))) \ No newline at end of file diff --git a/collects/srfi/42/generators.scm b/collects/srfi/42/generators.scm index 59945fbbfb..89f2c1034f 100644 --- a/collects/srfi/42/generators.scm +++ b/collects/srfi/42/generators.scm @@ -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 ...) or (:list (index ) 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 (index )) where (index ) 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 (index i) ...) 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 (index i) ...) 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 (index ) ) 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 (index i) ) where index is optional, and the 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 ) or (:let (index ) ), 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 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 ), 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) ...) ...) ( ...) (let ((in ie) ...) ...) ( ...)) - #'(_ (let-values (((on) oe) ...) ...) ( ...) (let-values ([(in) ie] ...) ...) ( ...))] - [(_ (let ((on oe) ...) ...) ( ...) ilet ( ...)) - #'(_ (let-values (((on) oe) ...) ...) ( ...) ilet ( ...))] - [(_ olet ( ...) (let ((in ie) ...) ...) ( ...)) - #'(_ olet ( ...) (let-values ([(in) ie] ...) ...) ( ...))] - - ; 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 (( ) ...) ...) or\n" - "(let-values ([( ...) ] ...) ...) , got ") - #'olet)]) - (syntax-case #'ilet (let-values) - [(let-values (((i ...) e) ...) ic ...) 'ok] - [_ (raise-syntax-error - ':do (string-append "expected (let (( ) ...) ...) or\n" - "(let-values ([( ...) ] ...) ...), 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 (( ) ...), got: " #'lbs)]) - (syntax-case #'lss () - [(expr ...) 'ok] - [_ (raise-syntax-error "expected loop steppers: ( ...), 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 (( ) ...) ...) (let (( ) ...) ...) ( ...)), 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 ) 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 ...) or (:list (index ) 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 (index )) where (index ) 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 (index i) ...) 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 (index i) ...) 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 (index ) ) 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 (index i) ) where index is optional, and the 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 ) or (:let (index ) ), 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 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 ), 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) ...) ...) ( ...) (let ((in ie) ...) ...) ( ...)) + #'(_ (let-values (((on) oe) ...) ...) ( ...) (let-values ([(in) ie] ...) ...) ( ...))] + [(_ (let ((on oe) ...) ...) ( ...) ilet ( ...)) + #'(_ (let-values (((on) oe) ...) ...) ( ...) ilet ( ...))] + [(_ olet ( ...) (let ((in ie) ...) ...) ( ...)) + #'(_ olet ( ...) (let-values ([(in) ie] ...) ...) ( ...))] + + ; 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 (( ) ...) ...) or\n" + "(let-values ([( ...) ] ...) ...) , got ") + #'olet)]) + (syntax-case #'ilet (let-values) + [(let-values (((i ...) e) ...) ic ...) 'ok] + [_ (raise-syntax-error + ':do (string-append "expected (let (( ) ...) ...) or\n" + "(let-values ([( ...) ] ...) ...), 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 (( ) ...), got: " #'lbs)]) + (syntax-case #'lss () + [(expr ...) 'ok] + [_ (raise-syntax-error "expected loop steppers: ( ...), 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 (( ) ...) ...) (let (( ) ...) ...) ( ...)), 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 ) got: " + form-stx)])) + ) \ No newline at end of file diff --git a/collects/srfi/42/loops.scm b/collects/srfi/42/loops.scm index 4ea042c7d7..aa6e93fa61 100644 --- a/collects/srfi/42/loops.scm +++ b/collects/srfi/42/loops.scm @@ -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 (*) ; outer bindings - * ; outer commands - (let loop (*) ; loop bindings - (if ; not end (stop-before) - (let (*) ; inner bindings - * ; inner commands - ; payload (from the comprehension) - (if ; not end (stop-after) - (loop *)))))) ; 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 (*) - (if - (loop *))) - - (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 (*) ; outer bindings + * ; outer commands + (let loop (*) ; loop bindings + (if ; not end (stop-before) + (let (*) ; inner bindings + * ; inner commands + ; payload (from the comprehension) + (if ; not end (stop-after) + (loop *)))))) ; 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 (*) + (if + (loop *))) + + (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 ...))))))))))])) + ) \ No newline at end of file diff --git a/collects/srfi/42/simplifier.scm b/collects/srfi/42/simplifier.scm index c2d1613a40..d948e5ac39 100644 --- a/collects/srfi/42/simplifier.scm +++ b/collects/srfi/42/simplifier.scm @@ -1,93 +1,93 @@ -;;; -;;; SIMPLIFIER -;;; - -(module simplifier mzscheme - (provide ec-simplify) - - ; (ec-simplify ) - ; generates potentially more efficient code for . - ; The macro handles if, (begin *), and (let () *) - ; 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 - ((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 )) - ((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 () *) - - ; empty * - #;((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 ) + ; generates potentially more efficient code for . + ; The macro handles if, (begin *), and (let () *) + ; 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 + ((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 )) + ((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 () *) + + ; empty * + #;((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 )))) \ No newline at end of file