From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Tue, 9 Feb 2010 23:55:03 +0000 (-0800)
Subject: Create constructor stubs for combination, conditional, and disjunction.
X-Git-Tag: 20100708-Gtk~168^2~11
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3b3353a6e0d8e96bf9e49087d07634ed3d5763e2;p=mit-scheme.git

Create constructor stubs for combination, conditional, and disjunction.
---

diff --git a/src/sf/copy.scm b/src/sf/copy.scm
index f296ec5d1..5f778f8b7 100644
--- a/src/sf/copy.scm
+++ b/src/sf/copy.scm
@@ -187,7 +187,7 @@ USA.
 
 (define-method/copy 'COMBINATION
   (lambda (block environment expression)
-    (combination/make
+    (combination/%make
      (combination/scode expression)
      block
      (copy/expression block environment (combination/operator expression))
diff --git a/src/sf/object.scm b/src/sf/object.scm
index 9aba78a58..fc4226a54 100644
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -187,7 +187,7 @@ USA.
 		   (named variable/enumerand)
 		   (type-descriptor rtd:variable)
 		   (conc-name variable/)
-		   (constructor variable/make)
+		   (constructor variable/make (block name flags))
 		   (print-procedure
 		    (standard-unparser-method 
 		     'variable
@@ -196,24 +196,46 @@ USA.
 		       (write (variable/name var) port)))))
   block
   name
+  ;; A count of how many times in the block that the variable
+  ;; is invoked as an operator.
+  (invocation-count 0)
   flags)
 
 (define-guarantee variable "variable")
 
 ;;; Expressions
-(define-simple-type access          #f (environment name))
-(define-simple-type assignment      #f (block variable value))
-(define-simple-type combination     #f (block operator operands))
-(define-simple-type conditional     #f (predicate consequent alternative))
-(define-simple-type constant        #f (value))
-(define-simple-type declaration     #f (declarations expression))
-(define-simple-type delay           #f (expression))
-(define-simple-type disjunction     #f (predicate alternative))
-(define-simple-type open-block      #f (block variables values actions))
-(define-simple-type procedure       #f (block name required optional rest body))
-(define-simple-type quotation       #f (block expression))
-(define-simple-type sequence        #f (actions))
-(define-simple-type the-environment #f (block))
+(define-simple-type access          #f                 (environment name))
+(define-simple-type assignment      #f                 (block variable value))
+(define-simple-type combination     combination/%%make (block operator operands))
+(define-simple-type conditional     conditional/%make  (predicate consequent alternative))
+(define-simple-type constant        #f                 (value))
+(define-simple-type declaration     #f                 (declarations expression))
+(define-simple-type delay           #f                 (expression))
+(define-simple-type disjunction     disjunction/%make  (predicate alternative))
+(define-simple-type open-block      #f                 (block variables values actions))
+(define-simple-type procedure       #f                 (block name required optional rest body))
+(define-simple-type quotation       #f                 (block expression))
+(define-simple-type sequence        #f                 (actions))
+(define-simple-type the-environment #f                 (block))
+
+;;; Constructors that need to do work.
+
+(define (combination/%make scode block operator operands)
+  ;; Keep track of how many times a reference appears as an operator.
+  (if (reference? operator)
+      (let ((variable (reference/variable operator)))
+	(set-variable/invocation-count! variable
+					(1+ (variable/invocation-count variable)))))
+  (combination/%%make scode block operator operands))
+
+(define (combination/make expression block operator operands)
+  (combination/%make expression block operator operands))
+
+(define (conditional/make scode predicate consequent alternative)
+  (conditional/%make scode predicate consequent alternative))
+
+(define (disjunction/make scode predicate alternative)
+  (disjunction/%make scode predicate alternative))
 
 ;; Done specially so we can tweak the print method.
 ;; This makes debugging an awful lot easier.
diff --git a/src/sf/xform.scm b/src/sf/xform.scm
index a200c8044..4d28f379e 100644
--- a/src/sf/xform.scm
+++ b/src/sf/xform.scm
@@ -232,10 +232,10 @@ USA.
 (define (transform/combination* expression block environment expression*)
   (combination-components expression*
     (lambda (operator operands)
-      (combination/make expression
-			block
-			(transform/expression block environment operator)
-			(transform/expressions block environment operands)))))
+      (combination/%make expression
+			 block
+			 (transform/expression block environment operator)
+			 (transform/expressions block environment operands)))))
 
 (define (transform/comment block environment expression)
   (transform/expression block environment (comment-expression expression)))