Create constructor stubs for combination, conditional, and disjunction.

diff --git a/src/sf/copy.scm b/src/sf/copy.scm
index f296ec5d1300763c11ede2ab168d0530a054fbae..5f778f8b797318167958db1819e1c6cf87a588b2 100644 (file)
--- 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 9aba78a583b5ed3d71924d24567da602e8db365e..fc4226a5466e773439c2da18c464156fa776024c 100644 (file)
--- 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 a200c804443f6cf9cc565e0851c50f2a0aee8a9c..4d28f379eba0d5ad7c820a7b0326f758c22470d3 100644 (file)
--- 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)))