1 module IdStack
    2 
    3 ( IdStack
    4 
    5 , emptyIS, globIS
    6 
    7 , pushlocs, poplocs, mkglobs
    8 
    9 , findidS, changeprecS
   10 , setarityS, setformS
   11 
   12 )
   13 
   14 where
   15 
   16 import Ids
   17 
   18 --------------------------------------------------------------------
   19 
   20 data IdStack = IS
   21         [ IdTable ]    -- stack of local bindings
   22         IdTable        -- global environment
   23         deriving Show
   24 
   25 globIS it = IS [] it
   26 emptyIS = globIS emptyIT
   27 
   28 
   29 --------------------------------------------------------------------
   30 
   31 pushlocs (IS locs glob) = IS (emptyIT : locs) glob
   32 
   33 poplocs (IS [] glob) = error "cannot pop locals (stack empty)"
   34 poplocs (IS (loc : locs) glob ) = IS  locs glob
   35 
   36 mkglobs (IS [] glob) = error "cannot make globals (local stack empty)"
   37 mkglobs (IS (loc : locs) glob ) = IS ( loc : locs) (plusIT glob loc)
   38 
   39 --------------------------------------------------------------------
   40 
   41 -- lift a function on an IdTable
   42 -- to a function on an IdStack:
   43 
   44 -- first look for a local name
   45 -- then default to the global one
   46 
   47 wrapIS :: Bool -> (String -> IdTable -> (a, IdTable)) 
   48         -> (String -> IdStack -> (a, IdStack))
   49 
   50 wrapIS def f name (IS [] glob) = 
   51         let (x, glob') = f name glob
   52         in  (x, IS [] glob')
   53 
   54 wrapIS def f name (IS (loc : locs) glob) =
   55     if def 
   56 
   57     then -- don't search, rather define new variable right here
   58         let (x, loc') = f name loc
   59         in (x, IS (loc' : locs) glob)
   60 
   61     else -- do search
   62         case lookupIT loc name of
   63             Just _ ->  let (x, loc') = f name loc
   64                         in (x, IS (loc' : locs) glob)
   65             Nothing ->         let (x, IS locs' glob') 
   66                                 = wrapIS def f name (IS locs glob)
   67                         in (x, IS (loc : locs') glob')
   68 
   69 --------------------------------------------------------------------
   70 
   71 
   72 findidS :: Bool -> String -> Kind -> Kind -> IdStack -> (Id, IdStack)
   73 findidS def name look use is = 
   74         wrapIS def (\ name it -> findid name look use it ) name is
   75 
   76 changeprecS :: IdStack -> String -> Int -> Bind -> (Id, IdStack)
   77 changeprecS is name level bind =
   78         wrapIS False (\ name it -> changeprec it name level bind) name is
   79 
   80 
   81 setarityS :: IdStack -> String -> Int -> (Id, IdStack)
   82 -- does nothing if arity is already set 
   83 -- (will complain elsewhere if does not agree and switch implicit is off)
   84 setarityS is name ar  =
   85         wrapIS False (\ name it -> setarity it name ar) name is
   86 
   87 
   88 setformS :: IdStack -> String -> Form -> (Id, IdStack)
   89 -- does never complain
   90 setformS is name form =
   91         wrapIS False (\ name it -> setform it name form ) name is
   92