A whole lot of changes, described in #101 that help with records and separate compilation

The scheme may be strange, but a lot of KRoC compiles with it (and I think the cgtests will compile again now too)

backends/GenerateC.hs

@@ -180,17 +180,22 @@ cgenTopLevel headerName s
           tell ["#include <tock_support_cif.h>\n"]
           cs <- getCompState
 
-          let isTopLevelSpec (A.Specification _ n _)
+          let isHeaderSpec (A.Specification _ n _)
                 = A.nameName n `elem` (csOriginalTopLevelProcs cs)
+              isBodySpec (A.Specification _ n sp)
+                = A.nameName n `notElem` (csOriginalTopLevelProcs cs)
 
-          tellToHeader $ sequence_ $ map (call genForwardDeclaration)
+          tellToHeader (nameString $ A.Name emptyMeta $ dropPath headerName)
-                                       (reverse $ listifyDepth isTopLevelSpec s)
+            $ sequence_ $ map (call genForwardDeclaration True)
+                                       (reverse $ listifyDepth isHeaderSpec s)
+
+          -- The header now contains record types and such, so we need to include
+          -- that before forward-declaring other PROCs:
+          tell ["#include \"", dropPath headerName, "\"\n"]
           -- Things like lifted wrapper_procs we still need to forward-declare,
           -- but we do it in the C file, not in the header:
-          sequence_ $ map (call genForwardDeclaration)
+          sequence_ $ map (call genForwardDeclaration False)
-                            (reverse $ listifyDepth (not . isTopLevelSpec) s)
+                            (reverse $ listifyDepth (isBodySpec) s)
-
-          tell ["#include \"", dropPath headerName, "\"\n"]
 
           sequence_ [let usedFile' = if ".tock.inc" `isSuffixOf` usedFile
                            then take (length usedFile - length ".tock.inc") usedFile
@@ -1398,7 +1403,8 @@ cintroduceSpec lvl (A.Specification _ n (A.Is _ _ _ (A.ActualClaim v)))
                               else "MT_CB_SERVER"
                        ,")"]
 cintroduceSpec _ (A.Specification _ _ (A.DataType _ _)) = return ()
-cintroduceSpec _ (A.Specification _ _ (A.RecordType _ _ _)) = return ()
+cintroduceSpec _ (A.Specification _ n (A.RecordType _ ra nts))
+  = call genRecordTypeSpec True n ra nts
 cintroduceSpec _ (A.Specification _ _ (A.ChanBundleType {})) = return ()
 cintroduceSpec _ (A.Specification _ n (A.Protocol _ _)) = return ()
 cintroduceSpec _ (A.Specification _ n (A.ProtocolCase _ ts))
@@ -1446,19 +1452,17 @@ cintroduceSpec _ (A.Specification _ n (A.Forking _))
 --cintroduceSpec (A.Specification _ n (A.RetypesExpr _ am t e))
 cintroduceSpec _ n = call genMissing $ "introduceSpec " ++ show n
 
-cgenRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
+cgenRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
-cgenRecordTypeSpec n attr fs
+cgenRecordTypeSpec extraStuff n attr fs
+  | not extraStuff
     =  do tell ["typedef struct{"]
           sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs]
           tell ["}"]
           when (A.packedRecord attr || A.mobileRecord attr) $ tell [" occam_struct_packed "]
           genName n
           tell [";"]
-          tell ["typedef "]
+  | otherwise
-          genName n
+    =     if null [t | (_, A.Mobile t) <- fs]
-          origN <- lookupName n >>* A.ndOrigName
-          tell [" ", nameString $ A.Name emptyMeta origN, ";"]
-          if null [t | (_, A.Mobile t) <- fs]
             then do genStatic TopLevel n
                     tell ["const word "]
                     genName n
@@ -1493,12 +1497,12 @@ cgenRecordTypeSpec n attr fs
         ] ++ mt t
     mt t = [mobileElemType False t]
 
-cgenForwardDeclaration :: A.Specification -> CGen ()
+cgenForwardDeclaration :: Bool -> A.Specification -> CGen ()
-cgenForwardDeclaration (A.Specification _ n st@(A.Proc _ _ _ _))
+cgenForwardDeclaration _ (A.Specification _ n st@(A.Proc _ _ _ _))
     = genProcSpec TopLevel n st True
