remove more pamphlets

1 files changed, 455 insertions, 0 deletions

diff --git a/src/interp/i-intern.boot b/src/interp/i-intern.boot
new file mode 100644
index 00000000..c2cd8a84
--- /dev/null
+++ b/src/interp/i-intern.boot
@@ -0,0 +1,455 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- 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 '"i-object"
+import '"ptrees"
+)package "BOOT"
+
+$useParserSrcPos :=  NIL
+$transferParserSrcPos := NIL
+
+--  Making Trees
+
+mkAtree x ==
+  -- maker of attrib tree from parser form
+  mkAtree1 mkAtreeExpandMacros x
+
+mkAtreeWithSrcPos(form, posnForm) ==
+    posnForm and $useParserSrcPos => pf2Atree(posnForm)
+    transferSrcPosInfo(posnForm, mkAtree form)
+
+mkAtree1WithSrcPos(form, posnForm) ==
+  transferSrcPosInfo(posnForm, mkAtree1 form)
+
+mkAtreeNodeWithSrcPos(form, posnForm) ==
+  transferSrcPosInfo(posnForm, mkAtreeNode form)
+
+transferSrcPosInfo(pf, atree) ==
+    not (pf and $transferParserSrcPos) => atree
+    pos := pfPosOrNopos(pf)
+    pfNoPosition?(pos) => atree
+
+    -- following is a hack because parser code for getting filename
+    -- seems wrong.
+    fn := lnPlaceOfOrigin poGetLineObject(pos)
+    if NULL fn or fn = '"strings" then fn := '"console"
+
+    putSrcPos(atree, fn, pfSourceText(pf), pfLinePosn(pos), pfCharPosn(pos))
+    atree
+
+mkAtreeExpandMacros x ==
+  -- handle macro expansion. if the macros have args we require that
+  -- we match the correct number of args
+  if x isnt ["MDEF",:.] and x isnt ["DEF",["macro",:.],:.] then
+    atom x and (m := isInterpMacro x) =>
+      [args,:body] := m
+      args => "doNothing"
+      x := body
+    x is [op,:argl] =>
+      op = "QUOTE" => "doNothing"
+      op = "where" and argl is [before,after] =>
+        -- in a where clause, what follows "where" (the "after" parm
+        -- above) might be a local macro, so do not expand the "before"
+        -- part yet
+        x := [op,before,mkAtreeExpandMacros after]
+      argl := [mkAtreeExpandMacros a for a in argl]
+      (m := isInterpMacro op) =>
+        [args,:body] := m
+        #args = #argl =>
+          sl := [[a,:s] for a in args for s in argl]
+          x := SUBLISNQ(sl,body)
+        null args => x := [body,:argl]
+        x := [op,:argl]
+      x := [mkAtreeExpandMacros op,:argl]
+  x
+
+mkAtree1 x ==
+  -- first special handler for making attrib tree
+  null x => throwKeyedMsg("S2IP0005",['"NIL"])
+  VECP x => x
+  atom x =>
+    x in '(noBranch noMapVal) => x
+    x in '(nil true false) => mkAtree2([x],x,NIL)
+    x = '_/throwAway =>
+      -- don't want to actually compute this
+      tree := mkAtree1 '(void)
+      putValue(tree,objNewWrap(voidValue(),$Void))
+      putModeSet(tree,[$Void])
+      tree
+    getBasicMode x =>
+      v := mkAtreeNode $immediateDataSymbol
+      putValue(v,getBasicObject x)
+      v
+    IDENTP x => mkAtreeNode x
+    keyedSystemError("S2II0002",[x])
+  x is [op,:argl] => mkAtree2(x,op,argl)
+  systemErrorHere '"mkAtree1"
+
+-- mkAtree2 and mkAtree3 were created because mkAtree1 got so big
+
+mkAtree2(x,op,argl) ==
+  nargl := #argl
+  (op= "-") and (nargl = 1) and (INTEGERP CAR argl) =>
+    mkAtree1(MINUS CAR argl)
+  op=":" and argl is [y,z] => [mkAtreeNode "Declare",:argl]
+  op="COLLECT" => [mkAtreeNode op,:transformCollect argl]
+  op= "break" =>
+    argl is [.,val] =>
+      if val = '$NoValue then val := '(void)
+      [mkAtreeNode op,mkAtree1 val]
+    [mkAtreeNode op,mkAtree1 '(void)]
+  op= "return" =>
+    argl is [val] =>
+      if val = '$NoValue then val := '(void)
+      [mkAtreeNode op,mkAtree1 val]
+    [mkAtreeNode op,mkAtree1 '(void)]
+  op="exit" => mkAtree1 CADR argl
+  op = "QUOTE" => [mkAtreeNode op,:argl]
+  op="SEGMENT" =>
+    argl is [a] => [mkAtreeNode op, mkAtree1 a]
+    z :=
+      null argl.1 => nil
+      mkAtree1 argl.1
+    [mkAtreeNode op, mkAtree1 argl.0,z]
+  op in '(pretend is isnt) =>
+    [mkAtreeNode op,mkAtree1 first argl,:rest argl]
+  op =  "::" =>
+    [mkAtreeNode "COERCE",mkAtree1 first argl,CADR argl]
+  x is ["@", expr, type] =>
+    t := evaluateType unabbrev type
+    t = '(DoubleFloat) and expr is [['_$elt, '(Float), 'float], :args] =>
+        mkAtree1 [['_$elt, '(DoubleFloat), 'float], :args]
+    t = '(DoubleFloat) and INTEGERP expr =>
+        v := mkAtreeNode $immediateDataSymbol
+        putValue(v,getBasicObject float expr)
+        v
+    t = '(Float) and INTEGERP expr =>
+        mkAtree1 ["::", expr, t]
+    typeIsASmallInteger(t) and INTEGERP expr =>
+        mkAtree1 ["::", expr, t]
+    [mkAtreeNode 'TARGET,mkAtree1 expr, type]
+  (op="case") and (nargl = 2)  =>
+    [mkAtreeNode "case",mkAtree1 first argl,unabbrev CADR argl]
+  op="REPEAT" => [mkAtreeNode op,:transformREPEAT argl]
+  op="LET" and argl is [['construct,:.],rhs] =>
+    [mkAtreeNode "LET",first argl,mkAtree1 rhs]
+  op="LET" and argl is [[":",a,.],rhs] =>
+    mkAtree1 ["SEQ",first argl,["LET",a,rhs]]
+  op is ['_$elt,D,op1] =>
+    op1 is "=" =>
+      a' := [mkAtreeNode '_=,:[mkAtree1 arg for arg in argl]]
+      [mkAtreeNode "Dollar",D,a']
+    [mkAtreeNode "Dollar",D,mkAtree1 [op1,:argl]]
+  op='_$elt =>
+    argl is [D,a] =>
+      INTEGERP a =>
+        a = 0 => mkAtree1 [['_$elt,D,'Zero]]
+        a = 1 => mkAtree1 [['_$elt,D,'One]]
+        t := evaluateType unabbrev [D]
+        typeIsASmallInteger(t) and SINTP a =>
+            v := mkAtreeNode $immediateDataSymbol
+            putValue(v,objNewWrap(a, t))
+            v
+        mkAtree1 ["*",a,[['_$elt,D,'One]]]
+      [mkAtreeNode "Dollar",D,mkAtree1 a]
+    keyedSystemError("S2II0003",['"$",argl,
+      '"not qualifying an operator"])
+  mkAtree3(x,op,argl)
+
+mkAtree3(x,op,argl) ==
+  op="REDUCE" and argl is [op1,axis,body] =>
+    [mkAtreeNode op,axis,mkAtree1 op1,mkAtree1 body]
+  op="has" => [mkAtreeNode op, :argl]
+  op="|" => [mkAtreeNode "AlgExtension",:[mkAtree1 arg for arg in argl]]
+  op="=" => [mkAtreeNode "equation",:[mkAtree1 arg for arg in argl]]
+  op="not" and argl is [["=",lhs,rhs]] =>
+    [mkAtreeNode "not",[mkAtreeNode "=",mkAtree1 lhs,mkAtree1 rhs]]
+  op="in" and argl is [var ,["SEGMENT",lb,ul]] =>
+    upTest:=
+      null ul => NIL
+      mkLessOrEqual(var,ul)
+    lowTest:=mkLessOrEqual(lb,var)
+    z :=
+      ul => ['and,lowTest,upTest]
+      lowTest
+    mkAtree1 z
+  x is ["IF",p,"noBranch",a] => mkAtree1 ["IF",["not",p],a,"noBranch"]
+  x is ["RULEDEF",:.] => [mkAtreeNode "RULEDEF",:CDR x]
+  x is ["MDEF",sym,junk1,junk2,val] =>
+    -- new macros look like  macro f ==  or macro f(x) ===
+    -- so transform into that format
+    mkAtree1 ["DEF",["macro",sym],junk1,junk2,val]
+  x is ["~=",a,b] => mkAtree1 ["not",["=",a,b]]
+  x is ["+->",funargs,funbody] =>
+    if funbody is [":",body,type] then
+      types := [type]
+      funbody := body
+    else types := [NIL]
+    v := collectDefTypesAndPreds funargs
+    types := [:types,:v.1]
+    [mkAtreeNode "ADEF",[v.0,types,[NIL for a in types],funbody],
+      if v.2 then v.2 else true, false]
+  x is ['ADEF,arg,:r] =>
+    r := mkAtreeValueOf r
+    v :=
+      null arg => VECTOR(NIL,NIL,NIL)
+      PAIRP arg and rest arg and first arg^= "|" =>
+        collectDefTypesAndPreds ['Tuple,:arg]
+      null rest arg => collectDefTypesAndPreds first arg
+      collectDefTypesAndPreds arg
+    [types,:r'] := r
+    at := [fn(x,y) for x in rest types for y in v.1]
+    r := [[first types,:at],:r']
+    [mkAtreeNode "ADEF",[v.0,:r],if v.2 then v.2 else true,false]
+  x is ["where",before,after] =>
+    [mkAtreeNode "where",before,mkAtree1 after]
+  x is ["DEF",["macro",form],.,.,body] =>
+    [mkAtreeNode "MDEF",form,body]
+  x is ["DEF",a,:r] =>
+    r := mkAtreeValueOf r
+    a is [op,:arg] =>
+      v :=
+        null arg => VECTOR(NIL,NIL,NIL)
+        PAIRP arg and rest arg and first arg^= "|" =>
+          collectDefTypesAndPreds ['Tuple,:arg]
+        null rest arg => collectDefTypesAndPreds first arg
+        collectDefTypesAndPreds arg
+      [types,:r'] := r
+      -- see case for ADEF above for defn of fn
+      at := [fn(x,y) for x in rest types for y in v.1]
+      r := [[first types,:at],:r']
+      [mkAtreeNode 'DEF,[[op,:v.0],:r],if v.2 then v.2 else true,false]
+    [mkAtreeNode 'DEF,[a,:r],true,false]
+--x is ['when,y,pred] =>
+--  y isnt ['DEF,a,:r] =>
+--    keyedSystemError("S2II0003",['"when",y,'"improper argument form"])
+--  a is [op,p1,:pr] =>
+--    null pr => mkAtree1 ['DEF,[op,["|",p1,pred]],:r]
+--    mkAtree1 ['DEF,[op,["|",['Tuple,p1,:pr],pred]],:r]
+--  [mkAtreeNode 'DEF, CDR y,pred,false]
+--x is ['otherwise,u] =>
+--  throwMessage '"   otherwise is no longer supported."
+  z :=
+    getBasicMode op =>
+      v := mkAtreeNode $immediateDataSymbol
+      putValue(v,getBasicObject op)
+      v
+    atom op => mkAtreeNode op
+    mkAtree1 op
+  [z,:[mkAtree1 y for y in argl]]
+ where
+  fn(a,b) ==
+    a and b =>
+      if a = b then a
+      else throwMessage '"   double declaration of parameter"
+    a or b
+
+collectDefTypesAndPreds args ==
+  -- given an arglist to a DEF-like form, this function returns
+  -- a vector of three things:
+  --   slot 0: just the variables
+  --   slot 1: the type declarations on the variables
+  --   slot 2: a predicate for all arguments
+  pred := types := vars := NIL
+  junk :=
+    IDENTP args =>
+      types := [NIL]
+      vars  := [args]
+    args is [":",var,type] =>
+      types := [type]
+      var is ["|",var',p] =>
+        vars := [var']
+        pred := addPred(pred,p)
+      vars := [var]
+    args is ["|",var,p] =>
+      pred := addPred(pred,p)
+      var is [":",var',type] =>
+        types := [type]
+        vars := [var']
+      var is ['Tuple,:.] or var is ["|",:.] =>
+        v := collectDefTypesAndPreds var
+        vars  := [:vars,:v.0]
+        types := [:types,:v.1]
+        pred  := addPred(pred,v.2)
+      vars := [var]
+      types := [NIL]
+    args is ['Tuple,:args'] =>
+      for a in args' repeat
+        v := collectDefTypesAndPreds a
+        vars  := [:vars,first v.0]
+        types := [:types,first v.1]
+        pred  := addPred(pred,v.2)
+    types := [NIL]
+    vars  := [args]
+  VECTOR(vars,types,pred)
+ where
+  addPred(old,new) ==
+    null new => old
+    null old => new
+    ['and,old,new]
+
+mkAtreeValueOf l ==
+  -- scans for ['valueOf,atom]
+  not CONTAINED("valueOf",l) => l
+  mkAtreeValueOf1 l
+
+mkAtreeValueOf1 l ==
+  null l or atom l or null rest l => l
+  l is ["valueOf",u] and IDENTP u =>
+    v := mkAtreeNode $immediateDataSymbol
+    putValue(v,get(u,"value",$InteractiveFrame) or
+      objNewWrap(u,['Variable,u]))
+    v
+  [mkAtreeValueOf1 x for x in l]
+
+mkLessOrEqual(lhs,rhs) == ["not",["<",rhs,lhs]]
+
+atree2EvaluatedTree x == atree2Tree1(x,true)
+
+atree2Tree1(x,evalIfTrue) ==
+  (triple := getValue x) and objMode(triple) ^= $EmptyMode =>
+    coerceOrCroak(triple,$OutputForm,$mapName)
+  isLeaf x =>
+    VECP x => x.0
+    x
+  [atree2Tree1(y,evalIfTrue) for y in x]
+
+--% Environment Utilities
+
+-- getValueFromEnvironment(x,mode) ==
+--   $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v
+--   $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e))   => v
+--   throwKeyedMsg("S2IE0001",[x])
+getValueFromEnvironment(x,mode) ==
+  $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$env)) => v
+  $failure ^= (v := getValueFromSpecificEnvironment(x,mode,$e))   => v
+  null(v := coerceInt(objNew(x, ['Variable, x]), mode)) =>
+     throwKeyedMsg("S2IE0001",[x])
+  objValUnwrap v
+
+getValueFromSpecificEnvironment(id,mode,e) ==
+  PAIRP e =>
+    u := get(id,'value,e) =>
+      objMode(u) = $EmptyMode =>
+        systemErrorHere '"getValueFromSpecificEnvironment"
+      v := objValUnwrap u
+      mode isnt ['Mapping,:mapSig] => v
+      v isnt ['MAP,:.] => v
+      v' := coerceInt(u,mode)
+      null v' => throwKeyedMsg("S2IC0002",[objMode u,mode])
+      objValUnwrap v'
+
+    m := get(id,'mode,e) =>
+      -- See if we can make it into declared mode from symbolic form
+      -- For example, (x : P[x] I; x + 1)
+      if isPartialMode(m) then m' := resolveTM(['Variable,id],m)
+      else m' := m
+      m' and
+        (u := coerceInteractive(objNewWrap(id,['Variable,id]),m')) =>
+          objValUnwrap u
+
+      throwKeyedMsg("S2IE0002",[id,m])
+    $failure
+  $failure
+
+addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) ==
+  -- change proplist of var in e destructively
+  u := ASSQ(var,curContour) =>
+    RPLACD(u,proplist)
+    e
+  RPLAC(CAAR e,[[var,:proplist],:curContour])
+  e
+
+augProplistInteractive(proplist,prop,val) ==
+  u := ASSQ(prop,proplist) =>
+    RPLACD(u,val)
+    proplist
+  [[prop,:val],:proplist]
+
+getFlag x == get("--flags--",x,$e)
+
+putFlag(flag,value) ==
+  $e := put ("--flags--", flag, value, $e)
+
+getI(x,prop) == get(x,prop,$InteractiveFrame)
+
+putI(x,prop,val) == ($InteractiveFrame := put(x,prop,val,$InteractiveFrame))
+
+getIProplist x == getProplist(x,$InteractiveFrame)
+
+removeBindingI x ==
+  RPLAC(CAAR $InteractiveFrame,deleteAssocWOC(x,CAAR $InteractiveFrame))
+
+rempropI(x,prop) ==
+  id:=
+    atom x => x
+    first x
+  getI(id,prop) =>
+    recordNewValue(id,prop,NIL)
+    recordOldValue(id,prop,getI(id,prop))
+    $InteractiveFrame:= remprop(id,prop,$InteractiveFrame)
+
+remprop(x,prop,e) ==
+  u:= ASSOC(prop,pl:= getProplist(x,e)) =>
+    e:= addBinding(x,DELASC(first u,pl),e)
+    e
+  e
+
+fastSearchCurrentEnv(x,currentEnv) ==
+  u:= QLASSQ(x,CAR currentEnv) => u
+  while (currentEnv:= QCDR currentEnv) repeat
+    u:= QLASSQ(x,CAR currentEnv) => u
+
+putIntSymTab(x,prop,val,e) ==
+  null atom x => putIntSymTab(first x,prop,val,e)
+  pl0 := pl := search(x,e)
+  pl :=
+    null pl => [[prop,:val]]
+    u := ASSQ(prop,pl) =>
+      RPLACD(u,val)
+      pl
+    lp := LASTPAIR pl
+    u := [[prop,:val]]
+    RPLACD(lp,u)
+    pl
+  EQ(pl0,pl) => e
+  addIntSymTabBinding(x,pl,e)
+
+addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) ==
+  -- change proplist of var in e destructively
+  u := ASSQ(var,curContour) =>
+    RPLACD(u,proplist)
+    e
+  RPLAC(CAAR e,[[var,:proplist],:curContour])
+  e
+
+