-- 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.

)package "BOOT"

getOperationAlistFromLisplib x ==
  u := GETDATABASE(x, 'OPERATIONALIST)
--  u := removeZeroOneDestructively u
  null u => u          -- this can happen for Object
  CAAR u = '_$unique => rest u
  f:= addConsDB '(NIL T ELT)
  for [op,:sigList] in u repeat
    for items in tails sigList repeat
      [sig,:r] := first items
      if r is [.,:s] then
        if s is [.,:t] then
          if t is [.] then nil
          else RPLACD(s,QCDDR f)
        else RPLACD(r,QCDR f)
      else RPLACD(first items,f)
      RPLACA(items,addConsDB CAR items)
  u and markUnique u

markUnique x ==
  u := first x
  RPLACA(x,'(_$unique))
  RPLACD(x,[u,:rest x])
  rest x

--=======================================================================
--          Creation of System Sig/Pred Vectors & Hash Tables
--=======================================================================

addConsDB x == x

--=======================================================================
--               Functions Creating Lisplib Information
--=======================================================================
NRTdescendCodeTran(u,condList) ==
--NRTbuildFunctor calls to fill $template slots with names of compiled functions
  null u => nil
  u is ['LIST] => nil
  u is [op,.,i,a] and MEMQ(op,'(SETELT QSETREFV)) =>
    null condList and a is ['CONS,fn,:.] =>
      RPLACA(u,'LIST)
      RPLACD(u,nil)
      $template.i :=
        fn = 'IDENTITY => a
        fn is ['dispatchFunction,fn'] => fn'
        fn
    nil   --code for this will be generated by the instantiator
  u is ['COND,:c] =>
    for [pred,:y] in c|y repeat NRTdescendCodeTran(first y,[pred,:condList])
  u is ['PROGN,:c] => for x in c repeat NRTdescendCodeTran(x,condList)
  nil

--=======================================================================
--                  Miscellaneous Functions
--=======================================================================
NRTaddInner x ==
--called by genDeltaEntry and others that affect $NRTdeltaList
  PROGN
    atom x => nil
    x is ['Record,:l] =>
      for [.,.,y] in l repeat NRTinnerGetLocalIndex y
    first x in '(Union Mapping) =>
      for y in rest x repeat
         y is [":",.,z] => NRTinnerGetLocalIndex z
         NRTinnerGetLocalIndex y
    x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y
    getConstructorSignature x is [.,:ml] =>
      for y in rest x for m in ml | not (y = '$) repeat
        isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y
    keyedSystemError("S2NR0003",[x])
  x

-- NRTaddInner should call following function instead of NRTgetLocalIndex
-- This would prevent putting spurious items in $NRTdeltaList
NRTinnerGetLocalIndex x ==
  atom x => x
  -- following test should skip Unions, Records, Mapping
  MEMQ(opOf x,'(Union Record Mapping)) => NRTgetLocalIndex x
  constructor?(x) => NRTgetLocalIndex x
  NRTaddInner x

makeSpadConstant [fn,dollar,slot] ==
  val := FUNCALL(fn,dollar)
  u:= dollar.slot
  RPLACA(u,function IDENTITY)
  RPLACD(u,val)
  val
