Upgraded inliner from 0.54. There is still a bug as a call to error must not be the last expression of a procedure. No fix for now, use (if #t (error ...)) as a workaround

scheme/opt/analyze.scm

@@ -237,11 +237,20 @@
   (let ((proc (car exp)))
     (and (require "non-local non-tail call" proc
 	   (or (and ret? (simple? proc no-ret))	;tail calls are ok
-	       (lexical-node? proc)))		;so are calls to arguments
+               (primitive-proc? proc)))         ;as are calls to primitives
 	 (simple-list? exp))))
 
-(define (lexical-node? node)
-  (not (node-ref node 'binding)))
+; Calls to primitives and lexically bound variables are okay.
+
+(define (primitive-proc? proc)
+  (cond ((literal-node? proc)
+	 (primop? (node-form proc)))
+	((name-node? proc)
+	 (let ((binding (node-ref proc 'binding)))
+	   (and (binding? binding)
+		(primop? (binding-static binding)))))
+	(else
+	 #f)))
 
 (define no-ret #f)
 
@@ -282,6 +291,7 @@
 (define name-node? (node-predicate 'name))
 (define loophole-node? (node-predicate 'loophole))
 (define define-node? (node-predicate 'define syntax-type))
+(define literal-node? (node-predicate 'literal 'leaf))
 
 ;----------------
 ;(define (foo f p)

scheme/opt/inline.scm

@@ -9,18 +9,21 @@
   (let* ((free (find-node-usages node))
 	 (env (package->environment package))
 	 (qualified-free (map (lambda (name)
-				(name->qualified name env))
+				(cons name 
+				      (name->qualified name env)))
 			      free)))
-    (let ((form (clean-node node (map cons free qualified-free)))
-	  (aux-names (map (lambda (name)
-			    (do ((name name (qualified-parent-name name)))
+    (let ((form (clean-node node '()))
+	  (aux-names (map (lambda (pair)
+			    (do ((name (cdr pair) (qualified-parent-name name)))
 				((not (qualified? name))
 				 name)))
 			  qualified-free)))
       (make-transform (inline-transform form aux-names)
 		      package		;env ?
 		      type
-		      `(inline-transform ',form ',aux-names)
+		      `(inline-transform ',(remove-bindings form
+ 							    qualified-free)
+					 ',aux-names)
 		      name))))
 
 ; This routine is obligated to return an S-expression.
@@ -76,10 +79,10 @@
 ; node itself.
 
 (define (clean-lookup env node)
-  (cdr (assq (if (binding? (node-ref node 'binding))
-		 (node-form node)
-		 node)
-	     env)))
+  (let ((binding (node-ref node 'binding))) 
+    (if (binding? binding)
+ 	`(package-name ,(node-form node) ,binding)
+ 	(cdr (assq node env)))))
   
 ; I'm aware that this is pedantic.
 
@@ -96,6 +99,23 @@
 		env)
 	 name))))
 
+; We need to remove the binding records from the form that will be used for
+; reification.  
+
+(define (remove-bindings form free)
+  (let label ((form form))
+    (if (pair? form)
+      (case (car form)
+        ((package-name)
+         (cdr (assq (cadr form) free))) ; just the name
+        ((quote) form)
+        ((lambda)
+         `(lambda ,(cadr form)
+            ,(label (caddr form))))
+        (else
+         (map label form)))
+      form)))
+
 ;----------------
 ; ST stands for substitution template (cf. MAKE-SUBSTITUTION-TEMPLATE)
 
@@ -150,6 +170,10 @@
 	   (case (car st)
 	     ((quote)
 	      (make-node (get-operator 'quote) st))
+ 	     ((package-name)
+ 	      (let ((node (make-node operator/name (cadr st))))
+ 		(node-set! node 'binding (caddr st))
+ 		node))
 	     ((call)
 	      (make-node (get-operator 'call)
 			 (map label (cdr st))))

scheme/opt/usage.scm

@@ -142,17 +142,18 @@
 
 (define-usage-analyzer 'letrec syntax-type
   (lambda (node free usages)
-    (let* ((exp (node-form node))
-	   (specs (cadr exp))
-	   (body (caddr exp)))
-      (for-each (lambda (spec)
-		  (node-set! (car spec) 'usage (make-usage)))
-		specs)
-      (analyze body
-	       (analyze-nodes (map cadr specs)
-			      free
-			      usages)
-	       usages))))
+    (let ((exp (node-form node)))
+      (analyze-letrec (cadr exp) (caddr exp) free usages))))
+
+(define (analyze-letrec specs body free usages)
+  (for-each (lambda (spec)
+	      (node-set! (car spec) 'usage (make-usage)))
+	    specs)
+  (analyze body
+	   (analyze-nodes (map cadr specs)
+			  free
+			  usages)
+	   usages))
 
 (define-usage-analyzer 'begin syntax-type
   (lambda (node free usages)