>From 95dbd419ed6753fbcadb3f4c1b9b4fdd5287a7a6 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Sat, 16 Aug 2014 17:02:01 +0200
Subject: [PATCH 10/19] compiler-modules: Simplify compiler module import
 forms

Prefix the get, get-all, get-list and put! procedures with "db-".
This prevents confusion with the 2-argument "get" and "put!" versions
from library.scm, and it also cleans up the chicken module import.

Remove syntax-error from exclusion list: The module system merely
aliases identifiers, so it doesn't need any special handling in order
to prevent compiler modules from including the "wrong" syntax-error
procedure.  Add a test for the aliasing behaviour of the module
system.

The debugging-chicken variable is used in a similar fashion: it is
defined in and exported by support, and it is set! in batch-driver.
It is read by both support and compiler.
---
 batch-driver.scm       |    7 +-
 c-backend.scm          |    3 +-
 c-platform.scm         |   37 +++++----
 compiler-namespace.scm |    1 -
 compiler-syntax.scm    |    2 +-
 compiler.scm           |  180 +++++++++++++++++++++--------------------
 lfa2.scm               |    6 +-
 optimizer.scm          |  211 ++++++++++++++++++++++++------------------------
 scrutinizer.scm        |   23 +++---
 support.scm            |  101 ++++++++++++-----------
 tests/module-tests.scm |   42 ++++++++++
 11 files changed, 325 insertions(+), 288 deletions(-)

diff --git a/batch-driver.scm b/batch-driver.scm
index be286f9..b71d016 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -43,8 +43,7 @@
      user-options-pass user-read-pass user-preprocessor-pass user-pass
      user-post-analysis-pass)
 
-(import (except chicken put! get syntax-error) scheme
-	extras data-structures files srfi-1
+(import chicken scheme extras data-structures files srfi-1
 	support lfa2 compiler-syntax optimizer scrutinizer c-platform c-backend)
 
 (include "tweaks")
@@ -177,8 +176,8 @@
         (let ((db (analyze-expression node)))
 	  (when upap
 	    (upap pass db node
-		  (cut get db <> <>)
-		  (cut put! db <> <> <>)
+		  (cut db-get db <> <>)
+		  (cut db-put! db <> <> <>)
 		  no contf) )
 	  db) ) )
 
diff --git a/c-backend.scm b/c-backend.scm
index 6d1131d..f91077b 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -42,8 +42,7 @@
      ;; For "foreign" (aka chicken-ffi-syntax):
      foreign-type-declaration)
 
-(import (except chicken put! get syntax-error) scheme foreign
-	srfi-1 data-structures
+(import chicken scheme foreign srfi-1 data-structures
 	c-platform support)
 
 ;;; Write atoms to output-port:
diff --git a/c-platform.scm b/c-platform.scm
index 50967db..bde46db 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -46,8 +46,7 @@
      target-include-file words-per-flonum
      parameter-limit small-parameter-limit)
 
