diff --git a/scheme/ikarus.compiler.source-optimizer.ss b/scheme/ikarus.compiler.source-optimizer.ss
index 0138fc1..77f4785 100644
--- a/scheme/ikarus.compiler.source-optimizer.ss
+++ b/scheme/ikarus.compiler.source-optimizer.ss
@@ -1,8 +1,6 @@
 
 ;;; Work in progress
-(define (source-optimize x) x)
 
-#!eof
 
 
 ;;; Oscar Waddell. "Extending the Scope of Syntactic Abstraction". PhD.
@@ -10,18 +8,68 @@
 ;;; Available online: 
 ;;;   http://www.cs.indiana.edu/~owaddell/papers/thesis.ps.gz
 
-(module (source-optimize)
+(module (source-optimize optimize-level)
   (define who 'source-optimize)
-  (define-struct info (source-referenced source-assigned 
-                       residual-referenced residual-assigned))
+  ;;; this define-structure definition for compatibility with the
+  ;;; notation used in Oscar's thesis.
+  (define-syntax define-structure
+    (lambda (stx) 
+      (define (fmt ctxt)
+        (lambda (str . args) 
+          (datum->syntax ctxt 
+            (string->symbol 
+              (apply format str (map syntax->datum args))))))
+      (syntax-case stx ()
+        [(_ (name fields ...)) 
+         #'(define-struct name (fields ...))]
+        [(_ (name fields ...) ([others defaults] ...))
+         (with-syntax ([(pred maker (getters ...) (setters ...))
+                        (let ([fmt (fmt #'name)])
+                          (list (fmt "~s?" #'name)
+                                (fmt "make-~s" #'name)
+                                (map (lambda (x) (fmt "~s-~s" #'name x))
+                                     #'(fields ... others ...))
+                                (map (lambda (x) (fmt "set-~s-~s!" #'name x))
+                                     #'(fields ... others ...))))])
+           #'(module (name pred getters ... setters ... maker)
+               (module P (name pred getters ... setters ... maker)
+                 (define-struct name (fields ... others ...)))
+               (module (maker)
+                 (define (maker fields ...)
+                   (import P)
+                   (maker fields ... defaults ...)))
+               (module (name pred getters ... setters ...)
+                 (import P))))])))
+  ;;;
+  (define-structure (prelex name operand)
+    ([source-referenced?   #f]
+     [source-assigned?     #f]
+     [residual-referenced? #f]
+     [residual-assigned?   #f]))
+  ;;;
+  (define-structure (app rand* ctxt)
+    ([inlined #f]))
+  ;;;
+  (define-structure (operand expr env)
+    ([value                  #f]
+     [residualize-for-effect #f]))
+  ;;;
   (module (init-var! var-info)
-    (define (init-var! x) 
-      (set-var-index! x (make-info #f #f #f #f)))
+    (define (init-var! x)
+      (set-var-index! x (make-prelex #f #f)))
     (define (var-info x)
       (let ([v (var-index x)])
-        (if (info? v) 
+        (if (prelex? v)
             v
             (error 'var-info "not initialized" x)))))
+  (module (with-extended-env)
+    (define (extend e args rands) 
+      (error 'extend "not yet"))
+    (define-syntax with-extended-env
+      (syntax-rules ()
+        [(_ ((e2 args2) (e1 args1 rands)) b b* ...)
+         (let-values ([(e2 args2) (extend e1 args1 rands)])
+           b b* ...)])))
   ;;; purpose of prepare:
   ;;; 1. attach an info struct to every bound variable
   ;;; 2. set the plref and plset flags to indicate whether
@@ -39,14 +87,14 @@
     (define (E x) 
       (struct-case x 
         [(constant) (void)]
-        [(var) (set-info-source-refereced! (var-info x) #t)]
+        [(var) (set-prelex-source-referenced?! (var-info x) #t)]
         [(primref)  (void)]
         [(clambda)  (L x)]
         [(seq e0 e1) (E e0) (E e1)]
         [(conditional e0 e1 e2) 
          (E e0) (E e1) (E e2)]
         [(assign x val) 
-         (set-info-source-assigned! (var-info x) #t) 
+         (set-prelex-source-assigned?! (var-info x) #t)
          (E val)]
         [(bind lhs* rhs* body)
          (for-each E rhs*)
@@ -58,7 +106,7 @@
          (E body)
          (for-each ;;; sanity check
            (lambda (x)
-             (assert (not (info-source-assigned (var-info x))))) 
+             (assert (not (prelex-source-assigned? (var-info x))))) 
            lhs*)]
         [(funcall rator rand*) 
          (for-each E rand*)
@@ -68,6 +116,29 @@
         [else (error who "invalid expr in prepare" x)]))
     (E x))
   ;;; business
+  (define-syntax ctxt-case
+    (lambda (stx)
+      (define (test x)
+        (case (syntax->datum x)
+          [(p)   #'(eq? t 'p)]
+          [(v)   #'(eq? t 'v)]
+          [(e)   #'(eq? t 'e)]
+          [(app) #'(app? t)]
+          [else (syntax-violation stx "invalid ctxt" x)]))
+      (define (extract cls*)
+        (syntax-case cls* (else)
+          [([else e e* ...]) #'(begin e e* ...)]
+          [([(t* ...) e e* ...] rest ...) 
+           (with-syntax ([(t* ...) (map test #'(t* ...))]
+                         [body (extract #'(rest ...))])
+             #'(if (or t* ...) 
+                   (begin e e* ...)
+                   body))]))
+      (syntax-case stx ()
+        [(_ expr cls* ...)
+         (with-syntax ([body (extract #'(cls* ...))])
+           #'(let ([t expr])
+               body))])))
   (define (mkseq e0 e1)
     ;;; returns a (seq e0 e1) with a seq-less e1 if both 
     ;;; e0 and e1 are constructed properly.
@@ -88,13 +159,14 @@
       [(clambda)  #t]
       [else       #f]))
   ;;; result returns the "last" value of an expression
-  (define (result x)
+  (define (result-expr x)
     (struct-case x
       [(seq e0 e1) e1]
       [else        x]))
-  (define (records-equal? x y)
+  ;;;
+  (define (records-equal? x y ctxt)
     (struct-case x
-      [(constant kx) 
+      [(constant kx)
        (struct-case y
          [(constant ky)
           (ctxt-case ctxt
@@ -103,27 +175,105 @@
             [else (eq? kx ky)])]
          [else #f])]
       [else #f]))
-  (module (E-call)
+  ;;;
+  (module (E-call value-visit-operand!)
+    (define (residualize-operand x)
+      (or (operand-value x)
+          (E (operand-expr x) (operand-env x) 'e)))
     (define (residualize-operands e rand*)
       (cond
         [(null? rand*) e]
-        [(not (rand-residualize-for-effect (car rand*)))
+        [(not (operand-residualize-for-effect (car rand*)))
          (residualize-operands e (cdr rand*))]
         [else
-         (let ([e1 (process-rands-for-effect rand*)])
-           (mkseq e1 (residualize-operands e (cdr rand*))))])) 
+         (mkseq 
+           (residualize-operand (car rand*))
+           (residualize-operands e (cdr rand*)))]))
     (define (value-visit-operand! rand)
-      (or (rand-value rand) 
-          (let ([e (E (rand-expr rand) (rand-env rand) 'v)])
-            (set-rand-value! rand e)
+      (or (operand-value rand) 
+          (let ([e (E (operand-expr rand) (operand-env rand) 'v)])
+            (set-operand-value! rand e)
             e)))
     (define (E-call rator rand* env ctxt)
-      (let ([ctxt (make-app-ctxt rand* ctxt)])
+      (let ([ctxt (make-app rand* ctxt)])
         (let ([rator (E rator env ctxt)])
-          (if (app-inlined ctxt) 
-              (residualize-operand rator rand*)
+          (if (app-inlined ctxt)
+              (residualize-operands rator rand*)
               (make-funcall rator 
                 (map value-visit-operand! rand*)))))))
+  ;;;
+  (define (E-var x env ctxt)
+    (ctxt-case ctxt
+      [(e) (make-constant (void))]
+      [else 
+       (let ([x (lookup x env)])
+         (let ([opnd (prelex-operand x)])
+           (if opnd
+               (begin
+                 (value-visit-operand! opnd)
+                 (if (prelex-source-assigned? x) 
+                     (residualize-ref x)
+                     (copy x opnd ctxt)))
+               (residualize-ref x))))]))
+  ;;;
+  (define (copy x opnd ctxt)
+    (let ([rhs (result-expr (operand-value opnd))])
+      (struct-case rhs
+        [(constant) rhs]
+        [(var) 
+         (if (prelex-source-assigned? rhs)
+             (residualize-ref x)
+             (let ([opnd (prelex-operand rhs)])
+               (if (and opnd (operand-value opnd))
+                   (copy2 rhs opnd ctxt)
+                   (residualize-ref rhs))))]
+        [else (copy2 x opnd ctxt)])))
+  (define (copy2 x opnd ctxt)
+    (let ([rhs (result-expr (operand-value opnd))])
+      (struct-case rhs
+        [(clambda) 
+         (ctxt-case ctxt
+           [(v) (residualize-ref x)]
+           [(p) (make-constant #t)]
+           [(e) (make-constant (void))]
+           [(app) (inline rhs ctxt empty-env)]
+           [else (error 'copy2 "cannot happen")])]
+        [(primref p) 
+         (ctxt-case ctxt
+           [(v) rhs]
+           [(p) (make-constant #t)]
+           [(e) (make-constant (void))]
+           [(app) (fold-prim p ctxt)]
+           [else (error 'copy2 "cannot happen")])]
+        [else (residualize-ref x)])))
+  ;;;
+  (define (inline proc ctxt env)
+    (struct-case proc
+      [(clambda g cases cp free name)
+       (let ([rand* (app-rand* ctxt)])
+         (struct-case (get-case cases rand*)
+           [(clambda-case info body) 
+            (struct-case info
+              [(case-info label args proper) 
+               (with-extended-env ((env args) (env args rand*))
+                 (let ([body (E body (app-ctxt ctxt) env)])
+                   (let ([result (make-let-binding args rand* body)])
+                     (set-app-inlined! ctxt #t)
+                     result)))])]
+           [else proc]))]))
+  ;;;
+  (define (make-let-binding args rand* body) 
+    (error 'make-let-binding "not yet"))
+  (define (get-case . args)
+    (error 'get-case "not yet"))
+  ;;;
+  (define (fold-prim p ctxt)
+    (make-primref p))
+  ;;;
+  (define (residualize-ref x)
+    (set-prelex-residual-referenced?! (var-info x) #t)
+    x)
+  ;;;
   (define (E x env ctxt)
     (struct-case x
       [(constant) x]
@@ -132,7 +282,7 @@
        (mkseq (E e0 env 'e) (E e1 env ctxt))]
       [(conditional e0 e1 e2)
        (let ([e0 (E e0 env 'p)])
-         (struct-case (result e0)
+         (struct-case (result-expr e0)
            [(constant k) 
             (mkseq e0 (E (if k e1 e2) env ctxt))]
            [else 
@@ -146,23 +296,23 @@
        (mkseq
          (let ([xi (var-info x)])
            (cond
-             [(not (info-source-referenced xi))
+             [(not (prelex-source-referenced? xi))
               ;;; dead on arrival
               (E v env 'e)]
              [else
-              (set-info-residual-assigned! i #t)
+              (set-prelex-residual-assigned?! xi #t)
               (make-assign x (E v env 'v))]))
          (make-constant (void)))]
-      [(funcall rator rand*) 
-       (E-call rator (map (mkoperand env) rand*) env ctxt)]
+      [(funcall rator rand*)
+       (E-call rator (map (make-operand env) rand*) env ctxt)]
       [(primref name)
        (ctxt-case ctxt
-         [(app) (E-fold-prim name env ctxt)]
-         [(value) x]
+         [(app) (fold-prim env ctxt)]
+         [(v) x]
          [else (make-constant (void))])]
       [(clambda g cases cp free name) 
        (ctxt-case ctxt
-         [(app) (E-inline x env ctxt)]
+         [(app) (inline x env ctxt)]
          [(p e) (make-constant (void))]
          [else
           (make-clambda g
@@ -174,14 +324,26 @@
                      [(case-info label args proper) 
                       (with-extended-env ((env args) (env args #f))
                         (make-clambda-case 
-                          (make-info label args proper)
+                          (make-case-info label args proper)
                           (E body env 'v)))])]))
               cases)
             cp free name)])]
       [else (error who "invalid expression" x)]))
+  (define empty-env '())
+  (define (lookup . args)
+    (error 'lookup "not yet"))
+  (define optimize-level 
+    (make-parameter #f))
   (define (source-optimize expr)
-    (prepare expr)
-    (E expr 'v)))
+    (cond
+      [(equal? (optimize-level) 17)
+       (prepare expr)
+       (pretty-print (unparse expr))
+       (let ([expr (E expr empty-env 'v)])
+         (pretty-print (unparse expr))
+         expr)]
+      [else expr])))
+
 
 
 
diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss
index ce4cfda..6b23ede 100644
--- a/scheme/ikarus.compiler.ss
+++ b/scheme/ikarus.compiler.ss
@@ -15,7 +15,7 @@
 
 
 (library (ikarus.compiler)
-  (export compile-core-expr-to-port 
+  (export compile-core-expr-to-port optimize-level
           assembler-output scc-letrec optimize-cp
           current-primitive-locations eval-core)
   (import 
@@ -25,6 +25,7 @@
     (only (ikarus system $codes) $code->closure)
     (only (ikarus system $structs) $struct-ref $struct/rtd?)
     (except (ikarus)
+        optimize-level
         fasl-write scc-letrec optimize-cp
         compile-core-expr-to-port assembler-output
         current-primitive-locations eval-core)
diff --git a/scheme/last-revision b/scheme/last-revision
index 7a1ed49..56bf291 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1385
+1387
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 49a714f..cd76166 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -16,7 +16,8 @@
 
 ;;; vim:syntax=scheme
 (import (only (ikarus) import))
-(import (except (ikarus) assembler-output scc-letrec optimize-cp))
+(import (except (ikarus) 
+          optimize-level assembler-output scc-letrec optimize-cp))
 (import (ikarus.compiler))
 (import (except (psyntax system $bootstrap)
                 eval-core 
@@ -1395,6 +1396,7 @@
     [ellipsis-map ]
     [scc-letrec i]
     [optimize-cp i]
+    [optimize-level i]
   ))
 
 (define (macro-identifier? x)