remove more pamphlets from interp/

1 files changed, 338 insertions, 0 deletions

diff --git a/src/interp/slam.boot b/src/interp/slam.boot
new file mode 100644
index 00000000..d9832a9a
--- /dev/null
+++ b/src/interp/slam.boot
@@ -0,0 +1,338 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+-- Copyright (C) 2007, Gabriel Dos Reis.
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+--     - Redistributions of source code must retain the above copyright
+--       notice, this list of conditions and the following disclaimer.
+--
+--     - Redistributions in binary form must reproduce the above copyright
+--       notice, this list of conditions and the following disclaimer in
+--       the documentation and/or other materials provided with the
+--       distribution.
+--
+--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--       names of its contributors may be used to endorse or promote products
+--       derived from this software without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+import '"g-timer"
+)package "BOOT"
+
+reportFunctionCompilation(op,nam,argl,body,isRecursive) ==
+  -- for an alternate definition of this function which does not allow
+  -- dynamic caching, see SLAMOLD BOOT
+--+
+  $compiledOpNameList := [nam]
+  minivectorName := makeInternalMapMinivectorName(nam)
+  $minivectorNames := [[op,:minivectorName],:$minivectorNames]
+  body := SUBST(minivectorName,"$$$",body)
+  if $compilingInputFile then
+    $minivectorCode := [:$minivectorCode,minivectorName]
+  SET(minivectorName,LIST2REFVEC $minivector)
+  argl := COPY argl     -- play it safe for optimization
+  init :=
+    not(isRecursive and $compileRecurrence and #argl = 1) => nil
+    NRTisRecurrenceRelation(nam,body,minivectorName)
+  init => compileRecurrenceRelation(op,nam,argl,body,init)
+  cacheCount:= getCacheCount op
+  cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body)
+  cacheCount = 0 or null argl =>
+    function:= [nam,['LAMBDA,[:argl,'envArg],body]]
+    compileInteractive function
+    nam
+  num :=
+    FIXP cacheCount =>
+      cacheCount < 1 =>
+        keyedSystemError("S2IM0019",[cacheCount,op])
+      cacheCount
+    keyedSystemError("S2IM0019",[cacheCount,op])
+  sayKeyedMsg("S2IX0003",[op,num])
+  auxfn := mkAuxiliaryName nam
+  g1:= GENSYM()  --argument or argument list
+  [arg,computeValue] :=
+    null argl => [nil,[auxfn]]
+    argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]]  --g1 is a parameter
+    [g1,['APPLX,MKQ auxfn,g1]]          --g1 is a parameter list
+  cacheName := mkCacheName nam
+  g2:= GENSYM()  --length of cache or arg-value pair
+  g3:= GENSYM()  --value computed by calling function
+  secondPredPair:=
+    null argl => [cacheName]
+    [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]]
+  thirdPredPair:=
+    null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]]
+    ['(QUOTE T),
+      ['SETQ,g2,computeValue],
+        ['SETQ,g3,
+            ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]],
+          ['RPLACA,g3,g1],
+            ['RPLACD,g3,g2],
+              g2]
+  codeBody:=
+    ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]]
+  -- cannot use envArg in next statement without redoing much
+  -- of above.
+  lamex:= ['LAM,arg,codeBody]
+  mainFunction:= [nam,lamex]
+  computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]]
+  compileInteractive mainFunction
+  compileInteractive computeFunction
+  cacheType:= 'function
+  cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]]
+  cacheCountCode:= ['countCircularAlist,cacheName,cacheCount]
+  cacheVector:=
+    mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode)
+  $e:= put(nam,'cacheInfo, cacheVector,$e)
+  eval cacheResetCode
+  SETANDFILE(cacheName,mkCircularAlist cacheCount)
+  nam
+ 
+getCacheCount fn ==
+  n:= LASSOC(fn,$cacheAlist) => n
+  $cacheCount
+ 
+reportFunctionCacheAll(op,nam,argl,body) ==
+  sayKeyedMsg("S2IX0004",[op])
+  auxfn:= mkAuxiliaryName nam
+  g1:= GENSYM()  --argument or argument list
+  [arg,computeValue] :=
+    null argl => [['envArg],[auxfn, 'envArg]]
+    argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]]  --g1 is a parameter
+    [g1,['APPLX,MKQ auxfn,g1]]          --g1 is a parameter list
+  if null argl then g1:=nil
+  cacheName:= mkCacheName nam
+  g2:= GENSYM()  --value computed by calling function
+  secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2]
+  thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]]
+  codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]]
+  lamex:= ['LAM,arg,codeBody]
+  mainFunction:= [nam,lamex]
+  computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]]
+  compileInteractive mainFunction
+  compileInteractive computeFunction
+  cacheType:= 'hash_-table
+  cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]]
+  cacheCountCode:= ['hashCount,cacheName]
+  cacheVector:=
+    mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode)
+  $e:= put(nam,'cacheInfo, cacheVector,$e)
+  eval cacheResetCode
+  nam
+ 
+hashCount table ==
+  +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table]
+ 
+mkCircularAlist n ==
+  l:= [[$failed,:$failed] for i in 1..n]
+  RPLACD(LASTNODE l,l)
+ 
+countCircularAlist(cal,n) ==
+  +/[nodeCount x for x in cal for i in 1..n]
+ 
+predCircular(al,n) ==
+  for i in 1..QSSUB1 n repeat al:= QCDR al
+  al
+ 
+assocCircular(x,al) ==  --like ASSOC except that al is circular
+  forwardPointer:= al
+  val:= nil
+  until EQ(forwardPointer,al) repeat
+    EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer)
+    forwardPointer:= CDR forwardPointer
+  val
+ 
+compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) ==
+  k:= #initCode
+  extraArgumentCode :=
+    extraArguments := [x for x in argl | x ^= sharpArg] =>
+      extraArguments is [x] => x
+      ['LIST,:extraArguments]
+    nil
+  g:= GENSYM()
+  gIndex:= GENSYM()
+  gsList:= [GENSYM() for x in initCode]
+  auxfn := mkAuxiliaryName(nam)
+  $compiledOpNameList := [:$compiledOpNameList,auxfn]
+  stateNam:= GENVAR()
+  stateVar:= GENSYM()
+  stateVal:= GENSYM()
+  lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl)
+  decomposeCode:=
+    [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]]
+      for g in gsList for i in 1..]]
+  gsRev:= REVERSE gsList
+  rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]]
+  advanceCode:= ['LET,gIndex,['ADD1,gIndex]]
+ 
+  newTripleCode := ['LIST,sharpArg,:gsList]
+  newStateCode :=
+    null extraArguments => ['SETQ,stateNam,newTripleCode]
+    ['HPUT,stateNam,extraArgumentCode,newTripleCode]
+ 
+  computeFunction:= [auxfn,['LAM,cargl,cbody]] where
+    cargl:= [:argl,lastArg]
+    returnValue:= ['PROGN,newStateCode,first gsList]
+    cbody:=
+      endTest:=
+        ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]]
+      newValueCode:= ['LET,g,SUBST(gIndex,sharpArg,
+        EQSUBSTLIST(gsList,rest $TriangleVariableList,body))]
+      ['PROGN,:decomposeCode,
+        ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode,
+          newValueCode,:rotateCode]]]
+  fromScratchInit:=
+    [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]]
+  continueInit:=
+    [['LET,gIndex,['ELT,stateVar,0]],
+      :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]]
+  mainFunction:= [nam,['LAM,margl,mbody]] where
+    margl:= [:argl,'envArg]
+    max:= GENSYM()
+    tripleCode := ['CONS,n,['LIST,:initCode]]
+ 
+    -- initialSetCode initializes the global variable if necessary and
+    --  also binds "stateVar" to its current value
+    initialSetCode :=
+      initialValueCode :=
+        extraArguments => ['MAKE_-HASHTABLE,''UEQUAL]
+        tripleCode
+      cacheResetCode := ['SETQ,stateNam,initialValueCode]
+      ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _
+                          ['PAIRP,stateNam]]],    _
+                 ['LET,stateVar,cacheResetCode]], _
+             [''T, ['LET,stateVar,stateNam]]]
+ 
+    -- when there are extra arguments, initialResetCode resets "stateVar"
+    --  to the hashtable entry for the extra arguments
+    initialResetCode :=
+      null extraArguments => nil
+      [['LET,stateVar,['OR,
+         ['HGET,stateVar,extraArgumentCode],
+          ['HPUT,stateVar,extraArgumentCode,tripleCode]]]]
+ 
+    mbody :=
+      preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]]
+      phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]],
+                  [auxfn,:argl,stateVar]]
+      phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]],
+                  ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]]
+      phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]]
+      phrase4:= [['GT,sharpArg,n-k],
+        ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]]
+      phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]]
+      ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]]
+  sayKeyedMsg("S2IX0001",[op])
+  compileInteractive computeFunction
+  compileInteractive mainFunction
+  cacheType:= 'recurrence
+  cacheCountCode:= ['nodeCount,stateNam]
+  cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode)
+  $e:= put(nam,'cacheInfo, cacheVector,$e)
+  nam
+ 
+nodeCount x == NUMOFNODES x
+ 
+recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg])
+ 
+mkCacheVec(op,nam,kind,resetCode,countCode) ==
+  [op,nam,kind,resetCode,countCode]
+ 
+-- reportCacheStore vl ==
+--   sayMSG concat(centerString('"Name",22,'" "),"   Kind          #Cells")
+--   sayMSG concat(centerString('"----",22,'" "),"   ----          ------")
+--   for x in vl repeat reportCacheStoreFor x
+--
+-- op2String op ==
+--   u:= linearFormatName op
+--   atom u => PNAME u
+--   "STRCONC"/u
+--
+-- reportCacheStorePrint(op,kind,count) ==
+--   ops:= op2String op
+--   opString:= centerString(ops,22,'" ")
+--   kindString:= centerString(PNAME kind,10,'" ")
+--   countString:= centerString(count,19,'" ")
+--   sayMSG concat(opString,kindString,countString)
+--
+-- reportCacheStoreFor op ==
+--   u:= getI(op,'localModemap) =>
+--     for [['local,target,:.],[.,fn],:.] in u repeat
+--       [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or
+--         keyedSystemError("S2GE0016",['"reportCacheStoreFor",
+--           '"missing cache information vector"])
+--       reportCacheStorePrint(op,kind,eval countCode)
+--     true
+--   u:= getI(op,"cache") =>
+--     reportCacheStorePrint(op,'variable,nodeCount u)
+--   nil
+ 
+clearCache x ==
+  get(x,'localModemap,$e) or get(x,'mapBody,$e) =>
+    for [map,:sub] in $mapSubNameAlist repeat
+      map=x => _/UNTRACE_,2(sub,NIL)
+    $e:= putHist(x,'localModemap,nil,$e)
+    $e:= putHist(x,'mapBody,nil,$e)
+    $e:= putHist(x,'localVars,nil,$e)
+    sayKeyedMsg("S2IX0007",[x])
+ 
+clearLocalModemaps x ==
+  u:= get(x,"localModemap",$e) =>
+    for sub in ASSOCRIGHT $mapSubNameAlist repeat
+      _/UNTRACE_,2(sub,NIL)
+    $e:= putHist(x,"localModemap",nil,$e)
+    for mm in u repeat
+      [.,fn,:.] := mm
+      if def:= get(fn,'definition,$e) then
+        $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e)
+      if cacheVec:= get(fn,'cacheInfo,$e) then
+        SET(cacheVec.cacheName,NIL)
+      -- now clear the property list of the identifier
+      $e := addIntSymTabBinding(x,nil,$e)
+    sayKeyedMsg("S2IX0007",[x])
+ 
+compileInteractive fn ==
+  if $InteractiveMode then startTimingProcess 'compilation
+  --following not used for common lisp
+  --removeUnnecessaryLastArguments CADR fn
+  if $reportCompilation then
+    sayBrightlyI bright '"Generated LISP code for function:"
+    pp fn
+  optfn :=
+     $InteractiveMode => [timedOptimization fn]
+     [fn]
+  result := compQuietly optfn
+  if $InteractiveMode then stopTimingProcess 'compilation
+  result
+ 
+clearAllSlams x ==
+  fn(x,nil) where
+    fn(thoseToClear,thoseCleared) ==
+      for x in thoseToClear | not MEMQ(x,thoseCleared) repeat
+        slamListName:= mkCacheName x
+        SET(slamListName,nil)
+        thoseCleared:= ADJOIN(x,thoseCleared)
+        someMoreToClear:=
+          setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,:
+            thoseCleared])
+        NCONC(thoseToClear,someMoreToClear)
+ 
+clearSlam("functor")==
+  id:= mkCacheName functor
+  SET(id,nil)