From 4da4e775ade14aa9e8c2d0b4b106e743e4d283a4 Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Sun, 5 Oct 2008 03:06:07 +0000
Subject: 	* interp/c-util.boot (isAtomicForm): New. 
 (replaceSimpleFunctions): Use it.  Simplify back to original 
 implementation. 	(proclaimCapsuleFunction): Constructor parameters are
 generic. 	* interp/sys-utility.boot (getVMType): Handle wildcard. 
 * algebra/stream.spad.pamphlet: Don't build STREAM with 	proclamation
 on -- it currently violates type rules.

---
 src/interp/c-util.boot      | 41 +++++++++++++++++++++--------------------
 src/interp/define.boot      |  4 ++--
 src/interp/sys-utility.boot |  4 +++-
 3 files changed, 26 insertions(+), 23 deletions(-)

(limited to 'src/interp')

diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 5ffaf9c3..8a6f4402 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -856,10 +856,15 @@ eqSubst: (%List, %List, %Form) -> %Form
 eqSubst(args,parms,body) ==
   NSUBLIS(pairList(parms,args),body,KEYWORD::TEST,function EQ)
 
+
+++ returns true if `form' does not really induce computations.
+isAtomicForm: %Form -> %Boolean
+isAtomicForm form ==
+  atom form or first form = "QUOTE"
+
 ++ Walk `form' and replace simple functions as appropriate.
 replaceSimpleFunctions form ==
-  atom form => form
-  form is ["QUOTE",:.] => form
+  isAtomicForm form => form
   -- 1. process argument first.
   for args in tails rest form repeat
     arg' := replaceSimpleFunctions(arg := first args)
@@ -876,7 +881,7 @@ replaceSimpleFunctions form ==
     -- 2.2. the substitution case.
     fun' is ["XLAM",parms,body] =>
       -- conservatively approximate eager semantics
-      and/[atom first as for as in tails args] =>
+      and/[isAtomicForm first as for as in tails args] =>
         -- alpha rename before substitution.
 	newparms := [GENSYM() for p in parms]
 	body := eqSubstAndCopy(newparms,parms,body)
@@ -910,25 +915,21 @@ setCompilerOptimizations level ==
 proclaimCapsuleFunction(op,sig) ==
   LAM_,EVALANDFILEACTQ
     ["DECLAIM",["FTYPE",
-       ["FUNCTION",[:[argType first d for d in tails rest sig],"%Shell"], 
-          retType first sig],op]] where
-      argType d ==
-        getVMType normalize d
-      retType d ==
-        d := normalize d
-        atom d => getVMType d
-        args := rest d
-        #args = 0 => getVMType d
-        or/[atom a for a in args] => "%Thing"
-        -- not theoretically correct, but practically OK.
-        getVMType d
-      normalize d ==
+       ["FUNCTION",[:[vmType first d for d in tails rest sig],"%Shell"], 
+          vmType first sig],op]] where
+      vmType d ==
+        getVMType normalize(d,true)
+      normalize(d,top?) ==
         d = "$" => 
+          not top? => "*"
           -- If the representation is explicitly stated, use it.  That way
           -- we optimize abstractions just as well as builtins.
-          rep := get("Rep","value",$e) => rep
+          r := get("Rep","value",$e) => normalize(r.expr,top?)
           -- Cope with old-style constructor definition
           atom $functorForm => [$functorForm] 
-          $functorForm
-        atom d => d
-        [first d, :[normalize first args for args in tails rest d]]
+          normalize($functorForm,top?)
+        atom d => 
+          top? => "%Thing"
+          getmode(d,$e) => "*"
+          d
+        [first d, :[normalize(first args,false) for args in tails rest d]]
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 5939cdcb..58c39f1b 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -927,8 +927,8 @@ compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body],
     e:= compArgumentConditions e
  
     if $profileCompiler then
-      for x in argl for t in rest signature' repeat profileRecord('arguments,x,t)
-
+      for x in argl for t in rest signature' repeat 
+        profileRecord('arguments,x,t)
 
     --4. introduce needed domains into extendedEnv
     for domain in signature' repeat e:= addDomain(domain,e)
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
index 20e84c18..3c820e9f 100644
--- a/src/interp/sys-utility.boot
+++ b/src/interp/sys-utility.boot
@@ -44,7 +44,9 @@ namespace BOOT
 ++ representation of a domain, as a Lisp type specifier as seen by
 ++ the runtime system.
 getVMType d ==
-  IDENTP d => "%Thing"
+  IDENTP d => 
+    d = "*" => d
+    "%Thing"
   STRINGP d => "%Thing"            -- literal flag parameter
   case (d' := devaluate d) of
     Void => "%Void"
-- 
cgit v1.2.3