From e2b728ff9a53eb2ff4518ad10beb649b5e636f74 Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Wed, 24 Sep 2008 22:42:55 +0000
Subject: 	* interp/i-analy.boot (putCallInfo): New. 	(bottomUp):
 Use it. 	* interp/i-spec1.boot (upand): Likewise. 	(upor):
 Likewise. 	(upcase): Likewise. 	* interp/i-spec2.boot (uperror):
 Likewise.

---
 src/interp/i-analy.boot | 11 ++++++++---
 src/interp/i-spec1.boot |  9 ++++++++-
 src/interp/i-spec2.boot |  2 +-
 3 files changed, 17 insertions(+), 5 deletions(-)

(limited to 'src/interp')

diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot
index d288eb80..26a1309d 100644
--- a/src/interp/i-analy.boot
+++ b/src/interp/i-analy.boot
@@ -52,6 +52,13 @@ $inRetract := false
 
 --% Interpreter Analysis Functions
 
+++ Record calling context information in the VAT `t'.
+putCallInfo(t,op,arg,nargs) ==
+  putAtree(t,"callingFunction",op)
+  putAtree(t,"argumentNumber",arg)
+  putAtree(t,"totalArgs",nargs)
+  t
+
 getMinimalVariableTower(var,t) ==
   -- gets the minimal polynomial subtower of t that contains the
   -- given variable. Returns NIL if none.
@@ -228,9 +235,7 @@ bottomUp t ==
     (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u
     nargs := #argl
     if opName then for x in argl for i in 1.. repeat
-      putAtree(x,'callingFunction,opName)
-      putAtree(x,'argumentNumber,i)
-      putAtree(x,'totalArgs,nargs)
+      putCallInfo(x,opName,i,nargs)
 
     if tar then pushDownTargetInfo(opName,tar,argl)
 
diff --git a/src/interp/i-spec1.boot b/src/interp/i-spec1.boot
index b8f6121d..f8820697 100644
--- a/src/interp/i-spec1.boot
+++ b/src/interp/i-spec1.boot
@@ -249,7 +249,9 @@ upand x ==
   -- evaluated if the first argument is true.
   x isnt [op,term1,term2] => NIL
   putTarget(term1,$Boolean)
+  putCallInfo(term1,"and",1,2)
   putTarget(term2,$Boolean)
+  putCallInfo(term2,"and",2,2)
   ms := bottomUp term1
   ms isnt [=$Boolean] => nil   -- use general modemap
   $genValue =>
@@ -284,7 +286,9 @@ upor x ==
   -- evaluated if the first argument is false.
   x isnt [op,term1,term2] => NIL
   putTarget(term1,$Boolean)
+  putCallInfo(term1,"or",1,2)
   putTarget(term2,$Boolean)
+  putCallInfo(term2,"or",2,2)
   ms := bottomUp term1
   ms isnt [=$Boolean] => nil
   $genValue =>
@@ -331,6 +335,7 @@ userDefinedCase(t is [op, lhs, rhs]) ==
 
 upcase t ==
   t isnt [op,lhs,rhs] => nil
+  putCallInfo(lhs,"case",1,2)
   bottomUp lhs
   triple := getValue lhs
   objMode(triple) isnt ['Union,:unionDoms] => userDefinedCase t
@@ -964,7 +969,9 @@ upconstruct t ==
     CAR(tar) in '(Matrix SquareMatrix RectangularMatrix) =>
       vec := ['List,underDomainOf tar]
       for x in l repeat if not getTarget(x) then putTarget(x,vec)
-  argModeSetList:= [bottomUp x for x in l]
+  nargs := #l
+  argModeSetList:= [bottomUp putCallInfo(x,"construct",i,nargs)
+                      for x in l for i in 1..]
   dol and dol is [topType,:.] and not (topType in aggs) =>
     (mmS:= selectMms(op,l,tar)) and (mS:= evalForm(op,getUnname op,l,mmS)) =>
       putModeSet(op,mS)
diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot
index f4256a06..fb5079a6 100644
--- a/src/interp/i-spec2.boot
+++ b/src/interp/i-spec2.boot
@@ -183,7 +183,7 @@ uperror t ==
   -- which is the name of the function.
   not $compilingMap => NIL
   t isnt [op,msg] => NIL
-  msgMs := bottomUp msg
+  msgMs := bottomUp putCallInfo(msg,"error",1,1)
   msgMs isnt [=$String] => NIL
   RPLACD(t,[mkAtree object2String $mapName,msg])
   bottomUp t
-- 
cgit v1.2.3