-cgenForwardDeclaration (A.Specification _ n (A.RecordType _ b fs))
+cgenForwardDeclaration True (A.Specification _ n (A.RecordType _ b fs))
-    = call genRecordTypeSpec n b fs
+    = call genRecordTypeSpec False n b fs
-cgenForwardDeclaration _ = return ()
+cgenForwardDeclaration _ _ = return ()
 
 cremoveSpec :: A.Specification -> CGen ()
 cremoveSpec (A.Specification m n (A.Declaration _ t))
@@ -1625,6 +1629,7 @@ genProcSpec lvl n (A.Proc _ (sm, rm) fs (Just p)) forwardDecl
               tell [" (Workspace wptr"]
               sequence_ [do tell [", "]
                             case origT of
+{-
                               A.Record rn | forwardDecl
                                 -> do origN <- lookupName rn >>* A.ndOrigName
                                       ct <- call getCType (A.nameMeta rn)
@@ -1632,7 +1637,7 @@ genProcSpec lvl n (A.Proc _ (sm, rm) fs (Just p)) forwardDecl
                                       tell [show $ replacePlainType (nameString rn)
                                         (nameString $ A.Name emptyMeta origN) ct
                                         ]
-                              _ -> t
+-}                              _ -> t
                             tell [" "]
                             n
                          | (A.Formal am origT _, (t, n)) <- zip fs rfs]

backends/GenerateCBased.hs

@@ -23,6 +23,8 @@ import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Writer hiding (tell)
 import Data.Generics (Data)
+import Data.HashTable (hashString)
+import Data.Int (Int32)
 import Data.List
 import System.IO
 
@@ -71,14 +73,31 @@ instance CSMR CGen where
   getCompState = lift getCompState
 
 -- Do not nest calls to this function!
-tellToHeader :: CGen a -> CGen a
+-- The function also puts in the #ifndef/#define/#endif stuff that prevents multiple
-tellToHeader act
+-- inclusion.
+tellToHeader :: String -> CGen a -> CGen a
+tellToHeader stem act
   = do st <- get
-       put $ st { cgenBody = cgenHeader st }
+       put $ st { cgenBody = Left [] }
        x <- act
        st' <- get
-       put $ st' { cgenBody = cgenBody st, cgenHeader = cgenBody st' }
+       let Left mainBit = cgenBody st'
+           nonce = "_" ++ stem ++ "_" ++ show (makePosInteger $ hashString $ concat mainBit)
+           contents =
+             "#ifndef " ++ nonce ++ "\n" ++
+             "#define " ++ nonce ++ "\n" ++
+             concat mainBit ++ "\n" ++
+             "#endif\n"
+       case cgenHeader st of
+         Right h -> do liftIO $ hPutStr h contents
+                       put $ st' { cgenBody = cgenBody st }
+         Left ls -> do put $ st' { cgenBody = cgenBody st
+                                 , cgenHeader = Left $ ls ++ [contents]
+                                 }
        return x
+  where
+    makePosInteger :: Int32 -> Integer
+    makePosInteger n = toInteger n + (toInteger (maxBound :: Int32))
 
 tell :: [String] -> CGen ()
 tell x = do st <- get
