* interp/define.boot (insertViewMorphisms): New.

	(checkRepresentation): Rename from maybeInsertViewMorphisms. Tidy.
	(compDefineFunctor1): Tidy.
	(doIt): Insert view morphisms if appropriate.

5 files changed, 81 insertions, 62 deletions

diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index c7274eb8..bec24a42 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1005,6 +1005,10 @@ replaceSimpleFunctions form ==
       NBUTLAST form
     -- 2.2. the substitution case.
     fun' is ["XLAM",parms,body] =>
+      -- Inline almost constant functions.
+      null parms => body
+      -- Identity function toos.
+      parms is [=body] => first args
       -- conservatively approximate eager semantics
       and/[isAtomicForm first as for as in tails args] =>
         -- alpha rename before substitution.
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 49d99f9a..6885ba74 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -220,12 +220,14 @@ applyMapping([op,:argl],m,e,ml) ==
       T() == [.,.,e]:= comp(x,m',e) or return "failed"
   if argl'="failed" then return nil
   form:=
-    atom op and not(op in $formalArgList) and not get(op,"value",e) =>
+    atom op and not(op in $formalArgList) and null (u := get(op,"value",e)) =>
       nprefix := $prefix or
       -- following needed for referencing local funs at capsule level
         getAbbreviation($op,#rest $form)
       [op',:argl',"$"] where
         op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op)
+    -- Compiler synthetized operators are inline.
+    u ^= nil and u.expr is ["XLAM",:.] => ["call",u.expr,:argl']
     ['call,['applyFun,op],:argl']
   pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList]
   convert([form,SUBLIS(pairlis,first ml),e],m)
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 06b181a9..5145d76b 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -62,9 +62,6 @@ $mutableDomain := false
 ++ when non nil, holds the declaration number of a function in a capsule.
 $suffix := nil
 
--- ??? turns off buggy code
-$NRTopt := false
-
 $doNotCompileJustPrint := false
 
 ++ stack of pending capsule function definitions.
@@ -76,7 +73,6 @@ $functorStats := nil
 $lisplibCategory := nil
 $lisplibAncestors := nil
 $lisplibAbbreviation := nil
-$LocalDomainAlist := []
 $CheckVectorList := []
 $setelt := nil
 $pairlis := []
@@ -169,45 +165,72 @@ compDefine(form,m,e) ==
   $macroIfTrue: local := false
   compDefine1(form,m,e)
 
-++ We are about to process the body of a capsule.  If the capsule defines
-++ `Rep' as a constant, then implicitly insert the view morphisms
+++ Activate synthetized pair concretization and abstraction
+++ view morphisms for domains.
+insertViewMorphisms: (%Mode,$Env) -> %Env
+insertViewMorphisms(t,e) ==
+  $useRepresentationHack => e
+  g := GENSYM()
+  repType := ["Mapping",t,"$"]
+  perType := ["Mapping","$",t]
+  e := put("rep","value",[["XLAM",[g],g],repType,nil],e)
+  put("per","value",[["XLAM",[g],g],perType,nil],e)
+
+++ We are about to process the body of a capsule.  Check the form of
+++ `Rep' definition, and whether it is appropriate to activate the
+++ implicitly generated morphisms
 ++     per: Rep -> %
 ++     rep: % -> Rep
-++ as local functions.  Note that we do not declare them as macros.
-maybeInsertViewMorphisms: %Form -> %Form
-maybeInsertViewMorphisms body ==
+++ as local inline functions.
+checkRepresentation: %Form -> %Form
+checkRepresentation body ==
   domainRep := nil
-  before := nil
-  
-  while null domainRep for [stmt,:after] in tails body repeat
-    stmt isnt ["DEF",["Rep",:args],sig,nils,domainRep] => 
-      before := [stmt,:before]
-    if args then
-      userError [:bright '"Rep",'"cannot take arguments"]
-    if first sig then
-      userError [:bright '"Rep", "cannot have type sepcification"]
-
-  null domainRep => body
-  -- Make sure we don't implicitly convert from `Rep' to `%'.
-  $useRepresentationHack := false
-  -- Reject user-defined view morphisms 
-  for stmt in after repeat
-    stmt is ["DEF",["rep",:.],:.] 
-      or stmt is ["DEF",["per",:.],:.] =>
-        -- ??? We may actually want to stop processing now.
-        stackSemanticError(['"Cannot define",:bright "per"],nil)
-
-  -- OK, insert synthetized view morphisms
-  g := GENSYM()
-  repMorphism := ["DEF",["rep",g],[domainRep,"$"],[nil,nil],
-                    ["pretend",g,domainRep]]
-  perMorphism := ["DEF",["per",g],["$",domainRep],[nil,nil],
-                    ["pretend",g,"$"]]
+  hasAssignRep := false        -- assume code does not assign to Rep.
+  viewFuns := nil
+
+  null body => body            -- Don't be too hard on nothing.
   
-  -- Trick the rest of the compiler into believing that
-  -- that `Rep' was defined the old way, for the purpose of lookup.
-  [:reverse before, ["%LET","Rep",domainRep], 
-     :[repMorphism,perMorphism],:after]
+  -- Locate possible Rep definition
+  for [stmt,:.] in tails body repeat
+    stmt is ["%LET","Rep",.] =>
+      domainRep ^= nil =>
+        stackAndThrow('"You cannot assign to constant domain %1b",["Rep"])
+      return hasAssignRep := true
+    stmt is ["MDEF",["Rep",:.],:.] =>
+      stackWarning('"Consider using == definition for %1b",["Rep"])
+      return hasAssignRep := true
+    stmt is ["IF",.,:l] or stmt is ["SEQ",:l] or stmt is ["exit",:l] =>
+      checkRepresentation l
+      $useRepresentationHack => return hasAssignRep := true
+    stmt isnt ["DEF",[op,:args],sig,.,val] => nil -- skip for now.
+    op in '(rep per) =>
+      domainRep ^= nil =>
+        stackAndThrow('"You cannot define implicitly generated %1b",[op])
+      viewFuns := [op,:viewFuns]
+    op ^= "Rep" => nil        -- we are only interested in Rep definition
+    domainRep := val
+    viewFuns ^= nil =>
+      stackAndThrow('"You cannot define both %1b and %2b",["Rep",:viewFuns])
+    -- A package has no "%".
+    $functorKind = "package" =>
+      stackAndThrow('"You cannot define %1b in a package",["Rep"])
+    -- It is a mistake to define Rep in category defaults
+    $insideCategoryPackageIfTrue =>
+      stackAndThrow('"You cannot define %1b in category defaults",["Rep"])
+    if args ^= nil then
+      stackAndThrow('"%1b does take arguments",["Rep"])
+    if first sig ^= nil then
+      stackAndThrow('"You cannot specify type for %1b",["Rep"])
+    -- Now, trick the rest of the compiler into believing that
+    -- `Rep' was defined the Old Way, for lookup purpose.
+    rplac(first stmt,"%LET")
+    rplac(rest stmt,["Rep",domainRep])
+    $useRepresentationHack := false          -- Don't confuse `Rep' and `%'.
+
+  -- Shall we perform the dirty tricks?
+  if hasAssignRep then
+    $useRepresentationHack := true
+  body
 
 
 compDefine1: (%Form,%Mode,%Env) -> %Maybe %Triple 
@@ -556,7 +579,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
     $functorTarget: local := nil
     $Representation: local := nil
          --Set in doIt, accessed in the compiler - compNoStacking
-    $LocalDomainAlist: local := []  --set in doIt, accessed in genDeltaEntry
     $functorForm: local := nil
     $functorLocalParameters: local := nil
     SETQ($myFunctorBody, body)
@@ -581,6 +603,9 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
       modemap2Signature getModemap($form,$e)
     target:= first signature'
     $functorTarget:= target
+    $functorKind: local :=
+      $functorTarget is ["CATEGORY",key,:.] => key
+      "domain"
     $e:= giveFormalParametersValues(argl,$e)
     [ds,.,$e]:= compMakeCategoryObject(target,$e) or return
        stackAndThrow('"   cannot produce category object: %1pb",[target])
@@ -610,20 +635,8 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
     -- generate slots for arguments first, then for $NRTaddForm in compAdd
     for x in argl repeat NRTgetLocalIndex x
     [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e)
-    --The following loop sees if we can economise on ADDed operations
-    --by using those of Rep, if that is the same. Example: DIRPROD
     if not $insideCategoryPackageIfTrue  then
-      if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector))
-         and FindRep(cb) = ab
-               where FindRep cb ==
-                 u:=
-                   while cb repeat
-                     ATOM cb => return nil
-                     cb is [["%LET",'Rep,v,:.],:.] => return (u:=v)
-                     cb:=CDR cb
-                 u
-      then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e)
-      else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e)
+      $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e)
     $signature:= signature'
     parSignature:= SUBLIS($pairlis,signature')
     parForm:= SUBLIS($pairlis,form)
@@ -673,8 +686,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body],
     $insideFunctorIfTrue:= false
     if $LISPLIB then
       $lisplibKind:=
-------->This next line prohibits changing the KIND once given
---------kk:=getConstructorKindFromDB $op => kk
         $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package
         'domain
       $lisplibForm:= form
@@ -1409,7 +1420,7 @@ compCapsule(['CAPSULE,:itemList],m,e) ==
   $insideExpressionIfTrue: local:= false
   $useRepresentationHack := true
   clearCapsuleFunctionTable()
-  compCapsuleInner(maybeInsertViewMorphisms itemList,m,addDomain('_$,e))
+  compCapsuleInner(checkRepresentation itemList,m,addDomain('_$,e))
  
 compSubDomain(["SubDomain",domainForm,predicate],m,e) ==
   $addFormLhs: local:= domainForm
@@ -1500,10 +1511,8 @@ doIt(item,$predl) ==
       if lhs="Rep" then
         $Representation:= (get("Rep",'value,$e)).expr
            --$Representation bound by compDefineFunctor, used in compNoStacking
-        if $NRTopt = true
-          then NRTgetLocalIndex $Representation
-      $LocalDomainAlist:= --see genDeltaEntry
-        [[lhs,:SUBLIS($LocalDomainAlist,(get(lhs,'value,$e)).0)],:$LocalDomainAlist]
+        -- Activate view morphisms if appropriate
+        $e := insertViewMorphisms($Representation,$e)
     code is ["%LET",:.] =>
       RPLACA(item,"setShellEntry")
       rhsCode := rhs'
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 52f54d3f..f19a4d69 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -381,7 +381,8 @@ optEQ u ==
 
 $simpleVMoperators == 
   '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND
-    QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP)
+    SPADfirst QVELT _+ _- _* _< _=
+     QEQCAR QCDR QCAR INTEGERP FLOATP STRINGP IDENTP SYMBOLP)
 
 isSimpleVMForm form ==
   isAtomicForm form => true
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index cc1d843b..8b3967f5 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -36,6 +36,9 @@ import macros
 import define
 namespace BOOT
 
+-- ??? turns off buggy code
+$NRTopt := false
+
 compDefineFunctor1(df, m,$e,$prefix,$formalArgList) ==
     ['DEF,form,signature,$functorSpecialCases,body] := df
     signature := markKillAll signature