diff --git a/lib/SRFI-1.ss b/lab/SRFI-1.ss similarity index 100% rename from lib/SRFI-1.ss rename to lab/SRFI-1.ss diff --git a/lib/SRFI-1.tests.ss b/lab/SRFI-1.tests.ss similarity index 100% rename from lib/SRFI-1.tests.ss rename to lab/SRFI-1.tests.ss diff --git a/lib/SRFI-2.ss b/lab/SRFI-2.ss similarity index 100% rename from lib/SRFI-2.ss rename to lab/SRFI-2.ss diff --git a/lib/SRFI-2.tests.ss b/lab/SRFI-2.tests.ss similarity index 100% rename from lib/SRFI-2.tests.ss rename to lab/SRFI-2.tests.ss diff --git a/lib/SRFI-6.ss b/lab/SRFI-6.ss similarity index 100% rename from lib/SRFI-6.ss rename to lab/SRFI-6.ss diff --git a/lib/SRFI-6.tests.ss b/lab/SRFI-6.tests.ss similarity index 100% rename from lib/SRFI-6.tests.ss rename to lab/SRFI-6.tests.ss diff --git a/lib/SRFI-8.ss b/lab/SRFI-8.ss similarity index 100% rename from lib/SRFI-8.ss rename to lab/SRFI-8.ss diff --git a/lib/SRFI-8.tests.ss b/lab/SRFI-8.tests.ss similarity index 100% rename from lib/SRFI-8.tests.ss rename to lab/SRFI-8.tests.ss diff --git a/lib/cgi-errors-to-browser.ss b/lab/cgi-errors-to-browser.ss similarity index 100% rename from lib/cgi-errors-to-browser.ss rename to lab/cgi-errors-to-browser.ss diff --git a/lib/cgi.ss b/lab/cgi.ss similarity index 100% rename from lib/cgi.ss rename to lab/cgi.ss diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index 0f83ac6..c483011 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -1136,6 +1136,7 @@ [(fix lhs* rhs* body) (known-value body)] [(seq e0 e1) (known-value e1)] [else #f])) + (define (same-values? x y) (cond [(constant? x) @@ -1174,7 +1175,9 @@ [(var-referenced lhs) (values (cons lhs lhs*) (cons rhs rhs*) eff*)] [else - (values lhs* rhs* (mk-seq eff* (Effect rhs)))])))])) + (values lhs* rhs* + (mk-seq eff* + (Effect rhs)))])))])) (define (partition/assign-known lhs* rhs*) (cond [(null? lhs*) (values '() '() the-void)] @@ -1225,50 +1228,53 @@ (make-clambda-case info (Value body))])) cls*) cp free name)) - (define (Effect x) - (struct-case x - [(constant) the-void] - [(var) the-void] - [(primref) the-void] - [(bind lhs* rhs* body) - (do-bind lhs* rhs* body Effect)] - [(fix lhs* rhs* body) - (do-fix lhs* rhs* body Effect)] - [(conditional e0 e1 e2) - (let ([e0 (Pred e0)]) - (cond - [(predicate-value e0) => - (lambda (v) - (mk-seq e0 (if (eq? v 't) (Effect e1) (Effect e2))))] - [else - (make-conditional e0 (Effect e1) (Effect e2))]))] - [(seq e0 e1) (mk-seq (Effect e0) (Effect e1))] - [(clambda g cls*) the-void] - [(primcall rator rand*) - (optimize-primcall 'e rator (map Value rand*))] - [(funcall rator rand*) - (let ([rator (Value rator)]) - (cond - [(known-value rator) => - (lambda (v) - (struct-case v - [(primref op) - (mk-seq rator - (optimize-primcall 'e op (map Value rand*)))] - [else - (make-funcall rator (map Value rand*))]))] - [else (make-funcall rator (map Value rand*))]))] - [(forcall rator rand*) - (make-forcall rator (map Value rand*))] - [(mvcall p c) - (mk-mvcall (Value p) (Value c))] - [(assign lhs rhs) - (unless (var-assigned lhs) - (error who "var is not assigned" lhs)) - (if (var-referenced lhs) - (make-assign lhs (Value rhs)) - (Effect rhs))] - [else (error who "invalid effect expression" (unparse x))])) + (define (MKEffect ctxt) + (define (Effect x) + (struct-case x + [(constant) the-void] + [(var) the-void] + [(primref) the-void] + [(bind lhs* rhs* body) + (do-bind lhs* rhs* body Effect)] + [(fix lhs* rhs* body) + (do-fix lhs* rhs* body Effect)] + [(conditional e0 e1 e2) + (let ([e0 (Pred e0)]) + (cond + [(predicate-value e0) => + (lambda (v) + (mk-seq e0 (if (eq? v 't) (Effect e1) (Effect e2))))] + [else + (make-conditional e0 (Effect e1) (Effect e2))]))] + [(seq e0 e1) (mk-seq (Effect e0) (Effect e1))] + [(clambda g cls*) the-void] + [(primcall rator rand*) + (optimize-primcall ctxt rator (map Value rand*))] + [(funcall rator rand*) + (let ([rator (Value rator)]) + (cond + [(known-value rator) => + (lambda (v) + (struct-case v + [(primref op) + (mk-seq rator + (optimize-primcall ctxt op (map Value rand*)))] + [else + (make-funcall rator (map Value rand*))]))] + [else (make-funcall rator (map Value rand*))]))] + [(forcall rator rand*) + (make-forcall rator (map Value rand*))] + [(mvcall p c) + (mk-mvcall (Value p) (Value c))] + [(assign lhs rhs) + (unless (var-assigned lhs) + (error who "var is not assigned" lhs)) + (if (var-referenced lhs) + (make-assign lhs (Value rhs)) + (Effect rhs))] + [else (error who "invalid effect expression" (unparse x))])) + Effect) + (define Effect (MKEffect 'e)) (define (Pred x) (struct-case x [(constant) x] diff --git a/scheme/last-revision b/scheme/last-revision index 691cbe1..7784c89 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1151 +1153