@@ -138,7 +157,8 @@ data GenOps = GenOps {
     genDirectedVariable :: Meta -> A.Type -> CGen () -> A.Direction -> CGen (),
     genExpression :: A.Expression -> CGen (),
     genFlatArraySize :: [A.Dimension] -> CGen (),
-    genForwardDeclaration :: A.Specification -> CGen(),
+    -- Bool is true if this is for the header:
+    genForwardDeclaration :: Bool -> A.Specification -> CGen(),
     -- | Only used for built-in operators at the moment:
     genFunctionCall :: Meta -> A.Name -> [A.Expression] -> CGen (),
     -- | Gets the current time into the given variable
@@ -169,7 +189,7 @@ data GenOps = GenOps {
     genPoison :: Meta -> A.Variable -> CGen (),
     genProcCall :: A.Name -> [A.Actual] -> CGen (),
     genProcess :: A.Process -> CGen (),
-    genRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen (),
+    genRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen (),
     genReplicatorStart :: A.Name -> A.Replicator -> CGen (),
     genReplicatorEnd :: A.Replicator -> CGen (),
     -- | Generates the three bits of a for loop (e.g. @int i = 0; i < 10; i++@ for the given replicator)

backends/GenerateCPPCSP.hs

@@ -141,16 +141,22 @@ cppgenTopLevel headerName s
 
           cs <- getCompState
 
-          let isTopLevelSpec (A.Specification _ n _)
+          let isHeaderSpec (A.Specification _ n _)
                 = A.nameName n `elem` (csOriginalTopLevelProcs cs)
+              isBodySpec (A.Specification _ n sp)
+                = case sp of
+                    A.RecordType {} -> True
+                    _ -> A.nameName n `elem` (csOriginalTopLevelProcs cs)
 
-          tellToHeader $ sequence_ $ map (call genForwardDeclaration)
+
-                                       (reverse $ listifyDepth isTopLevelSpec s)
+          tellToHeader (nameString $ A.Name emptyMeta $ dropPath headerName)
+            $ sequence_ $ map (call genForwardDeclaration True)
+                                       (reverse $ listifyDepth isHeaderSpec s)
           -- Things like lifted wrapper_procs we still need to forward-declare,
           -- but we do it in the C file, not in the header:
-          sequence_ $ map (call genForwardDeclaration)
+          sequence_ $ map (call genForwardDeclaration False)
                             (reverse $ listifyDepth (\sp@(A.Specification _ n _)
-                              -> not (isTopLevelSpec sp)
+                              -> isBodySpec sp
                                  && A.nameName n `notElem` map fst (csExternals cs)) s)
 
           tell ["#include \"", dropPath headerName, "\"\n"]
@@ -540,8 +546,8 @@ cppgenFormals nameFunc list = seqComma (map (cppgenFormal nameFunc) list)
 cppgenFormal :: (A.Name -> A.Name) -> A.Formal -> CGen ()
 cppgenFormal nameFunc (A.Formal am t n) = call genDecl NotTopLevel am t (nameFunc n)
 
-cppgenForwardDeclaration :: A.Specification -> CGen()
+cppgenForwardDeclaration :: Bool -> A.Specification -> CGen()
-cppgenForwardDeclaration (A.Specification _ n (A.Proc _ (sm, _) fs _))
+cppgenForwardDeclaration _ (A.Specification _ n (A.Proc _ (sm, _) fs _))
     =  do --Generate the "process" as a C++ function:
           genStatic TopLevel n
           call genSpecMode sm
@@ -591,9 +597,9 @@ cppgenForwardDeclaration (A.Specification _ n (A.Proc _ (sm, _) fs _))
     genConstructorList :: [A.Formal] -> CGen ()
     genConstructorList fs = mapM_ genConsItem fs
 
-cppgenForwardDeclaration (A.Specification _ n (A.RecordType _ b fs))
+cppgenForwardDeclaration header (A.Specification _ n (A.RecordType _ b fs))
-    = call genRecordTypeSpec n b fs
+    = call genRecordTypeSpec (not header) n b fs
-cppgenForwardDeclaration _ = return ()
+cppgenForwardDeclaration _ _ = return ()
 
 cppintroduceSpec :: Level -> A.Specification -> CGen ()
 --I generate process wrappers for all functions by default:
@@ -923,8 +929,8 @@ cppgenFunctionCall m n es
        tell [")"]
 
 -- Changed because we don't need the mobile descriptor stuff:
-cppgenRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
+cppgenRecordTypeSpec :: Bool -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen ()
-cppgenRecordTypeSpec n attr fs
+cppgenRecordTypeSpec True n attr fs
     =  do tell ["typedef struct{"]
           sequence_ [call genDeclaration NotTopLevel t n True | (n, t) <- fs]
           tell ["}"]
@@ -935,3 +941,4 @@ cppgenRecordTypeSpec n attr fs
           genName n
           origN <- lookupName n >>* A.ndOrigName
           tell [" ", nameString $ A.Name emptyMeta origN, ";"]
+cppgenRecordTypeSpec False _ _ _ = return ()

backends/GenerateCTest.hs

@@ -607,7 +607,7 @@ testRecord = TestList
     
     testAllS :: Int -> (String,String) -> (String,String) -> A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> State CompState () -> (GenOps -> GenOps) -> Test
     testAllS n (eCI,eCR) (eCPPI,eCPPR) rn rb rts st overFunc
-      = testBothS ("testRecord " ++ show n) eCI eCPPI (local overFunc (tcall genRecordTypeSpec rn rb rts)) st
+      = testBothS ("testRecord " ++ show n) eCI eCPPI (local overFunc (tcall genRecordTypeSpec False rn rb rts)) st
     testAllSame n e s0 s1 s2 = testAll n e e s0 s1 s2
     over ops = ops {genDeclaration = override3 (tell . (\x -> ["#ATION_",show x]))
                    ,declareInit = (override3 (Just $ tell ["#INIT"])), declareFree = override3 (Just $ tell ["#FREE"])

frontends/OccamCheckTypes.hs

@@ -435,6 +435,60 @@ sameType ta@(A.UserDataType {}) tb
 sameType ta tb@(A.UserDataType {})
   = do tb' <- resolveUserType emptyMeta tb
        sameType ta tb'
+
+-- For records, because of the way separate compilation works, the same record
+-- might end up with two different names.  So we consider records to be the same
+-- type, iff:
+-- a. They have the same original name, AND
+-- b. Their attributes are the same, AND
+-- c. There are the same number of fields, AND
+-- d. The fields have matching names, AND
+-- e. The fields have matching types.
+sameType (A.Record na) (A.Record nb)
+  = do nad <- lookupName na
+       nbd <- lookupName nb
+       let matchOn :: Eq a => (A.NameDef -> a) -> Bool
+           matchOn f = f nad == f nbd
+
+           allButTypesSame = and $
+             [matchOn A.ndOrigName
+             ,matchOn $ (\(A.RecordType _ ra _) -> ra) . A.ndSpecType
+             ,matchOn $ (\(A.RecordType _ _ fs) -> length fs) . A.ndSpecType
+             ,matchOn $ (\(A.RecordType _ _ fs) -> map fst fs) . A.ndSpecType
+             ]
+
+           getTypes = (\(A.RecordType _ _ fs) -> map snd fs) . A.ndSpecType
+
+       if allButTypesSame
+         then liftM and $ mapM (uncurry sameType) (zip (getTypes nad) (getTypes nbd))
+         else return False
+-- For protocols (due to separate compilation) we check that the original names
+-- were the same, and that all the types match, similar to records
+sameType (A.UserProtocol na) (A.UserProtocol nb)
+  = do nad <- lookupName na
+       nbd <- lookupName nb
+       if A.ndOrigName nad == A.ndOrigName nbd
+         then case (A.ndSpecType nad, A.ndSpecType nbd) of
+           (A.Protocol _ ats, A.Protocol _ bts)
+             | length ats == length bts
+               -> liftM and $ mapM (uncurry sameType) (zip ats bts)
+           (A.ProtocolCase _ ants, A.ProtocolCase _ bnts)
+             | length ants == length bnts && map fst ants == map fst bnts
+               -> liftM and $ mapM (liftM and . sequence . uncurry (zipWith sameType)) (zip (map snd ants) (map snd bnts))
+           _ -> return False
+         else return False
+-- Finally, for channel bundle types, we proceed as with the others:
+sameType (A.ChanDataType dirA shA na) (A.ChanDataType dirB shB nb)
+  | dirA == dirB && shA == shB
+  = do nad <- lookupName na
+       nbd <- lookupName nb
+       if A.ndOrigName nad == A.ndOrigName nbd
+         then case (A.ndSpecType nad, A.ndSpecType nbd) of
+                (A.ChanBundleType _ arm ants, A.ChanBundleType _ brm bnts)
+                  | arm == brm && length ants == length bnts && map fst ants == map fst bnts
+                    -> liftM and $ mapM (uncurry sameType) (zip (map snd ants) (map snd bnts))
+                _ -> return False
+         else return False
 sameType a b = return $ a == b
 
 -- | Check that the second dimension can be used in a context where the first

frontends/OccamPasses.hs

@@ -64,36 +64,69 @@ writeIncFile = occamOnlyPass "Write .inc file" [] []
     do out <- getCompOpts >>* csOutputIncFile
        case out of
          Just fn -> do f <- liftIO $ openFile fn WriteMode
-                       contents <- emitProcsAsExternal t >>* (unlines . F.toList)
+                       (origLines, ns) <- runStateT (emitProcsAsExternal t) []
-                       liftIO $ hPutStr f contents
+                       allLines <- mapM mask ns >>* (F.toList origLines ++)
+                       liftIO $ hPutStr f $ unlines allLines
                        liftIO $ hClose f
          Nothing -> return ()
        return t
   ))
   where
-    emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String)
+    emitProcsAsExternal :: A.AST -> StateT [A.Name] PassM (Seq.Seq String)
     emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ (A.PlainSpec,_) fs (Just _))) scope)
       = do origN <- lookupName n >>* A.ndOrigName
            thisProc <- sequence (
              [return $ "#PRAGMA TOCKEXTERNAL \"PROC " ++ origN ++ "("
-             ] ++ intersperse (return ",") (map showCode fs) ++
+             ] ++ intersperse (return ",") (map showFormal fs) ++
              [return $ ") = " ++ nameString n ++ "\""
              ]) >>* concat
