Initial population.

1 files changed, 1202 insertions, 0 deletions

diff --git a/src/interp/i-spec2.boot.pamphlet b/src/interp/i-spec2.boot.pamphlet
new file mode 100644
index 00000000..8b16f053
--- /dev/null
+++ b/src/interp/i-spec2.boot.pamphlet
@@ -0,0 +1,1202 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/interp i-spec2.boot}
+\author{The Axiom Team}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+\begin{verbatim}
+Handlers for Special Forms (2 of 2)
+
+This file contains the functions which do type analysis and
+evaluation of special functions in the interpreter.
+Special functions are ones which are not defined in the algebra
+code, such as assignment, construct, COLLECT and declaration.
+
+Operators which require special handlers all have a LISP "up"
+property which is the name of the special handler, which is
+always the word "up" followed by the operator name.
+If an operator has this "up" property the handler is called
+automatically from bottomUp instead of general modemap selection.
+
+The up handlers are usually split into two pieces, the first is
+the up function itself, which performs the type analysis, and an
+"eval" function, which generates (and executes, if required) the
+code for the function.
+The up functions always take a single argument, which is the
+entire attributed tree for the operation, and return the modeSet
+of the node, which is a singleton list containing the type
+computed for the node.
+The eval functions can take any arguments deemed necessary.
+Actual evaluation is done if $genValue is true, otherwise code is
+generated.
+(See the function analyzeMap for other things that may affect
+what is generated in these functions.)
+
+These functions are required to do two things:
+  1) do a putValue on the operator vector with the computed value
+     of the node, which is a triple.  This is usually done in the
+     eval functions.
+  2) do a putModeSet on the operator vector with a list of the
+     computed type of the node.  This is usually done in the
+     up functions.
+
+There are several special modes used in these functions:
+  1) Void is the mode that should be used for all statements
+     that do not otherwise return values, such as declarations,
+     loops, IF-THEN's without ELSE's, etc..
+  2) $NoValueMode and $ThrowAwayMode used to be used in situations
+     where Void is now used, and are being phased out completely.
+\end{verbatim}
+\section{License}
+<<license>>=
+-- 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.
+
+@
+<<*>>=
+<<license>>
+
+-- Functions which require special handlers (also see end of file)
+
+--% Handlers for map definitions
+
+upDEF t ==
+  -- performs map definitions.  value is thrown away
+  t isnt [op,def,pred,.] => nil
+  v:=addDefMap(['DEF,:def],pred)
+  null(LISTP(def)) or null(def) =>
+    keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
+  mapOp := first def
+  if LISTP(mapOp) then
+    null mapOp =>
+      keyedSystemError("S2GE0016",['"upDEF",'"bad map definition"])
+    mapOp := first mapOp
+  put(mapOp,'value,v,$e)
+  putValue(op,objNew(voidValue(), $Void))
+  putModeSet(op,[$Void])
+
+--% Handler for package calling and $ constants
+
+upDollar t ==
+  -- Puts "dollar" property in atree node, and calls bottom up
+  t isnt [op,D,form] => nil
+  t2 := t
+  (not $genValue) and or/[CONTAINED(var,D) for var in $localVars] =>
+    keyedMsgCompFailure("S2IS0032",NIL)
+  EQ(D,'Lisp) => upLispCall(op,form)
+  if VECP D and (SIZE(D) > 0) then D := D.0
+  t := evaluateType unabbrev D
+  categoryForm? t =>
+    throwKeyedMsg("S2IE0012", [t])
+  f := getUnname form
+  if f = $immediateDataSymbol then
+    f := objValUnwrap coerceInteractive(getValue form,$OutputForm)
+    if f = '(construct) then f := "nil"
+  ATOM(form) and (f ^= $immediateDataSymbol) and
+    (u := findUniqueOpInDomain(op,f,t)) => u
+  f in '(One Zero true false nil) and constantInDomain?([f],t) =>
+    isPartialMode t => throwKeyedMsg("S2IS0020",NIL)
+    if $genValue then
+      val := wrap getConstantFromDomain([f],t)
+    else val := ['getConstantFromDomain,['LIST,MKQ f],MKQ t]
+    putValue(op,objNew(val,t))
+    putModeSet(op,[t])
+
+  nargs := #rest form
+
+  (ms := upDollarTuple(op, f, t, t2, rest form, nargs)) => ms
+
+  f ^= 'construct and null isOpInDomain(f,t,nargs) =>
+    throwKeyedMsg("S2IS0023",[f,t])
+  if (sig := findCommonSigInDomain(f,t,nargs)) then
+    for x in sig for y in form repeat
+      if x then putTarget(y,x)
+  putAtree(first form,'dollar,t)
+  ms := bottomUp form
+  f in '(One Zero) and PAIRP(ms) and CAR(ms) = $OutputForm =>
+    throwKeyedMsg("S2IS0021",[f,t])
+  putValue(op,getValue first form)
+  putModeSet(op,ms)
+
+
+upDollarTuple(op, f, t, t2, args, nargs) ==
+  -- this function tries to find a tuple function to use
+  nargs = 1 and getUnname first args = "Tuple" => NIL
+  nargs = 1 and (ms := bottomUp first args) and ms is [["Tuple",.]] => NIL
+  null (singles := isOpInDomain(f,t,1)) => NIL
+  tuple := NIL
+  for [[.,arg], :.] in singles while null tuple repeat
+    if arg is ['Tuple,.] then tuple := arg
+  null tuple => NIL
+  [.,D,form] := t2
+  newArg := [mkAtreeNode "Tuple",:args]
+  putTarget(newArg, tuple)
+  ms := bottomUp newArg
+  first ms ^= tuple => NIL
+  form := [first form, newArg]
+  putAtree(first form,'dollar,t)
+  ms := bottomUp form
+  putValue(op,getValue first form)
+  putModeSet(op,ms)
+
+upLispCall(op,t) ==
+  -- process $Lisp calls
+  if atom t then code:=getUnname t else
+    [lispOp,:argl]:= t
+    null functionp lispOp.0 =>
+      throwKeyedMsg("S2IS0024",[lispOp.0])
+    for arg in argl repeat bottomUp arg
+    code:=[getUnname lispOp,
+      :[getArgValue(arg,computedMode arg) for arg in argl]]
+  code :=
+    $genValue => wrap timedEVALFUN code
+    code
+  rt := '(SExpression)
+  putValue(op,objNew(code,rt))
+  putModeSet(op,[rt])
+
+--% Handlers for equation
+
+upequation tree ==
+  -- only handle this if there is a target of Boolean
+  -- this should speed things up a bit
+  tree isnt [op,lhs,rhs] => NIL
+  $Boolean ^= getTarget(op) => NIL
+  null VECP op => NIL
+  -- change equation into '='
+  op.0 := "="
+  bottomUp tree
+
+--% Handler for error
+
+uperror t ==
+  -- when compiling a function, this merely inserts another argument
+  -- which is the name of the function.
+  not $compilingMap => NIL
+  t isnt [op,msg] => NIL
+  msgMs := bottomUp msg
+  msgMs isnt [=$String] => NIL
+  RPLACD(t,[mkAtree object2String $mapName,msg])
+  bottomUp t
+
+--% Handlers for free and local
+
+upfree t ==
+  putValue(t,objNew('(voidValue),$Void))
+  putModeSet(t,[$Void])
+
+uplocal t ==
+  putValue(t,objNew('(voidValue),$Void))
+  putModeSet(t,[$Void])
+
+upfreeWithType(var,type) ==
+  sayKeyedMsg("S2IS0055",['"free",var])
+  var
+
+uplocalWithType(var,type) ==
+  sayKeyedMsg("S2IS0055",['"local",var])
+  var
+
+--% Handlers for has
+
+uphas t ==
+  t isnt [op,type,prop] => nil
+  -- handler for category and attribute queries
+  type :=
+    isLocalVar(type) => ['unabbrev, type]
+    MKQ unabbrev type
+  catCode :=
+    prop := unabbrev prop
+    evaluateType0 prop => ['evaluateType, MKQ prop]
+    MKQ prop
+  code:=['newHasTest,['evaluateType, type], catCode]
+  if $genValue then code := wrap timedEVALFUN code
+  putValue(op,objNew(code,$Boolean))
+  putModeSet(op,[$Boolean])
+
+--hasTest(a,b) ==
+--  newHasTest(a,b)  --see NRUNFAST BOOT
+
+--% Handlers for IF
+
+upIF t ==
+  t isnt [op,cond,a,b] => nil
+  bottomUpPredicate(cond,'"if/when")
+  $genValue => interpIF(op,cond,a,b)
+  compileIF(op,cond,a,b,t)
+
+compileIF(op,cond,a,b,t) ==
+  -- type analyzer for compiled case where types of both branches of
+  --  IF are resolved.
+  ms1 := bottomUp a
+  [m1] := ms1
+  b = 'noBranch =>
+    evalIF(op,rest t,$Void)
+    putModeSet(op,[$Void])
+  b = 'noMapVal =>
+    -- if this was a return statement, we take the mode to be that
+    -- of what is being returned.
+    if getUnname a = 'return then
+      ms1 := bottomUp CADR a
+      [m1] := ms1
+    evalIF(op,rest t,m1)
+    putModeSet(op,ms1)
+  ms2 := bottomUp b
+  [m2] := ms2
+  m:=
+    m2=m1 => m1
+    m2 = $Exit => m1
+    m1 = $Exit => m2
+    if EQCAR(m1,'Symbol) then
+      m1:=getMinimalVarMode(getUnname a,$declaredMode)
+    if EQCAR(m2,'Symbol) then
+      m2:=getMinimalVarMode(getUnname b,$declaredMode)
+    (r := resolveTTAny(m2,m1)) => r
+    rempropI($mapName,'localModemap)
+    rempropI($mapName,'localVars)
+    rempropI($mapName,'mapBody)
+    throwKeyedMsg("S2IS0026",[m2,m1])
+  evalIF(op,rest t,m)
+  putModeSet(op,[m])
+
+evalIF(op,[cond,a,b],m) ==
+  -- generate code form compiled IF
+  elseCode:=
+    b='noMapVal =>
+      [[MKQ true, ['throwKeyedMsg,MKQ "S2IM0018",
+        ['CONS,MKQ object2Identifier $mapName,NIL]]]]
+    b='noBranch =>
+      $lastLineInSEQ => [[MKQ true,['voidValue]]]
+      NIL
+    [[MKQ true,genIFvalCode(b,m)]]
+  code:=['COND,[getArgValue(cond,$Boolean),
+    genIFvalCode(a,m)],:elseCode]
+  triple:= objNew(code,m)
+  putValue(op,triple)
+
+genIFvalCode(t,m) ==
+  -- passes type information down braches of IF statement
+  --  So that coercions can be performed on data at branches of IF.
+  m1 := computedMode t
+  m1=m => getArgValue(t,m)
+  code:=objVal getValue t
+  IFcodeTran(code,m,m1)
+
+IFcodeTran(code,m,m1) ==
+  -- coerces values at branches of IF
+  null code => code
+  code is ['spadThrowBrightly,:.] => code
+  m1 = $Exit => code
+  code isnt ['COND,[p1,a1],[''T,a2]] =>
+    m = $Void => code
+    code' := coerceInteractive(objNew(quote2Wrapped code,m1),m) =>
+      wrapped2Quote objVal code'
+    throwKeyedMsgCannotCoerceWithValue(quote2Wrapped code,m1,m)
+  a1:=IFcodeTran(a1,m,m1)
+  a2:=IFcodeTran(a2,m,m1)
+  ['COND,[p1,a1],[''T,a2]]
+
+interpIF(op,cond,a,b) ==
+  -- non-compiled version of IF type analyzer.  Doesn't resolve accross
+  --  branches of the IF.
+  val:= getValue cond
+  val:= coerceInteractive(val,$Boolean) =>
+    objValUnwrap(val) => upIFgenValue(op,a)
+    EQ(b,'noBranch) =>
+      putValue(op,objNew(voidValue(), $Void))
+      putModeSet(op,[$Void])
+    upIFgenValue(op,b)
+  throwKeyedMsg("S2IS0031",NIL)
+
+upIFgenValue(op,tree) ==
+  -- evaluates tree and transfers the results to op
+  ms:=bottomUp tree
+  val:= getValue tree
+  putValue(op,val)
+  putModeSet(op,ms)
+
+--% Handlers for is
+
+upis t ==
+  t isnt [op,a,pattern] => nil
+  $opIsIs : local := true
+  upisAndIsnt t
+
+upisnt t ==
+  t isnt [op,a,pattern] => nil
+  $opIsIs : local := nil
+  upisAndIsnt t
+
+upisAndIsnt(t:=[op,a,pattern]) ==
+  -- handler for "is" pattern matching
+  mS:= bottomUp a
+  mS isnt [m] =>
+    keyedSystemError("S2GE0016",['"upisAndIsnt",'"non-unique modeset"])
+  putPvarModes(removeConstruct pattern,m)
+  evalis(op,rest t,m)
+  putModeSet(op,[$Boolean])
+
+putPvarModes(pattern,m) ==
+  -- Puts the modes for the pattern variables into $env
+  m isnt ['List,um] => throwKeyedMsg("S2IS0030",NIL)
+  for pvar in pattern repeat
+    IDENTP pvar => (null (pvar=$quadSymbol)) and put(pvar,'mode,um,$env)
+    pvar is ['_:,var] =>
+      null (var=$quadSymbol) and put(var,'mode,m,$env)
+    pvar is ['_=,var] =>
+      null (var=$quadSymbol) and put(var,'mode,um,$env)
+    putPvarModes(pvar,um)
+
+evalis(op,[a,pattern],mode) ==
+  -- actually handles is and isnt
+  if $opIsIs
+    then fun := 'evalIsPredicate
+    else fun := 'evalIsntPredicate
+  if isLocalPred pattern then
+    code:= compileIs(a,pattern)
+  else code:=[fun,getArgValue(a,mode),
+    MKQ pattern,MKQ mode]
+  triple:=
+    $genValue => objNewWrap(timedEVALFUN code,$Boolean)
+    objNew(code,$Boolean)
+  putValue(op,triple)
+
+isLocalPred pattern ==
+  -- returns true if the is predicate is to be compiled
+  for pat in pattern repeat
+    IDENTP pat and isLocalVar(pat) => return true
+    pat is ['_:,var] and isLocalVar(var) => return true
+    pat is ['_=,var] and isLocalVar(var) => return true
+
+compileIs(val,pattern) ==
+  -- produce code for compiled "is" predicate.  makes pattern variables
+  --  into local variables of the function
+  vars:= NIL
+  for pat in CDR pattern repeat
+    IDENTP(pat) and isLocalVar(pat) => vars:=[pat,:vars]
+    pat is ['_:,var] => vars:= [var,:vars]
+    pat is ['_=,var] => vars:= [var,:vars]
+  predCode:=['LET,g:=GENSYM(),['isPatternMatch,
+    getArgValue(val,computedMode val),MKQ removeConstruct pattern]]
+  for var in REMDUP vars repeat
+    assignCode:=[['LET,var,['CDR,['ASSQ,MKQ var,g]]],:assignCode]
+  null $opIsIs =>
+    ['COND,[['EQ,predCode,MKQ 'failed],['SEQ,:assignCode,MKQ 'T]]]
+  ['COND,[['NOT,['EQ,predCode,MKQ 'failed]],['SEQ,:assignCode,MKQ 'T]]]
+
+evalIsPredicate(value,pattern,mode) ==
+  --This function pattern matches value to pattern, and returns
+  --true if it matches, and false otherwise.  As a side effect
+  --if the pattern matches then the bindings given in the pattern
+  --are made
+  pattern:= removeConstruct pattern
+  ^((valueAlist:=isPatternMatch(value,pattern))='failed) =>
+    for [id,:value] in valueAlist repeat
+      evalLETchangeValue(id,objNewWrap(value,get(id,'mode,$env)))
+    true
+  false
+
+evalIsntPredicate(value,pattern,mode) ==
+  evalIsPredicate(value,pattern,mode) => NIL
+  'TRUE
+
+removeConstruct pat ==
+  -- removes the "construct" from the beginning of patterns
+  if pat is ['construct,:p] then pat:=p
+  if pat is ['cons, a, b] then pat := [a, ['_:, b]]
+  atom pat => pat
+  RPLACA(pat,removeConstruct CAR pat)
+  RPLACD(pat,removeConstruct CDR pat)
+  pat
+
+isPatternMatch(l,pats) ==
+  -- perform the actual pattern match
+  $subs: local := NIL
+  isPatMatch(l,pats)
+  $subs
+
+isPatMatch(l,pats) ==
+  null pats =>
+    null l => $subs
+    $subs:='failed
+  null l =>
+    null pats => $subs
+    pats is [['_:,var]] =>
+      $subs := [[var],:$subs]
+    $subs:='failed
+  pats is [pat,:restPats] =>
+    IDENTP pat =>
+      $subs:=[[pat,:first l],:$subs]
+      isPatMatch(rest l,restPats)
+    pat is ['_=,var] =>
+      p:=ASSQ(var,$subs) =>
+        CAR l = CDR p => isPatMatch(rest l, restPats)
+        $subs:='failed
+      $subs:='failed
+    pat is ['_:,var] =>
+      n:=#restPats
+      m:=#l-n
+      m<0 => $subs:='failed
+      ZEROP n => $subs:=[[var,:l],:$subs]
+      $subs:=[[var,:[x for x in l for i in 1..m]],:$subs]
+      isPatMatch(DROP(m,l),restPats)
+    isPatMatch(first l,pat) = 'failed => 'failed
+    isPatMatch(rest l,restPats)
+  keyedSystemError("S2GE0016",['"isPatMatch",
+     '"unknown form of is predicate"])
+
+--% Handler for iterate
+
+upiterate t ==
+  null $repeatBodyLabel => throwKeyedMsg("S2IS0029",['"iterate"])
+  $iterateCount := $iterateCount + 1
+  code := ['THROW,$repeatBodyLabel,'(voidValue)]
+  $genValue => THROW(eval $repeatBodyLabel,voidValue())
+  putValue(t,objNew(code,$Void))
+  putModeSet(t,[$Void])
+
+--% Handler for break
+
+upbreak t ==
+  t isnt [op,.] => nil
+  null $repeatLabel => throwKeyedMsg("S2IS0029",['"break"])
+  $breakCount := $breakCount + 1
+  code := ['THROW,$repeatLabel,'(voidValue)]
+  $genValue => THROW(eval $repeatLabel,voidValue())
+  putValue(op,objNew(code,$Void))
+  putModeSet(op,[$Void])
+
+--% Handlers for LET
+
+upLET t ==
+  -- analyzes and evaluates the righthand side, and does the variable
+  -- binding
+  t isnt [op,lhs,rhs] => nil
+  $declaredMode: local := NIL
+  PAIRP lhs =>
+    var:= getUnname first lhs
+    var = 'construct => upLETWithPatternOnLhs t
+    var = 'QUOTE => throwKeyedMsg("S2IS0027",['"A quoted form"])
+    upLETWithFormOnLhs(op,lhs,rhs)
+  var:= getUnname lhs
+  var = $immediateDataSymbol =>
+    -- following will be immediate data, so probably ok to not
+    -- specially format it
+    obj := objValUnwrap coerceInteractive(getValue lhs,$OutputForm)
+    throwKeyedMsg("S2IS0027",[obj])
+  var in '(% %%) =>               -- for history
+    throwKeyedMsg("S2IS0027",[var])
+  (IDENTP var) and not (var in '(true false elt QUOTE)) =>
+    var ^= (var' := unabbrev(var)) =>  -- constructor abbreviation
+      throwKeyedMsg("S2IS0028",[var,var'])
+    if get(var,'isInterpreterFunction,$e) then
+      putHist(var,'isInterpreterFunction,false,$e)
+      sayKeyedMsg("S2IS0049",['"Function",var])
+    else if get(var,'isInterpreterRule,$e) then
+      putHist(var,'isInterpreterRule,false,$e)
+      sayKeyedMsg("S2IS0049",['"Rule",var])
+    not isTupleForm(rhs) and (m := isType rhs) => upLETtype(op,lhs,m)
+    transferPropsToNode(var,lhs)
+    if ( m:= getMode(lhs) ) then
+      $declaredMode := m
+      putTarget(rhs,m)
+    if (val := getValue lhs) and (objMode val = $Boolean) and
+      getUnname(rhs) = 'equation then putTarget(rhs,$Boolean)
+    (rhsMs:= bottomUp rhs) = [$Void] =>
+      throwKeyedMsg("S2IS0034",[var])
+    val:=evalLET(lhs,rhs)
+    putValue(op,val)
+    putModeSet(op,[objMode(val)])
+  throwKeyedMsg("S2IS0027",[var])
+
+isTupleForm f ==
+    -- have to do following since "Tuple" is an internal form name
+    getUnname f ^= "Tuple" => false
+    f is [op,:args] and VECP(op) and getUnname(op) = "Tuple" =>
+        #args ^= 1 => true
+        isTupleForm first args => true
+        isType first args => false
+        true
+    false
+
+evalLET(lhs,rhs) ==
+  -- lhs is a vector for a variable, and rhs is the evaluated atree
+  --  for the value which is coerced to the mode of lhs
+  $useConvertForCoercions: local := true
+  v' := (v:= getValue rhs)
+  ((not getMode lhs) and (getModeSet rhs is [.])) or
+    get(getUnname lhs,'autoDeclare,$env) =>
+      v:=
+        $genValue => v
+        objNew(wrapped2Quote objVal v,objMode v)
+      evalLETput(lhs,v)
+  t1:= objMode v
+  t2' := (t2 := getMode lhs)
+  value:=
+    t1 = t2 =>
+      $genValue => v
+      objNew(wrapped2Quote objVal v,objMode v)
+    if isPartialMode t2 then
+      if EQCAR(t1,'Symbol) and $declaredMode then
+        t1:= getMinimalVarMode(objValUnwrap v,$declaredMode)
+      t' := t2
+      null (t2 := resolveTM(t1,t2)) =>
+        if not t2 then t2 := t'
+        throwKeyedMsg("S2IS0035",[t1,t2])
+    null (v := getArgValue(rhs,t2)) =>
+      isWrapped(objVal v') and (v2:=coerceInteractive(v',$OutputForm)) =>
+        throwKeyedMsg("S2IS0036",[objValUnwrap v2,t2])
+      throwKeyedMsg("S2IS0037",[t2])
+    t2 and objNew(($genValue => wrap timedEVALFUN v ; v),t2)
+  value => evalLETput(lhs,value)
+  throwKeyedMsgCannotCoerceWithValue(objVal v,t1,getMode lhs)
+
+evalLETput(lhs,value) ==
+  -- put value into the cell for lhs
+  name:= getUnname lhs
+  if not $genValue then
+    code:=
+      isLocalVar(name) =>
+        om := objMode(value)
+        dm := get(name,'mode,$env)
+        dm and not ((om = dm) or isSubDomain(om,dm) or
+          isSubDomain(dm,om)) =>
+            compFailure ['"   The type of the local variable",
+              :bright name,'"has changed in the computation."]
+        if dm and isSubDomain(dm,om) then put(name,'mode,om,$env)
+        ['LET,name,objVal value,$mapName]
+               -- $mapName is set in analyzeMap
+      om := objMode value
+      dm := get(name, 'mode, $env) or objMode(get(name, 'value, $e))
+      dm and (null $compilingMap) and not(om = dm) and not(isSubDomain(om, dm)) =>
+        THROW('loopCompiler,'tryInterpOnly)
+      ['unwrap,['evalLETchangeValue,MKQ name,
+        objNewCode(['wrap,objVal value],objMode value)]]
+    value:= objNew(code,objMode value)
+    isLocalVar(name) =>
+      if not get(name,'mode,$env) then put(name,'autoDeclare,'T,$env)
+      put(name,'mode,objMode(value),$env)
+    put(name,'automode,objMode(value),$env)
+  $genValue and evalLETchangeValue(name,value)
+  putValue(lhs,value)
+
+upLETWithPatternOnLhs(t := [op,pattern,a]) ==
+  $opIsIs : local := true
+  [m] := bottomUp a
+  putPvarModes(pattern,m)
+  object := evalis(op,[a,pattern],m)
+  -- have to change code to return value of a
+  failCode :=
+    ['spadThrowBrightly,['concat,
+      '"   Pattern",['QUOTE,bright form2String pattern],
+        '"is not matched in assignment to right-hand side."]]
+  if $genValue
+    then
+      null objValUnwrap object => eval failCode
+      putValue(op,getValue a)
+    else
+      code := ['COND,[objVal object,objVal getValue a],[''T,failCode]]
+      putValue(op,objNew(code,m))
+  putModeSet(op,[m])
+
+evalLETchangeValue(name,value) ==
+  -- write the value of name into the environment, clearing dependent
+  --  maps if its type changes from its last value
+  localEnv := PAIRP $env
+  clearCompilationsFlag :=
+    val:= (localEnv and get(name,'value,$env)) or get(name,'value,$e)
+    null val =>
+      not ((localEnv and get(name,'mode,$env)) or get(name,'mode,$e))
+    objMode val ^= objMode(value)
+  if clearCompilationsFlag then
+    clearDependencies(name,true)
+  if localEnv and isLocalVar(name)
+    then $env:= putHist(name,'value,value,$env)
+    else putIntSymTab(name,'value,value,$e)
+  objVal value
+
+upLETWithFormOnLhs(op,lhs,rhs) ==
+  -- bottomUp for assignment to forms (setelt, table or tuple)
+  lhs' := getUnnameIfCan lhs
+  rhs' := getUnnameIfCan rhs
+  lhs' = 'Tuple =>
+    rhs' ^= 'Tuple => throwKeyedMsg("S2IS0039",NIL)
+    #(lhs) ^= #(rhs) => throwKeyedMsg("S2IS0038",NIL)
+    -- generate a sequence of assignments, using local variables
+    -- to first hold the assignments so that things like
+    -- (t1,t2) := (t2,t1) will work.
+    seq := []
+    temps := [GENSYM() for l in rest lhs]
+    for lvar in temps repeat mkLocalVar($mapName,lvar)
+    for l in reverse rest lhs for t in temps repeat
+      transferPropsToNode(getUnname l,l)
+      let := mkAtreeNode 'LET
+      t'  := mkAtreeNode t
+      if m := getMode(l) then putMode(t',m)
+      seq := cons([let,l,t'],seq)
+    for t in temps for r in reverse rest rhs
+      for l in reverse rest lhs repeat
+        let := mkAtreeNode 'LET
+        t'  := mkAtreeNode t
+        if m := getMode(l) then putMode(t',m)
+        seq := cons([let,t',r],seq)
+    seq := cons(mkAtreeNode 'SEQ,seq)
+    ms := bottomUp seq
+    putValue(op,getValue seq)
+    putModeSet(op,ms)
+  rhs' = 'Tuple => throwKeyedMsg("S2IS0039",NIL)
+  tree:= seteltable(lhs,rhs) => upSetelt(op,lhs,tree)
+  throwKeyedMsg("S2IS0060", NIL)
+--  upTableSetelt(op,lhs,rhs)
+
+seteltable(lhs is [f,:argl],rhs) ==
+  -- produces the setelt form for trees such as "l.2:= 3"
+  null (g := getUnnameIfCan f) => NIL
+  EQ(g,'elt) => altSeteltable [:argl, rhs]
+  get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL
+  transferPropsToNode(g,f)
+  getValue(lhs) or getMode(lhs) =>
+    f is [f',:argl'] => altSeteltable [f',:argl',:argl,rhs]
+    altSeteltable [:lhs,rhs]
+  NIL
+
+altSeteltable args ==
+    for x in args repeat bottomUp x
+    newOps := [mkAtreeNode "setelt", mkAtreeNode "set!"]
+    form := NIL
+
+    -- first look for exact matches for any of the possibilities
+    while ^form for newOp in newOps  repeat
+        if selectMms(newOp, args, NIL) then form := [newOp, :args]
+
+    -- now try retracting arguments after the first
+    while ^form and ( "and"/[retractAtree(a) for a in rest args] ) repeat
+        while ^form for newOp in newOps  repeat
+            if selectMms(newOp, args, NIL) then form := [newOp, :args]
+
+    form
+
+
+upSetelt(op,lhs,tree) ==
+  -- type analyzes implicit setelt forms
+  var:=opOf lhs
+  transferPropsToNode(getUnname var,var)
+  if (m1:=getMode var) then $declaredMode:= m1
+  if m1 or ((v1 := getValue var) and (m1 := objMode v1)) then
+    putModeSet(var,[m1])
+  ms := bottomUp tree
+  putValue(op,getValue tree)
+  putModeSet(op,ms)
+
+upTableSetelt(op,lhs is [htOp,:args],rhs) ==
+  -- called only for undeclared, uninitialized table setelts
+  ("*" = (PNAME getUnname htOp).0) and (1 ^= # args) =>
+    throwKeyedMsg("S2IS0040",NIL)
+  # args ^= 1 =>
+    throwKeyedMsg("S2IS0041",[[getUnname htOp,'".[",
+      getUnname first args,
+        ['",",getUnname arg for arg in rest args],'"]"]])
+  keyMode := '(Any)
+  putMode (htOp,['Table,keyMode,'(Any)])
+  -- if we are to use a new table, we must call the "table"
+  -- function to give it an initial value.
+  bottomUp [mkAtreeNode 'LET,htOp,[mkAtreeNode 'table]]
+  tableCode := objVal getValue htOp
+  r := upSetelt(op, lhs, [mkAtreeNode 'setelt,:lhs,rhs])
+  $genValue => r
+  -- construct code
+  t := getValue op
+  putValue(op,objNew(['PROGN,tableCode,objVal t],objMode t))
+  r
+
+isType t ==
+  -- Returns the evaluated type if t is a tree representing a type,
+  -- and NIL otherwise
+   op:=opOf t
+   VECP op =>
+     isMap(op:= getUnname op) => NIL
+     op = 'Mapping =>
+       argTypes := [isType type for type in rest t]
+       "or"/[null type for type in argTypes] => nil
+       ['Mapping, :argTypes]
+     isLocalVar(op) => NIL
+     d := isDomainValuedVariable op => d
+     type:=
+       -- next line handles subscripted vars
+         (abbreviation?(op) or (op = 'typeOf) or
+           constructor?(op) or (op in '(Record Union Enumeration))) and
+             unabbrev unVectorize t
+     type and evaluateType type
+   d := isDomainValuedVariable op => d
+   NIL
+
+upLETtype(op,lhs,type) ==
+  -- performs type assignment
+  opName:= getUnname lhs
+  (not $genValue) and or/[CONTAINED(var,type) for var in $localVars] =>
+    compFailure ['"   Cannot compile type assignment to",:bright opName]
+  mode :=
+    if isPartialMode type then '(Mode)
+    else if categoryForm?(type) then '(SubDomain (Domain))
+         else '(Domain)
+  val:= objNew(type,mode)
+  if isLocalVar(opName) then put(opName,'value,val,$env)
+  else putHist(opName,'value,val,$e)
+  putValue(op,val)
+  -- have to fix the following
+  putModeSet(op,[mode])
+
+assignSymbol(symbol, value, domain) ==
+-- Special function for binding an interpreter variable from within algebra
+-- code.  Does not do the assignment and returns nil, if the variable is
+-- already assigned
+  val := get(symbol, 'value, $e) => nil
+  obj := objNew(wrap value, devaluate domain)
+  put(symbol, 'value, obj, $e)
+  true
+
+--% Handler for Interpreter Macros
+
+getInterpMacroNames() ==
+  names := [n for [n,:.] in $InterpreterMacroAlist]
+  if (e := CAAR $InteractiveFrame) and (m := ASSOC("--macros--",e)) then
+    names := append(names,[n for [n,:.] in CDR m])
+  MSORT names
+
+isInterpMacro name ==
+  -- look in local and then global environment for a macro
+  null IDENTP name => NIL
+  name in $specialOps => NIL
+  (m := get("--macros--",name,$env)) => m
+  (m := get("--macros--",name,$e))   => m
+  (m := get("--macros--",name,$InteractiveFrame))   => m
+  -- $InterpreterMacroAlist will probably be phased out soon
+  (sv := ASSOC(name,$InterpreterMacroAlist)) => CONS(NIL,CDR sv)
+  NIL
+
+--% Handlers for prefix QUOTE
+
+upQUOTE t ==
+  t isnt [op,expr] => NIL
+  ms:= list
+    m:= getBasicMode expr => m
+    IDENTP expr =>
+--    $useSymbolNotVariable => $Symbol
+      ['Variable,expr]
+    $OutputForm
+  evalQUOTE(op,[expr],ms)
+  putModeSet(op,ms)
+
+evalQUOTE(op,[expr],[m]) ==
+  triple:=
+    $genValue => objNewWrap(expr,m)
+    objNew(['QUOTE,expr],m)
+  putValue(op,triple)
+
+--% Handler for pretend
+
+uppretend t ==
+  t isnt [op,expr,type] => NIL
+  mode := evaluateType unabbrev type
+  not isValidType(mode) => throwKeyedMsg("S2IE0004",[mode])
+  bottomUp expr
+  putValue(op,objNew(objVal getValue expr,mode))
+  putModeSet(op,[mode])
+
+--% Handlers for REDUCE
+
+getReduceFunction(op,type,result, locale) ==
+  -- return the function cell for operation with the signature
+  --  (type,type) -> type, possible from locale
+  if type is ['Variable,var] then
+    args := [arg := mkAtreeNode var,arg]
+    putValue(arg,objNewWrap(var,type))
+  else
+    args := [arg := mkAtreeNode "%1",arg]
+    if type=$Symbol then putValue(arg,objNewWrap("%1",$Symbol))
+  putModeSet(arg,[type])
+  vecOp:=mkAtreeNode op
+  transferPropsToNode(op,vecOp)
+  if locale then putAtree(vecOp,'dollar,locale)
+  mmS:= selectMms(vecOp,args,result)
+  mm:= or/[mm for (mm:=[[.,:sig],fun,cond]) in mmS |
+    (isHomogeneousArgs sig) and and/[null c for c in cond]]
+  null mm => 'failed
+  [[dc,:sig],fun,:.]:=mm
+  dc='local => [MKQ [fun,:'local],:CAR sig]
+  dcVector := evalDomain dc
+  $compilingMap =>
+    k := NRTgetMinivectorIndex(
+      NRTcompiledLookup(op,sig,dcVector),op,sig,dcVector)
+    ['ELT,"$$$",k]  --$$$ denotes minivector
+  env:=
+    NRTcompiledLookup(op,sig,dcVector)
+  MKQ env
+
+isHomogeneous sig ==
+  --return true if sig describes a homogeneous binary operation
+  sig.0=sig.1 and sig.1=sig.2
+
+isHomogeneousArgs sig ==
+  --return true if sig describes a homogeneous binary operation
+  sig.1=sig.2
+
+--% Handlers for REPEAT
+
+transformREPEAT [:itrl,body] ==
+  -- syntactic transformation of repeat iterators, called from mkAtree2
+  iterList:=[:iterTran1 for it in itrl] where iterTran1 ==
+    it is ['STEP,index,lower,step,:upperList] =>
+      [['STEP,index,mkAtree1 lower,mkAtree1 step,:[mkAtree1 upper
+        for upper in upperList]]]
+    it is ['IN,index,s] =>
+      [['IN,index,mkAtree1 s]]
+    it is ['ON,index,s] =>
+      [['IN,index,mkAtree1 ['tails,s]]]
+    it is ['WHILE,b] =>
+      [['WHILE,mkAtree1 b]]
+    it is ['_|,pred] =>
+      [['SUCHTHAT,mkAtree1 pred]]
+    it is [op,:.] and (op in '(VALUE UNTIL)) => nil
+  bodyTree:=mkAtree1 body
+  iterList:=NCONC(iterList,[:iterTran2 for it in itrl]) where iterTran2 ==
+    it is ['STEP,:.] => nil
+    it is ['IN,:.] => nil
+    it is ['ON,:.] => nil
+    it is ['WHILE,:.] => nil
+    it is [op,b] and (op in '(UNTIL VALUE)) =>
+      [[op,mkAtree1 b]]
+    it is ['_|,pred] => nil
+    keyedSystemError("S2GE0016",
+      ['"transformREPEAT",'"Unknown type of iterator"])
+  [:iterList,bodyTree]
+
+upREPEAT t ==
+  -- REPEATS always return void() of Void
+  -- assures throw to interpret-code mode goes to outermost loop
+  $repeatLabel : local := MKQ GENSYM()
+  $breakCount  : local := 0
+  $repeatBodyLabel : local := MKQ GENSYM()
+  $iterateCount    : local := 0
+  $compilingLoop => upREPEAT1 t
+  upREPEAT0 t
+
+upREPEAT0 t ==
+  -- sets up catch point for interp-only mode
+  $compilingLoop: local := true
+  ms := CATCH('loopCompiler,upREPEAT1 t)
+  ms = 'tryInterpOnly => interpOnlyREPEAT t
+  ms
+
+upREPEAT1 t ==
+  -- repeat loop handler with compiled body
+  -- see if it has the expected form
+  t isnt [op,:itrl,body] => NIL
+  -- determine the mode of the repeat loop. At the moment, if there
+  -- there are no iterators and there are no "break" statements, then
+  -- the return type is Exit, otherwise Void.
+  repeatMode :=
+    null(itrl) and ($breakCount=0) => $Void
+    $Void
+
+  -- if interpreting, go do that
+  $interpOnly => interpREPEAT(op,itrl,body,repeatMode)
+
+  -- analyze iterators and loop body
+  upLoopIters itrl
+  bottomUpCompile body
+
+  -- now that the body is analyzed, we should know everything that
+  -- is in the UNTIL clause
+  for itr in itrl repeat
+    itr is ['UNTIL, pred] => bottomUpCompilePredicate(pred,'"until")
+
+  -- now go do it
+  evalREPEAT(op,rest t,repeatMode)
+  putModeSet(op,[repeatMode])
+
+evalREPEAT(op,[:itrl,body],repeatMode) ==
+  -- generate code for loop
+  bodyMode := computedMode body
+  bodyCode := getArgValue(body,bodyMode)
+  if $iterateCount > 0 then
+    bodyCode := ['CATCH,$repeatBodyLabel,bodyCode]
+  code := ['REPEAT,:[evalLoopIter itr for itr in itrl], bodyCode]
+  if repeatMode = $Void then code := ['OR,code,'(voidValue)]
+  code := timedOptimization code
+  if $breakCount > 0 then code := ['CATCH,$repeatLabel,code]
+  val:=
+    $genValue =>
+      timedEVALFUN code
+      objNewWrap(voidValue(),repeatMode)
+    objNew(code,repeatMode)
+  putValue(op,val)
+
+interpOnlyREPEAT t ==
+  -- interpret-code mode call to upREPEAT
+  $genValue: local := true
+  $interpOnly: local := true
+  upREPEAT1 t
+
+interpREPEAT(op,itrl,body,repeatMode) ==
+  -- performs interpret-code repeat
+  $indexVars: local := NIL
+  $indexTypes: local := NIL
+  code :=
+      -- we must insert a CATCH for the iterate clause
+      ['REPEAT,:[interpIter itr for itr in itrl],
+        ['CATCH,$repeatBodyLabel,interpLoop(body,$indexVars,
+          $indexTypes,nil)]]
+  SPADCATCH(eval $repeatLabel,timedEVALFUN code)
+  val:= objNewWrap(voidValue(),repeatMode)
+  putValue(op,val)
+  putModeSet(op,[repeatMode])
+
+interpLoop(expr,indexList,indexTypes,requiredType) ==
+  -- generates code for interp-only repeat body
+  ['interpLoopIter,MKQ expr,MKQ indexList,['LIST,:indexList],
+    MKQ indexTypes, MKQ requiredType]
+
+interpLoopIter(exp,indexList,indexVals,indexTypes,requiredType) ==
+  -- call interpreter on exp with loop vars in indexList with given
+  --  values and types, requiredType is used from interpCOLLECT
+  --  to indicate the required type of the result
+  emptyAtree exp
+  for i in indexList for val in indexVals for type in indexTypes repeat
+    put(i,'value,objNewWrap(val,type),$env)
+  bottomUp exp
+  v:= getValue exp
+  val :=
+    null requiredType => v
+    coerceInteractive(v,requiredType)
+  null val =>
+    throwKeyedMsgCannotCoerceWithValue(objVal v,objMode v,requiredType)
+  objValUnwrap val
+
+--% Handler for return
+
+upreturn t ==
+  -- make sure we are in a user function
+  t isnt [op,val] => NIL
+  (null $compilingMap) and (null $interpOnly) =>
+    throwKeyedMsg("S2IS0047",NIL)
+  if $mapTarget then putTarget(val,$mapTarget)
+  bottomUp val
+  if $mapTarget
+    then
+      val' := getArgValue(val, $mapTarget)
+      m := $mapTarget
+    else
+      val' := wrapped2Quote objVal getValue val
+      m := computedMode val
+  cn := mapCatchName $mapName
+  $mapReturnTypes := insert(m, $mapReturnTypes)
+  $mapThrowCount := $mapThrowCount + 1
+  -- if $genValue then we are interpreting the map
+  $genValue => THROW(cn,objNewWrap(removeQuote val',m))
+  putValue(op,objNew(['THROW,MKQ cn,val'],m))
+  putModeSet(op,[$Exit])
+
+--% Handler for SEQ
+
+upSEQ u ==
+  -- assumes that exits were translated into if-then-elses
+  -- handles flat SEQs and embedded returns
+  u isnt [op,:args] => NIL
+  if (target := getTarget(op)) then putTarget(last args, target)
+  for x in args repeat bottomUp x
+  null (m := computedMode last args) =>
+    keyedSystemError("S2GE0016",['"upSEQ",
+      '"last line of SEQ has no mode"])
+  evalSEQ(op,args,m)
+  putModeSet(op,[m])
+
+evalSEQ(op,args,m) ==
+  -- generate code for SEQ
+  [:argl,last] := args
+  val:=
+    $genValue => getValue last
+    bodyCode := nil
+    for x in args repeat
+      (m1 := computedMode x) and (m1 ^= '$ThrowAwayMode) =>
+        (av := getArgValue(x,m1)) ^= voidValue() =>
+          bodyCode := [av,:bodyCode]
+    code:=
+      bodyCode is [c] => c
+      ['PROGN,:reverse bodyCode]
+    objNew(code,m)
+  putValue(op,val)
+
+--% Handlers for Tuple
+
+upTuple t ==
+  --Computes the common mode set of the construct by resolving across
+  --the argument list, and evaluating
+  t isnt [op,:l] => nil
+  dol := getAtree(op,'dollar)
+  tar := getTarget(op) or dol
+  null l => upNullTuple(op,l,tar)
+  isTaggedUnion tar => upTaggedUnionConstruct(op,l,tar)
+  aggs := '(List)
+  if tar and PAIRP(tar) and ^isPartialMode(tar) then
+    CAR(tar) in aggs =>
+      ud := CADR tar
+      for x in l repeat if not getTarget(x) then putTarget(x,ud)
+    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]
+  eltTypes := replaceSymbols([first x for x in argModeSetList],l)
+  if not isPartialMode(tar) and tar is ['Tuple,ud] then
+    mode := ['Tuple, resolveTypeListAny cons(ud,eltTypes)]
+  else mode := ['Tuple, resolveTypeListAny eltTypes]
+  if isPartialMode tar then tar:=resolveTM(mode,tar)
+  evalTuple(op,l,mode,tar)
+
+evalTuple(op,l,m,tar) ==
+  [agg,:.,underMode]:= m
+  code := asTupleNewCode(#l,
+    [(getArgValue(x,underMode) or throwKeyedMsg("S2IC0007",[underMode])) for x in l])
+  val :=
+    $genValue => objNewWrap(timedEVALFUN code,m)
+    objNew(code,m)
+  if tar then val1 := coerceInteractive(val,tar) else val1 := val
+
+  val1 =>
+    putValue(op,val1)
+    putModeSet(op,[tar or m])
+  putValue(op,val)
+  putModeSet(op,[m])
+
+upNullTuple(op,l,tar) ==
+  -- handler for the empty tuple
+  defMode :=
+    tar and tar is [a,b] and (a in '(Stream Vector List)) and
+      not isPartialMode(b) => ['Tuple,b]
+    '(Tuple (None))
+  val := objNewWrap(asTupleNew(0,NIL), defMode)
+  tar and not isPartialMode(tar) =>
+    null (val' := coerceInteractive(val,tar)) =>
+      throwKeyedMsg("S2IS0013",[tar])
+    putValue(op,val')
+    putModeSet(op,[tar])
+  putValue(op,val)
+  putModeSet(op,[defMode])
+
+--% Handler for typeOf
+
+uptypeOf form ==
+  form isnt [op, arg] => NIL
+  if VECP arg then transferPropsToNode(getUnname arg,arg)
+  if m := isType(arg) then
+    m :=
+      categoryForm?(m) => '(SubDomain (Domain))
+      isPartialMode m  => '(Mode)
+      '(Domain)
+  else if not (m := getMode arg) then [m] := bottomUp arg
+  t := typeOfType m
+  putValue(op, objNew(m,t))
+  putModeSet(op,[t])
+
+typeOfType type ==
+  type in '((Mode) (Domain)) => '(SubDomain (Domain))
+  '(Domain)
+
+--% Handler for where
+
+upwhere t ==
+  -- upwhere does the puts in where into a local environment
+  t isnt [op,tree,clause] => NIL
+  -- since the "clause" might be a local macro, we now call mkAtree
+  -- on the "tree" part (it is not yet a vat)
+  not $genValue =>
+    compFailure [:bright '"  where",
+      '"for compiled code is not yet implemented."]
+  $whereCacheList : local := nil
+  [env,:e] := upwhereClause(clause,$env,$e)
+  tree := upwhereMkAtree(tree,env,e)
+  if x := getAtree(op,'dollar) then
+    atom tree => throwKeyedMsg("S2IS0048",NIL)
+    putAtree(CAR tree,'dollar,x)
+  upwhereMain(tree,env,e)
+  val := getValue tree
+  putValue(op,val)
+  result := putModeSet(op,getModeSet tree)
+  wcl := [op for op in $whereCacheList]
+  for op in wcl repeat clearDependencies(op,'T)
+  result
+
+upwhereClause(tree,env,e) ==
+  -- uses the variable bindings from env and e and returns an environment
+  -- of its own bindings
+  $env: local := copyHack env
+  $e: local := copyHack e
+  bottomUp tree
+  [$env,:$e]
+
+upwhereMkAtree(tree,$env,$e) == mkAtree tree
+
+upwhereMain(tree,$env,$e) ==
+  -- uses local copies of $env and $e while evaluating tree
+  bottomUp tree
+
+copyHack(env) ==
+  -- makes a copy of an environment with the exception of pairs
+  -- (localModemap . something)
+  c:= CAAR env
+  d:= [fn p for p in c] where fn(p) ==
+    CONS(CAR p,[(EQCAR(q,'localModemap) => q; copy q) for q in CDR p])
+  [[d]]
+
+-- Creates the function names of the special function handlers and puts
+--  them on the property list of the function name
+
+EVALANDFILEACTQ
+ (
+   for name in $specialOps repeat
+    (
+      functionName:=INTERNL('up,name) ;
+      MAKEPROP(name,'up,functionName) ;
+      CREATE_-SBC functionName
+     )
+  )
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}