-(import (except chicken put! get syntax-error) scheme
-	srfi-1 data-structures
+(import chicken scheme srfi-1 data-structures
 	optimizer support)
 
 (include "tweaks")
@@ -489,22 +488,22 @@
        (and (= (length callargs) 1)
 	    (call-with-current-continuation
 	     (lambda (return)
-	       (let ([arg (first callargs)])
+	       (let ((arg (first callargs)))
 		 (make-node
 		  '##core#call (list #t)
 		  (list
 		   cont
-		   (cond [(and (eq? '##core#variable (node-class arg))
-			       (eq? 'vector (get db (first (node-parameters arg)) 'rest-parameter)) )
+		   (cond ((and (eq? '##core#variable (node-class arg))
+			       (eq? 'vector (db-get db (first (node-parameters arg)) 'rest-parameter)) )
 			  (make-node
 			   '##core#inline 
 			   (if unsafe
 			       '("C_slot")
 			       '("C_i_vector_ref") )
-			   (list arg (qnode index)) ) ]
-			 [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)]
-			 [iop1 (make-node '##core#inline (list iop1) callargs)]
-			 [else (return #f)] ) ) ) ) ) ) ) ) ) )
+			   (list arg (qnode index)) ) )
+			 ((and unsafe iop2) (make-node '##core#inline (list iop2) callargs))
+			 (iop1 (make-node '##core#inline (list iop1) callargs))
+			 (else (return #f)) ) ) ) ) ) ) ) ) ) )
 
   (rewrite-c..r 'car "C_i_car" "C_u_i_car" 0)
   (rewrite-c..r '##sys#car "C_i_car" "C_u_i_car" 0)
@@ -535,7 +534,7 @@
 	  (and (eq? '##core#variable (node-class arg1))	; probably not needed
 	       (eq? '##core#variable (node-class arg2))
 	       (and-let* ((sym (car (node-parameters arg2)))
-			  (val (get db sym 'value)) )
+			  (val (db-get db sym 'value)) )
 		 (and (eq? '##core#lambda (node-class val))
 		      (let ((llist (third (node-parameters val))))
 			(and (proper-list? llist)
@@ -1085,19 +1084,19 @@
   (define (rewrite-call/cc db classargs cont callargs)
     ;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f)
     (and (= 1 (length callargs))
-	 (let ([val (first callargs)])
+	 (let ((val (first callargs)))
 	   (and (eq? '##core#variable (node-class val))
-		(and-let* ([proc (get db (first (node-parameters val)) 'value)]
-			   [(eq? '##core#lambda (node-class proc))] )
-		  (let ([llist (third (node-parameters proc))])
+		(and-let* ((proc (db-get db (first (node-parameters val)) 'value))
+			   ((eq? '##core#lambda (node-class proc))) )
+		  (let ((llist (third (node-parameters proc))))
 		    (##sys#decompose-lambda-list 
 		     llist
 		     (lambda (vars argc rest)
 		       (and (= argc 2)
-			    (let ([var (or rest (second llist))])
-			      (and (not (get db var 'references))
-				   (not (get db var 'assigned)) 
-				   (not (get db var 'inline-transient))
+			    (let ((var (or rest (second llist))))
+			      (and (not (db-get db var 'references))
+				   (not (db-get db var 'assigned)) 
+				   (not (db-get db var 'inline-transient))
 				   (make-node
 				    '##core#call (list #t)
 				    (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )
@@ -1161,7 +1160,7 @@
 	   '##core#call (list #t) 
 	   (list cont
 		 (if (and (eq? '##core#variable (node-class arg))
-			  (not (get db (car (node-parameters arg)) 'global)) )
+			  (not (db-get db (car (node-parameters arg)) 'global)) )
 		     (qnode #t)
 		     (make-node 
 		      '##core#inline '("C_anyp")
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 2a6a0fc..c0210b8 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -47,7 +47,6 @@
  debug-info-vector-name
  debug-lambda-list
  debug-variable-list
- debugging-chicken
  debugging-executable
  default-default-target-heap-size
  default-extended-bindings
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 7c42bf2..e55ec5f 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -36,7 +36,7 @@
 (module compiler-syntax
     (compiler-syntax-statistics)
 
-(import (except chicken put! get syntax-error) scheme srfi-1 data-structures
+(import chicken scheme srfi-1 data-structures
 	support)
 
 (include "tweaks.scm")
diff --git a/compiler.scm b/compiler.scm
index ce31f96..8c1013e 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1860,9 +1860,9 @@
 	     (unless (memq var localenv)
 	       (grow 1)
 	       (cond ((memq var env) 
-		      (put! db var 'captured #t))
-		     ((not (get db var 'global)) 
-		      (put! db var 'global #t) ) ) ) ) )
+		      (db-put! db var 'captured #t))
+		     ((not (db-get db var 'global)) 
+		      (db-put! db var 'global #t) ) ) ) ) )
 	  
 	  ((##core#callunit ##core#recurse)
 	   (grow 1)
@@ -1884,7 +1884,7 @@
 		   (walk (car vals) env (append params localenv) env2 here #f)
 		   (let ([var (car vars)]
 			 [val (car vals)] )
-		     (put! db var 'home here)
+		     (db-put! db var 'home here)
 		     (assign var val env2 here)
 		     (walk val env localenv fullenv here #f) 
 		     (loop (cdr vars) (cdr vals)) ) ) ) ) )
@@ -1895,7 +1895,7 @@
 	    (first params)
 	    (lambda (vars argc rest)
 	      (for-each 
-	       (lambda (var) (put! db var 'unknown #t))
+	       (lambda (var) (db-put! db var 'unknown #t))
 	       vars)
 	      (let ([tl toplevel-scope])
 		(set! toplevel-scope #f)
@@ -1911,15 +1911,15 @@
 		    [size0 current-program-size] )
 		(when here
 		  (collect! db here 'contains id)
-		  (put! db id 'contained-in here) )
+		  (db-put! db id 'contained-in here) )
 		(for-each 
 		 (lambda (var)
-		   (put! db var 'home here)
-		   (put! db var 'unknown #t) )
+		   (db-put! db var 'home here)
+		   (db-put! db var 'unknown #t) )
 		 vars)
 		(when rest
-		  (put! db rest 'rest-parameter 'list) )
-		(when (simple-lambda-node? n) (put! db id 'simple #t))
+		  (db-put! db rest 'rest-parameter 'list) )
+		(when (simple-lambda-node? n) (db-put! db id 'simple #t))
 		(let ([tl toplevel-scope])
 		  (unless toplevel-lambda-id (set! toplevel-lambda-id id))
 		  (when (and (second params) (not (eq? toplevel-lambda-id id)))
@@ -1938,16 +1938,16 @@
 		  (warning "redefinition of standard binding" var) )
 		 ((extended)
 		  (warning "redefinition of extended binding" var) ) ))
-	     (put! db var 'potential-value val)
+	     (db-put! db var 'potential-value val)
 	     (unless (memq var localenv)
 	       (grow 1)
 	       (cond ((memq var env) 
-		      (put! db var 'captured #t))
-		     ((not (get db var 'global)) 
-		      (put! db var 'global #t) ) ) )
+		      (db-put! db var 'captured #t))
+		     ((not (db-get db var 'global)) 
+		      (db-put! db var 'global #t) ) ) )
 	     (assign var val fullenv here)
-	     (unless toplevel-scope (put! db var 'assigned-locally #t))
-	     (put! db var 'assigned #t)
+	     (unless toplevel-scope (db-put! db var 'assigned-locally #t))
+	     (db-put! db var 'assigned #t)
 	     (walk (car subs) env localenv fullenv here #f) ) )
 
 	  ((##core#primitive ##core#inline)
@@ -1963,30 +1963,30 @@
 
     (define (assign var val env here)
       (cond ((eq? '##core#undefined (node-class val))
-	     (put! db var 'undefined #t) )
+	     (db-put! db var 'undefined #t) )
 	    ((and (eq? '##core#variable (node-class val)) ; assignment to itself
 		  (eq? var (first (node-parameters val))) ) )
 	    ((or (memq var env)
 		 (variable-mark var '##compiler#constant)
 		 (not (variable-visible? var)))
-	     (let ((props (get-all db var 'unknown 'value))
-		   (home (get db var 'home)) )
+	     (let ((props (db-get-all db var 'unknown 'value))
+		   (home (db-get db var 'home)) )
 	       (unless (assq 'unknown props)
 		 (if (assq 'value props)
-		     (put! db var 'unknown #t)
+		     (db-put! db var 'unknown #t)
 		     (if (or (not home) (eq? here home))
-			 (put! db var 'value val)
-			 (put! db var 'unknown #t) ) ) ) ) )
+			 (db-put! db var 'value val)
+			 (db-put! db var 'unknown #t) ) ) ) ) )
 	    ((and (or local-definitions
 		      (variable-mark var '##compiler#local))
-		  (not (get db var 'unknown)))
-	     (let ((home (get db var 'home)))
-	       (cond ((get db var 'local-value)
-		      (put! db var 'unknown #t))
+		  (not (db-get db var 'unknown)))
+	     (let ((home (db-get db var 'home)))
+	       (cond ((db-get db var 'local-value)
+		      (db-put! db var 'unknown #t))
 		     ((or (not home) (eq? here home))
-		      (put! db var 'local-value val)	       )
-		     (else (put! db var 'unknown #t)))))
-	    (else (put! db var 'unknown #t)) ) )
+		      (db-put! db var 'local-value val)	       )
+		     (else (db-put! db var 'unknown #t)))))
+	    (else (db-put! db var 'unknown #t)) ) )
     
     (define (ref var node)
       (collect! db var 'references node) )
@@ -2078,7 +2078,7 @@
 		  (when (and (eq? '##core#lambda (node-class value))
 			     (or (not (second valparams))
 				 (every 
-				  (lambda (v) (get db v 'global))
+				  (lambda (v) (db-get db v 'global))
 				  (nth-value 0 (scan-free-variables value)) ) ) )
 		    (if (and (= 1 nreferences) (= 1 ncall-sites))
 			(quick-put! plist 'contractable #t)
@@ -2088,12 +2088,12 @@
 		(let ((valparams (node-parameters local-value)))
 		  (when (eq? '##core#lambda (node-class local-value))
 		    (let-values (((vars hvars) (scan-free-variables local-value)))
-		      (when (and (get db sym 'global)
+		      (when (and (db-get db sym 'global)
 				 (pair? hvars))
 			(quick-put! plist 'hidden-refs #t))
 		      (when (or (not (second valparams))
 				(every 
-				 (lambda (v) (get db v 'global)) 
+				 (lambda (v) (db-get db v 'global)) 
 				 vars))
 			(quick-put! plist 'inlinable #t) ) ) ) ) )
 	       ((variable-mark sym '##compiler#inline-global) =>
@@ -2127,10 +2127,10 @@
 	 ;;  - if the procedure is internal (a continuation) do NOT mark unused parameters.
 	 ;;  - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest.
 	 (when value
-	   (let ([has #f])
+	   (let ((has #f))
 	     (when (and (eq? '##core#lambda (node-class value))
 			(= nreferences ncall-sites) )
-	       (let ([lparams (node-parameters value)])
+	       (let ((lparams (node-parameters value)))
 		 (when (second lparams)
 		   (##sys#decompose-lambda-list
 		    (third lparams)
@@ -2138,17 +2138,17 @@
 		      (unless rest
 			(for-each
 			 (lambda (var)
-			   (cond [(and (not (get db var 'references))
-				       (not (get db var 'assigned)) )
-				  (put! db var 'unused #t)
+			   (cond ((and (not (db-get db var 'references))
+				       (not (db-get db var 'assigned)) )
+				  (db-put! db var 'unused #t)
 				  (set! has #t)
-				  #t]
-				 [else #f] ) )
+				  #t)
+				 (else #f) ) )
 			 vars) )
-		      (cond [(and has (not (rassoc sym callback-names eq?)))
-			     (put! db (first lparams) 'has-unused-parameters #t) ]
-			    [rest
-			     (put! db (first lparams) 'explicit-rest #t) ] ) ) ) ) ) ) ) )
+		      (cond ((and has (not (rassoc sym callback-names eq?)))
+			     (db-put! db (first lparams) 'has-unused-parameters #t) )
+			    (rest
+			     (db-put! db (first lparams) 'explicit-rest #t) ) ) ) ) ) ) ) ) )
 
 	 ;; Make 'removable, if it has no references and is not assigned to, and if it 
 	 ;; has either a value that does not cause any side-effects or if it is 'undefined:
@@ -2157,7 +2157,7 @@
 		    (or (and value
 			     (if (eq? '##core#variable (node-class value))
 				 (let ((varname (first (node-parameters value))))
-				   (or (not (get db varname 'global))
+				   (or (not (db-get db varname 'global))
 				       (variable-mark varname '##core#always-bound)
 				       (intrinsic? varname)))
 				 (not (expression-has-side-effects? value db)) ))
@@ -2173,40 +2173,41 @@
 	 ;;    it was contracted).
 	 (when (and value (not global))
 	   (when (eq? '##core#variable (node-class value))
-	     (let* ([name (first (node-parameters value))]
-		    [nrefs (get db name 'references)] )
+	     (let* ((name (first (node-parameters value)))
+		    (nrefs (db-get db name 'references)) )
 	       (when (and (not captured)
-			  (or (and (not (get db name 'unknown)) (get db name 'value))
-			      (and (not (get db name 'captured))
+			  (or (and (not (db-get db name 'unknown))
+				   (db-get db name 'value))
+			      (and (not (db-get db name 'captured))
 				   nrefs
 				   (= 1 (length nrefs))
 				   (not assigned)
-				   (not (get db name 'assigned)) 
+				   (not (db-get db name 'assigned)) 
 				   (or (not (variable-visible? name))
-				       (not (get db name 'global))) ) ))
+				       (not (db-get db name 'global))) ) ))
 		 (quick-put! plist 'replacable name) 
-		 (put! db name 'replacing #t) ) ) ) )
+		 (db-put! db name 'replacing #t) ) ) ) )
 
 	 ;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and
 	 ;;  is an internally created procedure: (See above for 'replacing)
 	 (when (and value (eq? '##core#lambda (node-class value)))
-	   (let ([params (node-parameters value)])
+	   (let ((params (node-parameters value)))
 	     (when (not (second params))
-	       (let ([llist (third params)]
-		     [body (first (node-subexpressions value))] )
+	       (let ((llist (third params))
+		     (body (first (node-subexpressions value))) )
 		 (when (and (pair? llist) 
 			    (null? (cdr llist))
 			    (eq? '##core#call (node-class body)) )
-		   (let ([subs (node-subexpressions body)])
+		   (let ((subs (node-subexpressions body)))
 		     (when (= 2 (length subs))
-		       (let ([v1 (first subs)]
-			     [v2 (second subs)] )
+		       (let ((v1 (first subs))
+			     (v2 (second subs)) )
 			 (when (and (eq? '##core#variable (node-class v1))
 				    (eq? '##core#variable (node-class v2))
 				    (eq? (first llist) (first (node-parameters v2))) )
-			   (let ([kvar (first (node-parameters v1))])
+			   (let ((kvar (first (node-parameters v1))))
 			     (quick-put! plist 'replacable kvar)
-			     (put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) ) ) )
+			     (db-put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) ) ) )
 
      db)
 
@@ -2228,11 +2229,11 @@
 	(customizable '())
 	(lexicals '()))
 
-    (define (test sym item) (get db sym item))
+    (define (test sym item) (db-get db sym item))
   
     (define (register-customizable! var id)
       (set! customizable (lset-adjoin eq? customizable var)) 
-      (put! db id 'customizable #t) )
+      (db-put! db id 'customizable #t) )
 
     (define (register-direct-call! id)
       (set! direct-calls (add1 direct-calls))
@@ -2320,8 +2321,8 @@
 	      (let ((id (if here (first params) 'toplevel)))
 		(fluid-let ((lexicals (append locals lexicals)))
 		  (let ((c (delete-duplicates (gather (first subs) id vars) eq?)))
-		    (put! db id 'closure-size (length c))
-		    (put! db id 'captured-variables c)
+		    (db-put! db id 'closure-size (length c))
+		    (db-put! db id 'captured-variables c)
 		    (lset-difference eq? c locals vars)))))))
 	
 	  (else (concatenate (map (lambda (n) (gather n here locals)) subs)) ) ) ))
@@ -2366,24 +2367,24 @@
 		  (maptransform subs here closure) ) ) ) )
 
 	  ((##core#lambda ##core#direct_lambda)
-	   (let ([llist (third params)])
+	   (let ((llist (third params)))
 	     (##sys#decompose-lambda-list
 	      llist
 	      (lambda (vars argc rest)
-		(let* ([boxedvars (filter (lambda (v) (test v 'boxed)) vars)]
-		       [boxedaliases (map cons boxedvars (map gensym boxedvars))]
-		       [cvar (gensym 'c)]
-		       [id (if here (first params) 'toplevel)]
-		       [capturedvars (or (test id 'captured-variables) '())]
-		       [csize (or (test id 'closure-size) 0)] 
-		       [info (and emit-closure-info (second params) (pair? llist))] )
+		(let* ((boxedvars (filter (lambda (v) (test v 'boxed)) vars))
+		       (boxedaliases (map cons boxedvars (map gensym boxedvars)))
+		       (cvar (gensym 'c))
+		       (id (if here (first params) 'toplevel))
+		       (capturedvars (or (test id 'captured-variables) '()))
+		       (csize (or (test id 'closure-size) 0)) 
+		       (info (and emit-closure-info (second params) (pair? llist))) )
 		  ;; If rest-parameter is boxed: mark it as 'boxed-rest
 		  ;;  (if we don't do this than preparation will think the (boxed) alias
 		  ;;  of the rest-parameter is never used)
-		  (and-let* ([rest]
-			     [(test rest 'boxed)]
-			     [rp (test rest 'rest-parameter)] )
-		    (put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
+		  (and-let* ((rest)
+			     ((test rest 'boxed))
+			     (rp (test rest 'rest-parameter)) )
+		    (db-put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
 		  (make-node
 		   '##core#closure (list (+ csize (if info 2 1)))
 		   (cons
@@ -2540,7 +2541,7 @@
 		       unsafe
 		       (variable-mark var '##compiler#always-bound)
 		       (intrinsic? var))]
-	     [blockvar (and (get db var 'assigned)
+	     [blockvar (and (db-get db var 'assigned)
 			    (not (variable-visible? var)))])
 	(when blockvar (set! fastrefs (add1 fastrefs)))
 	(make-node
@@ -2615,23 +2616,24 @@
 	     (##sys#decompose-lambda-list
 	      (third params)
 	      (lambda (vars argc rest)
-		(let* ([id (first params)]
-		       [rest-mode
+		(let* ((id (first params))
+		       (rest-mode
 			(and rest
-			     (let ([rrefs (get db rest 'references)])
-			       (cond [(get db rest 'assigned) 'list]
-				     [(and (not (get db rest 'boxed-rest)) (or (not rrefs) (null? rrefs))) 'none] 
-				     [else (get db rest 'rest-parameter)] ) ) ) ]
-		       [body (walk 
+			     (let ((rrefs (db-get db rest 'references)))
+			       (cond ((db-get db rest 'assigned) 'list)
+				     ((and (not (db-get db rest 'boxed-rest))
+					   (or (not rrefs) (null? rrefs))) 'none) 
+				     (else (db-get db rest 'rest-parameter)) ) ) ) )
+		       (body (walk 
 			      (car subs)
 			      (##sys#fast-reverse (if (eq? 'none rest-mode)
-                                                      (butlast vars)
-                                                      vars))
-                              (if (eq? 'none rest-mode)
+						      (butlast vars)
+						      vars))
+			      (if (eq? 'none rest-mode)
 				  (fx- (length vars) 1)
 				  (length vars))
 			      id
-			      '()) ] )
+			      '()) ) )
 		  (when (eq? rest-mode 'none)
 		    (debugging 'o "unused rest argument" rest id))
 		  (when (and direct rest)
@@ -2650,13 +2652,13 @@
                     signatures
                     allocated
                     (or direct (memq id direct-call-ids))
-                    (or (get db id 'closure-size) 0)
+                    (or (db-get db id 'closure-size) 0)
                     (and (not rest)
                          (> looping 0)
                          (begin
                            (debugging 'o "identified direct recursive calls" id looping)
                            #t) )
-                    (or direct (get db id 'customizable))
+                    (or direct (db-get db id 'customizable))
                     rest-mode
                     body
                     direct) )
diff --git a/lfa2.scm b/lfa2.scm
index 3e58989..386fd16 100644
--- a/lfa2.scm
+++ b/lfa2.scm
@@ -44,7 +44,7 @@
 (module lfa2
     (perform-secondary-flow-analysis)
 
-(import (except chicken put! get syntax-error) scheme srfi-1
+(import chicken scheme srfi-1
 	support)
 
 (include "tweaks")
@@ -191,14 +191,14 @@
 	    (else (set! stats (alist-cons elim 1 stats)))))
  
     (define (assigned? var)
-      (get db var 'assigned))
+      (db-get db var 'assigned))
 
     (define (droppable? n)
       (or (memq (node-class n) 
 		'(quote ##core#undefined ##core#primitive ##core#lambda))
 	  (and (eq? '##core#variable (node-class n))
 	       (let ((var (first (node-parameters n))))
-		 (or (not (get db var 'global))
+		 (or (not (db-get db var 'global))
 		     (variable-mark var '##compiler#always-bound))))))
 
     (define (drop! n)
diff --git a/optimizer.scm b/optimizer.scm
index 1b54c51..c4aa8f3 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -40,8 +40,7 @@
      eq-inline-operator membership-test-operators membership-unfold-limit
      default-optimization-passes rewrite)
 
-(import (except chicken put! get syntax-error) scheme
-	srfi-1 data-structures
+(import chicken scheme srfi-1 data-structures
 	support)
 
 (include "tweaks")
@@ -150,14 +149,14 @@
 (define simplified-ops '())
 
 (define (perform-high-level-optimizations node db)
-  (let ([removed-lets 0]
-	[removed-ifs 0]
-	[replaced-vars 0]
-	[rest-consers '()]
-	[simplified-classes '()]
-	[dirty #f] )
-
-    (define (test sym item) (get db sym item))
+  (let ((removed-lets 0)
+	(removed-ifs 0)
+	(replaced-vars 0)
+	(rest-consers '())
+	(simplified-classes '())
+	(dirty #f) )
+
+    (define (test sym item) (db-get db sym item))
     (define (constant-node? n) (eq? 'quote (node-class n)))
     (define (node-value n) (first (node-parameters n)))
     (define (touch) (set! dirty #t))
@@ -234,7 +233,7 @@
              (lambda (rvar)
                (let ((final-var (replace-var rvar)))
                  ;; Store intermediate vars to avoid recurring same chain again
-                 (put! db var 'replacable final-var)
+                 (db-put! db var 'replacable final-var)
                  final-var)))
             (else var)))
     
@@ -341,7 +340,7 @@
 			   (check-signature var args llist)
 			   (debugging 'o "contracted procedure" info)
 			   (touch)
-			   (for-each (cut put! db <> 'inline-target #t) fids)
+			   (for-each (cut db-put! db <> 'inline-target #t) fids)
 			   (walk
 			    (inline-lambda-bindings
 			     llist args (first (node-subexpressions lval)) #f db
@@ -393,7 +392,7 @@
 					    "global inlining" 	
 					    "inlining")
 					info ifid (fourth lparams))
-				       (for-each (cut put! db <> 'inline-target #t) fids)
+				       (for-each (cut db-put! db <> 'inline-target #t) fids)
 				       (check-signature var args llist)
 				       (debugging 'o "inlining procedure" info)
 				       (call/cc
@@ -569,7 +568,7 @@
 	(removed-nots 0) )
 
     (define (touch) (set! dirty #t) #t)
-    (define (test sym prop) (get db sym prop))
+    (define (test sym prop) (db-get db sym prop))
 
     (debugging 'p "pre-optimization phase...")
 
@@ -581,7 +580,7 @@
 		  (subs (node-subexpressions n))
 		  (kont (first (node-parameters (second subs))))
 		  (lnode (and (not (test kont 'unknown)) (test kont 'value)))
-		  (krefs (get-list db kont 'references)) )
+		  (krefs (db-get-list db kont 'references)) )
 	     ;; Call-site has one argument and a known continuation (which is a ##core#lambda)
 	     ;;  that has only one use:
 	     (when (and lnode krefs (= 1 (length krefs)) (= 3 (length subs))
@@ -592,7 +591,7 @@
 		 ;; Continuation has one parameter?
 		 (if (and (proper-list? llist) (null? (cdr llist)))
 		     (let* ((var (car llist))
-			    (refs (get-list db var 'references)) )
+			    (refs (db-get-list db var 'references)) )
 		       ;; Parameter is only used once?
 		       (if (and refs (= 1 (length refs)) (eq? 'if (node-class body)))
 			   ;; Continuation contains an 'if' node?
@@ -662,8 +661,8 @@
       (and (equal? op (eq-inline-operator))
 	   (immediate? const1)
 	   (immediate? const2)
-	   (= 1 (length (get-list db var1 'references)))
-	   (= 1 (length (get-list db var2 'references)))
+	   (= 1 (length (db-get-list db var1 'references)))
+	   (= 1 (length (db-get-list db var2 'references)))
 	   (make-node
 	    '##core#switch
 	    '(2)
@@ -688,7 +687,7 @@
    ,(lambda (db var op var0 const d body n clauses)
       (and (equal? op (eq-inline-operator))
 	   (immediate? const)
-	   (= 1 (length (get-list db var 'references)))
+	   (= 1 (length (db-get-list db var 'references)))
 	   (make-node
 	    '##core#switch
 	    (list (add1 n))
@@ -710,46 +709,46 @@
 	more)
    (var1 more)
    ,(lambda (db var1 more)
-      (let loop1 ([vars (list var1)] 
-		  [body more] )
-	(let ([c (node-class body)]
-	      [params (node-parameters body)] 
-	      [subs (node-subexpressions body)] )
+      (let loop1 ((vars (list var1)) 
+		  (body more) )
+	(let ((c (node-class body))
+	      (params (node-parameters body)) 
+	      (subs (node-subexpressions body)) )
 	  (and (eq? c 'let)
 	       (null? (cdr params))
-               (not (get db (first params) 'inline-transient))
-               (not (get db (first params) 'references))
-	       (let* ([val (first subs)]
-		      [valparams (node-parameters val)]
-		      [valsubs (node-subexpressions val)] )
+               (not (db-get db (first params) 'inline-transient))
+               (not (db-get db (first params) 'references))
+	       (let* ((val (first subs))
+		      (valparams (node-parameters val))
+		      (valsubs (node-subexpressions val)) )
 		 (case (node-class val)
-		   [(##core#undefined) (loop1 (cons (first params) vars) (second subs))]
-		   [(set!)
-		    (let ([allvars (reverse vars)])
+		   ((##core#undefined) (loop1 (cons (first params) vars) (second subs)))
+		   ((set!)
+		    (let ((allvars (reverse vars)))
 		      (and (pair? allvars)
 			   (eq? (first valparams) (first allvars))
-			   (let loop2 ([vals (list (first valsubs))]
-				       [vars (cdr allvars)] 
-				       [body (second subs)] )
-			     (let ([c (node-class body)]
-				   [params (node-parameters body)]
-				   [subs (node-subexpressions body)] )
-			       (cond [(and (eq? c 'let)
+			   (let loop2 ((vals (list (first valsubs)))
+				       (vars (cdr allvars)) 
+				       (body (second subs)) )
+			     (let ((c (node-class body))
+				   (params (node-parameters body))
+				   (subs (node-subexpressions body)) )
+			       (cond ((and (eq? c 'let)
 					   (null? (cdr params))
-					   (not (get db (first params) 'inline-transient))
-					   (not (get db (first params) 'references))
+					   (not (db-get db (first params) 'inline-transient))
+					   (not (db-get db (first params) 'references))
 					   (pair? vars)
 					   (eq? 'set! (node-class (first subs)))
 					   (eq? (car vars) (first (node-parameters (first subs)))) )
 				      (loop2 (cons (first (node-subexpressions (first subs))) vals)
 					     (cdr vars)
-					     (second subs) ) ]
-				     [(null? vars)
+					     (second subs) ) )
+				     ((null? vars)
 				      (receive (n progress) 
 					  (reorganize-recursive-bindings allvars (reverse vals) body) 
-					(and progress n) ) ]
-				     [else #f] ) ) ) ) ) ]
-		   [else #f] ) ) ) ) ) ) )
+					(and progress n) ) )
+				     (else #f) ) ) ) ) ) )
+		   (else #f) ) ) ) ) ) ) )
 
  ;; (let ((<var1> <var2>))
  ;;   (<var1> ...) )
@@ -760,7 +759,7 @@
 	(##core#call p (##core#variable (var1)) . more) ) ; `p' was `#t', bombed also
    (var1 var2 p more)
    ,(lambda (db var1 var2 p more)
-      (and (= 1 (length (get-list db var1 'references)))
+      (and (= 1 (length (db-get-list db var1 'references)))
 	   (make-node
 	    '##core#call p
 	    (cons (varnode var2) more) ) ) ) )
@@ -778,7 +777,7 @@
    (var op args d x y)
    ,(lambda (db var op args d x y)
       (and (not (equal? op (eq-inline-operator)))
-	   (= 1 (length (get-list db var 'references)))
+	   (= 1 (length (db-get-list db var 'references)))
 	   (make-node
 	    'if d
 	    (list (make-node '##core#inline (list op) args)
@@ -935,7 +934,7 @@
     (##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) )
 
 (define (simplify-named-call db params name cont class classargs callargs)
-  (define (test sym prop) (get db sym prop))
+  (define (test sym prop) (db-get db sym prop))
   (define (defarg x)
     (cond ((symbol? x) (varnode x))
 	  ((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
@@ -1339,10 +1338,10 @@
 ;;; Optimize direct leaf routines:
 
 (define (transform-direct-lambdas! node db)
-  (let ([dirty #f]
-	[inner-ks '()] 
-	[hoistable '()] 
-	[allocated 0] )
+  (let ((dirty #f)
+	(inner-ks '()) 
+	(hoistable '()) 
+	(allocated 0) )
 
     ;; Process node tree and walk lambdas that meet the following constraints:
     ;;  - Only external lambdas (no CPS redexes),
@@ -1352,18 +1351,18 @@
     ;;  - The lambda is not marked as a callback lambda
 
     (define (walk d n dn)
-      (let ([params (node-parameters n)]
-	    [subs (node-subexpressions n)] )
+      (let ((params (node-parameters n))
+	    (subs (node-subexpressions n)) )
 	(case (node-class n)
-	  [(##core#lambda)
-	   (let ([llist (third params)])
+	  ((##core#lambda)
+	   (let ((llist (third params)))
 	     (if (and d
 		      (second params)
-		      (not (get db d 'unknown))
+		      (not (db-get db d 'unknown))
 		      (proper-list? llist)
-		      (and-let* ([val (get db d 'value)]
-				 [refs (get-list db d 'references)]
-				 [sites (get-list db d 'call-sites)] )
+		      (and-let* ((val (db-get db d 'value))
+				 (refs (db-get-list db d 'references))
+				 (sites (db-get-list db d 'call-sites)) )
 			;; val must be lambda, since `sites' is set
 			(and (eq? n val)
 			     (not (variable-mark
@@ -1372,87 +1371,87 @@
 			     (= (length refs) (length sites))
 			     (scan (first subs) (first llist) d dn (cons d llist)) ) ) )
 		 (transform n d inner-ks hoistable dn allocated) 
-		 (walk #f (first subs) #f) ) ) ]
-	  [(set!) (walk (first params) (first subs) #f)]
-	  [(let)
+		 (walk #f (first subs) #f) ) ) )
+	  ((set!) (walk (first params) (first subs) #f))
+	  ((let)
 	   (walk (first params) (first subs) n)
-	   (walk #f (second subs) #f) ]
-	  [else (for-each (lambda (x) (walk #f x #f)) subs)] ) ) )
+	   (walk #f (second subs) #f) )
+	  (else (for-each (lambda (x) (walk #f x #f)) subs)) ) ) )
 
     (define (scan n kvar fnvar destn env)
-      (let ([closures '()]
-	    [recursive #f] )
+      (let ((closures '())
+	    (recursive #f) )
 	(define (rec n v vn e)
-	  (let ([params (node-parameters n)]
-		[subs (node-subexpressions n)] )
+	  (let ((params (node-parameters n))
+		(subs (node-subexpressions n)) )
 	    (case (node-class n)
-	      [(##core#variable)
-	       (let ([v (first params)])
-		 (or (not (get db v 'boxed))
+	      ((##core#variable)
+	       (let ((v (first params)))
+		 (or (not (db-get db v 'boxed))
 		     (not (memq v env))
 		     (and (not recursive)
 			  (begin
 			    (set! allocated (+ allocated 2))
-			    #t) ) ) ) ]
-	      [(##core#lambda)
+			    #t) ) ) ) )
+	      ((##core#lambda)
 	       (and v
 		    (##sys#decompose-lambda-list
 		     (third params)
 		     (lambda (vars argc rest)
 		       (set! closures (cons v closures))
-		       (rec (first subs) #f #f (append vars e)) ) ) ) ]
-	      [(##core#inline_allocate)
+		       (rec (first subs) #f #f (append vars e)) ) ) ) )
+	      ((##core#inline_allocate)
 	       (and (not recursive)
 		    (begin
 		      (set! allocated (+ allocated (second params)))
-		      (every (lambda (x) (rec x #f #f e)) subs) ) ) ]
-	      [(##core#direct_lambda)
+		      (every (lambda (x) (rec x #f #f e)) subs) ) ) )
+	      ((##core#direct_lambda)
 	       (and vn destn
 		    (null? (scan-used-variables (first subs) e)) 
 		    (begin
 		      (set! hoistable (alist-cons v vn hoistable))
-		      #t) ) ]
-	      [(##core#inline_ref)
-	       (and (let ([n (estimate-foreign-result-size (second params))])
+		      #t) ) )
+	      ((##core#inline_ref)
+	       (and (let ((n (estimate-foreign-result-size (second params))))
 		      (or (zero? n)
 			  (and (not recursive)
 			       (begin
 				 (set! allocated (+ allocated n))
 				 #t) ) ) )
-		    (every (lambda (x) (rec x #f #f e)) subs) ) ]
-	      [(##core#inline_loc_ref)
-	       (and (let ([n (estimate-foreign-result-size (first params))])
+		    (every (lambda (x) (rec x #f #f e)) subs) ) )
+	      ((##core#inline_loc_ref)
+	       (and (let ((n (estimate-foreign-result-size (first params))))
 		      (or (zero? n)
 			  (and (not recursive)
 			       (begin
 				 (set! allocated (+ allocated n))
 				 #t) ) ) )
-		    (every (lambda (x) (rec x #f #f e)) subs) ) ]
-	      [(##core#call)
-	       (let ([fn (first subs)])
+		    (every (lambda (x) (rec x #f #f e)) subs) ) )
+	      ((##core#call)
+	       (let ((fn (first subs)))
 		 (and (eq? '##core#variable (node-class fn))
-		      (let ([v (first (node-parameters fn))])
-			(cond [(eq? v fnvar)
+		      (let ((v (first (node-parameters fn))))
+			(cond ((eq? v fnvar)
 			       (and (zero? allocated)
-				    (let ([k (second subs)])
+				    (let ((k (second subs)))
 				      (when (eq? '##core#variable (node-class k))
 					(set! inner-ks (cons (first (node-parameters k)) inner-ks)) )
 				      (set! recursive #t)
-				      #t) ) ]
-			      [else (eq? v kvar)] ) )
-		      (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) ]
-	      [(##core#direct_call)
-	       (let ([n (fourth params)])
+				      #t) ) )
+			      (else (eq? v kvar)) ) )
+		      (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) )
+	      ((##core#direct_call)
+	       (let ((n (fourth params)))
 		 (or (zero? n)
 		     (and (not recursive)
 			  (begin
 			    (set! allocated (+ allocated n))
-			    (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) ]
-	      [(set!) (rec (first subs) (first params) #f e)]
-	      [(let)
+			    (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) )
+	      ((set!) (rec (first subs) (first params) #f e))
+	      ((let)
 	       (and (rec (first subs) (first params) n e)
-		    (rec (second subs) #f #f (append params e)) ) ]
-	      [else (every (lambda (x) (rec x #f #f e)) subs)] ) ) )
+		    (rec (second subs) #f #f (append params e)) ) )
+	      (else (every (lambda (x) (rec x #f #f e)) subs)) ) ) )
 	(set! inner-ks '())
 	(set! hoistable '())
 	(set! allocated 0)
@@ -1464,11 +1463,11 @@
 	  (debugging 'o "direct leaf routine with hoistable closures/allocation" fnvar (delay (unzip1 hoistable)) allocated)
 	  (debugging 'o "direct leaf routine/allocation" fnvar allocated) )
       (set! dirty #t)
-      (let* ([params (node-parameters n)]
-	     [argc (length (third params))]
-	     [klambdas '()] 
-	     [sites (or (get db fnvar 'call-sites) '())]
-	     [ksites '()] )
+      (let* ((params (node-parameters n))
+	     (argc (length (third params)))
+	     (klambdas '()) 
+	     (sites (or (db-get db fnvar 'call-sites) '()))
+	     (ksites '()) )
 	(if (and (list? params) (= (length params) 4) (list? (caddr params)))
 	    (let ((id (car params))
 		  (kvar (caaddr params))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3eed5b6..5421355 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -37,8 +37,7 @@
     (scrutinize load-type-database emit-type-file
      validate-type check-and-validate-type install-specializations)
 
-(import (except chicken put! get syntax-error) scheme
-	srfi-1 data-structures extras ports files
+(import chicken scheme srfi-1 data-structures extras ports files
 	support)
 
 (include "tweaks")
@@ -192,7 +191,7 @@
     (define (variable-result id e loc flow)
       (cond ((blist-type id flow) => list)
 	    ((and (not strict-variable-types)
-		  (get db id 'assigned) 
+		  (db-get db id 'assigned) 
 		  (not (variable-mark id '##compiler#declared-type)))
 	     '(*))
 	    ((assq id e) =>
@@ -550,9 +549,9 @@
 				   (walk val e loc var #f flow #f) 
 				   loc)))
 			  (when (and (eq? (node-class val) '##core#variable)
-				     (not (get db var 'assigned)))
+				     (not (db-get db var 'assigned)))
 			    (let ((var2 (first (node-parameters val))))
-			      (unless (get db var2 'assigned) ;XXX too conservative?
+			      (unless (db-get db var2 'assigned) ;XXX too conservative?
 				(set! aliased (alist-cons var var2 aliased)))))
 			  (loop (cdr vars) (cdr body) (alist-cons (car vars) t e2))))))
 		 ((##core#lambda lambda)
@@ -593,7 +592,7 @@
 			     (list
 			      (let loop ((argc argc) (vars vars) (args args))
 				(cond ((zero? argc) args)
-				      ((and (not (get db (car vars) 'assigned))
+				      ((and (not (db-get db (car vars) 'assigned))
 					    (assoc (cons (car vars) initial-tag) blist))
 				       =>
 				       (lambda (a)
@@ -634,9 +633,9 @@
 		    (when (and (not type) ;XXX global declaration could allow this
 			       (not b)
 			       (not (eq? '* rt))
-			       (not (get db var 'unknown)))
-		      (and-let* ((val (or (get db var 'value)
-					  (get db var 'local-value))))
+			       (not (db-get db var 'unknown)))
+		      (and-let* ((val (or (db-get db var 'value)
+					  (db-get db var 'local-value))))
 			(when (and (eq? val (first subs))
 				   (or (not (variable-visible? var))
 				       (not (eq? (variable-mark var '##compiler#inline) 
@@ -666,7 +665,7 @@
 				  #t)))))
 		      ;; don't use "add-to-blist" since the current operation does not affect aliases
 		      (let ((t (if (or strict-variable-types
-				       (not (get db var 'captured)))
+				       (not (db-get db var 'captured)))
 				   rt 
 				   '*))
 			    (fl (car flow)))
@@ -737,7 +736,7 @@
 					 (oparg? (eq? arg (first subs)))
 					 (pred (and pt
 						    ctags
-						    (not (get db var 'assigned)) 
+						    (not (db-get db var 'assigned)) 
 						    (not oparg?))))
 				    (cond (pred
 					   ;;XXX is this needed? "typeenv" is the te of "args",
@@ -766,7 +765,7 @@
 								(if (type<=? t argr)
 								    t
 								    argr)))
-							     ((get db var 'assigned) '*)
+							     ((db-get db var 'assigned) '*)
 							     ((type<=? (cdr a) argr) (cdr a))
 							     (else argr))))
 					       (d "  assuming: ~a -> ~a (flow: ~a)" 
diff --git a/support.scm b/support.scm
index c08cd27..b067d70 100644
--- a/support.scm
+++ b/support.scm
@@ -35,16 +35,17 @@
 
 (module support
     (compiler-cleanup-hook bomb collected-debugging-output debugging
-     with-debugging-output quit-compiling emit-syntax-trace-info
-     check-signature posq posv stringify symbolify
+     debugging-chicken with-debugging-output quit-compiling
+     emit-syntax-trace-info check-signature posq posv stringify symbolify
      build-lambda-list string->c-identifier c-ify-string valid-c-identifier?
      bytes->words words->bytes
      check-and-open-input-file close-checked-input-file fold-inner
      constant? collapsable-literal? immediate? basic-literal?
      canonicalize-begin-body string->expr llist-length llist-match?
-     expand-profile-lambda initialize-analysis-database get get-all put!
-     collect! get-list get-line get-line-2 display-line-number-database
-     display-analysis-database make-node node? node-class node-class-set!
+     expand-profile-lambda initialize-analysis-database db-get db-get-all
+     db-put! collect! db-get-list get-line get-line-2
+     display-line-number-database display-analysis-database
+     make-node node? node-class node-class-set!
      node-parameters node-parameters-set!
      node-subexpressions node-subexpressions-set! varnode qnode
      build-node-graph build-expression-tree fold-boolean inline-lambda-bindings
@@ -65,8 +66,7 @@
      mark-variable variable-mark intrinsic? foldable? load-identifier-database
      print-version print-usage print-debug-options)
 
-(import (except chicken put! get syntax-error) scheme foreign
-	data-structures srfi-1 files extras ports)
+(import chicken scheme foreign data-structures srfi-1 files extras ports)
 
 (include "tweaks")
 (include "banner")
@@ -409,21 +409,19 @@
 	 internal-bindings))
       (set! initial #f))))
 
-;; TODO: Rename this to avoid conflict/confusion with the one from scheme
-(define (get db key prop)
+(define (db-get db key prop)
   (let ((plist (##sys#hash-table-ref db key)))
     (and plist
 	 (let ([a (assq prop plist)])
 	   (and a (##sys#slot a 1)) ) ) ) )
 
-(define (get-all db key . props)
+(define (db-get-all db key . props)
   (let ((plist (##sys#hash-table-ref db key)))
     (if plist
 	(filter-map (lambda (prop) (assq prop plist)) props)
 	'() ) ) )
 
-;; TODO: Rename this to avoid conflict/confusion with the one from scheme
-(define (put! db key prop val)
+(define (db-put! db key prop val)
   (let ([plist (##sys#hash-table-ref db key)])
     (if plist
 	(let ([a (assq prop plist)])
@@ -439,15 +437,15 @@
 		[else (##sys#setslot plist 1 (alist-cons prop (list val) (##sys#slot plist 1)))] ) )
 	(##sys#hash-table-set! db key (list (list prop val)))) ) )
 
-(define (get-list db key prop)		; returns '() if not set
-  (let ((x (get db key prop)))
+(define (db-get-list db key prop)		; returns '() if not set
+  (let ((x (db-get db key prop)))
     (or x '())))
 
 
 ;;; Line-number database management:
 
 (define (get-line exp)
-  (get ##sys#line-number-database (car exp) exp) )
+  (db-get ##sys#line-number-database (car exp) exp) )
 
 (define (get-line-2 exp)
   (let* ((name (car exp))
@@ -739,40 +737,40 @@
 
 ;; Copy along with the above
 (define (copy-node-tree-and-rename node vars aliases db cfk)
-  (let ([rlist (map cons vars aliases)])
+  (let ((rlist (map cons vars aliases)))
     (define (rename v rl) (alist-ref v rl eq? v))
     (define (walk n rl)
-      (let ([subs (node-subexpressions n)]
-	    [params (node-parameters n)]
-	    [class (node-class n)] )
+      (let ((subs (node-subexpressions n))
+	    (params (node-parameters n))
+	    (class (node-class n)) )
 	(case class
 	  ((quote)
 	   (make-node class params '()))
-	  [(##core#variable) 
+	  ((##core#variable) 
 	   (let ((var (first params)))
-	     (when (get db var 'contractable)
+	     (when (db-get db var 'contractable)
 	       (cfk var))
-	     (varnode (rename var rl))) ]
-	  [(set!) 
+	     (varnode (rename var rl))) )
+	  ((set!) 
 	   (make-node
 	    'set! (list (rename (first params) rl))
-	    (list (walk (first subs) rl)) ) ]
-	  [(let) 
+	    (list (walk (first subs) rl)) ) )
+	  ((let) 
 	   (let* ((v (first params))
 		  (val1 (walk (first subs) rl))
 		  (a (gensym v))
 		  (rl2 (alist-cons v a rl)) )
-	     (put! db a 'inline-transient #t)
+	     (db-put! db a 'inline-transient #t)
 	     (make-node 
 	      'let (list a)
-	      (list val1 (walk (second subs) rl2)))) ]
-	  [(##core#lambda)
+	      (list val1 (walk (second subs) rl2)))) )
+	  ((##core#lambda)
 	   (##sys#decompose-lambda-list
 	    (third params)
 	    (lambda (vars argc rest)
 	      (let* ((as (map (lambda (v)
 				(let ((a (gensym v)))
-				  (put! db v 'inline-transient #t)
+				  (db-put! db v 'inline-transient #t)
 				  a))
 			      vars) )
 		     (rl2 (append (map cons vars as) rl)) )
@@ -781,8 +779,9 @@
 		 (list (gensym 'f) (second params) ; new function-id
 		       (build-lambda-list as argc (and rest (rename rest rl2)))
 		       (fourth params) )
-		 (map (cut walk <> rl2) subs) ) ) ) ) ]
-	  [else (make-node class (tree-copy params) (map (cut walk <> rl) subs))] ) ) )
+		 (map (cut walk <> rl2) subs) ) ) ) ) )
+	  (else (make-node class (tree-copy params)
+			   (map (cut walk <> rl) subs))) ) ) )
     (walk node rlist) ) )
 
 ;; Maybe move to scrutinizer.  It's generic enough to keep it here though
@@ -822,7 +821,7 @@
 			   (not (eq? 'unknown (cdr val))))))
 		    ((assq 'inlinable plist))
 		    (lparams (node-parameters (cdr val)))
-		    ((not (get db sym 'hidden-refs)))
+		    ((not (db-get db sym 'hidden-refs)))
 		    ((case (variable-mark sym '##compiler#inline)
 		       ((yes) #t)
 		       ((no) #f)
@@ -1442,30 +1441,30 @@
 
 (define (real-name var . db)
   (define (resolve n)
-    (let ([n2 (##sys#hash-table-ref real-name-table n)])
+    (let ((n2 (##sys#hash-table-ref real-name-table n)))
       (if n2
 	  (or (##sys#hash-table-ref real-name-table n2)
 	      n2) 
 	  n) ) )
-  (let ([rn (resolve var)])
-    (cond [(not rn) (##sys#symbol->qualified-string var)]
-	  [(pair? db)
-	   (let ([db (car db)])
-	     (let loop ([nesting (list (##sys#symbol->qualified-string rn))]
-                        [depth 0]
-			[container (get db var 'contained-in)] )
+  (let ((rn (resolve var)))
+    (cond ((not rn) (##sys#symbol->qualified-string var))
+	  ((pair? db)
+	   (let ((db (car db)))
+	     (let loop ((nesting (list (##sys#symbol->qualified-string rn)))
+			(depth 0)
+			(container (db-get db var 'contained-in)) )
 	       (cond
-                ((> depth real-name-max-depth)
-                 (string-intersperse (reverse (cons "..." nesting)) " in "))
-                (container
-                 (let ([rc (resolve container)])
-                   (if (eq? rc container)
-                       (string-intersperse (reverse nesting) " in ")
-                       (loop (cons (symbol->string rc) nesting)
-                             (fx+ depth 1)
-                             (get db container 'contained-in) ) ) ))
-                (else (string-intersperse (reverse nesting) " in "))) ) ) ]
-	  [else (##sys#symbol->qualified-string rn)] ) ) )
+		((> depth real-name-max-depth)
+		 (string-intersperse (reverse (cons "..." nesting)) " in "))
+		(container
+		 (let ((rc (resolve container)))
+		   (if (eq? rc container)
+		       (string-intersperse (reverse nesting) " in ")
+		       (loop (cons (symbol->string rc) nesting)
+			     (fx+ depth 1)
+			     (db-get db container 'contained-in) ) ) ))
+		(else (string-intersperse (reverse nesting) " in "))) ) ) )
+	  (else (##sys#symbol->qualified-string rn)) ) ) )
 
 (define (real-name2 var db)		; Used only in c-backend.scm
   (and-let* ([rn (##sys#hash-table-ref real-name-table var)])
diff --git a/tests/module-tests.scm b/tests/module-tests.scm
index 6d7bd1c..45b0cd7 100644
--- a/tests/module-tests.scm
+++ b/tests/module-tests.scm
@@ -298,6 +298,48 @@
    (m29-baz))
  'foo)
 
+;; Ensure that the modules system is simply an aliasing mechanism:
+;; Module instantion does not create multiple variable copies.
+
+(module m31 *
+  (import chicken scheme)
+  (define mutation-count 0)
+  (define (internally-mutate!)
+    (set! mutation-count (add1 mutation-count)))
+  (define (get-count)
+    mutation-count))
+
+(module m32 *
+  (import chicken scheme m31)
+  (define (externally-mutate!)
+    (set! mutation-count (add1 mutation-count))))
+
+(import m31 m32)
+(test-equal
+ "initial state"
+ 0 mutation-count)
+
+(internally-mutate!)
+
+(test-equal
+ "After mutating inside defining module"
+ 1 mutation-count)
+
+(set! mutation-count 2)
+
+(test-equal
+ "After mutating outside module"
+ 2 mutation-count)
+
+(externally-mutate!)
+
+(test-equal
+ "After mutation by another module"
+ 3 mutation-count)
+
+(test-equal
+ "Internal getter returns same thing"
+ 3 (get-count))
 
 (test-end "modules")
 
-- 
1.7.10.4