-           modify $ \cs -> cs { csOriginalTopLevelProcs =
+           recTopLevelName n
-             A.nameName n : csOriginalTopLevelProcs cs }
            emitProcsAsExternal scope >>* (thisProc Seq.<|)
-    emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Function _ (A.PlainSpec,_) ts fs (Just _))) scope)
+    emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Function m (A.PlainSpec,_) ts fs (Just _))) scope)
       = do origN <- lookupName n >>* A.ndOrigName
            thisProc <- sequence (
              [return $ "#PRAGMA TOCKEXTERNAL \""
-             ] ++ intersperse (return ",") (map showCode ts) ++
+             ] ++ intersperse (return ",") (map (showType m) ts) ++
              [return $ " FUNCTION " ++ showFuncName origN ++ "("
-             ] ++ intersperse (return ",") (map showCode fs) ++
+             ] ++ intersperse (return ",") (map showFormal fs) ++
              [return $ ") = " ++ nameString n ++ "\""
              ]) >>* concat
-           modify $ \cs -> cs { csOriginalTopLevelProcs =
+           recTopLevelName n
-             A.nameName n : csOriginalTopLevelProcs cs }
            emitProcsAsExternal scope >>* (thisProc Seq.<|)
+    emitProcsAsExternal (A.Spec _ (A.Specification _ n
+      (A.RecordType m ra nts)) scope)
+      = do ts' <- mapM (underlyingType m) ts
+           thisDef <- showCode $ A.Specification m n $ A.RecordType m ra (zip ns ts')
+           recordType n
+           recTopLevelName n
+           emitProcsAsExternal scope >>* (thisDef Seq.<|)
+      where
+        (ns, ts) = unzip nts
+    emitProcsAsExternal (A.Spec _ (A.Specification _ n
+      (A.ChanBundleType m rm nts)) scope)
+      = do ts' <- mapM (underlyingType m) ts
+           thisDef <- showCode $ A.Specification m n $ A.ChanBundleType m rm (zip ns ts')
+           recordType n
+           recTopLevelName n
+           emitProcsAsExternal scope >>* (thisDef Seq.<|)
+      where
+        (ns, ts) = unzip nts
+    emitProcsAsExternal (A.Spec _ (A.Specification _ n
+      (A.Protocol m ts)) scope)
+      = do ts' <- mapM (underlyingType m) ts
+           thisDef <- showCode $ A.Specification m n $ A.Protocol m ts'
+           recordType n
+           recTopLevelName n
+           emitProcsAsExternal scope >>* (thisDef Seq.<|)
+    emitProcsAsExternal (A.Spec _ (A.Specification _ n
+      (A.ProtocolCase m nts)) scope)
+      = do ts' <- mapM (mapM $ underlyingType m) ts
+           thisDef <- showCode $ A.Specification m n $ A.ProtocolCase m (zip ns ts')
+           recordType n
+           recTopLevelName n
+           emitProcsAsExternal scope >>* (thisDef Seq.<|)
+      where
+        (ns, ts) = unzip nts
     emitProcsAsExternal (A.Spec _ (A.Specification _ n _) scope)
       = emitProcsAsExternal scope
     emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope
@@ -101,12 +134,32 @@ writeIncFile = occamOnlyPass "Write .inc file" [] []
     emitProcsAsExternal (A.Several _ ss)
       = foldl (liftM2 (Seq.><)) (return Seq.empty) (map emitProcsAsExternal ss)
 
+    -- FIXME: for all the types, we should also output the types that they depend
+    -- on
+
     showFuncName :: String -> String
     showFuncName s | isOperator s = "\"" ++ doubleStars s ++ "\""
                    | otherwise = s
       where
         doubleStars cs = concat [if c == '*' then "**" else [c] | c <- cs]
 
+    recordType :: A.Name -> StateT [A.Name] PassM ()
+    recordType n = modify (n:)
+
+    recTopLevelName :: A.Name -> StateT [A.Name] PassM ()
+    recTopLevelName n = modifyCompState $ \cs -> cs { csOriginalTopLevelProcs =
+             A.nameName n : csOriginalTopLevelProcs cs }
+
+    mask :: A.Name -> PassM String
+    mask n = lookupName n >>* A.ndOrigName >>* ("#PRAGMA TOCKUNSCOPE " ++)
+
+    showType :: Meta -> A.Type -> StateT [A.Name] PassM String
+    showType m = showCode <.< underlyingType m
+
+    showFormal :: A.Formal -> StateT [A.Name] PassM String
+    showFormal (A.Formal am t n) = do t' <- underlyingType (findMeta n) t
+                                      showCode $ A.Formal am t' n
+
 -- | Fixed the types of array constructors according to the replicator count
 fixConstructorTypes :: PassOn A.Expression
 fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"

frontends/ParseOccam.hs

@@ -43,7 +43,7 @@ import Types
 import Utils
 
 data OccParserState = OccParserState
-  { csLocalNames :: [(String, (A.Name, NameType))]
+  { csLocalNames :: [(String, (A.Name, NameType, Bool))]
   , compState :: CompState  
   }
 
@@ -58,8 +58,9 @@ instance CSM (GenParser tok OccParserState) where
                        setState $ st { compState = cs }
 
 addLocalName :: (String, (A.Name, NameType)) -> OccParser ()
-addLocalName n = do st <- getState
+addLocalName (s, (n, nt))
-                    setState $ st { csLocalNames = n : csLocalNames st }
+  = do st <- getState
+       setState $ st { csLocalNames = (s, (n, nt, True)) : csLocalNames st }
 
 -- The other part of the state is actually the built-up list of warnings:
 instance Warn (GenParser tok OccParserState) where
@@ -403,10 +404,10 @@ findName :: A.Name -> NameType -> OccParser A.Name
 findName thisN thisNT
     =  do st <- getState
           (origN, origNT) <-
-            case lookup (A.nameName thisN) (csLocalNames st) of
+            case lookup (A.nameName thisN) [(s, (n, nt)) | (s, (n, nt, True)) <- csLocalNames st] of
-              Nothing -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined"
-                ++ "; possibilities were: " ++ show (map fst (csLocalNames st))
               Just def -> return def
+              _ -> dieP (A.nameMeta thisN) $ "name " ++ A.nameName thisN ++ " not defined"
+                ++ "; possibilities were: " ++ show (map fst (csLocalNames st))
           if thisNT /= origNT
             then dieP (A.nameMeta thisN) $ "expected " ++ show thisNT ++ " (" ++ A.nameName origN ++ " is " ++ show origNT ++ ")"
             else return $ thisN { A.nameName = A.nameName origN }
@@ -434,7 +435,7 @@ scopeOut :: A.Name -> OccParser ()
 scopeOut n@(A.Name m _)
     =  do st <- getState
           case csLocalNames st of
-            ((_, (old, _)):rest)
+            ((_, (old, _, _)):rest)
              | old == n -> setState $ st { csLocalNames = rest }
              | otherwise -> dieInternal (Just m, "scoping out not in order; "
                  ++ " tried to scope out: " ++ A.nameName n ++ " but found: " ++ A.nameName old)
@@ -1481,12 +1482,13 @@ pragma = do m <- getPosition >>* sourcePosToMeta
     -- The Right return expects the given string to be lexed then parsed, whereas
     -- the Left return is just some code to run as normal, that won't consume
     -- any input.
-    pragmas :: (Die m, CSM m) => [ (String, Meta -> [String] -> Either (m (Maybe NameSpec))
+    pragmas :: [ (String, Meta -> [String] -> Either (OccParser (Maybe NameSpec))
       (String, OccParser (Maybe NameSpec)) ) ]
     pragmas = [ ("^SHARED +(.*)", parseContents handleShared)
               , ("^PERMITALIASES +(.*)", parseContents handlePermitAliases)
               , ("^EXTERNAL +\"(.*)\"", parseContents $ handleExternal True)
               , ("^TOCKEXTERNAL +\"(.*)\"", parseContents $ handleExternal False)
+              , ("^TOCKUNSCOPE +(.*)", simple handleUnscope)
               , ("^TOCKSIZES +\"(.*)\"", simple handleSizes)
               , ("^TOCKINCLUDE +\"(.*)\"", simple handleInclude)
               , ("^TOCKNATIVELINK +\"(.*)\"", simple handleNativeLink)
@@ -1506,7 +1508,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta
                   do st <- getState
                      A.Name _ n <- case lookup var (csLocalNames st) of
                        Nothing -> dieP m $ "name " ++ var ++ " not defined"
-                       Just def -> return $ fst def
+                       Just (n, _, _) -> return n
                      modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union
                        n (Set.singleton NameShared) (csNameAttr st)})
                   vars
@@ -1518,7 +1520,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta
                   do st <- getState
                      A.Name _ n <- case lookup var (csLocalNames st) of
                        Nothing -> dieP m $ "name " ++ var ++ " not defined"
-                       Just def -> return $ fst def
+                       Just (n, _, _) -> return n
                      modifyCompState $ \st -> st {csNameAttr = Map.insertWith Set.union
                        n (Set.singleton NameAliasesPermitted) (csNameAttr st)})
                   vars
@@ -1568,6 +1570,17 @@ pragma = do m <- getPosition >>* sourcePosToMeta
                   }
                 return $ Just (A.Specification m origN sp, nt, (Just n, A.NameExternal))
 
+    handleUnscope _ [unscope]
+      = do st <- getState
+           setState $ st { csLocalNames = unscopeLatest $ csLocalNames st }
+           return Nothing
+      where
+        unscopeLatest (l@(s, (n, nt, _)): ls)
+          | s == unscope
+             = (s, (n, nt, False)) : ls
+          | otherwise
+             = l : unscopeLatest ls
+
     isPragma (Token _ p@(Pragma {})) = Just p
     isPragma _ = Nothing
 
@@ -1637,7 +1650,7 @@ claimSpec
     getOrigName :: A.Name -> OccParser String
     getOrigName n
       = do st <- getState
-           case lookup n [(munged, orig) | (orig, (munged, _)) <- csLocalNames st] of
+           case lookup n [(munged, orig) | (orig, (munged, _, True)) <- csLocalNames st] of
              Just orig -> return orig
              Nothing -> dieP (A.nameMeta n) $ "Could not find name: " ++ (A.nameName n)
 
@@ -2035,7 +2048,8 @@ topLevelItem
            -- when we get back to the file we included this one from, or
            -- pull the TLP name from them at the end.
            locals <- getState >>* csLocalNames
-           modifyCompState $ (\ps -> ps { csMainLocals = locals })
+           modifyCompState $ (\ps -> ps { csMainLocals =
+             [(s, (n, nt)) | (s, (n, nt, True)) <- locals] })
            return $ A.Several m []
 
 -- | A source file is a series of nested specifications.