+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[AbsSyntax]{Abstract syntax definition}
-
-This module glues together the pieces of the Haskell abstract syntax,
-which is declared in the various \tr{Hs*} modules. This module,
-therefore, is almost nothing but re-exporting.
-
-The abstract syntax, used in the front end of the compiler, follows
-that of a paper on the static semantics of Haskell by Simon Peyton
-Jones and Phil Wadler.
-
-The abstract syntax is parameterised with respect to variables
-(abbrev: \tr{name}) and patterns (abbrev: \tr{pat}); here is a typical
-example:
-\begin{pseudocode}
-type ProtoNameExpr = Expr ProtoName ProtoNamePat
-type TypecheckedExpr = Expr Id TypecheckedPat
-\end{pseudocode}
-Some parts of the syntax are unparameterised, because there is no
-need for them to be.
-
-\begin{code}
-#include "HsVersions.h"
-
-module AbsSyn (
- -- the mostly-parameterised data types
- ArithSeqInfo(..),
- Bind(..),
- Binds(..),
- ClassDecl(..),
- ClassPragmas, -- abstract
- ConDecl(..),
- DefaultDecl(..),
- Expr(..),
- FixityDecl(..),
- GRHSsAndBinds(..),
- GRHS(..),
- IE(..),
- ImportedInterface(..),
- IfaceImportDecl(..),
- InPat(..),
- InstDecl(..),
- InstancePragmas, -- abstract
- Interface(..),
- Literal(..),
- Match(..),
- Module(..),
- MonoBinds(..),
- MonoType(..),
- PolyType(..),
- Qual(..),
- Renaming(..),
- Sig(..),
- GenPragmas, -- abstract
- ClassOpPragmas, -- abstract
- TyDecl(..),
- DataPragmas, -- abstract
- TypePragmas, -- abstract
- TypecheckedPat(..),
- SpecialisedInstanceSig(..), -- a user pragma
- DataTypeSig(..),
-
- Context(..), -- synonyms
- ClassAssertion(..),
-
- -- synonyms for the (unparameterised) typechecker input
- ProtoNameArithSeqInfo(..),
- ProtoNameBind(..),
- ProtoNameBinds(..),
- ProtoNameClassDecl(..),
- ProtoNameClassPragmas(..),
- ProtoNameConDecl(..),
- ProtoNameContext(..),
- ProtoNameDefaultDecl(..),
- ProtoNameExpr(..),
- ProtoNameFixityDecl(..),
- ProtoNameGRHSsAndBinds(..),
- ProtoNameGRHS(..),
- ProtoNameImportedInterface(..),
- ProtoNameInstDecl(..),
- ProtoNameInstancePragmas(..),
- ProtoNameInterface(..),
- ProtoNameMatch(..),
- ProtoNameModule(..),
- ProtoNameMonoBinds(..),
- ProtoNameMonoType(..),
- ProtoNamePat(..),
- ProtoNamePolyType(..),
- ProtoNameQual(..),
- ProtoNameSig(..),
- ProtoNameClassOpSig(..),
- ProtoNameGenPragmas(..),
- ProtoNameClassOpPragmas(..),
- ProtoNameTyDecl(..),
- ProtoNameDataPragmas(..),
- ProtoNameSpecialisedInstanceSig(..),
- ProtoNameDataTypeSig(..),
-
- RenamedArithSeqInfo(..),
- RenamedBind(..),
- RenamedBinds(..),
- RenamedClassDecl(..),
- RenamedClassPragmas(..),
- RenamedConDecl(..),
- RenamedContext(..),
- RenamedDefaultDecl(..),
- RenamedExpr(..),
- RenamedFixityDecl(..),
- RenamedGRHSsAndBinds(..),
- RenamedGRHS(..),
- RenamedImportedInterface(..),
- RenamedInstDecl(..),
- RenamedInstancePragmas(..),
- RenamedInterface(..),
- RenamedMatch(..),
- RenamedModule(..),
- RenamedMonoBinds(..),
- RenamedMonoType(..),
- RenamedPat(..),
- RenamedPolyType(..),
- RenamedQual(..),
- RenamedSig(..),
- RenamedClassOpSig(..),
- RenamedGenPragmas(..),
- RenamedClassOpPragmas(..),
- RenamedTyDecl(..),
- RenamedDataPragmas(..),
- RenamedSpecialisedInstanceSig(..),
- RenamedDataTypeSig(..),
-
- -- synonyms for the (unparameterised) typechecker output
- TypecheckedArithSeqInfo(..),
- TypecheckedBind(..),
- TypecheckedBinds(..),
- TypecheckedExpr(..),
- TypecheckedGRHSsAndBinds(..),
- TypecheckedGRHS(..),
- TypecheckedMatch(..),
- TypecheckedMonoBinds(..),
- TypecheckedModule(..),
- TypecheckedQual(..),
-
- -- little help functions (AbsSynFuns)
- collectTopLevelBinders,
- collectBinders, collectTypedBinders,
- collectMonoBinders,
- collectMonoBindersAndLocs,
- collectQualBinders,
- collectPatBinders,
- collectTypedPatBinders,
- extractMonoTyNames,
- cmpInstanceTypes, getNonPrelOuterTyCon,
- getIEStrings, getRawIEStrings, ImExportListInfo(..),
---OLD: getMentionedVars,
- mkDictApp,
- mkDictLam,
- mkTyApp,
- mkTyLam,
- nullBinds,
- nullMonoBinds,
- isLitPat, patsAreAllLits, isConPat, patsAreAllCons,
- irrefutablePat,
-#ifdef DPH
- patsAreAllProcessor,
-#endif
- unfailablePat, unfailablePats,
- pprContext,
- typeOfPat,
- negLiteral,
-
- eqConDecls, eqMonoType, cmpPolyType,
-
- -- imported things so we get a closed interface
- Outputable(..), NamedThing(..),
- ExportFlag, SrcLoc,
- Pretty(..), PprStyle, PrettyRep,
-
- OptIdInfo(..), -- I hate the instance virus!
- IdInfo, SpecEnv, StrictnessInfo, UpdateInfo, ArityInfo,
- DemandInfo, Demand, ArgUsageInfo, ArgUsage, DeforestInfo,
- FBTypeInfo, FBType, FBConsum, FBProd,
-
- Name(..), -- NB: goes out *WITH* constructors
- Id, DictVar(..), Inst, ProtoName, TyVar, UniType, TauType(..),
- Maybe, PreludeNameFun(..), Unique,
- FullName, ShortName, Arity(..), TyCon, Class, ClassOp,
- UnfoldingGuidance, BinderInfo, BasicLit, PrimOp, PrimKind,
- IdEnv(..), UniqFM, FiniteMap,
- CoreExpr, CoreAtom, UnfoldingCoreAtom, UnfoldingCoreExpr,
- UnfoldingPrimOp, UfCostCentre, Bag
- IF_ATTACK_PRAGMAS(COMMA cmpClass COMMA cmpTyCon COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType COMMA pprPrimOp)
-#ifndef __GLASGOW_HASKELL__
- ,TAG_
-#endif
-#ifdef DPH
- ,ParQuals(..), ProtoNameParQuals(..),
- RenamedParQuals(..), TypecheckedParQuals(..),
- collectParQualBinders
-#endif {- Data Parallel Haskell -}
- ) where
-
-
-import AbsSynFuns -- help functions
-
-import HsBinds -- the main stuff to export
-import HsCore
-import HsDecls
-import HsExpr
-import HsImpExp
-import HsLit
-import HsMatches
-import HsPat
-import HsPragmas
-import HsTypes
-
-import AbsPrel ( PrimKind, PrimOp
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import AbsUniType ( TyVar, TyCon, Arity(..), Class, ClassOp, TauType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import BasicLit ( BasicLit )
-import FiniteMap ( FiniteMap )
-import Id ( Id, DictVar(..), DataCon(..) )
-import IdInfo
-import Inst ( Inst )
-import Maybes ( Maybe )
-import Name
-import NameTypes ( ShortName, FullName ) -- .. for pragmas only
-import Outputable
-import Pretty
-import ProtoName ( ProtoName(..) ) -- .. for pragmas only
-import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import Util
-\end{code}
-
-All we actually declare here is the top-level structure for a module.
-\begin{code}
-data Module name pat
- = Module
- FAST_STRING -- module name
- [IE] -- export list
- [ImportedInterface name pat]
- -- We snaffle interesting stuff out of the
- -- imported interfaces early on, adding that
- -- info to TyDecls/etc; so this list is
- -- often empty, downstream.
- [FixityDecl name]
- [TyDecl name]
- [DataTypeSig name] -- user pragmas that modify TyDecls;
- -- (much like "Sigs" modify value "Binds")
- [ClassDecl name pat]
- [InstDecl name pat]
- [SpecialisedInstanceSig name] -- user pragmas that modify InstDecls
- [DefaultDecl name]
- (Binds name pat) -- the main stuff!
- [Sig name] -- "Sigs" are folded into the "Binds"
- -- pretty early on, so this list is
- -- often either empty or just the
- -- interface signatures.
- SrcLoc
-\end{code}
-
-\begin{code}
-type ProtoNameModule = Module ProtoName ProtoNamePat
-type RenamedModule = Module Name RenamedPat
-type TypecheckedModule = Module Id TypecheckedPat
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name, NamedThing pat, Outputable pat) =>
- Outputable (Module name pat) where
-
- ppr sty (Module name exports imports fixities
- typedecls typesigs classdecls instdecls instsigs
- defdecls binds sigs src_loc)
- = ppAboves [
- ifPprShowAll sty (ppr sty src_loc),
- if (null exports)
- then (ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")])
- else (ppAboves [
- ppCat [ppPStr SLIT("module"), ppPStr name, ppLparen],
- ppNest 8 (interpp'SP sty exports),
- ppNest 4 (ppPStr SLIT(") where"))
- ]),
- ppr sty imports, ppr sty fixities,
- ppr sty typedecls, ppr sty typesigs,
- ppr sty classdecls,
- ppr sty instdecls, ppr sty instsigs,
- ppr sty defdecls,
- ppr sty binds, ppr sty sigs
- ]
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[AbsSynFuns]{Abstract syntax: help functions}
-
-\begin{code}
-#include "HsVersions.h"
-
-module AbsSynFuns (
- collectTopLevelBinders,
- collectBinders, collectTypedBinders,
- collectMonoBinders,
- collectMonoBindersAndLocs,
- collectPatBinders,
- collectQualBinders,
- collectTypedPatBinders,
-#ifdef DPH
- collectParQualBinders,
-#endif {- Data Parallel Haskell -}
- cmpInstanceTypes,
- extractMonoTyNames,
-{-OLD:-}getMentionedVars, -- MENTIONED
- getNonPrelOuterTyCon,
- mkDictApp,
- mkDictLam,
- mkTyApp,
- mkTyLam,
-
- PreludeNameFun(..)
- ) where
-
-IMPORT_Trace
-
-import AbsSyn
-
-import HsTypes ( cmpMonoType )
-import Id ( Id, DictVar(..), DictFun(..) )
-import Maybes ( Maybe(..) )
-import ProtoName ( ProtoName(..), cmpProtoName )
-import Rename ( PreludeNameFun(..) )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSynFuns-MonoBinds]{Bindings: @MonoBinds@}
-%* *
-%************************************************************************
-
-Get all the binders in some @ProtoNameMonoBinds@, IN THE ORDER OF
-APPEARANCE; e.g., in:
-\begin{verbatim}
-...
-where
- (x, y) = ...
- f i j = ...
- [a, b] = ...
-\end{verbatim}
-it should return @[x, y, f, a, b]@ (remember, order important).
-
-\begin{code}
-collectTopLevelBinders :: Binds name (InPat name) -> [name]
-collectTopLevelBinders EmptyBinds = []
-collectTopLevelBinders (SingleBind b) = collectBinders b
-collectTopLevelBinders (BindWith b _) = collectBinders b
-collectTopLevelBinders (ThenBinds b1 b2)
- = (collectTopLevelBinders b1) ++ (collectTopLevelBinders b2)
-
-collectBinders :: Bind name (InPat name) -> [name]
-collectBinders EmptyBind = []
-collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
-collectBinders (RecBind monobinds) = collectMonoBinders monobinds
-
-collectTypedBinders :: TypecheckedBind -> [Id]
-collectTypedBinders EmptyBind = []
-collectTypedBinders (NonRecBind monobinds) = collectTypedMonoBinders monobinds
-collectTypedBinders (RecBind monobinds) = collectTypedMonoBinders monobinds
-
-collectMonoBinders :: MonoBinds name (InPat name) -> [name]
-collectMonoBinders EmptyMonoBinds = []
-collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
-collectMonoBinders (FunMonoBind f matches _) = [f]
-collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
-collectMonoBinders (AndMonoBinds bs1 bs2)
- = (collectMonoBinders bs1) ++ (collectMonoBinders bs2)
-
-collectTypedMonoBinders :: TypecheckedMonoBinds -> [Id]
-collectTypedMonoBinders EmptyMonoBinds = []
-collectTypedMonoBinders (PatMonoBind pat grhss_w_binds _) = collectTypedPatBinders pat
-collectTypedMonoBinders (FunMonoBind f matches _) = [f]
-collectTypedMonoBinders (VarMonoBind v expr) = [v]
-collectTypedMonoBinders (AndMonoBinds bs1 bs2)
- = (collectTypedMonoBinders bs1) ++ (collectTypedMonoBinders bs2)
-
--- We'd like the binders -- and where they came from --
--- so we can make new ones with equally-useful origin info.
-
-collectMonoBindersAndLocs
- :: MonoBinds name (InPat name) -> [(name, SrcLoc)]
-
-collectMonoBindersAndLocs EmptyMonoBinds = []
-
-collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
- = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
-
-collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
- = collectPatBinders pat `zip` repeat locn
-
-collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)]
-
-collectMonoBindersAndLocs (VarMonoBind v expr)
- = trace "collectMonoBindersAndLocs:VarMonoBind" []
- -- ToDo: this is dubious, i.e., wrong, but harmless?
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSynFuns-Expr]{Help functions: @Expr@}
-%* *
-%************************************************************************
-
-And some little help functions that remove redundant redundancy:
-\begin{code}
-mkTyApp :: TypecheckedExpr -> [UniType] -> TypecheckedExpr
-mkTyApp expr [] = expr
-mkTyApp expr tys = TyApp expr tys
-
-mkDictApp :: TypecheckedExpr -> [DictVar] -> TypecheckedExpr
-mkDictApp expr [] = expr
-mkDictApp expr dict_vars = DictApp expr dict_vars
-
-mkTyLam :: [TyVar] -> TypecheckedExpr -> TypecheckedExpr
-mkTyLam [] expr = expr
-mkTyLam tyvars expr = TyLam tyvars expr
-
-mkDictLam :: [DictVar] -> TypecheckedExpr -> TypecheckedExpr
-mkDictLam [] expr = expr
-mkDictLam dicts expr = DictLam dicts expr
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSynFuns-Qual]{Help functions: @Quals@}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
-collectParQualBinders :: RenamedParQuals -> [Name]
-collectParQualBinders (AndParQuals q1 q2)
- = collectParQualBinders q1 ++ collectParQualBinders q2
-
-collectParQualBinders (DrawnGenIn pats pat expr)
- = concat ((map collectPatBinders pats)++[collectPatBinders pat])
-
-collectParQualBinders (IndexGen exprs pat expr)
- = (collectPatBinders pat)
-
-collectParQualBinders (ParFilter expr) = []
-#endif {- Data Parallel HAskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSynFuns-ParQuals]{Help functions: @ParQuals@}
-%* *
-%************************************************************************
-
-\begin{code}
-collectQualBinders :: [RenamedQual] -> [Name]
-
-collectQualBinders quals
- = concat (map collect quals)
- where
- collect (GeneratorQual pat expr) = collectPatBinders pat
- collect (FilterQual expr) = []
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSynFuns-pats]{Help functions: patterns}
-%* *
-%************************************************************************
-
-With un-parameterised patterns, we have to have ``duplicate'' copies
-of one or two functions:
-\begin{code}
-collectPatBinders :: InPat a -> [a]
-collectPatBinders (VarPatIn var) = [var]
-collectPatBinders (LazyPatIn pat) = collectPatBinders pat
-collectPatBinders (AsPatIn a pat) = a : (collectPatBinders pat)
-collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
-collectPatBinders (ConOpPatIn p1 c p2)= (collectPatBinders p1) ++ (collectPatBinders p2)
-collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders (NPlusKPatIn n _) = [n]
-#ifdef DPH
-collectPatBinders (ProcessorPatIn pats pat)
- = concat (map collectPatBinders pats) ++ (collectPatBinders pat)
-#endif
-collectPatBinders any_other_pat = [ {-no binders-} ]
-\end{code}
-
-Nota bene: DsBinds relies on the fact that at least for simple
-tuple patterns @collectTypedPatBinders@ returns the binders in
-the same order as they appear in the tuple.
-
-\begin{code}
-collectTypedPatBinders :: TypecheckedPat -> [Id]
-collectTypedPatBinders (VarPat var) = [var]
-collectTypedPatBinders (LazyPat pat) = collectTypedPatBinders pat
-collectTypedPatBinders (AsPat a pat) = a : (collectTypedPatBinders pat)
-collectTypedPatBinders (ConPat _ _ pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (ConOpPat p1 _ p2 _) = (collectTypedPatBinders p1) ++ (collectTypedPatBinders p2)
-collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (TuplePat pats) = concat (map collectTypedPatBinders pats)
-collectTypedPatBinders (NPlusKPat n _ _ _ _ _) = [n]
-#ifdef DPH
-collectTypedPatBinders (ProcessorPat pats _ pat)
- = (concat (map collectTypedPatBinders pats)) ++
- (collectTypedPatBinders pat)
-#endif {- Data Parallel Haskell -}
-collectTypedPatBinders any_other_pat = [ {-no binders-} ]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSynFuns-MonoType]{Help functions: @MonoType@}
-%* *
-%************************************************************************
-
-Get the type variable names from a @MonoType@. Don't use class @Eq@
-because @ProtoNames@ aren't in it.
-
-\begin{code}
-extractMonoTyNames :: (name -> name -> Bool) -> MonoType name -> [name]
-
-extractMonoTyNames eq monotype
- = get monotype []
- where
- get (MonoTyVar name) acc | name `is_elem` acc = acc
- | otherwise = name : acc
- get (MonoTyCon con tys) acc = foldr get acc tys
- get (ListMonoTy ty) acc = get ty acc
- get (FunMonoTy ty1 ty2) acc = get ty1 (get ty2 acc)
- get (TupleMonoTy tys) acc
- = foldr get_poly acc tys
- where
- get_poly (UnoverloadedTy ty) acc = get ty acc
- get_poly (ForAllTy _ ty) acc = get ty acc
- get_poly (OverloadedTy ctxt ty) acc = panic "extractMonoTyNames"
- get (MonoDict _ ty) acc = get ty acc
- get (MonoTyVarTemplate _) acc = acc
-#ifdef DPH
- get (MonoTyProc tys ty) acc = foldr get (get ty acc) tys
- get (MonoTyPod ty) acc = get ty acc
-#endif {- Data Parallel Haskell -}
-
- is_elem n [] = False
- is_elem n (x:xs) = n `eq` x || n `is_elem` xs
-\end{code}
-
-@cmpInstanceTypes@ compares two @MonoType@s which are being used as
-``instance types.'' This is used when comparing as-yet-unrenamed
-instance decls to eliminate duplicates. We allow things (e.g.,
-overlapping instances) which standard Haskell doesn't, so we must
-cater for that. Generally speaking, the instance-type
-``shape''-checker in @tcInstDecl@ will catch any mischief later on.
-
-All we do is call @cmpMonoType@, passing it a tyvar-comparing function
-that always claims that tyvars are ``equal;'' the result is that we
-end up comparing the non-tyvar-ish structure of the two types.
-
-\begin{code}
-cmpInstanceTypes :: ProtoNameMonoType -> ProtoNameMonoType -> TAG_
-
-cmpInstanceTypes ty1 ty2
- = cmpMonoType funny_cmp ty1 ty2
- where
- funny_cmp :: ProtoName -> ProtoName -> TAG_
-
- {- The only case we are really trying to catch
- is when both types are tyvars: which are both
- "Unk"s and names that start w/ a lower-case letter! (Whew.)
- -}
- funny_cmp (Unk u1) (Unk u2)
- | isLower s1 && isLower s2 = EQ_
- where
- s1 = _HEAD_ u1
- s2 = _HEAD_ u2
-
- funny_cmp x y = cmpProtoName x y -- otherwise completely normal
-\end{code}
-
-@getNonPrelOuterTyCon@ is a yukky function required when deciding
-whether to import an instance decl. If the class name or type
-constructor are ``wanted'' then we should import it, otherwise not.
-But the built-in core constructors for lists, tuples and arrows are
-never ``wanted'' in this sense. @getNonPrelOuterTyCon@ catches just a
-user-defined tycon and returns it.
-
-\begin{code}
-getNonPrelOuterTyCon :: ProtoNameMonoType -> Maybe ProtoName
-
-getNonPrelOuterTyCon (MonoTyCon con _) = Just con
-getNonPrelOuterTyCon _ = Nothing
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSynFuns-mentioned-vars]{Collect mentioned variables}
-%* *
-%************************************************************************
-
-This is just a {\em hack} whichs collects, from a module body, all the
-variables that are ``mentioned,'' either as top-level binders or as
-free variables. We can then use this list when walking over
-interfaces, using it to avoid imported variables that are patently of
-no interest.
-
-We have to be careful to look out for \tr{M..} constructs in the
-export list; if so, the game is up (and we must so report).
-
-\begin{code}
-{- OLD:MENTIONED-}
-getMentionedVars :: PreludeNameFun -- a prelude-name lookup function, so
- -- we can avoid recording prelude things
- -- as "mentioned"
- -> [IE]{-exports-} -- All the bits of the module body to
- -> [ProtoNameFixityDecl]-- look in for "mentioned" vars.
- -> [ProtoNameClassDecl]
- -> [ProtoNameInstDecl]
- -> ProtoNameBinds
-
- -> (Bool, -- True <=> M.. construct in exports
- [FAST_STRING]) -- list of vars "mentioned" in the module body
-
-getMentionedVars val_nf exports fixes class_decls inst_decls binds
- = case (mention_IE exports) of { (module_dotdot_seen, export_mentioned) ->
- (module_dotdot_seen,
- concat [export_mentioned,
- mention_Fixity fixes,
- mention_ClassDecls val_nf class_decls,
- mention_InstDecls val_nf inst_decls,
- mention_Binds val_nf True{-top-level-} binds])
- }
-\end{code}
-
-\begin{code}
-mention_IE :: [IE] -> (Bool, [FAST_STRING])
-
-mention_IE exps
- = foldr men (False, []) exps
- where
- men (IEVar str) (dotdot_seen, so_far) = (dotdot_seen, str : so_far)
- men (IEModuleContents _) (_, so_far) = (True, so_far)
- men other_ie acc = acc
-\end{code}
-
-\begin{code}
-mention_Fixity :: [ProtoNameFixityDecl] -> [FAST_STRING]
-
-mention_Fixity fixity_decls = []
- -- ToDo: if we ever do something proper with fixity declarations,
- -- this might need to do something.
-\end{code}
-
-\begin{code}
-mention_ClassDecls :: PreludeNameFun -> [ProtoNameClassDecl] -> [FAST_STRING]
-
-mention_ClassDecls val_nf [] = []
-mention_ClassDecls val_nf (ClassDecl _ _ _ _ binds _ _ : rest)
- = mention_MonoBinds val_nf True{-toplev-} binds
- ++ mention_ClassDecls val_nf rest
-\end{code}
-
-\begin{code}
-mention_InstDecls :: PreludeNameFun -> [ProtoNameInstDecl] -> [FAST_STRING]
-
-mention_InstDecls val_nf [] = []
-mention_InstDecls val_nf (InstDecl _ _ _ binds _ _ _ _ _ _ : rest)
- = mention_MonoBinds val_nf True{-toplev-} binds
- ++ mention_InstDecls val_nf rest
-\end{code}
-
-\begin{code}
-mention_Binds :: PreludeNameFun -> Bool -> ProtoNameBinds -> [FAST_STRING]
-
-mention_Binds val_nf toplev EmptyBinds = []
-mention_Binds val_nf toplev (ThenBinds a b)
- = mention_Binds val_nf toplev a ++ mention_Binds val_nf toplev b
-mention_Binds val_nf toplev (SingleBind a) = mention_Bind val_nf toplev a
-mention_Binds val_nf toplev (BindWith a _) = mention_Bind val_nf toplev a
-\end{code}
-
-\begin{code}
-mention_Bind :: PreludeNameFun -> Bool -> ProtoNameBind -> [FAST_STRING]
-
-mention_Bind val_nf toplev EmptyBind = []
-mention_Bind val_nf toplev (NonRecBind a) = mention_MonoBinds val_nf toplev a
-mention_Bind val_nf toplev (RecBind a) = mention_MonoBinds val_nf toplev a
-\end{code}
-
-\begin{code}
-mention_MonoBinds :: PreludeNameFun -> Bool -> ProtoNameMonoBinds -> [FAST_STRING]
-
-mention_MonoBinds val_nf toplev EmptyMonoBinds = []
-mention_MonoBinds val_nf toplev (AndMonoBinds a b)
- = mention_MonoBinds val_nf toplev a ++ mention_MonoBinds val_nf toplev b
-mention_MonoBinds val_nf toplev (PatMonoBind p gb _)
- = let
- rest = mention_GRHSsAndBinds val_nf gb
- in
- if toplev
- then (map stringify (collectPatBinders p)) ++ rest
- else rest
-
-mention_MonoBinds val_nf toplev (FunMonoBind v ms _)
- = let
- rest = concat (map (mention_Match val_nf) ms)
- in
- if toplev then (stringify v) : rest else rest
-
-stringify :: ProtoName -> FAST_STRING
-stringify (Unk s) = s
-\end{code}
-
-\begin{code}
-mention_Match :: PreludeNameFun -> ProtoNameMatch -> [FAST_STRING]
-
-mention_Match val_nf (PatMatch _ m) = mention_Match val_nf m
-mention_Match val_nf (GRHSMatch gb) = mention_GRHSsAndBinds val_nf gb
-\end{code}
-
-\begin{code}
-mention_GRHSsAndBinds :: PreludeNameFun -> ProtoNameGRHSsAndBinds -> [FAST_STRING]
-
-mention_GRHSsAndBinds val_nf (GRHSsAndBindsIn gs bs)
- = mention_GRHSs val_nf gs ++ mention_Binds val_nf False bs
-\end{code}
-
-\begin{code}
-mention_GRHSs :: PreludeNameFun -> [ProtoNameGRHS] -> [FAST_STRING]
-
-mention_GRHSs val_nf grhss
- = concat (map mention_grhs grhss)
- where
- mention_grhs (OtherwiseGRHS e _) = mention_Expr val_nf [] e
- mention_grhs (GRHS g e _)
- = mention_Expr val_nf [] g ++ mention_Expr val_nf [] e
-\end{code}
-
-\begin{code}
-mention_Expr :: PreludeNameFun -> [FAST_STRING] -> ProtoNameExpr -> [FAST_STRING]
-
-mention_Expr val_nf acc (Var v)
- = case v of
- Unk str | _LENGTH_ str >= 3
- -> case (val_nf str) of
- Nothing -> str : acc
- Just _ -> acc
- other -> acc
-
-mention_Expr val_nf acc (Lit _) = acc
-mention_Expr val_nf acc (Lam m) = acc ++ (mention_Match val_nf m)
-mention_Expr val_nf acc (App a b) = mention_Expr val_nf (mention_Expr val_nf acc a) b
-mention_Expr val_nf acc (OpApp a b c) = mention_Expr val_nf (mention_Expr val_nf (mention_Expr val_nf acc a) b) c
-mention_Expr val_nf acc (SectionL a b) = mention_Expr val_nf (mention_Expr val_nf acc a) b
-mention_Expr val_nf acc (SectionR a b) = mention_Expr val_nf (mention_Expr val_nf acc a) b
-mention_Expr val_nf acc (CCall _ es _ _ _) = mention_Exprs val_nf acc es
-mention_Expr val_nf acc (SCC _ e) = mention_Expr val_nf acc e
-mention_Expr val_nf acc (Case e ms) = mention_Expr val_nf acc e ++ concat (map (mention_Match val_nf) ms)
-mention_Expr val_nf acc (ListComp e q) = mention_Expr val_nf acc e ++ mention_Quals val_nf q
-mention_Expr val_nf acc (Let b e) = (mention_Expr val_nf acc e) ++ (mention_Binds val_nf False{-not toplev-} b)
-mention_Expr val_nf acc (ExplicitList es) = mention_Exprs val_nf acc es
-mention_Expr val_nf acc (ExplicitTuple es) = mention_Exprs val_nf acc es
-mention_Expr val_nf acc (ExprWithTySig e _) = mention_Expr val_nf acc e
-mention_Expr val_nf acc (If b t e) = mention_Expr val_nf (mention_Expr val_nf (mention_Expr val_nf acc b) t) e
-mention_Expr val_nf acc (ArithSeqIn s) = mention_ArithSeq val_nf acc s
-#ifdef DPH
-mention_Expr val_nf acc (ParallelZF e q) = (mention_Expr val_nf acc e) ++
- (mention_ParQuals val_nf q)
-mention_Expr val_nf acc (ExplicitPodIn es) = mention_Exprs val_nf acc es
-mention_Expr val_nf acc (ExplicitProcessor es e) = mention_Expr val_nf (mention_Exprs val_nf acc es) e
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-mention_Exprs :: PreludeNameFun -> [FAST_STRING] -> [ProtoNameExpr] -> [FAST_STRING]
-
-mention_Exprs val_nf acc [] = acc
-mention_Exprs val_nf acc (e:es) = mention_Exprs val_nf (mention_Expr val_nf acc e) es
-\end{code}
-
-\begin{code}
-mention_ArithSeq :: PreludeNameFun -> [FAST_STRING] -> ProtoNameArithSeqInfo -> [FAST_STRING]
-
-mention_ArithSeq val_nf acc (From e1)
- = mention_Expr val_nf acc e1
-mention_ArithSeq val_nf acc (FromThen e1 e2)
- = mention_Expr val_nf (mention_Expr val_nf acc e1) e2
-mention_ArithSeq val_nf acc (FromTo e1 e2)
- = mention_Expr val_nf (mention_Expr val_nf acc e1) e2
-mention_ArithSeq val_nf acc (FromThenTo e1 e2 e3)
- = mention_Expr val_nf (mention_Expr val_nf (mention_Expr val_nf acc e1) e2) e3
-\end{code}
-
-\begin{code}
-mention_Quals :: PreludeNameFun -> [ProtoNameQual] -> [FAST_STRING]
-
-mention_Quals val_nf quals
- = concat (map mention quals)
- where
- mention (GeneratorQual _ e) = mention_Expr val_nf [] e
- mention (FilterQual e) = mention_Expr val_nf [] e
-\end{code}
-
-\begin{code}
-#ifdef DPH
-mention_ParQuals :: PreludeNameFun -> ProtoNameParQuals -> [FAST_STRING]
-mention_ParQuals val_nf (ParFilter e) = mention_Expr val_nf [] e
-mention_ParQuals val_nf (DrawnGenIn _ _ e) = mention_Expr val_nf [] e
-mention_ParQuals val_nf (AndParQuals a b) = mention_ParQuals val_nf a ++
- mention_ParQuals val_nf b
-mention_ParQuals val_nf (IndexGen es _ e) = mention_Exprs val_nf [] es
- ++ mention_Expr val_nf [] e
-#endif {- Data Parallel Haskell -}
-
-{- END OLD:MENTIONED -}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[HsBinds]{Abstract syntax: top-level bindings and signatures}
-
-Datatype for: @Binds@, @Bind@, @Sig@, @MonoBinds@.
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsBinds where
-
-import AbsUniType ( pprUniType, TyVar, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import HsExpr ( Expr )
-import HsMatches ( pprMatches, pprGRHSsAndBinds, Match, GRHSsAndBinds )
-import HsPat ( ProtoNamePat(..), RenamedPat(..),
- TypecheckedPat, InPat
- IF_ATTACK_PRAGMAS(COMMA typeOfPat)
- )
-import HsPragmas ( GenPragmas, ClassOpPragmas )
-import HsTypes ( PolyType )
-import Id ( Id, DictVar(..) )
-import IdInfo ( UnfoldingGuidance )
-import Inst ( Inst )
-import Name ( Name )
-import Outputable
-import Pretty
-import ProtoName ( ProtoName(..) ) -- .. for pragmas only
-import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Binds]{Bindings: @Binds@}
-%* *
-%************************************************************************
-
-The following syntax may produce new syntax which is not part of the input,
-and which is instead a translation of the input to the typechecker.
-Syntax translations are marked TRANSLATION in comments. New empty
-productions are useful in development but may not appear in the final
-grammar.
-
-Collections of bindings, created by dependency analysis and translation:
-
-\begin{code}
-data Binds bdee pat -- binders and bindees
- = EmptyBinds
-
- | ThenBinds (Binds bdee pat)
- (Binds bdee pat)
-
- | SingleBind (Bind bdee pat)
-
- | BindWith -- Bind with a type signature.
- -- These appear only on typechecker input
- -- (PolyType [in Sigs] can't appear on output)
- (Bind bdee pat) -- really ProtoNameBind, but...
- -- (see "really" comment below)
- [Sig bdee]
-
- | AbsBinds -- Binds abstraction; TRANSLATION
- [TyVar]
- [DictVar]
- [(Id, Id)] -- (old, new) pairs
- [(Inst, Expr bdee pat)] -- local dictionaries
- (Bind bdee pat) -- "the business end"
-
- -- Creates bindings for *new* (polymorphic, overloaded) locals
- -- in terms of *old* (monomorphic, non-overloaded) ones.
- --
- -- See section 9 of static semantics paper for more details.
- -- (You can get a PhD for explaining the True Meaning
- -- of this last construct.)
-\end{code}
-
-The corresponding unparameterised synonyms:
-
-\begin{code}
-type ProtoNameBinds = Binds ProtoName ProtoNamePat
-type RenamedBinds = Binds Name RenamedPat
-type TypecheckedBinds = Binds Id TypecheckedPat
-\end{code}
-
-\begin{code}
-nullBinds :: Binds bdee pat -> Bool
-nullBinds EmptyBinds = True
-nullBinds (ThenBinds b1 b2) = (nullBinds b1) && (nullBinds b2)
-nullBinds (SingleBind b) = nullBind b
-nullBinds (BindWith b _) = nullBind b
-nullBinds (AbsBinds _ _ _ ds b) = (null ds) && (nullBind b)
-\end{code}
-
-ToDo: make this recursiveness checking also require that
-there be something there, i.e., not null ?
-\begin{code}
-{- UNUSED:
-bindsAreRecursive :: TypecheckedBinds -> Bool
-
-bindsAreRecursive EmptyBinds = False
-bindsAreRecursive (ThenBinds b1 b2)
- = (bindsAreRecursive b1) || (bindsAreRecursive b2)
-bindsAreRecursive (SingleBind b) = bindIsRecursive b
-bindsAreRecursive (BindWith b _) = bindIsRecursive b
-bindsAreRecursive (AbsBinds _ _ _ ds b)
- = (bindsAreRecursive d) || (bindIsRecursive b)
--}
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (Binds bdee pat) where
-
- ppr sty EmptyBinds = ppNil
- ppr sty (ThenBinds binds1 binds2)
- = ppAbove (ppr sty binds1) (ppr sty binds2)
- ppr sty (SingleBind bind) = ppr sty bind
- ppr sty (BindWith bind sigs)
- = ppAbove (if null sigs then ppNil else ppr sty sigs) (ppr sty bind)
- ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
- = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
- ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
- ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
- ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
- (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Sig]{@Sig@: type signatures and value-modifying user pragmas}
-%* *
-%************************************************************************
-
-It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
-``specialise this function to these four types...'') in with type
-signatures. Then all the machinery to move them into place, etc.,
-serves for both.
-
-\begin{code}
-data Sig name
- = Sig name -- a bog-std type signature
- (PolyType name)
- (GenPragmas name) -- only interface ones have pragmas
- SrcLoc
-
- | ClassOpSig name -- class-op sigs have different pragmas
- (PolyType name)
- (ClassOpPragmas name) -- only interface ones have pragmas
- SrcLoc
-
- | SpecSig name -- specialise a function or datatype ...
- (PolyType name) -- ... to these types
- (Maybe name) -- ... maybe using this as the code for it
- SrcLoc
-
- | InlineSig name -- INLINE f [howto]
- UnfoldingGuidance -- "howto": how gung-ho we are about inlining
- SrcLoc
-
- -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
- | DeforestSig name -- Deforest using this function definition
- SrcLoc
-
- | MagicUnfoldingSig
- name -- Associate the "name"d function with
- FAST_STRING -- the compiler-builtin unfolding (known
- SrcLoc -- by the String name)
-
-type ProtoNameSig = Sig ProtoName
-type RenamedSig = Sig Name
-
-type ProtoNameClassOpSig = Sig ProtoName
-type RenamedClassOpSig = Sig Name
-\end{code}
-
-\begin{code}
-instance (Outputable name) => Outputable (Sig name) where
- ppr sty (Sig var ty pragmas _)
- = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
- 4 (ppAbove (ppr sty ty)
- (ifnotPprForUser sty (ppr sty pragmas)))
-
- ppr sty (ClassOpSig var ty pragmas _)
- = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
- 4 (ppAbove (ppr sty ty)
- (ifnotPprForUser sty (ppr sty pragmas)))
-
- ppr sty (DeforestSig var _)
- = ppHang (ppCat [ppStr "{-# DEFOREST", ppr sty var])
- 4 (ppStr "#-}")
-
- ppr sty (SpecSig var ty using _)
- = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), ppr sty var, ppPStr SLIT("::")])
- 4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
- where
- pp_using Nothing = ppNil
- pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
-
- ppr sty (InlineSig var _ _)
- = ppHang (ppCat [ppPStr SLIT("{-# INLINE"), ppr sty var])
- 4 (ppCat [ppPStr SLIT("<enthusiasm not done yet>"), ppPStr SLIT("#-}")])
-
- ppr sty (MagicUnfoldingSig var str _)
- = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), ppr sty var, ppPStr str, ppPStr SLIT("#-}")]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Bind]{Binding: @Bind@}
-%* *
-%************************************************************************
-
-\begin{code}
-data Bind bdee pat -- binders and bindees
- = EmptyBind -- because it's convenient when parsing signatures
- | NonRecBind (MonoBinds bdee pat)
- | RecBind (MonoBinds bdee pat)
-\end{code}
-
-The corresponding unparameterised synonyms:
-
-\begin{code}
-type ProtoNameBind = Bind ProtoName ProtoNamePat
-type RenamedBind = Bind Name RenamedPat
-type TypecheckedBind = Bind Id TypecheckedPat
-\end{code}
-
-\begin{code}
-nullBind :: Bind bdee pat -> Bool
-nullBind EmptyBind = True
-nullBind (NonRecBind bs) = nullMonoBinds bs
-nullBind (RecBind bs) = nullMonoBinds bs
-\end{code}
-
-\begin{code}
-bindIsRecursive :: TypecheckedBind -> Bool
-bindIsRecursive EmptyBind = False
-bindIsRecursive (NonRecBind _) = False
-bindIsRecursive (RecBind _) = True
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (Bind bdee pat) where
- ppr sty EmptyBind = ppNil
- ppr sty (NonRecBind binds)
- = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
- (ppr sty binds)
- ppr sty (RecBind binds)
- = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
- (ppr sty binds)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-MonoBinds]{Bindings: @MonoBinds@}
-%* *
-%************************************************************************
-
-Global bindings (where clauses)
-
-\begin{code}
-data MonoBinds bdee pat -- binders and bindees
- = EmptyMonoBinds -- TRANSLATION
- | AndMonoBinds (MonoBinds bdee pat)
- (MonoBinds bdee pat)
- | PatMonoBind pat
- (GRHSsAndBinds bdee pat)
- SrcLoc
- | VarMonoBind Id -- TRANSLATION
- (Expr bdee pat)
- | FunMonoBind bdee
- [Match bdee pat] -- must have at least one Match
- SrcLoc
-\end{code}
-
-The corresponding unparameterised synonyms:
-\begin{code}
-type ProtoNameMonoBinds = MonoBinds ProtoName ProtoNamePat
-type RenamedMonoBinds = MonoBinds Name RenamedPat
-type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
-\end{code}
-
-\begin{code}
-nullMonoBinds :: MonoBinds bdee pat -> Bool
-nullMonoBinds EmptyMonoBinds = True
-nullMonoBinds (AndMonoBinds bs1 bs2) = (nullMonoBinds bs1) && (nullMonoBinds bs2)
-nullMonoBinds other_monobind = False
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (MonoBinds bdee pat) where
- ppr sty EmptyMonoBinds = ppNil
- ppr sty (AndMonoBinds binds1 binds2)
- = ppAbove (ppr sty binds1) (ppr sty binds2)
-
- ppr sty (PatMonoBind pat grhss_n_binds locn)
- = ppAboves [
- ifPprShowAll sty (ppr sty locn),
- (if (hasType pat) then
- ppHang (ppCat [ppr sty pat, ppStr "::"]) 4 (pprUniType sty (getType pat))
- else
- ppNil
- ),
- (ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)) ]
-
- ppr sty (FunMonoBind fun matches locn)
- = ppAboves [
- ifPprShowAll sty (ppr sty locn),
- if (hasType fun) then
- ppHang (ppCat [pprNonOp sty fun, ppStr "::"]) 4
- (pprUniType sty (getType fun))
- else
- ppNil,
- pprMatches sty (False, pprNonOp sty fun) matches
- ]
-
- ppr sty (VarMonoBind name expr)
- = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
-%
-%************************************************************************
-%* *
-\section[HsCore]{Core-syntax unfoldings in Haskell interface files}
-%* *
-%************************************************************************
-
-We could either use this, or parameterise @CoreExpr@ on @UniTypes@ and
-@TyVars@ as well. Currently trying the former.
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsCore (
- -- types:
- UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
- UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
- UnfoldingCoreAtom(..), UfId(..), UnfoldingType(..),
- UnfoldingPrimOp(..), UfCostCentre(..),
-
- -- function:
- eqUfExpr
- ) where
-
-IMPORT_Trace
-
-import AbsPrel ( PrimOp, PrimKind )
-import AbsSynFuns ( cmpInstanceTypes )
-import BasicLit ( BasicLit )
-import HsTypes -- ( cmpPolyType, PolyType(..), MonoType )
-import Maybes ( Maybe(..) )
-import Name ( Name )
-import Outputable -- class for printing, forcing
-import Pretty -- pretty-printing utilities
-import PrimOps ( tagOf_PrimOp -- HACK
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import ProtoName ( cmpProtoName, eqProtoName, ProtoName(..) ) -- .. for pragmas
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[HsCore-types]{Types for read/written Core unfoldings}
-%* *
-%************************************************************************
-
-\begin{code}
-data UnfoldingCoreExpr name
- = UfCoVar (UfId name)
- | UfCoLit BasicLit
- | UfCoCon name -- must be a "BoringUfId"...
- [UnfoldingType name]
- [UnfoldingCoreAtom name]
- | UfCoPrim (UnfoldingPrimOp name)
- [UnfoldingType name]
- [UnfoldingCoreAtom name]
- | UfCoLam [UfBinder name]
- (UnfoldingCoreExpr name)
- | UfCoTyLam name
- (UnfoldingCoreExpr name)
- | UfCoApp (UnfoldingCoreExpr name)
- (UnfoldingCoreAtom name)
- | UfCoTyApp (UnfoldingCoreExpr name)
- (UnfoldingType name)
- | UfCoCase (UnfoldingCoreExpr name)
- (UnfoldingCoreAlts name)
- | UfCoLet (UnfoldingCoreBinding name)
- (UnfoldingCoreExpr name)
- | UfCoSCC (UfCostCentre name)
- (UnfoldingCoreExpr name)
-
-type ProtoNameCoreExpr = UnfoldingCoreExpr ProtoName
-
-data UnfoldingPrimOp name
- = UfCCallOp FAST_STRING -- callee
- Bool -- True <=> casm, rather than ccall
- Bool -- True <=> might cause GC
- [UnfoldingType name] -- arg types, incl state token
- -- (which will be first)
- (UnfoldingType name) -- return type
- | UfOtherOp PrimOp
-
-data UnfoldingCoreAlts name
- = UfCoAlgAlts [(name, [UfBinder name], UnfoldingCoreExpr name)]
- (UnfoldingCoreDefault name)
- | UfCoPrimAlts [(BasicLit, UnfoldingCoreExpr name)]
- (UnfoldingCoreDefault name)
-
-data UnfoldingCoreDefault name
- = UfCoNoDefault
- | UfCoBindDefault (UfBinder name)
- (UnfoldingCoreExpr name)
-
-data UnfoldingCoreBinding name
- = UfCoNonRec (UfBinder name)
- (UnfoldingCoreExpr name)
- | UfCoRec [(UfBinder name, UnfoldingCoreExpr name)]
-
-data UnfoldingCoreAtom name
- = UfCoVarAtom (UfId name)
- | UfCoLitAtom BasicLit
-
-data UfCostCentre name
- = UfPreludeDictsCC
- Bool -- True <=> is dupd
- | UfAllDictsCC FAST_STRING -- module and group
- FAST_STRING
- Bool -- True <=> is dupd
- | UfUserCC FAST_STRING
- FAST_STRING FAST_STRING -- module and group
- Bool -- True <=> is dupd
- Bool -- True <=> is CAF
- | UfAutoCC (UfId name)
- FAST_STRING FAST_STRING -- module and group
- Bool Bool -- as above
- | UfDictCC (UfId name)
- FAST_STRING FAST_STRING -- module and group
- Bool Bool -- as above
-
-type UfBinder name = (name, UnfoldingType name)
-
-data UfId name
- = BoringUfId name
- | SuperDictSelUfId name name -- class and superclass
- | ClassOpUfId name name -- class and class op
- | DictFunUfId name -- class and type
- (UnfoldingType name)
- | ConstMethodUfId name name -- class, class op, and type
- (UnfoldingType name)
- | DefaultMethodUfId name name -- class and class op
- | SpecUfId (UfId name) -- its unspecialised "parent"
- [Maybe (MonoType name)]
- | WorkerUfId (UfId name) -- its non-working "parent"
- -- more to come?
-
-type UnfoldingType name = PolyType name
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[HsCore-print]{Printing Core unfoldings}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable name => Outputable (UnfoldingCoreExpr name) where
- ppr sty (UfCoVar v) = pprUfId sty v
- ppr sty (UfCoLit l) = ppr sty l
-
- ppr sty (UfCoCon c tys as)
- = ppCat [ppStr "(UfCoCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
- ppr sty (UfCoPrim o tys as)
- = ppCat [ppStr "(UfCoPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
-
- ppr sty (UfCoLam bs body)
- = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
- ppr sty (UfCoTyLam tv body)
- = ppCat [ppStr "/\\", ppr sty tv, ppStr "->", ppr sty body]
-
- ppr sty (UfCoApp fun arg)
- = ppCat [ppStr "(UfCoApp", ppr sty fun, ppr sty arg, ppStr ")"]
- ppr sty (UfCoTyApp expr ty)
- = ppCat [ppStr "(UfCoTyApp", ppr sty expr, ppr sty ty, ppStr ")"]
-
- ppr sty (UfCoCase scrut alts)
- = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
- where
- pp_alts (UfCoAlgAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
- where
- pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
- pp_alts (UfCoPrimAlts alts deflt)
- = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
- where
- pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
-
- pp_deflt UfCoNoDefault = ppNil
- pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
-
- ppr sty (UfCoLet (UfCoNonRec b rhs) body)
- = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
- ppr sty (UfCoLet (UfCoRec pairs) body)
- = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
- where
- pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
-
- ppr sty (UfCoSCC uf_cc body)
- = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
-
-instance Outputable name => Outputable (UnfoldingPrimOp name) where
- ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
- = let
- before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
- after = if is_casm then ppStr "'' " else ppSP
- in
- ppBesides [before, ppPStr str, after,
- ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
- ppr sty (UfOtherOp op)
- = ppr sty op
-
-instance Outputable name => Outputable (UnfoldingCoreAtom name) where
- ppr sty (UfCoVarAtom v) = pprUfId sty v
- ppr sty (UfCoLitAtom l) = ppr sty l
-
-pprUfId sty (BoringUfId v) = ppr sty v
-pprUfId sty (SuperDictSelUfId c sc)
- = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
-pprUfId sty (ClassOpUfId c op)
- = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
-pprUfId sty (DictFunUfId c ty)
- = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
-pprUfId sty (ConstMethodUfId c op ty)
- = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
-pprUfId sty (DefaultMethodUfId c ty)
- = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
-
-pprUfId sty (SpecUfId unspec ty_maybes)
- = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
- ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
- where
- pp_ty_maybe Nothing = ppStr "_N_"
- pp_ty_maybe (Just t) = ppr sty t
-
-pprUfId sty (WorkerUfId unwrkr)
- = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[HsCore-equality]{Comparing Core unfoldings}
-%* *
-%************************************************************************
-
-We want to check that they are {\em exactly} the same.
-
-\begin{code}
-eqUfExpr :: ProtoNameCoreExpr -> ProtoNameCoreExpr -> Bool
-
-eqUfExpr (UfCoVar v1) (UfCoVar v2) = eqUfId v1 v2
-eqUfExpr (UfCoLit l1) (UfCoLit l2) = l1 == l2
-
-eqUfExpr (UfCoCon c1 tys1 as1) (UfCoCon c2 tys2 as2)
- = eq_name c1 c2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
-eqUfExpr (UfCoPrim o1 tys1 as1) (UfCoPrim o2 tys2 as2)
- = eq_op o1 o2 && eq_lists eq_type tys1 tys2 && eq_lists eq_atom as1 as2
- where
- eq_op (UfCCallOp _ _ _ _ _) (UfCCallOp _ _ _ _ _) = True
- eq_op (UfOtherOp o1) (UfOtherOp o2)
- = tagOf_PrimOp o1 _EQ_ tagOf_PrimOp o2
-
-eqUfExpr (UfCoLam bs1 body1) (UfCoLam bs2 body2)
- = eq_lists eq_binder bs1 bs2 && eqUfExpr body1 body2
-eqUfExpr (UfCoTyLam tv1 body1) (UfCoTyLam tv2 body2)
- = eq_name tv1 tv2 && eqUfExpr body1 body2
-
-eqUfExpr (UfCoApp fun1 arg1) (UfCoApp fun2 arg2)
- = eqUfExpr fun1 fun2 && eq_atom arg1 arg2
-eqUfExpr (UfCoTyApp expr1 ty1) (UfCoTyApp expr2 ty2)
- = eqUfExpr expr1 expr2 && eq_type ty1 ty2
-
-eqUfExpr (UfCoCase scrut1 alts1) (UfCoCase scrut2 alts2)
- = eqUfExpr scrut1 scrut2 && eq_alts alts1 alts2
- where
- eq_alts (UfCoAlgAlts alts1 deflt1) (UfCoAlgAlts alts2 deflt2)
- = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
- where
- eq_alt (c1,bs1,rhs1) (c2,bs2,rhs2)
- = eq_name c1 c2 && eq_lists eq_binder bs1 bs2 && eqUfExpr rhs1 rhs2
-
- eq_alts (UfCoPrimAlts alts1 deflt1) (UfCoPrimAlts alts2 deflt2)
- = eq_lists eq_alt alts1 alts2 && eq_deflt deflt1 deflt2
- where
- eq_alt (l1,rhs1) (l2,rhs2)
- = l1 == l2 && eqUfExpr rhs1 rhs2
-
- eq_alts _ _ = False -- catch-all
-
- eq_deflt UfCoNoDefault UfCoNoDefault = True
- eq_deflt (UfCoBindDefault b1 rhs1) (UfCoBindDefault b2 rhs2)
- = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
- eq_deflt _ _ = False
-
-eqUfExpr (UfCoLet (UfCoNonRec b1 rhs1) body1) (UfCoLet (UfCoNonRec b2 rhs2) body2)
- = eq_binder b1 b2 && eqUfExpr rhs1 rhs2 && eqUfExpr body1 body2
-
-eqUfExpr (UfCoLet (UfCoRec pairs1) body1) (UfCoLet (UfCoRec pairs2) body2)
- = eq_lists eq_pair pairs1 pairs2 && eqUfExpr body1 body2
- where
- eq_pair (b1,rhs1) (b2,rhs2) = eq_binder b1 b2 && eqUfExpr rhs1 rhs2
-
-eqUfExpr (UfCoSCC cc1 body1) (UfCoSCC cc2 body2)
- = {-trace "eqUfExpr: not comparing cost-centres!"-} (eqUfExpr body1 body2)
-
-eqUfExpr _ _ = False -- Catch-all
-\end{code}
-
-\begin{code}
-eqUfId (BoringUfId n1) (BoringUfId n2)
- = eq_name n1 n2
-eqUfId (SuperDictSelUfId a1 b1) (SuperDictSelUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (ClassOpUfId a1 b1) (ClassOpUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (DictFunUfId c1 t1) (DictFunUfId c2 t2)
- = eq_name c1 c2 && eq_tycon t1 t2 -- NB: **** only compare TyCons ******
- where
- eq_tycon (UnoverloadedTy ty1) (UnoverloadedTy ty2)
- = case (cmpInstanceTypes ty1 ty2) of { EQ_ -> True; _ -> False }
- eq_tycon ty1 ty2
- = trace "eq_tycon" (eq_type ty1 ty2) -- desperately try something else
-
-eqUfId (ConstMethodUfId a1 b1 t1) (ConstMethodUfId a2 b2 t2)
- = eq_name a1 a2 && eq_name b1 b2 && eq_type t1 t2
-eqUfId (DefaultMethodUfId a1 b1) (DefaultMethodUfId a2 b2)
- = eq_name a1 a2 && eq_name b1 b2
-eqUfId (SpecUfId id1 tms1) (SpecUfId id2 tms2)
- = eqUfId id1 id2 && eq_lists eq_ty_maybe tms1 tms2
- where
- eq_ty_maybe Nothing Nothing = True
- eq_ty_maybe (Just ty1) (Just ty2)
- = eq_type (UnoverloadedTy ty1) (UnoverloadedTy ty2)
- -- a HACKy way to compare MonoTypes (ToDo) [WDP 94/05/02]
- eq_ty_maybe _ _ = False
-eqUfId (WorkerUfId id1) (WorkerUfId id2)
- = eqUfId id1 id2
-eqUfId _ _ = False -- catch-all
-\end{code}
-
-\begin{code}
-eq_atom (UfCoVarAtom id1) (UfCoVarAtom id2) = eqUfId id1 id2
-eq_atom (UfCoLitAtom l1) (UfCoLitAtom l2) = l1 == l2
-eq_atom _ _ = False
-
-eq_binder (n1, ty1) (n2, ty2) = eq_name n1 n2 && eq_type ty1 ty2
-
-eq_name :: ProtoName -> ProtoName -> Bool
-eq_name pn1 pn2 = eqProtoName pn1 pn2 -- uses original names
-
-eq_type ty1 ty2
- = case (cmpPolyType cmpProtoName ty1 ty2) of { EQ_ -> True; _ -> False }
-\end{code}
-
-\begin{code}
-eq_lists :: (a -> a -> Bool) -> [a] -> [a] -> Bool
-
-eq_lists eq [] [] = True
-eq_lists eq [] _ = False
-eq_lists eq _ [] = False
-eq_lists eq (x:xs) (y:ys) = eq x y && eq_lists eq xs ys
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[HsDecls]{Abstract syntax: global declarations}
-
-Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
-@InstDecl@, @DefaultDecl@.
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsDecls where
-
-import HsBinds ( nullMonoBinds, ProtoNameMonoBinds(..),
- MonoBinds, Sig
- )
-import HsPat ( ProtoNamePat(..), RenamedPat(..), InPat )
-import HsPragmas ( DataPragmas, TypePragmas, ClassPragmas,
- InstancePragmas, ClassOpPragmas
- )
-import HsTypes
-import Id ( Id )
-import Name ( Name )
-import Outputable
-import Pretty
-import ProtoName ( cmpProtoName, ProtoName(..) ) -- .. for pragmas only
-import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[FixityDecl]{A fixity declaration}
-%* *
-%************************************************************************
-
-These are only used in generating interfaces at the moment. They are
-not used in pretty-printing.
-
-\begin{code}
-data FixityDecl name
- = InfixL name Int
- | InfixR name Int
- | InfixN name Int
-
-type ProtoNameFixityDecl = FixityDecl ProtoName
-type RenamedFixityDecl = FixityDecl Name
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name)
- => Outputable (FixityDecl name) where
- ppr sty (InfixL var prec) = ppCat [ppStr "infixl", ppInt prec, pprOp sty var]
- ppr sty (InfixR var prec) = ppCat [ppStr "infixr", ppInt prec, pprOp sty var]
- ppr sty (InfixN var prec) = ppCat [ppStr "infix ", ppInt prec, pprOp sty var]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyDecl]{An algebraic datatype or type-synonym declaration (plus @DataTypeSig@...)}
-%* *
-%************************************************************************
-
-\begin{code}
-data TyDecl name
- = TyData (Context name) -- context (not used yet)
- name -- type constructor
- [name] -- type variables
- [ConDecl name] -- data constructors
- [name] -- derivings
- (DataPragmas name)
- SrcLoc
-
- | TySynonym name -- type constructor
- [name] -- type variables
- (MonoType name) -- synonym expansion
- TypePragmas
- SrcLoc
-
-type ProtoNameTyDecl = TyDecl ProtoName
-type RenamedTyDecl = TyDecl Name
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name)
- => Outputable (TyDecl name) where
-
- ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
- = ppAbove (ifPprShowAll sty (ppr sty src_loc)) -- ToDo: pragmas
- (ppHang (ppCat [ppStr "data", pprContext sty context, ppr sty tycon, interppSP sty tyvars])
- 4
- (ppSep [
- ppr sty condecls,
- if (null derivings) then
- ppNil
- else
- ppBesides [ppStr "deriving (", interpp'SP sty derivings, ppStr ")"]]))
-
- ppr sty (TySynonym tycon tyvars mono_ty pragmas src_loc)
- = ppHang (ppCat [ppStr "type", ppr sty tycon, interppSP sty tyvars])
- 4 (ppCat [ppEquals, ppr sty mono_ty,
- ifPprShowAll sty (ppr sty src_loc)]) -- ToDo: pragmas
-\end{code}
-
-A type for recording what type synonyms the user wants treated as {\em
-abstract} types. It's called a ``Sig'' because it's sort of like a
-``type signature'' for an synonym declaration.
-
-Note: the Right Way to do this abstraction game is for the language to
-support it.
-\begin{code}
-data DataTypeSig name
- = AbstractTypeSig name -- tycon to abstract-ify
- SrcLoc
- | SpecDataSig name -- tycon to specialise
- (MonoType name)
- SrcLoc
-
-
-type ProtoNameDataTypeSig = DataTypeSig ProtoName
-type RenamedDataTypeSig = DataTypeSig Name
-
-instance (NamedThing name, Outputable name)
- => Outputable (DataTypeSig name) where
-
- ppr sty (AbstractTypeSig tycon _)
- = ppCat [ppStr "{-# ABSTRACT", ppr sty tycon, ppStr "#-}"]
-
- ppr sty (SpecDataSig tycon ty _)
- = ppCat [ppStr "{-# SPECIALSIE data", ppr sty ty, ppStr "#-}"]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ConDecl]{A data-constructor declaration}
-%* *
-%************************************************************************
-
-A data constructor for an algebraic data type.
-
-\begin{code}
-data ConDecl name = ConDecl name [MonoType name] SrcLoc
-
-type ProtoNameConDecl = ConDecl ProtoName
-type RenamedConDecl = ConDecl Name
-\end{code}
-
-In checking interfaces, we need to ``compare'' @ConDecls@. Use with care!
-\begin{code}
-eqConDecls cons1 cons2
- = case (cmpList cmp cons1 cons2) of { EQ_ -> True; _ -> False }
- where
- cmp (ConDecl n1 tys1 _) (ConDecl n2 tys2 _)
- = case cmpProtoName n1 n2 of
- EQ_ -> cmpList (cmpMonoType cmpProtoName) tys1 tys2
- xxx -> xxx
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
-
- ppr sty (ConDecl con mono_tys src_loc)
- = ppCat [pprNonOp sty con,
- ppInterleave ppNil (map (pprParendMonoType sty) mono_tys)]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ClassDecl]{A class declaration}
-%* *
-%************************************************************************
-
-\begin{code}
-data ClassDecl name pat
- = ClassDecl (Context name) -- context...
- name -- name of the class
- name -- the class type variable
- [Sig name] -- methods' signatures
- (MonoBinds name pat) -- default methods
- (ClassPragmas name)
- SrcLoc
-
-type ProtoNameClassDecl = ClassDecl ProtoName ProtoNamePat
-type RenamedClassDecl = ClassDecl Name RenamedPat
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name,
- NamedThing pat, Outputable pat)
- => Outputable (ClassDecl name pat) where
-
- ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
- = ppAboves [ppCat [ppStr "class", pprContext sty context, ppr sty clas,
- ppr sty tyvar, ppStr "where"],
- -- ToDo: really shouldn't print "where" unless there are sigs
- ppNest 4 (ppAboves (map (ppr sty) sigs)),
- ppNest 4 (ppr sty methods),
- ppNest 4 (ppr sty pragmas)]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[InstDecl]{An instance declaration (also, @SpecialisedInstanceSig@)}
-%* *
-%************************************************************************
-
-\begin{code}
-data InstDecl name pat
- = InstDecl (Context name)
- name -- class
- (MonoType name)
- (MonoBinds name pat)
- Bool -- True <=> This instance decl is from the
- -- module being compiled; False <=> It is from
- -- an imported interface.
-
- FAST_STRING{-ModuleName-}
- -- The module where the instance decl
- -- originally came from; easy enough if it's
- -- the module being compiled; otherwise, the
- -- info comes from a pragma.
-
- FAST_STRING
- -- Name of the module who told us about this
- -- inst decl (the `informer') ToDo: listify???
-
- [Sig name] -- actually user-supplied pragmatic info
- (InstancePragmas name) -- interface-supplied pragmatic info
- SrcLoc
-
-type ProtoNameInstDecl = InstDecl ProtoName ProtoNamePat
-type RenamedInstDecl = InstDecl Name RenamedPat
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name,
- NamedThing pat, Outputable pat)
- => Outputable (InstDecl name pat) where
-
- ppr sty (InstDecl context clas ty binds local modname imod uprags pragmas src_loc)
- = let
- top_matter = ppCat [ppStr "instance", pprContext sty context, ppr sty clas, ppr sty ty]
- in
- if nullMonoBinds binds && null uprags then
- ppAbove top_matter (ppNest 4 (ppr sty pragmas))
- else
- ppAboves [
- ppCat [top_matter, ppStr "where"],
- ppNest 4 (ppr sty uprags),
- ppNest 4 (ppr sty binds),
- ppNest 4 (ppr sty pragmas) ]
-\end{code}
-
-A type for recording what instances the user wants to specialise;
-called a ``Sig'' because it's sort of like a ``type signature'' for an
-instance.
-\begin{code}
-data SpecialisedInstanceSig name
- = InstSpecSig name -- class
- (MonoType name) -- type to specialise to
- SrcLoc
-
-type ProtoNameSpecialisedInstanceSig = SpecialisedInstanceSig ProtoName
-type RenamedSpecialisedInstanceSig = SpecialisedInstanceSig Name
-
-instance (NamedThing name, Outputable name)
- => Outputable (SpecialisedInstanceSig name) where
-
- ppr sty (InstSpecSig clas ty _)
- = ppCat [ppStr "{-# SPECIALIZE instance", ppr sty clas, ppr sty ty, ppStr "#-}"]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[DefaultDecl]{A @default@ declaration}
-%* *
-%************************************************************************
-
-There can only be one default declaration per module, but it is hard
-for the parser to check that; we pass them all through in the abstract
-syntax, and that restriction must be checked in the front end.
-
-\begin{code}
-data DefaultDecl name
- = DefaultDecl [MonoType name]
- SrcLoc
-
-type ProtoNameDefaultDecl = DefaultDecl ProtoName
-type RenamedDefaultDecl = DefaultDecl Name
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name)
- => Outputable (DefaultDecl name) where
-
- ppr sty (DefaultDecl tys src_loc)
- = ppBesides [ppStr "default (", interpp'SP sty tys, ppStr ")"]
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[HsExpr]{Abstract Haskell syntax: expressions}
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsExpr where
-
-import AbsUniType ( pprUniType, pprParendUniType, TyVar, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Name ( Name )
-import Unique ( Unique )
-import HsBinds ( Binds )
-import HsLit ( Literal )
-import HsMatches ( pprMatches, pprMatch, Match )
-import HsPat ( ProtoNamePat(..), RenamedPat(..),
- TypecheckedPat, InPat
- IF_ATTACK_PRAGMAS(COMMA typeOfPat)
- )
-import HsTypes ( PolyType )
-import Id ( Id, DictVar(..), DictFun(..) )
-import Outputable
-import ProtoName ( ProtoName(..) ) -- .. for pragmas only
-import Pretty
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Expr]{Expressions proper}
-%* *
-%************************************************************************
-
-\begin{code}
-data Expr bdee pat
- = Var bdee -- variable
- | Lit Literal -- literal
-
- | Lam (Match bdee pat) -- lambda
- | App (Expr bdee pat) -- application
- (Expr bdee pat)
-
- -- Operator applications and sections.
- -- NB Bracketed ops such as (+) come out as Vars.
-
- | OpApp (Expr bdee pat) (Expr bdee pat) (Expr bdee pat)
- -- middle expr is the "op"
-
- -- ADR Question? Why is the "op" in a section an expr when it will
- -- have to be of the form (Var op) anyway?
- -- WDP Answer: But when the typechecker gets ahold of it, it may
- -- apply the var to a few types; it will then be an expression.
-
- | SectionL (Expr bdee pat) (Expr bdee pat)
- -- right expr is the "op"
- | SectionR (Expr bdee pat) (Expr bdee pat)
- -- left expr is the "op"
-
- | CCall FAST_STRING -- call into the C world; string is
- [Expr bdee pat] -- the C function; exprs are the
- -- arguments to pass.
- Bool -- True <=> might cause Haskell
- -- garbage-collection (must generate
- -- more paranoid code)
- Bool -- True <=> it's really a "casm"
- -- NOTE: this CCall is the *boxed*
- -- version; the desugarer will convert
- -- it into the unboxed "ccall#".
- UniType -- The result type; will be *bottom*
- -- until the typechecker gets ahold of it
-
- | SCC FAST_STRING -- set cost centre annotation
- (Expr bdee pat) -- expr whose cost is to be measured
-
- | Case (Expr bdee pat)
- [Match bdee pat] -- must have at least one Match
-
- | If -- conditional
- (Expr bdee pat) -- predicate
- (Expr bdee pat) -- then part
- (Expr bdee pat) -- else part
-
- | Let (Binds bdee pat) -- let(rec)
- (Expr bdee pat)
-
- | ListComp (Expr bdee pat) -- list comprehension
- [Qual bdee pat] -- at least one Qual(ifier)
-
- | ExplicitList -- syntactic list
- [Expr bdee pat]
- | ExplicitListOut -- TRANSLATION
- UniType -- Unitype gives type of components of list
- [Expr bdee pat]
-
- | ExplicitTuple -- tuple
- [Expr bdee pat]
- -- NB: Unit is ExplicitTuple []
- -- for tuples, we can get the types
- -- direct from the components
-
- | ExprWithTySig -- signature binding
- (Expr bdee pat)
- (PolyType bdee)
- | ArithSeqIn -- arithmetic sequence
- (ArithSeqInfo bdee pat)
- | ArithSeqOut
- (Expr bdee pat) -- (typechecked, of course)
- (ArithSeqInfo bdee pat)
-#ifdef DPH
- | ParallelZF
- (Expr bdee pat)
- (ParQuals bdee pat)
- | ExplicitPodIn
- [Expr bdee pat]
- | ExplicitPodOut
- UniType -- Unitype gives type of components of list
- [Expr bdee pat]
- | ExplicitProcessor
- [Expr bdee pat]
- (Expr bdee pat)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Everything from here on appears only in typechecker output; hence, the
-explicit @Id@s.
-\begin{code}
- | TyLam -- TRANSLATION
- [TyVar] -- Not TyVarTemplate, which only occur in a
- -- binding position in a forall type.
- (Expr bdee pat)
- | TyApp -- TRANSLATION
- (Expr bdee pat) -- generated by Spec
- [UniType]
-
- -- DictLam and DictApp are "inverses"
- | DictLam
- [DictVar]
- (Expr bdee pat)
- | DictApp
- (Expr bdee pat)
- [DictVar] -- dictionary names
-
- -- ClassDictLam and Dictionary are "inverses" (see note below)
- | ClassDictLam
- [DictVar]
- [Id]
- -- The ordering here allows us to do away with dicts and methods
-
- -- [I don't understand this comment. WDP. Perhaps a ptr to
- -- a complete description of what's going on ? ]
- (Expr bdee pat)
- | Dictionary
- [DictVar] -- superclass dictionary names
- [Id] -- method names
- | SingleDict -- a simple special case of Dictionary
- DictVar -- local dictionary name
-\end{code}
-
-\begin{code}
-type ProtoNameExpr = Expr ProtoName ProtoNamePat
-
-type RenamedExpr = Expr Name RenamedPat
-
-type TypecheckedExpr = Expr Id TypecheckedPat
-\end{code}
-
-A @Dictionary@, unless of length 0 or 1, becomes a tuple. A
-@ClassDictLam dictvars methods expr@ is, therefore:
-\begin{verbatim}
-\ x -> case x of ( dictvars-and-methods-tuple ) -> expr
-\end{verbatim}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (Expr bdee pat) where
- ppr = pprExpr
-\end{code}
-
-\begin{code}
-pprExpr :: (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- PprStyle -> Expr bdee pat -> Pretty
-
-pprExpr sty (Var v)
- = if (isOpLexeme v) then
- ppBesides [ppLparen, ppr sty v, ppRparen]
- else
- ppr sty v
-
-pprExpr sty (Lit lit) = ppr sty lit
-pprExpr sty (Lam match)
- = ppCat [ppStr "\\", ppNest 2 (pprMatch sty True match)]
-
-pprExpr sty expr@(App e1 e2)
- = let (fun, args) = collect_args expr [] in
- ppHang (pprParendExpr sty fun) 4 (ppSep (map (pprParendExpr sty) args))
- where
- collect_args (App fun arg) args = collect_args fun (arg:args)
- collect_args fun args = (fun, args)
-
-pprExpr sty (OpApp e1 op e2)
- = case op of
- Var v -> pp_infixly v
- _ -> pp_prefixly
- where
- pp_e1 = pprParendExpr sty e1
- pp_e2 = pprParendExpr sty e2
-
- pp_prefixly
- = ppHang (pprParendExpr sty op) 4 (ppSep [pp_e1, pp_e2])
-
- pp_infixly v
- = ppSep [pp_e1, ppCat [pprOp sty v, pp_e2]]
-
-pprExpr sty (SectionL expr op)
- = case op of
- Var v -> pp_infixly v
- _ -> pp_prefixly
- where
- pp_expr = pprParendExpr sty expr
-
- pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op])
- 4 (ppCat [pp_expr, ppStr "_x )"])
- pp_infixly v
- = ppSep [ ppBesides [ppLparen, pp_expr],
- ppBesides [pprOp sty v, ppRparen] ]
-
-pprExpr sty (SectionR op expr)
- = case op of
- Var v -> pp_infixly v
- _ -> pp_prefixly
- where
- pp_expr = pprParendExpr sty expr
-
- pp_prefixly = ppHang (ppCat [ppStr "( \\ _x ->", ppr sty op, ppStr "_x"])
- 4 (ppBesides [pp_expr, ppRparen])
- pp_infixly v
- = ppSep [ ppBesides [ppLparen, pprOp sty v],
- ppBesides [pp_expr, ppRparen] ]
-
-pprExpr sty (CCall fun args _ is_asm result_ty)
- = ppHang (if is_asm
- then ppBesides [ppStr "_casm_ ``", ppPStr fun, ppStr "''"]
- else ppCat [ppStr "_ccall_", ppPStr fun])
- 4 (ppSep (map (pprParendExpr sty) args
- {-++ [ppCat [ppStr "{-", ppr sty result_ty, ppStr "-}"]]-}))
- -- printing the result type can give reader panics (ToDo: fix)
-
-pprExpr sty (SCC label expr)
- = ppSep [ ppBesides [ppStr "scc", ppBesides [ppChar '"', ppPStr label, ppChar '"'] ],
- pprParendExpr sty expr ]
-
-pprExpr sty (Case expr matches)
- = ppSep [ ppSep [ppStr "case", ppNest 4 (pprExpr sty expr), ppStr "of"],
- ppNest 2 (pprMatches sty (True, ppNil) matches) ]
-
-pprExpr sty (ListComp expr quals)
- = ppHang (ppCat [ppStr "[", pprExpr sty expr, ppStr "|"])
- 4 (ppSep [interpp'SP sty quals, ppRbrack])
-
--- special case: let ... in let ...
-pprExpr sty (Let binds expr@(Let _ _))
- = ppSep [ppHang (ppStr "let") 2 (ppCat [ppr sty binds, ppStr "in"]),
- ppr sty expr]
-
-pprExpr sty (Let binds expr)
- = ppSep [ppHang (ppStr "let") 2 (ppr sty binds),
- ppHang (ppStr "in") 2 (ppr sty expr)]
-
-pprExpr sty (ExplicitList exprs)
- = ppBesides [ppLbrack, ppInterleave ppComma (map (pprExpr sty) exprs), ppRbrack]
-pprExpr sty (ExplicitListOut ty exprs)
- = ppBesides [ ppLbrack, ppInterleave ppComma (map (pprExpr sty) exprs), ppRbrack,
- case sty of
- PprForUser -> ppNil
- _ -> ppBesides [ppStr " (", pprUniType sty ty, ppStr ")"] ]
-
-pprExpr sty (ExplicitTuple exprs)
- = ppBesides [ppLparen, ppInterleave ppComma (map (pprExpr sty) exprs), ppRparen]
-pprExpr sty (ExprWithTySig expr sig)
- = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppStr " ::"])
- 4 (ppBesides [ppr sty sig, ppRparen])
-
-pprExpr sty (If e1 e2 e3)
- = ppSep [ppCat [ppStr "if", ppNest 2 (pprExpr sty e1), ppStr "then"],
- ppNest 4 (pprExpr sty e2),
- ppStr "else",
- ppNest 4 (pprExpr sty e3)]
-pprExpr sty (ArithSeqIn info)
- = ppCat [ppLbrack, ppr sty info, ppRbrack]
-pprExpr sty (ArithSeqOut expr info)
- = case sty of
- PprForUser ->
- ppBesides [ppLbrack, ppr sty info, ppRbrack]
- _ ->
- ppBesides [ppLbrack, ppLparen, ppr sty expr, ppRparen, ppr sty info, ppRbrack]
-#ifdef DPH
-pprExpr sty (ParallelZF expr pquals)
- = ppHang (ppCat [ppStr "<<" , pprExpr sty expr , ppStr "|"])
- 4 (ppSep [ppr sty pquals, ppStr ">>"])
-
-pprExpr sty (ExplicitPodIn exprs)
- = ppBesides [ppStr "<<", ppInterleave ppComma (map (pprExpr sty) exprs) ,
- ppStr ">>"]
-
-pprExpr sty (ExplicitPodOut ty exprs)
- = ppBesides [ppStr "(",ppStr "<<",
- ppInterleave ppComma (map (pprExpr sty) exprs),
- ppStr ">>", ppStr " ::" , ppStr "<<" , pprUniType sty ty ,
- ppStr ">>" , ppStr ")"]
-
-pprExpr sty (ExplicitProcessor exprs expr)
- = ppBesides [ppStr "(|", ppInterleave ppComma (map (pprExpr sty) exprs) ,
- ppSemi , pprExpr sty expr, ppStr "|)"]
-
-#endif {- Data Parallel Haskell -}
-
--- for these translation-introduced things, we don't show them
--- if style is PprForUser
-
-pprExpr sty (TyLam tyvars expr)
- = case sty of
- PprForUser -> pprExpr sty expr
- _ -> ppHang (ppCat [ppStr "/\\", interppSP sty tyvars, ppStr "->"])
- 4 (pprExpr sty expr)
-
-pprExpr sty (TyApp expr [ty])
- = case sty of
- PprForUser -> pprExpr sty expr
- _ -> ppHang (ppBeside pp_note (pprExpr sty expr)) 4 (pprParendUniType sty ty)
- where
- pp_note = ifPprShowAll sty (ppStr "{-TyApp-} ")
-
-pprExpr sty (TyApp expr tys)
- = case sty of
- PprForUser -> pprExpr sty expr
- _ -> ppHang (ppBeside pp_note (pprExpr sty expr))
- 4 (ppBesides [ppLbrack, interpp'SP sty tys, ppRbrack])
- where
- pp_note = ifPprShowAll sty (ppStr "{-TyApp-} ")
-
-pprExpr sty (DictLam dictvars expr)
- = case sty of
- PprForUser -> pprExpr sty expr
- _ -> ppHang (ppCat [ppStr "\\{-dict-}", interppSP sty dictvars, ppStr "->"])
- 4 (pprExpr sty expr)
-
-pprExpr sty (DictApp expr [dname])
- = case sty of
- PprForUser -> pprExpr sty expr
- _ -> ppHang (ppBeside pp_note (pprExpr sty expr)) 4 (ppr sty dname)
- where
- pp_note = ifPprShowAll sty (ppStr "{-DictApp-} ")
-
-pprExpr sty (DictApp expr dnames)
- = case sty of
- PprForUser -> pprExpr sty expr
- _ -> ppHang (ppBeside pp_note (pprExpr sty expr))
- 4 (ppBesides [ppLbrack, interpp'SP sty dnames, ppRbrack])
- where
- pp_note = ifPprShowAll sty (ppStr "{-DictApp-} ")
-
-pprExpr sty (ClassDictLam dicts methods expr)
- = case sty of
- PprForUser -> pprExpr sty expr
- _ -> ppHang (ppCat [ppStr "\\{-classdict-}",
- ppBesides [ppLbrack, interppSP sty dicts, ppRbrack],
- ppBesides [ppLbrack, interppSP sty methods, ppRbrack],
- ppStr "->"])
- 4 (pprExpr sty expr)
-
-pprExpr sty (Dictionary dictNames methods)
- = ppSep [ppBesides [ppLparen, ppStr "{-dict-}"],
- ppBesides [ppLbrack, interpp'SP sty dictNames, ppRbrack],
- ppBesides [ppLbrack, interpp'SP sty methods, ppRbrack, ppRparen]]
-
-pprExpr sty (SingleDict dname)
- = ppCat [ppStr "{-singleDict-}", ppr sty dname]
-\end{code}
-
-Parenthesize unless very simple:
-\begin{code}
-pprParendExpr :: (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- PprStyle -> Expr bdee pat -> Pretty
-pprParendExpr sty e@(Var _) = pprExpr sty e
-pprParendExpr sty e@(Lit _) = pprExpr sty e
-pprParendExpr sty other_e = ppBesides [ppLparen, pprExpr sty other_e, ppRparen]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyntax-enums-list-comps]{Enumerations and list comprehensions}
-%* *
-%************************************************************************
-
-\begin{code}
-data ArithSeqInfo bdee pat
- = From (Expr bdee pat)
- | FromThen (Expr bdee pat) (Expr bdee pat)
- | FromTo (Expr bdee pat) (Expr bdee pat)
- | FromThenTo (Expr bdee pat) (Expr bdee pat) (Expr bdee pat)
-
-type ProtoNameArithSeqInfo = ArithSeqInfo ProtoName ProtoNamePat
-type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat
-type TypecheckedArithSeqInfo = ArithSeqInfo Id TypecheckedPat
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (ArithSeqInfo bdee pat) where
- ppr sty (From e1) = ppBesides [ppr sty e1, ppStr " .. "]
- ppr sty (FromThen e1 e2) = ppBesides [ppr sty e1, pp'SP, ppr sty e2, ppStr " .. "]
- ppr sty (FromTo e1 e3) = ppBesides [ppr sty e1, ppStr " .. ", ppr sty e3]
- ppr sty (FromThenTo e1 e2 e3)
- = ppBesides [ppr sty e1, pp'SP, ppr sty e2, ppStr " .. ", ppr sty e3]
-\end{code}
-
-``Qualifiers'' in list comprehensions:
-\begin{code}
-data Qual bdee pat
- = GeneratorQual pat (Expr bdee pat)
- | FilterQual (Expr bdee pat)
-
-type ProtoNameQual = Qual ProtoName ProtoNamePat
-type RenamedQual = Qual Name RenamedPat
-type TypecheckedQual = Qual Id TypecheckedPat
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (Qual bdee pat) where
- ppr sty (GeneratorQual pat expr)
- = ppCat [ppr sty pat, ppStr "<-", ppr sty expr]
- ppr sty (FilterQual expr) = ppr sty expr
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyntax-parallel-quals]{Parallel Qualifiers for ZF expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-#ifdef DPH
-data ParQuals var pat
- = AndParQuals (ParQuals var pat)
- (ParQuals var pat)
- | DrawnGenIn [pat]
- pat
- (Expr var pat) -- (|pat1,...,patN;pat|)<<-exp
-
- | DrawnGenOut [pat] -- Same information as processor
- [(Expr var pat)] -- Conversion fn of type t -> Integer
- pat -- to keep things together :-)
- (Expr var pat)
- | IndexGen [(Expr var pat)]
- pat
- (Expr var pat) -- (|exp1,...,expN;pat|)<<-exp
- | ParFilter (Expr var pat)
-
-type ProtoNameParQuals = ParQuals ProtoName ProtoNamePat
-type RenamedParQuals = ParQuals Name RenamedPat
-type TypecheckedParQuals = ParQuals Id TypecheckedPat
-
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (ParQuals bdee pat) where
- ppr sty (AndParQuals quals1 quals2)
- = ppBesides [ppr sty quals1, pp'SP, ppr sty quals2]
- ppr sty (DrawnGenIn pats pat expr)
- = ppCat [ppStr "(|",
- ppInterleave ppComma (map (ppr sty) pats),
- ppSemi, ppr sty pat,ppStr "|)",
- ppStr "<<-", ppr sty expr]
-
- ppr sty (DrawnGenOut pats convs pat expr)
- = case sty of
- PprForUser -> basic_ppr
- _ -> ppHang basic_ppr 4 exprs_ppr
- where
- basic_ppr = ppCat [ppStr "(|",
- ppInterleave ppComma (map (ppr sty) pats),
- ppSemi, ppr sty pat,ppStr "|)",
- ppStr "<<-", ppr sty expr]
-
- exprs_ppr = ppBesides [ppStr "{- " ,
- ppr sty convs,
- ppStr " -}"]
-
- ppr sty (IndexGen exprs pat expr)
- = ppCat [ppStr "(|",
- ppInterleave ppComma (map (pprExpr sty) exprs),
- ppSemi, ppr sty pat, ppStr "|)",
- ppStr "<<=", ppr sty expr]
-
- ppr sty (ParFilter expr) = ppr sty expr
-#endif {-Data Parallel Haskell -}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[HsImpExp]{Abstract syntax: imports, exports, interfaces}
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsImpExp where
-
-import FiniteMap
-import HsDecls ( FixityDecl, TyDecl, ClassDecl, InstDecl )
-import HsBinds ( Sig )
-import HsPat ( ProtoNamePat(..), RenamedPat(..), InPat )
-import Id ( Id )
-import Name ( Name )
-import Outputable
-import Pretty
-import ProtoName ( ProtoName(..) ) -- .. for pragmas only
-import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import Util -- pragmas only
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-ImpExpDecls]{Import and export declaration lists}
-%* *
-%************************************************************************
-
-One per \tr{import} declaration in a module.
-\begin{code}
-data ImportedInterface name pat
- = ImportAll (Interface name pat) -- the contents of the interface
- -- (incl module name)
- [Renaming]
-
- | ImportSome (Interface name pat)
- [IE] -- the only things being imported
- [Renaming]
-
- | ImportButHide (Interface name pat)
- [IE] -- import everything "but hide" these entities
- [Renaming]
-\end{code}
-
-Synonyms:
-\begin{code}
-type ProtoNameImportedInterface = ImportedInterface ProtoName ProtoNamePat
-type RenamedImportedInterface = ImportedInterface Name RenamedPat
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name,
- NamedThing pat, Outputable pat)
- => Outputable (ImportedInterface name pat) where
-
- ppr sty (ImportAll iface renamings)
- = ppAbove (ppCat [ppStr "import", ppr sty iface])
- (pprRenamings sty renamings)
-
- ppr sty (ImportSome iface imports renamings)
- = ppAboves [ppCat [ppStr "import", ppr sty iface],
- ppNest 8 (ppBesides [ppStr " (", interpp'SP sty imports, ppStr ") "]),
- pprRenamings sty renamings]
-
- ppr sty (ImportButHide iface imports renamings)
- = ppAboves [ppCat [ppStr "import", ppr sty iface],
- ppNest 8 (ppBesides [ppStr "hiding (", interpp'SP sty imports, ppStr ") "]),
- pprRenamings sty renamings]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-entities]{Imported and exported entities}
-%* *
-%************************************************************************
-\begin{code}
-data IE
- = IEVar FAST_STRING
- | IEThingAbs FAST_STRING -- Constructor/Type/Class (can't tell)
- | IEThingAll FAST_STRING -- Class/Type plus all methods/constructors
- | IEConWithCons FAST_STRING -- import tycon w/ some cons
- [FAST_STRING]
- | IEClsWithOps FAST_STRING -- import tycls w/ some methods
- [FAST_STRING]
- | IEModuleContents FAST_STRING -- (Export Only)
-\end{code}
-
-\begin{code}
-instance Outputable IE where
- ppr sty (IEVar var) = ppPStr var
- ppr sty (IEThingAbs thing) = ppPStr thing
- ppr sty (IEThingAll thing) = ppBesides [ppPStr thing, ppStr "(..)"]
- ppr sty (IEConWithCons tycon datacons)
- = ppBesides [ppPStr tycon, ppLparen, ppInterleave ppComma (map ppPStr datacons), ppRparen]
- ppr sty (IEClsWithOps cls methods)
- = ppBesides [ppPStr cls, ppLparen, ppInterleave ppComma (map ppPStr methods), ppRparen]
- ppr sty (IEModuleContents mod) = ppBesides [ppPStr mod, ppStr ".."]
-\end{code}
-
-We want to know what names are exported (the first list of the result)
-and what modules are exported (the second list of the result).
-\begin{code}
-type ImExportListInfo
- = ( FiniteMap FAST_STRING ExportFlag,
- -- Assoc list of im/exported things &
- -- their "export" flags (im/exported
- -- abstractly, concretely, etc.)
- -- Hmm... slight misnomer there (WDP 95/02)
- FiniteSet FAST_STRING )
- -- List of modules to be exported
- -- entirely; NB: *not* everything with
- -- original names in these modules;
- -- but: everything that these modules'
- -- interfaces told us about.
- -- Note: This latter component can
- -- only arise on export lists.
-
-getIEStrings :: [IE] -> ImExportListInfo
-getRawIEStrings :: [IE] -> ([(FAST_STRING, ExportFlag)], [FAST_STRING])
- -- "Raw" gives the raw lists of things; we need this for
- -- checking for duplicates.
-
-getIEStrings exps
- = case (getRawIEStrings exps) of { (pairs, mods) ->
- (listToFM pairs, mkSet mods) }
-
-getRawIEStrings exps
- = foldr do_one ([],[]) exps
- where
- do_one (IEVar n) (prs, mods)
- = ((n, ExportAll):prs, mods)
- do_one (IEThingAbs n) (prs, mods)
- = ((n, ExportAbs):prs, mods)
- do_one (IEThingAll n) (prs, mods)
- = ((n, ExportAll):prs, mods)
- do_one (IEConWithCons n ns) (prs, mods) -- needn't do anything
- = ((n, ExportAll):prs, mods) -- with the indiv cons/ops
- do_one (IEClsWithOps n ns) (prs, mods)
- = ((n, ExportAll):prs, mods)
- do_one (IEModuleContents n) (prs, mods)
- = (prs, n : mods)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Renaming]{Renamings}
-%* *
-%************************************************************************
-
-\begin{code}
-data Renaming = MkRenaming FAST_STRING FAST_STRING
-\end{code}
-
-\begin{code}
-pprRenamings :: PprStyle -> [Renaming] -> Pretty
-pprRenamings sty [] = ppNil
-pprRenamings sty rs = ppBesides [ppStr "renaming (", interpp'SP sty rs, ppStr ")"]
-\end{code}
-
-\begin{code}
-instance Outputable Renaming where
- ppr sty (MkRenaming from too) = ppCat [ppPStr from, ppStr "to", ppPStr too]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Interface]{Interfaces}
-%* *
-%************************************************************************
-
-\begin{code}
-data Interface name pat
- = MkInterface FAST_STRING -- module name
- [IfaceImportDecl]
- [FixityDecl name] -- none yet (ToDo)
- [TyDecl name] -- data decls may have no constructors
- [ClassDecl name pat] -- Without default methods
- [InstDecl name pat] -- Without method defns
- [Sig name]
- SrcLoc
-\end{code}
-
-\begin{code}
-type ProtoNameInterface = Interface ProtoName ProtoNamePat
-type RenamedInterface = Interface Name RenamedPat
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name,
- NamedThing pat, Outputable pat)
- => Outputable (Interface name pat) where
-
- ppr PprForUser (MkInterface name _ _ _ _ _ _ _) = ppPStr name
-
- ppr sty (MkInterface name iimpdecls fixities tydecls classdecls instdecls sigs anns)
- = ppHang (ppBeside (ppPStr name) (ppStr " {-"))
- 4 (ppAboves [
- ifPprShowAll sty (ppr sty anns),
- ppCat [ppStr "interface", ppPStr name, ppStr "where"],
- ppNest 4 (ppAboves [
- ppr sty iimpdecls, ppr sty fixities,
- ppr sty tydecls, ppr sty classdecls,
- ppr sty instdecls, ppr sty sigs]),
- ppStr "-}"])
-\end{code}
-
-\begin{code}
-data IfaceImportDecl
- = IfaceImportDecl FAST_STRING -- module we're being told about
- [IE] -- things we're being told about
- [Renaming] -- AAYYYYEEEEEEEEEE!!! (help)
- SrcLoc
-\end{code}
-
-\begin{code}
-instance Outputable IfaceImportDecl where
-
- ppr sty (IfaceImportDecl mod names renamings src_loc)
- = ppHang (ppCat [ppStr "import", ppPStr mod, ppLparen])
- 4 (ppSep [ppCat [interpp'SP sty names, ppRparen],
- pprRenamings sty renamings])
-\end{code}
-
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[HsLit]{Abstract syntax: source-language literals}
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsLit where
-
-import AbsPrel ( PrimKind )
-import Outputable
-import Pretty
-import Util
-\end{code}
-
-\begin{code}
-data Literal
- = CharLit Char -- characters
- | CharPrimLit Char -- unboxed char literals
- | StringLit FAST_STRING -- strings
- | StringPrimLit FAST_STRING -- packed string
-
- | IntLit Integer -- integer-looking literals
- | FracLit Rational -- frac-looking literals
- -- Up through dict-simplification, IntLit and FracLit simply
- -- mean the literal was integral- or fractional-looking; i.e.,
- -- whether it had an explicit decimal-point in it. *After*
- -- dict-simplification, they mean (boxed) "Integer" and
- -- "Rational" [Ratio Integer], respectively.
-
- -- Dict-simplification tries to replace such lits w/ more
- -- specific ones, using the unboxed variants that follow...
- | LitLitLitIn FAST_STRING -- to pass ``literal literals'' through to C
- -- also: "overloaded" type; but
- -- must resolve to boxed-primitive!
- -- (WDP 94/10)
- | LitLitLit FAST_STRING
- UniType -- and now we know the type
- -- Must be a boxed-primitive type
-
- | IntPrimLit Integer -- unboxed Int literals
-#if __GLASGOW_HASKELL__ <= 22
- | FloatPrimLit Double -- unboxed Float literals
- | DoublePrimLit Double -- unboxed Double literals
-#else
- | FloatPrimLit Rational -- unboxed Float literals
- | DoublePrimLit Rational -- unboxed Double literals
-#endif
-\end{code}
-
-\begin{code}
-negLiteral (IntLit i) = IntLit (-i)
-negLiteral (FracLit f) = FracLit (-f)
-\end{code}
-
-\begin{code}
-instance Outputable Literal where
- ppr sty (CharLit c) = ppStr (show c)
- ppr sty (CharPrimLit c) = ppBeside (ppStr (show c)) (ppChar '#')
- ppr sty (StringLit s) = ppStr (show s)
- ppr sty (StringPrimLit s) = ppBeside (ppStr (show s)) (ppChar '#')
- ppr sty (IntLit i) = ppInteger i
-#if __GLASGOW_HASKELL__ <= 22
- ppr sty (FracLit f) = ppDouble (fromRational f) -- ToDo: better??
- ppr sty (FloatPrimLit f) = ppBeside (ppDouble f) (ppChar '#')
- ppr sty (DoublePrimLit d) = ppBeside (ppDouble d) (ppStr "##")
-#else
- ppr sty (FracLit f) = ppRational f
- ppr sty (FloatPrimLit f) = ppBeside (ppRational f) (ppChar '#')
- ppr sty (DoublePrimLit d) = ppBeside (ppRational d) (ppStr "##")
-#endif
- ppr sty (IntPrimLit i) = ppBeside (ppInteger i) (ppChar '#')
- ppr sty (LitLitLitIn s) = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
- ppr sty (LitLitLit s k) = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[HsMatches]{Abstract syntax: matches and guarded right-hand-sides}
-
-The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes.
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsMatches where
-
-import AbsUniType ( UniType
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import HsBinds ( Binds, nullBinds )
-import HsExpr ( Expr )
-import HsPat ( ProtoNamePat(..), RenamedPat(..),
- TypecheckedPat, InPat
- IF_ATTACK_PRAGMAS(COMMA typeOfPat)
- )
-import Name ( Name )
-import Unique ( Unique )
-import Id ( Id )
-import Outputable
-import Pretty
-import ProtoName ( ProtoName(..) ) -- .. for pragmas only
-import SrcLoc ( SrcLoc )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyntax-Match]{@Match@}
-%* *
-%************************************************************************
-
-Sets of pattern bindings and right hand sides for
-functions, patterns or case branches. For example,
-if a function @g@ is defined as:
-\begin{verbatim}
-g (x,y) = y
-g ((x:ys),y) = y+1,
-\end{verbatim}
-then a single @Match@ would be either @(x,y) = y@ or
-@((x:ys),y) = y+1@, and @[Match]@ would be
-@[((x,y) = y), (((x:ys),y) = y+1)]@.
-
-It is always the case that each element of an @[Match]@ list has the
-same number of @PatMatch@s inside it. This corresponds to saying that
-a function defined by pattern matching must have the same number of
-patterns in each equation.
-
-So, a single ``match'':
-\begin{code}
-data Match bdee pat
- = PatMatch pat
- (Match bdee pat)
- | GRHSMatch (GRHSsAndBinds bdee pat)
-
-type ProtoNameMatch = Match ProtoName ProtoNamePat
-type RenamedMatch = Match Name RenamedPat
-type TypecheckedMatch = Match Id TypecheckedPat
-\end{code}
-
-Printing, of one and several @Matches@.
-\begin{code}
-pprMatch :: (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- PprStyle -> Bool -> Match bdee pat -> Pretty
-
-pprMatch sty is_case first_match
- = ppHang (ppSep (map (ppr sty) row_of_pats))
- 8 grhss_etc_stuff
- where
- (row_of_pats, grhss_etc_stuff) = ppr_match sty is_case first_match
-
- ppr_match sty is_case (PatMatch pat match)
- = (pat:pats, grhss_stuff)
- where
- (pats, grhss_stuff) = ppr_match sty is_case match
-
- ppr_match sty is_case (GRHSMatch grhss_n_binds)
- = ([], pprGRHSsAndBinds sty is_case grhss_n_binds)
-\end{code}
-
-We know the list must have at least one @Match@ in it.
-\begin{code}
-pprMatches :: (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- PprStyle -> (Bool, Pretty) -> [Match bdee pat] -> Pretty
-
-pprMatches sty print_info@(is_case, name) [match]
- = if is_case then
- pprMatch sty is_case match
- else
- ppHang name 4 (pprMatch sty is_case match)
-
-pprMatches sty print_info (match1 : rest)
- = ppAbove (pprMatches sty print_info [match1])
- (pprMatches sty print_info rest)
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (Match bdee pat) where
- ppr sty b = panic "ppr: Match"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyntax-GRHSsAndBinds]{Guarded RHSs plus their Binds}
-%* *
-%************************************************************************
-
-Possibly \tr{NoGuardNoBinds{In,Out}}, etc.? ToDo
-
-\begin{code}
-data GRHSsAndBinds bdee pat
- = GRHSsAndBindsIn [GRHS bdee pat] -- at least one GRHS
- (Binds bdee pat)
-
- | GRHSsAndBindsOut [GRHS bdee pat] -- at least one GRHS
- (Binds bdee pat)
- UniType
-
-type ProtoNameGRHSsAndBinds = GRHSsAndBinds ProtoName ProtoNamePat
-type RenamedGRHSsAndBinds = GRHSsAndBinds Name RenamedPat
-type TypecheckedGRHSsAndBinds = GRHSsAndBinds Id TypecheckedPat
-\end{code}
-
-\begin{code}
-pprGRHSsAndBinds sty is_case (GRHSsAndBindsIn grhss binds)
- = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
- (if (nullBinds binds)
- then ppNil
- else ppAboves [ ppStr "where", ppNest 4 (ppr sty binds) ])
-
-pprGRHSsAndBinds sty is_case (GRHSsAndBindsOut grhss binds ty)
- = ppAbove (ppAboves (map (pprGRHS sty is_case) grhss))
- (if (nullBinds binds)
- then ppNil
- else ppAboves [ ifPprShowAll sty
- (ppCat [ppStr "{- ty:", ppr sty ty, ppStr "-}"]),
- ppStr "where", ppNest 4 (ppr sty binds) ])
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (GRHSsAndBinds bdee pat) where
- ppr sty b = panic "ppr:GRHSsAndBinds"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyntax-GRHS]{A guarded right-hand-side}
-%* *
-%************************************************************************
-
-Sets of guarded right hand sides. In
-\begin{verbatim}
-f (x,y) | x==True = y
- | otherwise = y*2
-\end{verbatim}
-a guarded right hand side is either
-@(x==True = y)@, or @(otherwise = y*2)@.
-
-For each match, there may be several guarded right hand
-sides, as the definition of @f@ shows.
-
-\begin{code}
-data GRHS bdee pat
- = GRHS (Expr bdee pat) -- guard(ed)...
- (Expr bdee pat) -- ... right-hand side
- SrcLoc
-
- | OtherwiseGRHS (Expr bdee pat) -- guard-free
- SrcLoc
-\end{code}
-
-And, as always:
-\begin{code}
-type ProtoNameGRHS = GRHS ProtoName ProtoNamePat
-type RenamedGRHS = GRHS Name RenamedPat
-type TypecheckedGRHS = GRHS Id TypecheckedPat
-\end{code}
-
-\begin{code}
-pprGRHS :: (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- PprStyle -> Bool -> GRHS bdee pat -> Pretty
-
-pprGRHS sty is_case (GRHS guard expr locn)
- = ppAboves [
- ifPprShowAll sty (ppr sty locn),
- ppHang (ppCat [ppStr "|", ppr sty guard, ppStr (if is_case then "->" else "=")])
- 4 (ppr sty expr)
- ]
-
-pprGRHS sty is_case (OtherwiseGRHS expr locn)
- = ppAboves [
- ifPprShowAll sty (ppr sty locn),
- ppHang (ppStr (if is_case then "->" else "="))
- 4 (ppr sty expr)
- ]
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (GRHS bdee pat) where
- ppr sty b = panic "ppr: GRHSs"
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
-%
-\section[PatSyntax]{Abstract Haskell syntax---patterns}
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsPat where
-
-import AbsPrel ( mkTupleTy, mkListTy
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-#ifdef DPH
- , mkProcessorTy
-#endif
- )
-import AbsUniType
-import HsLit ( Literal )
-import HsExpr ( Expr, TypecheckedExpr(..) )
-import Id
-import IdInfo
-import Maybes ( maybeToBool, Maybe(..) )
-import Name ( Name )
-import ProtoName ( ProtoName(..) ) -- .. for pragmas only
-import Outputable
-import Pretty
-import Unique ( Unique )
-import Util
-\end{code}
-
-Patterns come in distinct before- and after-typechecking flavo(u)rs.
-\begin{code}
-data InPat name
- = WildPatIn --X wild card
- | VarPatIn name --X variable
- | LitPatIn Literal -- literal
- | LazyPatIn (InPat name) --X lazy pattern
- | AsPatIn name --X as pattern
- (InPat name)
- | ConPatIn name --X constructed type
- [(InPat name)]
- | ConOpPatIn (InPat name)
- name
- (InPat name)
- | ListPatIn [InPat name] --X syntactic list
- -- must have >= 1 elements
- | TuplePatIn [InPat name] --X tuple
- -- UnitPat is TuplePat []
- | NPlusKPatIn name -- n+k pattern
- Literal
-#ifdef DPH
- | ProcessorPatIn [(InPat name)]
- (InPat name) -- (|pat1,...,patK;pat|)
-#endif {- Data Parallel Haskell -}
-
-type ProtoNamePat = InPat ProtoName
-type RenamedPat = InPat Name
-
-data TypecheckedPat
- = WildPat UniType -- wild card
-
- | VarPat Id -- variable (type is in the Id)
-
- | LazyPat TypecheckedPat -- lazy pattern
-
- | AsPat Id -- as pattern
- TypecheckedPat
-
- | ConPat Id -- constructed type;
- UniType -- the type of the pattern
- [TypecheckedPat]
-
- | ConOpPat TypecheckedPat -- just a special case...
- Id
- TypecheckedPat
- UniType
- | ListPat -- syntactic list
- UniType -- the type of the elements
- [TypecheckedPat]
-
- | TuplePat [TypecheckedPat] -- tuple
- -- UnitPat is TuplePat []
-
- | LitPat -- Used for *non-overloaded* literal patterns:
- -- Int#, Char#, Int, Char, String, etc.
- Literal
- UniType -- type of pattern
-
- | NPat -- Used for *overloaded* literal patterns
- Literal -- the literal is retained so that
- -- the desugarer can readily identify
- -- equations with identical literal-patterns
- UniType -- type of pattern, t
- TypecheckedExpr -- Of type t -> Bool; detects match
-
- | NPlusKPat Id
- Literal -- Same reason as for LitPat
- -- (This could be an Integer, but then
- -- it's harder to partitionEqnsByLit
- -- in the desugarer.)
- UniType -- Type of pattern, t
- TypecheckedExpr -- "fromInteger literal"; of type t
- TypecheckedExpr -- Of type t-> t -> Bool; detects match
- TypecheckedExpr -- Of type t -> t -> t; subtracts k
-#ifdef DPH
- | ProcessorPat
- [TypecheckedPat] -- Typechecked Pattern
- [TypecheckedExpr] -- Of type t-> Integer; conversion
- TypecheckedPat -- Data at that processor
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Note: If @typeOfPat@ doesn't bear a strong resemblance to @typeOfCoreExpr@,
-then something is wrong.
-\begin{code}
-typeOfPat :: TypecheckedPat -> UniType
-typeOfPat (WildPat ty) = ty
-typeOfPat (VarPat var) = getIdUniType var
-typeOfPat (LazyPat pat) = typeOfPat pat
-typeOfPat (AsPat var pat) = getIdUniType var
-typeOfPat (ConPat _ ty _) = ty
-typeOfPat (ConOpPat _ _ _ ty) = ty
-typeOfPat (ListPat ty _) = mkListTy ty
-typeOfPat (TuplePat pats) = mkTupleTy (length pats) (map typeOfPat pats)
-typeOfPat (LitPat lit ty) = ty
-typeOfPat (NPat lit ty _) = ty
-typeOfPat (NPlusKPat n k ty _ _ _) = ty
-#ifdef DPH
--- Should be more efficient to find type of pid than pats
-typeOfPat (ProcessorPat pats _ pat)
- = mkProcessorTy (map typeOfPat pats) (typeOfPat pat)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-instance (NamedThing name) => NamedThing (InPat name) where
- hasType pat = False
-#ifdef DEBUG
- getExportFlag = panic "NamedThing.InPat.getExportFlag"
- isLocallyDefined = panic "NamedThing.InPat.isLocallyDefined"
- getOrigName = panic "NamedThing.InPat.getOrigName"
- getOccurrenceName = panic "NamedThing.InPat.getOccurrenceName"
- getInformingModules = panic "NamedThing.InPat.getOccurrenceName"
- getSrcLoc = panic "NamedThing.InPat.getSrcLoc"
- getTheUnique = panic "NamedThing.InPat.getTheUnique"
- getType pat = panic "NamedThing.InPat.getType"
- fromPreludeCore = panic "NamedThing.InPat.fromPreludeCore"
-#endif
-
-instance NamedThing TypecheckedPat where
- hasType pat = True
- getType = typeOfPat
-#ifdef DEBUG
- getExportFlag = panic "NamedThing.TypecheckedPat.getExportFlag"
- isLocallyDefined = panic "NamedThing.TypecheckedPat.isLocallyDefined"
- getOrigName = panic "NamedThing.TypecheckedPat.getOrigName"
- getOccurrenceName = panic "NamedThing.TypecheckedPat.getOccurrenceName"
- getInformingModules = panic "NamedThing.TypecheckedPat.getOccurrenceName"
- getSrcLoc = panic "NamedThing.TypecheckedPat.getSrcLoc"
- getTheUnique = panic "NamedThing.TypecheckedPat.getTheUnique"
- fromPreludeCore = panic "NamedThing.TypecheckedPat.fromPreludeCore"
-#endif
-\end{code}
-
-\begin{code}
-instance (Outputable name) => Outputable (InPat name) where
- ppr = pprInPat
-
-pprInPat :: (Outputable name) => PprStyle -> InPat name -> Pretty
-pprInPat sty (WildPatIn) = ppStr "_"
-pprInPat sty (VarPatIn var) = ppr sty var
-pprInPat sty (LitPatIn s) = ppr sty s
-pprInPat sty (LazyPatIn pat) = ppBeside (ppChar '~') (ppr sty pat)
-pprInPat sty (AsPatIn name pat)
- = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
-
-pprInPat sty (ConPatIn c pats)
- = if null pats then
- ppr sty c
- else
- ppBesides [ppLparen, ppr sty c, ppSP, interppSP sty pats, ppRparen]
-
-
-pprInPat sty (ConOpPatIn pat1 op pat2)
- = ppBesides [ppLparen, ppr sty pat1, ppSP, ppr sty op, ppSP, ppr sty pat2, ppRparen]
-
--- ToDo: use pprOp to print op (but this involves fiddling various
--- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP)
-
-pprInPat sty (ListPatIn pats)
- = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
-pprInPat sty (TuplePatIn pats)
- = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
-pprInPat sty (NPlusKPatIn n k)
- = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen]
-#ifdef DPH
-pprInPat sty (ProcessorPatIn pats pat)
- = ppBesides [ppStr "(|", interpp'SP sty pats,ppSemi ,
- ppr sty pat , ppStr "|)"]
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Problems with @Outputable@ instance for @TypecheckedPat@ when no
-original names.
-\begin{code}
-instance Outputable TypecheckedPat where
- ppr = pprTypecheckedPat
-\end{code}
-
-\begin{code}
-pprTypecheckedPat sty (WildPat ty) = ppChar '_'
-pprTypecheckedPat sty (VarPat var) = ppr sty var
-pprTypecheckedPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat]
-pprTypecheckedPat sty (AsPat name pat)
- = ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
-
-pprTypecheckedPat sty (ConPat name ty [])
- = ppBeside (ppr sty name)
- (ifPprShowAll sty (pprConPatTy sty ty))
-
-pprTypecheckedPat sty (ConPat name ty pats)
- = ppBesides [ppLparen, ppr sty name, ppSP,
- interppSP sty pats, ppRparen,
- ifPprShowAll sty (pprConPatTy sty ty) ]
-
-pprTypecheckedPat sty (ConOpPat pat1 op pat2 ty)
- = ppBesides [ppLparen, ppr sty pat1, ppSP, pprOp sty op, ppSP, ppr sty pat2, ppRparen]
-
-pprTypecheckedPat sty (ListPat ty pats)
- = ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
-pprTypecheckedPat sty (TuplePat pats)
- = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
-
-pprTypecheckedPat sty (LitPat l ty) = ppr sty l -- ToDo: print more
-pprTypecheckedPat sty (NPat l ty e) = ppr sty l -- ToDo: print more
-
-pprTypecheckedPat sty (NPlusKPat n k ty e1 e2 e3)
- = case sty of
- PprForUser -> basic_ppr
- _ -> ppHang basic_ppr 4 exprs_ppr
- where
- basic_ppr = ppBesides [ppLparen, ppr sty n, ppChar '+', ppr sty k, ppRparen]
- exprs_ppr = ppSep [ ppBeside (ppStr "{- ") (ppr sty ty),
- ppr sty e1, ppr sty e2,
- ppBeside (ppr sty e3) (ppStr " -}")]
-#ifdef DPH
-pprTypecheckedPat sty (ProcessorPat pats convs pat)
- = case sty of
- PprForUser -> basic_ppr
- _ -> ppHang basic_ppr 4 exprs_ppr
- where
- basic_ppr = ppBesides [ppStr "(|", interpp'SP sty pats,ppSemi ,
- ppr sty pat , ppStr "|)"]
- exprs_ppr = ppBesides [ppStr "{- " ,
- ppr sty convs,
- ppStr " -}"]
-#endif {- Data Parallel Haskell -}
-
-pprConPatTy :: PprStyle -> UniType -> Pretty
-pprConPatTy sty ty
- = ppBesides [ppLparen, ppr sty ty, ppRparen]
-\end{code}
-
-%************************************************************************
-%* *
-%* predicates for checking things about pattern-lists in EquationInfo *
-%* *
-%************************************************************************
-\subsection[Pat-list-predicates]{Look for interesting things in patterns}
-
-Unlike in the Wadler chapter, where patterns are either ``variables''
-or ``constructors,'' here we distinguish between:
-\begin{description}
-\item[unfailable:]
-Patterns that cannot fail to match: variables, wildcards, and lazy
-patterns.
-
-These are the irrefutable patterns; the two other categories
-are refutable patterns.
-
-\item[constructor:]
-A non-literal constructor pattern (see next category).
-
-\item[literal (including n+k patterns):]
-At least the numeric ones may be overloaded.
-\end{description}
-
-A pattern is in {\em exactly one} of the above three categories; `as'
-patterns are treated specially, of course.
-
-\begin{code}
-unfailablePats :: [TypecheckedPat] -> Bool
-unfailablePats pat_list = all unfailablePat pat_list
-
-unfailablePat (AsPat _ pat) = unfailablePat pat
-unfailablePat (WildPat _) = True
-unfailablePat (VarPat _) = True
-unfailablePat (LazyPat _) = True
-unfailablePat other = False
-
-patsAreAllCons :: [TypecheckedPat] -> Bool
-patsAreAllCons pat_list = all isConPat pat_list
-
-isConPat (AsPat _ pat) = isConPat pat
-isConPat (ConPat _ _ _) = True
-isConPat (ConOpPat _ _ _ _) = True
-isConPat (ListPat _ _) = True
-isConPat (TuplePat _) = True
-#ifdef DPH
-isConPat (ProcessorPat _ _ _) = True
-
-#endif {- Data Parallel Haskell -}
-isConPat other = False
-
-patsAreAllLits :: [TypecheckedPat] -> Bool
-patsAreAllLits pat_list = all isLitPat pat_list
-
-isLitPat (AsPat _ pat) = isLitPat pat
-isLitPat (LitPat _ _) = True
-isLitPat (NPat _ _ _) = True
-isLitPat (NPlusKPat _ _ _ _ _ _)= True
-isLitPat other = False
-
-#ifdef DPH
-patsAreAllProcessor :: [TypecheckedPat] -> Bool
-patsAreAllProcessor pat_list = all isProcessorPat pat_list
- where
- isProcessorPat (ProcessorPat _ _ _) = True
- isProcessorPat _ = False
-#endif
-\end{code}
-
-\begin{code}
--- A pattern is irrefutable if a match on it cannot fail
--- (at any depth)
-irrefutablePat :: TypecheckedPat -> Bool
-
-irrefutablePat (WildPat _) = True
-irrefutablePat (VarPat _) = True
-irrefutablePat (LazyPat _) = True
-irrefutablePat (AsPat _ pat) = irrefutablePat pat
-irrefutablePat (ConPat con tys pats) = all irrefutablePat pats && only_con con
-irrefutablePat (ConOpPat pat1 con pat2 _) = irrefutablePat pat1 && irrefutablePat pat1 && only_con con
-irrefutablePat (ListPat _ _) = False
-irrefutablePat (TuplePat pats) = all irrefutablePat pats
-irrefutablePat other_pat = False -- Literals, NPlusK, NPat
-
-only_con con = maybeToBool (maybeSingleConstructorTyCon tycon)
- where
- (_,_,_, tycon) = getDataConSig con
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
-%
-%************************************************************************
-%* *
-\section[HsPragmas]{Pragmas in Haskell interface files}
-%* *
-%************************************************************************
-
-See also: @Sig@ (``signatures'') which is where user-supplied pragmas
-for values show up; ditto @SpecialisedInstanceSig@ (for instances) and
-@DataTypeSig@ (for data types and type synonyms).
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsPragmas where
-
-import HsCore ( UnfoldingCoreExpr, UfCostCentre )
-import HsDecls ( ConDecl )
-import HsTypes ( MonoType, PolyType )
-import IdInfo
-import Maybes ( Maybe(..) )
-import Name ( Name )
-import Outputable -- class for printing, forcing
-import Pretty -- pretty-printing utilities
-import ProtoName ( ProtoName(..) ) -- .. is for pragmas only
-import Util
-\end{code}
-
-Certain pragmas expect to be pinned onto certain constructs.
-
-Pragma types may be parameterised, just as with any other
-abstract-syntax type.
-
-For a @data@ declaration---makes visible the constructors for an
-abstract @data@ type and indicates which specialisations exist.
-\begin{code}
-data DataPragmas name
- = DataPragmas [ConDecl name] -- hidden data constructors
- [[Maybe (MonoType name)]] -- types to which speciaised
-
-type ProtoNameDataPragmas = DataPragmas ProtoName
-type RenamedDataPragmas = DataPragmas Name
-\end{code}
-
-For a @type@ declaration---declare that it should be treated as
-``abstract'' (flag any use of its expansion as an error):
-\begin{code}
-data TypePragmas
- = NoTypePragmas
- | AbstractTySynonym
-\end{code}
-
-These are {\em general} things you can know about any value:
-\begin{code}
-data GenPragmas name
- = NoGenPragmas
- | GenPragmas (Maybe Int) -- arity (maybe)
- (Maybe UpdateInfo) -- update info (maybe)
- DeforestInfo -- deforest info
- (ImpStrictness name) -- strictness, worker-wrapper
- (ImpUnfolding name) -- unfolding (maybe)
- [([Maybe (MonoType name)], -- Specialisations: types to which spec'd;
- Int, -- # dicts to ignore
- GenPragmas name)] -- Gen info about the spec'd version
-
-type ProtoNameGenPragmas = GenPragmas ProtoName
-type RenamedGenPragmas = GenPragmas Name
-
-data ImpUnfolding name
- = NoImpUnfolding
- | ImpMagicUnfolding FAST_STRING -- magic "unfolding"
- -- known to the compiler by "String"
- | ImpUnfolding UnfoldingGuidance -- always, if you like, etc.
- (UnfoldingCoreExpr name)
-
-type ProtoNameUnfoldingCoreExpr = UnfoldingCoreExpr ProtoName
-
-data ImpStrictness name
- = NoImpStrictness
- | ImpStrictness Bool -- True <=> bottoming Id
- [Demand] -- demand info
- (GenPragmas name) -- about the *worker*
-
-type RenamedImpStrictness = ImpStrictness Name
-\end{code}
-
-For an ordinary imported function: it can have general pragmas (only).
-
-For a class's super-class dictionary selectors:
-\begin{code}
-data ClassPragmas name
- = NoClassPragmas
- | SuperDictPragmas [GenPragmas name] -- list mustn't be empty
-
-type ProtoNameClassPragmas = ClassPragmas ProtoName
-type RenamedClassPragmas = ClassPragmas Name
-\end{code}
-
-For a class's method selectors:
-\begin{code}
-data ClassOpPragmas name
- = NoClassOpPragmas
- | ClassOpPragmas (GenPragmas name) -- for method selector
- (GenPragmas name) -- for default method
-
-type ProtoNameClassOpPragmas = ClassOpPragmas ProtoName
-type RenamedClassOpPragmas = ClassOpPragmas Name
-\end{code}
-
-\begin{code}
-data InstancePragmas name
- = NoInstancePragmas
-
- | SimpleInstancePragma -- nothing but for the dfun itself...
- (GenPragmas name)
-
- | ConstantInstancePragma
- (GenPragmas name) -- for the "dfun" itself
- [(name, GenPragmas name)] -- one per class op
-
- | SpecialisedInstancePragma
- (GenPragmas name) -- for its "dfun"
- [([Maybe (MonoType name)], -- specialised instance; type...
- Int, -- #dicts to ignore
- InstancePragmas name)] -- (no SpecialisedInstancePragma please!)
-
-type ProtoNameInstancePragmas = InstancePragmas ProtoName
-type RenamedInstancePragmas = InstancePragmas Name
-\end{code}
-
-Some instances for printing (just for debugging, really)
-\begin{code}
-instance Outputable name => Outputable (ClassPragmas name) where
- ppr sty NoClassPragmas = ppNil
- ppr sty (SuperDictPragmas sdsel_prags)
- = ppAbove (ppStr "{-superdict pragmas-}")
- (ppr sty sdsel_prags)
-
-instance Outputable name => Outputable (ClassOpPragmas name) where
- ppr sty NoClassOpPragmas = ppNil
- ppr sty (ClassOpPragmas op_prags defm_prags)
- = ppAbove (ppCat [ppStr "{-meth-}", ppr sty op_prags])
- (ppCat [ppStr "{-defm-}", ppr sty defm_prags])
-
-instance Outputable name => Outputable (InstancePragmas name) where
- ppr sty NoInstancePragmas = ppNil
- ppr sty (SimpleInstancePragma dfun_pragmas)
- = ppCat [ppStr "{-dfun-}", ppr sty dfun_pragmas]
- ppr sty (ConstantInstancePragma dfun_pragmas name_pragma_pairs)
- = ppAbove (ppCat [ppStr "{-constm-}", ppr sty dfun_pragmas])
- (ppAboves (map pp_pair name_pragma_pairs))
- where
- pp_pair (n, prags)
- = ppCat [ppr sty n, ppEquals, ppr sty prags]
-
- ppr sty (SpecialisedInstancePragma dfun_pragmas spec_pragma_info)
- = ppAbove (ppCat [ppStr "{-spec'd-}", ppr sty dfun_pragmas])
- (ppAboves (map pp_info spec_pragma_info))
- where
- pp_info (ty_maybes, num_dicts, prags)
- = ppBesides [ppLbrack, ppInterleave ppSP (map pp_ty ty_maybes), ppRbrack,
- ppLparen, ppInt num_dicts, ppRparen, ppEquals, ppr sty prags]
- pp_ty Nothing = ppStr "_N_"
- pp_ty (Just t)= ppr sty t
-
-instance Outputable name => Outputable (GenPragmas name) where
- ppr sty NoGenPragmas = ppNil
- ppr sty (GenPragmas arity_maybe upd_maybe def strictness unfolding specs)
- = ppCat [pp_arity arity_maybe, pp_upd upd_maybe, -- ToDo: print def?
- pp_str strictness, pp_unf unfolding,
- pp_specs specs]
- where
- pp_arity Nothing = ppNil
- pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i)
-
- pp_upd Nothing = ppNil
- pp_upd (Just u) = ppInfo sty id u
-
- pp_str NoImpStrictness = ppNil
- pp_str (ImpStrictness is_bot demands wrkr_prags)
- = ppBesides [ppStr "IS_BOT=", ppr sty is_bot,
- ppStr "STRICTNESS=", ppStr (showList demands ""),
- ppStr " {", ppr sty wrkr_prags, ppStr "}"]
-
- pp_unf NoImpUnfolding = ppStr "NO_UNFOLDING"
- pp_unf (ImpMagicUnfolding m) = ppBeside (ppStr "MAGIC=") (ppPStr m)
- pp_unf (ImpUnfolding g core) = ppBeside (ppStr "UNFOLD=") (ppr sty core)
-
- pp_specs [] = ppNil
- pp_specs specs
- = ppBesides [ppStr "SPECS=[", ppInterleave ppSP (map pp_spec specs), ppStr "]"]
- where
- pp_spec (ty_maybes, num_dicts, gprags)
- = ppCat [ppLbrack, ppInterleave ppSP (map pp_MaB ty_maybes), ppRbrack, ppInt num_dicts, ppr sty gprags]
-
- pp_MaB Nothing = ppStr "_N_"
- pp_MaB (Just x) = ppr sty x
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[HsTypes]{Abstract syntax: user-defined types}
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsTypes (
- PolyType(..), MonoType(..),
- ClassAssertion(..), Context(..),
-
- ProtoNameContext(..),
- ProtoNameMonoType(..),
- ProtoNamePolyType(..),
- RenamedContext(..),
- RenamedMonoType(..),
- RenamedPolyType(..),
-
- cmpPolyType, cmpMonoType, cmpList,
- eqMonoType,
-
- pprContext, pprParendMonoType
-
- ) where
-
-import ProtoName
-import Name ( Name )
-import Unique ( Unique )
-import Outputable
-import Pretty
-import Util
-\end{code}
-
-This is the syntax for types as seen in type signatures.
-
-\begin{code}
-data PolyType name
- = UnoverloadedTy (MonoType name) -- equiv to having a [] context
-
- | OverloadedTy (Context name) -- not supposed to be []
- (MonoType name)
-
- -- this next one is only used in unfoldings in interfaces
- | ForAllTy [name]
- (MonoType name)
-
-type Context name = [ClassAssertion name]
-
-type ClassAssertion name = (name, name)
-
-type ProtoNamePolyType = PolyType ProtoName
-type RenamedPolyType = PolyType Name
-
-type ProtoNameContext = Context ProtoName
-type RenamedContext = Context Name
-
-data MonoType name
- = MonoTyVar name -- Type variable
- | MonoTyCon name -- Type constructor
- [MonoType name]
- | FunMonoTy (MonoType name) -- function type
- (MonoType name)
- | ListMonoTy (MonoType name) -- list type
- | TupleMonoTy [PolyType name] -- tuple type (length gives arity)
- -- *** NOTA BENE *** The tuple type takes *Poly*Type
- -- arguments, because these *do* arise in pragmatic info
- -- in interfaces (mostly to do with dictionaries). It just
- -- so happens that this won't happen for lists, etc.,
- -- (as far as I know).
- -- We might want to be less hacky about this in future. (ToDo)
- -- [WDP]
-
- -- these next two are only used in unfoldings in interfaces
- | MonoTyVarTemplate name
- | MonoDict name -- Class
- (MonoType name)
-
-#ifdef DPH
- | MonoTyProc [MonoType name]
- (MonoType name) -- Processor
- | MonoTyPod (MonoType name) -- Pod
-#endif {- Data Parallel Haskell -}
-
-type ProtoNameMonoType = MonoType ProtoName
-type RenamedMonoType = MonoType Name
-\end{code}
-
-We do define a specialised equality for these \tr{*Type} types; used
-in checking interfaces. Most any other use is likely to be {\em
-wrong}, so be careful!
-\begin{code}
-cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
-cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
-cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_
-cmpList :: (a -> a -> TAG_) -> [a] -> [a] -> TAG_
-
-cmpPolyType cmp (UnoverloadedTy t1) (UnoverloadedTy t2)
- = cmpMonoType cmp t1 t2
-cmpPolyType cmp (OverloadedTy c1 t1) (OverloadedTy c2 t2)
- = case cmpContext cmp c1 c2 of { EQ_ -> cmpMonoType cmp t1 t2; xxx -> xxx }
-
-cmpPolyType cmp (ForAllTy tvs1 t1) (ForAllTy tvs2 t2)
- = case cmp_tvs tvs1 tvs2 of { EQ_ -> cmpMonoType cmp t1 t2; xxx -> xxx }
- where
- cmp_tvs [] [] = EQ_
- cmp_tvs [] _ = LT_
- cmp_tvs _ [] = GT_
- cmp_tvs (a:as) (b:bs)
- = case cmp a b of { EQ_ -> cmp_tvs as bs; xxx -> xxx }
- cmp_tvs _ _ = case (panic "cmp_tvs") of { v -> cmp_tvs v v } -- BUG avoidance
-
-cmpPolyType cmp ty1 ty2 -- tags must be different
- = let tag1 = tag ty1
- tag2 = tag ty2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
- where
- tag (UnoverloadedTy _) = (ILIT(1) :: FAST_INT)
- tag (OverloadedTy _ _) = ILIT(2)
- tag (ForAllTy _ _) = ILIT(3)
-
------------
-cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
- = cmp n1 n2
-
-cmpMonoType cmp (TupleMonoTy tys1) (TupleMonoTy tys2)
- = cmpList (cmpPolyType cmp) tys1 tys2
-cmpMonoType cmp (ListMonoTy ty1) (ListMonoTy ty2)
- = cmpMonoType cmp ty1 ty2
-
-cmpMonoType cmp (MonoTyCon tc1 tys1) (MonoTyCon tc2 tys2)
- = case cmp tc1 tc2 of { EQ_ -> cmpList (cmpMonoType cmp) tys1 tys2; xxx -> xxx }
-
-cmpMonoType cmp (FunMonoTy a1 b1) (FunMonoTy a2 b2)
- = case cmpMonoType cmp a1 a2 of { EQ_ -> cmpMonoType cmp b1 b2; xxx -> xxx }
-
-cmpMonoType cmp (MonoTyVarTemplate n1) (MonoTyVarTemplate n2)
- = cmp n1 n2
-cmpMonoType cmp (MonoDict c1 ty1) (MonoDict c2 ty2)
- = case cmp c1 c2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx }
-
-#ifdef DPH
-cmpMonoType cmp (MonoTyProc tys1 ty1) (MonoTyProc tys2 ty2)
- = case cmpList (cmpMonoType cmp) tys1 tys2 of { EQ_ -> cmpMonoType cmp ty1 ty2; xxx -> xxx }
-cmpMonoType cmp (MonoTyPod ty1) (MonoTyPod ty2) = cmpMonoType cmp ty1 ty2
-#endif {- Data Parallel Haskell -}
-
-cmpMonoType cmp ty1 ty2 -- tags must be different
- = let tag1 = tag ty1
- tag2 = tag ty2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
- where
- tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
- tag (TupleMonoTy tys1) = ILIT(2)
- tag (ListMonoTy ty1) = ILIT(3)
- tag (MonoTyCon tc1 tys1) = ILIT(4)
- tag (FunMonoTy a1 b1) = ILIT(5)
- tag (MonoTyVarTemplate n1) = ILIT(6)
- tag (MonoDict c1 ty1) = ILIT(7)
-#ifdef DPH
- tag (MonoTyProc tys1 ty1) = ILIT(8)
- tag (MonoTyPod ty1) = ILIT(9)
-#endif {- Data Parallel Haskell -}
-
--------------------
-cmpContext cmp a b
- = cmpList cmp_ctxt a b
- where
- cmp_ctxt (c1, tv1) (c2, tv2)
- = case cmp c1 c2 of { EQ_ -> cmp tv1 tv2; xxx -> xxx }
-
--------------------
-cmpList cmp [] [] = EQ_
-cmpList cmp [] _ = LT_
-cmpList cmp _ [] = GT_
-cmpList cmp (a:as) (b:bs)
- = case cmp a b of { EQ_ -> cmpList cmp as bs; xxx -> xxx }
-
-cmpList cmp _ _
- = case (panic "cmpList (HsTypes)") of { l -> cmpList cmp l l } -- BUG avoidance
-\end{code}
-
-\begin{code}
-eqMonoType :: ProtoNameMonoType -> ProtoNameMonoType -> Bool
-
-eqMonoType a b = case (cmpMonoType cmpProtoName a b) of { EQ_ -> True; _ -> False }
-\end{code}
-
-This is used in various places:
-\begin{code}
-pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
-
-pprContext sty [] = ppNil
-pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"]
-pprContext sty context
- = ppBesides [ppLparen,
- ppInterleave ppComma (map pp_assert context),
- ppRparen, ppStr " =>"]
- where
- pp_assert (clas, ty)
- = ppCat [ppr sty clas, ppr sty ty]
-\end{code}
-
-\begin{code}
-instance (Outputable name) => Outputable (PolyType name) where
- ppr sty (UnoverloadedTy ty) = ppr sty ty
- ppr sty (OverloadedTy ctxt ty)
- = ppCat [pprContext sty ctxt, ppr sty ty]
- ppr sty (ForAllTy tvs ty)
- = ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => ", ppr sty ty]
-
-instance (Outputable name) => Outputable (MonoType name) where
- ppr = pprMonoType
-
-pREC_TOP = (0 :: Int)
-pREC_FUN = (1 :: Int)
-pREC_CON = (2 :: Int)
-
--- printing works more-or-less as for UniTypes (in UniTyFuns)
-
-pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty
-
-pprMonoType sty ty = ppr_mono_ty sty pREC_TOP ty
-pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
-
-ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
-
-ppr_mono_ty sty ctxt_prec (FunMonoTy ty1 ty2)
- = let p1 = ppr_mono_ty sty pREC_FUN ty1
- p2 = ppr_mono_ty sty pREC_TOP ty2
- in
- if ctxt_prec < pREC_FUN then -- no parens needed
- ppSep [p1, ppBeside (ppStr "-> ") p2]
- else
- ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]]
-
-ppr_mono_ty sty ctxt_prec (TupleMonoTy tys)
- = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen]
-
-ppr_mono_ty sty ctxt_prec (ListMonoTy ty)
- = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
-
-ppr_mono_ty sty ctxt_prec (MonoTyCon tycon tys)
- = let pp_tycon = ppr sty tycon in
- if null tys then
- pp_tycon
- else if ctxt_prec < pREC_CON then -- no parens needed
- ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]
- else
- ppBesides [ ppLparen, pp_tycon, ppSP,
- ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ]
-
--- unfoldings only
-ppr_mono_ty sty ctxt_prec (MonoTyVarTemplate tv) = ppr sty tv
-
-ppr_mono_ty sty ctxt_prec (MonoDict clas ty)
- = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"]
-
-#ifdef DPH
-ppr_mono_ty sty ctxt_prec (MonoTyProc tys ty)
- = ppBesides [ppStr "(|",
- ppInterleave ppComma (map (ppr_mono_ty sty pREC_TOP) tys),
- ppSemi,
- ppr_mono_ty sty pREC_TOP ty,
- ppStr "|)"]
-
-ppr_mono_ty sty ctxt_prec (MonoTyPod ty)
- = ppBesides [ppStr "<<", ppr_mono_ty sty pREC_TOP ty ,ppStr ">>"]
-
-#endif {- Data Parallel Haskell -}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Name]{@Name@: to transmit name info from renamer to typechecker}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Name (
- -- things for the Name NON-abstract type
- Name(..),
-
- isTyConName, isClassName, isClassOpName,
- getTagFromClassOpName, isUnboundName,
- invisibleName,
- eqName, cmpName,
-
- -- to make the interface self-sufficient
- Id, FullName, ShortName, TyCon, Unique
-#ifndef __GLASGOW_HASKELL__
- ,TAG_
-#endif
- ) where
-
-import AbsUniType ( cmpTyCon, TyCon, Class, ClassOp, Arity(..)
- IF_ATTACK_PRAGMAS(COMMA cmpClass)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Id ( cmpId, Id )
-import NameTypes -- all of them
-import Outputable
-import Pretty
-import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc )
-import Unique ( eqUnique, cmpUnique, pprUnique, Unique )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Name-datatype]{The @Name@ datatype}
-%* *
-%************************************************************************
-
-\begin{code}
-data Name
- = Short Unique -- Local ids and type variables
- ShortName
-
- -- Nano-prelude things; truly wired in.
- -- Includes all type constructors and their associated data constructors
- | WiredInTyCon TyCon
- | WiredInVal Id
-
- -- Prelude things not actually wired into the compiler, but important
- -- enough to get their own special lookup key (a magic Unique).
- | PreludeVal Unique{-IdKey-} FullName
- | PreludeTyCon Unique{-TyConKey-} FullName Arity Bool -- as for OtherTyCon
- | PreludeClass Unique{-ClassKey-} FullName
-
- | OtherTyCon Unique -- TyCons other than Prelude ones; need to
- FullName -- separate these because we want to pin on
- Arity -- their arity.
- Bool -- True <=> `data', False <=> `type'
- [Name] -- List of user-visible data constructors;
- -- NB: for `data' types only.
- -- Used in checking import/export lists.
-
- | OtherClass Unique
- FullName
- [Name] -- List of class methods; used for checking
- -- import/export lists.
-
- | OtherTopId Unique -- Top level id
- FullName
-
- | ClassOpName Unique
- Name -- Name associated w/ the defined class
- -- (can get unique and export info, etc., from this)
- FAST_STRING -- The class operation
- Int -- Unique tag within the class
-
- -- Miscellaneous
- | Unbound FAST_STRING -- Placeholder for a name which isn't in scope
- -- Used only so that the renamer can carry on after
- -- finding an unbound identifier.
- -- The string is grabbed from the unbound name, for
- -- debugging information only.
-\end{code}
-
-These @is..@ functions are used in the renamer to check that (eg) a tycon
-is seen in a context which demands one.
-
-\begin{code}
-isTyConName, isClassName, isUnboundName :: Name -> Bool
-
-isTyConName (WiredInTyCon _) = True
-isTyConName (PreludeTyCon _ _ _ _) = True
-isTyConName (OtherTyCon _ _ _ _ _) = True
-isTyConName other = False
-
-isClassName (PreludeClass _ _) = True
-isClassName (OtherClass _ _ _) = True
-isClassName other = False
-
-isUnboundName (Unbound _) = True
-isUnboundName other = False
-\end{code}
-
-@isClassOpName@ is a little cleverer: it checks to see whether the
-class op comes from the correct class.
-
-\begin{code}
-isClassOpName :: Name -- The name of the class expected for this op
- -> Name -- The name of the thing which should be a class op
- -> Bool
-
-isClassOpName (PreludeClass key1 _) (ClassOpName _ (PreludeClass key2 _) _ _)
- = key1 == key2
-isClassOpName (OtherClass uniq1 _ _) (ClassOpName _ (OtherClass uniq2 _ _) _ _)
- = eqUnique uniq1 uniq2
-isClassOpName other_class other_op = False
-\end{code}
-
-A Name is ``invisible'' if the user has no business seeing it; e.g., a
-data-constructor for an abstract data type (but whose constructors are
-known because of a pragma).
-\begin{code}
-invisibleName :: Name -> Bool
-
-invisibleName (PreludeVal _ n) = invisibleFullName n
-invisibleName (PreludeTyCon _ n _ _) = invisibleFullName n
-invisibleName (PreludeClass _ n) = invisibleFullName n
-invisibleName (OtherTyCon _ n _ _ _) = invisibleFullName n
-invisibleName (OtherClass _ n _) = invisibleFullName n
-invisibleName (OtherTopId _ n) = invisibleFullName n
-invisibleName _ = False
-\end{code}
-
-\begin{code}
-getTagFromClassOpName :: Name -> Int
-
-getTagFromClassOpName (ClassOpName _ _ _ tag) = tag
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Name-instances]{Instance declarations}
-%* *
-%************************************************************************
-
-\begin{code}
-cmpName n1 n2 = cmp n1 n2
- where
- cmp (Short u1 _) (Short u2 _) = cmpUnique u1 u2
-
- cmp (WiredInTyCon tc1) (WiredInTyCon tc2) = cmpTyCon tc1 tc2
- cmp (WiredInVal id1) (WiredInVal id2) = cmpId id1 id2
-
- cmp (PreludeVal k1 _) (PreludeVal k2 _) = cmpUnique k1 k2
- cmp (PreludeTyCon k1 _ _ _) (PreludeTyCon k2 _ _ _) = cmpUnique k1 k2
- cmp (PreludeClass k1 _) (PreludeClass k2 _) = cmpUnique k1 k2
-
- cmp (OtherTyCon u1 _ _ _ _) (OtherTyCon u2 _ _ _ _) = cmpUnique u1 u2
- cmp (OtherClass u1 _ _) (OtherClass u2 _ _) = cmpUnique u1 u2
- cmp (OtherTopId u1 _) (OtherTopId u2 _) = cmpUnique u1 u2
-
- cmp (ClassOpName u1 _ _ _) (ClassOpName u2 _ _ _) = cmpUnique u1 u2
-#if 0
- -- panic won't unify w/ CMP_TAG (Int#)
- cmp (Unbound a) (Unbound b) = panic "Eq.Name.Unbound"
-#endif
-
- cmp other_1 other_2 -- the tags *must* be different
- = let tag1 = tag_Name n1
- tag2 = tag_Name n2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
-
- tag_Name (Short _ _) = (ILIT(1) :: FAST_INT)
- tag_Name (WiredInTyCon _) = ILIT(2)
- tag_Name (WiredInVal _) = ILIT(3)
- tag_Name (PreludeVal _ _) = ILIT(4)
- tag_Name (PreludeTyCon _ _ _ _) = ILIT(5)
- tag_Name (PreludeClass _ _) = ILIT(6)
- tag_Name (OtherTyCon _ _ _ _ _) = ILIT(7)
- tag_Name (OtherClass _ _ _) = ILIT(8)
- tag_Name (OtherTopId _ _) = ILIT(9)
- tag_Name (ClassOpName _ _ _ _) = ILIT(10)
- tag_Name (Unbound _) = ILIT(11)
-\end{code}
-
-\begin{code}
-eqName a b = case cmpName a b of { EQ_ -> True; _ -> False }
-gtName a b = case cmpName a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
-
-instance Eq Name where
- a == b = case cmpName a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpName a b of { EQ_ -> False; _ -> True }
-
-instance Ord Name where
- a <= b = case cmpName a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpName a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpName a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpName a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
-#ifdef __GLASGOW_HASKELL__
- _tagCmp a b = case cmpName a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-\end{code}
-
-\begin{code}
-instance NamedThing Name where
- getExportFlag (Short _ _) = NotExported
- getExportFlag (WiredInTyCon _) = NotExported -- compiler always know about these
- getExportFlag (WiredInVal _) = NotExported
- getExportFlag (ClassOpName _ c _ _) = getExportFlag c
- getExportFlag other = getExportFlag (get_nm "getExportFlag" other)
-
- isLocallyDefined (Short _ _) = True
- isLocallyDefined (WiredInTyCon _) = False
- isLocallyDefined (WiredInVal _) = False
- isLocallyDefined (ClassOpName _ c _ _) = isLocallyDefined c
- isLocallyDefined other = isLocallyDefined (get_nm "isLocallyDefined" other)
-
- getOrigName (Short _ sn) = getOrigName sn
- getOrigName (WiredInTyCon tc) = getOrigName tc
- getOrigName (WiredInVal id) = getOrigName id
- getOrigName (ClassOpName _ c op _) = (fst (getOrigName c), op)
- getOrigName other = getOrigName (get_nm "getOrigName" other)
-
- getOccurrenceName (Short _ sn) = getOccurrenceName sn
- getOccurrenceName (WiredInTyCon tc) = getOccurrenceName tc
- getOccurrenceName (WiredInVal id) = getOccurrenceName id
- getOccurrenceName (ClassOpName _ _ op _) = op
- getOccurrenceName (Unbound s) = s _APPEND_ SLIT("<unbound>")
- getOccurrenceName other = getOccurrenceName (get_nm "getOccurrenceName" other)
-
- getInformingModules thing = panic "getInformingModule:Name"
-
- getSrcLoc (Short _ sn) = getSrcLoc sn
- getSrcLoc (WiredInTyCon tc) = mkBuiltinSrcLoc
- getSrcLoc (WiredInVal id) = mkBuiltinSrcLoc
- getSrcLoc (ClassOpName _ c _ _) = getSrcLoc c
- getSrcLoc (Unbound _) = mkUnknownSrcLoc
- getSrcLoc other = getSrcLoc (get_nm "getSrcLoc" other)
-
- getTheUnique (Short uniq _) = uniq
- getTheUnique (OtherTopId uniq _) = uniq
- getTheUnique other
- = pprPanic "NamedThing.Name.getTheUnique: not a Short or OtherTopId:" (ppr PprShowAll other)
-
- fromPreludeCore (WiredInTyCon _) = True
- fromPreludeCore (WiredInVal _) = True
- fromPreludeCore (PreludeVal _ n) = fromPreludeCore n
- fromPreludeCore (PreludeTyCon _ n _ _) = fromPreludeCore n
- fromPreludeCore (PreludeClass _ n) = fromPreludeCore n
- fromPreludeCore (ClassOpName _ c _ _) = fromPreludeCore c
- fromPreludeCore other = False
-
- hasType n = False
- getType n = panic "NamedThing.Name.getType"
-\end{code}
-
-A useful utility; most emphatically not for export!:
-\begin{code}
-get_nm :: String -> Name -> FullName
-
-get_nm msg (PreludeVal _ n) = n
-get_nm msg (PreludeTyCon _ n _ _) = n
-get_nm msg (OtherTyCon _ n _ _ _) = n
-get_nm msg (PreludeClass _ n) = n
-get_nm msg (OtherClass _ n _) = n
-get_nm msg (OtherTopId _ n) = n
-#ifdef DEBUG
-get_nm msg other = pprPanic ("get_nm:"++msg) (ppr PprShowAll other)
--- If match failure, probably on a ClassOpName or Unbound :-(
-#endif
-\end{code}
-
-\begin{code}
-instance Outputable Name where
-#ifdef DEBUG
- ppr PprDebug (Short u s) = pp_debug u s
- ppr PprDebug (PreludeVal u i) = pp_debug u i
- ppr PprDebug (PreludeTyCon u t _ _) = pp_debug u t
- ppr PprDebug (PreludeClass u c) = pp_debug u c
-
- ppr PprDebug (OtherTyCon u n _ _ _) = pp_debug u n
- ppr PprDebug (OtherClass u n _) = pp_debug u n
- ppr PprDebug (OtherTopId u n) = pp_debug u n
-#endif
- ppr sty (Short u s) = ppr sty s
-
- ppr sty (WiredInTyCon tc) = ppr sty tc
- ppr sty (WiredInVal id) = ppr sty id
- ppr sty (PreludeVal _ i) = ppr sty i
- ppr sty (PreludeTyCon _ t _ _) = ppr sty t
- ppr sty (PreludeClass _ c) = ppr sty c
-
- ppr sty (OtherTyCon u n a b c) = ppr sty n
- ppr sty (OtherClass u n c) = ppr sty n
- ppr sty (OtherTopId u n) = ppr sty n
-
- ppr sty (ClassOpName u c s i)
- = let
- ps = ppPStr s
- in
- case sty of
- PprForUser -> ps
- PprInterface _ -> ps
- PprDebug -> ps
- other -> ppBesides [ps, ppChar '{',
- ppSep [pprUnique u,
- ppStr "op", ppInt i,
- ppStr "cls", ppr sty c],
- ppChar '}']
-
- ppr sty (Unbound s) = ppStr ("*UNBOUND*"++ _UNPK_ s)
-
-pp_debug uniq thing
- = ppBesides [ppr PprDebug thing, ppStr "{-", pprUnique uniq, ppStr "-}" ]
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[AbsUniType]{@AbsUniType@: the abstract interface to @UniType@}
-
-The module @AbsUniType@ is the ``outside world's'' interface to the
-@UniType@ datatype. It imports and re-exports the appropriate
-@UniType@ stuff.
-
-The prototype compiler's lack of original namery means it is good to
-include @Class@, @TyVar@ and @TyCon@ stuff here, too, and to let this
-module also present the ``outside-world'' interface for them.
-
-\begin{code}
-#include "HsVersions.h"
-
-module AbsUniType (
- -- Class and ClassOp stuff -------------------------------------
- Class,
- mkClass,
- getClassKey, getClassOps,
- getSuperDictSelId, getClassOpId, getDefaultMethodId,
- getConstMethodId,
- getClassSig, getClassBigSig, getClassInstEnv,
---UNUSED: getClassDefaultMethodsInfo,
- isSuperClassOf,
- cmpClass,
- derivableClassKeys,
- isNumericClass, isStandardClass, -- UNUSED: isDerivableClass,
-
- ClassOp,
- mkClassOp,
- getClassOpTag, getClassOpString,
---UNUSED: getClassOpSig,
- getClassOpLocalType,
-
- -- TyVar stuff -------------------------------------------------
- TyVar,
- TyVarTemplate,
-
- mkUserTyVar, mkPolySysTyVar, mkOpenSysTyVar,
---UNUSED: mkPrimSysTyVar, isPrimTyVar,
-
--- getTyVarUnique,
-
- cmpTyVar, eqTyVar, ltTyVar, -- used a lot!
-
- mkUserTyVarTemplate, mkSysTyVarTemplate, mkTemplateTyVars,
-
- cloneTyVarFromTemplate,
- cloneTyVar,
- instantiateTyVarTemplates,
-
- -- a supply of template tyvars
- alphaTyVars,
- alpha_tv, beta_tv, gamma_tv, delta_tv, epsilon_tv, -- templates
- alpha_tyvar, beta_tyvar, gamma_tyvar, delta_tyvar, epsilon_tyvar,-- real tyvars
-
- -- TyCon stuff -------------------------------------------------
- TyCon,
- Arity(..), -- synonym for Int
- mkSynonymTyCon, mkDataTyCon, mkTupleTyCon,
- mkPrimTyCon, mkSpecTyCon,
-#ifdef DPH
- mkProcessorTyCon, mkPodizedPodTyCon,
-#endif {- Data Parallel Haskell -}
-
- isSynTyCon, isVisibleSynTyCon, isDataTyCon,
- isPrimTyCon, isBoxedTyCon,
- maybeCharLikeTyCon, maybeIntLikeTyCon,
- maybeFloatLikeTyCon, maybeDoubleLikeTyCon,
- isEnumerationTyCon, --UNUSED: isEnumerationTyConMostly,
- isTupleTyCon,
- isLocalSpecTyCon, isLocalGenTyCon, isBigTupleTyCon,
- maybeSingleConstructorTyCon,
- derivedFor, --UNUSED: preludeClassDerivedFor,
- cmpTyCon, eqTyCon,
-
- getTyConArity, getTyConDataCons,
- getTyConTyVarTemplates,
- getTyConKind,
- getTyConDerivings,
- getTyConFamilySize,
-
- -- UniType stuff -----------------------------------------------
- UniType,
-
- -- USEFUL SYNONYMS
- SigmaType(..), RhoType(..), TauType(..),
- ThetaType(..), -- synonym for [(Class,UniType)]
-
- -- CONSTRUCTION
- mkTyVarTy, mkTyVarTemplateTy, mkDictTy,
- -- use applyTyCon to make UniDatas, UniSyns
- mkRhoTy, mkForallTy, mkSigmaTy, -- ToDo: perhaps nuke one?
-
- -- QUANTIFICATION & INSTANTIATION
- quantifyTy,
- instantiateTy, instantiateTauTy, instantiateThetaTy,
-
- -- COMPARISON (use sparingly!)
- cmpUniType,
- cmpUniTypeMaybeList,
-
- -- PRE-BUILT TYPES (for Prelude)
- alpha, beta, gamma, delta, epsilon, -- these have templates in them
- alpha_ty, beta_ty, gamma_ty, delta_ty, epsilon_ty, -- these have tyvars in them
-
- -- UniTyFuns stuff ---------------------------------------------
- -- CONSTRUCTION
- applyTy, applyTyCon, applySynTyCon, applyNonSynTyCon,
- glueTyArgs, mkSuperDictSelType, --UNUSED: mkDictFunType,
- specialiseTy,
-
- -- DESTRUCTION
---not exported: expandTySyns,
- expandVisibleTySyn,
- getTyVar, getTyVarMaybe, getTyVarTemplateMaybe,
- splitType, splitForalls, getTauType, splitTyArgs,
- splitTypeWithDictsAsArgs,
---not exported/unused: sourceTypes, targetType,
- funResultTy,
- splitDictType,
- kindFromType,
- getUniDataTyCon, getUniDataTyCon_maybe,
- getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
- unDictifyTy,
- getMentionedTyCons,
-#ifdef USE_SEMANTIQUE_STRANAL
- getReferredToTyCons,
-#endif {- Semantique strictness analyser -}
- getMentionedTyConsAndClassesFromUniType,
- getMentionedTyConsAndClassesFromTyCon,
- getMentionedTyConsAndClassesFromClass,
- getUniTyDescription,
-
- -- FREE-VARIABLE EXTRACTION
- extractTyVarsFromTy, extractTyVarsFromTys,
- extractTyVarTemplatesFromTy,
-
- -- PREDICATES
- isTyVarTy, isTyVarTemplateTy,
- maybeUnpackFunTy, isFunType,
- isPrimType, isUnboxedDataType, --UNUSED: isDataConType,
- isLeakFreeType,
- maybeBoxedPrimType,
---UNUSED: hasHigherOrderArg,
- isDictTy, isGroundTy, isGroundOrTyVarTy,
- instanceIsExported,
---UNUSED: isSynTarget,
- isTauTy, isForAllTy,
- maybePurelyLocalTyCon, maybePurelyLocalClass,
- maybePurelyLocalType,
- returnsRealWorld, -- HACK courtesy of SLPJ
-#ifdef DPH
- isProcessorTy,
- isProcessorTyCon,
- isPodizedPodTyCon,
- getPodizedPodDimension,
- runtimeUnpodizableType,
-#endif {- Data Parallel Haskell -}
-
- -- SUBSTITUTION
- applyTypeEnvToTy, applyTypeEnvToThetaTy,
---not exported: applyTypeEnvToTauTy,
- mapOverTyVars,
--- genInstantiateTyUS, -- ToDo: ???
-
- -- PRETTY PRINTING AND FORCING
- pprUniType, pprParendUniType, pprMaybeTy,
- pprTyCon, pprIfaceClass, pprClassOp,
- getTypeString,
- typeMaybeString,
- specMaybeTysSuffix,
- showTyCon,
- showTypeCategory,
-
- -- MATCHING
- matchTy, -- UNUSED: matchTys,
-
- -- and, finally, stuff to make the interface self-contained...
--- Outputable(..), NamedThing(..),
- ExportFlag, Pretty(..), PprStyle, PrettyRep,
-
- GlobalSwitch, UnfoldingDetails, Id, DataCon(..), IdEnv(..),
- InstTemplate, Maybe, Name, FullName, ShortName,
- PrimKind, TyVarEnv(..), TypeEnv(..), Unique, ClassInstEnv(..),
- MatchEnv(..), InstTyEnv(..), UniqFM, Bag
-
- IF_ATTACK_PRAGMAS(COMMA assocMaybe)
-
-#ifndef __GLASGOW_HASKELL__
- ,TAG_
-#endif
- ) where
-
-import Class
-import TyVar
-import TyCon
-import UniType
-import UniTyFuns
-
-import AbsSyn ( RenamedBinds(..), RenamedExpr(..), RenamedGRHS(..),
- RenamedGRHSsAndBinds(..), RenamedPat(..), Binds,
- Expr, GRHS, GRHSsAndBinds, InPat
- )
-import InstEnv ( ClassInstEnv(..), MatchEnv(..) )
-import Maybes ( assocMaybe, Maybe(..) ) -- (..) for pragmas only
-import NameTypes ( ShortName, FullName ) -- pragmas only
-import Outputable
-import Pretty ( Pretty(..)
- IF_ATTACK_PRAGMAS(COMMA ppStr COMMA ppDouble COMMA ppInteger)
- )
-import TyVarEnv -- ( TyVarEnv )
-import Unique ( Unique, UniqueSupply )
-#if USE_ATTACK_PRAGMAS
-import Util
-#else
-#ifndef __GLASGOW_HASKELL__
-import Util ( TAG_ )
-#endif
-#endif
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Class]{The @Class@ datatype}
-
-\begin{code}
-#include "HsVersions.h"
-
-module Class (
- Class(..), -- must be *NON*-abstract so UniTyFuns can see it
-
- mkClass,
- getClassKey, getClassOps,
- getSuperDictSelId, getClassOpId, getDefaultMethodId,
- getConstMethodId,
- getClassSig, getClassBigSig, getClassInstEnv,
---UNUSED: getClassDefaultMethodsInfo,
- isSuperClassOf,
- cmpClass,
-
- derivableClassKeys,
- isNumericClass, isStandardClass, --UNUSED: isDerivableClass,
-
- ClassOp(..), -- must be non-abstract so UniTyFuns can see them
- mkClassOp,
- getClassOpTag, getClassOpString,
---UNUSED: getClassOpSig,
- getClassOpLocalType,
-
- -- and to make the interface self-sufficient...
- Id, InstTemplate, Maybe, Name, FullName, TyVarTemplate,
- UniType, Unique
- ) where
-
-import Id ( getIdSpecialisation, Id )
-import IdInfo
-import InstEnv ( ClassInstEnv(..), MatchEnv(..) )
-import Maybes ( assocMaybe, Maybe(..) )
-import Name ( Name(..), ShortName )
-import NameTypes ( FullName, SrcLoc )
-import Pretty
-import Outputable -- class for printing, forcing
-import TyCon ( TyCon, Arity(..)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- )
-import TyVar ( TyVarTemplate )
-import Unique -- class key stuff
-import UniType ( UniType, ThetaType(..), TauType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import UniTyFuns ( splitType, pprClassOp
- IF_ATTACK_PRAGMAS(COMMA pprUniType COMMA pprTyCon)
- )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Class-basic]{@Class@: basic definition}
-%* *
-%************************************************************************
-
-A @Class@ corresponds to a Greek kappa in the static semantics:
-
-\begin{code}
-data Class
- = MkClass
- Unique{-ClassKey-}-- Key for fast comparison
- FullName
-
- TyVarTemplate -- The class type variable
-
- [Class] [Id] -- Immediate superclasses, and the
- -- corresponding selector functions to
- -- extract them from a dictionary of this
- -- class
-
- [ClassOp] -- The * class operations
- [Id] -- * selector functions
- [Id] -- * default methods
- -- They are all ordered by tag. The
- -- selector ids are less innocent than they
- -- look, because their IdInfos contains
- -- suitable specialisation information. In
- -- particular, constant methods are
- -- instances of selectors at suitably simple
- -- types.
-
- ClassInstEnv -- Gives details of all the instances of this class
-
- [(Class,[Class])] -- Indirect superclasses;
- -- (k,[k1,...,kn]) means that
- -- k is an immediate superclass of k1
- -- k1 is an immediate superclass of k2
- -- ... and kn is an immediate superclass
- -- of this class. (This is all redundant
- -- information, since it can be derived from
- -- the superclass information above.)
-\end{code}
-
-The @mkClass@ function fills in the indirect superclasses.
-
-\begin{code}
-mkClass :: Name -> TyVarTemplate
- -> [Class] -> [Id]
- -> [ClassOp] -> [Id] -> [Id]
- -> ClassInstEnv
- -> Class
-
-mkClass name tyvar super_classes superdict_sels
- class_ops dict_sels defms class_insts
- = MkClass key full_name tyvar
- super_classes superdict_sels
- class_ops dict_sels defms
- class_insts
- trans_clos
- where
- (key,full_name) = case name of
- OtherClass uniq full_name _ -> (uniq, full_name)
- PreludeClass key full_name -> (key, full_name)
-
- trans_clos :: [(Class,[Class])]
- trans_clos = transitiveClosure succ (==) [ (clas, []) | clas <- super_classes ]
-
- succ (clas@(MkClass _ _ _ super_classes _ _ _ _ _ _), links)
- = [(super, (clas:links)) | super <- super_classes]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Class-selectors]{@Class@: simple selectors}
-%* *
-%************************************************************************
-
-The rest of these functions are just simple selectors.
-
-\begin{code}
-getClassKey (MkClass key _ _ _ _ _ _ _ _ _) = key
-
-getClassOps (MkClass _ _ _ _ _ ops _ _ _ _) = ops
-
-getSuperDictSelId (MkClass _ _ _ scs scsel_ids _ _ _ _ _) super_clas
- = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas
-
-getClassOpId (MkClass _ _ _ _ _ ops op_ids _ _ _) op
- = op_ids !! (getClassOpTag op - 1)
-
-getDefaultMethodId (MkClass _ _ _ _ _ ops _ defm_ids _ _) op
- = defm_ids !! (getClassOpTag op - 1)
-
-getConstMethodId (MkClass _ _ _ _ _ ops op_ids _ _ _) op ty
- = -- constant-method info is hidden in the IdInfo of
- -- the class-op id (as mentioned up above).
- let
- sel_id = op_ids !! (getClassOpTag op - 1)
- in
- case (lookupConstMethodId sel_id ty) of
- Just xx -> xx
- Nothing -> error (ppShow 80 (ppAboves [
- ppCat [ppStr "ERROR: getConstMethodId:", ppr PprDebug op, ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids, ppr PprDebug sel_id],
- ppStr "(This can arise if an interface pragma refers to an instance",
- ppStr "but there is no imported interface which *defines* that instance.",
- ppStr "The info above, however ugly, should indicate what else you need to import."
- ]))
-
-getClassSig :: Class -> (TyVarTemplate, [Class], [ClassOp])
-
-getClassSig (MkClass _ _ tyvar super_classes _ ops _ _ _ _)
- = (tyvar, super_classes, ops)
-
-getClassBigSig (MkClass _ _ tyvar super_classes sdsels ops sels defms _ _)
- = (tyvar, super_classes, sdsels, ops, sels, defms)
-
-getClassInstEnv (MkClass _ _ _ _ _ _ _ _ inst_env _) = inst_env
-
---UNUSED: getClassDefaultMethodsInfo (MkClass _ _ _ _ _ _ _ defms _ _) = defms
-\end{code}
-
-@a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
-@b@, but if it is, it returns $@Just@~[k_1,\ldots,k_n]$, where the
-$k_1,\ldots,k_n$ are exactly as described in the definition of the
-@MkClass@ constructor above.
-
-\begin{code}
-isSuperClassOf :: Class -> Class -> Maybe [Class]
-
-clas `isSuperClassOf` (MkClass _ _ _ _ _ _ _ _ _ links) = assocMaybe links clas
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Class-std-groups]{Standard groups of Prelude classes}
-%* *
-%************************************************************************
-
-@derivableClassKeys@ is also used in checking \tr{deriving} constructs
-(@TcDeriv@).
-
-NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
-even though every numeric class has these two as a superclass,
-because the list of ambiguous dictionaries hasn't been simplified.
-
-\begin{code}
-isNumericClass, isStandardClass {-UNUSED:, isDerivableClass-} :: Class -> Bool
-
-isNumericClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys
-isStandardClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
---isDerivableClass (MkClass key _ _ _ _ _ _ _ _ _) = key `is_elem` derivableClassKeys
-
-is_elem = isIn "is_X_Class"
-
-numericClassKeys
- = [ numClassKey,
- realClassKey,
- integralClassKey,
- fractionalClassKey,
- floatingClassKey,
- realFracClassKey,
- realFloatClassKey ]
-
-derivableClassKeys
- = [ eqClassKey,
- textClassKey,
- ordClassKey,
- enumClassKey,
- ixClassKey ]
- -- ToDo: add binaryClass
-
-standardClassKeys
- = derivableClassKeys ++ numericClassKeys
- ++ [ cCallableClassKey, cReturnableClassKey ]
- --
- -- We have to have "_CCallable" and "_CReturnable" in the standard
- -- classes, so that if you go...
- --
- -- _ccall_ foo ... 93{-numeric literal-} ...
- --
- -- ... it can do The Right Thing on the 93.
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Class-instances]{Instance declarations for @Class@}
-%* *
-%************************************************************************
-
-We compare @Classes@ by their keys (which include @Uniques@).
-
-\begin{code}
-cmpClass (MkClass k1 _ _ _ _ _ _ _ _ _) (MkClass k2 _ _ _ _ _ _ _ _ _)
- = cmpUnique k1 k2
-
-instance Eq Class where
- (MkClass k1 _ _ _ _ _ _ _ _ _) == (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 == k2
- (MkClass k1 _ _ _ _ _ _ _ _ _) /= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 /= k2
-
-instance Ord Class where
- (MkClass k1 _ _ _ _ _ _ _ _ _) <= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 <= k2
- (MkClass k1 _ _ _ _ _ _ _ _ _) < (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 < k2
- (MkClass k1 _ _ _ _ _ _ _ _ _) >= (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 >= k2
- (MkClass k1 _ _ _ _ _ _ _ _ _) > (MkClass k2 _ _ _ _ _ _ _ _ _) = k1 > k2
-#ifdef __GLASGOW_HASKELL__
- _tagCmp a b = case cmpClass a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-\end{code}
-
-\begin{code}
-instance NamedThing Class where
- getExportFlag (MkClass _ n _ _ _ _ _ _ _ _) = getExportFlag n
- isLocallyDefined (MkClass _ n _ _ _ _ _ _ _ _) = isLocallyDefined n
- getOrigName (MkClass _ n _ _ _ _ _ _ _ _) = getOrigName n
- getOccurrenceName (MkClass _ n _ _ _ _ _ _ _ _) = getOccurrenceName n
- getInformingModules (MkClass _ n _ _ _ _ _ _ _ _) = getInformingModules n
- getSrcLoc (MkClass _ n _ _ _ _ _ _ _ _) = getSrcLoc n
- fromPreludeCore (MkClass _ n _ _ _ _ _ _ _ _) = fromPreludeCore n
-
- getTheUnique = panic "NamedThing.Class.getTheUnique"
- hasType = panic "NamedThing.Class.hasType"
- getType = panic "NamedThing.Class.getType"
-\end{code}
-
-And the usual output stuff:
-\begin{code}
-instance Outputable Class where
- -- we use pprIfaceClass for printing in interfaces
-
-{- ppr sty@PprShowAll (MkClass u n _ _ _ ops _ _ _ _)
- = ppCat [ppr sty n, pprUnique u, ppr sty ops]
--}
- ppr sty (MkClass u n _ _ _ _ _ _ _ _) = ppr sty n
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ClassOp-basic]{@ClassOp@: type and basic functions}
-%* *
-%************************************************************************
-
-\begin{code}
-data ClassOp
- = MkClassOp FAST_STRING -- The operation name
-
- Int -- Unique within a class; starts at 1
-
- UniType -- Type; the class tyvar is free (you can find
- -- it from the class). This means that a
- -- ClassOp doesn't make much sense outside the
- -- context of its parent class.
-\end{code}
-
-A @ClassOp@ represents a a class operation. From it and its parent
-class we can construct the dictionary-selector @Id@ for the
-operation/superclass dictionary, and the @Id@ for its default method.
-It appears in a list inside the @Class@ object.
-
-The type of a method in a @ClassOp@ object is its local type; that is,
-without the overloading of the class itself. For example, in the
-declaration
-\begin{pseudocode}
- class Foo a where
- op :: Ord b => a -> b -> a
-\end{pseudocode}
-the type recorded for @op@ in the @ClassOp@ list of the @Class@ object is
-just
- $\forall \beta.~
- @Ord@~\beta \Rightarrow
- \alpha \rightarrow \beta \rightarrow alpha$
-
-(where $\alpha$ is the class type variable recorded in the @Class@
-object). Of course, the type of @op@ recorded in the GVE will be its
-``full'' type
-
- $\forall \alpha \forall \beta.~
- @Foo@~\alpha \Rightarrow
- ~@Ord@~\beta \Rightarrow \alpha
- \rightarrow \beta \rightarrow alpha$
-
-******************************************************************
-**** That is, the type variables of a class op selector
-*** are all at the outer level.
-******************************************************************
-
-\begin{code}
-mkClassOp = MkClassOp
-
-getClassOpTag :: ClassOp -> Int
-getClassOpTag (MkClassOp _ tag _) = tag
-
-getClassOpString :: ClassOp -> FAST_STRING
-getClassOpString (MkClassOp str _ _) = str
-
-{- UNUSED:
-getClassOpSig :: ClassOp -> ([TyVarTemplate], ThetaType, TauType)
-getClassOpSig (MkClassOp _ _ ty) = splitType ty
--}
-
-getClassOpLocalType :: ClassOp -> UniType {-SigmaType-}
-getClassOpLocalType (MkClassOp _ _ ty) = ty
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ClassOp-instances]{Instance declarations for @ClassOp@}
-%* *
-%************************************************************************
-
-@ClassOps@ are compared by their tags.
-
-\begin{code}
-instance Eq ClassOp where
- (MkClassOp _ i1 _) == (MkClassOp _ i2 _) = i1 == i2
- (MkClassOp _ i1 _) /= (MkClassOp _ i2 _) = i1 == i2
-
-instance Ord ClassOp where
- (MkClassOp _ i1 _) <= (MkClassOp _ i2 _) = i1 <= i2
- (MkClassOp _ i1 _) < (MkClassOp _ i2 _) = i1 < i2
- (MkClassOp _ i1 _) >= (MkClassOp _ i2 _) = i1 >= i2
- (MkClassOp _ i1 _) > (MkClassOp _ i2 _) = i1 > i2
- -- ToDo: something for _tagCmp? (WDP 94/10)
-\end{code}
-
-And the usual output stuff:
-\begin{code}
-instance Outputable ClassOp where
- ppr = pprClassOp
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TyCon]{Type constructors}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TyCon (
- TyCon(..), -- not abstract; usually grabbed via AbsUniType
- Arity(..), -- synonym for Int
- mkSynonymTyCon, mkDataTyCon, mkTupleTyCon,
- mkPrimTyCon, mkSpecTyCon,
-#ifdef DPH
- mkProcessorTyCon,
- mkPodizedPodTyCon,
- isProcessorTyCon,
- isPodizedPodTyCon,
- getPodizedPodDimension,
-#endif {- Data Parallel Haskell -}
-
- isSynTyCon, isVisibleSynTyCon, isDataTyCon,
- isPrimTyCon, isBoxedTyCon,
- maybeCharLikeTyCon, maybeIntLikeTyCon,
- maybeFloatLikeTyCon, maybeDoubleLikeTyCon,
- isEnumerationTyCon, --UNUSED: isEnumerationTyConMostly,
- isTupleTyCon,
- isLocalSpecTyCon, isLocalGenTyCon, isBigTupleTyCon,
- maybeSingleConstructorTyCon,
- derivedFor, --UNUSED: preludeClassDerivedFor,
- cmpTyCon, eqTyCon,
-
- getTyConArity, getTyConDataCons,
- getTyConTyVarTemplates,
- getTyConKind,
- getTyConDerivings,
- getTyConFamilySize,
-
- -- to make the interface self-sufficient...
- Class, Id, FullName, PrimKind, TyVarTemplate, UniType,
- Unique, Maybe, DataCon(..)
- ) where
-
-IMPORT_Trace -- ToDo: rm (debugging)
-
-import AbsPrel ( charPrimTy, intPrimTy, floatPrimTy,
- doublePrimTy, pRELUDE_BUILTIN
- )
-
-import Class ( getClassKey, Class
- IF_ATTACK_PRAGMAS(COMMA cmpClass)
- )
-import Id -- DPH wants to export various things as well
-import IdInfo
-import Maybes ( Maybe(..) )
-import NameTypes -- various types to do with names
-import Outputable -- class for printing, forcing
-import Pretty -- pretty-printing utilities
-import PrimKind ( PrimKind(..) )
-import SrcLoc
-import TyVar ( TyVarTemplate, alphaTyVars )
-import Unique ( cmpUnique, Unique )
-import UniTyFuns ( getTauType, getUniDataTyCon, pprTyCon,
- cmpUniTypeMaybeList, specMaybeTysSuffix
- IF_ATTACK_PRAGMAS(COMMA pprUniType COMMA splitType)
- )
-import UniType ( UniType
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyCon-basics]{@TyCon@ type and basic operations}
-%* *
-%************************************************************************
-
-\begin{code}
-data TyCon
- = SynonymTyCon Unique{-TyConKey-} -- for fast comparison
- FullName
- Arity
- [TyVarTemplate]-- Argument type variables
- UniType -- Right-hand side, mentioning these type vars
- -- Acts as a template for the expansion when
- -- the tycon is applied to some types.
- Bool -- True <=> expansion is visible to user;
- -- i.e., *not* abstract
-
- | DataTyCon Unique{-TyConKey-}
- FullName
- Arity
- [TyVarTemplate] -- see note below
- [Id] -- its data constructors
- [Class] -- classes which have derived instances
- Bool -- True <=> data constructors are visible
- -- to user; i.e., *not* abstract
-
- | TupleTyCon Arity -- just a special case of DataTyCon
-
- | PrimTyCon -- Primitive types; cannot be defined in Haskell
- -- Always unboxed; hence never represented by a closure
- -- Often represented by a bit-pattern for the thing
- -- itself (eg Int#), but sometimes by a pointer to
- -- a heap-allocated object (eg ArrInt#).
- -- The primitive types Arr# and StablePtr# have
- -- parameters (hence arity /= 0); but the rest don't.
- Unique{-TyConKey-}
- FullName
- Arity -- Arity is *usually* 0.
- ([PrimKind] -> PrimKind)
- -- Only arrays use the list in a non-trivial way.
- -- Length of that list must == arity.
-
- -- Used only for naming purposes in CLabels
- | SpecTyCon TyCon -- original data (or tuple) tycon
- [Maybe UniType] -- specialising types
-
-#ifdef DPH
- | ProcessorTyCon Arity -- special cased in same way as tuples
-
- | PodizedPodTyCon Int -- podized dimension
- TyCon -- Thing the pod contains
-#endif
-
-type Arity = Int
-\end{code}
-
-{\em Note about the the @[TyVarTemplates]@ in @DataTyCon@ (and
-@SynonymTyCon@, too? ToDo):} they should be the type variables which
-appeared in the original @data@ declaration. They are there {\em for
-documentation purposes only}. In particular, when printing out
-interface files, we want to use the same type-variable names as
-appeared in the @data@ declaration for that type constructor.
-However, they have no semantic significance.
-
-We could also ensure that the data constructors in the @[Id]@ had the
-{\em same} type vars in their @[TyVarTemplate]@ lists, so that we
-don't have to do a translation on printout.
-{\em End of note.}
-
-Constructor functions, and simple access functions:
-\begin{code}
-mkSynonymTyCon = SynonymTyCon
-mkDataTyCon = DataTyCon
-mkTupleTyCon = TupleTyCon
-mkPrimTyCon = PrimTyCon
-mkSpecTyCon = SpecTyCon
-
-#ifdef DPH
-mkProcessorTyCon= ProcessorTyCon
-mkPodizedPodTyCon = PodizedPodTyCon
-#endif {- Data Parallell Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyCon-extractors]{Extractors for @TyCon@}
-%* *
-%************************************************************************
-
-\begin{code}
-getTyConArity (PrimTyCon _ _ a _) = a
-getTyConArity (SynonymTyCon _ _ a _ _ _) = a
-getTyConArity (DataTyCon _ _ a _ _ _ _) = a
-getTyConArity (SpecTyCon tc tys) = getTyConArity tc - length tys
-getTyConArity (TupleTyCon a) = a
-#ifdef DPH
-getTyConArity (ProcessorTyCon a) = a
-getTyConArity (PodizedPodTyCon _ _) = panic "getTyConArity: pod"
-#endif {- Data Parallel Haskell -}
-
-getTyConKind (PrimTyCon _ _ _ kind_fn) kinds = kind_fn kinds
-#ifdef DPH
-getTyConKind (PodizedPodTyCon _ tc) kinds = getTyConKind tc kinds
-#endif {- Data Parallel Haskell -}
-getTyConKind other kinds = PtrKind -- the "default"
-
-getTyConDerivings (DataTyCon _ _ _ _ _ derivings _) = derivings
-getTyConDerivings (SpecTyCon tc tys) = panic "getTyConDerivings:SpecTyCon"
-#ifdef DPH
-getTyConDerivings (PodizedPodTyCon _ _) = panic "getTyConDerivings:pod"
-#endif {- Data Parallel Haskell -}
-getTyConDerivings other = []
- -- NB: we do *not* report the PreludeCore types "derivings"...
-
-getTyConDataCons (DataTyCon _ _ _ _ data_cons _ _) = data_cons
-getTyConDataCons (SpecTyCon tc tys) = panic "getTyConDataCons:SpecTyCon"
-getTyConDataCons (TupleTyCon a) = [mkTupleCon a]
-#ifdef DPH
-getTyConDataCons (ProcessorTyCon a) = [mkProcessorCon a]
-getTyConDataCons (PodizedPodTyCon _ _) = panic "getTyConDataCons: pod"
-#endif {- Data Parallel Haskell -}
-getTyConDataCons other_tycon = []
-\end{code}
-For the use of @getTyConDataCons@ in @MkUnfoldings@, the behaviour
-above is right: return @[]@ if not an algebraic data type. I am not
-certain if that's right for all uses (perhaps should @panic@?) [WDP]
-
-The following function returns (free) type-variables associated with a
-given @TyCon@. As the information about these variables is distributed
-over the @TyCon@'s constructors we take them from the type of any
-of the constructors assuming that the variables in the remaining
-type constructors are the same (responsible for keeping this assumption
-valid is the typechecker). ToDo: rm this old comment?
-\begin{code}
-getTyConTyVarTemplates (SynonymTyCon _ _ _ tvs _ _) = tvs
-getTyConTyVarTemplates (DataTyCon _ _ _ tvs _ _ _) = tvs
-getTyConTyVarTemplates (SpecTyCon tc tys) = panic "getTyConTyVarTemplates:SpecTyCon"
-getTyConTyVarTemplates (TupleTyCon a) = take a alphaTyVars
-getTyConTyVarTemplates (PrimTyCon _ _ _ _) = [] -- ToDo: ???
-#ifdef DPH
-getTyConTyVarTemplates (ProcessorTyCon a) = take a alphaTyVars
-getTyConTyVarTemplates (PodizedPodTyCon _ _) = panic "getTyConTyVarTem"
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-getTyConFamilySize :: TyCon -> Maybe Int -- return Nothing if we don't know
-
-getTyConFamilySize (TupleTyCon _) = Just 1
-getTyConFamilySize (SpecTyCon tc tys) = getTyConFamilySize tc
-getTyConFamilySize (DataTyCon _ _ _ _ dcs _ _)
- = let
- no_data_cons = length dcs
- in
- if no_data_cons == 0 then Nothing else Just no_data_cons
-
-#ifdef DEBUG
- -- ToDo: if 0 then the answer is really "I don't know"; what then?
-getTyConFamilySize tc@(PrimTyCon _ _ _ _)
- = pprPanic "getTyConFamilySize:prim:" (ppr PprDebug tc)
-getTyConFamilySize (SynonymTyCon _ _ _ _ expand _)
- = pprTrace "getTyConFamilySize:Syn:" (ppr PprDebug expand) (
- let
- (tycon,_,data_cons) = getUniDataTyCon (getTauType expand)
- no_data_cons = length data_cons
- in
- if no_data_cons == 0 then Nothing else Just no_data_cons
- )
-#endif
-#ifdef DPH
-getTyConFamilySize (ProcessorTyCon _) = Just 1
-getTyConFamilySize (PodizedPodTyCon _ _) = panic "getTyConFamilySize: Pod"
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyCon-predicates]{Predicates on @TyCon@s}
-%* *
-%************************************************************************
-
-\begin{code}
--- True <=> Algebraic data type
-isDataTyCon (DataTyCon _ _ _ _ _ _ _) = True
-isDataTyCon (SpecTyCon tc tys) = isDataTyCon tc
-isDataTyCon (TupleTyCon _) = True
-#ifdef DPH
-isDataTyCon (ProcessorTyCon _) = True
-isDataTyCon (PodizedPodTyCon _ tc) = isDataTyCon tc
-#endif {- Data Parallel Haskell -}
-isDataTyCon other = False
-
--- True <=> Synonym
-isSynTyCon (SynonymTyCon _ _ _ _ _ _) = True
-isSynTyCon (SpecTyCon tc tys) = panic "isSynTyCon: SpecTyCon"
-#ifdef DPH
-isSynTyCon (PodizedPodTyCon _ _) = panic "isSynTyCon: Pod"
-#endif {- Data Parallel Haskell -}
-isSynTyCon other = False
-
-isVisibleSynTyCon (SynonymTyCon _ _ _ _ _ visible) = visible
-isVisibleSynTyCon other_tycon = panic "isVisibleSynTyCon"
-
-isPrimTyCon (PrimTyCon _ _ _ _) = True
-isPrimTyCon (SpecTyCon tc tys) = isPrimTyCon tc
-#ifdef DPH
-isPrimTyCon (PodizedPodTyCon _ tc) = isPrimTyCon tc
-#endif {- Data Parallel Haskell -}
-isPrimTyCon other = False
-
--- At present there are no unboxed non-primitive types, so isBoxedTyCon is
--- just the negation of isPrimTyCon.
-isBoxedTyCon (PrimTyCon _ _ _ _) = False
-isBoxedTyCon (SpecTyCon tc tys) = isBoxedTyCon tc
-#ifdef DPH
-isBoxedTyCon (PodizedPodTyCon _ tc) = isBoxedTyCon tc
-#endif {- Data Parallel Haskell -}
-isBoxedTyCon other = True
-
-\end{code}
-
-The @maybeCharLikeTyCon@ predicate tests for a tycon with no type
-variables, and one constructor which has one argument of type
-@CharPrim@. Similarly @maybeIntLikeTyCon@, etc.
-
-ToDo:SpecTyCon Do we want to CharLike etc for SpecTyCons ???
-
-\begin{code}
-maybeCharLikeTyCon (DataTyCon _ _ _ [] [con] [] _) = maybe_foo_like con charPrimTy
-#ifdef DPH
-maybeCharLikeTyCon (PodizedPodTyCon _ _) = panic "maybeCharLikeTyCon: Pod"
-#endif {- Data Parallel Haskell -}
-maybeCharLikeTyCon other = Nothing
-
-maybeIntLikeTyCon (DataTyCon _ _ _ [] [con] [] _) = maybe_foo_like con intPrimTy
-#ifdef DPH
-maybeIntLikeTyCon (PodizedPodTyCon _ _) = panic "maybeIntLikeTyCon: Pod"
-#endif {- Data Parallel Haskell -}
-maybeIntLikeTyCon other = Nothing
-
-maybeFloatLikeTyCon (DataTyCon _ _ _ [] [con] [] _) = maybe_foo_like con floatPrimTy
-#ifdef DPH
-maybeFloatLikeTyCon (PodizedPodTyCon _ _) = panic "maybeFloatLikeTyCon: Pod"
-#endif {- Data Parallel Haskell -}
-maybeFloatLikeTyCon other = Nothing
-
-maybeDoubleLikeTyCon (DataTyCon _ _ _ [] [con] [] _) = maybe_foo_like con doublePrimTy
-#ifdef DPH
-maybeDoubleLikeTyCon (PodizedPodTyCon _ _) = panic "maybeDoubleLikeTyCon: Pod"
-#endif {- Data Parallel Haskell -}
-maybeDoubleLikeTyCon other = Nothing
-
-maybe_foo_like con prim_type_to_match
- = case (getDataConSig con) of
- ([], [], [should_be_prim], _)
- | should_be_prim == prim_type_to_match -> Just con
- other -> Nothing
-
-#ifdef DPH
-isProcessorTyCon :: TyCon -> Bool
-isProcessorTyCon (ProcessorTyCon _) = True
-isProcessorTyCon other = False
-
-isPodizedPodTyCon :: TyCon -> Bool
-isPodizedPodTyCon (PodizedPodTyCon _ _) = True
-isPodizedPodTyCon other = False
-
-getPodizedPodDimension::TyCon -> Int
-getPodizedPodDimension (PodizedPodTyCon d _) = d
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-isEnumerationTyCon :: TyCon -> Bool
-
-isEnumerationTyCon (TupleTyCon arity)
- = arity == 0
-isEnumerationTyCon (DataTyCon _ _ _ _ data_cons _ _)
- = not (null data_cons) && all is_nullary data_cons
- where
- is_nullary con = case (getDataConSig con) of { (_,_, arg_tys, _) ->
- null arg_tys }
-#ifdef DEBUG
--- isEnumerationTyCon (SpecTyCon tc tys) -- ToDo:SpecTyCon
-isEnumerationTyCon other = pprPanic "isEnumerationTyCon: " (ppr PprShowAll other)
-#endif
-
--- this one is more of a *heuristic*
-{- UNUSED:
-isEnumerationTyConMostly :: TyCon -> Bool
-
-isEnumerationTyConMostly (TupleTyCon arity) = arity == 0
-
-isEnumerationTyConMostly tycon@(DataTyCon _ _ _ _ data_cons _ _)
- = isEnumerationTyCon tycon
- || four_or_more data_cons 0
- where
- four_or_more :: [Id] -> Int -> Bool
-
- four_or_more [] acc = if acc >= 4 then True else False
- four_or_more (c:cs) acc
- = case (getDataConSig c) of { (_,_, arg_tys, _) ->
- four_or_more cs (if (null arg_tys) then acc+1 else acc)
- }
--- isEnumerationTyConMostly (SpecTyCon tc tys) -- ToDo:SpecTyCon
--}
-
-
-maybeSingleConstructorTyCon :: TyCon -> Maybe Id
-maybeSingleConstructorTyCon (TupleTyCon arity) = Just (mkTupleCon arity)
-maybeSingleConstructorTyCon (DataTyCon _ _ _ _ [c] _ _) = Just c
-maybeSingleConstructorTyCon (DataTyCon _ _ _ _ _ _ _) = Nothing
-maybeSingleConstructorTyCon (PrimTyCon _ _ _ _) = Nothing
-maybeSingleConstructorTyCon tycon@(SpecTyCon tc tys) = pprPanic "maybeSingleConstructorTyCon:SpecTyCon:" (ppr PprDebug tycon)
- -- requires DataCons of TyCon
-\end{code}
-
-@derivedFor@ reports if we have an {\em obviously}-derived instance
-for the given class/tycon. Of course, you might be deriving something
-because it a superclass of some other obviously-derived class---this
-function doesn't deal with that.
-
-ToDo:SpecTyCon Do we want derivedFor etc for SpecTyCons ???
-
-\begin{code}
-derivedFor :: Class -> TyCon -> Bool
-
-clas `derivedFor` (DataTyCon _ _ _ _ _ derivs _) = clas `is_elem` derivs
-clas `derivedFor` something_weird = False
-
-x `is_elem` y = isIn "X_derivedFor" x y
-
-{- UNUSED:
-preludeClassDerivedFor :: Unique{-ClassKey-} -> TyCon -> Bool
-
-preludeClassDerivedFor key (DataTyCon _ _ _ _ _ derivs _)
- = key `is_elem` (map getClassKey derivs)
-preludeClassDerivedFor key something_weird = False
--}
-\end{code}
-
-\begin{code}
-isTupleTyCon (TupleTyCon arity) = arity >= 2 -- treat "0-tuple" specially
-isTupleTyCon (SpecTyCon tc tys) = isTupleTyCon tc
-isTupleTyCon other = False
-\end{code}
-
-@isLocalSpecTyCon@ determines if a tycon has specialisations created
-locally: locally defined tycons and any tycons from the prelude.
-But *not* if we're compiling the prelude itself...
-
-@isLocalGenTyCon@ determines if constructor code for a tycon is
-generated locally: locally defined tycons and big tuple tycons.
-
-\begin{code}
-isLocalSpecTyCon :: Bool -> TyCon -> Bool
-isLocalGenTyCon :: TyCon -> Bool
-
-isLocalSpecTyCon compiling_prelude tc
- = isLocallyDefined tc -- || (fromPreludeCore tc && not compiling_prelude)
- -- Not for now ... need to be local
- -- This will cause problem with splitting
-
-isLocalGenTyCon tc
- = isLocallyDefined tc -- || isBigTupleTyCon tc
- -- Not for now ... need to be local
- -- This will cause problem with splitting
-
-isBigTupleTyCon (TupleTyCon arity) = arity > 32
- -- Tuple0 to Tuple32 declared in prelude
- -- HEY! Nice magic constant! WDP 95/06
-isBigTupleTyCon (SpecTyCon tc _) = isBigTupleTyCon tc
-isBigTupleTyCon _ = False
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyCon-instances]{Instance declarations for @TyCon@}
-%* *
-%************************************************************************
-
-@TyCon@s are compared by comparing their @Unique@s.
-
-The strictness analyser needs @Ord@. It is a lexicographic order with
-the property @(a<=b) || (b<=a)@.
-
-\begin{code}
-cmpTyCon (SynonymTyCon k1 _ _ _ _ _) (SynonymTyCon k2 _ _ _ _ _)= cmpUnique k1 k2
-cmpTyCon (DataTyCon k1 _ _ _ _ _ _) (DataTyCon k2 _ _ _ _ _ _) = cmpUnique k1 k2
-cmpTyCon (TupleTyCon a1) (TupleTyCon a2) = cmp_i a1 a2
-cmpTyCon (PrimTyCon k1 _ _ _) (PrimTyCon k2 _ _ _) = cmpUnique k1 k2
-cmpTyCon (SpecTyCon tc1 mtys1) (SpecTyCon tc2 mtys2)
- = case cmpTyCon tc1 tc2 of { EQ_ -> cmpUniTypeMaybeList mtys1 mtys2; other -> other }
-#ifdef DPH
-cmpTyCon (ProcessorTyCon a1) (ProcessorTyCon a2) = cmp_i a1 a2
-cmpTyCon (PodizedPodTyCon d1 tc1) (PodizedPodTyCon d2 tc2)
- = case cmp_i d1 d2 of { EQ_ -> cmpTyCon tc1 tc2; other -> other }
-#endif {- Data Parallel Haskell -}
-
- -- now we *know* the tags are different, so...
-cmpTyCon other_1 other_2
- = let
- tag1 = tag_TyCon other_1
- tag2 = tag_TyCon other_2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
- where
- tag_TyCon (SynonymTyCon _ _ _ _ _ _) = (ILIT(1) :: FAST_INT)
- tag_TyCon (DataTyCon _ _ _ _ _ _ _)= ILIT(2)
- tag_TyCon (TupleTyCon _) = ILIT(3)
- tag_TyCon (PrimTyCon _ _ _ _) = ILIT(4)
- tag_TyCon (SpecTyCon _ _) = ILIT(5)
-#ifdef DPH
- tag_TyCon (ProcessorTyCon _) = ILIT(6)
- tag_TyCon (PodizedPodTyCon _ _) = ILIT(7)
-#endif {- Data Parallel Haskell -}
-
-cmp_i :: Int -> Int -> TAG_
-cmp_i a1 a2
- = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_
-\end{code}
-
-\begin{code}
-eqTyCon :: TyCon -> TyCon -> Bool
-
-eqTyCon a b = case cmpTyCon a b of { EQ_ -> True; _ -> False }
-
-instance Eq TyCon where
- a == b = case cmpTyCon a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpTyCon a b of { EQ_ -> False; _ -> True }
-
-instance Ord TyCon where
- a <= b = case cmpTyCon a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpTyCon a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpTyCon a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpTyCon a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
-#ifdef __GLASGOW_HASKELL__
- _tagCmp a b = case cmpTyCon a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-\end{code}
-
-\begin{code}
-instance NamedThing TyCon where
- getExportFlag (TupleTyCon _) = NotExported
-#ifdef DPH
- getExportFlag (ProcessorTyCon _) = NotExported
- getExportFlag (PodizedPodTyCon _ tc) = getExportFlag tc
-#endif {- Data Parallel Haskell -}
- getExportFlag other = getExportFlag (get_name other)
-
- isLocallyDefined (TupleTyCon _) = False
-#ifdef DPH
- isLocallyDefined (ProcessorTyCon _) = False
- isLocallyDefined (PodizedPodTyCon _ tc) = isLocallyDefined tc
-#endif {- Data Parallel Haskell -}
- isLocallyDefined other = isLocallyDefined (get_name other)
-
- getOrigName (TupleTyCon a) = (pRELUDE_BUILTIN, _PK_ ("Tuple" ++ (show a)))
- getOrigName (SpecTyCon tc tys) = let (m,n) = getOrigName tc in
- (m, n _APPEND_ specMaybeTysSuffix tys)
-#ifdef DPH
- getOrigName (ProcessorTyCon a) = ("PreludeBuiltin", "Processor" ++ (show a))
- getOrigName (PodizedPodTyCon d tc) = let (m,n) = getOrigName tc in
- (m,n++"Pod"++show d)
-#endif {- Data Parallel Haskell -}
- getOrigName other = getOrigName (get_name other)
-
- getOccurrenceName (TupleTyCon a) = _PK_ ("Tuple" ++ (show a))
- getOccurrenceName (SpecTyCon tc tys) = getOccurrenceName tc _APPEND_ specMaybeTysSuffix tys
-#ifdef DPH
- getOccurrenceName (ProcessorTyCon a) = "Processor" ++ (show a)
- getOccurrenceName (PodizedPodTyCon d tc) = getOccurrenceName tc ++
- "Pod" ++ show d
-#endif {- Data Parallel Haskell -}
- getOccurrenceName other = getOccurrenceName (get_name other)
-
- getInformingModules (TupleTyCon a) = panic "getInformingModule:TupleTyCon"
-#ifdef DPH
- getInformingModules (ProcessorTyCon a) = "Processor" ++ (show a)
- getInformingModules (PodizedPodTyCon d tc) = getInformingModule tc ++
- "Pod" ++ show d
-#endif {- Data Parallel Haskell -}
- getInformingModules other = getInformingModules (get_name other)
-
- getSrcLoc (TupleTyCon _) = mkBuiltinSrcLoc
-#ifdef DPH
- getSrcLoc (ProcessorTyCon _) = mkBuiltinSrcLoc
- getSrcLoc (PodizedPodTyCon _ tc) = getSrcLoc tc
-#endif {- Data Parallel Haskell -}
- getSrcLoc other = getSrcLoc (get_name other)
-
- getTheUnique other = panic "NamedThing.TyCon.getTheUnique"
-
- fromPreludeCore (TupleTyCon a) = True
-#ifdef DPH
- fromPreludeCore (ProcessorTyCon a) = True
- fromPreludeCore (PodizedPodTyCon _ tc) = fromPreludeCore tc
-#endif {- Data Parallel Haskell -}
- fromPreludeCore other = fromPreludeCore (get_name other)
-
- hasType = panic "NamedThing.TyCon.hasType"
- getType = panic "NamedThing.TyCon.getType"
-\end{code}
-
-Emphatically un-exported:
-\begin{code}
-get_name (SynonymTyCon _ n _ _ _ _) = n
-get_name (DataTyCon _ n _ _ _ _ _) = n
-get_name (PrimTyCon _ n _ _) = n
-get_name (SpecTyCon tc _) = get_name tc
-\end{code}
-
-And the usual output stuff:
-\begin{code}
-instance Outputable TyCon where
- ppr sty tycon = pprTyCon sty tycon [{-No Specialisations-}]
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TyVar]{Type variables}
-
-\begin{code}
-#include "HsVersions.h"
-
-module TyVar (
- TyVar(..), -- non-abstract for unifier's benefit
- TyVarTemplate,
-
- mkUserTyVar, mkPolySysTyVar, mkOpenSysTyVar,
---UNUSED: mkPrimSysTyVar, isPrimTyVar,
-
--- getTyVarUnique,
-
- cmpTyVar, eqTyVar, ltTyVar, -- used a lot!
-
- mkUserTyVarTemplate, mkSysTyVarTemplate, mkTemplateTyVars,
-
- cloneTyVarFromTemplate,
- cloneTyVar,
- instantiateTyVarTemplates,
-
- -- a supply of template tyvars
- alphaTyVars,
- alpha_tv, beta_tv, gamma_tv, delta_tv, epsilon_tv, -- templates
- alpha_tyvar, beta_tyvar, gamma_tyvar, delta_tyvar, epsilon_tyvar,-- real tyvars
-
- -- so the module is self-contained...
- ShortName
- ) where
-
-import NameTypes ( ShortName )
-import Outputable -- class for printing, forcing
-import Pretty -- pretty-printing utilities
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
-import Unique
-import UniType ( mkTyVarTy, TauType(..), InstTyEnv(..), UniType
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Util
-
-#ifndef __GLASGOW_HASKELL__
-{-hide import from mkdependHS-}
-import
- Word
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyVar-basics]{@TyVar@ type and basic operations}
-%* *
-%************************************************************************
-
-We distinguish system from user type variables so that the unifier can
-bias in terms of replacing system with user ones rather than vice
-versa.
-
-\begin{code}
-data TyVar
- = PrimSysTyVar -- Can only be unified with a primitive type
- Unique -- Cannot be generalised
- -- Introduced by ccalls
-
- | PolySysTyVar -- Can only be unified with a boxed type
- Unique -- Can be generalised
- -- Introduced when a polymorphic type is instantiated
-
- | OpenSysTyVar -- Can unify with any type at all
- Unique -- Can be generalised, but remember that the resulting
- -- polymorphic type will be instantiated with PolySysTyVars
- -- Introduced by lambda bindings
-
- | UserTyVar -- This is exactly like PolySysTyVar except that it
- Unique -- has a name attached, derived from something the user typed
- ShortName
-
--- **** NB: Unboxed but non-primitive things (which don't exist at all at present)
--- are not catered for by the above scheme.
-
-mkPolySysTyVar = PolySysTyVar
-mkUserTyVar = UserTyVar
-mkOpenSysTyVar = OpenSysTyVar
---UNUSED:mkPrimSysTyVar = PrimSysTyVar
-
-{-UNUSED
-isPrimTyVar (PrimSysTyVar _) = True
-isPrimTyVar other = False
--}
-
--- Make a tyvar from a template, given also a unique
-cloneTyVarFromTemplate :: TyVarTemplate -> Unique -> TyVar
-cloneTyVarFromTemplate (SysTyVarTemplate _ _) uniq = PolySysTyVar uniq
-cloneTyVarFromTemplate (UserTyVarTemplate _ n) uniq = UserTyVar uniq n
-
-instantiateTyVarTemplates
- :: [TyVarTemplate]
- -> [Unique]
- -> (InstTyEnv, -- Old-to-new assoc list
- [TyVar], -- New type vars
- [TauType]) -- New type vars wrapped in a UniTyVar
-instantiateTyVarTemplates tv_tmpls uniqs
- = --pprTrace "instTyVarTemplates:" (ppr PprDebug new_tys)
- (tv_tmpls `zipEqual` new_tys, new_tyvars, new_tys)
- where
- new_tyvars = zipWith cloneTyVarFromTemplate tv_tmpls uniqs
- new_tys = map mkTyVarTy new_tyvars
-
-getTyVarUnique :: TyVar -> Unique
-getTyVarUnique (PolySysTyVar u) = u
-getTyVarUnique (PrimSysTyVar u) = u
-getTyVarUnique (OpenSysTyVar u) = u
-getTyVarUnique (UserTyVar u _) = u
-\end{code}
-
-Make a new TyVar ``just like'' another one, but w/ a new @Unique@.
-Used when cloning big lambdas. his is only required after
-typechecking so the @TyVarUnique@ is just a normal @Unique@.
-
-\begin{code}
-cloneTyVar :: TyVar -> Unique -> TyVar
-
-cloneTyVar (PolySysTyVar _) uniq = PolySysTyVar uniq
-cloneTyVar (PrimSysTyVar _) uniq = PrimSysTyVar uniq
-cloneTyVar (OpenSysTyVar _) uniq = OpenSysTyVar uniq
-cloneTyVar (UserTyVar _ n) uniq = UserTyVar uniq n
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyVar-template]{The @TyVarTemplate@ type}
-%* *
-%************************************************************************
-
-A @TyVarTemplate@ is a type variable which is used by @UniForall@ to
-universally quantify a type. It only occurs in a {\em binding}
-position in a @UniForall@, not (for example) in a @TyLam@ or
-@AbsBinds@. Every occurrence of a @TyVarTemplate@ in a @UniType@ is
-bound by an enclosing @UniForall@, with the sole exception that the
-type in a @ClassOp@ has a free @TyVarTemplate@ which is the class type
-variable; it is found in the corresponding @Class@ object.
-
-\begin{code}
-data TyVarTemplate
- = SysTyVarTemplate Unique FAST_STRING
- | UserTyVarTemplate Unique ShortName
-
-mkSysTyVarTemplate = SysTyVarTemplate
-mkUserTyVarTemplate = UserTyVarTemplate
-
-getTyVarTemplateUnique (SysTyVarTemplate u _) = u
-getTyVarTemplateUnique (UserTyVarTemplate u _) = u
-\end{code}
-
-\begin{code}
-alpha_tv, beta_tv, gamma_tv, delta_tv, epsilon_tv :: TyVarTemplate
-alpha_tv = SysTyVarTemplate (mkBuiltinUnique 1) SLIT("a")
-beta_tv = SysTyVarTemplate (mkBuiltinUnique 2) SLIT("b")
-gamma_tv = SysTyVarTemplate (mkBuiltinUnique 3) SLIT("c")
-delta_tv = SysTyVarTemplate (mkBuiltinUnique 4) SLIT("d")
-epsilon_tv = SysTyVarTemplate (mkBuiltinUnique 5) SLIT("e")
-
-alpha_tyvar, beta_tyvar, gamma_tyvar, delta_tyvar, epsilon_tyvar :: TyVar
-alpha_tyvar = PolySysTyVar (mkBuiltinUnique 1)
-beta_tyvar = PolySysTyVar (mkBuiltinUnique 2)
-gamma_tyvar = PolySysTyVar (mkBuiltinUnique 3)
-delta_tyvar = PolySysTyVar (mkBuiltinUnique 4)
-epsilon_tyvar = PolySysTyVar (mkBuiltinUnique 5)
-
--- these are used in tuple magic (see TyCon.lhs and Id.lhs)
-alphaTyVars :: [TyVarTemplate]
-alphaTyVars = alphas_from (10::Int) tyVarStrings
- where
- alphas_from :: Int -> [FAST_STRING] -> [TyVarTemplate]
- alphas_from n (s:ss)
- = SysTyVarTemplate (mkBuiltinUnique n) s : (alphas_from (n+1) ss)
-
-tyVarStrings :: [FAST_STRING]
-tyVarStrings
- = letter_strs {- a..y -} ++ number_strs {- z0 ... zN -}
- where
- letter_strs = [ _PK_ [c] | c <- ['d' .. 'y'] ]
- number_strs = [ _PK_ ('z': show n) | n <- ([0 .. ] :: [Int]) ]
-\end{code}
-
-@mkTemplateTyVars@ creates new template type variables, giving them
-the same name and unique as the type variable given to it. (The name
-is for documentation purposes; the unique could just as well be
-fresh.)
-
-\begin{code}
-mkTemplateTyVars :: [TyVar] -> [TyVarTemplate]
-
-mkTemplateTyVars tyvars
- = zipWith mk_tmpl tyvars tyVarStrings
- where
- mk_tmpl (UserTyVar u name) str = UserTyVarTemplate u name
- mk_tmpl (PolySysTyVar u) str = SysTyVarTemplate u str
- mk_tmpl (OpenSysTyVar u) str = SysTyVarTemplate u str
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyVar-instances]{Instance declarations for @TyVar@}
-%* *
-%************************************************************************
-
-@TyVars@s are compared by comparing their @Unique@s. (Often!)
-\begin{code}
-cmpTyVar (PolySysTyVar u1) (PolySysTyVar u2) = u1 `cmpUnique` u2
-cmpTyVar (PrimSysTyVar u1) (PrimSysTyVar u2) = u1 `cmpUnique` u2
-cmpTyVar (OpenSysTyVar u1) (OpenSysTyVar u2) = u1 `cmpUnique` u2
-cmpTyVar (UserTyVar u1 _) (UserTyVar u2 _) = u1 `cmpUnique` u2
-cmpTyVar other_1 other_2
- = let tag1 = tag other_1
- tag2 = tag other_2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
- where
- tag (PolySysTyVar _) = (ILIT(1) :: FAST_INT)
- tag (PrimSysTyVar _) = ILIT(2)
- tag (OpenSysTyVar _) = ILIT(3)
- tag (UserTyVar _ _) = ILIT(4)
-\end{code}
-
-\begin{code}
-eqTyVar a b = case cmpTyVar a b of { EQ_ -> True; _ -> False }
-ltTyVar a b = case cmpTyVar a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
-
-instance Eq TyVar where
- a == b = case cmpTyVar a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpTyVar a b of { EQ_ -> False; _ -> True }
-
-instance Ord TyVar where
- a <= b = case cmpTyVar a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case cmpTyVar a b of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case cmpTyVar a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case cmpTyVar a b of { LT_ -> False; EQ_ -> False; GT__ -> True }
-#ifdef __GLASGOW_HASKELL__
- _tagCmp a b = case cmpTyVar a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-\end{code}
-(@Ord@ for @TyVars@ is needed for the @sortLt@ in @TcSimplify@.)
-
-\begin{code}
-instance NamedThing TyVar where
- getExportFlag tyvar = NotExported
- isLocallyDefined tyvar = True
-
- getOrigName (UserTyVar _ n) = (panic "NamedThing.TyVar.getOrigName(UserTyVar)",
- getLocalName n)
- getOrigName tyvar = (panic "NamedThing.TyVar.getOrigName(SysTyVar)",
- _PK_ ('t' : (_UNPK_ (showUnique (getTyVarUnique tyvar)))))
-
- getOccurrenceName (UserTyVar _ n) = getOccurrenceName n
- getOccurrenceName tyvar = _PK_ ('t' : (_UNPK_ (showUnique (getTyVarUnique tyvar))))
-
- getInformingModules tyvar = panic "getInformingModule:TyVar"
-
- getSrcLoc (UserTyVar _ n) = getSrcLoc n
- getSrcLoc _ = mkUnknownSrcLoc
-
- getTheUnique tyvar = getTyVarUnique tyvar
-
- fromPreludeCore _ = False
-\end{code}
-
-\begin{code}
-instance Outputable TyVar where
- ppr sty (PolySysTyVar u) = ppr_tyvar sty (ppChar 't') u
- ppr sty (PrimSysTyVar u) = ppr_tyvar sty (ppChar 'p') u
- ppr sty (OpenSysTyVar u) = ppr_tyvar sty (ppChar 'o') u
- ppr sty (UserTyVar u name) = ppr_tyvar sty (ppr sty name) u
-
-ppr_tyvar sty name u
- = case sty of
- --OLD: PprForUser -> name
- PprDebug -> pprUnique10 u
- PprUnfolding _ -> pprUnique10 u
- _ -> ppBesides [name, ppChar '.', pprUnique10 u]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TyVarTemplate-instances]{Instance declarations for @TyVarTemplates@}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Eq TyVarTemplate where
- a == b = getTyVarTemplateUnique a == getTyVarTemplateUnique b
- a /= b = getTyVarTemplateUnique a /= getTyVarTemplateUnique b
-\end{code}
-
-\begin{code}
-instance Ord TyVarTemplate where
- a <= b = getTyVarTemplateUnique a <= getTyVarTemplateUnique b
- a < b = getTyVarTemplateUnique a < getTyVarTemplateUnique b
- a >= b = getTyVarTemplateUnique a >= getTyVarTemplateUnique b
- a > b = getTyVarTemplateUnique a > getTyVarTemplateUnique b
-#ifdef __GLASGOW_HASKELL__
- _tagCmp a b = case cmpUnique (getTyVarTemplateUnique a) (getTyVarTemplateUnique b)
- of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT }
-#endif
-\end{code}
-
-\begin{code}
-instance NamedThing TyVarTemplate where
- getExportFlag tyvar = NotExported
- isLocallyDefined tyvar = True
-
- getOrigName (UserTyVarTemplate _ n) = (panic "NamedThing.TyVar.getOrigName(UserTyVarTemplate)",
- getLocalName n)
- getOrigName tyvar = (panic "NamedThing.TyVar.getOrigName(SysTyVarTemplate)",
- _PK_ ('t' : (_UNPK_ (showUnique (getTyVarTemplateUnique tyvar)))))
-
- getOccurrenceName (UserTyVarTemplate _ n) = getOccurrenceName n
- getOccurrenceName tyvar = _PK_ ('t' : (_UNPK_ (showUnique (getTyVarTemplateUnique tyvar))))
-
- getInformingModules tyvar = panic "getInformingModule:TyVarTemplate"
-
- getSrcLoc (UserTyVarTemplate _ n) = getSrcLoc n
- getSrcLoc _ = mkUnknownSrcLoc
-
- getTheUnique tyvar = getTyVarTemplateUnique tyvar
-
- fromPreludeCore _ = False
-\end{code}
-
-\begin{code}
-instance Outputable TyVarTemplate where
- ppr sty (SysTyVarTemplate u name)
- = case sty of
---OLD: PprForUser -> ppPStr name
- _ -> ppBesides [ppPStr name, ppChar '$', pprUnique10 u]
-
- ppr sty (UserTyVarTemplate u name)
- = case sty of
---OLD: PprForUser -> ppr sty name
- _ -> ppBesides [ppr sty name, ppChar '$', pprUnique10 u]
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[UniTyFuns]{Utility functions for @UniTypes@}
-
-This is one of the modules whose functions know about the internal
-representation of @UniTypes@ (and @TyCons@ and ... ?).
-
-\begin{code}
-#include "HsVersions.h"
-
-module UniTyFuns (
-
- -- CONSTRUCTION
- applyTy, applyTyCon, applySynTyCon, applyNonSynTyCon,
- {-mkSigmaTy,-} glueTyArgs, mkSuperDictSelType, --UNUSED: mkDictFunType,
- specialiseTy,
-
- -- DESTRUCTION
---not exported: expandTySyns,
- expandVisibleTySyn,
- getTyVar, getTyVarMaybe, getTyVarTemplateMaybe,
- splitType, splitForalls, getTauType, splitTyArgs,
- splitTypeWithDictsAsArgs,
---not exported/unused: sourceTypes, targetType,
- funResultTy,
- splitDictType,
- kindFromType,
- getUniDataTyCon, getUniDataTyCon_maybe,
- getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
- unDictifyTy,
- getMentionedTyCons,
-#ifdef USE_SEMANTIQUE_STRANAL
- getReferredToTyCons,
-#endif {- Semantique strictness analyser -}
- getMentionedTyConsAndClassesFromUniType,
- getMentionedTyConsAndClassesFromTyCon,
- getMentionedTyConsAndClassesFromClass,
- getUniTyDescription,
-
- -- FREE-VARIABLE EXTRACTION
- extractTyVarsFromTy, extractTyVarsFromTys,
- extractTyVarTemplatesFromTy,
-
- -- PREDICATES
- isTyVarTy, isTyVarTemplateTy,
- maybeUnpackFunTy, isFunType,
- isPrimType, isUnboxedDataType, -- UNUSED: isDataConType,
- isLeakFreeType,
- maybeBoxedPrimType,
---UNUSED: hasHigherOrderArg,
- isDictTy, isGroundTy, isGroundOrTyVarTy,
- instanceIsExported,
--- UNUSED: isSynTarget,
- isTauTy, isForAllTy,
- maybePurelyLocalTyCon, maybePurelyLocalClass, maybePurelyLocalType,
- returnsRealWorld, -- HACK courtesy of SLPJ
-#ifdef DPH
- isProcessorTy,
- runtimeUnpodizableType,
-#endif {- Data Parallel Haskell -}
-
- -- SUBSTITUTION
- applyTypeEnvToTy, applyTypeEnvToThetaTy,
---not exported : applyTypeEnvToTauTy,
- mapOverTyVars,
- -- moved to Subst: applySubstToTauTy, applySubstToTy, applySubstToThetaTy,
- -- genInstantiateTyUS, -- ToDo: ???
-
- -- PRETTY PRINTING AND FORCING
- pprUniType, pprParendUniType, pprMaybeTy,
- pprTyCon, pprIfaceClass, pprClassOp,
- getTypeString,
- typeMaybeString,
- specMaybeTysSuffix,
- showTyCon,
- showTypeCategory,
-
- -- MATCHING and COMPARISON
- matchTy, -- UNUSED: matchTys,
- cmpUniTypeMaybeList,
-
- -- to make this interface self-sufficient....
- TyVar, TyVarTemplate, TyCon, Class, UniType, UniqueSupply,
- IdEnv(..), UniqFM, UnfoldingDetails, PrimKind, TyVarEnv(..),
- TypeEnv(..), Maybe, PprStyle, PrettyRep, Bag
- ) where
-
-IMPORT_Trace -- ToDo:rm (debugging)
-
--- internal modules; allowed to see constructors for type things
-import Class
-import TyVar
-import TyCon
-import UniType
-
-import AbsPrel ( listTyCon, integerTyCon, charPrimTyCon,
- intPrimTyCon, wordPrimTyCon, addrPrimTyCon,
- floatPrimTyCon, doublePrimTyCon,
- realWorldTyCon
-#ifdef DPH
- , podTyCon
-#endif {- Data Parallel Haskell -}
- )
-import Bag
-import CLabelInfo ( identToC )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( Id, getIdInfo,
- getMentionedTyConsAndClassesFromId,
- getInstantiatedDataConSig,
- getDataConSig, mkSameSpecCon,
- DataCon(..)
- )
-import IdEnv -- ( lookupIdEnv, IdEnv )
-import IdInfo ( ppIdInfo, boringIdInfo, IdInfo, UnfoldingDetails )
-import InstEnv ( ClassInstEnv(..), MatchEnv(..) )
-import ListSetOps ( unionLists )
-import NameTypes ( FullName )
-import Maybes
-import Outputable
-import Pretty
-import PrimKind ( PrimKind(..) )
-import SpecTyFuns ( specialiseConstrTys )
-import TyVarEnv
-import Unique -- used UniqueSupply monadery
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniTyFuns-construction]{Putting types together}
-%* *
-%************************************************************************
-
-\begin{code}
-applyTy :: SigmaType -> SigmaType -> SigmaType
-
-applyTy (UniSyn _ _ fun_ty) arg_ty = applyTy fun_ty arg_ty
-applyTy fun_ty@(UniForall tyvar ty) arg_ty
- = instantiateTy [(tyvar,arg_ty)] ty
-#ifdef DEBUG
-applyTy bad_fun_ty arg_ty
- = pprPanic "applyTy: not a forall type:" (ppAbove (ppr PprDebug bad_fun_ty) (ppr PprDebug arg_ty))
-#endif
-\end{code}
-
-@applyTyCon@ applies a type constructor to a list of tau-types to give
-a type. @applySynTyCon@ and @applyNonSynTyCon@ are similar, but they
-``know'' what sort the type constructor is, so they are a bit lazier.
-This is important in @TcMonoType.lhs@.
-
-\begin{code}
-applyTyCon, applySynTyCon, applyNonSynTyCon :: TyCon -> [TauType] -> TauType
-
-applyTyCon tc tys
- = ASSERT (if (getTyConArity tc == length tys) then True else pprTrace "applyTyCon" (ppCat [ppr PprDebug tc, ppr PprDebug tys]) False)
- --false:ASSERT (all isTauTy tys) TauType?? 94/06
- let
- result = apply_tycon tc tys
- in
- --false:ASSERT (isTauTy result) TauType?? 94/06
- result
- where
- apply_tycon tc@(SynonymTyCon _ _ _ _ _ _) tys = applySynTyCon tc tys
- apply_tycon tc@(DataTyCon _ _ _ _ _ _ _) tys = applyNonSynTyCon tc tys
-
- apply_tycon tc@(PrimTyCon _ _ _ _) tys = UniData tc tys
-
- apply_tycon tc@(TupleTyCon _) tys = UniData tc tys
- -- The arg types here aren't necessarily tau-types, because we
- -- may have polymorphic methods in a dictionary.
-
- -- Original tycon used in type of SpecTyCon
- apply_tycon tc_spec@(SpecTyCon tc spec_tys) tys
- = apply_tycon tc (fill_nothings spec_tys tys)
- where
- fill_nothings (Just ty:maybes) fills = ty : fill_nothings maybes fills
- fill_nothings (Nothing:maybes) (ty:fills) = ty : fill_nothings maybes fills
- fill_nothings [] [] = []
-
-#ifdef DPH
- apply_tycon tc@(ProcessorTyCon _) tys = UniData tc tys
-#endif {- Data Parallel Haskell -}
-
-
------------------
-
-applySynTyCon tycon tys
- = UniSyn tycon ok_tys (instantiateTauTy (tyvars `zip` ok_tys) template)
- -- Memo the result of substituting for the tyvars in the template
- where
- SynonymTyCon _ _ _ tyvars template _ = tycon
- -- NB: Matched lazily
-
-#ifdef DEBUG
- ok_tys = map (verifyTauTy "applyTyConLazily[syn]") tys
-#else
- ok_tys = tys
-#endif
-
------------------
-
-applyNonSynTyCon tycon tys -- We don't expect function tycons;
- -- but it must be lazy, so we can't check that here!
-#ifdef DEBUG
- = UniData tycon (map (verifyTauTy "applyTyConLazily[data]") tys)
-#else
- = UniData tycon tys
-#endif
-\end{code}
-
-@glueTyArgs [ty1,...,tyn] ty@ returns the type
-@ty1 -> ... -> tyn -> ty@. This is the exact reverse of @splitTyArgs@.
-
-\begin{code}
--- ToDo: DEBUG: say what's true about these types
-glueTyArgs :: [UniType] -> UniType -> UniType
-
-glueTyArgs tys ty = foldr UniFun ty tys
-\end{code}
-
-\begin{code}
-mkSuperDictSelType :: Class -- The input class
- -> Class -- The superclass
- -> UniType -- The type of the selector function
-
-mkSuperDictSelType clas@(MkClass _ _ tyvar _ _ _ _ _ _ _) super
- = UniForall tyvar (UniFun (UniDict clas (UniTyVarTemplate tyvar))
- (UniDict super (UniTyVarTemplate tyvar)))
-\end{code}
-
-UNUSED: @mkDictFunType@ creates the type of a dictionary function, given:
-the polymorphic type variables, the types of the dict args, the class and
-tautype of the result.
-
-\begin{code}
-{- UNUSED:
-mkDictFunType :: [TyVarTemplate] -> ThetaType -> Class -> TauType -> UniType
-
-mkDictFunType tyvars theta clas tau_ty
-#ifndef DEBUG
- = mkForallTy tyvars (foldr f (UniDict clas tau_ty) theta)
-#else
- = mkForallTy tyvars (foldr f (UniDict clas (verifyTauTy "mkDictFunType" tau_ty)) theta)
-#endif
- where
- f (clas,tau_ty) sofar = UniFun (UniDict clas tau_ty) sofar
--}
-\end{code}
-
-\begin{code}
-specialiseTy :: UniType -- The type of the Id of which the SpecId
- -- is a specialised version
- -> [Maybe UniType] -- The types at which it is specialised
- -> Int -- Number of leading dictionary args to ignore
- -> UniType
-
-specialiseTy main_ty maybe_tys dicts_to_ignore
- = --false:ASSERT(isTauTy tau) TauType??
- mkSigmaTy remaining_tyvars
- (instantiateThetaTy inst_env remaining_theta)
- (instantiateTauTy inst_env tau)
- where
- (tyvars, theta, tau) = splitType main_ty -- A prefix of, but usually all,
- -- the theta is discarded!
- remaining_theta = drop dicts_to_ignore theta
- tyvars_and_maybe_tys = tyvars `zip` maybe_tys
- remaining_tyvars = [tyvar | (tyvar, Nothing) <- tyvars_and_maybe_tys]
- inst_env = [(tyvar,ty) | (tyvar, Just ty) <- tyvars_and_maybe_tys]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniTyFuns-destruction]{Taking types apart}
-%* *
-%************************************************************************
-
-@expandVisibleTySyn@ removes any visible type-synonym from the top level of a
-@TauType@. Note that the expansion is recursive.
-
-@expandTySyns@ removes all type-synonyms from a @TauType@.
-
-\begin{code}
-expandVisibleTySyn, expandTySyns :: TauType -> TauType
-
-expandVisibleTySyn (UniSyn con _ tau)
- | isVisibleSynTyCon con
- = ASSERT(isTauTy tau)
- expandVisibleTySyn tau
-expandVisibleTySyn tau
- = ASSERT(isTauTy tau)
- tau
-
-expandTySyns (UniSyn _ _ tau) = expandTySyns tau
-expandTySyns (UniFun a b) = UniFun (expandTySyns a) (expandTySyns b)
-expandTySyns (UniData c tys) = UniData c (map expandTySyns tys)
-expandTySyns tau = -- FALSE:WDP 95/03: ASSERT(isTauTy tau)
- tau
-\end{code}
-
-@getTyVar@ extracts a type variable from a @UniType@ if the latter is
-just a type variable, failing otherwise. @getTyVarMaybe@ is similar,
-except that it returns a @Maybe@ type.
-
-\begin{code}
-getTyVar :: String -> UniType -> TyVar
-getTyVar panic_msg (UniTyVar tyvar) = tyvar
-getTyVar panic_msg other = panic ("getTyVar: " ++ panic_msg)
-
-getTyVarMaybe :: UniType -> Maybe TyVar
-getTyVarMaybe (UniTyVar tyvar) = Just tyvar
-getTyVarMaybe (UniSyn _ _ exp) = getTyVarMaybe exp
-getTyVarMaybe other = Nothing
-
-getTyVarTemplateMaybe :: UniType -> Maybe TyVarTemplate
-getTyVarTemplateMaybe (UniTyVarTemplate tyvar) = Just tyvar
-getTyVarTemplateMaybe (UniSyn _ _ exp) = getTyVarTemplateMaybe exp
-getTyVarTemplateMaybe other = Nothing
-\end{code}
-
-@splitType@ splits a type into three components. The first is the
-bound type variables, the second is the context and the third is the
-tau type. I'll produce specific functions which access particular pieces
-of the type when we see where they are needed.
-
-\begin{code}
-splitType :: UniType -> ([TyVarTemplate], ThetaType, TauType)
-splitType uni_ty
- = case (split_foralls uni_ty) of { (tyvars, rho_ty) ->
- case (split_rho_ty rho_ty) of { (theta_ty, tau_ty) ->
- --false:ASSERT(isTauTy tau_ty) TauType
- (tyvars, theta_ty, tau_ty)
- }}
- where
- split_foralls (UniForall tyvar uni_ty)
- = case (split_foralls uni_ty) of { (tyvars,new_ty) ->
- (tyvar:tyvars, new_ty) }
-
- split_foralls other_ty = ([], other_ty)
-
- split_rho_ty (UniFun (UniDict clas ty) ty_body)
- = case (split_rho_ty ty_body) of { (context,ty_body') ->
- ((clas, ty) :context, ty_body') }
-
- split_rho_ty other_ty = ([], other_ty)
-\end{code}
-
-Sometimes we want the dictionaries counted as arguments. We guarantee
-to return {\em some} arguments if there are any, but not necessarily
-{\em all}. In particular, the ``result type'' might be a @UniDict@,
-which might (in the case of a single-classop class) be a function. In
-that case, we strongly avoid returning a @UniDict@ ``in the corner''
-(by @unDictify@ing that type, too).
-
-This seems like a bit of a fudge, frankly, but it does the job.
-
-\begin{code}
-splitTypeWithDictsAsArgs
- :: UniType -- input
- -> ([TyVarTemplate],
- [UniType], -- arg types
- TauType) -- result type
-
-splitTypeWithDictsAsArgs ty
- = case (splitType ty) of { (tvs, theta, tau_ty) ->
- case (splitTyArgs tau_ty) of { (tau_arg_tys, res_ty) ->
- let
- result extra_arg_tys res_ty
- = --false: ASSERT(isTauTy res_ty) TauType
- (tvs,
- [ mkDictTy c t | (c,t) <- theta ] ++ tau_arg_tys ++ extra_arg_tys,
- res_ty)
- in
- if not (isDictTy res_ty) then
- result [] res_ty
- else
- let
- undicted_res_ty = unDictifyTy res_ty
- (tau_arg_tys', res_ty') = splitTyArgs undicted_res_ty
- in
- if (null theta && null tau_arg_tys)
- || isFunType undicted_res_ty then
-
- -- (a) The input ty was just a "dictionary" for a
- -- single-method class with no super-dicts; the
- -- "dictionary" is just the one method itself; we'd really
- -- rather give info about that method...
-
- -- (b) The input ty gave back a "dictionary" for a
- -- single-method class; if the method itself is a
- -- function, then we'd jolly well better add its arguments
- -- onto the whole "arg_tys" list.
-
- -- There may be excessive paranoia going on here (WDP).
-
- result tau_arg_tys' res_ty'
-
- else -- do nothing special...
- result [] res_ty
- }}
-\end{code}
-
-@splitForalls@ is similar, but only splits off the forall'd type
-variables.
-
-\begin{code}
-splitForalls :: UniType -> ([TyVarTemplate], RhoType)
-
-splitForalls (UniForall tyvar ty)
- = case (splitForalls ty) of
- (tyvars, new_ty) -> (tyvar:tyvars, new_ty)
-splitForalls (UniSyn _ _ ty) = splitForalls ty
-splitForalls other_ty = ([], other_ty)
-\end{code}
-
-And a terribly convenient way to access @splitType@:
-
-\begin{code}
-getTauType :: UniType -> TauType
-getTauType uni_ty
- = case (splitType uni_ty) of { (_,_,tau_ty) ->
- --false:ASSERT(isTauTy tau_ty) TauType??? (triggered in ProfMassage)
- tau_ty }
-\end{code}
-
-@splitTyArgs@ does the same for the arguments of a function type.
-
-\begin{code}
-splitTyArgs :: TauType -> ([TauType], TauType)
-
-splitTyArgs ty
- = --false: ASSERT(isTauTy ty) TauType???
- split ty
- where
- split (UniSyn _ _ expand) = split expand
-
- split (UniFun arg result)
- = case (split result) of { (args, result') ->
- (arg:args, result') }
-
- split ty = ([], ty)
-
-funResultTy :: RhoType -- Function type
- -> Int -- Number of args to which applied
- -> RhoType -- Result type
-
-funResultTy ty 0 = ty
-funResultTy (UniSyn _ _ expand) n_args = funResultTy expand n_args
-funResultTy ty@(UniDict _ _) n_args = funResultTy (unDictifyTy ty) n_args
-funResultTy (UniFun _ result_ty) n_args = funResultTy result_ty (n_args - 1)
-#ifdef DEBUG
-funResultTy other_ty n_args = panic ("funResultTy:not a fun:"++(ppShow 80 (ppr PprDebug other_ty)))
-#endif
-\end{code}
-
-The type-destructor functions above return dictionary information in
-terms of @UniDict@, a relatively abstract construct. What really
-happens ``under the hood'' is that {\em tuples} (usually) are passed
-around as ordinary arguments. Sometimes we want this ``what's really
-happening'' information.
-
-The interesting case for @getUniDataTyCon_maybe@ is if the argument is
-a dictionary type. Dictionaries are represented by tuples (except for
-size-one dictionaries which are represented by the method itself), so
-@getUniDataTyCon_maybe@ has to figure out which tuple. This is a bit
-unsatisfactory; the information about how dictionaries are represented
-is rather thinly distributed.
-
-@unDictify@ only removes a {\em top-level} @UniDict@. There may be
-buried @UniDicts@ in what is returned.
-
-\begin{code}
-unDictifyTy :: UniType -- Might be a UniDict
- -> UniType -- Can't be a UniDict
-
-unDictifyTy (UniSyn _ _ expansion) = unDictifyTy expansion
-
-unDictifyTy (UniDict clas ty)
- = ASSERT(dict_size >= 0)
- if dict_size == 1 then
- unDictifyTy (head all_arg_tys) -- just the <whatever> itself
- -- The extra unDictify is to make sure that
- -- the result isn't still a dict, which it might be
- -- if the original guy was a dict with one superdict and
- -- no methods!
- else
- UniData (mkTupleTyCon dict_size) all_arg_tys -- a tuple of 'em
- -- NB: dict_size can be 0 if the class is
- -- _CCallable, _CReturnable (and anything else
- -- *really weird* that the user writes).
- where
- (tyvar, super_classes, ops) = getClassSig clas
- dict_size = length super_classes + length ops
-
- super_dict_tys = map mk_super_ty super_classes
- class_op_tys = map mk_op_ty ops
-
- all_arg_tys = super_dict_tys ++ class_op_tys
-
- mk_super_ty sc = mkDictTy sc ty
- mk_op_ty op = instantiateTy [(tyvar,ty)] (getClassOpLocalType op)
-
-unDictifyTy other_ty = other_ty
-\end{code}
-
-\begin{code}
-{- UNUSED:
-sourceTypes :: TauType -> [TauType]
-sourceTypes ty
- = --false:ASSERT(isTauTy ty)
- (fst . splitTyArgs) ty
-
-targetType :: TauType -> TauType
-targetType ty
- = --false: ASSERT(isTauTy ty) TauType??
- (snd . splitTyArgs) ty
--}
-\end{code}
-
-Here is a function that tell you if a type has as its target a Synonym.
-If so it returns the relevant constructor and its argument type.
-
-\begin{code}
-{- UNUSED:
-isSynTarget :: UniType -> Maybe (TyCon,Int)
-
-isSynTarget (UniFun _ arg) = case isSynTarget arg of
- Just (tycon,x) -> Just (tycon,x + 1)
- Nothing -> Nothing
-isSynTarget (UniSyn tycon _ _) = Just (tycon,0)
-isSynTarget (UniForall _ e) = isSynTarget e
-isSynTarget _ = Nothing
---isSynTarget (UniTyVarTemplate e) = panic "isSynTarget: got a UniTyVarTemplate!"
--}
-\end{code}
-
-\begin{code}
-splitDictType :: UniType -> (Class, UniType)
-splitDictType (UniDict clas ty) = (clas, ty)
-splitDictType (UniSyn _ _ ty) = splitDictType ty
-splitDictType other = panic "splitDictTy"
-\end{code}
-
-In @kindFromType@ it can happen that we come across a @TyVarTemplate@,
-for example when figuring out the kinds of the argument of a data
-constructor; inside the @DataCon@ the argument types are in template form.
-
-\begin{code}
-kindFromType :: UniType -> PrimKind
-kindFromType (UniSyn tycon tys expand) = kindFromType expand
-kindFromType (UniData tycon tys) = getTyConKind tycon (map kindFromType tys)
-kindFromType other = PtrKind -- the "default"
-
-isPrimType :: UniType -> Bool
-
-isPrimType (UniSyn tycon tys expand) = isPrimType expand
-#ifdef DPH
-isPrimType (UniData tycon tys) | isPodizedPodTyCon tycon
- = all isPrimType tys
-#endif {- Data Parallel Haskell}
-isPrimType (UniData tycon tys) = isPrimTyCon tycon
-isPrimType other = False -- the "default"
-
-maybeBoxedPrimType :: UniType -> Maybe (Id{-DataCon-}, UniType)
-
-maybeBoxedPrimType ty
- = case (getUniDataTyCon_maybe ty) of -- Data type,
- Just (tycon, tys_applied, [data_con]) -- with exactly one constructor
- -> case (getInstantiatedDataConSig data_con tys_applied) of
- (_, [data_con_arg_ty], _) -- Applied to exactly one type,
- | isPrimType data_con_arg_ty -- which is primitive
- -> Just (data_con, data_con_arg_ty)
- other_cases -> Nothing
- other_cases -> Nothing
-\end{code}
-
-At present there are no unboxed non-primitive types, so
-isUnboxedDataType is the same as isPrimType.
-
-\begin{code}
-isUnboxedDataType :: UniType -> Bool
-
-isUnboxedDataType (UniSyn _ _ expand) = isUnboxedDataType expand
-isUnboxedDataType (UniData tycon _) = not (isBoxedTyCon tycon)
-isUnboxedDataType other = False
-\end{code}
-
-If you want to run @getUniDataTyCon...@ or @UniDataArgTys@ over a
-dictionary-full type, then put the type through @unDictifyTy@ first.
-
-\begin{code}
-getUniDataTyCon_maybe
- :: TauType
- -> Maybe (TyCon, -- the type constructor
- [TauType], -- types to which it is applied
- [Id]) -- its family of data-constructors
-
-getUniDataTyCon_maybe ty
- = --false:ASSERT(isTauTy ty) TauType?
- get ty
- where
- get (UniSyn _ _ expand) = get expand
- get ty@(UniDict _ _) = get (unDictifyTy ty)
-
- get (UniData tycon arg_tys)
- = Just (tycon, arg_tys, getTyConDataCons tycon)
- -- does not returned specialised data constructors
-
- get other_ty = Nothing
-\end{code}
-
-@getUniDataTyCon@ is just a version which fails noisily.
-\begin{code}
-getUniDataTyCon ty
- = case getUniDataTyCon_maybe ty of
- Just stuff -> stuff
-#ifdef DEBUG
- Nothing -> pprPanic "getUniDataTyCon:" (ppr PprShowAll ty)
-#endif
-\end{code}
-
-@getUniDataSpecTyCon_maybe@ returns an appropriate specialised tycon,
-any remaining (boxed) type arguments, and specialsied constructors.
-\begin{code}
-getUniDataSpecTyCon_maybe
- :: TauType
- -> Maybe (TyCon, -- the type constructor
- [TauType], -- types to which it is applied
- [Id]) -- its family of data-constructors
-
-getUniDataSpecTyCon_maybe ty
- = case getUniDataTyCon_maybe ty of
- Nothing -> Nothing
- Just unspec@(tycon, tycon_arg_tys, datacons) ->
- let spec_tys = specialiseConstrTys tycon_arg_tys
- spec_reqd = maybeToBool (firstJust spec_tys)
-
- data_cons = getTyConDataCons tycon
- spec_datacons = map (mkSameSpecCon spec_tys) data_cons
- spec_tycon = mkSpecTyCon tycon spec_tys
-
- tys_left = [ty | (spec, ty) <- spec_tys `zip` tycon_arg_tys,
- not (maybeToBool spec) ]
- in
- if spec_reqd
- then Just (spec_tycon, tys_left, spec_datacons)
- else Just unspec
-\end{code}
-
-@getUniDataSpecTyCon@ is just a version which fails noisily.
-\begin{code}
-getUniDataSpecTyCon ty
- = case getUniDataSpecTyCon_maybe ty of
- Just stuff -> stuff
- Nothing -> panic ("getUniDataSpecTyCon:"++ (ppShow 80 (ppr PprShowAll ty)))
-\end{code}
-
-@getMentionedTyCons@ maps a type constructor to a list of type
-constructors. If the type constructor is built-in or a @data@ type
-constructor, the list is empty. In the case of synonyms, list
-contains all the type {\em synonym} constructors {\em directly}
-mentioned in the definition of the synonym.
-\begin{code}
-getMentionedTyCons :: TyCon -> [TyCon]
-
-getMentionedTyCons (SynonymTyCon _ _ _ _ expansion _) = get_ty_cons expansion
- where
- get_ty_cons (UniTyVar _) = []
- get_ty_cons (UniTyVarTemplate _)= []
- get_ty_cons (UniData _ tys) = concat (map get_ty_cons tys)
- get_ty_cons (UniFun ty1 ty2) = get_ty_cons ty1 ++ get_ty_cons ty2
- get_ty_cons (UniSyn tycon _ _) = [tycon]
- get_ty_cons _ = panic "get_ty_cons: unexpected UniType"
-
-getMentionedTyCons other_tycon = []
-\end{code}
-
-Here's a similar thing used in the Semantique strictness analyser:
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-getReferredToTyCons :: TauType -> [TyCon]
-getReferredToTyCons (UniTyVar v) = []
-getReferredToTyCons (UniTyVarTemplate v) = []
-getReferredToTyCons (UniData t ts) = t : concat (map getReferredToTyCons ts)
-getReferredToTyCons (UniFun s t) = getReferredToTyCons s ++ getReferredToTyCons t
-getReferredToTyCons (UniSyn _ _ t) = getReferredToTyCons (getTauType t)
-getReferredToTyCons other = panic "getReferredToTyCons: not TauType"
-#endif {- Semantique strictness analyser -}
-\end{code}
-
-This @getMentioned*@ code is for doing interfaces. Tricky point: we
-{\em always} expand synonyms in interfaces, so note the handling of
-@UniSyns@.
-\begin{code}
-getMentionedTyConsAndClassesFromUniType :: UniType -> (Bag TyCon, Bag Class)
-
-getMentionedTyConsAndClassesFromUniType (UniTyVar _) = (emptyBag, emptyBag)
-getMentionedTyConsAndClassesFromUniType (UniTyVarTemplate _) = (emptyBag, emptyBag)
-
-getMentionedTyConsAndClassesFromUniType (UniData tycon arg_tys)
- = foldr do_arg_ty (unitBag tycon, emptyBag) arg_tys
- where
- do_arg_ty ty (ts_sofar, cs_sofar)
- = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
- (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) }
-
-getMentionedTyConsAndClassesFromUniType (UniFun ty1 ty2)
- = case (getMentionedTyConsAndClassesFromUniType ty1) of { (ts1, cs1) ->
- case (getMentionedTyConsAndClassesFromUniType ty2) of { (ts2, cs2) ->
- (ts1 `unionBags` ts2, cs1 `unionBags` cs2) }}
-
-getMentionedTyConsAndClassesFromUniType (UniSyn tycon _ expansion)
- = getMentionedTyConsAndClassesFromUniType expansion
- -- if synonyms were not expanded: (unitBag tycon, emptyBag)
-
-getMentionedTyConsAndClassesFromUniType (UniDict clas ty)
- = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
- (ts, cs `snocBag` clas) }
-
-getMentionedTyConsAndClassesFromUniType (UniForall _ ty)
- = getMentionedTyConsAndClassesFromUniType ty
-\end{code}
-
-This code could go in @TyCon@, but it's better to keep all the
-``getMentioning'' together.
-\begin{code}
-getMentionedTyConsAndClassesFromTyCon :: TyCon -> (Bag TyCon, Bag Class)
-
-getMentionedTyConsAndClassesFromTyCon tycon@(SynonymTyCon _ _ _ _ ty _)
- = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
- (ts `snocBag` tycon, cs) }
-
-getMentionedTyConsAndClassesFromTyCon tycon@(DataTyCon _ _ _ _ constructors _ _)
- = foldr do_con (unitBag tycon, emptyBag) constructors
- -- We don't worry whether this TyCon is exported abstractly
- -- or not, because even if so, the pragmas probably need
- -- to know this info.
- where
- do_con con (ts_sofar, cs_sofar)
- = case (getMentionedTyConsAndClassesFromId con) of { (ts, cs) ->
- (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) }
-
-getMentionedTyConsAndClassesFromTyCon other
- = panic "tried to get mentioned tycons and classes from funny tycon"
-\end{code}
-
-\begin{code}
-getMentionedTyConsAndClassesFromClass :: Class -> (Bag TyCon, Bag Class)
-
-getMentionedTyConsAndClassesFromClass clas@(MkClass _ _ _ super_classes _ ops _ _ _ _)
- = foldr do_op
- (emptyBag, unitBag clas `unionBags` listToBag super_classes)
- ops
- where
- do_op (MkClassOp _ _ ty) (ts_sofar, cs_sofar)
- = case (getMentionedTyConsAndClassesFromUniType ty) of { (ts, cs) ->
- (ts `unionBags` ts_sofar, cs `unionBags` cs_sofar) }
-\end{code}
-
-Grab a name for the type. This is used to determine the type
-description for profiling.
-\begin{code}
-getUniTyDescription :: UniType -> String
-getUniTyDescription ty
- = case (getTauType ty) of
- UniFun arg res -> '-' : '>' : fun_result res
- UniData tycon _ -> _UNPK_ (getOccurrenceName tycon)
- UniSyn tycon _ _ -> _UNPK_ (getOccurrenceName tycon)
- UniDict cls uni -> "dict" -- Or from unitype ?
- UniTyVar _ -> "*" -- Distinguish ?
- UniTyVarTemplate _-> "*"
- _ -> panic "getUniTyName: other"
-
- where
- fun_result (UniFun _ res) = '>' : fun_result res
- fun_result other = getUniTyDescription other
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniTyFuns-fvs]{Extracting free type variables}
-%* *
-%************************************************************************
-
-@extractTyVarsFromTy@ gets the free type variables from a @UniType@.
-The list returned has no duplicates.
-
-\begin{code}
-extractTyVarsFromTys :: [UniType] -> [TyVar]
-extractTyVarsFromTys = foldr (unionLists . extractTyVarsFromTy) []
-
-extractTyVarsFromTy :: UniType -> [TyVar]
-extractTyVarsFromTy ty
- = get ty []
- where
- -- weird arg order so we can foldr easily
- get (UniTyVar tyvar) free
- | tyvar `is_elem` free = free
- | otherwise = tyvar:free
- get (UniTyVarTemplate _) free = free
- get (UniFun ty1 ty2) free = get ty1 (get ty2 free)
- get (UniData tycon tys) free = foldr get free tys
- get (UniSyn tycon tys ty) free = foldr get free tys
- get (UniDict clas ty) free = get ty free
- get (UniForall tyvar ty) free = get ty free
-
- is_elem = isIn "extractTyVarsFromTy"
-\end{code}
-
-\begin{code}
-extractTyVarTemplatesFromTy :: UniType -> [TyVarTemplate]
-extractTyVarTemplatesFromTy ty
- = get ty []
- where
- get (UniTyVarTemplate tyvar) free
- | tyvar `is_elem` free = free
- | otherwise = tyvar:free
- get (UniTyVar tyvar) free = free
- get (UniFun ty1 ty2) free = get ty1 (get ty2 free)
- get (UniData tycon tys) free = foldr get free tys
- get (UniSyn tycon tys ty) free = foldr get free tys
- get (UniDict clas ty) free = get ty free
- get (UniForall tyvar ty) free = get ty free
-
- is_elem = isIn "extractTyVarTemplatesFromTy"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniTyFuns-predicates]{Predicates (and such) on @UniTypes@}
-%* *
-%************************************************************************
-
-We include functions that return @Maybe@ thingies as ``predicates.''
-
-\begin{code}
-isTyVarTy :: UniType -> Bool
-isTyVarTy (UniTyVar _) = True
-isTyVarTy (UniSyn _ _ expand) = isTyVarTy expand
-isTyVarTy other = False
-
--- isTyVarTemplateTy only used in Renamer for error checking
-isTyVarTemplateTy :: UniType -> Bool
-isTyVarTemplateTy (UniTyVarTemplate tv) = True
-isTyVarTemplateTy (UniSyn _ _ expand) = isTyVarTemplateTy expand
-isTyVarTemplateTy other = False
-
-maybeUnpackFunTy :: TauType -> Maybe (TauType, TauType)
-
-maybeUnpackFunTy ty
- = --false: ASSERT(isTauTy ty) TauType??
- maybe ty
- where
- maybe (UniSyn _ _ expand) = maybe expand
- maybe (UniFun arg result) = Just (arg, result)
- maybe ty@(UniDict _ _) = maybe (unDictifyTy ty)
- maybe other = Nothing
-
-isFunType :: TauType -> Bool
-isFunType ty
- = --false: ASSERT(isTauTy ty) TauType???
- maybeToBool (maybeUnpackFunTy ty)
-\end{code}
-
-\begin{code}
-{- UNUSED:
-isDataConType :: TauType -> Bool
-
-isDataConType ty
- = ASSERT(isTauTy ty)
- is_con_ty ty
- where
- is_con_ty (UniData _ _) = True
- is_con_ty (UniSyn _ _ expand) = is_con_ty expand
- is_con_ty _ = False
--}
-\end{code}
-
-SIMON'S NOTES:
-
-leakFree (UniData (DataTyCon ...) tys)
- = nonrecursive type &&
- all leakFree (apply constructors to tys)
-
-leakFree (PrimTyCon...) = True
-
-leakFree (TyVar _) = False
-leakFree (UniFun _ _) = False
-
-non-recursive: enumeration types, tuples, primitive types...
-
-END NOTES
-
-The list of @TyCons@ is ones we have already seen (and mustn't see
-again).
-
-\begin{code}
-isLeakFreeType :: [TyCon] -> UniType -> Bool
-
-isLeakFreeType seen (UniSyn _ _ expand) = isLeakFreeType seen expand
-
-isLeakFreeType _ (UniTyVar _) = False -- Utterly unknown
-isLeakFreeType _ (UniTyVarTemplate _) = False
-
-isLeakFreeType _ (UniFun _ _) = False -- Could have leaky free variables
-
-isLeakFreeType _ ty@(UniDict _ _) = True -- I'm prepared to bet that
- -- we'll never get a space leak
- -- from a dictionary. But I could
- -- be wrong... SLPJ
-
-isLeakFreeType seen (UniForall _ ty) = isLeakFreeType seen ty
-
--- For a data type we must look at all the argument types of all
--- the constructors. It isn't enough to look merely at the
--- types to which the type constructor is applied. For example
---
--- data Foo a = MkFoo [a]
---
--- Is (Foo Int) leak free? No!
-
-isLeakFreeType seen (UniData tycon tycon_arg_tys)
- | tycon `is_elem` seen = False -- Recursive type! Bale out!
-
- | isDataTyCon tycon = all data_con_args_leak_free (getTyConDataCons tycon)
-
- | otherwise = isPrimTyCon tycon && -- was an assert; now just paranoia
- -- We should have a leak-free-ness predicate on PrimTyCons,
- -- but that's too big a change for today, so we hack it.
- -- Return true iff it's one of the tycons we know are leak-free
- -- 94/10: I hope I don't live to regret taking out
- -- the first check...
- {-(tycon `elem` [
- charPrimTyCon, intPrimTyCon, wordPrimTyCon,
- addrPrimTyCon, floatPrimTyCon, doublePrimTyCon,
- byteArrayPrimTyCon, arrayPrimTyCon,
- mallocPtrPrimTyCon, stablePtrPrimTyCon
- -- List almost surely incomplete!
- ])
- &&-} (all (isLeakFreeType (tycon:seen)) tycon_arg_tys)
- where
- data_con_args_leak_free data_con
- = case (getInstantiatedDataConSig data_con tycon_arg_tys) of { (_,arg_tys,_) ->
- all (isLeakFreeType (tycon:seen)) arg_tys }
-
- is_elem = isIn "isLeakFreeType"
-\end{code}
-
-\begin{code}
-{- UNUSED:
-hasHigherOrderArg :: UniType -> Bool
-hasHigherOrderArg ty
- = case (splitType ty) of { (_, _, tau_ty) ->
- case (splitTyArgs tau_ty) of { (arg_tys, _) ->
-
- foldr ((||) . isFunType . expandTySyns) False arg_tys
- }}
--}
-\end{code}
-
-\begin{code}
-isDictTy :: UniType -> Bool
-
-isDictTy (UniDict _ _) = True
-isDictTy (UniSyn _ _ expand) = isDictTy expand
-isDictTy _ = False
-
-isTauTy :: UniType -> Bool
-
-isTauTy (UniTyVar v) = True
-isTauTy (UniFun a b) = isTauTy a && isTauTy b
-isTauTy (UniData _ tys) = all isTauTy tys
-isTauTy (UniSyn _ _ ty) = isTauTy ty
-isTauTy (UniDict _ ty) = False
-isTauTy (UniTyVarTemplate _) = False
-isTauTy (UniForall _ _) = False
-
-isForAllTy :: UniType -> Bool
-isForAllTy (UniForall _ _) = True
-isForAllTy (UniSyn _ _ ty) = isForAllTy ty
-isForAllTy _ = False
-\end{code}
-
-NOTE: I haven't thought about this much (ToDo: check).
-\begin{code}
-isGroundOrTyVarTy, isGroundTy :: UniType -> Bool
-
-isGroundOrTyVarTy ty = isGroundTy ty || isTyVarTy ty
-
-isGroundTy (UniTyVar tyvar) = False
-isGroundTy (UniTyVarTemplate _) = False
-isGroundTy (UniFun ty1 ty2) = isGroundTy ty1 && isGroundTy ty2
-isGroundTy (UniData tycon tys) = all isGroundTy tys
-isGroundTy (UniSyn _ _ exp) = isGroundTy exp
-isGroundTy (UniDict clas ty) = isGroundTy ty
-isGroundTy (UniForall tyvar ty) = False -- Safe for the moment
-\end{code}
-
-Broadly speaking, instances are exported (a)~if {\em either} the class
-or {\em OUTERMOST} tycon [arbitrary...] is exported; or (b)~{\em both}
-class and tycon are from PreludeCore [non-std, but convenient] {\em
-and} the instance was defined in this module. BUT: if either the
-class or tycon was defined in this module, but not exported, then
-there is no point exporting the instance.
-
-\begin{code}
-instanceIsExported
- :: Class -> TauType -- class/"tycon" defining instance
- -> Bool -- True <=> instance decl in this module
- -> Bool
-
-instanceIsExported clas ty from_here
- = --false:ASSERT(isTauTy ty) TauType?? failed compiling IArray
- if is_core_class then
- if is_fun_tycon || is_core_tycon then
- {-if-} from_here
- else
- is_exported_tycon
- || (is_imported_tycon && from_here) -- V NAUGHTY BY HASKELL RULES
-
- else if is_fun_tycon || is_core_tycon then
- -- non-Core class; depends on its export flag
- is_exported_class
- || (is_imported_class && from_here) -- V NAUGHTY BY HASKELL RULES
-
- else -- non-Core class & non-Core tycon:
- -- exported if one of them is, but not if either of them
- -- is locally-defined *and* not exported
- if (isLocallyDefined clas && not is_exported_class)
- || (isLocallyDefined tycon && not is_exported_tycon) then
- False
- else
- is_exported_class || is_exported_tycon
- where
- tycon = case getUniDataTyCon_maybe ty of
- Just (xx,_,_) -> xx
- Nothing -> panic "instanceIsExported:no tycon"
-
- is_core_class = fromPreludeCore clas
- is_core_tycon = fromPreludeCore tycon
-
- is_fun_tycon = isFunType ty
-
- is_exported_class = case (getExportFlag clas) of
- NotExported -> False
- _ -> True
-
- is_exported_tycon = case (getExportFlag tycon) of
- NotExported -> False
- _ -> True
-
- is_imported_class = not (isLocallyDefined clas)
- is_imported_tycon = not (isLocallyDefined tycon)
-\end{code}
-
-\begin{code}
-maybePurelyLocalTyCon :: TyCon -> Maybe [Pretty]
-maybePurelyLocalClass :: Class -> Maybe [Pretty]
-maybePurelyLocalType :: UniType -> Maybe [Pretty]
-
-purely_local tc -- overloaded
- = if (isLocallyDefined tc && not (isExported tc))
- then Just (ppr PprForUser tc)
- else Nothing
-
---overloaded: merge_maybes :: (a -> Maybe b) -> [a] -> Maybe [b]
-
-merge_maybes f xs
- = case (catMaybes (map f xs)) of
- [] -> Nothing -- no hit anywhere along the list
- xs -> Just xs
-
-maybePurelyLocalTyCon tycon
- = let
- mentioned_tycons = fst (getMentionedTyConsAndClassesFromTyCon tycon)
- -- will include tycon itself
- in
- merge_maybes purely_local (bagToList mentioned_tycons)
-
-maybePurelyLocalClass clas
- = let
- (mentioned_classes, mentioned_tycons)
- = getMentionedTyConsAndClassesFromClass clas
- -- will include clas itself
-
- tc_stuff = merge_maybes purely_local (bagToList mentioned_tycons)
- cl_stuff = merge_maybes purely_local (bagToList mentioned_classes)
- in
- case (tc_stuff, cl_stuff) of
- (Nothing, Nothing) -> Nothing
- (Nothing, Just xs) -> Just xs
- (Just xs, Nothing) -> Just xs
- (Just xs, Just ys) -> Just (xs ++ ys)
-
-maybePurelyLocalType ty
- = let
- (mentioned_classes, mentioned_tycons)
- = getMentionedTyConsAndClassesFromUniType ty
- -- will include ty itself
-
- tc_stuff = merge_maybes purely_local (bagToList mentioned_tycons)
- cl_stuff = merge_maybes purely_local (bagToList mentioned_classes)
- in
- case (tc_stuff, cl_stuff) of
- (Nothing, Nothing) -> Nothing
- (Nothing, Just xs) -> Just xs
- (Just xs, Nothing) -> Just xs
- (Just xs, Just ys) -> Just (xs ++ ys)
-\end{code}
-
-A gigantic HACK due to Simon (95/05)
-\begin{code}
-returnsRealWorld :: UniType -> Bool
-
-returnsRealWorld (UniTyVar _) = False
-returnsRealWorld (UniTyVarTemplate _) = False
-returnsRealWorld (UniSyn _ _ exp) = returnsRealWorld exp
-returnsRealWorld (UniDict _ ty) = returnsRealWorld ty
-returnsRealWorld (UniForall _ ty) = returnsRealWorld ty
-returnsRealWorld (UniFun ty1 ty2) = returnsRealWorld ty2
-
-returnsRealWorld (UniData tycon []) = tycon == realWorldTyCon
-returnsRealWorld (UniData tycon tys) = any returnsRealWorld tys
-\end{code}
-
-\begin{code}
-#ifdef DPH
-isProcessorTy :: UniType -> Bool
-isProcessorTy (UniData tycon _) = isProcessorTyCon tycon
-isProcessorTy _ = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-Podization of a function @f@ is the compile time specialisation of @f@
-to a form that is equivalent to (map.f) . We can podize {\em some}
-functions at runtime because of the laws concerning map and functional
-composition:
-\begin{verbatim}
- map (f . g) == (map f) . (map g) etc...
-\end{verbatim}
-i.e If we compose two functions, to create a {\em new} function, then
-we can compose the podized versions in just the same way. There is a
-problem however (as always :-(; We cannot convert between an vanilla
-function, and the podized form (and visa versa) at run-time. The
-predicate below describes the set of all objects that cannot be
-podized at runtime (i.e anything that has a function in it).
-\begin{code}
-#ifdef DPH
-runtimeUnpodizableType:: UniType -> Bool
-runtimeUnpodizableType (UniDict _ _) = True
-runtimeUnpodizableType (UniFun _ _) = True
-runtimeUnpodizableType (UniData _ tys) = any runtimeUnpodizableType tys
-runtimeUnpodizableType (UniSyn _ _ ty) = runtimeUnpodizableType ty
-runtimeUnpodizableType other = False
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniTyFuns-subst]{Substitute in a type}
-%* *
-%************************************************************************
-
-The idea here is to substitute for the TyVars in a type. Note, not
-the TyVarTemplates---that's the job of instantiateTy.
-
-There is a single general function, and two interfaces.
-
-\subsubsection{Interface 1: substitutions}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-NOTE: This has been moved to @Subst@ (mostly for speed reasons).
-
-\subsubsection{Interface 2: Envs}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType
-applyTypeEnvToTy tenv ty
- = mapOverTyVars v_fn ty
- where
- v_fn v = case (lookupTyVarEnv tenv v) of
- Just ty -> ty
- Nothing -> UniTyVar v
-
-applyTypeEnvToTauTy :: TypeEnv -> TauType -> TauType
-applyTypeEnvToTauTy e ty
- = ASSERT(isTauTy ty)
- applyTypeEnvToTy e ty
-
-applyTypeEnvToThetaTy tenv theta
- = [(clas,
- ASSERT(isTauTy ty)
- applyTypeEnvToTauTy tenv ty) | (clas, ty) <- theta]
-\end{code}
-
-\subsubsection{@mapOverTyVars@: does the real work}
-%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-@mapOverTyVars@ is a local function which actually does the work. It does
-no cloning or other checks for shadowing, so be careful when calling
-this on types with Foralls in them.
-
-\begin{code}
-mapOverTyVars :: (TyVar -> UniType) -> UniType -> UniType
-mapOverTyVars v_fn (UniTyVar v) = v_fn v
-mapOverTyVars v_fn (UniFun t1 t2) = UniFun (mapOverTyVars v_fn t1) (mapOverTyVars v_fn t2)
-mapOverTyVars v_fn (UniData con args) = UniData con (map (mapOverTyVars v_fn) args)
-mapOverTyVars v_fn (UniSyn con args ty) = UniSyn con (map (mapOverTyVars v_fn) args) (mapOverTyVars v_fn ty)
-mapOverTyVars v_fn (UniDict clas ty) = UniDict clas (mapOverTyVars v_fn ty)
-mapOverTyVars v_fn (UniForall v ty) = UniForall v (mapOverTyVars v_fn ty)
-mapOverTyVars v_fn (UniTyVarTemplate v) = UniTyVarTemplate v
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniTyFuns-ppr]{Pretty-printing @UniTypes@}
-%* *
-%************************************************************************
-
-@pprUniType@ is the std @UniType@ printer; the overloaded @ppr@
-function is defined to use this. @pprParendUniType@ is the same,
-except it puts parens around the type, except for the atomic cases.
-@pprParendUniType@ works just by setting the initial context
-precedence very high. ToDo: what if not a @TauType@?
-\begin{code}
-pprUniType, pprParendUniType :: PprStyle -> UniType -> Pretty
-
-pprUniType sty ty = ppr_ty_init sty tOP_PREC ty
-pprParendUniType sty ty = ppr_ty_init sty tYCON_PREC ty
-
-pprMaybeTy :: PprStyle -> Maybe UniType -> Pretty
-pprMaybeTy PprDebug Nothing = ppStr "*"
-pprMaybeTy PprDebug (Just ty) = pprParendUniType PprDebug ty
-
-getTypeString :: UniType -> [FAST_STRING]
- -- shallowly magical; converts a type into something
- -- vaguely close to what can be used in C identifier.
- -- Don't forget to include the module name!!!
-
-getTypeString ty
- = let
- ppr_t = ppr_ty PprForUser (\t -> ppStr "*") tOP_PREC (expandTySyns ty)
-
- string = _PK_ (tidy (ppShow 1000 ppr_t))
- in
- if is_prelude_ty
- then [string]
- else [mod, string]
- where
- (is_prelude_ty, mod)
- = case getUniDataTyCon_maybe ty of
- Nothing -> true_bottom
- Just (tycon,_,_) ->
- if fromPreludeCore tycon
- then true_bottom
- else (False, fst (getOrigName tycon))
-
- true_bottom = (True, panic "getTypeString")
-
- --------------------------------------------------
- -- tidy: very ad-hoc
- tidy [] = [] -- done
-
- tidy (' ' : more)
- = case more of
- ' ' : _ -> tidy more
- '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
- other -> ' ' : tidy more
-
- tidy (',' : more) = ',' : tidy (no_leading_sps more)
-
- tidy (x : xs) = x : tidy xs -- catch all
-
- no_leading_sps [] = []
- no_leading_sps (' ':xs) = no_leading_sps xs
- no_leading_sps other = other
-
-typeMaybeString :: Maybe UniType -> [FAST_STRING]
-typeMaybeString Nothing = [SLIT("!")]
-typeMaybeString (Just t) = getTypeString t
-
-specMaybeTysSuffix :: [Maybe UniType] -> FAST_STRING
-specMaybeTysSuffix ty_maybes
- = let
- ty_strs = concat (map typeMaybeString ty_maybes)
- dotted_tys = [ _CONS_ '.' str | str <- ty_strs ]
- in
- _CONCAT_ dotted_tys
-\end{code}
-
-Nota Bene: we must assign print-names to the forall'd type variables
-alphabetically, with the first forall'd variable having the alphabetically
-first name. Reason: so anyone reading the type signature printed without
-explicit forall's will be able to reconstruct them in the right order.
-
-\begin{code}
-ppr_ty_init :: PprStyle -> Int -> UniType -> Pretty
-
-ppr_ty_init sty init_prec ty
- = let (tyvars, _, _) = splitType ty
- lookup_fn = mk_lookup_tyvar_fn sty tyvars
- in
- ppr_ty sty lookup_fn init_prec ty
-
-mk_lookup_tyvar_fn :: PprStyle -> [TyVarTemplate] -> (TyVarTemplate -> Pretty)
-
-mk_lookup_tyvar_fn sty tyvars
- = tv_lookup_fn
- where
- tv_lookup_fn :: TyVarTemplate -> Pretty
- tv_lookup_fn tyvar
- = let
- pp_tyvar_styish = ppr sty tyvar
-
- assocs = [ pp | (tv, pp) <- tvs_n_pprs, tv == tyvar ]
-
- pp_tyvar_canonical
- = case assocs of
- [] -> pprPanic "pprUniType: bad tyvar lookup:" (ppr sty tyvar)
- -- sometimes, in printing monomorphic types,
- -- (usually in debugging), we won't have the tyvar
- -- in our list; so we just ppr it anyway...
- x:_ -> x
- in
- case sty of
- PprInterface _ -> pp_tyvar_canonical
- PprForC _ -> ppChar '*'
- PprUnfolding _ -> case assocs of
- x:_ -> ppBeside x (ppPStr SLIT("$z1"))
- _ -> ppPStr SLIT("z$z1")
- PprForUser -> case assocs of
- x:_ -> x
- _ -> pp_tyvar_styish
- debuggish -> pp_tyvar_styish
-
- tvs_n_pprs = tyvars `zip` tyvar_pretties
-
- tyvar_pretties = letter_pprs {- a..y -} ++ number_pprs {- z0 ... zN -}
-
- letter_pprs = map (\ c -> ppChar c ) ['a' .. 'y']
- number_pprs = map (\ n -> ppBeside (ppChar 'z') (ppInt n))
- ([0 .. ] :: [Int])
-\end{code}
-
-\begin{code}
-ppr_ty :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> UniType -> Pretty
-
-ppr_ty sty lookup_fn ctxt_prec (UniTyVarTemplate tyvar) = lookup_fn tyvar
-
-ppr_ty sty lookup_fn ctxt_prec (UniTyVar tyvar) = ppr sty tyvar
-
-ppr_ty sty lookup_fn ctxt_prec ty
- = case sty of
- PprForUser -> context_onward
- PprInterface _ -> context_onward
- _ ->
- (if null tyvars then id else ppBeside (ppr_forall sty tyvars))
- context_onward
- where
- (tyvars, context, tau_ty) = splitType ty
-
- context_onward =
- if (null pretty_context_pieces) then
- ppr_tau_ty sty lookup_fn ctxt_prec tau_ty
- else
- ppCat (pretty_context_pieces
- ++ [connector sty, ppr_tau_ty sty lookup_fn ctxt_prec tau_ty]) -- ToDo: dubious
-
- pretty_context_pieces = ppr_context sty context
-
- ppr_forall :: PprStyle -> [TyVarTemplate] -> Pretty
-
- ppr_forall _ [] = ppNil
- ppr_forall sty tyvars
- = ppBesides [ppPStr SLIT("_forall_ "), ppIntersperse pp'SP{-'-} pp_tyvars,
- ppPStr SLIT(" =>")]
- where
- pp_tyvars = map lookup_fn tyvars
-
- ppr_context :: PprStyle -> [(Class, UniType)] -> [Pretty]
-
- ppr_context _ [] = []
- ppr_context sty context@(c:cs)
- = case sty of
- PprForUser -> userish
- PprInterface _ -> userish
- _ -> hackerish
- where
- userish
- = [if (context `lengthExceeds` (1::Int)) then
- ppBesides [ ppLparen,
- ppIntersperse pp'SP{-'-} (map (ppr_kappa_tau PprForUser) context),
- ppRparen]
- else
- ppr_kappa_tau PprForUser (head context)
- ]
- hackerish
- = (ppr_kappa_tau sty c) : (map ( pin_on_arrow . (ppr_kappa_tau sty) ) cs)
-
- connector PprForUser = ppPStr SLIT("=>")
- connector (PprInterface _) = ppPStr SLIT("=>")
- connector other_sty = ppPStr SLIT("->")
-
- ppr_kappa_tau :: PprStyle -> (Class, UniType) -> Pretty
-
- ppr_kappa_tau sty (clas, ty)
- = let
- pp_ty = ppr_tau_ty sty lookup_fn ctxt_prec ty
- user_ish = ppCat [ppr PprForUser clas, pp_ty]
- hack_ish = ppBesides [ppStr "{{", ppr sty clas, ppSP, pp_ty, ppStr "}}"]
- in
- case sty of
- PprForUser -> user_ish
- PprInterface _ -> user_ish
- _ -> hack_ish
-
- pin_on_arrow p = ppBeside (ppPStr SLIT("-> ")) p
-\end{code}
-
-@ppr_tau_ty@ takes an @Int@ that is the precedence of the context.
-The precedence levels are:
-\begin{description}
-\item[0:] What we start with.
-\item[1:] Function application (@UniFuns@).
-\item[2:] Type constructors.
-\end{description}
-
-A non-exported help function that really does the printing:
-\begin{code}
-tOP_PREC = (0 :: Int)
-fUN_PREC = (1 :: Int)
-tYCON_PREC = (2 :: Int)
-
-ppr_tau_ty :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> UniType -> Pretty
-
--- a quite special case, for printing instance decls in interfaces:
-ppr_tau_ty sty@(PprInterface _) lookup_fn ctxt_prec (UniDict clas ty)
- = ppCat [ppr PprForUser clas, ppr_ty sty lookup_fn tYCON_PREC ty]
-
-ppr_tau_ty sty lookup_fn ctxt_prec (UniSyn _ _ expansion)
- -- Expand type synonyms unless PprForUser
- -- NB: it is important that synonyms are expanded with PprInterface
- | case sty of { PprForUser -> False; _ -> True }
- = ppr_tau_ty sty lookup_fn ctxt_prec expansion
-
-ppr_tau_ty sty lookup_fn ctxt_prec (UniTyVarTemplate tyvar) = lookup_fn tyvar
-
-ppr_tau_ty sty lookup_fn ctxt_prec (UniTyVar tyvar) = ppr sty tyvar
-
-ppr_tau_ty sty lookup_fn ctxt_prec (UniFun ty1 ty2)
- -- we fiddle the precedences passed to left/right branches,
- -- so that right associativity comes out nicely...
-
- = let p1 = ppr_tau_ty sty lookup_fn fUN_PREC ty1
- p2 = ppr_tau_ty sty lookup_fn tOP_PREC ty2
- in
- if ctxt_prec < fUN_PREC then -- no parens needed
- ppCat [p1, ppBeside (ppPStr SLIT("-> ")) p2]
- else
- ppCat [ppBeside ppLparen p1, ppBesides [ppPStr SLIT("-> "), p2, ppRparen]]
-
--- Special printing for list and tuple types.
--- we can re-set the precedence to tOP_PREC
-
-ppr_tau_ty sty lookup_fn ctxt_prec (UniData tycon tys)
- = if tycon == listTyCon then
- ppBesides [ppLbrack, ppr_tau_ty sty lookup_fn tOP_PREC (head tys), ppRbrack]
-
- else if (tycon == (TupleTyCon (length tys))) then
- ppBesides [ppLparen, ppIntersperse pp'SP{-'-} (map (ppr_tau_ty sty lookup_fn tOP_PREC) tys), ppRparen]
-#ifdef DPH
- else if (tycon == podTyCon) then
- pprPodshort sty lookup_fn tOP_PREC (head tys)
-
- else if (tycon == (ProcessorTyCon ((length tys)-1))) then
- ppBesides [ppStr "(|",
- ppIntersperse pp'SP{-'-}
- (map (ppr_tau_ty sty lookup_fn tOP_PREC) (init tys)),
- ppSemi ,
- ppr_tau_ty sty lookup_fn tOP_PREC (last tys),
- ppStr "|)"]
-#endif {- Data Parallel Haskell -}
- else
- ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys
-
-ppr_tau_ty sty lookup_fn ctxt_prec (UniSyn tycon tys expansion)
- = ppBeside
- (ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys)
- (ifPprShowAll sty (ppCat [ppStr " {- expansion:", ppr_ty sty lookup_fn ctxt_prec expansion, ppStr "-}"]))
-
--- For SPECIALIZE instance error messages ...
-ppr_tau_ty sty@PprForUser lookup_fn ctxt_prec (UniDict clas ty)
- = if ctxt_prec < tYCON_PREC then
- ppCat [ppr sty clas, ppr_ty sty lookup_fn tYCON_PREC ty]
- else
- ppBesides [ppStr "(", ppr sty clas, ppSP, ppr_ty sty lookup_fn tYCON_PREC ty, ppStr ")"]
-
-ppr_tau_ty sty lookup_fn ctxt_prec (UniDict clas ty)
- = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_ty sty lookup_fn tYCON_PREC ty, ppStr "}}"]
-
-ppr_tau_ty sty lookup_fn ctxt_prec other_ty -- must a be UniForall (ToDo: something?)
- = ppBesides [ppLparen, ppr_ty sty lookup_fn ctxt_prec other_ty, ppRparen]
-
--- code shared for UniDatas and UniSyns
-ppr_tycon_and_tys :: PprStyle -> (TyVarTemplate -> Pretty) -> Int -> TyCon -> [UniType] -> Pretty
-
-ppr_tycon_and_tys sty lookup_fn ctxt_prec tycon tys
- = let pp_tycon = ppr (case sty of PprInterface _ -> PprForUser; _ -> sty) tycon
- in
- if null tys then
- pp_tycon
- else if ctxt_prec < tYCON_PREC then -- no parens needed
- ppCat [pp_tycon, ppIntersperse ppSP (map (ppr_tau_ty sty lookup_fn tYCON_PREC) tys) ]
- else
- ppBesides [ ppLparen, pp_tycon, ppSP,
- ppIntersperse ppSP (map (ppr_tau_ty sty lookup_fn tYCON_PREC) tys), ppRparen ]
-\end{code}
-
-\begin{code}
-#ifdef DPH
-pprPodshort :: PprStyle -> (TyVarTemplate-> Pretty) -> Int -> UniType -> Pretty
-pprPodshort sty lookup_fn ctxt_prec (UniData tycon tys)
- | (tycon == (ProcessorTyCon ((length tys)-1)))
- = ppBesides [ppStr "<<",
- ppIntersperse pp'SP{-'-}
- (map (ppr_tau_ty sty lookup_fn tOP_PREC) (init tys)),
- ppSemi ,
- ppr_tau_ty sty lookup_fn tOP_PREC (last tys),
- ppStr ">>"]
-pprPodshort sty lookup_fn ctxt_prec ty
- = ppBesides [ppStr "<<",
- ppr_tau_ty sty lookup_fn tOP_PREC ty,
- ppStr ">>"]
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-showTyCon :: PprStyle -> TyCon -> String
-showTyCon sty tycon
- = ppShow 80 (pprTyCon sty tycon [])
-
-pprTyCon :: PprStyle -> TyCon -> [[Maybe UniType]] -> Pretty
--- with "PprInterface", we print out for interfaces
-
-pprTyCon sty@(PprInterface sw_chkr) (SynonymTyCon k n a vs exp unabstract) specs
- = ASSERT (null specs)
- let
- lookup_fn = mk_lookup_tyvar_fn sty vs
- pp_tyvars = map lookup_fn vs
- pp_abstract = if unabstract || (sw_chkr OmitInterfacePragmas)
- then ppNil
- else ppStr "{-# GHC_PRAGMA _ABSTRACT_ #-}"
- in
- ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
- ppEquals, ppr_ty sty lookup_fn tOP_PREC exp, pp_abstract]
-
-pprTyCon sty@(PprInterface sw_chkr) this_tycon@(DataTyCon k n a vs cons derivings unabstract) specs
- = ppHang (ppCat [ppPStr SLIT("data"),
- -- pprContext sty context,
- ppr sty n,
- ppIntersperse ppSP (map lookup_fn vs)])
- 4
- (ppCat [pp_unabstract_condecls,
- pp_pragma])
- -- NB: we do not print deriving info in interfaces
- where
- lookup_fn = mk_lookup_tyvar_fn sty vs
-
- yes_we_print_condecls
- = unabstract
- && not (null cons) -- we know what they are
- && (case (getExportFlag n) of
- ExportAbs -> False
- other -> True)
-
- yes_we_print_pragma_condecls
- = not yes_we_print_condecls
- && not (sw_chkr OmitInterfacePragmas)
- && not (null cons)
- && not (maybeToBool (maybePurelyLocalTyCon this_tycon))
- {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
-
- yes_we_print_pragma_specs
- = not (null specs)
-
- pp_unabstract_condecls
- = if yes_we_print_condecls
- then ppCat [ppSP, ppEquals, pp_condecls]
- else ppNil
-
- pp_pragma_condecls
- = if yes_we_print_pragma_condecls
- then pp_condecls
- else ppNil
-
- pp_pragma_specs
- = if yes_we_print_pragma_specs
- then pp_specs
- else ppNil
-
- pp_pragma
- = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs)
- then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"]
- else ppNil
-
- pp_condecls
- = let
- (c:cs) = cons
- in
- ppCat ((ppr_con c) : (map ppr_next_con cs))
- where
- ppr_con con
- = let
- (_, _, con_arg_tys, _) = getDataConSig con
- in
- ppCat [pprNonOp PprForUser con, -- the data con's name...
- ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
-
- ppr_next_con con = ppCat [ppChar '|', ppr_con con]
-
- pp_specs
- = ppBesides [ppStr "_SPECIALISE_ ", pp_the_list [
- ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
- | ty_maybes <- specs ]]
-
- pp_the_list [p] = p
- pp_the_list (p:ps) = ppCat [ppBeside p ppComma, pp_the_list ps]
-
- pp_maybe Nothing = pp_NONE
- pp_maybe (Just ty) = pprParendUniType sty ty
-
- pp_NONE = ppStr "_N_"
-
-pprTyCon (PprInterface _) (TupleTyCon a) specs
- = ASSERT (null specs)
- ppCat [ ppStr "{- Tuple", ppInt a, ppStr "-}" ]
-
-pprTyCon (PprInterface _) (PrimTyCon k n a kind_fn) specs
- = ASSERT (null specs)
- ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
-
-#ifdef DPH
-pprTyCon (PprInterface _) (ProcessorTyCon a) specs
- = ppCat [ ppStr "{- Processor", ppInt a, ppStr "-}" ]
-#endif {- Data Parallel Haskell -}
-
--- regular printing (ToDo: probably update)
-
-pprTyCon sty (SynonymTyCon k n a vs exp unabstract) [{-no specs-}]
- = ppBeside (ppr sty n)
- (ifPprShowAll sty
- (ppCat [ ppStr " {-", ppInt a, interpp'SP sty vs,
- pprParendUniType sty exp,
- if unabstract then ppNil else ppStr "_ABSTRACT_", ppStr "-}"]))
-
-pprTyCon sty tycon@(DataTyCon k n a vs cons derivings unabstract) [{-no specs-}]
- = case sty of
- PprDebug -> pp_tycon_and_uniq
- PprShowAll -> pp_tycon_and_uniq
- _ -> pp_tycon
- where
- pp_tycon_and_uniq = ppBesides [pp_tycon, ppStr "{-", pprUnique k, ppStr "-}"]
- pp_tycon
- = let
- pp_name = ppr sty n
- in
- if codeStyle sty || tycon /= listTyCon
- then pp_name
- else ppBesides [ppLbrack, interpp'SP sty vs, ppRbrack]
-
-{-ppBeside-} -- pp_tycon
-{- SOMETIMES:
- (ifPprShowAll sty
- (ppCat [ ppStr " {-", ppInt a, interppSP sty vs,
- interpp'SP PprForUser cons,
- ppStr "deriving (", interpp'SP PprForUser derivings,
- ppStr ")-}" ]))
--}
-
-pprTyCon sty (TupleTyCon a) [{-no specs-}]
- = ppBeside (ppPStr SLIT("Tuple")) (ppInt a)
-
-pprTyCon sty (PrimTyCon k n a kind_fn) [{-no specs-}]
- = ppr sty n
-
-pprTyCon sty (SpecTyCon tc ty_maybes) []
- = ppBeside (pprTyCon sty tc [])
- (if (codeStyle sty)
- then identToC tys_stuff
- else ppPStr tys_stuff)
- where
- tys_stuff = specMaybeTysSuffix ty_maybes
-
-#ifdef DPH
-pprTyCon sty (ProcessorTyCon a) [] = ppBeside (ppStr "Processor") (ppInt a)
-
-pprTyCon sty (PodizedPodTyCon dim tc) []
- = ppBesides [ ppr sty tc, ppStr "Podized", ppr sty dim]
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-pprIfaceClass :: (GlobalSwitch -> Bool) -> (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
-
-pprIfaceClass sw_chker better_id_fn inline_env
- (MkClass k n tyvar super_classes sdsels ops sels defms insts links)
- = let
- sdsel_infos = map (getIdInfo . better_id_fn) sdsels
- in
- ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
- ppr sty n, lookup_fn tyvar,
- if null sdsel_infos
- || omit_iface_pragmas
- || (any boringIdInfo sdsel_infos)
- -- ToDo: really should be "all bor..."
- -- but then parsing is more tedious,
- -- and this is really as good in practice.
- then ppNil
- else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
- if (null ops)
- then ppNil
- else ppPStr SLIT("where")],
- ppNest 8 (ppAboves
- [ ppr_op op (better_id_fn sel) (better_id_fn defm)
- | (op,sel,defm) <- zip3 ops sels defms]) ]
- where
- sty = PprInterface sw_chker
- omit_iface_pragmas = sw_chker OmitInterfacePragmas
-
- lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
-
- ppr_theta :: TyVarTemplate -> [Class] -> Pretty
- ppr_theta tv [] = ppNil
- ppr_theta tv super_classes
- = ppBesides [ppLparen,
- ppIntersperse pp'SP{-'-} (map ppr_assert super_classes),
- ppStr ") =>"]
- where
- ppr_assert (MkClass _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
-
- pp_sdsel_pragmas sdsels_and_infos
- = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}",
- ppIntersperse pp'SP{-'-}
- [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info
- | (sdsel, info) <- sdsels_and_infos ],
- ppStr "#-}"]
-
- ppr_op op opsel_id defm_id
- = let
- stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
- in
- if omit_iface_pragmas
- then stuff
- else ppAbove stuff
- (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
- where
- pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)]
- pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)]
-\end{code}
-
-\begin{code}
-pprClassOp :: PprStyle -> ClassOp -> Pretty
-
-pprClassOp sty op = ppr_class_op sty [] op
-
-ppr_class_op sty tyvars (MkClassOp op_name i ty)
- = case sty of
- PprForC _ -> pp_C
- PprForAsm _ _ _ -> pp_C
- PprInterface _ -> ppCat [pp_user, ppPStr SLIT("::"), ppr_ty sty lookup_fn tOP_PREC ty]
- PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr_ty PprDebug lookup_fn tOP_PREC ty]
- _ -> pp_user
- where
- (local_tyvars,_,_) = splitType ty
- lookup_fn = mk_lookup_tyvar_fn sty (tyvars ++ local_tyvars)
-
- pp_C = ppPStr op_name
- pp_user = if isAvarop op_name
- then ppBesides [ppLparen, pp_C, ppRparen]
- else pp_C
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniTyFuns-matching]{@matchTy@}
-%* *
-%************************************************************************
-
-Matching is a {\em unidirectional} process, matching a type against a
-template (which is just a type with type variables in it). The matcher
-assumes that there are no repeated type variables in the template, so that
-it simply returns a mapping of type variables to types.
-
-\begin{code}
-matchTy :: UniType -- Template
- -> UniType -- Proposed instance of template
- -> Maybe [(TyVarTemplate,UniType)] -- Matching substitution
-
-matchTy (UniTyVarTemplate v) ty = Just [(v,ty)]
-matchTy (UniTyVar _) ty = panic "matchTy: unexpected TyVar (need TyVarTemplates)"
-
-matchTy (UniFun fun1 arg1) (UniFun fun2 arg2) = matchTys [fun1, arg1] [fun2, arg2]
-
-matchTy ty1@(UniData con1 args1) ty2@(UniData con2 args2) | con1 == con2
- = matchTys args1 args2 -- Same constructors, just match the arguments
-
--- with type synonyms, we have to be careful
--- for the exact same reasons as in the unifier.
--- Please see the considerable commentary there
--- before changing anything here! (WDP 95/05)
-
--- If just one or the other is a "visible" synonym (they all are at
--- the moment...), just expand it.
-
-matchTy (UniSyn con1 args1 ty1) ty2
- | isVisibleSynTyCon con1
- = matchTy ty1 ty2
-matchTy ty1 (UniSyn con2 args2 ty2)
- | isVisibleSynTyCon con2
- = matchTy ty1 ty2
-
-matchTy (UniSyn con1 args1 ty1) (UniSyn con2 args2 ty2)
- -- if we get here, both synonyms must be "abstract"
- -- (NB: not done yet)
- = if (con1 == con2) then
- -- Good news! Same synonym constructors, so we can shortcut
- -- by unifying their arguments and ignoring their expansions.
- matchTys args1 args2
- else
- -- Never mind. Just expand them and try again
- matchTy ty1 ty2
-
--- Catch-all fails
-matchTy templ ty = Nothing
-\end{code}
-
-@matchTys@ matches corresponding elements of a list of templates and
-types.
-
-\begin{code}
-matchTys :: [UniType] -> [UniType] -> Maybe [(TyVarTemplate, UniType)]
-
-matchTys [] [] = Just []
-matchTys (templ:templs) (ty:tys)
- = case (matchTy templ ty) of
- Nothing -> Nothing
- Just subst -> case (matchTys templs tys) of
- Nothing -> Nothing
- Just subst2 -> Just (subst ++ subst2)
-#ifdef DEBUG
-matchTys [] tys
- = pprPanic "matchTys: out of templates!; tys:" (ppr PprDebug tys)
-matchTys tmpls []
- = pprPanic "matchTys: out of types!; templates:" (ppr PprDebug tmpls)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniTyFuns-misc]{Misc @UniType@ functions}
-%* *
-%************************************************************************
-
-\begin{code}
-cmpUniTypeMaybeList :: [Maybe UniType] -> [Maybe UniType] -> TAG_
-cmpUniTypeMaybeList [] [] = EQ_
-cmpUniTypeMaybeList (x:xs) [] = GT_
-cmpUniTypeMaybeList [] (y:ys) = LT_
-cmpUniTypeMaybeList (x:xs) (y:ys)
- = case cmp_maybe_ty x y of { EQ_ -> cmpUniTypeMaybeList xs ys; other -> other }
-
-cmp_maybe_ty Nothing Nothing = EQ_
-cmp_maybe_ty (Just x) Nothing = GT_
-cmp_maybe_ty Nothing (Just y) = LT_
-cmp_maybe_ty (Just x) (Just y) = cmpUniType True{-properly-} x y
-\end{code}
-
-Identity function if the type is a @TauType@; panics otherwise.
-\begin{code}
-#ifdef DEBUG
-verifyTauTy :: String -> TauType -> TauType
-
-verifyTauTy caller ty@(UniDict _ _) = pprPanic (caller++":verifyTauTy:dict") (ppr PprShowAll ty)
-verifyTauTy caller ty@(UniForall _ _) = pprPanic (caller++":verifyTauTy:forall") (ppr PprShowAll ty)
-verifyTauTy caller (UniSyn tycon tys expansion) = UniSyn tycon tys (verifyTauTy caller expansion)
-verifyTauTy caller tau_ty = tau_ty
-
-#endif {- DEBUG -}
-\end{code}
-
-\begin{code}
-showTypeCategory :: UniType -> Char
- {-
- {C,I,F,D} char, int, float, double
- T tuple
- S other single-constructor type
- {c,i,f,d} unboxed ditto
- t *unpacked* tuple
- s *unpacked" single-cons...
-
- v void#
- a primitive array
-
- E enumeration type
- + dictionary, unless it's a ...
- L List
- > function
- M other (multi-constructor) data-con type
- . other type
- - reserved for others to mark as "uninteresting"
- -}
-showTypeCategory ty
- = if isDictTy ty
- then '+'
- else
- case getUniDataTyCon_maybe ty of
- Nothing -> if isFunType ty
- then '>'
- else '.'
-
- Just (tycon,_,_) ->
- if maybeToBool (maybeCharLikeTyCon tycon) then 'C'
- else if maybeToBool (maybeIntLikeTyCon tycon) then 'I'
- else if maybeToBool (maybeFloatLikeTyCon tycon) then 'F'
- else if maybeToBool (maybeDoubleLikeTyCon tycon) then 'D'
- else if tycon == integerTyCon then 'J'
- else if tycon == charPrimTyCon then 'c'
- else if (tycon == intPrimTyCon || tycon == wordPrimTyCon
- || tycon == addrPrimTyCon) then 'i'
- else if tycon == floatPrimTyCon then 'f'
- else if tycon == doublePrimTyCon then 'd'
- else if isPrimTyCon tycon {- array, we hope -} then 'A'
- else if isEnumerationTyCon tycon then 'E'
- else if isTupleTyCon tycon then 'T'
- else if maybeToBool (maybeSingleConstructorTyCon tycon) then 'S'
- else if tycon == listTyCon then 'L'
- else 'M' -- oh, well...
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[UniType]{The UniType data type}
-
-The module @AbsUniType@ is the normal interface to this datatype.
-This interface is for ``Friends Only.''
-
-\begin{code}
-#include "HsVersions.h"
-
-module UniType (
- UniType(..), -- not abstract; usually grabbed through AbsUniType
-
- -- USEFUL SYNONYMS
- SigmaType(..), RhoType(..), TauType(..),
- ThetaType(..), -- synonym for [(Class,UniType)]
- InstTyEnv(..),
-
- -- CONSTRUCTION
- mkTyVarTy, mkTyVarTemplateTy, mkDictTy,
- -- use applyTyCon to make UniDatas, UniSyns
- mkRhoTy, mkForallTy, mkSigmaTy, -- ToDo: perhaps nuke one?
-
- -- QUANTIFICATION & INSTANTIATION
- quantifyTy,
- instantiateTy, instantiateTauTy, instantiateThetaTy,
-
- -- COMPARISON
- cmpUniType,
-
- -- PRE-BUILT TYPES (for Prelude)
- alpha, beta, gamma, delta, epsilon, -- these have templates in them
- alpha_ty, beta_ty, gamma_ty, delta_ty, epsilon_ty, -- these have tyvars in them
-
- -- to make the interface self-sufficient...
- Class, TyCon, TyVar, TyVarTemplate, Maybe
- ) where
-
-IMPORT_Trace -- ToDo:rm (debugging only)
-
-#if USE_ATTACK_PRAGMAS
-import Class ( cmpClass, getClassSig, Class(..), ClassOp(..) )
-#else
-import Class ( cmpClass, getClassSig, Class, ClassOp )
-#endif
-import Maybes ( assocMaybe, Maybe(..) )
-import Outputable -- the output class, etc.
-import Pretty
-import TyCon ( cmpTyCon, TyCon, Arity(..) )
-import TyVar -- various things
-import UniTyFuns ( pprUniType, unDictifyTy
- IF_ATTACK_PRAGMAS(COMMA pprTyCon)
- )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniType-basics]{Basics of the @UniType@ datatype}
-%* *
-%************************************************************************
-
-\begin{code}
-data UniType
- =
- -- The free variables of a UniType are always TyVars.
- UniTyVar TyVar
-
- | UniFun UniType -- Function type
- UniType
-
- | UniData -- Application of a non SynonymTyCon
- TyCon -- Must NOT be a SynonymTyCon
- [UniType] -- Arguments to the type constructor
-
- | UniSyn -- Application of a SynonymTyCon
- TyCon -- Must be a SynonymTyCon
- [UniType] -- Arguments to the type constructor
- UniType -- Expanded version (merely cached here)
-
- | UniDict Class
- UniType
-
- -- The next two are to do with universal quantification
-
- -- TyVarTemplates only need be unique within a single UniType;
- -- because they are always bound by an enclosing UniForall.
- | UniTyVarTemplate
- TyVarTemplate
-
- | UniForall TyVarTemplate
- UniType
-\end{code}
-
-Universal quantification is over @TyVarTemplate@s. A type containing
-a @UniTyVarTemplate@ always has either an enclosing @UniForall@ which
-binds it, or a ``nearby'' binding @TyVarTemplate@. The only example
-of the latter is that a @ClassOp@ will have a free occurrence of the
-@TyVarTemplate@ which is held in the @Class@ object.
-
-@UniTyVarTemplate@s are never encountered during unification.
-
-The reasons for this huff and puff over template variables are:
-\begin{enumerate}
-\item
-It's nice to be able to identify them in the code.
-\item
-It saves worry about accidental capture when instantiating types,
-because the types with which the template variables are being
-instantiated never themselves contain @UniTyVarTemplates@.
-\end{enumerate}
-
-Note: if not @do_properly@, then we treat @UniTyVarTemplates@ as
-``wildcards;'' we use this {\em only} when comparing types in STG
-land. It is the responsibility of the caller to strip the
-@UniForalls@ off the front.
-
-\begin{code}
-cmpUniType do_properly ty1 ty2
- = cmp_ty [] ty1 ty2
- where
- cmp_ty equivs (UniTyVar tv1) (UniTyVar tv2) = tv1 `cmpTyVar` tv2
-
- cmp_ty equivs (UniFun a1 b1) (UniFun a2 b2)
- = case cmp_ty equivs a1 a2 of { EQ_ -> cmp_ty equivs b1 b2; other -> other }
-
- cmp_ty equivs (UniData tc1 tys1) (UniData tc2 tys2)
- = case cmpTyCon tc1 tc2 of { EQ_ -> cmp_ty_lists equivs tys1 tys2; other -> other }
-
- cmp_ty equivs (UniForall tv1 ty1) (UniForall tv2 ty2)
- = cmp_ty ((tv1,tv2) : equivs) ty1 ty2
-\end{code}
-
-Now we deal with the Dict/Dict case. If the two classes are the same
-then all is straightforward. If not, the two dicts will usually
-differ, but (rarely) we could still be looking at two equal
-dictionaries! For example,
-
- class Foo a => Baz a where
-
-That is, Foo is the only superclass of Baz, and Baz has no methods.
-Then a Baz dictionary will be represented simply by a Foo dictionary!
-
-We could sort this out by unDictifying, but that seems like a
-sledgehammer to crack a (rather rare) nut. Instead we ``de-synonym''
-each class, by looking to see if it is one of these odd guys which has
-no ops and just one superclass (if so, do the same to this
-superclass), and then compare the results.
-
-\begin{code}
- cmp_ty equivs (UniDict c1 ty1) (UniDict c2 ty2)
- = case cmpClass c1 c2 of
- EQ_ -> cmp_ty equivs ty1 ty2
- other -> case cmpClass (super_ify c1) (super_ify c2) of
- EQ_ -> cmp_ty equivs ty1 ty2
- other -> other
- where
- super_ify :: Class -> Class -- Iff the arg is a class with just one
- -- superclass and no operations, then
- -- return super_ify of the superclass,
- -- otherwise just return the original
- super_ify clas
- = case getClassSig clas of
- (_, [super_clas], [{-no ops-}]) -> super_ify super_clas
- other -> clas
-\end{code}
-
-Back to more straightforward things.
-
-\begin{code}
- cmp_ty equivs (UniTyVarTemplate tv1) (UniTyVarTemplate tv2)
- | not do_properly -- STG case: tyvar templates are ``wildcards''
- = EQ_
-
- | otherwise -- compare properly
- = case (tv1 `cmp_tv_tmpl` tv2) of
- EQ_ -> EQ_
- _ -> -- tv1 should Jolly Well be in the equivalents list
- case assocMaybe equivs tv1 of
- Just xx -> xx `cmp_tv_tmpl` tv2
- Nothing ->
-#if defined(DEBUG)
- case (pprPanic "cmpUniType:failed assoc:" (ppCat [ppr PprDebug tv1, ppr PprDebug tv2, ppr PprDebug ty1, ppr PprDebug ty2, ppr PprDebug equivs])) of
-#else
- case (panic "cmpUniType:failed assoc") of
-#endif
- s -> -- never get here (BUG)
- cmp_ty equivs s s
-
- cmp_ty equivs a@(UniDict _ _) b = cmp_ty equivs (unDictifyTy a) b
- cmp_ty equivs a b@(UniDict _ _) = cmp_ty equivs a (unDictifyTy b)
-
- cmp_ty equivs (UniSyn _ _ expand) b = cmp_ty equivs expand b
- cmp_ty equivs a (UniSyn _ _ expand) = cmp_ty equivs a expand
-
- -- more special cases for STG case
- cmp_ty equivs (UniTyVarTemplate _) b | not do_properly = EQ_
- cmp_ty equivs a (UniTyVarTemplate _) | not do_properly = EQ_
-
- cmp_ty equivs other_1 other_2
- = let tag1 = tag other_1
- tag2 = tag other_2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
- where
- tag (UniTyVar _) = (ILIT(1) :: FAST_INT)
- tag (UniFun _ _) = ILIT(2)
- tag (UniData _ _) = ILIT(3)
- tag (UniDict _ _) = ILIT(4)
- tag (UniForall _ _) = ILIT(5)
- tag (UniTyVarTemplate _) = ILIT(6)
- tag (UniSyn _ _ _) = ILIT(7)
-
- cmp_tv_tmpl :: TyVarTemplate -> TyVarTemplate -> TAG_
- cmp_tv_tmpl tv1 tv2
- = if tv1 == tv2 then EQ_ else if tv1 < tv2 then LT_ else GT_
-
- cmp_ty_lists equivs [] [] = EQ_
- cmp_ty_lists equivs (x:xs) [] = GT_
- cmp_ty_lists equivs [] (y:ys) = LT_
- cmp_ty_lists equivs (x:xs) (y:ys)
- = case cmp_ty equivs x y of { EQ_ -> cmp_ty_lists equivs xs ys; other -> other }
-\end{code}
-
-\begin{code}
-instance Eq UniType where
- a == b = case cmpUniType True{-properly-} a b of { EQ_ -> True; _ -> False }
- a /= b = case cmpUniType True{-properly-} a b of { EQ_ -> False; _ -> True }
-\end{code}
-
-Useful synonyms:
-
-\begin{code}
-type SigmaType = UniType
-type RhoType = UniType -- No UniForall, UniTyVarTemplate
-type TauType = UniType -- No UniDict constructors either
-type ThetaType = [(Class, TauType)] -- No UniForalls in the UniTypes
-
-type InstTyEnv = [(TyVarTemplate, TauType)] -- Used for instantiating types
-\end{code}
-
-Using @UniType@, a @SigmaType@ such as (Eq a) => a -> [a]
-is written as
-\begin{verbatim}
-UniForall TyVarTemplate
- (UniFun (UniDict Class (UniTyVarTemplate TyVarTemplate))
- (UniFun (UniTyVarTemplate TyVarTemplate)
- (UniData TyCon [(UniTyVar TyVarTemplate)])))
-\end{verbatim}
-
-NB: @mkFunTy@ comes from the prelude.
-
-\begin{code}
-mkTyVarTy = UniTyVar
-mkTyVarTemplateTy = UniTyVarTemplate
-mkDictTy = UniDict
--- use applyTyCon to make UniDatas and UniSyns
-
-alpha = UniTyVarTemplate alpha_tv
-beta = UniTyVarTemplate beta_tv
-gamma = UniTyVarTemplate gamma_tv
-delta = UniTyVarTemplate delta_tv
-epsilon = UniTyVarTemplate epsilon_tv
-
-alpha_ty = UniTyVar alpha_tyvar
-beta_ty = UniTyVar beta_tyvar
-gamma_ty = UniTyVar gamma_tyvar
-delta_ty = UniTyVar delta_tyvar
-epsilon_ty = UniTyVar epsilon_tyvar
-
-mkRhoTy :: ThetaType -> TauType -> RhoType
-mkRhoTy theta tau
- = foldr mk_dict tau theta
- where
- mk_dict (clas,ty) ty_body = UniFun (UniDict clas ty) ty_body
-
-mkForallTy [] ty = ty
-mkForallTy tyvars ty = foldr UniForall ty tyvars
-
-mkSigmaTy :: [TyVarTemplate] -> ThetaType -> TauType -> SigmaType
-mkSigmaTy tyvars theta tau = foldr UniForall (mkRhoTy theta tau) tyvars
-\end{code}
-
-@quantifyTy@ takes @TyVars@ (not templates) and a @SigmaType@, and quantifies
-over them. It makes new template type variables, and substitutes for the
-original variables in the body.
-
-\begin{code}
-quantifyTy :: [TyVar] -> SigmaType -> ([TyVarTemplate], SigmaType)
-
-quantifyTy [] ty = ([], ty) -- Simple, common case
-
-quantifyTy tyvars ty
- = (templates, foldr UniForall (quant ty) templates)
- where
- templates = mkTemplateTyVars tyvars
- env = tyvars `zip` (map UniTyVarTemplate templates)
-
- quant :: SigmaType -> SigmaType -- Rename the quantified type variables
- -- to their template equivalents
-
- quant old_ty@(UniTyVar v) = case (assocMaybe env v) of
- Nothing -> old_ty -- We may not be quantifying
- -- over all the type vars!
- Just ty -> ty
-
- quant ty@(UniTyVarTemplate v) = ty
- quant ty@(UniData con []) = ty
- quant (UniData con tys) = UniData con (map quant tys)
- quant (UniSyn con tys ty) = UniSyn con (map quant tys) (quant ty)
- quant (UniFun ty1 ty2) = UniFun (quant ty1) (quant ty2)
- quant (UniDict clas ty) = UniDict clas (quant ty)
-
- quant (UniForall tv ty) =
-#ifdef DEBUG
- -- Paranoia check here; shouldn't happen
- if tv `elem` templates then
- panic "quantifyTy"
- else
-#endif
- UniForall tv (quant ty)
-\end{code}
-
-@instantiateTy@ is the inverse. It instantiates the free @TyVarTemplates@
-of a type. We assume that no inner Foralls bind one of the variables
-being instantiated.
-
-\begin{code}
-instantiateTy :: InstTyEnv -> UniType -> UniType
-
-instantiateTy [] ty = ty -- Simple, common case
-
-instantiateTy env ty
- = inst ty
- where
- inst ty@(UniTyVar v) = ty
- inst ty@(UniData con []) = ty
- inst (UniData con tys) = UniData con (map inst tys)
- inst (UniFun ty1 ty2) = UniFun (inst ty1) (inst ty2)
- inst (UniSyn con tys ty) = UniSyn con (map inst tys) (inst ty)
- inst (UniDict clas ty) = UniDict clas (inst ty)
- inst (UniForall v ty) = UniForall v (inst ty)
-
- inst old_ty@(UniTyVarTemplate v) = case (assocMaybe env v) of
- Nothing -> old_ty -- May partially instantiate
- Just ty -> ty
-\end{code}
-The case mentioned in the comment (ie when the template isn't in the envt)
-occurs when we instantiate a class op type before instantiating with the class
-variable itself.
-\begin{code}
-instantiateTauTy :: InstTyEnv -> TauType -> TauType
-instantiateTauTy tenv ty = instantiateTy tenv ty
-
-instantiateThetaTy :: InstTyEnv -> ThetaType -> ThetaType
-instantiateThetaTy tenv theta
- = [(clas,instantiateTauTy tenv ty) | (clas,ty) <- theta]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[UniType-instances]{Instance declarations for @UniType@}
-%* *
-%************************************************************************
-
-\begin{code}
-instance Outputable UniType where
- ppr = pprUniType
-\end{code}
+++ /dev/null
-#if IncludeTestDirsInBuild == YES
-#define IHaveSubdirs
-#define __ghc_parser_tests_dir tests
-#else
-#define __ghc_parser_tests_dir /* nothing */
-#endif
-
-SUBDIRS = __ghc_parser_tests_dir
-
-/* only subdir is the test suite */
-#define NoAllTargetForSubdirs
-#define NoDocsTargetForSubdirs
-#define NoInstallTargetForSubdirs
-#define NoInstallDocsTargetForSubdirs
-#define NoDependTargetForSubdirs
-#define NoTagTargetForSubdirs
-
-YACC_OPTS = -d
-/* add to this on the command line with, e.g., EXTRA_YACC_OPTS=-v */
-
-#if BuildDataParallelHaskell == YES
-D_DPH = -DDPH
-#endif
-
-XCOMM D_DEBUG = -DDEBUG
-
-CPP_DEFINES = $(D_DEBUG) $(D_DPH)
-
-HSP_SRCS_C = /*main.c*/ hsparser.tab.c hslexer.c id.c atype.c ttype.c \
- tree.c literal.c coresyn.c list.c binding.c pbinding.c hpragma.c impidt.c \
- finfot.c util.c entidt.c syntax.c type2context.c import_dirlist.c infix.c printtree.c
-
-HSP_OBJS_O = /*main.o*/ hsparser.tab.o hslexer.o id.o atype.o ttype.o \
- tree.o literal.o coresyn.o list.o binding.o pbinding.o hpragma.o impidt.o \
- finfot.o util.o entidt.o syntax.o type2context.o import_dirlist.o infix.o printtree.o
-
-/* DPH uses some tweaked files; here are the lists again... */
-
-#if BuildDataParallelHaskell == YES
-DPH_HSP_SRCS_C = main.c hsparser-DPH.tab.c hslexer-DPH.c id.c atype.c ttype-DPH.c \
- tree-DPH.c literal.c coresyn.c list.c binding.c pbinding.c hpragma.c impidt.c \
- finfot.c util.c entidt.c syntax.c type2context.c import_dirlist.c infix.c printtree.c
-
-DPH_HSP_OBJS_O = main.o hsparser-DPH.tab.o hslexer-DPH.o id.o atype.o ttype-DPH.o \
- tree-DPH.o literal.o coresyn.o list.o binding.o pbinding.o hpragma.o impidt.o \
- finfot.o util.o entidt.o syntax.o type2context.o import_dirlist.o infix.o printtree.o
-#endif
-
-/* this is for etags */
-REAL_HSP_SRCS_C = main.c id.c \
- util.c syntax.c type2context.c import_dirlist.c infix.c printtree.c
-
-UgenNeededHere(all depend)
-
-BuildPgmFromCFiles(hsp,main.o,$(FLEX_LIB),libhsp.a)
-#if BuildDataParallelHaskell == YES
-BuildPgmFromCFiles(dphsp,$(DPH_HSP_OBJS_O),$(LEX_LIB),)
-#endif
-
-/* Most hsp files are in libhsp.a, so we can either make
- a standalone parser, or incorporate the files into
- the hsc compiler directly (WDP 94/10)
-*/
-NormalLibraryTarget(hsp,$(HSP_OBJS_O))
-
-#if DoInstallGHCSystem == YES
-MakeDirectories(install, $(INSTLIBDIR_GHC))
-InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC))
-#if BuildDataParallelHaskell == YES
-InstallBinaryTarget(dphsp,$(INSTLIBDIR_GHC))
-#endif
-#endif /* DoInstall... */
-
-YaccRunWithExpectMsg(hsparser,13,2)
-
-UgenTarget(atype)
-UgenTarget(binding)
-UgenTarget(coresyn)
-UgenTarget(entidt)
-UgenTarget(finfot)
-UgenTarget(impidt)
-UgenTarget(literal)
-UgenTarget(list)
-UgenTarget(pbinding)
-UgenTarget(hpragma)
-UgenTarget(tree)
-UgenTarget(ttype)
-
-#if BuildDataParallelHaskell == YES
-YaccRunWithExpectMsg(hsparser-DPH,12,4)
-UgenTarget(tree-DPH)
-UgenTarget(ttype-DPH)
-#endif
-
-CDependTarget( $(HSP_SRCS_C) )
-
-ExtraStuffToClean( y.output )
-ExtraStuffToBeVeryClean( $(STD_VERY_CLEAN) hsparser.tab.* hsparser-DPH.tab.* hslexer.c hslexer-DPH.c )
-
-EtagsNeededHere(tags) /* need this to do "make tags" */
-ClearTagsFile()
-CTagsTarget( *.y *.lex *.ugn $(REAL_HSP_SRCS_C) )
-
-
-
-
-
-
-
-
-
-
+++ /dev/null
-Return-Path: mattson@dcs.gla.ac.uk
-Return-Path: <mattson@dcs.gla.ac.uk>
-Received: from starbuck.dcs.gla.ac.uk by goggins.dcs.gla.ac.uk
- with LOCAL SMTP (PP) id <02535-0@goggins.dcs.gla.ac.uk>;
- Thu, 18 Nov 1993 09:59:57 +0000
-To: Robert.Corbett@Eng.Sun.COM
-cc: partain@dcs.gla.ac.uk
-Subject: Re: [Robert.Corbett@Eng.Sun.COM: Re: possible bug, byacc 1.9]
-In-reply-to: Your message from 9:46 AM GMT
-Date: Thu, 18 Nov 93 09:59:53 +0000
-From: Jim Mattson <mattson@dcs.gla.ac.uk>
-
-It's clear that this feature improves error detection, but it's not
-clear to me how it improves the scope of possible error recoveries.
-
-If I understand your explanation, it sounds like the only alternative
-(short of changing the byacc source) is to add tens or hundreds of
-error productions sprinkled throughout the code anywhere that an
-unexpected symbol may appear, since no intervening reductions are
-allowed.
-
-Although the addition of all of these error productions increases the
-scope of possible error recoveries, the same functionality (with, in fact,
-the same approach) is provided by other versions of yacc. The apparent
-advantage of other versions of yacc is that they provide a facility by
-which a single _default_ error production can handle a number of
-possibilities (after some possibly illegal reductions have been performed).
-
-Am I missing something?
-
---jim
---------
-In reply to the following message:
---------
-
-------- Forwarded Message
-
-Date: Wed, 17 Nov 93 22:33:44 PST
-From: Robert.Corbett@Eng.Sun.COM (Robert Corbett)
-Message-Id: <9311180633.AA07545@lupa.Eng.Sun.COM>
-To: partain@dcs.gla.ac.uk
-Subject: Re: possible bug, byacc 1.9
-
-It is a feature. One difference between Berkeley Yacc and its
-predecessors is that the parsers Berkeley Yacc produces detect
-errors as soon as possible. That will lead to different behavior.
-
-In this particular case, the token "IN" is not a permitted
-lookahead symbol in state 390. AT&T Yacc parsers will not detect
-the error until after doing more reductions than Berkeley Yacc
-parsers. Doing reductions in illegal contexts limits the scope of
-recoveries that are possible (unless backtracking is possible).
-
-I am sorry that my attempt to provide better error detection is
-causing you trouble. You can get the AT&T Yacc behavior by
-replacing the routine sole_reduction in mkpar.c with a routine
-that returns the most frequently occurring reduction.
-
- Yours truly,
- Bob Corbett
-
-- ----- Begin Included Message -----
-
->From partain@dcs.gla.ac.uk Wed Nov 17 05:03:44 1993
-To: robert.corbett@Eng
-Subject: possible bug, byacc 1.9
-Date: Wed, 17 Nov 93 12:33:42 +0000
-From: Will Partain <partain@dcs.gla.ac.uk>
-
-Sadly, it's in a *HUGE* grammar, which I will send you if you have the
-stomach for it.
-
-The problem occurs where {Sun's /usr/lang/yacc, bison} say:
-
- state 390
-
- aexp -> var . (rule 356)
- aexp -> var . AT aexp (rule 366)
-
- AT shift, and go to state 508
- $default reduce using rule 356 (aexp)
-
-but byacc says
-
- state 396
- aexp : var . (356)
- aexp : var . AT aexp (366)
-
- AT shift 511
- error reduce 356
- VARID reduce 356
- CONID reduce 356
- VARSYM reduce 356
- CONSYM reduce 356
- MINUS reduce 356
- INTEGER reduce 356
- FLOAT reduce 356
- CHAR reduce 356
- STRING reduce 356
- CHARPRIM reduce 356
- INTPRIM reduce 356
- FLOATPRIM reduce 356
- DOUBLEPRIM reduce 356
- CLITLIT reduce 356
- VOIDPRIM reduce 356
- CCURLY reduce 356
- VCCURLY reduce 356
- SEMI reduce 356
- OBRACK reduce 356
- CBRACK reduce 356
- OPAREN reduce 356
- CPAREN reduce 356
- COMMA reduce 356
- BQUOTE reduce 356
- RARROW reduce 356
- VBAR reduce 356
- EQUAL reduce 356
- DOTDOT reduce 356
- DCOLON reduce 356
- LARROW reduce 356
- WILDCARD reduce 356
- LAZY reduce 356
- WHERE reduce 356
- OF reduce 356
- THEN reduce 356
- ELSE reduce 356
- PLUS reduce 356
-
-The token that comes in is "IN"; bison/sun-yacc-generated parser
-tickles the default, reduces to "aexp", but byacc-generated tickles
-"error" and the rest is history.
-
-Maybe this is enough for you to exclaim, "Oh yes, that's a feature."
-
-As I say, more info if you want it.
-
-Will Partain
-
-
-- ----- End Included Message -----
-
-
-
-------- End of Forwarded Message
-
---------
+++ /dev/null
-The *-DPH.* files are for parsing Jon Hill's "Data Parallel Haskell"
-variant. These notes indicate the differences from the regular
-parser. If they are much changed from what's below, someone probably
-needs to do some work.
-
-Note: you should also "grep" for "#ifdef DPH" in the C source files...
-
-Will Partain
-
-foreach i ( ttype.ugn tree.ugn hslexer.lex hsparser.y )
- set base=$i:r
- set suff=$i:e
- diff -c2 $i $base-DPH.$suff
-end
-
-*** ttype.ugn Thu Nov 21 18:54:47 1991
---- ttype-DPH.ugn Thu Jul 9 10:38:59 1992
-***************
-*** 12,15 ****
---- 12,18 ----
- context : < gtcontextl : list;
- gtcontextt : ttype; >;
-+ tproc : < gtpid : list;
-+ gtdata : ttype; >;
-+ tpod : < gtpod : ttype; >;
- end;
-
-*** tree.ugn Thu May 14 17:13:43 1992
---- tree-DPH.ugn Thu Jul 9 10:39:04 1992
-***************
-*** 62,64 ****
---- 62,75 ----
- gsccexp : tree; >;
- negate : < gnexp : tree; >;
-+ parzf : < gpzfexp : tree;
-+ gpzfqual : list; >;
-+ pardgen : < gdproc : tree;
-+ gdexp : tree; >;
-+ parigen : < giproc : tree;
-+ giexp : tree; >;
-+ parfilt : < gpfilt : tree; >;
-+ pod : < gpod : list; >;
-+ proc : < gpid : list;
-+ gpdata : tree; >;
-+
- end;
-*** hslexer.lex Wed Jun 3 20:56:01 1992
---- hslexer-DPH.lex Thu Jul 9 10:45:03 1992
-***************
-*** 17,20 ****
---- 17,21 ----
- * 04/12/91 kh Added Int#. *
- * 31/01/92 kh Haskell 1.2 version. *
-+ * 19/03/92 Jon Hill Added Data Parallel Notation *
- * 24/04/92 ps Added 'scc'. *
- * 03/06/92 kh Changed Infix/Prelude Handling. *
-***************
-*** 560,563 ****
---- 561,570 ----
- "_" { RETURN(WILDCARD); }
- "`" { RETURN(BQUOTE); }
-+ "<<" { RETURN(OPOD); }
-+ ">>" { RETURN(CPOD); }
-+ "(|" { RETURN(OPROC); }
-+ "|)" { RETURN(CPROC); }
-+ "<<-" { RETURN(DRAWNFROM); }
-+ "<<=" { RETURN(INDEXFROM); }
-
- <PRIM>("-")?{N}"#" {
-*** hsparser.y Thu Jul 9 10:58:27 1992
---- hsparser-DPH.y Thu Jul 9 10:49:12 1992
-***************
-*** 5,9 ****
- * Modified by: Kevin Hammond *
- * Last date revised: December 13 1991. KH. *
-! * Modification: Haskell 1.1 Syntax. *
- * *
- * *
---- 5,10 ----
- * Modified by: Kevin Hammond *
- * Last date revised: December 13 1991. KH. *
-! * Modification: o Haskell 1.1 Syntax. *
-! * o Data Parallel Syntax. *
- * *
- * *
-***************
-*** 15,19 ****
- * *
- * *
-! * LALR(1) Syntax for Haskell 1.2 *
- * *
- **************************************************************************/
---- 16,20 ----
- * *
- * *
-! * LALR(1) Syntax for Haskell 1.2 + Data Parallelism *
- * *
- **************************************************************************/
-***************
-*** 146,149 ****
---- 147,151 ----
- %token OBRACK CBRACK OPAREN CPAREN
- %token COMMA BQUOTE
-+ %token OPOD CPOD OPROC CPROC
-
-
-***************
-*** 160,163 ****
---- 162,166 ----
- %token DCOLON LARROW
- %token WILDCARD AT LAZY LAMBDA
-+ %token DRAWNFROM INDEXFROM
-
-
-***************
-*** 210,213 ****
---- 213,218 ----
- %left OCURLY OBRACK OPAREN
-
-+ %left OPOD OPROC
-+
- %left EQUAL
-
-***************
-*** 238,241 ****
---- 243,248 ----
- upto
- cexp
-+ tyvar_pids
-+ parquals
-
-
-***************
-*** 246,249 ****
---- 253,257 ----
- dpatk fpatk opatk aapatk
- texps
-+ processor parqual
-
- %type <uid> MINUS VARID CONID VARSYM CONSYM
-***************
-*** 605,610 ****
---- 613,629 ----
- | OBRACK tyvar CBRACK { $$ = mktllist($2); }
- | OPAREN tyvar RARROW tyvar CPAREN { $$ = mktfun($2,$4); }
-+ | OPOD tyvar CPOD { $$ = mktpod($2); }
-+ | OPROC tyvar_pids SEMI tyvar CPROC { $$ = mktproc($2,$4); }
-+ | OPOD tyvar_pids SEMI tyvar CPOD { $$ = mktpod(mktproc($2,$4));}
-+ | OPOD OPROC tyvar_pids SEMI tyvar CPROC CPOD
-+ { $$ = mktpod(mktproc($3,$5)); }
- ;
-
-+ /* Note (hilly) : Similar to tyvar_list except k>=1 not k>=2 */
-+
-+ tyvar_pids : tyvar COMMA tyvar_pids { $$ = mklcons($1,$3); }
-+ | tyvar { $$ = lsing($1); }
-+ ;
-+
- defaultd: defaultkey dtypes
- {
-***************
-*** 740,743 ****
---- 759,765 ----
- | OPAREN type CPAREN { $$ = $2; }
- | OBRACK type CBRACK { $$ = mktllist($2); }
-+ | OPOD type CPOD { $$ = mktpod($2); }
-+ | OPROC types SEMI type CPROC { $$ = mktproc($2,$4); }
-+ | OPOD types SEMI type CPOD { $$ = mktpod(mktproc($2,$4));}
- ;
-
-***************
-*** 1027,1030 ****
---- 1049,1055 ----
- | sequence { $$ = mkpar($1); }
- | comprehension { $$ = mkpar($1); }
-+ | OPOD exp VBAR parquals CPOD { $$ = mkparzf($2,$4); }
-+ | OPOD exps CPOD { $$ = mkpod($2); }
-+ | processor { $$ = mkpar($1); }
-
- /* These only occur in patterns */
-***************
-*** 1035,1038 ****
---- 1060,1076 ----
-
-
-+ processor : OPROC exps SEMI exp CPROC { $$ = mkproc($2,$4); }
-+ ;
-+
-+ parquals : parquals COMMA parqual { $$ = lapp($1,$3); }
-+ | parqual { $$ = lsing($1); }
-+ ;
-+
-+ parqual : exp { $$ = mkparfilt($1); }
-+ | processor DRAWNFROM exp { $$ = mkpardgen($1,$3); }
-+ | processor INDEXFROM exp { $$ = mkparigen($1,$3); }
-+ ;
-+
-+
- /*
- LHS patterns are parsed in a similar way to
-***************
-*** 1131,1134 ****
---- 1169,1173 ----
- | OBRACK CBRACK { $$ = mkllist(Lnil); }
- | LAZY apat { $$ = mklazyp($2); }
-+ | OPROC pats SEMI apat CPROC { $$ = mkproc($2,$4); }
- ;
-
-***************
-*** 1146,1149 ****
---- 1185,1189 ----
- | obrackkey CBRACK { $$ = mkllist(Lnil); }
- | lazykey apat { $$ = mklazyp($2); }
-+ | oprockey pats SEMI opat CPROC { $$ = mkproc($2,$4); }
- ;
-
-***************
-*** 1283,1286 ****
---- 1323,1327 ----
- | OBRACK CBRACK { $$ = mkllist(Lnil); }
- | LAZY apat { $$ = mklazyp($2); }
-+ | OPROC pats SEMI apat CPROC { $$ = mkproc($2,$4); }
- ;
-
-***************
-*** 1312,1315 ****
---- 1353,1357 ----
- | obrackkey CBRACK { $$ = mkllist(Lnil); }
- | lazykey apat { $$ = mklazyp($2); }
-+ | oprockey pats SEMI opat CPROC { $$ = mkproc($2,$4); }
- ;
- */
-***************
-*** 1372,1375 ****
---- 1414,1419 ----
- ;
-
-+ oprockey: OPROC { setstartlineno(); }
-+ ;
-
-
+++ /dev/null
-If you want to debug...
-
-* the lexer:
-
- run "flex" with the -d flag; compile as normal thereafter
-
-* the parser:
-
- compile hsparser.tab.c and main.c with EXTRA_CC_OPTS=-DHSP_DEBUG
-
- run hsp with -D; it's dumping the output into *stdout*,
- so you have to do something weird to look at it.
+++ /dev/null
-
-
-module U_atype where
-import UgenUtil
-import Util
-
-import U_list
-data U_atype = U_atc U_unkId U_list U_long
-
-rdU_atype :: _Addr -> UgnM U_atype
-rdU_atype t
- = ioToUgnM (_ccall_ tatype t) `thenUgn` \ tag@(I# _) ->
- if tag == ``atc'' then
- ioToUgnM (_ccall_ gatcid t) `thenUgn` \ x_gatcid ->
- rdU_unkId x_gatcid `thenUgn` \ y_gatcid ->
- ioToUgnM (_ccall_ gatctypel t) `thenUgn` \ x_gatctypel ->
- rdU_list x_gatctypel `thenUgn` \ y_gatctypel ->
- ioToUgnM (_ccall_ gatcline t) `thenUgn` \ x_gatcline ->
- rdU_long x_gatcline `thenUgn` \ y_gatcline ->
- returnUgn (U_atc y_gatcid y_gatctypel y_gatcline)
- else
- error ("rdU_atype: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_binding where
-import UgenUtil
-import Util
-
-import U_coresyn ( U_coresyn ) -- for interfaces only
-import U_hpragma
-import U_list
-import U_literal ( U_literal ) -- for interfaces only
-import U_ttype
-data U_binding = U_tbind U_list U_ttype U_list U_list U_long U_hpragma | U_nbind U_ttype U_ttype U_long U_hpragma | U_pbind U_list U_long | U_fbind U_list U_long | U_abind U_binding U_binding | U_ibind U_list U_unkId U_ttype U_binding U_long U_hpragma | U_dbind U_list U_long | U_cbind U_list U_ttype U_binding U_long U_hpragma | U_sbind U_list U_ttype U_long U_hpragma | U_mbind U_stringId U_list U_list U_long | U_nullbind | U_import U_stringId U_list U_list U_binding U_stringId U_long | U_hiding U_stringId U_list U_list U_binding U_stringId U_long | U_vspec_uprag U_unkId U_list U_long | U_vspec_ty_and_id U_ttype U_list | U_ispec_uprag U_unkId U_ttype U_long | U_inline_uprag U_unkId U_list U_long | U_deforest_uprag U_unkId U_long | U_magicuf_uprag U_unkId U_stringId U_long | U_abstract_uprag U_unkId U_long | U_dspec_uprag U_unkId U_list U_long
-
-rdU_binding :: _Addr -> UgnM U_binding
-rdU_binding t
- = ioToUgnM (_ccall_ tbinding t) `thenUgn` \ tag@(I# _) ->
- if tag == ``tbind'' then
- ioToUgnM (_ccall_ gtbindc t) `thenUgn` \ x_gtbindc ->
- rdU_list x_gtbindc `thenUgn` \ y_gtbindc ->
- ioToUgnM (_ccall_ gtbindid t) `thenUgn` \ x_gtbindid ->
- rdU_ttype x_gtbindid `thenUgn` \ y_gtbindid ->
- ioToUgnM (_ccall_ gtbindl t) `thenUgn` \ x_gtbindl ->
- rdU_list x_gtbindl `thenUgn` \ y_gtbindl ->
- ioToUgnM (_ccall_ gtbindd t) `thenUgn` \ x_gtbindd ->
- rdU_list x_gtbindd `thenUgn` \ y_gtbindd ->
- ioToUgnM (_ccall_ gtline t) `thenUgn` \ x_gtline ->
- rdU_long x_gtline `thenUgn` \ y_gtline ->
- ioToUgnM (_ccall_ gtpragma t) `thenUgn` \ x_gtpragma ->
- rdU_hpragma x_gtpragma `thenUgn` \ y_gtpragma ->
- returnUgn (U_tbind y_gtbindc y_gtbindid y_gtbindl y_gtbindd y_gtline y_gtpragma)
- else if tag == ``nbind'' then
- ioToUgnM (_ccall_ gnbindid t) `thenUgn` \ x_gnbindid ->
- rdU_ttype x_gnbindid `thenUgn` \ y_gnbindid ->
- ioToUgnM (_ccall_ gnbindas t) `thenUgn` \ x_gnbindas ->
- rdU_ttype x_gnbindas `thenUgn` \ y_gnbindas ->
- ioToUgnM (_ccall_ gnline t) `thenUgn` \ x_gnline ->
- rdU_long x_gnline `thenUgn` \ y_gnline ->
- ioToUgnM (_ccall_ gnpragma t) `thenUgn` \ x_gnpragma ->
- rdU_hpragma x_gnpragma `thenUgn` \ y_gnpragma ->
- returnUgn (U_nbind y_gnbindid y_gnbindas y_gnline y_gnpragma)
- else if tag == ``pbind'' then
- ioToUgnM (_ccall_ gpbindl t) `thenUgn` \ x_gpbindl ->
- rdU_list x_gpbindl `thenUgn` \ y_gpbindl ->
- ioToUgnM (_ccall_ gpline t) `thenUgn` \ x_gpline ->
- rdU_long x_gpline `thenUgn` \ y_gpline ->
- returnUgn (U_pbind y_gpbindl y_gpline)
- else if tag == ``fbind'' then
- ioToUgnM (_ccall_ gfbindl t) `thenUgn` \ x_gfbindl ->
- rdU_list x_gfbindl `thenUgn` \ y_gfbindl ->
- ioToUgnM (_ccall_ gfline t) `thenUgn` \ x_gfline ->
- rdU_long x_gfline `thenUgn` \ y_gfline ->
- returnUgn (U_fbind y_gfbindl y_gfline)
- else if tag == ``abind'' then
- ioToUgnM (_ccall_ gabindfst t) `thenUgn` \ x_gabindfst ->
- rdU_binding x_gabindfst `thenUgn` \ y_gabindfst ->
- ioToUgnM (_ccall_ gabindsnd t) `thenUgn` \ x_gabindsnd ->
- rdU_binding x_gabindsnd `thenUgn` \ y_gabindsnd ->
- returnUgn (U_abind y_gabindfst y_gabindsnd)
- else if tag == ``ibind'' then
- ioToUgnM (_ccall_ gibindc t) `thenUgn` \ x_gibindc ->
- rdU_list x_gibindc `thenUgn` \ y_gibindc ->
- ioToUgnM (_ccall_ gibindid t) `thenUgn` \ x_gibindid ->
- rdU_unkId x_gibindid `thenUgn` \ y_gibindid ->
- ioToUgnM (_ccall_ gibindi t) `thenUgn` \ x_gibindi ->
- rdU_ttype x_gibindi `thenUgn` \ y_gibindi ->
- ioToUgnM (_ccall_ gibindw t) `thenUgn` \ x_gibindw ->
- rdU_binding x_gibindw `thenUgn` \ y_gibindw ->
- ioToUgnM (_ccall_ giline t) `thenUgn` \ x_giline ->
- rdU_long x_giline `thenUgn` \ y_giline ->
- ioToUgnM (_ccall_ gipragma t) `thenUgn` \ x_gipragma ->
- rdU_hpragma x_gipragma `thenUgn` \ y_gipragma ->
- returnUgn (U_ibind y_gibindc y_gibindid y_gibindi y_gibindw y_giline y_gipragma)
- else if tag == ``dbind'' then
- ioToUgnM (_ccall_ gdbindts t) `thenUgn` \ x_gdbindts ->
- rdU_list x_gdbindts `thenUgn` \ y_gdbindts ->
- ioToUgnM (_ccall_ gdline t) `thenUgn` \ x_gdline ->
- rdU_long x_gdline `thenUgn` \ y_gdline ->
- returnUgn (U_dbind y_gdbindts y_gdline)
- else if tag == ``cbind'' then
- ioToUgnM (_ccall_ gcbindc t) `thenUgn` \ x_gcbindc ->
- rdU_list x_gcbindc `thenUgn` \ y_gcbindc ->
- ioToUgnM (_ccall_ gcbindid t) `thenUgn` \ x_gcbindid ->
- rdU_ttype x_gcbindid `thenUgn` \ y_gcbindid ->
- ioToUgnM (_ccall_ gcbindw t) `thenUgn` \ x_gcbindw ->
- rdU_binding x_gcbindw `thenUgn` \ y_gcbindw ->
- ioToUgnM (_ccall_ gcline t) `thenUgn` \ x_gcline ->
- rdU_long x_gcline `thenUgn` \ y_gcline ->
- ioToUgnM (_ccall_ gcpragma t) `thenUgn` \ x_gcpragma ->
- rdU_hpragma x_gcpragma `thenUgn` \ y_gcpragma ->
- returnUgn (U_cbind y_gcbindc y_gcbindid y_gcbindw y_gcline y_gcpragma)
- else if tag == ``sbind'' then
- ioToUgnM (_ccall_ gsbindids t) `thenUgn` \ x_gsbindids ->
- rdU_list x_gsbindids `thenUgn` \ y_gsbindids ->
- ioToUgnM (_ccall_ gsbindid t) `thenUgn` \ x_gsbindid ->
- rdU_ttype x_gsbindid `thenUgn` \ y_gsbindid ->
- ioToUgnM (_ccall_ gsline t) `thenUgn` \ x_gsline ->
- rdU_long x_gsline `thenUgn` \ y_gsline ->
- ioToUgnM (_ccall_ gspragma t) `thenUgn` \ x_gspragma ->
- rdU_hpragma x_gspragma `thenUgn` \ y_gspragma ->
- returnUgn (U_sbind y_gsbindids y_gsbindid y_gsline y_gspragma)
- else if tag == ``mbind'' then
- ioToUgnM (_ccall_ gmbindmodn t) `thenUgn` \ x_gmbindmodn ->
- rdU_stringId x_gmbindmodn `thenUgn` \ y_gmbindmodn ->
- ioToUgnM (_ccall_ gmbindimp t) `thenUgn` \ x_gmbindimp ->
- rdU_list x_gmbindimp `thenUgn` \ y_gmbindimp ->
- ioToUgnM (_ccall_ gmbindren t) `thenUgn` \ x_gmbindren ->
- rdU_list x_gmbindren `thenUgn` \ y_gmbindren ->
- ioToUgnM (_ccall_ gmline t) `thenUgn` \ x_gmline ->
- rdU_long x_gmline `thenUgn` \ y_gmline ->
- returnUgn (U_mbind y_gmbindmodn y_gmbindimp y_gmbindren y_gmline)
- else if tag == ``nullbind'' then
- returnUgn (U_nullbind )
- else if tag == ``import'' then
- ioToUgnM (_ccall_ giebindmod t) `thenUgn` \ x_giebindmod ->
- rdU_stringId x_giebindmod `thenUgn` \ y_giebindmod ->
- ioToUgnM (_ccall_ giebindexp t) `thenUgn` \ x_giebindexp ->
- rdU_list x_giebindexp `thenUgn` \ y_giebindexp ->
- ioToUgnM (_ccall_ giebindren t) `thenUgn` \ x_giebindren ->
- rdU_list x_giebindren `thenUgn` \ y_giebindren ->
- ioToUgnM (_ccall_ giebinddef t) `thenUgn` \ x_giebinddef ->
- rdU_binding x_giebinddef `thenUgn` \ y_giebinddef ->
- ioToUgnM (_ccall_ giebindfile t) `thenUgn` \ x_giebindfile ->
- rdU_stringId x_giebindfile `thenUgn` \ y_giebindfile ->
- ioToUgnM (_ccall_ giebindline t) `thenUgn` \ x_giebindline ->
- rdU_long x_giebindline `thenUgn` \ y_giebindline ->
- returnUgn (U_import y_giebindmod y_giebindexp y_giebindren y_giebinddef y_giebindfile y_giebindline)
- else if tag == ``hiding'' then
- ioToUgnM (_ccall_ gihbindmod t) `thenUgn` \ x_gihbindmod ->
- rdU_stringId x_gihbindmod `thenUgn` \ y_gihbindmod ->
- ioToUgnM (_ccall_ gihbindexp t) `thenUgn` \ x_gihbindexp ->
- rdU_list x_gihbindexp `thenUgn` \ y_gihbindexp ->
- ioToUgnM (_ccall_ gihbindren t) `thenUgn` \ x_gihbindren ->
- rdU_list x_gihbindren `thenUgn` \ y_gihbindren ->
- ioToUgnM (_ccall_ gihbinddef t) `thenUgn` \ x_gihbinddef ->
- rdU_binding x_gihbinddef `thenUgn` \ y_gihbinddef ->
- ioToUgnM (_ccall_ gihbindfile t) `thenUgn` \ x_gihbindfile ->
- rdU_stringId x_gihbindfile `thenUgn` \ y_gihbindfile ->
- ioToUgnM (_ccall_ gihbindline t) `thenUgn` \ x_gihbindline ->
- rdU_long x_gihbindline `thenUgn` \ y_gihbindline ->
- returnUgn (U_hiding y_gihbindmod y_gihbindexp y_gihbindren y_gihbinddef y_gihbindfile y_gihbindline)
- else if tag == ``vspec_uprag'' then
- ioToUgnM (_ccall_ gvspec_id t) `thenUgn` \ x_gvspec_id ->
- rdU_unkId x_gvspec_id `thenUgn` \ y_gvspec_id ->
- ioToUgnM (_ccall_ gvspec_tys t) `thenUgn` \ x_gvspec_tys ->
- rdU_list x_gvspec_tys `thenUgn` \ y_gvspec_tys ->
- ioToUgnM (_ccall_ gvspec_line t) `thenUgn` \ x_gvspec_line ->
- rdU_long x_gvspec_line `thenUgn` \ y_gvspec_line ->
- returnUgn (U_vspec_uprag y_gvspec_id y_gvspec_tys y_gvspec_line)
- else if tag == ``vspec_ty_and_id'' then
- ioToUgnM (_ccall_ gvspec_ty t) `thenUgn` \ x_gvspec_ty ->
- rdU_ttype x_gvspec_ty `thenUgn` \ y_gvspec_ty ->
- ioToUgnM (_ccall_ gvspec_tyid t) `thenUgn` \ x_gvspec_tyid ->
- rdU_list x_gvspec_tyid `thenUgn` \ y_gvspec_tyid ->
- returnUgn (U_vspec_ty_and_id y_gvspec_ty y_gvspec_tyid)
- else if tag == ``ispec_uprag'' then
- ioToUgnM (_ccall_ gispec_clas t) `thenUgn` \ x_gispec_clas ->
- rdU_unkId x_gispec_clas `thenUgn` \ y_gispec_clas ->
- ioToUgnM (_ccall_ gispec_ty t) `thenUgn` \ x_gispec_ty ->
- rdU_ttype x_gispec_ty `thenUgn` \ y_gispec_ty ->
- ioToUgnM (_ccall_ gispec_line t) `thenUgn` \ x_gispec_line ->
- rdU_long x_gispec_line `thenUgn` \ y_gispec_line ->
- returnUgn (U_ispec_uprag y_gispec_clas y_gispec_ty y_gispec_line)
- else if tag == ``inline_uprag'' then
- ioToUgnM (_ccall_ ginline_id t) `thenUgn` \ x_ginline_id ->
- rdU_unkId x_ginline_id `thenUgn` \ y_ginline_id ->
- ioToUgnM (_ccall_ ginline_howto t) `thenUgn` \ x_ginline_howto ->
- rdU_list x_ginline_howto `thenUgn` \ y_ginline_howto ->
- ioToUgnM (_ccall_ ginline_line t) `thenUgn` \ x_ginline_line ->
- rdU_long x_ginline_line `thenUgn` \ y_ginline_line ->
- returnUgn (U_inline_uprag y_ginline_id y_ginline_howto y_ginline_line)
- else if tag == ``deforest_uprag'' then
- ioToUgnM (_ccall_ gdeforest_id t) `thenUgn` \ x_gdeforest_id ->
- rdU_unkId x_gdeforest_id `thenUgn` \ y_gdeforest_id ->
- ioToUgnM (_ccall_ gdeforest_line t) `thenUgn` \ x_gdeforest_line ->
- rdU_long x_gdeforest_line `thenUgn` \ y_gdeforest_line ->
- returnUgn (U_deforest_uprag y_gdeforest_id y_gdeforest_line)
- else if tag == ``magicuf_uprag'' then
- ioToUgnM (_ccall_ gmagicuf_id t) `thenUgn` \ x_gmagicuf_id ->
- rdU_unkId x_gmagicuf_id `thenUgn` \ y_gmagicuf_id ->
- ioToUgnM (_ccall_ gmagicuf_str t) `thenUgn` \ x_gmagicuf_str ->
- rdU_stringId x_gmagicuf_str `thenUgn` \ y_gmagicuf_str ->
- ioToUgnM (_ccall_ gmagicuf_line t) `thenUgn` \ x_gmagicuf_line ->
- rdU_long x_gmagicuf_line `thenUgn` \ y_gmagicuf_line ->
- returnUgn (U_magicuf_uprag y_gmagicuf_id y_gmagicuf_str y_gmagicuf_line)
- else if tag == ``abstract_uprag'' then
- ioToUgnM (_ccall_ gabstract_id t) `thenUgn` \ x_gabstract_id ->
- rdU_unkId x_gabstract_id `thenUgn` \ y_gabstract_id ->
- ioToUgnM (_ccall_ gabstract_line t) `thenUgn` \ x_gabstract_line ->
- rdU_long x_gabstract_line `thenUgn` \ y_gabstract_line ->
- returnUgn (U_abstract_uprag y_gabstract_id y_gabstract_line)
- else if tag == ``dspec_uprag'' then
- ioToUgnM (_ccall_ gdspec_id t) `thenUgn` \ x_gdspec_id ->
- rdU_unkId x_gdspec_id `thenUgn` \ y_gdspec_id ->
- ioToUgnM (_ccall_ gdspec_tys t) `thenUgn` \ x_gdspec_tys ->
- rdU_list x_gdspec_tys `thenUgn` \ y_gdspec_tys ->
- ioToUgnM (_ccall_ gdspec_line t) `thenUgn` \ x_gdspec_line ->
- rdU_long x_gdspec_line `thenUgn` \ y_gdspec_line ->
- returnUgn (U_dspec_uprag y_gdspec_id y_gdspec_tys y_gdspec_line)
- else
- error ("rdU_binding: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_coresyn where
-import UgenUtil
-import Util
-
-import U_list
-import U_literal
-import U_ttype
-data U_coresyn = U_cobinder U_unkId U_ttype | U_colit U_literal | U_colocal U_coresyn | U_cononrec U_coresyn U_coresyn | U_corec U_list | U_corec_pair U_coresyn U_coresyn | U_covar U_coresyn | U_coliteral U_literal | U_cocon U_coresyn U_list U_list | U_coprim U_coresyn U_list U_list | U_colam U_list U_coresyn | U_cotylam U_list U_coresyn | U_coapp U_coresyn U_list | U_cotyapp U_coresyn U_ttype | U_cocase U_coresyn U_coresyn | U_colet U_coresyn U_coresyn | U_coscc U_coresyn U_coresyn | U_coalg_alts U_list U_coresyn | U_coalg_alt U_coresyn U_list U_coresyn | U_coprim_alts U_list U_coresyn | U_coprim_alt U_literal U_coresyn | U_conodeflt | U_cobinddeflt U_coresyn U_coresyn | U_co_primop U_stringId | U_co_ccall U_stringId U_long U_list U_ttype | U_co_casm U_literal U_long U_list U_ttype | U_co_preludedictscc U_coresyn | U_co_alldictscc U_hstring U_hstring U_coresyn | U_co_usercc U_hstring U_hstring U_hstring U_coresyn U_coresyn | U_co_autocc U_coresyn U_hstring U_hstring U_coresyn U_coresyn | U_co_dictcc U_coresyn U_hstring U_hstring U_coresyn U_coresyn | U_co_scc_noncaf | U_co_scc_caf | U_co_scc_nondupd | U_co_scc_dupd | U_co_id U_stringId | U_co_orig_id U_stringId U_stringId | U_co_sdselid U_unkId U_unkId | U_co_classopid U_unkId U_unkId | U_co_defmid U_unkId U_unkId | U_co_dfunid U_unkId U_ttype | U_co_constmid U_unkId U_unkId U_ttype | U_co_specid U_coresyn U_list | U_co_wrkrid U_coresyn
-
-rdU_coresyn :: _Addr -> UgnM U_coresyn
-rdU_coresyn t
- = ioToUgnM (_ccall_ tcoresyn t) `thenUgn` \ tag@(I# _) ->
- if tag == ``cobinder'' then
- ioToUgnM (_ccall_ gcobinder_v t) `thenUgn` \ x_gcobinder_v ->
- rdU_unkId x_gcobinder_v `thenUgn` \ y_gcobinder_v ->
- ioToUgnM (_ccall_ gcobinder_ty t) `thenUgn` \ x_gcobinder_ty ->
- rdU_ttype x_gcobinder_ty `thenUgn` \ y_gcobinder_ty ->
- returnUgn (U_cobinder y_gcobinder_v y_gcobinder_ty)
- else if tag == ``colit'' then
- ioToUgnM (_ccall_ gcolit t) `thenUgn` \ x_gcolit ->
- rdU_literal x_gcolit `thenUgn` \ y_gcolit ->
- returnUgn (U_colit y_gcolit)
- else if tag == ``colocal'' then
- ioToUgnM (_ccall_ gcolocal_v t) `thenUgn` \ x_gcolocal_v ->
- rdU_coresyn x_gcolocal_v `thenUgn` \ y_gcolocal_v ->
- returnUgn (U_colocal y_gcolocal_v)
- else if tag == ``cononrec'' then
- ioToUgnM (_ccall_ gcononrec_b t) `thenUgn` \ x_gcononrec_b ->
- rdU_coresyn x_gcononrec_b `thenUgn` \ y_gcononrec_b ->
- ioToUgnM (_ccall_ gcononrec_rhs t) `thenUgn` \ x_gcononrec_rhs ->
- rdU_coresyn x_gcononrec_rhs `thenUgn` \ y_gcononrec_rhs ->
- returnUgn (U_cononrec y_gcononrec_b y_gcononrec_rhs)
- else if tag == ``corec'' then
- ioToUgnM (_ccall_ gcorec t) `thenUgn` \ x_gcorec ->
- rdU_list x_gcorec `thenUgn` \ y_gcorec ->
- returnUgn (U_corec y_gcorec)
- else if tag == ``corec_pair'' then
- ioToUgnM (_ccall_ gcorec_b t) `thenUgn` \ x_gcorec_b ->
- rdU_coresyn x_gcorec_b `thenUgn` \ y_gcorec_b ->
- ioToUgnM (_ccall_ gcorec_rhs t) `thenUgn` \ x_gcorec_rhs ->
- rdU_coresyn x_gcorec_rhs `thenUgn` \ y_gcorec_rhs ->
- returnUgn (U_corec_pair y_gcorec_b y_gcorec_rhs)
- else if tag == ``covar'' then
- ioToUgnM (_ccall_ gcovar t) `thenUgn` \ x_gcovar ->
- rdU_coresyn x_gcovar `thenUgn` \ y_gcovar ->
- returnUgn (U_covar y_gcovar)
- else if tag == ``coliteral'' then
- ioToUgnM (_ccall_ gcoliteral t) `thenUgn` \ x_gcoliteral ->
- rdU_literal x_gcoliteral `thenUgn` \ y_gcoliteral ->
- returnUgn (U_coliteral y_gcoliteral)
- else if tag == ``cocon'' then
- ioToUgnM (_ccall_ gcocon_con t) `thenUgn` \ x_gcocon_con ->
- rdU_coresyn x_gcocon_con `thenUgn` \ y_gcocon_con ->
- ioToUgnM (_ccall_ gcocon_tys t) `thenUgn` \ x_gcocon_tys ->
- rdU_list x_gcocon_tys `thenUgn` \ y_gcocon_tys ->
- ioToUgnM (_ccall_ gcocon_args t) `thenUgn` \ x_gcocon_args ->
- rdU_list x_gcocon_args `thenUgn` \ y_gcocon_args ->
- returnUgn (U_cocon y_gcocon_con y_gcocon_tys y_gcocon_args)
- else if tag == ``coprim'' then
- ioToUgnM (_ccall_ gcoprim_op t) `thenUgn` \ x_gcoprim_op ->
- rdU_coresyn x_gcoprim_op `thenUgn` \ y_gcoprim_op ->
- ioToUgnM (_ccall_ gcoprim_tys t) `thenUgn` \ x_gcoprim_tys ->
- rdU_list x_gcoprim_tys `thenUgn` \ y_gcoprim_tys ->
- ioToUgnM (_ccall_ gcoprim_args t) `thenUgn` \ x_gcoprim_args ->
- rdU_list x_gcoprim_args `thenUgn` \ y_gcoprim_args ->
- returnUgn (U_coprim y_gcoprim_op y_gcoprim_tys y_gcoprim_args)
- else if tag == ``colam'' then
- ioToUgnM (_ccall_ gcolam_vars t) `thenUgn` \ x_gcolam_vars ->
- rdU_list x_gcolam_vars `thenUgn` \ y_gcolam_vars ->
- ioToUgnM (_ccall_ gcolam_body t) `thenUgn` \ x_gcolam_body ->
- rdU_coresyn x_gcolam_body `thenUgn` \ y_gcolam_body ->
- returnUgn (U_colam y_gcolam_vars y_gcolam_body)
- else if tag == ``cotylam'' then
- ioToUgnM (_ccall_ gcotylam_tvs t) `thenUgn` \ x_gcotylam_tvs ->
- rdU_list x_gcotylam_tvs `thenUgn` \ y_gcotylam_tvs ->
- ioToUgnM (_ccall_ gcotylam_body t) `thenUgn` \ x_gcotylam_body ->
- rdU_coresyn x_gcotylam_body `thenUgn` \ y_gcotylam_body ->
- returnUgn (U_cotylam y_gcotylam_tvs y_gcotylam_body)
- else if tag == ``coapp'' then
- ioToUgnM (_ccall_ gcoapp_fun t) `thenUgn` \ x_gcoapp_fun ->
- rdU_coresyn x_gcoapp_fun `thenUgn` \ y_gcoapp_fun ->
- ioToUgnM (_ccall_ gcoapp_args t) `thenUgn` \ x_gcoapp_args ->
- rdU_list x_gcoapp_args `thenUgn` \ y_gcoapp_args ->
- returnUgn (U_coapp y_gcoapp_fun y_gcoapp_args)
- else if tag == ``cotyapp'' then
- ioToUgnM (_ccall_ gcotyapp_e t) `thenUgn` \ x_gcotyapp_e ->
- rdU_coresyn x_gcotyapp_e `thenUgn` \ y_gcotyapp_e ->
- ioToUgnM (_ccall_ gcotyapp_t t) `thenUgn` \ x_gcotyapp_t ->
- rdU_ttype x_gcotyapp_t `thenUgn` \ y_gcotyapp_t ->
- returnUgn (U_cotyapp y_gcotyapp_e y_gcotyapp_t)
- else if tag == ``cocase'' then
- ioToUgnM (_ccall_ gcocase_s t) `thenUgn` \ x_gcocase_s ->
- rdU_coresyn x_gcocase_s `thenUgn` \ y_gcocase_s ->
- ioToUgnM (_ccall_ gcocase_alts t) `thenUgn` \ x_gcocase_alts ->
- rdU_coresyn x_gcocase_alts `thenUgn` \ y_gcocase_alts ->
- returnUgn (U_cocase y_gcocase_s y_gcocase_alts)
- else if tag == ``colet'' then
- ioToUgnM (_ccall_ gcolet_bind t) `thenUgn` \ x_gcolet_bind ->
- rdU_coresyn x_gcolet_bind `thenUgn` \ y_gcolet_bind ->
- ioToUgnM (_ccall_ gcolet_body t) `thenUgn` \ x_gcolet_body ->
- rdU_coresyn x_gcolet_body `thenUgn` \ y_gcolet_body ->
- returnUgn (U_colet y_gcolet_bind y_gcolet_body)
- else if tag == ``coscc'' then
- ioToUgnM (_ccall_ gcoscc_scc t) `thenUgn` \ x_gcoscc_scc ->
- rdU_coresyn x_gcoscc_scc `thenUgn` \ y_gcoscc_scc ->
- ioToUgnM (_ccall_ gcoscc_body t) `thenUgn` \ x_gcoscc_body ->
- rdU_coresyn x_gcoscc_body `thenUgn` \ y_gcoscc_body ->
- returnUgn (U_coscc y_gcoscc_scc y_gcoscc_body)
- else if tag == ``coalg_alts'' then
- ioToUgnM (_ccall_ gcoalg_alts t) `thenUgn` \ x_gcoalg_alts ->
- rdU_list x_gcoalg_alts `thenUgn` \ y_gcoalg_alts ->
- ioToUgnM (_ccall_ gcoalg_deflt t) `thenUgn` \ x_gcoalg_deflt ->
- rdU_coresyn x_gcoalg_deflt `thenUgn` \ y_gcoalg_deflt ->
- returnUgn (U_coalg_alts y_gcoalg_alts y_gcoalg_deflt)
- else if tag == ``coalg_alt'' then
- ioToUgnM (_ccall_ gcoalg_con t) `thenUgn` \ x_gcoalg_con ->
- rdU_coresyn x_gcoalg_con `thenUgn` \ y_gcoalg_con ->
- ioToUgnM (_ccall_ gcoalg_bs t) `thenUgn` \ x_gcoalg_bs ->
- rdU_list x_gcoalg_bs `thenUgn` \ y_gcoalg_bs ->
- ioToUgnM (_ccall_ gcoalg_rhs t) `thenUgn` \ x_gcoalg_rhs ->
- rdU_coresyn x_gcoalg_rhs `thenUgn` \ y_gcoalg_rhs ->
- returnUgn (U_coalg_alt y_gcoalg_con y_gcoalg_bs y_gcoalg_rhs)
- else if tag == ``coprim_alts'' then
- ioToUgnM (_ccall_ gcoprim_alts t) `thenUgn` \ x_gcoprim_alts ->
- rdU_list x_gcoprim_alts `thenUgn` \ y_gcoprim_alts ->
- ioToUgnM (_ccall_ gcoprim_deflt t) `thenUgn` \ x_gcoprim_deflt ->
- rdU_coresyn x_gcoprim_deflt `thenUgn` \ y_gcoprim_deflt ->
- returnUgn (U_coprim_alts y_gcoprim_alts y_gcoprim_deflt)
- else if tag == ``coprim_alt'' then
- ioToUgnM (_ccall_ gcoprim_lit t) `thenUgn` \ x_gcoprim_lit ->
- rdU_literal x_gcoprim_lit `thenUgn` \ y_gcoprim_lit ->
- ioToUgnM (_ccall_ gcoprim_rhs t) `thenUgn` \ x_gcoprim_rhs ->
- rdU_coresyn x_gcoprim_rhs `thenUgn` \ y_gcoprim_rhs ->
- returnUgn (U_coprim_alt y_gcoprim_lit y_gcoprim_rhs)
- else if tag == ``conodeflt'' then
- returnUgn (U_conodeflt )
- else if tag == ``cobinddeflt'' then
- ioToUgnM (_ccall_ gcobinddeflt_v t) `thenUgn` \ x_gcobinddeflt_v ->
- rdU_coresyn x_gcobinddeflt_v `thenUgn` \ y_gcobinddeflt_v ->
- ioToUgnM (_ccall_ gcobinddeflt_rhs t) `thenUgn` \ x_gcobinddeflt_rhs ->
- rdU_coresyn x_gcobinddeflt_rhs `thenUgn` \ y_gcobinddeflt_rhs ->
- returnUgn (U_cobinddeflt y_gcobinddeflt_v y_gcobinddeflt_rhs)
- else if tag == ``co_primop'' then
- ioToUgnM (_ccall_ gco_primop t) `thenUgn` \ x_gco_primop ->
- rdU_stringId x_gco_primop `thenUgn` \ y_gco_primop ->
- returnUgn (U_co_primop y_gco_primop)
- else if tag == ``co_ccall'' then
- ioToUgnM (_ccall_ gco_ccall t) `thenUgn` \ x_gco_ccall ->
- rdU_stringId x_gco_ccall `thenUgn` \ y_gco_ccall ->
- ioToUgnM (_ccall_ gco_ccall_may_gc t) `thenUgn` \ x_gco_ccall_may_gc ->
- rdU_long x_gco_ccall_may_gc `thenUgn` \ y_gco_ccall_may_gc ->
- ioToUgnM (_ccall_ gco_ccall_arg_tys t) `thenUgn` \ x_gco_ccall_arg_tys ->
- rdU_list x_gco_ccall_arg_tys `thenUgn` \ y_gco_ccall_arg_tys ->
- ioToUgnM (_ccall_ gco_ccall_res_ty t) `thenUgn` \ x_gco_ccall_res_ty ->
- rdU_ttype x_gco_ccall_res_ty `thenUgn` \ y_gco_ccall_res_ty ->
- returnUgn (U_co_ccall y_gco_ccall y_gco_ccall_may_gc y_gco_ccall_arg_tys y_gco_ccall_res_ty)
- else if tag == ``co_casm'' then
- ioToUgnM (_ccall_ gco_casm t) `thenUgn` \ x_gco_casm ->
- rdU_literal x_gco_casm `thenUgn` \ y_gco_casm ->
- ioToUgnM (_ccall_ gco_casm_may_gc t) `thenUgn` \ x_gco_casm_may_gc ->
- rdU_long x_gco_casm_may_gc `thenUgn` \ y_gco_casm_may_gc ->
- ioToUgnM (_ccall_ gco_casm_arg_tys t) `thenUgn` \ x_gco_casm_arg_tys ->
- rdU_list x_gco_casm_arg_tys `thenUgn` \ y_gco_casm_arg_tys ->
- ioToUgnM (_ccall_ gco_casm_res_ty t) `thenUgn` \ x_gco_casm_res_ty ->
- rdU_ttype x_gco_casm_res_ty `thenUgn` \ y_gco_casm_res_ty ->
- returnUgn (U_co_casm y_gco_casm y_gco_casm_may_gc y_gco_casm_arg_tys y_gco_casm_res_ty)
- else if tag == ``co_preludedictscc'' then
- ioToUgnM (_ccall_ gco_preludedictscc_dupd t) `thenUgn` \ x_gco_preludedictscc_dupd ->
- rdU_coresyn x_gco_preludedictscc_dupd `thenUgn` \ y_gco_preludedictscc_dupd ->
- returnUgn (U_co_preludedictscc y_gco_preludedictscc_dupd)
- else if tag == ``co_alldictscc'' then
- ioToUgnM (_ccall_ gco_alldictscc_m t) `thenUgn` \ x_gco_alldictscc_m ->
- rdU_hstring x_gco_alldictscc_m `thenUgn` \ y_gco_alldictscc_m ->
- ioToUgnM (_ccall_ gco_alldictscc_g t) `thenUgn` \ x_gco_alldictscc_g ->
- rdU_hstring x_gco_alldictscc_g `thenUgn` \ y_gco_alldictscc_g ->
- ioToUgnM (_ccall_ gco_alldictscc_dupd t) `thenUgn` \ x_gco_alldictscc_dupd ->
- rdU_coresyn x_gco_alldictscc_dupd `thenUgn` \ y_gco_alldictscc_dupd ->
- returnUgn (U_co_alldictscc y_gco_alldictscc_m y_gco_alldictscc_g y_gco_alldictscc_dupd)
- else if tag == ``co_usercc'' then
- ioToUgnM (_ccall_ gco_usercc_n t) `thenUgn` \ x_gco_usercc_n ->
- rdU_hstring x_gco_usercc_n `thenUgn` \ y_gco_usercc_n ->
- ioToUgnM (_ccall_ gco_usercc_m t) `thenUgn` \ x_gco_usercc_m ->
- rdU_hstring x_gco_usercc_m `thenUgn` \ y_gco_usercc_m ->
- ioToUgnM (_ccall_ gco_usercc_g t) `thenUgn` \ x_gco_usercc_g ->
- rdU_hstring x_gco_usercc_g `thenUgn` \ y_gco_usercc_g ->
- ioToUgnM (_ccall_ gco_usercc_dupd t) `thenUgn` \ x_gco_usercc_dupd ->
- rdU_coresyn x_gco_usercc_dupd `thenUgn` \ y_gco_usercc_dupd ->
- ioToUgnM (_ccall_ gco_usercc_cafd t) `thenUgn` \ x_gco_usercc_cafd ->
- rdU_coresyn x_gco_usercc_cafd `thenUgn` \ y_gco_usercc_cafd ->
- returnUgn (U_co_usercc y_gco_usercc_n y_gco_usercc_m y_gco_usercc_g y_gco_usercc_dupd y_gco_usercc_cafd)
- else if tag == ``co_autocc'' then
- ioToUgnM (_ccall_ gco_autocc_i t) `thenUgn` \ x_gco_autocc_i ->
- rdU_coresyn x_gco_autocc_i `thenUgn` \ y_gco_autocc_i ->
- ioToUgnM (_ccall_ gco_autocc_m t) `thenUgn` \ x_gco_autocc_m ->
- rdU_hstring x_gco_autocc_m `thenUgn` \ y_gco_autocc_m ->
- ioToUgnM (_ccall_ gco_autocc_g t) `thenUgn` \ x_gco_autocc_g ->
- rdU_hstring x_gco_autocc_g `thenUgn` \ y_gco_autocc_g ->
- ioToUgnM (_ccall_ gco_autocc_dupd t) `thenUgn` \ x_gco_autocc_dupd ->
- rdU_coresyn x_gco_autocc_dupd `thenUgn` \ y_gco_autocc_dupd ->
- ioToUgnM (_ccall_ gco_autocc_cafd t) `thenUgn` \ x_gco_autocc_cafd ->
- rdU_coresyn x_gco_autocc_cafd `thenUgn` \ y_gco_autocc_cafd ->
- returnUgn (U_co_autocc y_gco_autocc_i y_gco_autocc_m y_gco_autocc_g y_gco_autocc_dupd y_gco_autocc_cafd)
- else if tag == ``co_dictcc'' then
- ioToUgnM (_ccall_ gco_dictcc_i t) `thenUgn` \ x_gco_dictcc_i ->
- rdU_coresyn x_gco_dictcc_i `thenUgn` \ y_gco_dictcc_i ->
- ioToUgnM (_ccall_ gco_dictcc_m t) `thenUgn` \ x_gco_dictcc_m ->
- rdU_hstring x_gco_dictcc_m `thenUgn` \ y_gco_dictcc_m ->
- ioToUgnM (_ccall_ gco_dictcc_g t) `thenUgn` \ x_gco_dictcc_g ->
- rdU_hstring x_gco_dictcc_g `thenUgn` \ y_gco_dictcc_g ->
- ioToUgnM (_ccall_ gco_dictcc_dupd t) `thenUgn` \ x_gco_dictcc_dupd ->
- rdU_coresyn x_gco_dictcc_dupd `thenUgn` \ y_gco_dictcc_dupd ->
- ioToUgnM (_ccall_ gco_dictcc_cafd t) `thenUgn` \ x_gco_dictcc_cafd ->
- rdU_coresyn x_gco_dictcc_cafd `thenUgn` \ y_gco_dictcc_cafd ->
- returnUgn (U_co_dictcc y_gco_dictcc_i y_gco_dictcc_m y_gco_dictcc_g y_gco_dictcc_dupd y_gco_dictcc_cafd)
- else if tag == ``co_scc_noncaf'' then
- returnUgn (U_co_scc_noncaf )
- else if tag == ``co_scc_caf'' then
- returnUgn (U_co_scc_caf )
- else if tag == ``co_scc_nondupd'' then
- returnUgn (U_co_scc_nondupd )
- else if tag == ``co_scc_dupd'' then
- returnUgn (U_co_scc_dupd )
- else if tag == ``co_id'' then
- ioToUgnM (_ccall_ gco_id t) `thenUgn` \ x_gco_id ->
- rdU_stringId x_gco_id `thenUgn` \ y_gco_id ->
- returnUgn (U_co_id y_gco_id)
- else if tag == ``co_orig_id'' then
- ioToUgnM (_ccall_ gco_orig_id_m t) `thenUgn` \ x_gco_orig_id_m ->
- rdU_stringId x_gco_orig_id_m `thenUgn` \ y_gco_orig_id_m ->
- ioToUgnM (_ccall_ gco_orig_id_n t) `thenUgn` \ x_gco_orig_id_n ->
- rdU_stringId x_gco_orig_id_n `thenUgn` \ y_gco_orig_id_n ->
- returnUgn (U_co_orig_id y_gco_orig_id_m y_gco_orig_id_n)
- else if tag == ``co_sdselid'' then
- ioToUgnM (_ccall_ gco_sdselid_c t) `thenUgn` \ x_gco_sdselid_c ->
- rdU_unkId x_gco_sdselid_c `thenUgn` \ y_gco_sdselid_c ->
- ioToUgnM (_ccall_ gco_sdselid_sc t) `thenUgn` \ x_gco_sdselid_sc ->
- rdU_unkId x_gco_sdselid_sc `thenUgn` \ y_gco_sdselid_sc ->
- returnUgn (U_co_sdselid y_gco_sdselid_c y_gco_sdselid_sc)
- else if tag == ``co_classopid'' then
- ioToUgnM (_ccall_ gco_classopid_c t) `thenUgn` \ x_gco_classopid_c ->
- rdU_unkId x_gco_classopid_c `thenUgn` \ y_gco_classopid_c ->
- ioToUgnM (_ccall_ gco_classopid_o t) `thenUgn` \ x_gco_classopid_o ->
- rdU_unkId x_gco_classopid_o `thenUgn` \ y_gco_classopid_o ->
- returnUgn (U_co_classopid y_gco_classopid_c y_gco_classopid_o)
- else if tag == ``co_defmid'' then
- ioToUgnM (_ccall_ gco_defmid_c t) `thenUgn` \ x_gco_defmid_c ->
- rdU_unkId x_gco_defmid_c `thenUgn` \ y_gco_defmid_c ->
- ioToUgnM (_ccall_ gco_defmid_op t) `thenUgn` \ x_gco_defmid_op ->
- rdU_unkId x_gco_defmid_op `thenUgn` \ y_gco_defmid_op ->
- returnUgn (U_co_defmid y_gco_defmid_c y_gco_defmid_op)
- else if tag == ``co_dfunid'' then
- ioToUgnM (_ccall_ gco_dfunid_c t) `thenUgn` \ x_gco_dfunid_c ->
- rdU_unkId x_gco_dfunid_c `thenUgn` \ y_gco_dfunid_c ->
- ioToUgnM (_ccall_ gco_dfunid_ty t) `thenUgn` \ x_gco_dfunid_ty ->
- rdU_ttype x_gco_dfunid_ty `thenUgn` \ y_gco_dfunid_ty ->
- returnUgn (U_co_dfunid y_gco_dfunid_c y_gco_dfunid_ty)
- else if tag == ``co_constmid'' then
- ioToUgnM (_ccall_ gco_constmid_c t) `thenUgn` \ x_gco_constmid_c ->
- rdU_unkId x_gco_constmid_c `thenUgn` \ y_gco_constmid_c ->
- ioToUgnM (_ccall_ gco_constmid_op t) `thenUgn` \ x_gco_constmid_op ->
- rdU_unkId x_gco_constmid_op `thenUgn` \ y_gco_constmid_op ->
- ioToUgnM (_ccall_ gco_constmid_ty t) `thenUgn` \ x_gco_constmid_ty ->
- rdU_ttype x_gco_constmid_ty `thenUgn` \ y_gco_constmid_ty ->
- returnUgn (U_co_constmid y_gco_constmid_c y_gco_constmid_op y_gco_constmid_ty)
- else if tag == ``co_specid'' then
- ioToUgnM (_ccall_ gco_specid_un t) `thenUgn` \ x_gco_specid_un ->
- rdU_coresyn x_gco_specid_un `thenUgn` \ y_gco_specid_un ->
- ioToUgnM (_ccall_ gco_specid_tys t) `thenUgn` \ x_gco_specid_tys ->
- rdU_list x_gco_specid_tys `thenUgn` \ y_gco_specid_tys ->
- returnUgn (U_co_specid y_gco_specid_un y_gco_specid_tys)
- else if tag == ``co_wrkrid'' then
- ioToUgnM (_ccall_ gco_wrkrid_un t) `thenUgn` \ x_gco_wrkrid_un ->
- rdU_coresyn x_gco_wrkrid_un `thenUgn` \ y_gco_wrkrid_un ->
- returnUgn (U_co_wrkrid y_gco_wrkrid_un)
- else
- error ("rdU_coresyn: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_entidt where
-import UgenUtil
-import Util
-
-import U_list
-data U_entidt = U_entid U_stringId | U_enttype U_stringId | U_enttypeall U_stringId | U_enttypecons U_stringId U_list | U_entclass U_stringId U_list | U_entmod U_stringId
-
-rdU_entidt :: _Addr -> UgnM U_entidt
-rdU_entidt t
- = ioToUgnM (_ccall_ tentidt t) `thenUgn` \ tag@(I# _) ->
- if tag == ``entid'' then
- ioToUgnM (_ccall_ gentid t) `thenUgn` \ x_gentid ->
- rdU_stringId x_gentid `thenUgn` \ y_gentid ->
- returnUgn (U_entid y_gentid)
- else if tag == ``enttype'' then
- ioToUgnM (_ccall_ gitentid t) `thenUgn` \ x_gitentid ->
- rdU_stringId x_gitentid `thenUgn` \ y_gitentid ->
- returnUgn (U_enttype y_gitentid)
- else if tag == ``enttypeall'' then
- ioToUgnM (_ccall_ gatentid t) `thenUgn` \ x_gatentid ->
- rdU_stringId x_gatentid `thenUgn` \ y_gatentid ->
- returnUgn (U_enttypeall y_gatentid)
- else if tag == ``enttypecons'' then
- ioToUgnM (_ccall_ gctentid t) `thenUgn` \ x_gctentid ->
- rdU_stringId x_gctentid `thenUgn` \ y_gctentid ->
- ioToUgnM (_ccall_ gctentcons t) `thenUgn` \ x_gctentcons ->
- rdU_list x_gctentcons `thenUgn` \ y_gctentcons ->
- returnUgn (U_enttypecons y_gctentid y_gctentcons)
- else if tag == ``entclass'' then
- ioToUgnM (_ccall_ gcentid t) `thenUgn` \ x_gcentid ->
- rdU_stringId x_gcentid `thenUgn` \ y_gcentid ->
- ioToUgnM (_ccall_ gcentops t) `thenUgn` \ x_gcentops ->
- rdU_list x_gcentops `thenUgn` \ y_gcentops ->
- returnUgn (U_entclass y_gcentid y_gcentops)
- else if tag == ``entmod'' then
- ioToUgnM (_ccall_ gmentid t) `thenUgn` \ x_gmentid ->
- rdU_stringId x_gmentid `thenUgn` \ y_gmentid ->
- returnUgn (U_entmod y_gmentid)
- else
- error ("rdU_entidt: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_finfot where
-import UgenUtil
-import Util
-data U_finfot = U_finfo U_stringId U_stringId
-
-rdU_finfot :: _Addr -> UgnM U_finfot
-rdU_finfot t
- = ioToUgnM (_ccall_ tfinfot t) `thenUgn` \ tag@(I# _) ->
- if tag == ``finfo'' then
- ioToUgnM (_ccall_ fi1 t) `thenUgn` \ x_fi1 ->
- rdU_stringId x_fi1 `thenUgn` \ y_fi1 ->
- ioToUgnM (_ccall_ fi2 t) `thenUgn` \ x_fi2 ->
- rdU_stringId x_fi2 `thenUgn` \ y_fi2 ->
- returnUgn (U_finfo y_fi1 y_fi2)
- else
- error ("rdU_finfot: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_hpragma where
-import UgenUtil
-import Util
-
-import U_coresyn
-import U_list
-import U_literal ( U_literal ) -- ditto
-import U_ttype ( U_ttype ) -- interface only
-data U_hpragma = U_no_pragma | U_idata_pragma U_list U_list | U_itype_pragma | U_iclas_pragma U_list | U_iclasop_pragma U_hpragma U_hpragma | U_iinst_simpl_pragma U_stringId U_hpragma | U_iinst_const_pragma U_stringId U_hpragma U_list | U_igen_pragma U_hpragma U_hpragma U_hpragma U_hpragma U_hpragma U_list | U_iarity_pragma U_numId | U_iupdate_pragma U_stringId | U_ideforest_pragma | U_istrictness_pragma U_hstring U_hpragma | U_imagic_unfolding_pragma U_stringId | U_iunfolding_pragma U_hpragma U_coresyn | U_iunfold_always | U_iunfold_if_args U_numId U_numId U_stringId U_numId | U_iname_pragma_pr U_unkId U_hpragma | U_itype_pragma_pr U_list U_numId U_hpragma | U_idata_pragma_4s U_list
-
-rdU_hpragma :: _Addr -> UgnM U_hpragma
-rdU_hpragma t
- = ioToUgnM (_ccall_ thpragma t) `thenUgn` \ tag@(I# _) ->
- if tag == ``no_pragma'' then
- returnUgn (U_no_pragma )
- else if tag == ``idata_pragma'' then
- ioToUgnM (_ccall_ gprag_data_constrs t) `thenUgn` \ x_gprag_data_constrs ->
- rdU_list x_gprag_data_constrs `thenUgn` \ y_gprag_data_constrs ->
- ioToUgnM (_ccall_ gprag_data_specs t) `thenUgn` \ x_gprag_data_specs ->
- rdU_list x_gprag_data_specs `thenUgn` \ y_gprag_data_specs ->
- returnUgn (U_idata_pragma y_gprag_data_constrs y_gprag_data_specs)
- else if tag == ``itype_pragma'' then
- returnUgn (U_itype_pragma )
- else if tag == ``iclas_pragma'' then
- ioToUgnM (_ccall_ gprag_clas t) `thenUgn` \ x_gprag_clas ->
- rdU_list x_gprag_clas `thenUgn` \ y_gprag_clas ->
- returnUgn (U_iclas_pragma y_gprag_clas)
- else if tag == ``iclasop_pragma'' then
- ioToUgnM (_ccall_ gprag_dsel t) `thenUgn` \ x_gprag_dsel ->
- rdU_hpragma x_gprag_dsel `thenUgn` \ y_gprag_dsel ->
- ioToUgnM (_ccall_ gprag_defm t) `thenUgn` \ x_gprag_defm ->
- rdU_hpragma x_gprag_defm `thenUgn` \ y_gprag_defm ->
- returnUgn (U_iclasop_pragma y_gprag_dsel y_gprag_defm)
- else if tag == ``iinst_simpl_pragma'' then
- ioToUgnM (_ccall_ gprag_imod_simpl t) `thenUgn` \ x_gprag_imod_simpl ->
- rdU_stringId x_gprag_imod_simpl `thenUgn` \ y_gprag_imod_simpl ->
- ioToUgnM (_ccall_ gprag_dfun_simpl t) `thenUgn` \ x_gprag_dfun_simpl ->
- rdU_hpragma x_gprag_dfun_simpl `thenUgn` \ y_gprag_dfun_simpl ->
- returnUgn (U_iinst_simpl_pragma y_gprag_imod_simpl y_gprag_dfun_simpl)
- else if tag == ``iinst_const_pragma'' then
- ioToUgnM (_ccall_ gprag_imod_const t) `thenUgn` \ x_gprag_imod_const ->
- rdU_stringId x_gprag_imod_const `thenUgn` \ y_gprag_imod_const ->
- ioToUgnM (_ccall_ gprag_dfun_const t) `thenUgn` \ x_gprag_dfun_const ->
- rdU_hpragma x_gprag_dfun_const `thenUgn` \ y_gprag_dfun_const ->
- ioToUgnM (_ccall_ gprag_constms t) `thenUgn` \ x_gprag_constms ->
- rdU_list x_gprag_constms `thenUgn` \ y_gprag_constms ->
- returnUgn (U_iinst_const_pragma y_gprag_imod_const y_gprag_dfun_const y_gprag_constms)
- else if tag == ``igen_pragma'' then
- ioToUgnM (_ccall_ gprag_arity t) `thenUgn` \ x_gprag_arity ->
- rdU_hpragma x_gprag_arity `thenUgn` \ y_gprag_arity ->
- ioToUgnM (_ccall_ gprag_update t) `thenUgn` \ x_gprag_update ->
- rdU_hpragma x_gprag_update `thenUgn` \ y_gprag_update ->
- ioToUgnM (_ccall_ gprag_deforest t) `thenUgn` \ x_gprag_deforest ->
- rdU_hpragma x_gprag_deforest `thenUgn` \ y_gprag_deforest ->
- ioToUgnM (_ccall_ gprag_strictness t) `thenUgn` \ x_gprag_strictness ->
- rdU_hpragma x_gprag_strictness `thenUgn` \ y_gprag_strictness ->
- ioToUgnM (_ccall_ gprag_unfolding t) `thenUgn` \ x_gprag_unfolding ->
- rdU_hpragma x_gprag_unfolding `thenUgn` \ y_gprag_unfolding ->
- ioToUgnM (_ccall_ gprag_specs t) `thenUgn` \ x_gprag_specs ->
- rdU_list x_gprag_specs `thenUgn` \ y_gprag_specs ->
- returnUgn (U_igen_pragma y_gprag_arity y_gprag_update y_gprag_deforest y_gprag_strictness y_gprag_unfolding y_gprag_specs)
- else if tag == ``iarity_pragma'' then
- ioToUgnM (_ccall_ gprag_arity_val t) `thenUgn` \ x_gprag_arity_val ->
- rdU_numId x_gprag_arity_val `thenUgn` \ y_gprag_arity_val ->
- returnUgn (U_iarity_pragma y_gprag_arity_val)
- else if tag == ``iupdate_pragma'' then
- ioToUgnM (_ccall_ gprag_update_val t) `thenUgn` \ x_gprag_update_val ->
- rdU_stringId x_gprag_update_val `thenUgn` \ y_gprag_update_val ->
- returnUgn (U_iupdate_pragma y_gprag_update_val)
- else if tag == ``ideforest_pragma'' then
- returnUgn (U_ideforest_pragma )
- else if tag == ``istrictness_pragma'' then
- ioToUgnM (_ccall_ gprag_strict_spec t) `thenUgn` \ x_gprag_strict_spec ->
- rdU_hstring x_gprag_strict_spec `thenUgn` \ y_gprag_strict_spec ->
- ioToUgnM (_ccall_ gprag_strict_wrkr t) `thenUgn` \ x_gprag_strict_wrkr ->
- rdU_hpragma x_gprag_strict_wrkr `thenUgn` \ y_gprag_strict_wrkr ->
- returnUgn (U_istrictness_pragma y_gprag_strict_spec y_gprag_strict_wrkr)
- else if tag == ``imagic_unfolding_pragma'' then
- ioToUgnM (_ccall_ gprag_magic_str t) `thenUgn` \ x_gprag_magic_str ->
- rdU_stringId x_gprag_magic_str `thenUgn` \ y_gprag_magic_str ->
- returnUgn (U_imagic_unfolding_pragma y_gprag_magic_str)
- else if tag == ``iunfolding_pragma'' then
- ioToUgnM (_ccall_ gprag_unfold_guide t) `thenUgn` \ x_gprag_unfold_guide ->
- rdU_hpragma x_gprag_unfold_guide `thenUgn` \ y_gprag_unfold_guide ->
- ioToUgnM (_ccall_ gprag_unfold_core t) `thenUgn` \ x_gprag_unfold_core ->
- rdU_coresyn x_gprag_unfold_core `thenUgn` \ y_gprag_unfold_core ->
- returnUgn (U_iunfolding_pragma y_gprag_unfold_guide y_gprag_unfold_core)
- else if tag == ``iunfold_always'' then
- returnUgn (U_iunfold_always )
- else if tag == ``iunfold_if_args'' then
- ioToUgnM (_ccall_ gprag_unfold_if_t_args t) `thenUgn` \ x_gprag_unfold_if_t_args ->
- rdU_numId x_gprag_unfold_if_t_args `thenUgn` \ y_gprag_unfold_if_t_args ->
- ioToUgnM (_ccall_ gprag_unfold_if_v_args t) `thenUgn` \ x_gprag_unfold_if_v_args ->
- rdU_numId x_gprag_unfold_if_v_args `thenUgn` \ y_gprag_unfold_if_v_args ->
- ioToUgnM (_ccall_ gprag_unfold_if_con_args t) `thenUgn` \ x_gprag_unfold_if_con_args ->
- rdU_stringId x_gprag_unfold_if_con_args `thenUgn` \ y_gprag_unfold_if_con_args ->
- ioToUgnM (_ccall_ gprag_unfold_if_size t) `thenUgn` \ x_gprag_unfold_if_size ->
- rdU_numId x_gprag_unfold_if_size `thenUgn` \ y_gprag_unfold_if_size ->
- returnUgn (U_iunfold_if_args y_gprag_unfold_if_t_args y_gprag_unfold_if_v_args y_gprag_unfold_if_con_args y_gprag_unfold_if_size)
- else if tag == ``iname_pragma_pr'' then
- ioToUgnM (_ccall_ gprag_name_pr1 t) `thenUgn` \ x_gprag_name_pr1 ->
- rdU_unkId x_gprag_name_pr1 `thenUgn` \ y_gprag_name_pr1 ->
- ioToUgnM (_ccall_ gprag_name_pr2 t) `thenUgn` \ x_gprag_name_pr2 ->
- rdU_hpragma x_gprag_name_pr2 `thenUgn` \ y_gprag_name_pr2 ->
- returnUgn (U_iname_pragma_pr y_gprag_name_pr1 y_gprag_name_pr2)
- else if tag == ``itype_pragma_pr'' then
- ioToUgnM (_ccall_ gprag_type_pr1 t) `thenUgn` \ x_gprag_type_pr1 ->
- rdU_list x_gprag_type_pr1 `thenUgn` \ y_gprag_type_pr1 ->
- ioToUgnM (_ccall_ gprag_type_pr2 t) `thenUgn` \ x_gprag_type_pr2 ->
- rdU_numId x_gprag_type_pr2 `thenUgn` \ y_gprag_type_pr2 ->
- ioToUgnM (_ccall_ gprag_type_pr3 t) `thenUgn` \ x_gprag_type_pr3 ->
- rdU_hpragma x_gprag_type_pr3 `thenUgn` \ y_gprag_type_pr3 ->
- returnUgn (U_itype_pragma_pr y_gprag_type_pr1 y_gprag_type_pr2 y_gprag_type_pr3)
- else if tag == ``idata_pragma_4s'' then
- ioToUgnM (_ccall_ gprag_data_spec t) `thenUgn` \ x_gprag_data_spec ->
- rdU_list x_gprag_data_spec `thenUgn` \ y_gprag_data_spec ->
- returnUgn (U_idata_pragma_4s y_gprag_data_spec)
- else
- error ("rdU_hpragma: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_list where
-import UgenUtil
-import Util
-data U_list = U_lcons U_VOID_STAR U_list | U_lnil
-
-rdU_list :: _Addr -> UgnM U_list
-rdU_list t
- = ioToUgnM (_ccall_ tlist t) `thenUgn` \ tag@(I# _) ->
- if tag == ``lcons'' then
- ioToUgnM (_ccall_ lhd t) `thenUgn` \ x_lhd ->
- rdU_VOID_STAR x_lhd `thenUgn` \ y_lhd ->
- ioToUgnM (_ccall_ ltl t) `thenUgn` \ x_ltl ->
- rdU_list x_ltl `thenUgn` \ y_ltl ->
- returnUgn (U_lcons y_lhd y_ltl)
- else if tag == ``lnil'' then
- returnUgn (U_lnil )
- else
- error ("rdU_list: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_literal where
-import UgenUtil
-import Util
-data U_literal = U_integer U_stringId | U_intprim U_stringId | U_floatr U_stringId | U_doubleprim U_stringId | U_floatprim U_stringId | U_charr U_hstring | U_charprim U_hstring | U_string U_hstring | U_stringprim U_hstring | U_clitlit U_stringId U_stringId | U_norepi U_stringId | U_norepr U_stringId U_stringId | U_noreps U_hstring
-
-rdU_literal :: _Addr -> UgnM U_literal
-rdU_literal t
- = ioToUgnM (_ccall_ tliteral t) `thenUgn` \ tag@(I# _) ->
- if tag == ``integer'' then
- ioToUgnM (_ccall_ ginteger t) `thenUgn` \ x_ginteger ->
- rdU_stringId x_ginteger `thenUgn` \ y_ginteger ->
- returnUgn (U_integer y_ginteger)
- else if tag == ``intprim'' then
- ioToUgnM (_ccall_ gintprim t) `thenUgn` \ x_gintprim ->
- rdU_stringId x_gintprim `thenUgn` \ y_gintprim ->
- returnUgn (U_intprim y_gintprim)
- else if tag == ``floatr'' then
- ioToUgnM (_ccall_ gfloatr t) `thenUgn` \ x_gfloatr ->
- rdU_stringId x_gfloatr `thenUgn` \ y_gfloatr ->
- returnUgn (U_floatr y_gfloatr)
- else if tag == ``doubleprim'' then
- ioToUgnM (_ccall_ gdoubleprim t) `thenUgn` \ x_gdoubleprim ->
- rdU_stringId x_gdoubleprim `thenUgn` \ y_gdoubleprim ->
- returnUgn (U_doubleprim y_gdoubleprim)
- else if tag == ``floatprim'' then
- ioToUgnM (_ccall_ gfloatprim t) `thenUgn` \ x_gfloatprim ->
- rdU_stringId x_gfloatprim `thenUgn` \ y_gfloatprim ->
- returnUgn (U_floatprim y_gfloatprim)
- else if tag == ``charr'' then
- ioToUgnM (_ccall_ gchar t) `thenUgn` \ x_gchar ->
- rdU_hstring x_gchar `thenUgn` \ y_gchar ->
- returnUgn (U_charr y_gchar)
- else if tag == ``charprim'' then
- ioToUgnM (_ccall_ gcharprim t) `thenUgn` \ x_gcharprim ->
- rdU_hstring x_gcharprim `thenUgn` \ y_gcharprim ->
- returnUgn (U_charprim y_gcharprim)
- else if tag == ``string'' then
- ioToUgnM (_ccall_ gstring t) `thenUgn` \ x_gstring ->
- rdU_hstring x_gstring `thenUgn` \ y_gstring ->
- returnUgn (U_string y_gstring)
- else if tag == ``stringprim'' then
- ioToUgnM (_ccall_ gstringprim t) `thenUgn` \ x_gstringprim ->
- rdU_hstring x_gstringprim `thenUgn` \ y_gstringprim ->
- returnUgn (U_stringprim y_gstringprim)
- else if tag == ``clitlit'' then
- ioToUgnM (_ccall_ gclitlit t) `thenUgn` \ x_gclitlit ->
- rdU_stringId x_gclitlit `thenUgn` \ y_gclitlit ->
- ioToUgnM (_ccall_ gclitlit_kind t) `thenUgn` \ x_gclitlit_kind ->
- rdU_stringId x_gclitlit_kind `thenUgn` \ y_gclitlit_kind ->
- returnUgn (U_clitlit y_gclitlit y_gclitlit_kind)
- else if tag == ``norepi'' then
- ioToUgnM (_ccall_ gnorepi t) `thenUgn` \ x_gnorepi ->
- rdU_stringId x_gnorepi `thenUgn` \ y_gnorepi ->
- returnUgn (U_norepi y_gnorepi)
- else if tag == ``norepr'' then
- ioToUgnM (_ccall_ gnorepr_n t) `thenUgn` \ x_gnorepr_n ->
- rdU_stringId x_gnorepr_n `thenUgn` \ y_gnorepr_n ->
- ioToUgnM (_ccall_ gnorepr_d t) `thenUgn` \ x_gnorepr_d ->
- rdU_stringId x_gnorepr_d `thenUgn` \ y_gnorepr_d ->
- returnUgn (U_norepr y_gnorepr_n y_gnorepr_d)
- else if tag == ``noreps'' then
- ioToUgnM (_ccall_ gnoreps t) `thenUgn` \ x_gnoreps ->
- rdU_hstring x_gnoreps `thenUgn` \ y_gnoreps ->
- returnUgn (U_noreps y_gnoreps)
- else
- error ("rdU_literal: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_pbinding where
-import UgenUtil
-import Util
-
-import U_binding
-import U_coresyn ( U_coresyn ) -- interface only
-import U_hpragma ( U_hpragma ) -- interface only
-import U_list
-import U_literal ( U_literal ) -- ditto
-import U_treeHACK
-import U_ttype ( U_ttype ) -- ditto
-data U_pbinding = U_pgrhs U_tree U_list U_binding U_stringId U_long
-
-rdU_pbinding :: _Addr -> UgnM U_pbinding
-rdU_pbinding t
- = ioToUgnM (_ccall_ tpbinding t) `thenUgn` \ tag@(I# _) ->
- if tag == ``pgrhs'' then
- ioToUgnM (_ccall_ ggpat t) `thenUgn` \ x_ggpat ->
- rdU_tree x_ggpat `thenUgn` \ y_ggpat ->
- ioToUgnM (_ccall_ ggdexprs t) `thenUgn` \ x_ggdexprs ->
- rdU_list x_ggdexprs `thenUgn` \ y_ggdexprs ->
- ioToUgnM (_ccall_ ggbind t) `thenUgn` \ x_ggbind ->
- rdU_binding x_ggbind `thenUgn` \ y_ggbind ->
- ioToUgnM (_ccall_ ggfuncname t) `thenUgn` \ x_ggfuncname ->
- rdU_stringId x_ggfuncname `thenUgn` \ y_ggfuncname ->
- ioToUgnM (_ccall_ ggline t) `thenUgn` \ x_ggline ->
- rdU_long x_ggline `thenUgn` \ y_ggline ->
- returnUgn (U_pgrhs y_ggpat y_ggdexprs y_ggbind y_ggfuncname y_ggline)
- else
- error ("rdU_pbinding: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_tree where
-import UgenUtil
-import Util
-
-import U_binding
-import U_coresyn ( U_coresyn ) -- interface only
-import U_hpragma ( U_hpragma ) -- interface only
-import U_list
-import U_literal
-import U_ttype
-
-type U_infixTree = (ProtoName, U_tree, U_tree)
-
-rdU_infixTree :: _Addr -> UgnM U_infixTree
-rdU_infixTree pt
- = ioToUgnM (_casm_ ``%r = gident(*Rginfun_hs((struct Sap *)%0));'' pt) `thenUgn` \ op_t ->
- ioToUgnM (_casm_ ``%r = (*Rginarg1_hs((struct Sap *)%0));'' pt) `thenUgn` \ arg1_t ->
- ioToUgnM (_casm_ ``%r = (*Rginarg2_hs((struct Sap *)%0));'' pt) `thenUgn` \ arg2_t ->
-
- rdU_unkId op_t `thenUgn` \ op ->
- rdU_tree arg1_t `thenUgn` \ arg1 ->
- rdU_tree arg2_t `thenUgn` \ arg2 ->
- returnUgn (op, arg1, arg2)
-data U_tree = U_hmodule U_stringId U_list U_list U_binding U_long | U_ident U_unkId | U_lit U_literal | U_tuple U_list | U_ap U_tree U_tree | U_lambda U_list U_tree U_long | U_let U_binding U_tree | U_casee U_tree U_list | U_ife U_tree U_tree U_tree | U_par U_tree | U_as U_unkId U_tree | U_lazyp U_tree | U_plusp U_tree U_literal | U_wildp | U_restr U_tree U_ttype | U_comprh U_tree U_list | U_qual U_tree U_tree | U_guard U_tree | U_def U_tree | U_tinfixop U_infixTree | U_lsection U_tree U_unkId | U_rsection U_unkId U_tree | U_eenum U_tree U_list U_list | U_llist U_list | U_ccall U_stringId U_stringId U_list | U_scc U_hstring U_tree | U_negate U_tree
-
-rdU_tree :: _Addr -> UgnM U_tree
-rdU_tree t
- = ioToUgnM (_ccall_ ttree t) `thenUgn` \ tag@(I# _) ->
- if tag == ``hmodule'' then
- ioToUgnM (_ccall_ ghname t) `thenUgn` \ x_ghname ->
- rdU_stringId x_ghname `thenUgn` \ y_ghname ->
- ioToUgnM (_ccall_ ghimplist t) `thenUgn` \ x_ghimplist ->
- rdU_list x_ghimplist `thenUgn` \ y_ghimplist ->
- ioToUgnM (_ccall_ ghexplist t) `thenUgn` \ x_ghexplist ->
- rdU_list x_ghexplist `thenUgn` \ y_ghexplist ->
- ioToUgnM (_ccall_ ghmodlist t) `thenUgn` \ x_ghmodlist ->
- rdU_binding x_ghmodlist `thenUgn` \ y_ghmodlist ->
- ioToUgnM (_ccall_ ghmodline t) `thenUgn` \ x_ghmodline ->
- rdU_long x_ghmodline `thenUgn` \ y_ghmodline ->
- returnUgn (U_hmodule y_ghname y_ghimplist y_ghexplist y_ghmodlist y_ghmodline)
- else if tag == ``ident'' then
- ioToUgnM (_ccall_ gident t) `thenUgn` \ x_gident ->
- rdU_unkId x_gident `thenUgn` \ y_gident ->
- returnUgn (U_ident y_gident)
- else if tag == ``lit'' then
- ioToUgnM (_ccall_ glit t) `thenUgn` \ x_glit ->
- rdU_literal x_glit `thenUgn` \ y_glit ->
- returnUgn (U_lit y_glit)
- else if tag == ``tuple'' then
- ioToUgnM (_ccall_ gtuplelist t) `thenUgn` \ x_gtuplelist ->
- rdU_list x_gtuplelist `thenUgn` \ y_gtuplelist ->
- returnUgn (U_tuple y_gtuplelist)
- else if tag == ``ap'' then
- ioToUgnM (_ccall_ gfun t) `thenUgn` \ x_gfun ->
- rdU_tree x_gfun `thenUgn` \ y_gfun ->
- ioToUgnM (_ccall_ garg t) `thenUgn` \ x_garg ->
- rdU_tree x_garg `thenUgn` \ y_garg ->
- returnUgn (U_ap y_gfun y_garg)
- else if tag == ``lambda'' then
- ioToUgnM (_ccall_ glampats t) `thenUgn` \ x_glampats ->
- rdU_list x_glampats `thenUgn` \ y_glampats ->
- ioToUgnM (_ccall_ glamexpr t) `thenUgn` \ x_glamexpr ->
- rdU_tree x_glamexpr `thenUgn` \ y_glamexpr ->
- ioToUgnM (_ccall_ glamline t) `thenUgn` \ x_glamline ->
- rdU_long x_glamline `thenUgn` \ y_glamline ->
- returnUgn (U_lambda y_glampats y_glamexpr y_glamline)
- else if tag == ``let'' then
- ioToUgnM (_ccall_ gletvdeflist t) `thenUgn` \ x_gletvdeflist ->
- rdU_binding x_gletvdeflist `thenUgn` \ y_gletvdeflist ->
- ioToUgnM (_ccall_ gletvexpr t) `thenUgn` \ x_gletvexpr ->
- rdU_tree x_gletvexpr `thenUgn` \ y_gletvexpr ->
- returnUgn (U_let y_gletvdeflist y_gletvexpr)
- else if tag == ``casee'' then
- ioToUgnM (_ccall_ gcaseexpr t) `thenUgn` \ x_gcaseexpr ->
- rdU_tree x_gcaseexpr `thenUgn` \ y_gcaseexpr ->
- ioToUgnM (_ccall_ gcasebody t) `thenUgn` \ x_gcasebody ->
- rdU_list x_gcasebody `thenUgn` \ y_gcasebody ->
- returnUgn (U_casee y_gcaseexpr y_gcasebody)
- else if tag == ``ife'' then
- ioToUgnM (_ccall_ gifpred t) `thenUgn` \ x_gifpred ->
- rdU_tree x_gifpred `thenUgn` \ y_gifpred ->
- ioToUgnM (_ccall_ gifthen t) `thenUgn` \ x_gifthen ->
- rdU_tree x_gifthen `thenUgn` \ y_gifthen ->
- ioToUgnM (_ccall_ gifelse t) `thenUgn` \ x_gifelse ->
- rdU_tree x_gifelse `thenUgn` \ y_gifelse ->
- returnUgn (U_ife y_gifpred y_gifthen y_gifelse)
- else if tag == ``par'' then
- ioToUgnM (_ccall_ gpare t) `thenUgn` \ x_gpare ->
- rdU_tree x_gpare `thenUgn` \ y_gpare ->
- returnUgn (U_par y_gpare)
- else if tag == ``as'' then
- ioToUgnM (_ccall_ gasid t) `thenUgn` \ x_gasid ->
- rdU_unkId x_gasid `thenUgn` \ y_gasid ->
- ioToUgnM (_ccall_ gase t) `thenUgn` \ x_gase ->
- rdU_tree x_gase `thenUgn` \ y_gase ->
- returnUgn (U_as y_gasid y_gase)
- else if tag == ``lazyp'' then
- ioToUgnM (_ccall_ glazyp t) `thenUgn` \ x_glazyp ->
- rdU_tree x_glazyp `thenUgn` \ y_glazyp ->
- returnUgn (U_lazyp y_glazyp)
- else if tag == ``plusp'' then
- ioToUgnM (_ccall_ gplusp t) `thenUgn` \ x_gplusp ->
- rdU_tree x_gplusp `thenUgn` \ y_gplusp ->
- ioToUgnM (_ccall_ gplusi t) `thenUgn` \ x_gplusi ->
- rdU_literal x_gplusi `thenUgn` \ y_gplusi ->
- returnUgn (U_plusp y_gplusp y_gplusi)
- else if tag == ``wildp'' then
- returnUgn (U_wildp )
- else if tag == ``restr'' then
- ioToUgnM (_ccall_ grestre t) `thenUgn` \ x_grestre ->
- rdU_tree x_grestre `thenUgn` \ y_grestre ->
- ioToUgnM (_ccall_ grestrt t) `thenUgn` \ x_grestrt ->
- rdU_ttype x_grestrt `thenUgn` \ y_grestrt ->
- returnUgn (U_restr y_grestre y_grestrt)
- else if tag == ``comprh'' then
- ioToUgnM (_ccall_ gcexp t) `thenUgn` \ x_gcexp ->
- rdU_tree x_gcexp `thenUgn` \ y_gcexp ->
- ioToUgnM (_ccall_ gcquals t) `thenUgn` \ x_gcquals ->
- rdU_list x_gcquals `thenUgn` \ y_gcquals ->
- returnUgn (U_comprh y_gcexp y_gcquals)
- else if tag == ``qual'' then
- ioToUgnM (_ccall_ gqpat t) `thenUgn` \ x_gqpat ->
- rdU_tree x_gqpat `thenUgn` \ y_gqpat ->
- ioToUgnM (_ccall_ gqexp t) `thenUgn` \ x_gqexp ->
- rdU_tree x_gqexp `thenUgn` \ y_gqexp ->
- returnUgn (U_qual y_gqpat y_gqexp)
- else if tag == ``guard'' then
- ioToUgnM (_ccall_ ggexp t) `thenUgn` \ x_ggexp ->
- rdU_tree x_ggexp `thenUgn` \ y_ggexp ->
- returnUgn (U_guard y_ggexp)
- else if tag == ``def'' then
- ioToUgnM (_ccall_ ggdef t) `thenUgn` \ x_ggdef ->
- rdU_tree x_ggdef `thenUgn` \ y_ggdef ->
- returnUgn (U_def y_ggdef)
- else if tag == ``tinfixop'' then
- ioToUgnM (_ccall_ gdummy t) `thenUgn` \ x_gdummy ->
- rdU_infixTree x_gdummy `thenUgn` \ y_gdummy ->
- returnUgn (U_tinfixop y_gdummy)
- else if tag == ``lsection'' then
- ioToUgnM (_ccall_ glsexp t) `thenUgn` \ x_glsexp ->
- rdU_tree x_glsexp `thenUgn` \ y_glsexp ->
- ioToUgnM (_ccall_ glsop t) `thenUgn` \ x_glsop ->
- rdU_unkId x_glsop `thenUgn` \ y_glsop ->
- returnUgn (U_lsection y_glsexp y_glsop)
- else if tag == ``rsection'' then
- ioToUgnM (_ccall_ grsop t) `thenUgn` \ x_grsop ->
- rdU_unkId x_grsop `thenUgn` \ y_grsop ->
- ioToUgnM (_ccall_ grsexp t) `thenUgn` \ x_grsexp ->
- rdU_tree x_grsexp `thenUgn` \ y_grsexp ->
- returnUgn (U_rsection y_grsop y_grsexp)
- else if tag == ``eenum'' then
- ioToUgnM (_ccall_ gefrom t) `thenUgn` \ x_gefrom ->
- rdU_tree x_gefrom `thenUgn` \ y_gefrom ->
- ioToUgnM (_ccall_ gestep t) `thenUgn` \ x_gestep ->
- rdU_list x_gestep `thenUgn` \ y_gestep ->
- ioToUgnM (_ccall_ geto t) `thenUgn` \ x_geto ->
- rdU_list x_geto `thenUgn` \ y_geto ->
- returnUgn (U_eenum y_gefrom y_gestep y_geto)
- else if tag == ``llist'' then
- ioToUgnM (_ccall_ gllist t) `thenUgn` \ x_gllist ->
- rdU_list x_gllist `thenUgn` \ y_gllist ->
- returnUgn (U_llist y_gllist)
- else if tag == ``ccall'' then
- ioToUgnM (_ccall_ gccid t) `thenUgn` \ x_gccid ->
- rdU_stringId x_gccid `thenUgn` \ y_gccid ->
- ioToUgnM (_ccall_ gccinfo t) `thenUgn` \ x_gccinfo ->
- rdU_stringId x_gccinfo `thenUgn` \ y_gccinfo ->
- ioToUgnM (_ccall_ gccargs t) `thenUgn` \ x_gccargs ->
- rdU_list x_gccargs `thenUgn` \ y_gccargs ->
- returnUgn (U_ccall y_gccid y_gccinfo y_gccargs)
- else if tag == ``scc'' then
- ioToUgnM (_ccall_ gsccid t) `thenUgn` \ x_gsccid ->
- rdU_hstring x_gsccid `thenUgn` \ y_gsccid ->
- ioToUgnM (_ccall_ gsccexp t) `thenUgn` \ x_gsccexp ->
- rdU_tree x_gsccexp `thenUgn` \ y_gsccexp ->
- returnUgn (U_scc y_gsccid y_gsccexp)
- else if tag == ``negate'' then
- ioToUgnM (_ccall_ gnexp t) `thenUgn` \ x_gnexp ->
- rdU_tree x_gnexp `thenUgn` \ y_gnexp ->
- returnUgn (U_negate y_gnexp)
- else
- error ("rdU_tree: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_treeHACK where
-import UgenUtil
-import Util
-
-import U_binding
-import U_coresyn ( U_coresyn ) -- interface only
-import U_hpragma ( U_hpragma ) -- interface only
-import U_list
-import U_literal
-import U_ttype
-
-type U_infixTree = (ProtoName, U_tree, U_tree)
-
-rdU_infixTree :: _Addr -> UgnM U_infixTree
-rdU_infixTree pt
- = ioToUgnM (_casm_ ``%r = gident(*Rginfun((struct Sap *)%0));'' pt) `thenUgn` \ op_t ->
- ioToUgnM (_casm_ ``%r = (*Rginarg1((struct Sap *)%0));'' pt) `thenUgn` \ arg1_t ->
- ioToUgnM (_casm_ ``%r = (*Rginarg2((struct Sap *)%0));'' pt) `thenUgn` \ arg2_t ->
-
- rdU_unkId op_t `thenUgn` \ op ->
- rdU_tree arg1_t `thenUgn` \ arg1 ->
- rdU_tree arg2_t `thenUgn` \ arg2 ->
- returnUgn (op, arg1, arg2)
-
-data U_tree = U_hmodule U_stringId U_list U_list U_binding U_long | U_ident U_unkId | U_lit U_literal | U_tuple U_list | U_ap U_tree U_tree | U_lambda U_list U_tree U_long | U_let U_binding U_tree | U_casee U_tree U_list | U_ife U_tree U_tree U_tree | U_par U_tree | U_as U_unkId U_tree | U_lazyp U_tree | U_plusp U_tree U_literal | U_wildp | U_restr U_tree U_ttype | U_comprh U_tree U_list | U_qual U_tree U_tree | U_guard U_tree | U_def U_tree | U_tinfixop U_infixTree | U_lsection U_tree U_unkId | U_rsection U_unkId U_tree | U_eenum U_tree U_list U_list | U_llist U_list | U_ccall U_stringId U_stringId U_list | U_scc U_hstring U_tree | U_negate U_tree
-
-rdU_tree :: _Addr -> UgnM U_tree
-rdU_tree t
- = ioToUgnM (_ccall_ ttree t) `thenUgn` \ tag@(I# _) ->
- if tag == ``hmodule'' then
- ioToUgnM (_ccall_ ghname t) `thenUgn` \ x_ghname ->
- rdU_stringId x_ghname `thenUgn` \ y_ghname ->
- ioToUgnM (_ccall_ ghimplist t) `thenUgn` \ x_ghimplist ->
- rdU_list x_ghimplist `thenUgn` \ y_ghimplist ->
- ioToUgnM (_ccall_ ghexplist t) `thenUgn` \ x_ghexplist ->
- rdU_list x_ghexplist `thenUgn` \ y_ghexplist ->
- ioToUgnM (_ccall_ ghmodlist t) `thenUgn` \ x_ghmodlist ->
- rdU_binding x_ghmodlist `thenUgn` \ y_ghmodlist ->
- ioToUgnM (_ccall_ ghmodline t) `thenUgn` \ x_ghmodline ->
- rdU_long x_ghmodline `thenUgn` \ y_ghmodline ->
- returnUgn (U_hmodule y_ghname y_ghimplist y_ghexplist y_ghmodlist y_ghmodline)
- else if tag == ``ident'' then
- ioToUgnM (_ccall_ gident t) `thenUgn` \ x_gident ->
- rdU_unkId x_gident `thenUgn` \ y_gident ->
- returnUgn (U_ident y_gident)
- else if tag == ``lit'' then
- ioToUgnM (_ccall_ glit t) `thenUgn` \ x_glit ->
- rdU_literal x_glit `thenUgn` \ y_glit ->
- returnUgn (U_lit y_glit)
- else if tag == ``tuple'' then
- ioToUgnM (_ccall_ gtuplelist t) `thenUgn` \ x_gtuplelist ->
- rdU_list x_gtuplelist `thenUgn` \ y_gtuplelist ->
- returnUgn (U_tuple y_gtuplelist)
- else if tag == ``ap'' then
- ioToUgnM (_ccall_ gfun t) `thenUgn` \ x_gfun ->
- rdU_tree x_gfun `thenUgn` \ y_gfun ->
- ioToUgnM (_ccall_ garg t) `thenUgn` \ x_garg ->
- rdU_tree x_garg `thenUgn` \ y_garg ->
- returnUgn (U_ap y_gfun y_garg)
- else if tag == ``lambda'' then
- ioToUgnM (_ccall_ glampats t) `thenUgn` \ x_glampats ->
- rdU_list x_glampats `thenUgn` \ y_glampats ->
- ioToUgnM (_ccall_ glamexpr t) `thenUgn` \ x_glamexpr ->
- rdU_tree x_glamexpr `thenUgn` \ y_glamexpr ->
- ioToUgnM (_ccall_ glamline t) `thenUgn` \ x_glamline ->
- rdU_long x_glamline `thenUgn` \ y_glamline ->
- returnUgn (U_lambda y_glampats y_glamexpr y_glamline)
- else if tag == ``let'' then
- ioToUgnM (_ccall_ gletvdeflist t) `thenUgn` \ x_gletvdeflist ->
- rdU_binding x_gletvdeflist `thenUgn` \ y_gletvdeflist ->
- ioToUgnM (_ccall_ gletvexpr t) `thenUgn` \ x_gletvexpr ->
- rdU_tree x_gletvexpr `thenUgn` \ y_gletvexpr ->
- returnUgn (U_let y_gletvdeflist y_gletvexpr)
- else if tag == ``casee'' then
- ioToUgnM (_ccall_ gcaseexpr t) `thenUgn` \ x_gcaseexpr ->
- rdU_tree x_gcaseexpr `thenUgn` \ y_gcaseexpr ->
- ioToUgnM (_ccall_ gcasebody t) `thenUgn` \ x_gcasebody ->
- rdU_list x_gcasebody `thenUgn` \ y_gcasebody ->
- returnUgn (U_casee y_gcaseexpr y_gcasebody)
- else if tag == ``ife'' then
- ioToUgnM (_ccall_ gifpred t) `thenUgn` \ x_gifpred ->
- rdU_tree x_gifpred `thenUgn` \ y_gifpred ->
- ioToUgnM (_ccall_ gifthen t) `thenUgn` \ x_gifthen ->
- rdU_tree x_gifthen `thenUgn` \ y_gifthen ->
- ioToUgnM (_ccall_ gifelse t) `thenUgn` \ x_gifelse ->
- rdU_tree x_gifelse `thenUgn` \ y_gifelse ->
- returnUgn (U_ife y_gifpred y_gifthen y_gifelse)
- else if tag == ``par'' then
- ioToUgnM (_ccall_ gpare t) `thenUgn` \ x_gpare ->
- rdU_tree x_gpare `thenUgn` \ y_gpare ->
- returnUgn (U_par y_gpare)
- else if tag == ``as'' then
- ioToUgnM (_ccall_ gasid t) `thenUgn` \ x_gasid ->
- rdU_unkId x_gasid `thenUgn` \ y_gasid ->
- ioToUgnM (_ccall_ gase t) `thenUgn` \ x_gase ->
- rdU_tree x_gase `thenUgn` \ y_gase ->
- returnUgn (U_as y_gasid y_gase)
- else if tag == ``lazyp'' then
- ioToUgnM (_ccall_ glazyp t) `thenUgn` \ x_glazyp ->
- rdU_tree x_glazyp `thenUgn` \ y_glazyp ->
- returnUgn (U_lazyp y_glazyp)
- else if tag == ``plusp'' then
- ioToUgnM (_ccall_ gplusp t) `thenUgn` \ x_gplusp ->
- rdU_tree x_gplusp `thenUgn` \ y_gplusp ->
- ioToUgnM (_ccall_ gplusi t) `thenUgn` \ x_gplusi ->
- rdU_literal x_gplusi `thenUgn` \ y_gplusi ->
- returnUgn (U_plusp y_gplusp y_gplusi)
- else if tag == ``wildp'' then
- returnUgn (U_wildp )
- else if tag == ``restr'' then
- ioToUgnM (_ccall_ grestre t) `thenUgn` \ x_grestre ->
- rdU_tree x_grestre `thenUgn` \ y_grestre ->
- ioToUgnM (_ccall_ grestrt t) `thenUgn` \ x_grestrt ->
- rdU_ttype x_grestrt `thenUgn` \ y_grestrt ->
- returnUgn (U_restr y_grestre y_grestrt)
- else if tag == ``comprh'' then
- ioToUgnM (_ccall_ gcexp t) `thenUgn` \ x_gcexp ->
- rdU_tree x_gcexp `thenUgn` \ y_gcexp ->
- ioToUgnM (_ccall_ gcquals t) `thenUgn` \ x_gcquals ->
- rdU_list x_gcquals `thenUgn` \ y_gcquals ->
- returnUgn (U_comprh y_gcexp y_gcquals)
- else if tag == ``qual'' then
- ioToUgnM (_ccall_ gqpat t) `thenUgn` \ x_gqpat ->
- rdU_tree x_gqpat `thenUgn` \ y_gqpat ->
- ioToUgnM (_ccall_ gqexp t) `thenUgn` \ x_gqexp ->
- rdU_tree x_gqexp `thenUgn` \ y_gqexp ->
- returnUgn (U_qual y_gqpat y_gqexp)
- else if tag == ``guard'' then
- ioToUgnM (_ccall_ ggexp t) `thenUgn` \ x_ggexp ->
- rdU_tree x_ggexp `thenUgn` \ y_ggexp ->
- returnUgn (U_guard y_ggexp)
- else if tag == ``def'' then
- ioToUgnM (_ccall_ ggdef t) `thenUgn` \ x_ggdef ->
- rdU_tree x_ggdef `thenUgn` \ y_ggdef ->
- returnUgn (U_def y_ggdef)
- else if tag == ``tinfixop'' then
--- ioToUgnM (_ccall_ gdummy t) `thenUgn` \ x_gdummy ->
- rdU_infixTree t {-THIS IS THE HACK-} `thenUgn` \ y_gdummy ->
- returnUgn (U_tinfixop y_gdummy)
- else if tag == ``lsection'' then
- ioToUgnM (_ccall_ glsexp t) `thenUgn` \ x_glsexp ->
- rdU_tree x_glsexp `thenUgn` \ y_glsexp ->
- ioToUgnM (_ccall_ glsop t) `thenUgn` \ x_glsop ->
- rdU_unkId x_glsop `thenUgn` \ y_glsop ->
- returnUgn (U_lsection y_glsexp y_glsop)
- else if tag == ``rsection'' then
- ioToUgnM (_ccall_ grsop t) `thenUgn` \ x_grsop ->
- rdU_unkId x_grsop `thenUgn` \ y_grsop ->
- ioToUgnM (_ccall_ grsexp t) `thenUgn` \ x_grsexp ->
- rdU_tree x_grsexp `thenUgn` \ y_grsexp ->
- returnUgn (U_rsection y_grsop y_grsexp)
- else if tag == ``eenum'' then
- ioToUgnM (_ccall_ gefrom t) `thenUgn` \ x_gefrom ->
- rdU_tree x_gefrom `thenUgn` \ y_gefrom ->
- ioToUgnM (_ccall_ gestep t) `thenUgn` \ x_gestep ->
- rdU_list x_gestep `thenUgn` \ y_gestep ->
- ioToUgnM (_ccall_ geto t) `thenUgn` \ x_geto ->
- rdU_list x_geto `thenUgn` \ y_geto ->
- returnUgn (U_eenum y_gefrom y_gestep y_geto)
- else if tag == ``llist'' then
- ioToUgnM (_ccall_ gllist t) `thenUgn` \ x_gllist ->
- rdU_list x_gllist `thenUgn` \ y_gllist ->
- returnUgn (U_llist y_gllist)
- else if tag == ``ccall'' then
- ioToUgnM (_ccall_ gccid t) `thenUgn` \ x_gccid ->
- rdU_stringId x_gccid `thenUgn` \ y_gccid ->
- ioToUgnM (_ccall_ gccinfo t) `thenUgn` \ x_gccinfo ->
- rdU_stringId x_gccinfo `thenUgn` \ y_gccinfo ->
- ioToUgnM (_ccall_ gccargs t) `thenUgn` \ x_gccargs ->
- rdU_list x_gccargs `thenUgn` \ y_gccargs ->
- returnUgn (U_ccall y_gccid y_gccinfo y_gccargs)
- else if tag == ``scc'' then
- ioToUgnM (_ccall_ gsccid t) `thenUgn` \ x_gsccid ->
- rdU_hstring x_gsccid `thenUgn` \ y_gsccid ->
- ioToUgnM (_ccall_ gsccexp t) `thenUgn` \ x_gsccexp ->
- rdU_tree x_gsccexp `thenUgn` \ y_gsccexp ->
- returnUgn (U_scc y_gsccid y_gsccexp)
- else if tag == ``negate'' then
- ioToUgnM (_ccall_ gnexp t) `thenUgn` \ x_gnexp ->
- rdU_tree x_gnexp `thenUgn` \ y_gnexp ->
- returnUgn (U_negate y_gnexp)
- else
- error ("rdU_tree: bad tag selection:"++show tag++"\n")
+++ /dev/null
-
-
-module U_ttype where
-import UgenUtil
-import Util
-
-import U_list
-data U_ttype = U_tname U_unkId U_list | U_namedtvar U_unkId | U_tllist U_ttype | U_ttuple U_list | U_tfun U_ttype U_ttype | U_context U_list U_ttype | U_unidict U_unkId U_ttype | U_unityvartemplate U_unkId | U_uniforall U_list U_ttype | U_ty_maybe_nothing | U_ty_maybe_just U_ttype
-
-rdU_ttype :: _Addr -> UgnM U_ttype
-rdU_ttype t
- = ioToUgnM (_ccall_ tttype t) `thenUgn` \ tag@(I# _) ->
- if tag == ``tname'' then
- ioToUgnM (_ccall_ gtypeid t) `thenUgn` \ x_gtypeid ->
- rdU_unkId x_gtypeid `thenUgn` \ y_gtypeid ->
- ioToUgnM (_ccall_ gtypel t) `thenUgn` \ x_gtypel ->
- rdU_list x_gtypel `thenUgn` \ y_gtypel ->
- returnUgn (U_tname y_gtypeid y_gtypel)
- else if tag == ``namedtvar'' then
- ioToUgnM (_ccall_ gnamedtvar t) `thenUgn` \ x_gnamedtvar ->
- rdU_unkId x_gnamedtvar `thenUgn` \ y_gnamedtvar ->
- returnUgn (U_namedtvar y_gnamedtvar)
- else if tag == ``tllist'' then
- ioToUgnM (_ccall_ gtlist t) `thenUgn` \ x_gtlist ->
- rdU_ttype x_gtlist `thenUgn` \ y_gtlist ->
- returnUgn (U_tllist y_gtlist)
- else if tag == ``ttuple'' then
- ioToUgnM (_ccall_ gttuple t) `thenUgn` \ x_gttuple ->
- rdU_list x_gttuple `thenUgn` \ y_gttuple ->
- returnUgn (U_ttuple y_gttuple)
- else if tag == ``tfun'' then
- ioToUgnM (_ccall_ gtfun t) `thenUgn` \ x_gtfun ->
- rdU_ttype x_gtfun `thenUgn` \ y_gtfun ->
- ioToUgnM (_ccall_ gtarg t) `thenUgn` \ x_gtarg ->
- rdU_ttype x_gtarg `thenUgn` \ y_gtarg ->
- returnUgn (U_tfun y_gtfun y_gtarg)
- else if tag == ``context'' then
- ioToUgnM (_ccall_ gtcontextl t) `thenUgn` \ x_gtcontextl ->
- rdU_list x_gtcontextl `thenUgn` \ y_gtcontextl ->
- ioToUgnM (_ccall_ gtcontextt t) `thenUgn` \ x_gtcontextt ->
- rdU_ttype x_gtcontextt `thenUgn` \ y_gtcontextt ->
- returnUgn (U_context y_gtcontextl y_gtcontextt)
- else if tag == ``unidict'' then
- ioToUgnM (_ccall_ gunidict_clas t) `thenUgn` \ x_gunidict_clas ->
- rdU_unkId x_gunidict_clas `thenUgn` \ y_gunidict_clas ->
- ioToUgnM (_ccall_ gunidict_ty t) `thenUgn` \ x_gunidict_ty ->
- rdU_ttype x_gunidict_ty `thenUgn` \ y_gunidict_ty ->
- returnUgn (U_unidict y_gunidict_clas y_gunidict_ty)
- else if tag == ``unityvartemplate'' then
- ioToUgnM (_ccall_ gunityvartemplate t) `thenUgn` \ x_gunityvartemplate ->
- rdU_unkId x_gunityvartemplate `thenUgn` \ y_gunityvartemplate ->
- returnUgn (U_unityvartemplate y_gunityvartemplate)
- else if tag == ``uniforall'' then
- ioToUgnM (_ccall_ guniforall_tv t) `thenUgn` \ x_guniforall_tv ->
- rdU_list x_guniforall_tv `thenUgn` \ y_guniforall_tv ->
- ioToUgnM (_ccall_ guniforall_ty t) `thenUgn` \ x_guniforall_ty ->
- rdU_ttype x_guniforall_ty `thenUgn` \ y_guniforall_ty ->
- returnUgn (U_uniforall y_guniforall_tv y_guniforall_ty)
- else if tag == ``ty_maybe_nothing'' then
- returnUgn (U_ty_maybe_nothing )
- else if tag == ``ty_maybe_just'' then
- ioToUgnM (_ccall_ gty_maybe t) `thenUgn` \ x_gty_maybe ->
- rdU_ttype x_gty_maybe `thenUgn` \ y_gty_maybe ->
- returnUgn (U_ty_maybe_just y_gty_maybe)
- else
- error ("rdU_ttype: bad tag selection:"++show tag++"\n")
+++ /dev/null
-Stuff the Ugenny things show to the parser.
-
-\begin{code}
-module UgenAll (
- -- re-exported Prelude stuff
- returnUgn, thenUgn,
-
- -- stuff defined in utils module
- UgenUtil.. ,
-
- -- re-exported ugen-generated stuff
- U_atype.. ,
- U_coresyn.. ,
- U_hpragma.. ,
- U_binding.. ,
- U_treeHACK.. ,
- U_entidt.. ,
- U_finfot.. ,
- U_list.. ,
- U_literal.. ,
- U_pbinding.. ,
- U_ttype..
-
- ) where
-
-#if __GLASGOW_HASKELL__ < 26
-import PreludePrimIO
-#else
-import PreludeGlaST
-#endif
-
-import U_atype
-import U_binding
-import U_coresyn
-import U_entidt
-import U_finfot
-import U_hpragma
-import U_list
-import U_literal
-import U_pbinding
-import U_treeHACK
-import U_ttype
-
-import SrcLoc ( SrcLoc )
-import Outputable
-import UgenUtil
-import Util
-\end{code}
+++ /dev/null
-Glues lots of things together for ugen-generated
-.hs files here
-
-\begin{code}
-#include "HsVersions.h"
-
-module UgenUtil (
- -- re-exported Prelude stuff
- returnPrimIO, thenPrimIO,
-
- -- stuff defined here
- UgenUtil..,
-
- -- complete interface
- ProtoName
- ) where
-
-#if __GLASGOW_HASKELL__ < 26
-import PreludePrimIO
-#else
-import PreludeGlaST
-#endif
-import MainMonad
-
-import ProtoName
-import Outputable
-import SrcLoc ( mkSrcLoc2 )
-import Util
-\end{code}
-
-\begin{code}
-type UgnM a
- = FAST_STRING -- source file name; carried down
- -> PrimIO a
-
-{-# INLINE returnUgn #-}
-{-# INLINE thenUgn #-}
-
-returnUgn x mod = returnPrimIO x
-
-thenUgn x y mod
- = x mod `thenPrimIO` \ z ->
- y z mod
-
-initUgn :: FAST_STRING -> UgnM a -> MainIO a
-initUgn srcfile action
- = action srcfile
-
-ioToUgnM :: PrimIO a -> UgnM a
-ioToUgnM x mod = x
-\end{code}
-
-\begin{code}
-type ParseTree = _Addr
-
-type U_VOID_STAR = _Addr
-rdU_VOID_STAR :: _Addr -> UgnM U_VOID_STAR
-rdU_VOID_STAR x = returnUgn x
-
-type U_long = Int
-rdU_long :: Int -> UgnM U_long
-rdU_long x = returnUgn x -- (A# x) = returnUgn (I# (addr2Int# x))
-
-type U_unkId = ProtoName
-rdU_unkId :: _Addr -> UgnM U_unkId
-rdU_unkId x
- = rdU_stringId x `thenUgn` \ y ->
- returnUgn (Unk y)
-
-type U_stringId = FAST_STRING
-rdU_stringId :: _Addr -> UgnM U_stringId
-rdU_stringId s
- = ioToUgnM (_ccall_ hash_index s) `thenUgn` \ (I# i) ->
- returnUgn (_packCString s) -- ToDo: use the i!
-
-type U_numId = Int -- ToDo: Int
-rdU_numId :: _Addr -> UgnM U_numId
-rdU_numId i = rdU_stringId i `thenUgn` \ y -> returnUgn ((read (_UNPK_ y))::Int)
-
-type U_hstring = FAST_STRING
-rdU_hstring :: _Addr -> UgnM U_hstring
-rdU_hstring x
- = ioToUgnM (_ccall_ get_hstring_len x) `thenUgn` \ len ->
- ioToUgnM (_ccall_ get_hstring_bytes x) `thenUgn` \ bytes ->
- returnUgn (_packCBytes len bytes)
-\end{code}
-
-\begin{code}
-setSrcFileUgn :: FAST_STRING{-filename-} -> UgnM a -> UgnM a
-setSrcFileUgn file action _ = action file
-
-getSrcFileUgn :: UgnM FAST_STRING{-filename-}
-getSrcFileUgn mod = returnUgn mod mod
-
-mkSrcLocUgn :: U_long -> UgnM SrcLoc
-mkSrcLocUgn ln mod
- = returnUgn (mkSrcLoc2 mod ln) mod
-\end{code}
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/atype.h"
-
-Tatype tatype(t)
- atype t;
-{
- return(t -> tag);
-}
-
-
-/************** atc ******************/
-
-atype mkatc(PPgatcid, PPgatctypel, PPgatcline)
- unkId PPgatcid;
- list PPgatctypel;
- long PPgatcline;
-{
- register struct Satc *pp =
- (struct Satc *) malloc(sizeof(struct Satc));
- pp -> tag = atc;
- pp -> Xgatcid = PPgatcid;
- pp -> Xgatctypel = PPgatctypel;
- pp -> Xgatcline = PPgatcline;
- return((atype)pp);
-}
-
-unkId *Rgatcid(t)
- struct Satc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != atc)
- fprintf(stderr,"gatcid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgatcid);
-}
-
-list *Rgatctypel(t)
- struct Satc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != atc)
- fprintf(stderr,"gatctypel: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgatctypel);
-}
-
-long *Rgatcline(t)
- struct Satc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != atc)
- fprintf(stderr,"gatcline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgatcline);
-}
+++ /dev/null
-#ifndef atype_defined
-#define atype_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- atc
-} Tatype;
-
-typedef struct { Tatype tag; } *atype;
-
-#ifdef __GNUC__
-Tatype tatype(atype t);
-extern __inline__ Tatype tatype(atype t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tatype tatype PROTO((atype));
-#endif /* ! __GNUC__ */
-
-struct Satc {
- Tatype tag;
- unkId Xgatcid;
- list Xgatctypel;
- long Xgatcline;
-};
-
-extern atype mkatc PROTO((unkId, list, long));
-#ifdef __GNUC__
-
-unkId *Rgatcid PROTO((struct Satc *));
-
-extern __inline__ unkId *Rgatcid(struct Satc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != atc)
- fprintf(stderr,"gatcid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgatcid);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgatcid PROTO((struct Satc *));
-#endif /* ! __GNUC__ */
-
-#define gatcid(xyzxyz) (*Rgatcid((struct Satc *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgatctypel PROTO((struct Satc *));
-
-extern __inline__ list *Rgatctypel(struct Satc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != atc)
- fprintf(stderr,"gatctypel: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgatctypel);
-}
-#else /* ! __GNUC__ */
-extern list *Rgatctypel PROTO((struct Satc *));
-#endif /* ! __GNUC__ */
-
-#define gatctypel(xyzxyz) (*Rgatctypel((struct Satc *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgatcline PROTO((struct Satc *));
-
-extern __inline__ long *Rgatcline(struct Satc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != atc)
- fprintf(stderr,"gatcline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgatcline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgatcline PROTO((struct Satc *));
-#endif /* ! __GNUC__ */
-
-#define gatcline(xyzxyz) (*Rgatcline((struct Satc *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_atype where
-import UgenUtil
-import Util
-
-import U_list
-%}}
-type atype;
- atc : < gatcid : unkId;
- gatctypel : list;
- gatcline : long; >;
-end;
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/binding.h"
-
-Tbinding tbinding(t)
- binding t;
-{
- return(t -> tag);
-}
-
-
-/************** tbind ******************/
-
-binding mktbind(PPgtbindc, PPgtbindid, PPgtbindl, PPgtbindd, PPgtline, PPgtpragma)
- list PPgtbindc;
- ttype PPgtbindid;
- list PPgtbindl;
- list PPgtbindd;
- long PPgtline;
- hpragma PPgtpragma;
-{
- register struct Stbind *pp =
- (struct Stbind *) malloc(sizeof(struct Stbind));
- pp -> tag = tbind;
- pp -> Xgtbindc = PPgtbindc;
- pp -> Xgtbindid = PPgtbindid;
- pp -> Xgtbindl = PPgtbindl;
- pp -> Xgtbindd = PPgtbindd;
- pp -> Xgtline = PPgtline;
- pp -> Xgtpragma = PPgtpragma;
- return((binding)pp);
-}
-
-list *Rgtbindc(t)
- struct Stbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtbindc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtbindc);
-}
-
-ttype *Rgtbindid(t)
- struct Stbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtbindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtbindid);
-}
-
-list *Rgtbindl(t)
- struct Stbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtbindl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtbindl);
-}
-
-list *Rgtbindd(t)
- struct Stbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtbindd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtbindd);
-}
-
-long *Rgtline(t)
- struct Stbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtline);
-}
-
-hpragma *Rgtpragma(t)
- struct Stbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtpragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtpragma);
-}
-
-/************** nbind ******************/
-
-binding mknbind(PPgnbindid, PPgnbindas, PPgnline, PPgnpragma)
- ttype PPgnbindid;
- ttype PPgnbindas;
- long PPgnline;
- hpragma PPgnpragma;
-{
- register struct Snbind *pp =
- (struct Snbind *) malloc(sizeof(struct Snbind));
- pp -> tag = nbind;
- pp -> Xgnbindid = PPgnbindid;
- pp -> Xgnbindas = PPgnbindas;
- pp -> Xgnline = PPgnline;
- pp -> Xgnpragma = PPgnpragma;
- return((binding)pp);
-}
-
-ttype *Rgnbindid(t)
- struct Snbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != nbind)
- fprintf(stderr,"gnbindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnbindid);
-}
-
-ttype *Rgnbindas(t)
- struct Snbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != nbind)
- fprintf(stderr,"gnbindas: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnbindas);
-}
-
-long *Rgnline(t)
- struct Snbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != nbind)
- fprintf(stderr,"gnline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnline);
-}
-
-hpragma *Rgnpragma(t)
- struct Snbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != nbind)
- fprintf(stderr,"gnpragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnpragma);
-}
-
-/************** pbind ******************/
-
-binding mkpbind(PPgpbindl, PPgpline)
- list PPgpbindl;
- long PPgpline;
-{
- register struct Spbind *pp =
- (struct Spbind *) malloc(sizeof(struct Spbind));
- pp -> tag = pbind;
- pp -> Xgpbindl = PPgpbindl;
- pp -> Xgpline = PPgpline;
- return((binding)pp);
-}
-
-list *Rgpbindl(t)
- struct Spbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pbind)
- fprintf(stderr,"gpbindl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgpbindl);
-}
-
-long *Rgpline(t)
- struct Spbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pbind)
- fprintf(stderr,"gpline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgpline);
-}
-
-/************** fbind ******************/
-
-binding mkfbind(PPgfbindl, PPgfline)
- list PPgfbindl;
- long PPgfline;
-{
- register struct Sfbind *pp =
- (struct Sfbind *) malloc(sizeof(struct Sfbind));
- pp -> tag = fbind;
- pp -> Xgfbindl = PPgfbindl;
- pp -> Xgfline = PPgfline;
- return((binding)pp);
-}
-
-list *Rgfbindl(t)
- struct Sfbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != fbind)
- fprintf(stderr,"gfbindl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfbindl);
-}
-
-long *Rgfline(t)
- struct Sfbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != fbind)
- fprintf(stderr,"gfline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfline);
-}
-
-/************** abind ******************/
-
-binding mkabind(PPgabindfst, PPgabindsnd)
- binding PPgabindfst;
- binding PPgabindsnd;
-{
- register struct Sabind *pp =
- (struct Sabind *) malloc(sizeof(struct Sabind));
- pp -> tag = abind;
- pp -> Xgabindfst = PPgabindfst;
- pp -> Xgabindsnd = PPgabindsnd;
- return((binding)pp);
-}
-
-binding *Rgabindfst(t)
- struct Sabind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != abind)
- fprintf(stderr,"gabindfst: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgabindfst);
-}
-
-binding *Rgabindsnd(t)
- struct Sabind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != abind)
- fprintf(stderr,"gabindsnd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgabindsnd);
-}
-
-/************** ibind ******************/
-
-binding mkibind(PPgibindc, PPgibindid, PPgibindi, PPgibindw, PPgiline, PPgipragma)
- list PPgibindc;
- unkId PPgibindid;
- ttype PPgibindi;
- binding PPgibindw;
- long PPgiline;
- hpragma PPgipragma;
-{
- register struct Sibind *pp =
- (struct Sibind *) malloc(sizeof(struct Sibind));
- pp -> tag = ibind;
- pp -> Xgibindc = PPgibindc;
- pp -> Xgibindid = PPgibindid;
- pp -> Xgibindi = PPgibindi;
- pp -> Xgibindw = PPgibindw;
- pp -> Xgiline = PPgiline;
- pp -> Xgipragma = PPgipragma;
- return((binding)pp);
-}
-
-list *Rgibindc(t)
- struct Sibind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gibindc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgibindc);
-}
-
-unkId *Rgibindid(t)
- struct Sibind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gibindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgibindid);
-}
-
-ttype *Rgibindi(t)
- struct Sibind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gibindi: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgibindi);
-}
-
-binding *Rgibindw(t)
- struct Sibind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gibindw: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgibindw);
-}
-
-long *Rgiline(t)
- struct Sibind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"giline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiline);
-}
-
-hpragma *Rgipragma(t)
- struct Sibind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gipragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgipragma);
-}
-
-/************** dbind ******************/
-
-binding mkdbind(PPgdbindts, PPgdline)
- list PPgdbindts;
- long PPgdline;
-{
- register struct Sdbind *pp =
- (struct Sdbind *) malloc(sizeof(struct Sdbind));
- pp -> tag = dbind;
- pp -> Xgdbindts = PPgdbindts;
- pp -> Xgdline = PPgdline;
- return((binding)pp);
-}
-
-list *Rgdbindts(t)
- struct Sdbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dbind)
- fprintf(stderr,"gdbindts: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdbindts);
-}
-
-long *Rgdline(t)
- struct Sdbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dbind)
- fprintf(stderr,"gdline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdline);
-}
-
-/************** cbind ******************/
-
-binding mkcbind(PPgcbindc, PPgcbindid, PPgcbindw, PPgcline, PPgcpragma)
- list PPgcbindc;
- ttype PPgcbindid;
- binding PPgcbindw;
- long PPgcline;
- hpragma PPgcpragma;
-{
- register struct Scbind *pp =
- (struct Scbind *) malloc(sizeof(struct Scbind));
- pp -> tag = cbind;
- pp -> Xgcbindc = PPgcbindc;
- pp -> Xgcbindid = PPgcbindid;
- pp -> Xgcbindw = PPgcbindw;
- pp -> Xgcline = PPgcline;
- pp -> Xgcpragma = PPgcpragma;
- return((binding)pp);
-}
-
-list *Rgcbindc(t)
- struct Scbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcbindc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcbindc);
-}
-
-ttype *Rgcbindid(t)
- struct Scbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcbindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcbindid);
-}
-
-binding *Rgcbindw(t)
- struct Scbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcbindw: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcbindw);
-}
-
-long *Rgcline(t)
- struct Scbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcline);
-}
-
-hpragma *Rgcpragma(t)
- struct Scbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcpragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcpragma);
-}
-
-/************** sbind ******************/
-
-binding mksbind(PPgsbindids, PPgsbindid, PPgsline, PPgspragma)
- list PPgsbindids;
- ttype PPgsbindid;
- long PPgsline;
- hpragma PPgspragma;
-{
- register struct Ssbind *pp =
- (struct Ssbind *) malloc(sizeof(struct Ssbind));
- pp -> tag = sbind;
- pp -> Xgsbindids = PPgsbindids;
- pp -> Xgsbindid = PPgsbindid;
- pp -> Xgsline = PPgsline;
- pp -> Xgspragma = PPgspragma;
- return((binding)pp);
-}
-
-list *Rgsbindids(t)
- struct Ssbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != sbind)
- fprintf(stderr,"gsbindids: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsbindids);
-}
-
-ttype *Rgsbindid(t)
- struct Ssbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != sbind)
- fprintf(stderr,"gsbindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsbindid);
-}
-
-long *Rgsline(t)
- struct Ssbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != sbind)
- fprintf(stderr,"gsline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsline);
-}
-
-hpragma *Rgspragma(t)
- struct Ssbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != sbind)
- fprintf(stderr,"gspragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgspragma);
-}
-
-/************** mbind ******************/
-
-binding mkmbind(PPgmbindmodn, PPgmbindimp, PPgmbindren, PPgmline)
- stringId PPgmbindmodn;
- list PPgmbindimp;
- list PPgmbindren;
- long PPgmline;
-{
- register struct Smbind *pp =
- (struct Smbind *) malloc(sizeof(struct Smbind));
- pp -> tag = mbind;
- pp -> Xgmbindmodn = PPgmbindmodn;
- pp -> Xgmbindimp = PPgmbindimp;
- pp -> Xgmbindren = PPgmbindren;
- pp -> Xgmline = PPgmline;
- return((binding)pp);
-}
-
-stringId *Rgmbindmodn(t)
- struct Smbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != mbind)
- fprintf(stderr,"gmbindmodn: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmbindmodn);
-}
-
-list *Rgmbindimp(t)
- struct Smbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != mbind)
- fprintf(stderr,"gmbindimp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmbindimp);
-}
-
-list *Rgmbindren(t)
- struct Smbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != mbind)
- fprintf(stderr,"gmbindren: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmbindren);
-}
-
-long *Rgmline(t)
- struct Smbind *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != mbind)
- fprintf(stderr,"gmline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmline);
-}
-
-/************** nullbind ******************/
-
-binding mknullbind(void)
-{
- register struct Snullbind *pp =
- (struct Snullbind *) malloc(sizeof(struct Snullbind));
- pp -> tag = nullbind;
- return((binding)pp);
-}
-
-/************** import ******************/
-
-binding mkimport(PPgiebindmod, PPgiebindexp, PPgiebindren, PPgiebinddef, PPgiebindfile, PPgiebindline)
- stringId PPgiebindmod;
- list PPgiebindexp;
- list PPgiebindren;
- binding PPgiebinddef;
- stringId PPgiebindfile;
- long PPgiebindline;
-{
- register struct Simport *pp =
- (struct Simport *) malloc(sizeof(struct Simport));
- pp -> tag = import;
- pp -> Xgiebindmod = PPgiebindmod;
- pp -> Xgiebindexp = PPgiebindexp;
- pp -> Xgiebindren = PPgiebindren;
- pp -> Xgiebinddef = PPgiebinddef;
- pp -> Xgiebindfile = PPgiebindfile;
- pp -> Xgiebindline = PPgiebindline;
- return((binding)pp);
-}
-
-stringId *Rgiebindmod(t)
- struct Simport *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindmod: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindmod);
-}
-
-list *Rgiebindexp(t)
- struct Simport *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindexp);
-}
-
-list *Rgiebindren(t)
- struct Simport *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindren: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindren);
-}
-
-binding *Rgiebinddef(t)
- struct Simport *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebinddef: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebinddef);
-}
-
-stringId *Rgiebindfile(t)
- struct Simport *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindfile: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindfile);
-}
-
-long *Rgiebindline(t)
- struct Simport *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindline);
-}
-
-/************** hiding ******************/
-
-binding mkhiding(PPgihbindmod, PPgihbindexp, PPgihbindren, PPgihbinddef, PPgihbindfile, PPgihbindline)
- stringId PPgihbindmod;
- list PPgihbindexp;
- list PPgihbindren;
- binding PPgihbinddef;
- stringId PPgihbindfile;
- long PPgihbindline;
-{
- register struct Shiding *pp =
- (struct Shiding *) malloc(sizeof(struct Shiding));
- pp -> tag = hiding;
- pp -> Xgihbindmod = PPgihbindmod;
- pp -> Xgihbindexp = PPgihbindexp;
- pp -> Xgihbindren = PPgihbindren;
- pp -> Xgihbinddef = PPgihbinddef;
- pp -> Xgihbindfile = PPgihbindfile;
- pp -> Xgihbindline = PPgihbindline;
- return((binding)pp);
-}
-
-stringId *Rgihbindmod(t)
- struct Shiding *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindmod: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindmod);
-}
-
-list *Rgihbindexp(t)
- struct Shiding *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindexp);
-}
-
-list *Rgihbindren(t)
- struct Shiding *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindren: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindren);
-}
-
-binding *Rgihbinddef(t)
- struct Shiding *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbinddef: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbinddef);
-}
-
-stringId *Rgihbindfile(t)
- struct Shiding *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindfile: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindfile);
-}
-
-long *Rgihbindline(t)
- struct Shiding *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindline);
-}
-
-/************** vspec_uprag ******************/
-
-binding mkvspec_uprag(PPgvspec_id, PPgvspec_tys, PPgvspec_line)
- unkId PPgvspec_id;
- list PPgvspec_tys;
- long PPgvspec_line;
-{
- register struct Svspec_uprag *pp =
- (struct Svspec_uprag *) malloc(sizeof(struct Svspec_uprag));
- pp -> tag = vspec_uprag;
- pp -> Xgvspec_id = PPgvspec_id;
- pp -> Xgvspec_tys = PPgvspec_tys;
- pp -> Xgvspec_line = PPgvspec_line;
- return((binding)pp);
-}
-
-unkId *Rgvspec_id(t)
- struct Svspec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_uprag)
- fprintf(stderr,"gvspec_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_id);
-}
-
-list *Rgvspec_tys(t)
- struct Svspec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_uprag)
- fprintf(stderr,"gvspec_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_tys);
-}
-
-long *Rgvspec_line(t)
- struct Svspec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_uprag)
- fprintf(stderr,"gvspec_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_line);
-}
-
-/************** vspec_ty_and_id ******************/
-
-binding mkvspec_ty_and_id(PPgvspec_ty, PPgvspec_tyid)
- ttype PPgvspec_ty;
- list PPgvspec_tyid;
-{
- register struct Svspec_ty_and_id *pp =
- (struct Svspec_ty_and_id *) malloc(sizeof(struct Svspec_ty_and_id));
- pp -> tag = vspec_ty_and_id;
- pp -> Xgvspec_ty = PPgvspec_ty;
- pp -> Xgvspec_tyid = PPgvspec_tyid;
- return((binding)pp);
-}
-
-ttype *Rgvspec_ty(t)
- struct Svspec_ty_and_id *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_ty_and_id)
- fprintf(stderr,"gvspec_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_ty);
-}
-
-list *Rgvspec_tyid(t)
- struct Svspec_ty_and_id *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_ty_and_id)
- fprintf(stderr,"gvspec_tyid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_tyid);
-}
-
-/************** ispec_uprag ******************/
-
-binding mkispec_uprag(PPgispec_clas, PPgispec_ty, PPgispec_line)
- unkId PPgispec_clas;
- ttype PPgispec_ty;
- long PPgispec_line;
-{
- register struct Sispec_uprag *pp =
- (struct Sispec_uprag *) malloc(sizeof(struct Sispec_uprag));
- pp -> tag = ispec_uprag;
- pp -> Xgispec_clas = PPgispec_clas;
- pp -> Xgispec_ty = PPgispec_ty;
- pp -> Xgispec_line = PPgispec_line;
- return((binding)pp);
-}
-
-unkId *Rgispec_clas(t)
- struct Sispec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ispec_uprag)
- fprintf(stderr,"gispec_clas: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgispec_clas);
-}
-
-ttype *Rgispec_ty(t)
- struct Sispec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ispec_uprag)
- fprintf(stderr,"gispec_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgispec_ty);
-}
-
-long *Rgispec_line(t)
- struct Sispec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ispec_uprag)
- fprintf(stderr,"gispec_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgispec_line);
-}
-
-/************** inline_uprag ******************/
-
-binding mkinline_uprag(PPginline_id, PPginline_howto, PPginline_line)
- unkId PPginline_id;
- list PPginline_howto;
- long PPginline_line;
-{
- register struct Sinline_uprag *pp =
- (struct Sinline_uprag *) malloc(sizeof(struct Sinline_uprag));
- pp -> tag = inline_uprag;
- pp -> Xginline_id = PPginline_id;
- pp -> Xginline_howto = PPginline_howto;
- pp -> Xginline_line = PPginline_line;
- return((binding)pp);
-}
-
-unkId *Rginline_id(t)
- struct Sinline_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != inline_uprag)
- fprintf(stderr,"ginline_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xginline_id);
-}
-
-list *Rginline_howto(t)
- struct Sinline_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != inline_uprag)
- fprintf(stderr,"ginline_howto: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xginline_howto);
-}
-
-long *Rginline_line(t)
- struct Sinline_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != inline_uprag)
- fprintf(stderr,"ginline_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xginline_line);
-}
-
-/************** deforest_uprag ******************/
-
-binding mkdeforest_uprag(PPgdeforest_id, PPgdeforest_line)
- unkId PPgdeforest_id;
- long PPgdeforest_line;
-{
- register struct Sdeforest_uprag *pp =
- (struct Sdeforest_uprag *) malloc(sizeof(struct Sdeforest_uprag));
- pp -> tag = deforest_uprag;
- pp -> Xgdeforest_id = PPgdeforest_id;
- pp -> Xgdeforest_line = PPgdeforest_line;
- return((binding)pp);
-}
-
-unkId *Rgdeforest_id(t)
- struct Sdeforest_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != deforest_uprag)
- fprintf(stderr,"gdeforest_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdeforest_id);
-}
-
-long *Rgdeforest_line(t)
- struct Sdeforest_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != deforest_uprag)
- fprintf(stderr,"gdeforest_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdeforest_line);
-}
-
-/************** magicuf_uprag ******************/
-
-binding mkmagicuf_uprag(PPgmagicuf_id, PPgmagicuf_str, PPgmagicuf_line)
- unkId PPgmagicuf_id;
- stringId PPgmagicuf_str;
- long PPgmagicuf_line;
-{
- register struct Smagicuf_uprag *pp =
- (struct Smagicuf_uprag *) malloc(sizeof(struct Smagicuf_uprag));
- pp -> tag = magicuf_uprag;
- pp -> Xgmagicuf_id = PPgmagicuf_id;
- pp -> Xgmagicuf_str = PPgmagicuf_str;
- pp -> Xgmagicuf_line = PPgmagicuf_line;
- return((binding)pp);
-}
-
-unkId *Rgmagicuf_id(t)
- struct Smagicuf_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != magicuf_uprag)
- fprintf(stderr,"gmagicuf_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmagicuf_id);
-}
-
-stringId *Rgmagicuf_str(t)
- struct Smagicuf_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != magicuf_uprag)
- fprintf(stderr,"gmagicuf_str: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmagicuf_str);
-}
-
-long *Rgmagicuf_line(t)
- struct Smagicuf_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != magicuf_uprag)
- fprintf(stderr,"gmagicuf_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmagicuf_line);
-}
-
-/************** abstract_uprag ******************/
-
-binding mkabstract_uprag(PPgabstract_id, PPgabstract_line)
- unkId PPgabstract_id;
- long PPgabstract_line;
-{
- register struct Sabstract_uprag *pp =
- (struct Sabstract_uprag *) malloc(sizeof(struct Sabstract_uprag));
- pp -> tag = abstract_uprag;
- pp -> Xgabstract_id = PPgabstract_id;
- pp -> Xgabstract_line = PPgabstract_line;
- return((binding)pp);
-}
-
-unkId *Rgabstract_id(t)
- struct Sabstract_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != abstract_uprag)
- fprintf(stderr,"gabstract_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgabstract_id);
-}
-
-long *Rgabstract_line(t)
- struct Sabstract_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != abstract_uprag)
- fprintf(stderr,"gabstract_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgabstract_line);
-}
-
-/************** dspec_uprag ******************/
-
-binding mkdspec_uprag(PPgdspec_id, PPgdspec_tys, PPgdspec_line)
- unkId PPgdspec_id;
- list PPgdspec_tys;
- long PPgdspec_line;
-{
- register struct Sdspec_uprag *pp =
- (struct Sdspec_uprag *) malloc(sizeof(struct Sdspec_uprag));
- pp -> tag = dspec_uprag;
- pp -> Xgdspec_id = PPgdspec_id;
- pp -> Xgdspec_tys = PPgdspec_tys;
- pp -> Xgdspec_line = PPgdspec_line;
- return((binding)pp);
-}
-
-unkId *Rgdspec_id(t)
- struct Sdspec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dspec_uprag)
- fprintf(stderr,"gdspec_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdspec_id);
-}
-
-list *Rgdspec_tys(t)
- struct Sdspec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dspec_uprag)
- fprintf(stderr,"gdspec_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdspec_tys);
-}
-
-long *Rgdspec_line(t)
- struct Sdspec_uprag *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dspec_uprag)
- fprintf(stderr,"gdspec_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdspec_line);
-}
+++ /dev/null
-#ifndef binding_defined
-#define binding_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- tbind,
- nbind,
- pbind,
- fbind,
- abind,
- ibind,
- dbind,
- cbind,
- sbind,
- mbind,
- nullbind,
- import,
- hiding,
- vspec_uprag,
- vspec_ty_and_id,
- ispec_uprag,
- inline_uprag,
- deforest_uprag,
- magicuf_uprag,
- abstract_uprag,
- dspec_uprag
-} Tbinding;
-
-typedef struct { Tbinding tag; } *binding;
-
-#ifdef __GNUC__
-Tbinding tbinding(binding t);
-extern __inline__ Tbinding tbinding(binding t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tbinding tbinding PROTO((binding));
-#endif /* ! __GNUC__ */
-
-struct Stbind {
- Tbinding tag;
- list Xgtbindc;
- ttype Xgtbindid;
- list Xgtbindl;
- list Xgtbindd;
- long Xgtline;
- hpragma Xgtpragma;
-};
-
-struct Snbind {
- Tbinding tag;
- ttype Xgnbindid;
- ttype Xgnbindas;
- long Xgnline;
- hpragma Xgnpragma;
-};
-
-struct Spbind {
- Tbinding tag;
- list Xgpbindl;
- long Xgpline;
-};
-
-struct Sfbind {
- Tbinding tag;
- list Xgfbindl;
- long Xgfline;
-};
-
-struct Sabind {
- Tbinding tag;
- binding Xgabindfst;
- binding Xgabindsnd;
-};
-
-struct Sibind {
- Tbinding tag;
- list Xgibindc;
- unkId Xgibindid;
- ttype Xgibindi;
- binding Xgibindw;
- long Xgiline;
- hpragma Xgipragma;
-};
-
-struct Sdbind {
- Tbinding tag;
- list Xgdbindts;
- long Xgdline;
-};
-
-struct Scbind {
- Tbinding tag;
- list Xgcbindc;
- ttype Xgcbindid;
- binding Xgcbindw;
- long Xgcline;
- hpragma Xgcpragma;
-};
-
-struct Ssbind {
- Tbinding tag;
- list Xgsbindids;
- ttype Xgsbindid;
- long Xgsline;
- hpragma Xgspragma;
-};
-
-struct Smbind {
- Tbinding tag;
- stringId Xgmbindmodn;
- list Xgmbindimp;
- list Xgmbindren;
- long Xgmline;
-};
-
-struct Snullbind {
- Tbinding tag;
-};
-
-struct Simport {
- Tbinding tag;
- stringId Xgiebindmod;
- list Xgiebindexp;
- list Xgiebindren;
- binding Xgiebinddef;
- stringId Xgiebindfile;
- long Xgiebindline;
-};
-
-struct Shiding {
- Tbinding tag;
- stringId Xgihbindmod;
- list Xgihbindexp;
- list Xgihbindren;
- binding Xgihbinddef;
- stringId Xgihbindfile;
- long Xgihbindline;
-};
-
-struct Svspec_uprag {
- Tbinding tag;
- unkId Xgvspec_id;
- list Xgvspec_tys;
- long Xgvspec_line;
-};
-
-struct Svspec_ty_and_id {
- Tbinding tag;
- ttype Xgvspec_ty;
- list Xgvspec_tyid;
-};
-
-struct Sispec_uprag {
- Tbinding tag;
- unkId Xgispec_clas;
- ttype Xgispec_ty;
- long Xgispec_line;
-};
-
-struct Sinline_uprag {
- Tbinding tag;
- unkId Xginline_id;
- list Xginline_howto;
- long Xginline_line;
-};
-
-struct Sdeforest_uprag {
- Tbinding tag;
- unkId Xgdeforest_id;
- long Xgdeforest_line;
-};
-
-struct Smagicuf_uprag {
- Tbinding tag;
- unkId Xgmagicuf_id;
- stringId Xgmagicuf_str;
- long Xgmagicuf_line;
-};
-
-struct Sabstract_uprag {
- Tbinding tag;
- unkId Xgabstract_id;
- long Xgabstract_line;
-};
-
-struct Sdspec_uprag {
- Tbinding tag;
- unkId Xgdspec_id;
- list Xgdspec_tys;
- long Xgdspec_line;
-};
-
-extern binding mktbind PROTO((list, ttype, list, list, long, hpragma));
-#ifdef __GNUC__
-
-list *Rgtbindc PROTO((struct Stbind *));
-
-extern __inline__ list *Rgtbindc(struct Stbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtbindc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtbindc);
-}
-#else /* ! __GNUC__ */
-extern list *Rgtbindc PROTO((struct Stbind *));
-#endif /* ! __GNUC__ */
-
-#define gtbindc(xyzxyz) (*Rgtbindc((struct Stbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgtbindid PROTO((struct Stbind *));
-
-extern __inline__ ttype *Rgtbindid(struct Stbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtbindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtbindid);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgtbindid PROTO((struct Stbind *));
-#endif /* ! __GNUC__ */
-
-#define gtbindid(xyzxyz) (*Rgtbindid((struct Stbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgtbindl PROTO((struct Stbind *));
-
-extern __inline__ list *Rgtbindl(struct Stbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtbindl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtbindl);
-}
-#else /* ! __GNUC__ */
-extern list *Rgtbindl PROTO((struct Stbind *));
-#endif /* ! __GNUC__ */
-
-#define gtbindl(xyzxyz) (*Rgtbindl((struct Stbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgtbindd PROTO((struct Stbind *));
-
-extern __inline__ list *Rgtbindd(struct Stbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtbindd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtbindd);
-}
-#else /* ! __GNUC__ */
-extern list *Rgtbindd PROTO((struct Stbind *));
-#endif /* ! __GNUC__ */
-
-#define gtbindd(xyzxyz) (*Rgtbindd((struct Stbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgtline PROTO((struct Stbind *));
-
-extern __inline__ long *Rgtline(struct Stbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgtline PROTO((struct Stbind *));
-#endif /* ! __GNUC__ */
-
-#define gtline(xyzxyz) (*Rgtline((struct Stbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgtpragma PROTO((struct Stbind *));
-
-extern __inline__ hpragma *Rgtpragma(struct Stbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tbind)
- fprintf(stderr,"gtpragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtpragma);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgtpragma PROTO((struct Stbind *));
-#endif /* ! __GNUC__ */
-
-#define gtpragma(xyzxyz) (*Rgtpragma((struct Stbind *) (xyzxyz)))
-
-extern binding mknbind PROTO((ttype, ttype, long, hpragma));
-#ifdef __GNUC__
-
-ttype *Rgnbindid PROTO((struct Snbind *));
-
-extern __inline__ ttype *Rgnbindid(struct Snbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != nbind)
- fprintf(stderr,"gnbindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnbindid);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgnbindid PROTO((struct Snbind *));
-#endif /* ! __GNUC__ */
-
-#define gnbindid(xyzxyz) (*Rgnbindid((struct Snbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgnbindas PROTO((struct Snbind *));
-
-extern __inline__ ttype *Rgnbindas(struct Snbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != nbind)
- fprintf(stderr,"gnbindas: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnbindas);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgnbindas PROTO((struct Snbind *));
-#endif /* ! __GNUC__ */
-
-#define gnbindas(xyzxyz) (*Rgnbindas((struct Snbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgnline PROTO((struct Snbind *));
-
-extern __inline__ long *Rgnline(struct Snbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != nbind)
- fprintf(stderr,"gnline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgnline PROTO((struct Snbind *));
-#endif /* ! __GNUC__ */
-
-#define gnline(xyzxyz) (*Rgnline((struct Snbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgnpragma PROTO((struct Snbind *));
-
-extern __inline__ hpragma *Rgnpragma(struct Snbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != nbind)
- fprintf(stderr,"gnpragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnpragma);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgnpragma PROTO((struct Snbind *));
-#endif /* ! __GNUC__ */
-
-#define gnpragma(xyzxyz) (*Rgnpragma((struct Snbind *) (xyzxyz)))
-
-extern binding mkpbind PROTO((list, long));
-#ifdef __GNUC__
-
-list *Rgpbindl PROTO((struct Spbind *));
-
-extern __inline__ list *Rgpbindl(struct Spbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pbind)
- fprintf(stderr,"gpbindl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgpbindl);
-}
-#else /* ! __GNUC__ */
-extern list *Rgpbindl PROTO((struct Spbind *));
-#endif /* ! __GNUC__ */
-
-#define gpbindl(xyzxyz) (*Rgpbindl((struct Spbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgpline PROTO((struct Spbind *));
-
-extern __inline__ long *Rgpline(struct Spbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pbind)
- fprintf(stderr,"gpline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgpline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgpline PROTO((struct Spbind *));
-#endif /* ! __GNUC__ */
-
-#define gpline(xyzxyz) (*Rgpline((struct Spbind *) (xyzxyz)))
-
-extern binding mkfbind PROTO((list, long));
-#ifdef __GNUC__
-
-list *Rgfbindl PROTO((struct Sfbind *));
-
-extern __inline__ list *Rgfbindl(struct Sfbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != fbind)
- fprintf(stderr,"gfbindl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfbindl);
-}
-#else /* ! __GNUC__ */
-extern list *Rgfbindl PROTO((struct Sfbind *));
-#endif /* ! __GNUC__ */
-
-#define gfbindl(xyzxyz) (*Rgfbindl((struct Sfbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgfline PROTO((struct Sfbind *));
-
-extern __inline__ long *Rgfline(struct Sfbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != fbind)
- fprintf(stderr,"gfline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgfline PROTO((struct Sfbind *));
-#endif /* ! __GNUC__ */
-
-#define gfline(xyzxyz) (*Rgfline((struct Sfbind *) (xyzxyz)))
-
-extern binding mkabind PROTO((binding, binding));
-#ifdef __GNUC__
-
-binding *Rgabindfst PROTO((struct Sabind *));
-
-extern __inline__ binding *Rgabindfst(struct Sabind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != abind)
- fprintf(stderr,"gabindfst: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgabindfst);
-}
-#else /* ! __GNUC__ */
-extern binding *Rgabindfst PROTO((struct Sabind *));
-#endif /* ! __GNUC__ */
-
-#define gabindfst(xyzxyz) (*Rgabindfst((struct Sabind *) (xyzxyz)))
-#ifdef __GNUC__
-
-binding *Rgabindsnd PROTO((struct Sabind *));
-
-extern __inline__ binding *Rgabindsnd(struct Sabind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != abind)
- fprintf(stderr,"gabindsnd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgabindsnd);
-}
-#else /* ! __GNUC__ */
-extern binding *Rgabindsnd PROTO((struct Sabind *));
-#endif /* ! __GNUC__ */
-
-#define gabindsnd(xyzxyz) (*Rgabindsnd((struct Sabind *) (xyzxyz)))
-
-extern binding mkibind PROTO((list, unkId, ttype, binding, long, hpragma));
-#ifdef __GNUC__
-
-list *Rgibindc PROTO((struct Sibind *));
-
-extern __inline__ list *Rgibindc(struct Sibind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gibindc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgibindc);
-}
-#else /* ! __GNUC__ */
-extern list *Rgibindc PROTO((struct Sibind *));
-#endif /* ! __GNUC__ */
-
-#define gibindc(xyzxyz) (*Rgibindc((struct Sibind *) (xyzxyz)))
-#ifdef __GNUC__
-
-unkId *Rgibindid PROTO((struct Sibind *));
-
-extern __inline__ unkId *Rgibindid(struct Sibind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gibindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgibindid);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgibindid PROTO((struct Sibind *));
-#endif /* ! __GNUC__ */
-
-#define gibindid(xyzxyz) (*Rgibindid((struct Sibind *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgibindi PROTO((struct Sibind *));
-
-extern __inline__ ttype *Rgibindi(struct Sibind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gibindi: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgibindi);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgibindi PROTO((struct Sibind *));
-#endif /* ! __GNUC__ */
-
-#define gibindi(xyzxyz) (*Rgibindi((struct Sibind *) (xyzxyz)))
-#ifdef __GNUC__
-
-binding *Rgibindw PROTO((struct Sibind *));
-
-extern __inline__ binding *Rgibindw(struct Sibind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gibindw: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgibindw);
-}
-#else /* ! __GNUC__ */
-extern binding *Rgibindw PROTO((struct Sibind *));
-#endif /* ! __GNUC__ */
-
-#define gibindw(xyzxyz) (*Rgibindw((struct Sibind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgiline PROTO((struct Sibind *));
-
-extern __inline__ long *Rgiline(struct Sibind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"giline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgiline PROTO((struct Sibind *));
-#endif /* ! __GNUC__ */
-
-#define giline(xyzxyz) (*Rgiline((struct Sibind *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgipragma PROTO((struct Sibind *));
-
-extern __inline__ hpragma *Rgipragma(struct Sibind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ibind)
- fprintf(stderr,"gipragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgipragma);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgipragma PROTO((struct Sibind *));
-#endif /* ! __GNUC__ */
-
-#define gipragma(xyzxyz) (*Rgipragma((struct Sibind *) (xyzxyz)))
-
-extern binding mkdbind PROTO((list, long));
-#ifdef __GNUC__
-
-list *Rgdbindts PROTO((struct Sdbind *));
-
-extern __inline__ list *Rgdbindts(struct Sdbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dbind)
- fprintf(stderr,"gdbindts: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdbindts);
-}
-#else /* ! __GNUC__ */
-extern list *Rgdbindts PROTO((struct Sdbind *));
-#endif /* ! __GNUC__ */
-
-#define gdbindts(xyzxyz) (*Rgdbindts((struct Sdbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgdline PROTO((struct Sdbind *));
-
-extern __inline__ long *Rgdline(struct Sdbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dbind)
- fprintf(stderr,"gdline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgdline PROTO((struct Sdbind *));
-#endif /* ! __GNUC__ */
-
-#define gdline(xyzxyz) (*Rgdline((struct Sdbind *) (xyzxyz)))
-
-extern binding mkcbind PROTO((list, ttype, binding, long, hpragma));
-#ifdef __GNUC__
-
-list *Rgcbindc PROTO((struct Scbind *));
-
-extern __inline__ list *Rgcbindc(struct Scbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcbindc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcbindc);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcbindc PROTO((struct Scbind *));
-#endif /* ! __GNUC__ */
-
-#define gcbindc(xyzxyz) (*Rgcbindc((struct Scbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgcbindid PROTO((struct Scbind *));
-
-extern __inline__ ttype *Rgcbindid(struct Scbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcbindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcbindid);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgcbindid PROTO((struct Scbind *));
-#endif /* ! __GNUC__ */
-
-#define gcbindid(xyzxyz) (*Rgcbindid((struct Scbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-binding *Rgcbindw PROTO((struct Scbind *));
-
-extern __inline__ binding *Rgcbindw(struct Scbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcbindw: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcbindw);
-}
-#else /* ! __GNUC__ */
-extern binding *Rgcbindw PROTO((struct Scbind *));
-#endif /* ! __GNUC__ */
-
-#define gcbindw(xyzxyz) (*Rgcbindw((struct Scbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgcline PROTO((struct Scbind *));
-
-extern __inline__ long *Rgcline(struct Scbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgcline PROTO((struct Scbind *));
-#endif /* ! __GNUC__ */
-
-#define gcline(xyzxyz) (*Rgcline((struct Scbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgcpragma PROTO((struct Scbind *));
-
-extern __inline__ hpragma *Rgcpragma(struct Scbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cbind)
- fprintf(stderr,"gcpragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcpragma);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgcpragma PROTO((struct Scbind *));
-#endif /* ! __GNUC__ */
-
-#define gcpragma(xyzxyz) (*Rgcpragma((struct Scbind *) (xyzxyz)))
-
-extern binding mksbind PROTO((list, ttype, long, hpragma));
-#ifdef __GNUC__
-
-list *Rgsbindids PROTO((struct Ssbind *));
-
-extern __inline__ list *Rgsbindids(struct Ssbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != sbind)
- fprintf(stderr,"gsbindids: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsbindids);
-}
-#else /* ! __GNUC__ */
-extern list *Rgsbindids PROTO((struct Ssbind *));
-#endif /* ! __GNUC__ */
-
-#define gsbindids(xyzxyz) (*Rgsbindids((struct Ssbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgsbindid PROTO((struct Ssbind *));
-
-extern __inline__ ttype *Rgsbindid(struct Ssbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != sbind)
- fprintf(stderr,"gsbindid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsbindid);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgsbindid PROTO((struct Ssbind *));
-#endif /* ! __GNUC__ */
-
-#define gsbindid(xyzxyz) (*Rgsbindid((struct Ssbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgsline PROTO((struct Ssbind *));
-
-extern __inline__ long *Rgsline(struct Ssbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != sbind)
- fprintf(stderr,"gsline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgsline PROTO((struct Ssbind *));
-#endif /* ! __GNUC__ */
-
-#define gsline(xyzxyz) (*Rgsline((struct Ssbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgspragma PROTO((struct Ssbind *));
-
-extern __inline__ hpragma *Rgspragma(struct Ssbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != sbind)
- fprintf(stderr,"gspragma: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgspragma);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgspragma PROTO((struct Ssbind *));
-#endif /* ! __GNUC__ */
-
-#define gspragma(xyzxyz) (*Rgspragma((struct Ssbind *) (xyzxyz)))
-
-extern binding mkmbind PROTO((stringId, list, list, long));
-#ifdef __GNUC__
-
-stringId *Rgmbindmodn PROTO((struct Smbind *));
-
-extern __inline__ stringId *Rgmbindmodn(struct Smbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != mbind)
- fprintf(stderr,"gmbindmodn: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmbindmodn);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgmbindmodn PROTO((struct Smbind *));
-#endif /* ! __GNUC__ */
-
-#define gmbindmodn(xyzxyz) (*Rgmbindmodn((struct Smbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgmbindimp PROTO((struct Smbind *));
-
-extern __inline__ list *Rgmbindimp(struct Smbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != mbind)
- fprintf(stderr,"gmbindimp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmbindimp);
-}
-#else /* ! __GNUC__ */
-extern list *Rgmbindimp PROTO((struct Smbind *));
-#endif /* ! __GNUC__ */
-
-#define gmbindimp(xyzxyz) (*Rgmbindimp((struct Smbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgmbindren PROTO((struct Smbind *));
-
-extern __inline__ list *Rgmbindren(struct Smbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != mbind)
- fprintf(stderr,"gmbindren: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmbindren);
-}
-#else /* ! __GNUC__ */
-extern list *Rgmbindren PROTO((struct Smbind *));
-#endif /* ! __GNUC__ */
-
-#define gmbindren(xyzxyz) (*Rgmbindren((struct Smbind *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgmline PROTO((struct Smbind *));
-
-extern __inline__ long *Rgmline(struct Smbind *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != mbind)
- fprintf(stderr,"gmline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgmline PROTO((struct Smbind *));
-#endif /* ! __GNUC__ */
-
-#define gmline(xyzxyz) (*Rgmline((struct Smbind *) (xyzxyz)))
-
-extern binding mknullbind PROTO((void));
-
-extern binding mkimport PROTO((stringId, list, list, binding, stringId, long));
-#ifdef __GNUC__
-
-stringId *Rgiebindmod PROTO((struct Simport *));
-
-extern __inline__ stringId *Rgiebindmod(struct Simport *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindmod: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindmod);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgiebindmod PROTO((struct Simport *));
-#endif /* ! __GNUC__ */
-
-#define giebindmod(xyzxyz) (*Rgiebindmod((struct Simport *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgiebindexp PROTO((struct Simport *));
-
-extern __inline__ list *Rgiebindexp(struct Simport *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindexp);
-}
-#else /* ! __GNUC__ */
-extern list *Rgiebindexp PROTO((struct Simport *));
-#endif /* ! __GNUC__ */
-
-#define giebindexp(xyzxyz) (*Rgiebindexp((struct Simport *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgiebindren PROTO((struct Simport *));
-
-extern __inline__ list *Rgiebindren(struct Simport *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindren: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindren);
-}
-#else /* ! __GNUC__ */
-extern list *Rgiebindren PROTO((struct Simport *));
-#endif /* ! __GNUC__ */
-
-#define giebindren(xyzxyz) (*Rgiebindren((struct Simport *) (xyzxyz)))
-#ifdef __GNUC__
-
-binding *Rgiebinddef PROTO((struct Simport *));
-
-extern __inline__ binding *Rgiebinddef(struct Simport *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebinddef: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebinddef);
-}
-#else /* ! __GNUC__ */
-extern binding *Rgiebinddef PROTO((struct Simport *));
-#endif /* ! __GNUC__ */
-
-#define giebinddef(xyzxyz) (*Rgiebinddef((struct Simport *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rgiebindfile PROTO((struct Simport *));
-
-extern __inline__ stringId *Rgiebindfile(struct Simport *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindfile: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindfile);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgiebindfile PROTO((struct Simport *));
-#endif /* ! __GNUC__ */
-
-#define giebindfile(xyzxyz) (*Rgiebindfile((struct Simport *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgiebindline PROTO((struct Simport *));
-
-extern __inline__ long *Rgiebindline(struct Simport *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != import)
- fprintf(stderr,"giebindline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgiebindline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgiebindline PROTO((struct Simport *));
-#endif /* ! __GNUC__ */
-
-#define giebindline(xyzxyz) (*Rgiebindline((struct Simport *) (xyzxyz)))
-
-extern binding mkhiding PROTO((stringId, list, list, binding, stringId, long));
-#ifdef __GNUC__
-
-stringId *Rgihbindmod PROTO((struct Shiding *));
-
-extern __inline__ stringId *Rgihbindmod(struct Shiding *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindmod: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindmod);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgihbindmod PROTO((struct Shiding *));
-#endif /* ! __GNUC__ */
-
-#define gihbindmod(xyzxyz) (*Rgihbindmod((struct Shiding *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgihbindexp PROTO((struct Shiding *));
-
-extern __inline__ list *Rgihbindexp(struct Shiding *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindexp);
-}
-#else /* ! __GNUC__ */
-extern list *Rgihbindexp PROTO((struct Shiding *));
-#endif /* ! __GNUC__ */
-
-#define gihbindexp(xyzxyz) (*Rgihbindexp((struct Shiding *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgihbindren PROTO((struct Shiding *));
-
-extern __inline__ list *Rgihbindren(struct Shiding *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindren: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindren);
-}
-#else /* ! __GNUC__ */
-extern list *Rgihbindren PROTO((struct Shiding *));
-#endif /* ! __GNUC__ */
-
-#define gihbindren(xyzxyz) (*Rgihbindren((struct Shiding *) (xyzxyz)))
-#ifdef __GNUC__
-
-binding *Rgihbinddef PROTO((struct Shiding *));
-
-extern __inline__ binding *Rgihbinddef(struct Shiding *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbinddef: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbinddef);
-}
-#else /* ! __GNUC__ */
-extern binding *Rgihbinddef PROTO((struct Shiding *));
-#endif /* ! __GNUC__ */
-
-#define gihbinddef(xyzxyz) (*Rgihbinddef((struct Shiding *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rgihbindfile PROTO((struct Shiding *));
-
-extern __inline__ stringId *Rgihbindfile(struct Shiding *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindfile: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindfile);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgihbindfile PROTO((struct Shiding *));
-#endif /* ! __GNUC__ */
-
-#define gihbindfile(xyzxyz) (*Rgihbindfile((struct Shiding *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgihbindline PROTO((struct Shiding *));
-
-extern __inline__ long *Rgihbindline(struct Shiding *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hiding)
- fprintf(stderr,"gihbindline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgihbindline);
-}
-#else /* ! __GNUC__ */
-extern long *Rgihbindline PROTO((struct Shiding *));
-#endif /* ! __GNUC__ */
-
-#define gihbindline(xyzxyz) (*Rgihbindline((struct Shiding *) (xyzxyz)))
-
-extern binding mkvspec_uprag PROTO((unkId, list, long));
-#ifdef __GNUC__
-
-unkId *Rgvspec_id PROTO((struct Svspec_uprag *));
-
-extern __inline__ unkId *Rgvspec_id(struct Svspec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_uprag)
- fprintf(stderr,"gvspec_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_id);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgvspec_id PROTO((struct Svspec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gvspec_id(xyzxyz) (*Rgvspec_id((struct Svspec_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgvspec_tys PROTO((struct Svspec_uprag *));
-
-extern __inline__ list *Rgvspec_tys(struct Svspec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_uprag)
- fprintf(stderr,"gvspec_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_tys);
-}
-#else /* ! __GNUC__ */
-extern list *Rgvspec_tys PROTO((struct Svspec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gvspec_tys(xyzxyz) (*Rgvspec_tys((struct Svspec_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgvspec_line PROTO((struct Svspec_uprag *));
-
-extern __inline__ long *Rgvspec_line(struct Svspec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_uprag)
- fprintf(stderr,"gvspec_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_line);
-}
-#else /* ! __GNUC__ */
-extern long *Rgvspec_line PROTO((struct Svspec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gvspec_line(xyzxyz) (*Rgvspec_line((struct Svspec_uprag *) (xyzxyz)))
-
-extern binding mkvspec_ty_and_id PROTO((ttype, list));
-#ifdef __GNUC__
-
-ttype *Rgvspec_ty PROTO((struct Svspec_ty_and_id *));
-
-extern __inline__ ttype *Rgvspec_ty(struct Svspec_ty_and_id *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_ty_and_id)
- fprintf(stderr,"gvspec_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgvspec_ty PROTO((struct Svspec_ty_and_id *));
-#endif /* ! __GNUC__ */
-
-#define gvspec_ty(xyzxyz) (*Rgvspec_ty((struct Svspec_ty_and_id *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgvspec_tyid PROTO((struct Svspec_ty_and_id *));
-
-extern __inline__ list *Rgvspec_tyid(struct Svspec_ty_and_id *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != vspec_ty_and_id)
- fprintf(stderr,"gvspec_tyid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgvspec_tyid);
-}
-#else /* ! __GNUC__ */
-extern list *Rgvspec_tyid PROTO((struct Svspec_ty_and_id *));
-#endif /* ! __GNUC__ */
-
-#define gvspec_tyid(xyzxyz) (*Rgvspec_tyid((struct Svspec_ty_and_id *) (xyzxyz)))
-
-extern binding mkispec_uprag PROTO((unkId, ttype, long));
-#ifdef __GNUC__
-
-unkId *Rgispec_clas PROTO((struct Sispec_uprag *));
-
-extern __inline__ unkId *Rgispec_clas(struct Sispec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ispec_uprag)
- fprintf(stderr,"gispec_clas: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgispec_clas);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgispec_clas PROTO((struct Sispec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gispec_clas(xyzxyz) (*Rgispec_clas((struct Sispec_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgispec_ty PROTO((struct Sispec_uprag *));
-
-extern __inline__ ttype *Rgispec_ty(struct Sispec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ispec_uprag)
- fprintf(stderr,"gispec_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgispec_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgispec_ty PROTO((struct Sispec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gispec_ty(xyzxyz) (*Rgispec_ty((struct Sispec_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgispec_line PROTO((struct Sispec_uprag *));
-
-extern __inline__ long *Rgispec_line(struct Sispec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ispec_uprag)
- fprintf(stderr,"gispec_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgispec_line);
-}
-#else /* ! __GNUC__ */
-extern long *Rgispec_line PROTO((struct Sispec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gispec_line(xyzxyz) (*Rgispec_line((struct Sispec_uprag *) (xyzxyz)))
-
-extern binding mkinline_uprag PROTO((unkId, list, long));
-#ifdef __GNUC__
-
-unkId *Rginline_id PROTO((struct Sinline_uprag *));
-
-extern __inline__ unkId *Rginline_id(struct Sinline_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != inline_uprag)
- fprintf(stderr,"ginline_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xginline_id);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rginline_id PROTO((struct Sinline_uprag *));
-#endif /* ! __GNUC__ */
-
-#define ginline_id(xyzxyz) (*Rginline_id((struct Sinline_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rginline_howto PROTO((struct Sinline_uprag *));
-
-extern __inline__ list *Rginline_howto(struct Sinline_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != inline_uprag)
- fprintf(stderr,"ginline_howto: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xginline_howto);
-}
-#else /* ! __GNUC__ */
-extern list *Rginline_howto PROTO((struct Sinline_uprag *));
-#endif /* ! __GNUC__ */
-
-#define ginline_howto(xyzxyz) (*Rginline_howto((struct Sinline_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rginline_line PROTO((struct Sinline_uprag *));
-
-extern __inline__ long *Rginline_line(struct Sinline_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != inline_uprag)
- fprintf(stderr,"ginline_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xginline_line);
-}
-#else /* ! __GNUC__ */
-extern long *Rginline_line PROTO((struct Sinline_uprag *));
-#endif /* ! __GNUC__ */
-
-#define ginline_line(xyzxyz) (*Rginline_line((struct Sinline_uprag *) (xyzxyz)))
-
-extern binding mkdeforest_uprag PROTO((unkId, long));
-#ifdef __GNUC__
-
-unkId *Rgdeforest_id PROTO((struct Sdeforest_uprag *));
-
-extern __inline__ unkId *Rgdeforest_id(struct Sdeforest_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != deforest_uprag)
- fprintf(stderr,"gdeforest_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdeforest_id);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgdeforest_id PROTO((struct Sdeforest_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gdeforest_id(xyzxyz) (*Rgdeforest_id((struct Sdeforest_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgdeforest_line PROTO((struct Sdeforest_uprag *));
-
-extern __inline__ long *Rgdeforest_line(struct Sdeforest_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != deforest_uprag)
- fprintf(stderr,"gdeforest_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdeforest_line);
-}
-#else /* ! __GNUC__ */
-extern long *Rgdeforest_line PROTO((struct Sdeforest_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gdeforest_line(xyzxyz) (*Rgdeforest_line((struct Sdeforest_uprag *) (xyzxyz)))
-
-extern binding mkmagicuf_uprag PROTO((unkId, stringId, long));
-#ifdef __GNUC__
-
-unkId *Rgmagicuf_id PROTO((struct Smagicuf_uprag *));
-
-extern __inline__ unkId *Rgmagicuf_id(struct Smagicuf_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != magicuf_uprag)
- fprintf(stderr,"gmagicuf_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmagicuf_id);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgmagicuf_id PROTO((struct Smagicuf_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gmagicuf_id(xyzxyz) (*Rgmagicuf_id((struct Smagicuf_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rgmagicuf_str PROTO((struct Smagicuf_uprag *));
-
-extern __inline__ stringId *Rgmagicuf_str(struct Smagicuf_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != magicuf_uprag)
- fprintf(stderr,"gmagicuf_str: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmagicuf_str);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgmagicuf_str PROTO((struct Smagicuf_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gmagicuf_str(xyzxyz) (*Rgmagicuf_str((struct Smagicuf_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgmagicuf_line PROTO((struct Smagicuf_uprag *));
-
-extern __inline__ long *Rgmagicuf_line(struct Smagicuf_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != magicuf_uprag)
- fprintf(stderr,"gmagicuf_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmagicuf_line);
-}
-#else /* ! __GNUC__ */
-extern long *Rgmagicuf_line PROTO((struct Smagicuf_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gmagicuf_line(xyzxyz) (*Rgmagicuf_line((struct Smagicuf_uprag *) (xyzxyz)))
-
-extern binding mkabstract_uprag PROTO((unkId, long));
-#ifdef __GNUC__
-
-unkId *Rgabstract_id PROTO((struct Sabstract_uprag *));
-
-extern __inline__ unkId *Rgabstract_id(struct Sabstract_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != abstract_uprag)
- fprintf(stderr,"gabstract_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgabstract_id);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgabstract_id PROTO((struct Sabstract_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gabstract_id(xyzxyz) (*Rgabstract_id((struct Sabstract_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgabstract_line PROTO((struct Sabstract_uprag *));
-
-extern __inline__ long *Rgabstract_line(struct Sabstract_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != abstract_uprag)
- fprintf(stderr,"gabstract_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgabstract_line);
-}
-#else /* ! __GNUC__ */
-extern long *Rgabstract_line PROTO((struct Sabstract_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gabstract_line(xyzxyz) (*Rgabstract_line((struct Sabstract_uprag *) (xyzxyz)))
-
-extern binding mkdspec_uprag PROTO((unkId, list, long));
-#ifdef __GNUC__
-
-unkId *Rgdspec_id PROTO((struct Sdspec_uprag *));
-
-extern __inline__ unkId *Rgdspec_id(struct Sdspec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dspec_uprag)
- fprintf(stderr,"gdspec_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdspec_id);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgdspec_id PROTO((struct Sdspec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gdspec_id(xyzxyz) (*Rgdspec_id((struct Sdspec_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgdspec_tys PROTO((struct Sdspec_uprag *));
-
-extern __inline__ list *Rgdspec_tys(struct Sdspec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dspec_uprag)
- fprintf(stderr,"gdspec_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdspec_tys);
-}
-#else /* ! __GNUC__ */
-extern list *Rgdspec_tys PROTO((struct Sdspec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gdspec_tys(xyzxyz) (*Rgdspec_tys((struct Sdspec_uprag *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgdspec_line PROTO((struct Sdspec_uprag *));
-
-extern __inline__ long *Rgdspec_line(struct Sdspec_uprag *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != dspec_uprag)
- fprintf(stderr,"gdspec_line: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdspec_line);
-}
-#else /* ! __GNUC__ */
-extern long *Rgdspec_line PROTO((struct Sdspec_uprag *));
-#endif /* ! __GNUC__ */
-
-#define gdspec_line(xyzxyz) (*Rgdspec_line((struct Sdspec_uprag *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_binding where
-import UgenUtil
-import Util
-
-import U_coresyn ( U_coresyn ) -- for interfaces only
-import U_hpragma
-import U_list
-import U_literal ( U_literal ) -- for interfaces only
-import U_ttype
-%}}
-type binding;
- tbind : < gtbindc : list;
- gtbindid : ttype;
- gtbindl : list;
- gtbindd : list;
- gtline : long;
- gtpragma : hpragma; >;
- nbind : < gnbindid : ttype;
- gnbindas : ttype;
- gnline : long;
- gnpragma : hpragma; >;
- pbind : < gpbindl : list;
- gpline : long; >;
- fbind : < gfbindl : list;
- gfline : long; >;
- abind : < gabindfst : binding;
- gabindsnd : binding; >;
-/*OLD:95/08:
- lbind : < glbindfst : binding;
- glbindsnd : binding; >;
-*/
-/*OLD:95/08: ebind : < gebindl : list;
- gebind : binding;
- geline : long; >;
-*/
-/*OLD: 95/08: hbind : < ghbindl : list;
- ghbind : binding;
- ghline : long; >;
-*/
- ibind : < gibindc : list;
- gibindid : unkId;
- gibindi : ttype;
- gibindw : binding;
- giline : long;
- gipragma : hpragma; >;
- dbind : < gdbindts : list;
- gdline : long; >;
- cbind : < gcbindc : list;
- gcbindid : ttype;
- gcbindw : binding;
- gcline : long;
- gcpragma : hpragma; >;
- sbind : < gsbindids : list;
- gsbindid : ttype;
- gsline : long;
- gspragma : hpragma; >;
- mbind : < gmbindmodn : stringId;
- gmbindimp : list;
- gmbindren : list;
- gmline : long; >;
- nullbind : < >;
- import : < giebindmod : stringId;
- giebindexp : list;
- giebindren : list;
- giebinddef : binding;
- giebindfile : stringId;
- giebindline : long; >;
-/* "hiding" is used in a funny way:
- it has to have the *exact* same structure as "import";
- because what we do is: create an "import" then change
- its tag to "hiding". Yeeps. (WDP 95/08)
-*/
- hiding : < gihbindmod : stringId;
- gihbindexp : list;
- gihbindren : list;
- gihbinddef : binding;
- gihbindfile : stringId;
- gihbindline : long; >;
-
- /* user-specified pragmas:XXXX */
-
- vspec_uprag : < gvspec_id : unkId;
- gvspec_tys : list;
- gvspec_line : long; >;
-
- vspec_ty_and_id : < gvspec_ty : ttype;
- gvspec_tyid : list; /* nil or singleton */ >;
-
- ispec_uprag : < gispec_clas : unkId;
- gispec_ty : ttype;
- gispec_line : long; >;
-
- inline_uprag: < ginline_id : unkId;
- ginline_howto: list;
- ginline_line : long; >;
-
- deforest_uprag: < gdeforest_id : unkId;
- gdeforest_line : long; >;
-
- magicuf_uprag:< gmagicuf_id : unkId;
- gmagicuf_str : stringId;
- gmagicuf_line : long; >;
-
- abstract_uprag:<gabstract_id : unkId;
- gabstract_line : long; >;
-
- dspec_uprag : < gdspec_id : unkId;
- gdspec_tys : list;
- gdspec_line : long; >;
-
-end;
+++ /dev/null
-/*
- Include File for the Lexical Analyser and Parser.
-
- 19/11/91 kh Created.
-*/
-
-
-#ifndef __CONSTANTS_H
-#define __CONSTANTS_H
-
-/*
- Important Literal Constants.
-*/
-
-#define MODNAME_SIZE 512 /* Size of Module Name buffers */
-#define FILENAME_SIZE 4096 /* Size of File buffers */
-#define ERR_BUF_SIZE 512 /* Size of error buffers */
-
-#ifdef YYLMAX /* Get rid of YYLMAX */
-#undef YYLMAX /* Ugly -- but necessary */
-#endif
-
-#define YYLMAX 8192 /* Size of yytext -- limits strings, identifiers etc. */
-
-
-#define HASH_TABLE_SIZE 993 /* Default number of entries in the hash table. */
-
-
-#define MAX_CONTEXTS 100 /* Maximum nesting of wheres, cases etc */
-#define MAX_INFIX 500 /* Maximum number of infix operators */
-#define MAX_ISTR (MAX_INFIX*10) /* Total size of all infix operatrors */
-#define INFIX_SCOPES 3 /* The number of infix scopes
- -- Predefs, Module, Imports */
-
-
-#define MAX_ESC_CHAR 255 /* Largest Recognised Character: \255 */
-#define MAX_ESC_DIGITS 10 /* Maximum number of digits in an escape \dd */
-
-
-#ifdef TRUE
-#undef TRUE
-#endif
-
-#ifdef FALSE
-#undef FALSE
-#endif
-
-#define TRUE 1
-#define FALSE 0
-typedef int BOOLEAN;
-
-#endif /* __CONSTANTS_H */
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/coresyn.h"
-
-Tcoresyn tcoresyn(t)
- coresyn t;
-{
- return(t -> tag);
-}
-
-
-/************** cobinder ******************/
-
-coresyn mkcobinder(PPgcobinder_v, PPgcobinder_ty)
- unkId PPgcobinder_v;
- ttype PPgcobinder_ty;
-{
- register struct Scobinder *pp =
- (struct Scobinder *) malloc(sizeof(struct Scobinder));
- pp -> tag = cobinder;
- pp -> Xgcobinder_v = PPgcobinder_v;
- pp -> Xgcobinder_ty = PPgcobinder_ty;
- return((coresyn)pp);
-}
-
-unkId *Rgcobinder_v(t)
- struct Scobinder *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cobinder)
- fprintf(stderr,"gcobinder_v: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcobinder_v);
-}
-
-ttype *Rgcobinder_ty(t)
- struct Scobinder *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cobinder)
- fprintf(stderr,"gcobinder_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcobinder_ty);
-}
-
-/************** colit ******************/
-
-coresyn mkcolit(PPgcolit)
- literal PPgcolit;
-{
- register struct Scolit *pp =
- (struct Scolit *) malloc(sizeof(struct Scolit));
- pp -> tag = colit;
- pp -> Xgcolit = PPgcolit;
- return((coresyn)pp);
-}
-
-literal *Rgcolit(t)
- struct Scolit *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colit)
- fprintf(stderr,"gcolit: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolit);
-}
-
-/************** colocal ******************/
-
-coresyn mkcolocal(PPgcolocal_v)
- coresyn PPgcolocal_v;
-{
- register struct Scolocal *pp =
- (struct Scolocal *) malloc(sizeof(struct Scolocal));
- pp -> tag = colocal;
- pp -> Xgcolocal_v = PPgcolocal_v;
- return((coresyn)pp);
-}
-
-coresyn *Rgcolocal_v(t)
- struct Scolocal *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colocal)
- fprintf(stderr,"gcolocal_v: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolocal_v);
-}
-
-/************** cononrec ******************/
-
-coresyn mkcononrec(PPgcononrec_b, PPgcononrec_rhs)
- coresyn PPgcononrec_b;
- coresyn PPgcononrec_rhs;
-{
- register struct Scononrec *pp =
- (struct Scononrec *) malloc(sizeof(struct Scononrec));
- pp -> tag = cononrec;
- pp -> Xgcononrec_b = PPgcononrec_b;
- pp -> Xgcononrec_rhs = PPgcononrec_rhs;
- return((coresyn)pp);
-}
-
-coresyn *Rgcononrec_b(t)
- struct Scononrec *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cononrec)
- fprintf(stderr,"gcononrec_b: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcononrec_b);
-}
-
-coresyn *Rgcononrec_rhs(t)
- struct Scononrec *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cononrec)
- fprintf(stderr,"gcononrec_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcononrec_rhs);
-}
-
-/************** corec ******************/
-
-coresyn mkcorec(PPgcorec)
- list PPgcorec;
-{
- register struct Scorec *pp =
- (struct Scorec *) malloc(sizeof(struct Scorec));
- pp -> tag = corec;
- pp -> Xgcorec = PPgcorec;
- return((coresyn)pp);
-}
-
-list *Rgcorec(t)
- struct Scorec *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != corec)
- fprintf(stderr,"gcorec: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcorec);
-}
-
-/************** corec_pair ******************/
-
-coresyn mkcorec_pair(PPgcorec_b, PPgcorec_rhs)
- coresyn PPgcorec_b;
- coresyn PPgcorec_rhs;
-{
- register struct Scorec_pair *pp =
- (struct Scorec_pair *) malloc(sizeof(struct Scorec_pair));
- pp -> tag = corec_pair;
- pp -> Xgcorec_b = PPgcorec_b;
- pp -> Xgcorec_rhs = PPgcorec_rhs;
- return((coresyn)pp);
-}
-
-coresyn *Rgcorec_b(t)
- struct Scorec_pair *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != corec_pair)
- fprintf(stderr,"gcorec_b: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcorec_b);
-}
-
-coresyn *Rgcorec_rhs(t)
- struct Scorec_pair *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != corec_pair)
- fprintf(stderr,"gcorec_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcorec_rhs);
-}
-
-/************** covar ******************/
-
-coresyn mkcovar(PPgcovar)
- coresyn PPgcovar;
-{
- register struct Scovar *pp =
- (struct Scovar *) malloc(sizeof(struct Scovar));
- pp -> tag = covar;
- pp -> Xgcovar = PPgcovar;
- return((coresyn)pp);
-}
-
-coresyn *Rgcovar(t)
- struct Scovar *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != covar)
- fprintf(stderr,"gcovar: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcovar);
-}
-
-/************** coliteral ******************/
-
-coresyn mkcoliteral(PPgcoliteral)
- literal PPgcoliteral;
-{
- register struct Scoliteral *pp =
- (struct Scoliteral *) malloc(sizeof(struct Scoliteral));
- pp -> tag = coliteral;
- pp -> Xgcoliteral = PPgcoliteral;
- return((coresyn)pp);
-}
-
-literal *Rgcoliteral(t)
- struct Scoliteral *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coliteral)
- fprintf(stderr,"gcoliteral: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoliteral);
-}
-
-/************** cocon ******************/
-
-coresyn mkcocon(PPgcocon_con, PPgcocon_tys, PPgcocon_args)
- coresyn PPgcocon_con;
- list PPgcocon_tys;
- list PPgcocon_args;
-{
- register struct Scocon *pp =
- (struct Scocon *) malloc(sizeof(struct Scocon));
- pp -> tag = cocon;
- pp -> Xgcocon_con = PPgcocon_con;
- pp -> Xgcocon_tys = PPgcocon_tys;
- pp -> Xgcocon_args = PPgcocon_args;
- return((coresyn)pp);
-}
-
-coresyn *Rgcocon_con(t)
- struct Scocon *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocon)
- fprintf(stderr,"gcocon_con: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocon_con);
-}
-
-list *Rgcocon_tys(t)
- struct Scocon *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocon)
- fprintf(stderr,"gcocon_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocon_tys);
-}
-
-list *Rgcocon_args(t)
- struct Scocon *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocon)
- fprintf(stderr,"gcocon_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocon_args);
-}
-
-/************** coprim ******************/
-
-coresyn mkcoprim(PPgcoprim_op, PPgcoprim_tys, PPgcoprim_args)
- coresyn PPgcoprim_op;
- list PPgcoprim_tys;
- list PPgcoprim_args;
-{
- register struct Scoprim *pp =
- (struct Scoprim *) malloc(sizeof(struct Scoprim));
- pp -> tag = coprim;
- pp -> Xgcoprim_op = PPgcoprim_op;
- pp -> Xgcoprim_tys = PPgcoprim_tys;
- pp -> Xgcoprim_args = PPgcoprim_args;
- return((coresyn)pp);
-}
-
-coresyn *Rgcoprim_op(t)
- struct Scoprim *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim)
- fprintf(stderr,"gcoprim_op: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_op);
-}
-
-list *Rgcoprim_tys(t)
- struct Scoprim *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim)
- fprintf(stderr,"gcoprim_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_tys);
-}
-
-list *Rgcoprim_args(t)
- struct Scoprim *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim)
- fprintf(stderr,"gcoprim_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_args);
-}
-
-/************** colam ******************/
-
-coresyn mkcolam(PPgcolam_vars, PPgcolam_body)
- list PPgcolam_vars;
- coresyn PPgcolam_body;
-{
- register struct Scolam *pp =
- (struct Scolam *) malloc(sizeof(struct Scolam));
- pp -> tag = colam;
- pp -> Xgcolam_vars = PPgcolam_vars;
- pp -> Xgcolam_body = PPgcolam_body;
- return((coresyn)pp);
-}
-
-list *Rgcolam_vars(t)
- struct Scolam *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colam)
- fprintf(stderr,"gcolam_vars: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolam_vars);
-}
-
-coresyn *Rgcolam_body(t)
- struct Scolam *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colam)
- fprintf(stderr,"gcolam_body: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolam_body);
-}
-
-/************** cotylam ******************/
-
-coresyn mkcotylam(PPgcotylam_tvs, PPgcotylam_body)
- list PPgcotylam_tvs;
- coresyn PPgcotylam_body;
-{
- register struct Scotylam *pp =
- (struct Scotylam *) malloc(sizeof(struct Scotylam));
- pp -> tag = cotylam;
- pp -> Xgcotylam_tvs = PPgcotylam_tvs;
- pp -> Xgcotylam_body = PPgcotylam_body;
- return((coresyn)pp);
-}
-
-list *Rgcotylam_tvs(t)
- struct Scotylam *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cotylam)
- fprintf(stderr,"gcotylam_tvs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcotylam_tvs);
-}
-
-coresyn *Rgcotylam_body(t)
- struct Scotylam *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cotylam)
- fprintf(stderr,"gcotylam_body: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcotylam_body);
-}
-
-/************** coapp ******************/
-
-coresyn mkcoapp(PPgcoapp_fun, PPgcoapp_args)
- coresyn PPgcoapp_fun;
- list PPgcoapp_args;
-{
- register struct Scoapp *pp =
- (struct Scoapp *) malloc(sizeof(struct Scoapp));
- pp -> tag = coapp;
- pp -> Xgcoapp_fun = PPgcoapp_fun;
- pp -> Xgcoapp_args = PPgcoapp_args;
- return((coresyn)pp);
-}
-
-coresyn *Rgcoapp_fun(t)
- struct Scoapp *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coapp)
- fprintf(stderr,"gcoapp_fun: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoapp_fun);
-}
-
-list *Rgcoapp_args(t)
- struct Scoapp *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coapp)
- fprintf(stderr,"gcoapp_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoapp_args);
-}
-
-/************** cotyapp ******************/
-
-coresyn mkcotyapp(PPgcotyapp_e, PPgcotyapp_t)
- coresyn PPgcotyapp_e;
- ttype PPgcotyapp_t;
-{
- register struct Scotyapp *pp =
- (struct Scotyapp *) malloc(sizeof(struct Scotyapp));
- pp -> tag = cotyapp;
- pp -> Xgcotyapp_e = PPgcotyapp_e;
- pp -> Xgcotyapp_t = PPgcotyapp_t;
- return((coresyn)pp);
-}
-
-coresyn *Rgcotyapp_e(t)
- struct Scotyapp *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cotyapp)
- fprintf(stderr,"gcotyapp_e: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcotyapp_e);
-}
-
-ttype *Rgcotyapp_t(t)
- struct Scotyapp *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cotyapp)
- fprintf(stderr,"gcotyapp_t: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcotyapp_t);
-}
-
-/************** cocase ******************/
-
-coresyn mkcocase(PPgcocase_s, PPgcocase_alts)
- coresyn PPgcocase_s;
- coresyn PPgcocase_alts;
-{
- register struct Scocase *pp =
- (struct Scocase *) malloc(sizeof(struct Scocase));
- pp -> tag = cocase;
- pp -> Xgcocase_s = PPgcocase_s;
- pp -> Xgcocase_alts = PPgcocase_alts;
- return((coresyn)pp);
-}
-
-coresyn *Rgcocase_s(t)
- struct Scocase *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocase)
- fprintf(stderr,"gcocase_s: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocase_s);
-}
-
-coresyn *Rgcocase_alts(t)
- struct Scocase *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocase)
- fprintf(stderr,"gcocase_alts: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocase_alts);
-}
-
-/************** colet ******************/
-
-coresyn mkcolet(PPgcolet_bind, PPgcolet_body)
- coresyn PPgcolet_bind;
- coresyn PPgcolet_body;
-{
- register struct Scolet *pp =
- (struct Scolet *) malloc(sizeof(struct Scolet));
- pp -> tag = colet;
- pp -> Xgcolet_bind = PPgcolet_bind;
- pp -> Xgcolet_body = PPgcolet_body;
- return((coresyn)pp);
-}
-
-coresyn *Rgcolet_bind(t)
- struct Scolet *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colet)
- fprintf(stderr,"gcolet_bind: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolet_bind);
-}
-
-coresyn *Rgcolet_body(t)
- struct Scolet *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colet)
- fprintf(stderr,"gcolet_body: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolet_body);
-}
-
-/************** coscc ******************/
-
-coresyn mkcoscc(PPgcoscc_scc, PPgcoscc_body)
- coresyn PPgcoscc_scc;
- coresyn PPgcoscc_body;
-{
- register struct Scoscc *pp =
- (struct Scoscc *) malloc(sizeof(struct Scoscc));
- pp -> tag = coscc;
- pp -> Xgcoscc_scc = PPgcoscc_scc;
- pp -> Xgcoscc_body = PPgcoscc_body;
- return((coresyn)pp);
-}
-
-coresyn *Rgcoscc_scc(t)
- struct Scoscc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coscc)
- fprintf(stderr,"gcoscc_scc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoscc_scc);
-}
-
-coresyn *Rgcoscc_body(t)
- struct Scoscc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coscc)
- fprintf(stderr,"gcoscc_body: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoscc_body);
-}
-
-/************** coalg_alts ******************/
-
-coresyn mkcoalg_alts(PPgcoalg_alts, PPgcoalg_deflt)
- list PPgcoalg_alts;
- coresyn PPgcoalg_deflt;
-{
- register struct Scoalg_alts *pp =
- (struct Scoalg_alts *) malloc(sizeof(struct Scoalg_alts));
- pp -> tag = coalg_alts;
- pp -> Xgcoalg_alts = PPgcoalg_alts;
- pp -> Xgcoalg_deflt = PPgcoalg_deflt;
- return((coresyn)pp);
-}
-
-list *Rgcoalg_alts(t)
- struct Scoalg_alts *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alts)
- fprintf(stderr,"gcoalg_alts: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_alts);
-}
-
-coresyn *Rgcoalg_deflt(t)
- struct Scoalg_alts *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alts)
- fprintf(stderr,"gcoalg_deflt: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_deflt);
-}
-
-/************** coalg_alt ******************/
-
-coresyn mkcoalg_alt(PPgcoalg_con, PPgcoalg_bs, PPgcoalg_rhs)
- coresyn PPgcoalg_con;
- list PPgcoalg_bs;
- coresyn PPgcoalg_rhs;
-{
- register struct Scoalg_alt *pp =
- (struct Scoalg_alt *) malloc(sizeof(struct Scoalg_alt));
- pp -> tag = coalg_alt;
- pp -> Xgcoalg_con = PPgcoalg_con;
- pp -> Xgcoalg_bs = PPgcoalg_bs;
- pp -> Xgcoalg_rhs = PPgcoalg_rhs;
- return((coresyn)pp);
-}
-
-coresyn *Rgcoalg_con(t)
- struct Scoalg_alt *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alt)
- fprintf(stderr,"gcoalg_con: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_con);
-}
-
-list *Rgcoalg_bs(t)
- struct Scoalg_alt *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alt)
- fprintf(stderr,"gcoalg_bs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_bs);
-}
-
-coresyn *Rgcoalg_rhs(t)
- struct Scoalg_alt *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alt)
- fprintf(stderr,"gcoalg_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_rhs);
-}
-
-/************** coprim_alts ******************/
-
-coresyn mkcoprim_alts(PPgcoprim_alts, PPgcoprim_deflt)
- list PPgcoprim_alts;
- coresyn PPgcoprim_deflt;
-{
- register struct Scoprim_alts *pp =
- (struct Scoprim_alts *) malloc(sizeof(struct Scoprim_alts));
- pp -> tag = coprim_alts;
- pp -> Xgcoprim_alts = PPgcoprim_alts;
- pp -> Xgcoprim_deflt = PPgcoprim_deflt;
- return((coresyn)pp);
-}
-
-list *Rgcoprim_alts(t)
- struct Scoprim_alts *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim_alts)
- fprintf(stderr,"gcoprim_alts: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_alts);
-}
-
-coresyn *Rgcoprim_deflt(t)
- struct Scoprim_alts *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim_alts)
- fprintf(stderr,"gcoprim_deflt: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_deflt);
-}
-
-/************** coprim_alt ******************/
-
-coresyn mkcoprim_alt(PPgcoprim_lit, PPgcoprim_rhs)
- literal PPgcoprim_lit;
- coresyn PPgcoprim_rhs;
-{
- register struct Scoprim_alt *pp =
- (struct Scoprim_alt *) malloc(sizeof(struct Scoprim_alt));
- pp -> tag = coprim_alt;
- pp -> Xgcoprim_lit = PPgcoprim_lit;
- pp -> Xgcoprim_rhs = PPgcoprim_rhs;
- return((coresyn)pp);
-}
-
-literal *Rgcoprim_lit(t)
- struct Scoprim_alt *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim_alt)
- fprintf(stderr,"gcoprim_lit: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_lit);
-}
-
-coresyn *Rgcoprim_rhs(t)
- struct Scoprim_alt *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim_alt)
- fprintf(stderr,"gcoprim_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_rhs);
-}
-
-/************** conodeflt ******************/
-
-coresyn mkconodeflt(void)
-{
- register struct Sconodeflt *pp =
- (struct Sconodeflt *) malloc(sizeof(struct Sconodeflt));
- pp -> tag = conodeflt;
- return((coresyn)pp);
-}
-
-/************** cobinddeflt ******************/
-
-coresyn mkcobinddeflt(PPgcobinddeflt_v, PPgcobinddeflt_rhs)
- coresyn PPgcobinddeflt_v;
- coresyn PPgcobinddeflt_rhs;
-{
- register struct Scobinddeflt *pp =
- (struct Scobinddeflt *) malloc(sizeof(struct Scobinddeflt));
- pp -> tag = cobinddeflt;
- pp -> Xgcobinddeflt_v = PPgcobinddeflt_v;
- pp -> Xgcobinddeflt_rhs = PPgcobinddeflt_rhs;
- return((coresyn)pp);
-}
-
-coresyn *Rgcobinddeflt_v(t)
- struct Scobinddeflt *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cobinddeflt)
- fprintf(stderr,"gcobinddeflt_v: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcobinddeflt_v);
-}
-
-coresyn *Rgcobinddeflt_rhs(t)
- struct Scobinddeflt *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cobinddeflt)
- fprintf(stderr,"gcobinddeflt_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcobinddeflt_rhs);
-}
-
-/************** co_primop ******************/
-
-coresyn mkco_primop(PPgco_primop)
- stringId PPgco_primop;
-{
- register struct Sco_primop *pp =
- (struct Sco_primop *) malloc(sizeof(struct Sco_primop));
- pp -> tag = co_primop;
- pp -> Xgco_primop = PPgco_primop;
- return((coresyn)pp);
-}
-
-stringId *Rgco_primop(t)
- struct Sco_primop *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_primop)
- fprintf(stderr,"gco_primop: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_primop);
-}
-
-/************** co_ccall ******************/
-
-coresyn mkco_ccall(PPgco_ccall, PPgco_ccall_may_gc, PPgco_ccall_arg_tys, PPgco_ccall_res_ty)
- stringId PPgco_ccall;
- long PPgco_ccall_may_gc;
- list PPgco_ccall_arg_tys;
- ttype PPgco_ccall_res_ty;
-{
- register struct Sco_ccall *pp =
- (struct Sco_ccall *) malloc(sizeof(struct Sco_ccall));
- pp -> tag = co_ccall;
- pp -> Xgco_ccall = PPgco_ccall;
- pp -> Xgco_ccall_may_gc = PPgco_ccall_may_gc;
- pp -> Xgco_ccall_arg_tys = PPgco_ccall_arg_tys;
- pp -> Xgco_ccall_res_ty = PPgco_ccall_res_ty;
- return((coresyn)pp);
-}
-
-stringId *Rgco_ccall(t)
- struct Sco_ccall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_ccall)
- fprintf(stderr,"gco_ccall: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_ccall);
-}
-
-long *Rgco_ccall_may_gc(t)
- struct Sco_ccall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_ccall)
- fprintf(stderr,"gco_ccall_may_gc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_ccall_may_gc);
-}
-
-list *Rgco_ccall_arg_tys(t)
- struct Sco_ccall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_ccall)
- fprintf(stderr,"gco_ccall_arg_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_ccall_arg_tys);
-}
-
-ttype *Rgco_ccall_res_ty(t)
- struct Sco_ccall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_ccall)
- fprintf(stderr,"gco_ccall_res_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_ccall_res_ty);
-}
-
-/************** co_casm ******************/
-
-coresyn mkco_casm(PPgco_casm, PPgco_casm_may_gc, PPgco_casm_arg_tys, PPgco_casm_res_ty)
- literal PPgco_casm;
- long PPgco_casm_may_gc;
- list PPgco_casm_arg_tys;
- ttype PPgco_casm_res_ty;
-{
- register struct Sco_casm *pp =
- (struct Sco_casm *) malloc(sizeof(struct Sco_casm));
- pp -> tag = co_casm;
- pp -> Xgco_casm = PPgco_casm;
- pp -> Xgco_casm_may_gc = PPgco_casm_may_gc;
- pp -> Xgco_casm_arg_tys = PPgco_casm_arg_tys;
- pp -> Xgco_casm_res_ty = PPgco_casm_res_ty;
- return((coresyn)pp);
-}
-
-literal *Rgco_casm(t)
- struct Sco_casm *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_casm)
- fprintf(stderr,"gco_casm: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_casm);
-}
-
-long *Rgco_casm_may_gc(t)
- struct Sco_casm *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_casm)
- fprintf(stderr,"gco_casm_may_gc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_casm_may_gc);
-}
-
-list *Rgco_casm_arg_tys(t)
- struct Sco_casm *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_casm)
- fprintf(stderr,"gco_casm_arg_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_casm_arg_tys);
-}
-
-ttype *Rgco_casm_res_ty(t)
- struct Sco_casm *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_casm)
- fprintf(stderr,"gco_casm_res_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_casm_res_ty);
-}
-
-/************** co_preludedictscc ******************/
-
-coresyn mkco_preludedictscc(PPgco_preludedictscc_dupd)
- coresyn PPgco_preludedictscc_dupd;
-{
- register struct Sco_preludedictscc *pp =
- (struct Sco_preludedictscc *) malloc(sizeof(struct Sco_preludedictscc));
- pp -> tag = co_preludedictscc;
- pp -> Xgco_preludedictscc_dupd = PPgco_preludedictscc_dupd;
- return((coresyn)pp);
-}
-
-coresyn *Rgco_preludedictscc_dupd(t)
- struct Sco_preludedictscc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_preludedictscc)
- fprintf(stderr,"gco_preludedictscc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_preludedictscc_dupd);
-}
-
-/************** co_alldictscc ******************/
-
-coresyn mkco_alldictscc(PPgco_alldictscc_m, PPgco_alldictscc_g, PPgco_alldictscc_dupd)
- hstring PPgco_alldictscc_m;
- hstring PPgco_alldictscc_g;
- coresyn PPgco_alldictscc_dupd;
-{
- register struct Sco_alldictscc *pp =
- (struct Sco_alldictscc *) malloc(sizeof(struct Sco_alldictscc));
- pp -> tag = co_alldictscc;
- pp -> Xgco_alldictscc_m = PPgco_alldictscc_m;
- pp -> Xgco_alldictscc_g = PPgco_alldictscc_g;
- pp -> Xgco_alldictscc_dupd = PPgco_alldictscc_dupd;
- return((coresyn)pp);
-}
-
-hstring *Rgco_alldictscc_m(t)
- struct Sco_alldictscc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_alldictscc)
- fprintf(stderr,"gco_alldictscc_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_alldictscc_m);
-}
-
-hstring *Rgco_alldictscc_g(t)
- struct Sco_alldictscc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_alldictscc)
- fprintf(stderr,"gco_alldictscc_g: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_alldictscc_g);
-}
-
-coresyn *Rgco_alldictscc_dupd(t)
- struct Sco_alldictscc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_alldictscc)
- fprintf(stderr,"gco_alldictscc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_alldictscc_dupd);
-}
-
-/************** co_usercc ******************/
-
-coresyn mkco_usercc(PPgco_usercc_n, PPgco_usercc_m, PPgco_usercc_g, PPgco_usercc_dupd, PPgco_usercc_cafd)
- hstring PPgco_usercc_n;
- hstring PPgco_usercc_m;
- hstring PPgco_usercc_g;
- coresyn PPgco_usercc_dupd;
- coresyn PPgco_usercc_cafd;
-{
- register struct Sco_usercc *pp =
- (struct Sco_usercc *) malloc(sizeof(struct Sco_usercc));
- pp -> tag = co_usercc;
- pp -> Xgco_usercc_n = PPgco_usercc_n;
- pp -> Xgco_usercc_m = PPgco_usercc_m;
- pp -> Xgco_usercc_g = PPgco_usercc_g;
- pp -> Xgco_usercc_dupd = PPgco_usercc_dupd;
- pp -> Xgco_usercc_cafd = PPgco_usercc_cafd;
- return((coresyn)pp);
-}
-
-hstring *Rgco_usercc_n(t)
- struct Sco_usercc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_n: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_n);
-}
-
-hstring *Rgco_usercc_m(t)
- struct Sco_usercc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_m);
-}
-
-hstring *Rgco_usercc_g(t)
- struct Sco_usercc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_g: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_g);
-}
-
-coresyn *Rgco_usercc_dupd(t)
- struct Sco_usercc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_dupd);
-}
-
-coresyn *Rgco_usercc_cafd(t)
- struct Sco_usercc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_cafd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_cafd);
-}
-
-/************** co_autocc ******************/
-
-coresyn mkco_autocc(PPgco_autocc_i, PPgco_autocc_m, PPgco_autocc_g, PPgco_autocc_dupd, PPgco_autocc_cafd)
- coresyn PPgco_autocc_i;
- hstring PPgco_autocc_m;
- hstring PPgco_autocc_g;
- coresyn PPgco_autocc_dupd;
- coresyn PPgco_autocc_cafd;
-{
- register struct Sco_autocc *pp =
- (struct Sco_autocc *) malloc(sizeof(struct Sco_autocc));
- pp -> tag = co_autocc;
- pp -> Xgco_autocc_i = PPgco_autocc_i;
- pp -> Xgco_autocc_m = PPgco_autocc_m;
- pp -> Xgco_autocc_g = PPgco_autocc_g;
- pp -> Xgco_autocc_dupd = PPgco_autocc_dupd;
- pp -> Xgco_autocc_cafd = PPgco_autocc_cafd;
- return((coresyn)pp);
-}
-
-coresyn *Rgco_autocc_i(t)
- struct Sco_autocc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_i: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_i);
-}
-
-hstring *Rgco_autocc_m(t)
- struct Sco_autocc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_m);
-}
-
-hstring *Rgco_autocc_g(t)
- struct Sco_autocc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_g: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_g);
-}
-
-coresyn *Rgco_autocc_dupd(t)
- struct Sco_autocc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_dupd);
-}
-
-coresyn *Rgco_autocc_cafd(t)
- struct Sco_autocc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_cafd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_cafd);
-}
-
-/************** co_dictcc ******************/
-
-coresyn mkco_dictcc(PPgco_dictcc_i, PPgco_dictcc_m, PPgco_dictcc_g, PPgco_dictcc_dupd, PPgco_dictcc_cafd)
- coresyn PPgco_dictcc_i;
- hstring PPgco_dictcc_m;
- hstring PPgco_dictcc_g;
- coresyn PPgco_dictcc_dupd;
- coresyn PPgco_dictcc_cafd;
-{
- register struct Sco_dictcc *pp =
- (struct Sco_dictcc *) malloc(sizeof(struct Sco_dictcc));
- pp -> tag = co_dictcc;
- pp -> Xgco_dictcc_i = PPgco_dictcc_i;
- pp -> Xgco_dictcc_m = PPgco_dictcc_m;
- pp -> Xgco_dictcc_g = PPgco_dictcc_g;
- pp -> Xgco_dictcc_dupd = PPgco_dictcc_dupd;
- pp -> Xgco_dictcc_cafd = PPgco_dictcc_cafd;
- return((coresyn)pp);
-}
-
-coresyn *Rgco_dictcc_i(t)
- struct Sco_dictcc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_i: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_i);
-}
-
-hstring *Rgco_dictcc_m(t)
- struct Sco_dictcc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_m);
-}
-
-hstring *Rgco_dictcc_g(t)
- struct Sco_dictcc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_g: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_g);
-}
-
-coresyn *Rgco_dictcc_dupd(t)
- struct Sco_dictcc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_dupd);
-}
-
-coresyn *Rgco_dictcc_cafd(t)
- struct Sco_dictcc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_cafd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_cafd);
-}
-
-/************** co_scc_noncaf ******************/
-
-coresyn mkco_scc_noncaf(void)
-{
- register struct Sco_scc_noncaf *pp =
- (struct Sco_scc_noncaf *) malloc(sizeof(struct Sco_scc_noncaf));
- pp -> tag = co_scc_noncaf;
- return((coresyn)pp);
-}
-
-/************** co_scc_caf ******************/
-
-coresyn mkco_scc_caf(void)
-{
- register struct Sco_scc_caf *pp =
- (struct Sco_scc_caf *) malloc(sizeof(struct Sco_scc_caf));
- pp -> tag = co_scc_caf;
- return((coresyn)pp);
-}
-
-/************** co_scc_nondupd ******************/
-
-coresyn mkco_scc_nondupd(void)
-{
- register struct Sco_scc_nondupd *pp =
- (struct Sco_scc_nondupd *) malloc(sizeof(struct Sco_scc_nondupd));
- pp -> tag = co_scc_nondupd;
- return((coresyn)pp);
-}
-
-/************** co_scc_dupd ******************/
-
-coresyn mkco_scc_dupd(void)
-{
- register struct Sco_scc_dupd *pp =
- (struct Sco_scc_dupd *) malloc(sizeof(struct Sco_scc_dupd));
- pp -> tag = co_scc_dupd;
- return((coresyn)pp);
-}
-
-/************** co_id ******************/
-
-coresyn mkco_id(PPgco_id)
- stringId PPgco_id;
-{
- register struct Sco_id *pp =
- (struct Sco_id *) malloc(sizeof(struct Sco_id));
- pp -> tag = co_id;
- pp -> Xgco_id = PPgco_id;
- return((coresyn)pp);
-}
-
-stringId *Rgco_id(t)
- struct Sco_id *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_id)
- fprintf(stderr,"gco_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_id);
-}
-
-/************** co_orig_id ******************/
-
-coresyn mkco_orig_id(PPgco_orig_id_m, PPgco_orig_id_n)
- stringId PPgco_orig_id_m;
- stringId PPgco_orig_id_n;
-{
- register struct Sco_orig_id *pp =
- (struct Sco_orig_id *) malloc(sizeof(struct Sco_orig_id));
- pp -> tag = co_orig_id;
- pp -> Xgco_orig_id_m = PPgco_orig_id_m;
- pp -> Xgco_orig_id_n = PPgco_orig_id_n;
- return((coresyn)pp);
-}
-
-stringId *Rgco_orig_id_m(t)
- struct Sco_orig_id *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_orig_id)
- fprintf(stderr,"gco_orig_id_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_orig_id_m);
-}
-
-stringId *Rgco_orig_id_n(t)
- struct Sco_orig_id *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_orig_id)
- fprintf(stderr,"gco_orig_id_n: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_orig_id_n);
-}
-
-/************** co_sdselid ******************/
-
-coresyn mkco_sdselid(PPgco_sdselid_c, PPgco_sdselid_sc)
- unkId PPgco_sdselid_c;
- unkId PPgco_sdselid_sc;
-{
- register struct Sco_sdselid *pp =
- (struct Sco_sdselid *) malloc(sizeof(struct Sco_sdselid));
- pp -> tag = co_sdselid;
- pp -> Xgco_sdselid_c = PPgco_sdselid_c;
- pp -> Xgco_sdselid_sc = PPgco_sdselid_sc;
- return((coresyn)pp);
-}
-
-unkId *Rgco_sdselid_c(t)
- struct Sco_sdselid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_sdselid)
- fprintf(stderr,"gco_sdselid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_sdselid_c);
-}
-
-unkId *Rgco_sdselid_sc(t)
- struct Sco_sdselid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_sdselid)
- fprintf(stderr,"gco_sdselid_sc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_sdselid_sc);
-}
-
-/************** co_classopid ******************/
-
-coresyn mkco_classopid(PPgco_classopid_c, PPgco_classopid_o)
- unkId PPgco_classopid_c;
- unkId PPgco_classopid_o;
-{
- register struct Sco_classopid *pp =
- (struct Sco_classopid *) malloc(sizeof(struct Sco_classopid));
- pp -> tag = co_classopid;
- pp -> Xgco_classopid_c = PPgco_classopid_c;
- pp -> Xgco_classopid_o = PPgco_classopid_o;
- return((coresyn)pp);
-}
-
-unkId *Rgco_classopid_c(t)
- struct Sco_classopid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_classopid)
- fprintf(stderr,"gco_classopid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_classopid_c);
-}
-
-unkId *Rgco_classopid_o(t)
- struct Sco_classopid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_classopid)
- fprintf(stderr,"gco_classopid_o: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_classopid_o);
-}
-
-/************** co_defmid ******************/
-
-coresyn mkco_defmid(PPgco_defmid_c, PPgco_defmid_op)
- unkId PPgco_defmid_c;
- unkId PPgco_defmid_op;
-{
- register struct Sco_defmid *pp =
- (struct Sco_defmid *) malloc(sizeof(struct Sco_defmid));
- pp -> tag = co_defmid;
- pp -> Xgco_defmid_c = PPgco_defmid_c;
- pp -> Xgco_defmid_op = PPgco_defmid_op;
- return((coresyn)pp);
-}
-
-unkId *Rgco_defmid_c(t)
- struct Sco_defmid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_defmid)
- fprintf(stderr,"gco_defmid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_defmid_c);
-}
-
-unkId *Rgco_defmid_op(t)
- struct Sco_defmid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_defmid)
- fprintf(stderr,"gco_defmid_op: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_defmid_op);
-}
-
-/************** co_dfunid ******************/
-
-coresyn mkco_dfunid(PPgco_dfunid_c, PPgco_dfunid_ty)
- unkId PPgco_dfunid_c;
- ttype PPgco_dfunid_ty;
-{
- register struct Sco_dfunid *pp =
- (struct Sco_dfunid *) malloc(sizeof(struct Sco_dfunid));
- pp -> tag = co_dfunid;
- pp -> Xgco_dfunid_c = PPgco_dfunid_c;
- pp -> Xgco_dfunid_ty = PPgco_dfunid_ty;
- return((coresyn)pp);
-}
-
-unkId *Rgco_dfunid_c(t)
- struct Sco_dfunid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dfunid)
- fprintf(stderr,"gco_dfunid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dfunid_c);
-}
-
-ttype *Rgco_dfunid_ty(t)
- struct Sco_dfunid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dfunid)
- fprintf(stderr,"gco_dfunid_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dfunid_ty);
-}
-
-/************** co_constmid ******************/
-
-coresyn mkco_constmid(PPgco_constmid_c, PPgco_constmid_op, PPgco_constmid_ty)
- unkId PPgco_constmid_c;
- unkId PPgco_constmid_op;
- ttype PPgco_constmid_ty;
-{
- register struct Sco_constmid *pp =
- (struct Sco_constmid *) malloc(sizeof(struct Sco_constmid));
- pp -> tag = co_constmid;
- pp -> Xgco_constmid_c = PPgco_constmid_c;
- pp -> Xgco_constmid_op = PPgco_constmid_op;
- pp -> Xgco_constmid_ty = PPgco_constmid_ty;
- return((coresyn)pp);
-}
-
-unkId *Rgco_constmid_c(t)
- struct Sco_constmid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_constmid)
- fprintf(stderr,"gco_constmid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_constmid_c);
-}
-
-unkId *Rgco_constmid_op(t)
- struct Sco_constmid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_constmid)
- fprintf(stderr,"gco_constmid_op: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_constmid_op);
-}
-
-ttype *Rgco_constmid_ty(t)
- struct Sco_constmid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_constmid)
- fprintf(stderr,"gco_constmid_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_constmid_ty);
-}
-
-/************** co_specid ******************/
-
-coresyn mkco_specid(PPgco_specid_un, PPgco_specid_tys)
- coresyn PPgco_specid_un;
- list PPgco_specid_tys;
-{
- register struct Sco_specid *pp =
- (struct Sco_specid *) malloc(sizeof(struct Sco_specid));
- pp -> tag = co_specid;
- pp -> Xgco_specid_un = PPgco_specid_un;
- pp -> Xgco_specid_tys = PPgco_specid_tys;
- return((coresyn)pp);
-}
-
-coresyn *Rgco_specid_un(t)
- struct Sco_specid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_specid)
- fprintf(stderr,"gco_specid_un: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_specid_un);
-}
-
-list *Rgco_specid_tys(t)
- struct Sco_specid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_specid)
- fprintf(stderr,"gco_specid_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_specid_tys);
-}
-
-/************** co_wrkrid ******************/
-
-coresyn mkco_wrkrid(PPgco_wrkrid_un)
- coresyn PPgco_wrkrid_un;
-{
- register struct Sco_wrkrid *pp =
- (struct Sco_wrkrid *) malloc(sizeof(struct Sco_wrkrid));
- pp -> tag = co_wrkrid;
- pp -> Xgco_wrkrid_un = PPgco_wrkrid_un;
- return((coresyn)pp);
-}
-
-coresyn *Rgco_wrkrid_un(t)
- struct Sco_wrkrid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_wrkrid)
- fprintf(stderr,"gco_wrkrid_un: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_wrkrid_un);
-}
+++ /dev/null
-#ifndef coresyn_defined
-#define coresyn_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- cobinder,
- colit,
- colocal,
- cononrec,
- corec,
- corec_pair,
- covar,
- coliteral,
- cocon,
- coprim,
- colam,
- cotylam,
- coapp,
- cotyapp,
- cocase,
- colet,
- coscc,
- coalg_alts,
- coalg_alt,
- coprim_alts,
- coprim_alt,
- conodeflt,
- cobinddeflt,
- co_primop,
- co_ccall,
- co_casm,
- co_preludedictscc,
- co_alldictscc,
- co_usercc,
- co_autocc,
- co_dictcc,
- co_scc_noncaf,
- co_scc_caf,
- co_scc_nondupd,
- co_scc_dupd,
- co_id,
- co_orig_id,
- co_sdselid,
- co_classopid,
- co_defmid,
- co_dfunid,
- co_constmid,
- co_specid,
- co_wrkrid
-} Tcoresyn;
-
-typedef struct { Tcoresyn tag; } *coresyn;
-
-#ifdef __GNUC__
-Tcoresyn tcoresyn(coresyn t);
-extern __inline__ Tcoresyn tcoresyn(coresyn t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tcoresyn tcoresyn PROTO((coresyn));
-#endif /* ! __GNUC__ */
-
-struct Scobinder {
- Tcoresyn tag;
- unkId Xgcobinder_v;
- ttype Xgcobinder_ty;
-};
-
-struct Scolit {
- Tcoresyn tag;
- literal Xgcolit;
-};
-
-struct Scolocal {
- Tcoresyn tag;
- coresyn Xgcolocal_v;
-};
-
-struct Scononrec {
- Tcoresyn tag;
- coresyn Xgcononrec_b;
- coresyn Xgcononrec_rhs;
-};
-
-struct Scorec {
- Tcoresyn tag;
- list Xgcorec;
-};
-
-struct Scorec_pair {
- Tcoresyn tag;
- coresyn Xgcorec_b;
- coresyn Xgcorec_rhs;
-};
-
-struct Scovar {
- Tcoresyn tag;
- coresyn Xgcovar;
-};
-
-struct Scoliteral {
- Tcoresyn tag;
- literal Xgcoliteral;
-};
-
-struct Scocon {
- Tcoresyn tag;
- coresyn Xgcocon_con;
- list Xgcocon_tys;
- list Xgcocon_args;
-};
-
-struct Scoprim {
- Tcoresyn tag;
- coresyn Xgcoprim_op;
- list Xgcoprim_tys;
- list Xgcoprim_args;
-};
-
-struct Scolam {
- Tcoresyn tag;
- list Xgcolam_vars;
- coresyn Xgcolam_body;
-};
-
-struct Scotylam {
- Tcoresyn tag;
- list Xgcotylam_tvs;
- coresyn Xgcotylam_body;
-};
-
-struct Scoapp {
- Tcoresyn tag;
- coresyn Xgcoapp_fun;
- list Xgcoapp_args;
-};
-
-struct Scotyapp {
- Tcoresyn tag;
- coresyn Xgcotyapp_e;
- ttype Xgcotyapp_t;
-};
-
-struct Scocase {
- Tcoresyn tag;
- coresyn Xgcocase_s;
- coresyn Xgcocase_alts;
-};
-
-struct Scolet {
- Tcoresyn tag;
- coresyn Xgcolet_bind;
- coresyn Xgcolet_body;
-};
-
-struct Scoscc {
- Tcoresyn tag;
- coresyn Xgcoscc_scc;
- coresyn Xgcoscc_body;
-};
-
-struct Scoalg_alts {
- Tcoresyn tag;
- list Xgcoalg_alts;
- coresyn Xgcoalg_deflt;
-};
-
-struct Scoalg_alt {
- Tcoresyn tag;
- coresyn Xgcoalg_con;
- list Xgcoalg_bs;
- coresyn Xgcoalg_rhs;
-};
-
-struct Scoprim_alts {
- Tcoresyn tag;
- list Xgcoprim_alts;
- coresyn Xgcoprim_deflt;
-};
-
-struct Scoprim_alt {
- Tcoresyn tag;
- literal Xgcoprim_lit;
- coresyn Xgcoprim_rhs;
-};
-
-struct Sconodeflt {
- Tcoresyn tag;
-};
-
-struct Scobinddeflt {
- Tcoresyn tag;
- coresyn Xgcobinddeflt_v;
- coresyn Xgcobinddeflt_rhs;
-};
-
-struct Sco_primop {
- Tcoresyn tag;
- stringId Xgco_primop;
-};
-
-struct Sco_ccall {
- Tcoresyn tag;
- stringId Xgco_ccall;
- long Xgco_ccall_may_gc;
- list Xgco_ccall_arg_tys;
- ttype Xgco_ccall_res_ty;
-};
-
-struct Sco_casm {
- Tcoresyn tag;
- literal Xgco_casm;
- long Xgco_casm_may_gc;
- list Xgco_casm_arg_tys;
- ttype Xgco_casm_res_ty;
-};
-
-struct Sco_preludedictscc {
- Tcoresyn tag;
- coresyn Xgco_preludedictscc_dupd;
-};
-
-struct Sco_alldictscc {
- Tcoresyn tag;
- hstring Xgco_alldictscc_m;
- hstring Xgco_alldictscc_g;
- coresyn Xgco_alldictscc_dupd;
-};
-
-struct Sco_usercc {
- Tcoresyn tag;
- hstring Xgco_usercc_n;
- hstring Xgco_usercc_m;
- hstring Xgco_usercc_g;
- coresyn Xgco_usercc_dupd;
- coresyn Xgco_usercc_cafd;
-};
-
-struct Sco_autocc {
- Tcoresyn tag;
- coresyn Xgco_autocc_i;
- hstring Xgco_autocc_m;
- hstring Xgco_autocc_g;
- coresyn Xgco_autocc_dupd;
- coresyn Xgco_autocc_cafd;
-};
-
-struct Sco_dictcc {
- Tcoresyn tag;
- coresyn Xgco_dictcc_i;
- hstring Xgco_dictcc_m;
- hstring Xgco_dictcc_g;
- coresyn Xgco_dictcc_dupd;
- coresyn Xgco_dictcc_cafd;
-};
-
-struct Sco_scc_noncaf {
- Tcoresyn tag;
-};
-
-struct Sco_scc_caf {
- Tcoresyn tag;
-};
-
-struct Sco_scc_nondupd {
- Tcoresyn tag;
-};
-
-struct Sco_scc_dupd {
- Tcoresyn tag;
-};
-
-struct Sco_id {
- Tcoresyn tag;
- stringId Xgco_id;
-};
-
-struct Sco_orig_id {
- Tcoresyn tag;
- stringId Xgco_orig_id_m;
- stringId Xgco_orig_id_n;
-};
-
-struct Sco_sdselid {
- Tcoresyn tag;
- unkId Xgco_sdselid_c;
- unkId Xgco_sdselid_sc;
-};
-
-struct Sco_classopid {
- Tcoresyn tag;
- unkId Xgco_classopid_c;
- unkId Xgco_classopid_o;
-};
-
-struct Sco_defmid {
- Tcoresyn tag;
- unkId Xgco_defmid_c;
- unkId Xgco_defmid_op;
-};
-
-struct Sco_dfunid {
- Tcoresyn tag;
- unkId Xgco_dfunid_c;
- ttype Xgco_dfunid_ty;
-};
-
-struct Sco_constmid {
- Tcoresyn tag;
- unkId Xgco_constmid_c;
- unkId Xgco_constmid_op;
- ttype Xgco_constmid_ty;
-};
-
-struct Sco_specid {
- Tcoresyn tag;
- coresyn Xgco_specid_un;
- list Xgco_specid_tys;
-};
-
-struct Sco_wrkrid {
- Tcoresyn tag;
- coresyn Xgco_wrkrid_un;
-};
-
-extern coresyn mkcobinder PROTO((unkId, ttype));
-#ifdef __GNUC__
-
-unkId *Rgcobinder_v PROTO((struct Scobinder *));
-
-extern __inline__ unkId *Rgcobinder_v(struct Scobinder *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cobinder)
- fprintf(stderr,"gcobinder_v: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcobinder_v);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgcobinder_v PROTO((struct Scobinder *));
-#endif /* ! __GNUC__ */
-
-#define gcobinder_v(xyzxyz) (*Rgcobinder_v((struct Scobinder *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgcobinder_ty PROTO((struct Scobinder *));
-
-extern __inline__ ttype *Rgcobinder_ty(struct Scobinder *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cobinder)
- fprintf(stderr,"gcobinder_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcobinder_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgcobinder_ty PROTO((struct Scobinder *));
-#endif /* ! __GNUC__ */
-
-#define gcobinder_ty(xyzxyz) (*Rgcobinder_ty((struct Scobinder *) (xyzxyz)))
-
-extern coresyn mkcolit PROTO((literal));
-#ifdef __GNUC__
-
-literal *Rgcolit PROTO((struct Scolit *));
-
-extern __inline__ literal *Rgcolit(struct Scolit *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colit)
- fprintf(stderr,"gcolit: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolit);
-}
-#else /* ! __GNUC__ */
-extern literal *Rgcolit PROTO((struct Scolit *));
-#endif /* ! __GNUC__ */
-
-#define gcolit(xyzxyz) (*Rgcolit((struct Scolit *) (xyzxyz)))
-
-extern coresyn mkcolocal PROTO((coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcolocal_v PROTO((struct Scolocal *));
-
-extern __inline__ coresyn *Rgcolocal_v(struct Scolocal *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colocal)
- fprintf(stderr,"gcolocal_v: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolocal_v);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcolocal_v PROTO((struct Scolocal *));
-#endif /* ! __GNUC__ */
-
-#define gcolocal_v(xyzxyz) (*Rgcolocal_v((struct Scolocal *) (xyzxyz)))
-
-extern coresyn mkcononrec PROTO((coresyn, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcononrec_b PROTO((struct Scononrec *));
-
-extern __inline__ coresyn *Rgcononrec_b(struct Scononrec *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cononrec)
- fprintf(stderr,"gcononrec_b: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcononrec_b);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcononrec_b PROTO((struct Scononrec *));
-#endif /* ! __GNUC__ */
-
-#define gcononrec_b(xyzxyz) (*Rgcononrec_b((struct Scononrec *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcononrec_rhs PROTO((struct Scononrec *));
-
-extern __inline__ coresyn *Rgcononrec_rhs(struct Scononrec *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cononrec)
- fprintf(stderr,"gcononrec_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcononrec_rhs);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcononrec_rhs PROTO((struct Scononrec *));
-#endif /* ! __GNUC__ */
-
-#define gcononrec_rhs(xyzxyz) (*Rgcononrec_rhs((struct Scononrec *) (xyzxyz)))
-
-extern coresyn mkcorec PROTO((list));
-#ifdef __GNUC__
-
-list *Rgcorec PROTO((struct Scorec *));
-
-extern __inline__ list *Rgcorec(struct Scorec *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != corec)
- fprintf(stderr,"gcorec: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcorec);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcorec PROTO((struct Scorec *));
-#endif /* ! __GNUC__ */
-
-#define gcorec(xyzxyz) (*Rgcorec((struct Scorec *) (xyzxyz)))
-
-extern coresyn mkcorec_pair PROTO((coresyn, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcorec_b PROTO((struct Scorec_pair *));
-
-extern __inline__ coresyn *Rgcorec_b(struct Scorec_pair *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != corec_pair)
- fprintf(stderr,"gcorec_b: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcorec_b);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcorec_b PROTO((struct Scorec_pair *));
-#endif /* ! __GNUC__ */
-
-#define gcorec_b(xyzxyz) (*Rgcorec_b((struct Scorec_pair *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcorec_rhs PROTO((struct Scorec_pair *));
-
-extern __inline__ coresyn *Rgcorec_rhs(struct Scorec_pair *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != corec_pair)
- fprintf(stderr,"gcorec_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcorec_rhs);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcorec_rhs PROTO((struct Scorec_pair *));
-#endif /* ! __GNUC__ */
-
-#define gcorec_rhs(xyzxyz) (*Rgcorec_rhs((struct Scorec_pair *) (xyzxyz)))
-
-extern coresyn mkcovar PROTO((coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcovar PROTO((struct Scovar *));
-
-extern __inline__ coresyn *Rgcovar(struct Scovar *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != covar)
- fprintf(stderr,"gcovar: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcovar);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcovar PROTO((struct Scovar *));
-#endif /* ! __GNUC__ */
-
-#define gcovar(xyzxyz) (*Rgcovar((struct Scovar *) (xyzxyz)))
-
-extern coresyn mkcoliteral PROTO((literal));
-#ifdef __GNUC__
-
-literal *Rgcoliteral PROTO((struct Scoliteral *));
-
-extern __inline__ literal *Rgcoliteral(struct Scoliteral *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coliteral)
- fprintf(stderr,"gcoliteral: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoliteral);
-}
-#else /* ! __GNUC__ */
-extern literal *Rgcoliteral PROTO((struct Scoliteral *));
-#endif /* ! __GNUC__ */
-
-#define gcoliteral(xyzxyz) (*Rgcoliteral((struct Scoliteral *) (xyzxyz)))
-
-extern coresyn mkcocon PROTO((coresyn, list, list));
-#ifdef __GNUC__
-
-coresyn *Rgcocon_con PROTO((struct Scocon *));
-
-extern __inline__ coresyn *Rgcocon_con(struct Scocon *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocon)
- fprintf(stderr,"gcocon_con: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocon_con);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcocon_con PROTO((struct Scocon *));
-#endif /* ! __GNUC__ */
-
-#define gcocon_con(xyzxyz) (*Rgcocon_con((struct Scocon *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcocon_tys PROTO((struct Scocon *));
-
-extern __inline__ list *Rgcocon_tys(struct Scocon *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocon)
- fprintf(stderr,"gcocon_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocon_tys);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcocon_tys PROTO((struct Scocon *));
-#endif /* ! __GNUC__ */
-
-#define gcocon_tys(xyzxyz) (*Rgcocon_tys((struct Scocon *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcocon_args PROTO((struct Scocon *));
-
-extern __inline__ list *Rgcocon_args(struct Scocon *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocon)
- fprintf(stderr,"gcocon_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocon_args);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcocon_args PROTO((struct Scocon *));
-#endif /* ! __GNUC__ */
-
-#define gcocon_args(xyzxyz) (*Rgcocon_args((struct Scocon *) (xyzxyz)))
-
-extern coresyn mkcoprim PROTO((coresyn, list, list));
-#ifdef __GNUC__
-
-coresyn *Rgcoprim_op PROTO((struct Scoprim *));
-
-extern __inline__ coresyn *Rgcoprim_op(struct Scoprim *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim)
- fprintf(stderr,"gcoprim_op: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_op);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoprim_op PROTO((struct Scoprim *));
-#endif /* ! __GNUC__ */
-
-#define gcoprim_op(xyzxyz) (*Rgcoprim_op((struct Scoprim *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcoprim_tys PROTO((struct Scoprim *));
-
-extern __inline__ list *Rgcoprim_tys(struct Scoprim *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim)
- fprintf(stderr,"gcoprim_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_tys);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcoprim_tys PROTO((struct Scoprim *));
-#endif /* ! __GNUC__ */
-
-#define gcoprim_tys(xyzxyz) (*Rgcoprim_tys((struct Scoprim *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcoprim_args PROTO((struct Scoprim *));
-
-extern __inline__ list *Rgcoprim_args(struct Scoprim *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim)
- fprintf(stderr,"gcoprim_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_args);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcoprim_args PROTO((struct Scoprim *));
-#endif /* ! __GNUC__ */
-
-#define gcoprim_args(xyzxyz) (*Rgcoprim_args((struct Scoprim *) (xyzxyz)))
-
-extern coresyn mkcolam PROTO((list, coresyn));
-#ifdef __GNUC__
-
-list *Rgcolam_vars PROTO((struct Scolam *));
-
-extern __inline__ list *Rgcolam_vars(struct Scolam *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colam)
- fprintf(stderr,"gcolam_vars: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolam_vars);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcolam_vars PROTO((struct Scolam *));
-#endif /* ! __GNUC__ */
-
-#define gcolam_vars(xyzxyz) (*Rgcolam_vars((struct Scolam *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcolam_body PROTO((struct Scolam *));
-
-extern __inline__ coresyn *Rgcolam_body(struct Scolam *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colam)
- fprintf(stderr,"gcolam_body: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolam_body);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcolam_body PROTO((struct Scolam *));
-#endif /* ! __GNUC__ */
-
-#define gcolam_body(xyzxyz) (*Rgcolam_body((struct Scolam *) (xyzxyz)))
-
-extern coresyn mkcotylam PROTO((list, coresyn));
-#ifdef __GNUC__
-
-list *Rgcotylam_tvs PROTO((struct Scotylam *));
-
-extern __inline__ list *Rgcotylam_tvs(struct Scotylam *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cotylam)
- fprintf(stderr,"gcotylam_tvs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcotylam_tvs);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcotylam_tvs PROTO((struct Scotylam *));
-#endif /* ! __GNUC__ */
-
-#define gcotylam_tvs(xyzxyz) (*Rgcotylam_tvs((struct Scotylam *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcotylam_body PROTO((struct Scotylam *));
-
-extern __inline__ coresyn *Rgcotylam_body(struct Scotylam *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cotylam)
- fprintf(stderr,"gcotylam_body: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcotylam_body);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcotylam_body PROTO((struct Scotylam *));
-#endif /* ! __GNUC__ */
-
-#define gcotylam_body(xyzxyz) (*Rgcotylam_body((struct Scotylam *) (xyzxyz)))
-
-extern coresyn mkcoapp PROTO((coresyn, list));
-#ifdef __GNUC__
-
-coresyn *Rgcoapp_fun PROTO((struct Scoapp *));
-
-extern __inline__ coresyn *Rgcoapp_fun(struct Scoapp *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coapp)
- fprintf(stderr,"gcoapp_fun: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoapp_fun);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoapp_fun PROTO((struct Scoapp *));
-#endif /* ! __GNUC__ */
-
-#define gcoapp_fun(xyzxyz) (*Rgcoapp_fun((struct Scoapp *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcoapp_args PROTO((struct Scoapp *));
-
-extern __inline__ list *Rgcoapp_args(struct Scoapp *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coapp)
- fprintf(stderr,"gcoapp_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoapp_args);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcoapp_args PROTO((struct Scoapp *));
-#endif /* ! __GNUC__ */
-
-#define gcoapp_args(xyzxyz) (*Rgcoapp_args((struct Scoapp *) (xyzxyz)))
-
-extern coresyn mkcotyapp PROTO((coresyn, ttype));
-#ifdef __GNUC__
-
-coresyn *Rgcotyapp_e PROTO((struct Scotyapp *));
-
-extern __inline__ coresyn *Rgcotyapp_e(struct Scotyapp *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cotyapp)
- fprintf(stderr,"gcotyapp_e: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcotyapp_e);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcotyapp_e PROTO((struct Scotyapp *));
-#endif /* ! __GNUC__ */
-
-#define gcotyapp_e(xyzxyz) (*Rgcotyapp_e((struct Scotyapp *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgcotyapp_t PROTO((struct Scotyapp *));
-
-extern __inline__ ttype *Rgcotyapp_t(struct Scotyapp *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cotyapp)
- fprintf(stderr,"gcotyapp_t: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcotyapp_t);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgcotyapp_t PROTO((struct Scotyapp *));
-#endif /* ! __GNUC__ */
-
-#define gcotyapp_t(xyzxyz) (*Rgcotyapp_t((struct Scotyapp *) (xyzxyz)))
-
-extern coresyn mkcocase PROTO((coresyn, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcocase_s PROTO((struct Scocase *));
-
-extern __inline__ coresyn *Rgcocase_s(struct Scocase *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocase)
- fprintf(stderr,"gcocase_s: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocase_s);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcocase_s PROTO((struct Scocase *));
-#endif /* ! __GNUC__ */
-
-#define gcocase_s(xyzxyz) (*Rgcocase_s((struct Scocase *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcocase_alts PROTO((struct Scocase *));
-
-extern __inline__ coresyn *Rgcocase_alts(struct Scocase *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cocase)
- fprintf(stderr,"gcocase_alts: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcocase_alts);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcocase_alts PROTO((struct Scocase *));
-#endif /* ! __GNUC__ */
-
-#define gcocase_alts(xyzxyz) (*Rgcocase_alts((struct Scocase *) (xyzxyz)))
-
-extern coresyn mkcolet PROTO((coresyn, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcolet_bind PROTO((struct Scolet *));
-
-extern __inline__ coresyn *Rgcolet_bind(struct Scolet *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colet)
- fprintf(stderr,"gcolet_bind: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolet_bind);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcolet_bind PROTO((struct Scolet *));
-#endif /* ! __GNUC__ */
-
-#define gcolet_bind(xyzxyz) (*Rgcolet_bind((struct Scolet *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcolet_body PROTO((struct Scolet *));
-
-extern __inline__ coresyn *Rgcolet_body(struct Scolet *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != colet)
- fprintf(stderr,"gcolet_body: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcolet_body);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcolet_body PROTO((struct Scolet *));
-#endif /* ! __GNUC__ */
-
-#define gcolet_body(xyzxyz) (*Rgcolet_body((struct Scolet *) (xyzxyz)))
-
-extern coresyn mkcoscc PROTO((coresyn, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcoscc_scc PROTO((struct Scoscc *));
-
-extern __inline__ coresyn *Rgcoscc_scc(struct Scoscc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coscc)
- fprintf(stderr,"gcoscc_scc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoscc_scc);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoscc_scc PROTO((struct Scoscc *));
-#endif /* ! __GNUC__ */
-
-#define gcoscc_scc(xyzxyz) (*Rgcoscc_scc((struct Scoscc *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcoscc_body PROTO((struct Scoscc *));
-
-extern __inline__ coresyn *Rgcoscc_body(struct Scoscc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coscc)
- fprintf(stderr,"gcoscc_body: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoscc_body);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoscc_body PROTO((struct Scoscc *));
-#endif /* ! __GNUC__ */
-
-#define gcoscc_body(xyzxyz) (*Rgcoscc_body((struct Scoscc *) (xyzxyz)))
-
-extern coresyn mkcoalg_alts PROTO((list, coresyn));
-#ifdef __GNUC__
-
-list *Rgcoalg_alts PROTO((struct Scoalg_alts *));
-
-extern __inline__ list *Rgcoalg_alts(struct Scoalg_alts *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alts)
- fprintf(stderr,"gcoalg_alts: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_alts);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcoalg_alts PROTO((struct Scoalg_alts *));
-#endif /* ! __GNUC__ */
-
-#define gcoalg_alts(xyzxyz) (*Rgcoalg_alts((struct Scoalg_alts *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcoalg_deflt PROTO((struct Scoalg_alts *));
-
-extern __inline__ coresyn *Rgcoalg_deflt(struct Scoalg_alts *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alts)
- fprintf(stderr,"gcoalg_deflt: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_deflt);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoalg_deflt PROTO((struct Scoalg_alts *));
-#endif /* ! __GNUC__ */
-
-#define gcoalg_deflt(xyzxyz) (*Rgcoalg_deflt((struct Scoalg_alts *) (xyzxyz)))
-
-extern coresyn mkcoalg_alt PROTO((coresyn, list, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcoalg_con PROTO((struct Scoalg_alt *));
-
-extern __inline__ coresyn *Rgcoalg_con(struct Scoalg_alt *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alt)
- fprintf(stderr,"gcoalg_con: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_con);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoalg_con PROTO((struct Scoalg_alt *));
-#endif /* ! __GNUC__ */
-
-#define gcoalg_con(xyzxyz) (*Rgcoalg_con((struct Scoalg_alt *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcoalg_bs PROTO((struct Scoalg_alt *));
-
-extern __inline__ list *Rgcoalg_bs(struct Scoalg_alt *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alt)
- fprintf(stderr,"gcoalg_bs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_bs);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcoalg_bs PROTO((struct Scoalg_alt *));
-#endif /* ! __GNUC__ */
-
-#define gcoalg_bs(xyzxyz) (*Rgcoalg_bs((struct Scoalg_alt *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcoalg_rhs PROTO((struct Scoalg_alt *));
-
-extern __inline__ coresyn *Rgcoalg_rhs(struct Scoalg_alt *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coalg_alt)
- fprintf(stderr,"gcoalg_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoalg_rhs);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoalg_rhs PROTO((struct Scoalg_alt *));
-#endif /* ! __GNUC__ */
-
-#define gcoalg_rhs(xyzxyz) (*Rgcoalg_rhs((struct Scoalg_alt *) (xyzxyz)))
-
-extern coresyn mkcoprim_alts PROTO((list, coresyn));
-#ifdef __GNUC__
-
-list *Rgcoprim_alts PROTO((struct Scoprim_alts *));
-
-extern __inline__ list *Rgcoprim_alts(struct Scoprim_alts *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim_alts)
- fprintf(stderr,"gcoprim_alts: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_alts);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcoprim_alts PROTO((struct Scoprim_alts *));
-#endif /* ! __GNUC__ */
-
-#define gcoprim_alts(xyzxyz) (*Rgcoprim_alts((struct Scoprim_alts *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcoprim_deflt PROTO((struct Scoprim_alts *));
-
-extern __inline__ coresyn *Rgcoprim_deflt(struct Scoprim_alts *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim_alts)
- fprintf(stderr,"gcoprim_deflt: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_deflt);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoprim_deflt PROTO((struct Scoprim_alts *));
-#endif /* ! __GNUC__ */
-
-#define gcoprim_deflt(xyzxyz) (*Rgcoprim_deflt((struct Scoprim_alts *) (xyzxyz)))
-
-extern coresyn mkcoprim_alt PROTO((literal, coresyn));
-#ifdef __GNUC__
-
-literal *Rgcoprim_lit PROTO((struct Scoprim_alt *));
-
-extern __inline__ literal *Rgcoprim_lit(struct Scoprim_alt *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim_alt)
- fprintf(stderr,"gcoprim_lit: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_lit);
-}
-#else /* ! __GNUC__ */
-extern literal *Rgcoprim_lit PROTO((struct Scoprim_alt *));
-#endif /* ! __GNUC__ */
-
-#define gcoprim_lit(xyzxyz) (*Rgcoprim_lit((struct Scoprim_alt *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcoprim_rhs PROTO((struct Scoprim_alt *));
-
-extern __inline__ coresyn *Rgcoprim_rhs(struct Scoprim_alt *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != coprim_alt)
- fprintf(stderr,"gcoprim_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcoprim_rhs);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcoprim_rhs PROTO((struct Scoprim_alt *));
-#endif /* ! __GNUC__ */
-
-#define gcoprim_rhs(xyzxyz) (*Rgcoprim_rhs((struct Scoprim_alt *) (xyzxyz)))
-
-extern coresyn mkconodeflt PROTO((void));
-
-extern coresyn mkcobinddeflt PROTO((coresyn, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgcobinddeflt_v PROTO((struct Scobinddeflt *));
-
-extern __inline__ coresyn *Rgcobinddeflt_v(struct Scobinddeflt *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cobinddeflt)
- fprintf(stderr,"gcobinddeflt_v: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcobinddeflt_v);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcobinddeflt_v PROTO((struct Scobinddeflt *));
-#endif /* ! __GNUC__ */
-
-#define gcobinddeflt_v(xyzxyz) (*Rgcobinddeflt_v((struct Scobinddeflt *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgcobinddeflt_rhs PROTO((struct Scobinddeflt *));
-
-extern __inline__ coresyn *Rgcobinddeflt_rhs(struct Scobinddeflt *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != cobinddeflt)
- fprintf(stderr,"gcobinddeflt_rhs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcobinddeflt_rhs);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgcobinddeflt_rhs PROTO((struct Scobinddeflt *));
-#endif /* ! __GNUC__ */
-
-#define gcobinddeflt_rhs(xyzxyz) (*Rgcobinddeflt_rhs((struct Scobinddeflt *) (xyzxyz)))
-
-extern coresyn mkco_primop PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgco_primop PROTO((struct Sco_primop *));
-
-extern __inline__ stringId *Rgco_primop(struct Sco_primop *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_primop)
- fprintf(stderr,"gco_primop: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_primop);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgco_primop PROTO((struct Sco_primop *));
-#endif /* ! __GNUC__ */
-
-#define gco_primop(xyzxyz) (*Rgco_primop((struct Sco_primop *) (xyzxyz)))
-
-extern coresyn mkco_ccall PROTO((stringId, long, list, ttype));
-#ifdef __GNUC__
-
-stringId *Rgco_ccall PROTO((struct Sco_ccall *));
-
-extern __inline__ stringId *Rgco_ccall(struct Sco_ccall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_ccall)
- fprintf(stderr,"gco_ccall: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_ccall);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgco_ccall PROTO((struct Sco_ccall *));
-#endif /* ! __GNUC__ */
-
-#define gco_ccall(xyzxyz) (*Rgco_ccall((struct Sco_ccall *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgco_ccall_may_gc PROTO((struct Sco_ccall *));
-
-extern __inline__ long *Rgco_ccall_may_gc(struct Sco_ccall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_ccall)
- fprintf(stderr,"gco_ccall_may_gc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_ccall_may_gc);
-}
-#else /* ! __GNUC__ */
-extern long *Rgco_ccall_may_gc PROTO((struct Sco_ccall *));
-#endif /* ! __GNUC__ */
-
-#define gco_ccall_may_gc(xyzxyz) (*Rgco_ccall_may_gc((struct Sco_ccall *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgco_ccall_arg_tys PROTO((struct Sco_ccall *));
-
-extern __inline__ list *Rgco_ccall_arg_tys(struct Sco_ccall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_ccall)
- fprintf(stderr,"gco_ccall_arg_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_ccall_arg_tys);
-}
-#else /* ! __GNUC__ */
-extern list *Rgco_ccall_arg_tys PROTO((struct Sco_ccall *));
-#endif /* ! __GNUC__ */
-
-#define gco_ccall_arg_tys(xyzxyz) (*Rgco_ccall_arg_tys((struct Sco_ccall *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgco_ccall_res_ty PROTO((struct Sco_ccall *));
-
-extern __inline__ ttype *Rgco_ccall_res_ty(struct Sco_ccall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_ccall)
- fprintf(stderr,"gco_ccall_res_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_ccall_res_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgco_ccall_res_ty PROTO((struct Sco_ccall *));
-#endif /* ! __GNUC__ */
-
-#define gco_ccall_res_ty(xyzxyz) (*Rgco_ccall_res_ty((struct Sco_ccall *) (xyzxyz)))
-
-extern coresyn mkco_casm PROTO((literal, long, list, ttype));
-#ifdef __GNUC__
-
-literal *Rgco_casm PROTO((struct Sco_casm *));
-
-extern __inline__ literal *Rgco_casm(struct Sco_casm *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_casm)
- fprintf(stderr,"gco_casm: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_casm);
-}
-#else /* ! __GNUC__ */
-extern literal *Rgco_casm PROTO((struct Sco_casm *));
-#endif /* ! __GNUC__ */
-
-#define gco_casm(xyzxyz) (*Rgco_casm((struct Sco_casm *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rgco_casm_may_gc PROTO((struct Sco_casm *));
-
-extern __inline__ long *Rgco_casm_may_gc(struct Sco_casm *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_casm)
- fprintf(stderr,"gco_casm_may_gc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_casm_may_gc);
-}
-#else /* ! __GNUC__ */
-extern long *Rgco_casm_may_gc PROTO((struct Sco_casm *));
-#endif /* ! __GNUC__ */
-
-#define gco_casm_may_gc(xyzxyz) (*Rgco_casm_may_gc((struct Sco_casm *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgco_casm_arg_tys PROTO((struct Sco_casm *));
-
-extern __inline__ list *Rgco_casm_arg_tys(struct Sco_casm *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_casm)
- fprintf(stderr,"gco_casm_arg_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_casm_arg_tys);
-}
-#else /* ! __GNUC__ */
-extern list *Rgco_casm_arg_tys PROTO((struct Sco_casm *));
-#endif /* ! __GNUC__ */
-
-#define gco_casm_arg_tys(xyzxyz) (*Rgco_casm_arg_tys((struct Sco_casm *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgco_casm_res_ty PROTO((struct Sco_casm *));
-
-extern __inline__ ttype *Rgco_casm_res_ty(struct Sco_casm *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_casm)
- fprintf(stderr,"gco_casm_res_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_casm_res_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgco_casm_res_ty PROTO((struct Sco_casm *));
-#endif /* ! __GNUC__ */
-
-#define gco_casm_res_ty(xyzxyz) (*Rgco_casm_res_ty((struct Sco_casm *) (xyzxyz)))
-
-extern coresyn mkco_preludedictscc PROTO((coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgco_preludedictscc_dupd PROTO((struct Sco_preludedictscc *));
-
-extern __inline__ coresyn *Rgco_preludedictscc_dupd(struct Sco_preludedictscc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_preludedictscc)
- fprintf(stderr,"gco_preludedictscc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_preludedictscc_dupd);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_preludedictscc_dupd PROTO((struct Sco_preludedictscc *));
-#endif /* ! __GNUC__ */
-
-#define gco_preludedictscc_dupd(xyzxyz) (*Rgco_preludedictscc_dupd((struct Sco_preludedictscc *) (xyzxyz)))
-
-extern coresyn mkco_alldictscc PROTO((hstring, hstring, coresyn));
-#ifdef __GNUC__
-
-hstring *Rgco_alldictscc_m PROTO((struct Sco_alldictscc *));
-
-extern __inline__ hstring *Rgco_alldictscc_m(struct Sco_alldictscc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_alldictscc)
- fprintf(stderr,"gco_alldictscc_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_alldictscc_m);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_alldictscc_m PROTO((struct Sco_alldictscc *));
-#endif /* ! __GNUC__ */
-
-#define gco_alldictscc_m(xyzxyz) (*Rgco_alldictscc_m((struct Sco_alldictscc *) (xyzxyz)))
-#ifdef __GNUC__
-
-hstring *Rgco_alldictscc_g PROTO((struct Sco_alldictscc *));
-
-extern __inline__ hstring *Rgco_alldictscc_g(struct Sco_alldictscc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_alldictscc)
- fprintf(stderr,"gco_alldictscc_g: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_alldictscc_g);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_alldictscc_g PROTO((struct Sco_alldictscc *));
-#endif /* ! __GNUC__ */
-
-#define gco_alldictscc_g(xyzxyz) (*Rgco_alldictscc_g((struct Sco_alldictscc *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgco_alldictscc_dupd PROTO((struct Sco_alldictscc *));
-
-extern __inline__ coresyn *Rgco_alldictscc_dupd(struct Sco_alldictscc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_alldictscc)
- fprintf(stderr,"gco_alldictscc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_alldictscc_dupd);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_alldictscc_dupd PROTO((struct Sco_alldictscc *));
-#endif /* ! __GNUC__ */
-
-#define gco_alldictscc_dupd(xyzxyz) (*Rgco_alldictscc_dupd((struct Sco_alldictscc *) (xyzxyz)))
-
-extern coresyn mkco_usercc PROTO((hstring, hstring, hstring, coresyn, coresyn));
-#ifdef __GNUC__
-
-hstring *Rgco_usercc_n PROTO((struct Sco_usercc *));
-
-extern __inline__ hstring *Rgco_usercc_n(struct Sco_usercc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_n: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_n);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_usercc_n PROTO((struct Sco_usercc *));
-#endif /* ! __GNUC__ */
-
-#define gco_usercc_n(xyzxyz) (*Rgco_usercc_n((struct Sco_usercc *) (xyzxyz)))
-#ifdef __GNUC__
-
-hstring *Rgco_usercc_m PROTO((struct Sco_usercc *));
-
-extern __inline__ hstring *Rgco_usercc_m(struct Sco_usercc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_m);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_usercc_m PROTO((struct Sco_usercc *));
-#endif /* ! __GNUC__ */
-
-#define gco_usercc_m(xyzxyz) (*Rgco_usercc_m((struct Sco_usercc *) (xyzxyz)))
-#ifdef __GNUC__
-
-hstring *Rgco_usercc_g PROTO((struct Sco_usercc *));
-
-extern __inline__ hstring *Rgco_usercc_g(struct Sco_usercc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_g: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_g);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_usercc_g PROTO((struct Sco_usercc *));
-#endif /* ! __GNUC__ */
-
-#define gco_usercc_g(xyzxyz) (*Rgco_usercc_g((struct Sco_usercc *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgco_usercc_dupd PROTO((struct Sco_usercc *));
-
-extern __inline__ coresyn *Rgco_usercc_dupd(struct Sco_usercc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_dupd);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_usercc_dupd PROTO((struct Sco_usercc *));
-#endif /* ! __GNUC__ */
-
-#define gco_usercc_dupd(xyzxyz) (*Rgco_usercc_dupd((struct Sco_usercc *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgco_usercc_cafd PROTO((struct Sco_usercc *));
-
-extern __inline__ coresyn *Rgco_usercc_cafd(struct Sco_usercc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_usercc)
- fprintf(stderr,"gco_usercc_cafd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_usercc_cafd);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_usercc_cafd PROTO((struct Sco_usercc *));
-#endif /* ! __GNUC__ */
-
-#define gco_usercc_cafd(xyzxyz) (*Rgco_usercc_cafd((struct Sco_usercc *) (xyzxyz)))
-
-extern coresyn mkco_autocc PROTO((coresyn, hstring, hstring, coresyn, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgco_autocc_i PROTO((struct Sco_autocc *));
-
-extern __inline__ coresyn *Rgco_autocc_i(struct Sco_autocc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_i: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_i);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_autocc_i PROTO((struct Sco_autocc *));
-#endif /* ! __GNUC__ */
-
-#define gco_autocc_i(xyzxyz) (*Rgco_autocc_i((struct Sco_autocc *) (xyzxyz)))
-#ifdef __GNUC__
-
-hstring *Rgco_autocc_m PROTO((struct Sco_autocc *));
-
-extern __inline__ hstring *Rgco_autocc_m(struct Sco_autocc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_m);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_autocc_m PROTO((struct Sco_autocc *));
-#endif /* ! __GNUC__ */
-
-#define gco_autocc_m(xyzxyz) (*Rgco_autocc_m((struct Sco_autocc *) (xyzxyz)))
-#ifdef __GNUC__
-
-hstring *Rgco_autocc_g PROTO((struct Sco_autocc *));
-
-extern __inline__ hstring *Rgco_autocc_g(struct Sco_autocc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_g: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_g);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_autocc_g PROTO((struct Sco_autocc *));
-#endif /* ! __GNUC__ */
-
-#define gco_autocc_g(xyzxyz) (*Rgco_autocc_g((struct Sco_autocc *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgco_autocc_dupd PROTO((struct Sco_autocc *));
-
-extern __inline__ coresyn *Rgco_autocc_dupd(struct Sco_autocc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_dupd);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_autocc_dupd PROTO((struct Sco_autocc *));
-#endif /* ! __GNUC__ */
-
-#define gco_autocc_dupd(xyzxyz) (*Rgco_autocc_dupd((struct Sco_autocc *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgco_autocc_cafd PROTO((struct Sco_autocc *));
-
-extern __inline__ coresyn *Rgco_autocc_cafd(struct Sco_autocc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_autocc)
- fprintf(stderr,"gco_autocc_cafd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_autocc_cafd);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_autocc_cafd PROTO((struct Sco_autocc *));
-#endif /* ! __GNUC__ */
-
-#define gco_autocc_cafd(xyzxyz) (*Rgco_autocc_cafd((struct Sco_autocc *) (xyzxyz)))
-
-extern coresyn mkco_dictcc PROTO((coresyn, hstring, hstring, coresyn, coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgco_dictcc_i PROTO((struct Sco_dictcc *));
-
-extern __inline__ coresyn *Rgco_dictcc_i(struct Sco_dictcc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_i: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_i);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_dictcc_i PROTO((struct Sco_dictcc *));
-#endif /* ! __GNUC__ */
-
-#define gco_dictcc_i(xyzxyz) (*Rgco_dictcc_i((struct Sco_dictcc *) (xyzxyz)))
-#ifdef __GNUC__
-
-hstring *Rgco_dictcc_m PROTO((struct Sco_dictcc *));
-
-extern __inline__ hstring *Rgco_dictcc_m(struct Sco_dictcc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_m);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_dictcc_m PROTO((struct Sco_dictcc *));
-#endif /* ! __GNUC__ */
-
-#define gco_dictcc_m(xyzxyz) (*Rgco_dictcc_m((struct Sco_dictcc *) (xyzxyz)))
-#ifdef __GNUC__
-
-hstring *Rgco_dictcc_g PROTO((struct Sco_dictcc *));
-
-extern __inline__ hstring *Rgco_dictcc_g(struct Sco_dictcc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_g: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_g);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgco_dictcc_g PROTO((struct Sco_dictcc *));
-#endif /* ! __GNUC__ */
-
-#define gco_dictcc_g(xyzxyz) (*Rgco_dictcc_g((struct Sco_dictcc *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgco_dictcc_dupd PROTO((struct Sco_dictcc *));
-
-extern __inline__ coresyn *Rgco_dictcc_dupd(struct Sco_dictcc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_dupd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_dupd);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_dictcc_dupd PROTO((struct Sco_dictcc *));
-#endif /* ! __GNUC__ */
-
-#define gco_dictcc_dupd(xyzxyz) (*Rgco_dictcc_dupd((struct Sco_dictcc *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgco_dictcc_cafd PROTO((struct Sco_dictcc *));
-
-extern __inline__ coresyn *Rgco_dictcc_cafd(struct Sco_dictcc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dictcc)
- fprintf(stderr,"gco_dictcc_cafd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dictcc_cafd);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_dictcc_cafd PROTO((struct Sco_dictcc *));
-#endif /* ! __GNUC__ */
-
-#define gco_dictcc_cafd(xyzxyz) (*Rgco_dictcc_cafd((struct Sco_dictcc *) (xyzxyz)))
-
-extern coresyn mkco_scc_noncaf PROTO((void));
-
-extern coresyn mkco_scc_caf PROTO((void));
-
-extern coresyn mkco_scc_nondupd PROTO((void));
-
-extern coresyn mkco_scc_dupd PROTO((void));
-
-extern coresyn mkco_id PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgco_id PROTO((struct Sco_id *));
-
-extern __inline__ stringId *Rgco_id(struct Sco_id *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_id)
- fprintf(stderr,"gco_id: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_id);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgco_id PROTO((struct Sco_id *));
-#endif /* ! __GNUC__ */
-
-#define gco_id(xyzxyz) (*Rgco_id((struct Sco_id *) (xyzxyz)))
-
-extern coresyn mkco_orig_id PROTO((stringId, stringId));
-#ifdef __GNUC__
-
-stringId *Rgco_orig_id_m PROTO((struct Sco_orig_id *));
-
-extern __inline__ stringId *Rgco_orig_id_m(struct Sco_orig_id *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_orig_id)
- fprintf(stderr,"gco_orig_id_m: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_orig_id_m);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgco_orig_id_m PROTO((struct Sco_orig_id *));
-#endif /* ! __GNUC__ */
-
-#define gco_orig_id_m(xyzxyz) (*Rgco_orig_id_m((struct Sco_orig_id *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rgco_orig_id_n PROTO((struct Sco_orig_id *));
-
-extern __inline__ stringId *Rgco_orig_id_n(struct Sco_orig_id *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_orig_id)
- fprintf(stderr,"gco_orig_id_n: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_orig_id_n);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgco_orig_id_n PROTO((struct Sco_orig_id *));
-#endif /* ! __GNUC__ */
-
-#define gco_orig_id_n(xyzxyz) (*Rgco_orig_id_n((struct Sco_orig_id *) (xyzxyz)))
-
-extern coresyn mkco_sdselid PROTO((unkId, unkId));
-#ifdef __GNUC__
-
-unkId *Rgco_sdselid_c PROTO((struct Sco_sdselid *));
-
-extern __inline__ unkId *Rgco_sdselid_c(struct Sco_sdselid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_sdselid)
- fprintf(stderr,"gco_sdselid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_sdselid_c);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_sdselid_c PROTO((struct Sco_sdselid *));
-#endif /* ! __GNUC__ */
-
-#define gco_sdselid_c(xyzxyz) (*Rgco_sdselid_c((struct Sco_sdselid *) (xyzxyz)))
-#ifdef __GNUC__
-
-unkId *Rgco_sdselid_sc PROTO((struct Sco_sdselid *));
-
-extern __inline__ unkId *Rgco_sdselid_sc(struct Sco_sdselid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_sdselid)
- fprintf(stderr,"gco_sdselid_sc: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_sdselid_sc);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_sdselid_sc PROTO((struct Sco_sdselid *));
-#endif /* ! __GNUC__ */
-
-#define gco_sdselid_sc(xyzxyz) (*Rgco_sdselid_sc((struct Sco_sdselid *) (xyzxyz)))
-
-extern coresyn mkco_classopid PROTO((unkId, unkId));
-#ifdef __GNUC__
-
-unkId *Rgco_classopid_c PROTO((struct Sco_classopid *));
-
-extern __inline__ unkId *Rgco_classopid_c(struct Sco_classopid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_classopid)
- fprintf(stderr,"gco_classopid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_classopid_c);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_classopid_c PROTO((struct Sco_classopid *));
-#endif /* ! __GNUC__ */
-
-#define gco_classopid_c(xyzxyz) (*Rgco_classopid_c((struct Sco_classopid *) (xyzxyz)))
-#ifdef __GNUC__
-
-unkId *Rgco_classopid_o PROTO((struct Sco_classopid *));
-
-extern __inline__ unkId *Rgco_classopid_o(struct Sco_classopid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_classopid)
- fprintf(stderr,"gco_classopid_o: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_classopid_o);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_classopid_o PROTO((struct Sco_classopid *));
-#endif /* ! __GNUC__ */
-
-#define gco_classopid_o(xyzxyz) (*Rgco_classopid_o((struct Sco_classopid *) (xyzxyz)))
-
-extern coresyn mkco_defmid PROTO((unkId, unkId));
-#ifdef __GNUC__
-
-unkId *Rgco_defmid_c PROTO((struct Sco_defmid *));
-
-extern __inline__ unkId *Rgco_defmid_c(struct Sco_defmid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_defmid)
- fprintf(stderr,"gco_defmid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_defmid_c);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_defmid_c PROTO((struct Sco_defmid *));
-#endif /* ! __GNUC__ */
-
-#define gco_defmid_c(xyzxyz) (*Rgco_defmid_c((struct Sco_defmid *) (xyzxyz)))
-#ifdef __GNUC__
-
-unkId *Rgco_defmid_op PROTO((struct Sco_defmid *));
-
-extern __inline__ unkId *Rgco_defmid_op(struct Sco_defmid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_defmid)
- fprintf(stderr,"gco_defmid_op: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_defmid_op);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_defmid_op PROTO((struct Sco_defmid *));
-#endif /* ! __GNUC__ */
-
-#define gco_defmid_op(xyzxyz) (*Rgco_defmid_op((struct Sco_defmid *) (xyzxyz)))
-
-extern coresyn mkco_dfunid PROTO((unkId, ttype));
-#ifdef __GNUC__
-
-unkId *Rgco_dfunid_c PROTO((struct Sco_dfunid *));
-
-extern __inline__ unkId *Rgco_dfunid_c(struct Sco_dfunid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dfunid)
- fprintf(stderr,"gco_dfunid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dfunid_c);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_dfunid_c PROTO((struct Sco_dfunid *));
-#endif /* ! __GNUC__ */
-
-#define gco_dfunid_c(xyzxyz) (*Rgco_dfunid_c((struct Sco_dfunid *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgco_dfunid_ty PROTO((struct Sco_dfunid *));
-
-extern __inline__ ttype *Rgco_dfunid_ty(struct Sco_dfunid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_dfunid)
- fprintf(stderr,"gco_dfunid_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_dfunid_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgco_dfunid_ty PROTO((struct Sco_dfunid *));
-#endif /* ! __GNUC__ */
-
-#define gco_dfunid_ty(xyzxyz) (*Rgco_dfunid_ty((struct Sco_dfunid *) (xyzxyz)))
-
-extern coresyn mkco_constmid PROTO((unkId, unkId, ttype));
-#ifdef __GNUC__
-
-unkId *Rgco_constmid_c PROTO((struct Sco_constmid *));
-
-extern __inline__ unkId *Rgco_constmid_c(struct Sco_constmid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_constmid)
- fprintf(stderr,"gco_constmid_c: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_constmid_c);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_constmid_c PROTO((struct Sco_constmid *));
-#endif /* ! __GNUC__ */
-
-#define gco_constmid_c(xyzxyz) (*Rgco_constmid_c((struct Sco_constmid *) (xyzxyz)))
-#ifdef __GNUC__
-
-unkId *Rgco_constmid_op PROTO((struct Sco_constmid *));
-
-extern __inline__ unkId *Rgco_constmid_op(struct Sco_constmid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_constmid)
- fprintf(stderr,"gco_constmid_op: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_constmid_op);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgco_constmid_op PROTO((struct Sco_constmid *));
-#endif /* ! __GNUC__ */
-
-#define gco_constmid_op(xyzxyz) (*Rgco_constmid_op((struct Sco_constmid *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgco_constmid_ty PROTO((struct Sco_constmid *));
-
-extern __inline__ ttype *Rgco_constmid_ty(struct Sco_constmid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_constmid)
- fprintf(stderr,"gco_constmid_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_constmid_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgco_constmid_ty PROTO((struct Sco_constmid *));
-#endif /* ! __GNUC__ */
-
-#define gco_constmid_ty(xyzxyz) (*Rgco_constmid_ty((struct Sco_constmid *) (xyzxyz)))
-
-extern coresyn mkco_specid PROTO((coresyn, list));
-#ifdef __GNUC__
-
-coresyn *Rgco_specid_un PROTO((struct Sco_specid *));
-
-extern __inline__ coresyn *Rgco_specid_un(struct Sco_specid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_specid)
- fprintf(stderr,"gco_specid_un: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_specid_un);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_specid_un PROTO((struct Sco_specid *));
-#endif /* ! __GNUC__ */
-
-#define gco_specid_un(xyzxyz) (*Rgco_specid_un((struct Sco_specid *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgco_specid_tys PROTO((struct Sco_specid *));
-
-extern __inline__ list *Rgco_specid_tys(struct Sco_specid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_specid)
- fprintf(stderr,"gco_specid_tys: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_specid_tys);
-}
-#else /* ! __GNUC__ */
-extern list *Rgco_specid_tys PROTO((struct Sco_specid *));
-#endif /* ! __GNUC__ */
-
-#define gco_specid_tys(xyzxyz) (*Rgco_specid_tys((struct Sco_specid *) (xyzxyz)))
-
-extern coresyn mkco_wrkrid PROTO((coresyn));
-#ifdef __GNUC__
-
-coresyn *Rgco_wrkrid_un PROTO((struct Sco_wrkrid *));
-
-extern __inline__ coresyn *Rgco_wrkrid_un(struct Sco_wrkrid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != co_wrkrid)
- fprintf(stderr,"gco_wrkrid_un: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgco_wrkrid_un);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgco_wrkrid_un PROTO((struct Sco_wrkrid *));
-#endif /* ! __GNUC__ */
-
-#define gco_wrkrid_un(xyzxyz) (*Rgco_wrkrid_un((struct Sco_wrkrid *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_coresyn where
-import UgenUtil
-import Util
-
-import U_list
-import U_literal
-import U_ttype
-%}}
-type coresyn;
- /* binders: simple Id, plus a type */
- cobinder : < gcobinder_v : unkId;
- gcobinder_ty : ttype; >;
-
- /* atoms */
- colit : < gcolit : literal; >;
- colocal : < gcolocal_v : coresyn; >;
-
- cononrec : <gcononrec_b : coresyn;
- gcononrec_rhs : coresyn; >;
- corec : <gcorec : list; >;
- corec_pair: <gcorec_b : coresyn;
- gcorec_rhs : coresyn; >;
-
- covar : < gcovar : coresyn; >;
- coliteral :< gcoliteral : literal; >;
- cocon : < gcocon_con : coresyn;
- gcocon_tys : list;
- gcocon_args : list; >;
- coprim : < gcoprim_op : coresyn; /* primop or something */
- gcoprim_tys : list;
- gcoprim_args: list; >;
- colam : < gcolam_vars : list;
- gcolam_body : coresyn; >;
- cotylam : < gcotylam_tvs: list;
- gcotylam_body : coresyn; >;
- coapp : < gcoapp_fun : coresyn;
- gcoapp_args : list; >;
- cotyapp : < gcotyapp_e : coresyn;
- gcotyapp_t : ttype; >;
- cocase : < gcocase_s : coresyn;
- gcocase_alts : coresyn; >;
- colet : < gcolet_bind : coresyn;
- gcolet_body : coresyn; >;
- coscc : < gcoscc_scc : coresyn;
- gcoscc_body : coresyn; >;
-
- coalg_alts : < gcoalg_alts : list;
- gcoalg_deflt : coresyn; >;
- coalg_alt : < gcoalg_con : coresyn;
- gcoalg_bs : list;
- gcoalg_rhs : coresyn; >;
-
- coprim_alts : < gcoprim_alts : list;
- gcoprim_deflt : coresyn; >;
- coprim_alt : < gcoprim_lit : literal;
- gcoprim_rhs : coresyn; >;
-
- conodeflt : < >;
- cobinddeflt : < gcobinddeflt_v : coresyn;
- gcobinddeflt_rhs : coresyn; >;
-
- co_primop : < gco_primop : stringId;>;
- co_ccall : < gco_ccall : stringId;
- gco_ccall_may_gc : long;
- gco_ccall_arg_tys : list;
- gco_ccall_res_ty : ttype; >;
- co_casm : < gco_casm : literal;
- gco_casm_may_gc : long;
- gco_casm_arg_tys : list;
- gco_casm_res_ty : ttype; >;
-
- /* various flavours of cost-centres */
- co_preludedictscc : < gco_preludedictscc_dupd : coresyn; >;
- co_alldictscc : < gco_alldictscc_m : hstring;
- gco_alldictscc_g : hstring;
- gco_alldictscc_dupd : coresyn; >;
- co_usercc : < gco_usercc_n : hstring;
- gco_usercc_m : hstring;
- gco_usercc_g : hstring;
- gco_usercc_dupd : coresyn;
- gco_usercc_cafd : coresyn; >;
- co_autocc : < gco_autocc_i : coresyn;
- gco_autocc_m : hstring;
- gco_autocc_g : hstring;
- gco_autocc_dupd : coresyn;
- gco_autocc_cafd : coresyn; >;
- co_dictcc : < gco_dictcc_i : coresyn;
- gco_dictcc_m : hstring;
- gco_dictcc_g : hstring;
- gco_dictcc_dupd : coresyn;
- gco_dictcc_cafd : coresyn; >;
-
- co_scc_noncaf : < >;
- co_scc_caf : < >;
- co_scc_nondupd : < >;
- co_scc_dupd : < >;
-
- /* various flavours of Ids */
- co_id : < gco_id : stringId; >;
- co_orig_id : < gco_orig_id_m : stringId;
- gco_orig_id_n : stringId; >;
- co_sdselid : < gco_sdselid_c : unkId;
- gco_sdselid_sc : unkId; >;
- co_classopid : < gco_classopid_c : unkId;
- gco_classopid_o : unkId; >;
- co_defmid : < gco_defmid_c : unkId;
- gco_defmid_op : unkId; >;
- co_dfunid : < gco_dfunid_c : unkId;
- gco_dfunid_ty : ttype; >;
- co_constmid : < gco_constmid_c : unkId;
- gco_constmid_op : unkId;
- gco_constmid_ty : ttype; >;
- co_specid : < gco_specid_un : coresyn;
- gco_specid_tys : list; >;
- co_wrkrid : < gco_wrkrid_un : coresyn; >;
-end;
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/entidt.h"
-
-Tentidt tentidt(t)
- entidt t;
-{
- return(t -> tag);
-}
-
-
-/************** entid ******************/
-
-entidt mkentid(PPgentid)
- stringId PPgentid;
-{
- register struct Sentid *pp =
- (struct Sentid *) malloc(sizeof(struct Sentid));
- pp -> tag = entid;
- pp -> Xgentid = PPgentid;
- return((entidt)pp);
-}
-
-stringId *Rgentid(t)
- struct Sentid *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != entid)
- fprintf(stderr,"gentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgentid);
-}
-
-/************** enttype ******************/
-
-entidt mkenttype(PPgitentid)
- stringId PPgitentid;
-{
- register struct Senttype *pp =
- (struct Senttype *) malloc(sizeof(struct Senttype));
- pp -> tag = enttype;
- pp -> Xgitentid = PPgitentid;
- return((entidt)pp);
-}
-
-stringId *Rgitentid(t)
- struct Senttype *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != enttype)
- fprintf(stderr,"gitentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgitentid);
-}
-
-/************** enttypeall ******************/
-
-entidt mkenttypeall(PPgatentid)
- stringId PPgatentid;
-{
- register struct Senttypeall *pp =
- (struct Senttypeall *) malloc(sizeof(struct Senttypeall));
- pp -> tag = enttypeall;
- pp -> Xgatentid = PPgatentid;
- return((entidt)pp);
-}
-
-stringId *Rgatentid(t)
- struct Senttypeall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != enttypeall)
- fprintf(stderr,"gatentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgatentid);
-}
-
-/************** enttypecons ******************/
-
-entidt mkenttypecons(PPgctentid, PPgctentcons)
- stringId PPgctentid;
- list PPgctentcons;
-{
- register struct Senttypecons *pp =
- (struct Senttypecons *) malloc(sizeof(struct Senttypecons));
- pp -> tag = enttypecons;
- pp -> Xgctentid = PPgctentid;
- pp -> Xgctentcons = PPgctentcons;
- return((entidt)pp);
-}
-
-stringId *Rgctentid(t)
- struct Senttypecons *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != enttypecons)
- fprintf(stderr,"gctentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgctentid);
-}
-
-list *Rgctentcons(t)
- struct Senttypecons *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != enttypecons)
- fprintf(stderr,"gctentcons: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgctentcons);
-}
-
-/************** entclass ******************/
-
-entidt mkentclass(PPgcentid, PPgcentops)
- stringId PPgcentid;
- list PPgcentops;
-{
- register struct Sentclass *pp =
- (struct Sentclass *) malloc(sizeof(struct Sentclass));
- pp -> tag = entclass;
- pp -> Xgcentid = PPgcentid;
- pp -> Xgcentops = PPgcentops;
- return((entidt)pp);
-}
-
-stringId *Rgcentid(t)
- struct Sentclass *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != entclass)
- fprintf(stderr,"gcentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcentid);
-}
-
-list *Rgcentops(t)
- struct Sentclass *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != entclass)
- fprintf(stderr,"gcentops: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcentops);
-}
-
-/************** entmod ******************/
-
-entidt mkentmod(PPgmentid)
- stringId PPgmentid;
-{
- register struct Sentmod *pp =
- (struct Sentmod *) malloc(sizeof(struct Sentmod));
- pp -> tag = entmod;
- pp -> Xgmentid = PPgmentid;
- return((entidt)pp);
-}
-
-stringId *Rgmentid(t)
- struct Sentmod *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != entmod)
- fprintf(stderr,"gmentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmentid);
-}
+++ /dev/null
-#ifndef entidt_defined
-#define entidt_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- entid,
- enttype,
- enttypeall,
- enttypecons,
- entclass,
- entmod
-} Tentidt;
-
-typedef struct { Tentidt tag; } *entidt;
-
-#ifdef __GNUC__
-Tentidt tentidt(entidt t);
-extern __inline__ Tentidt tentidt(entidt t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tentidt tentidt PROTO((entidt));
-#endif /* ! __GNUC__ */
-
-struct Sentid {
- Tentidt tag;
- stringId Xgentid;
-};
-
-struct Senttype {
- Tentidt tag;
- stringId Xgitentid;
-};
-
-struct Senttypeall {
- Tentidt tag;
- stringId Xgatentid;
-};
-
-struct Senttypecons {
- Tentidt tag;
- stringId Xgctentid;
- list Xgctentcons;
-};
-
-struct Sentclass {
- Tentidt tag;
- stringId Xgcentid;
- list Xgcentops;
-};
-
-struct Sentmod {
- Tentidt tag;
- stringId Xgmentid;
-};
-
-extern entidt mkentid PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgentid PROTO((struct Sentid *));
-
-extern __inline__ stringId *Rgentid(struct Sentid *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != entid)
- fprintf(stderr,"gentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgentid);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgentid PROTO((struct Sentid *));
-#endif /* ! __GNUC__ */
-
-#define gentid(xyzxyz) (*Rgentid((struct Sentid *) (xyzxyz)))
-
-extern entidt mkenttype PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgitentid PROTO((struct Senttype *));
-
-extern __inline__ stringId *Rgitentid(struct Senttype *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != enttype)
- fprintf(stderr,"gitentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgitentid);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgitentid PROTO((struct Senttype *));
-#endif /* ! __GNUC__ */
-
-#define gitentid(xyzxyz) (*Rgitentid((struct Senttype *) (xyzxyz)))
-
-extern entidt mkenttypeall PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgatentid PROTO((struct Senttypeall *));
-
-extern __inline__ stringId *Rgatentid(struct Senttypeall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != enttypeall)
- fprintf(stderr,"gatentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgatentid);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgatentid PROTO((struct Senttypeall *));
-#endif /* ! __GNUC__ */
-
-#define gatentid(xyzxyz) (*Rgatentid((struct Senttypeall *) (xyzxyz)))
-
-extern entidt mkenttypecons PROTO((stringId, list));
-#ifdef __GNUC__
-
-stringId *Rgctentid PROTO((struct Senttypecons *));
-
-extern __inline__ stringId *Rgctentid(struct Senttypecons *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != enttypecons)
- fprintf(stderr,"gctentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgctentid);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgctentid PROTO((struct Senttypecons *));
-#endif /* ! __GNUC__ */
-
-#define gctentid(xyzxyz) (*Rgctentid((struct Senttypecons *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgctentcons PROTO((struct Senttypecons *));
-
-extern __inline__ list *Rgctentcons(struct Senttypecons *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != enttypecons)
- fprintf(stderr,"gctentcons: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgctentcons);
-}
-#else /* ! __GNUC__ */
-extern list *Rgctentcons PROTO((struct Senttypecons *));
-#endif /* ! __GNUC__ */
-
-#define gctentcons(xyzxyz) (*Rgctentcons((struct Senttypecons *) (xyzxyz)))
-
-extern entidt mkentclass PROTO((stringId, list));
-#ifdef __GNUC__
-
-stringId *Rgcentid PROTO((struct Sentclass *));
-
-extern __inline__ stringId *Rgcentid(struct Sentclass *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != entclass)
- fprintf(stderr,"gcentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcentid);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgcentid PROTO((struct Sentclass *));
-#endif /* ! __GNUC__ */
-
-#define gcentid(xyzxyz) (*Rgcentid((struct Sentclass *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcentops PROTO((struct Sentclass *));
-
-extern __inline__ list *Rgcentops(struct Sentclass *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != entclass)
- fprintf(stderr,"gcentops: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcentops);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcentops PROTO((struct Sentclass *));
-#endif /* ! __GNUC__ */
-
-#define gcentops(xyzxyz) (*Rgcentops((struct Sentclass *) (xyzxyz)))
-
-extern entidt mkentmod PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgmentid PROTO((struct Sentmod *));
-
-extern __inline__ stringId *Rgmentid(struct Sentmod *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != entmod)
- fprintf(stderr,"gmentid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgmentid);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgmentid PROTO((struct Sentmod *));
-#endif /* ! __GNUC__ */
-
-#define gmentid(xyzxyz) (*Rgmentid((struct Sentmod *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_entidt where
-import UgenUtil
-import Util
-
-import U_list
-%}}
-type entidt;
- entid : < gentid : stringId; >;
- enttype : < gitentid : stringId; >;
- enttypeall : < gatentid : stringId; >;
- enttypecons : < gctentid : stringId;
- gctentcons : list; >;
- entclass : < gcentid : stringId;
- gcentops : list; >;
- entmod : < gmentid : stringId; >;
-end;
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/finfot.h"
-
-Tfinfot tfinfot(t)
- finfot t;
-{
- return(t -> tag);
-}
-
-
-/************** finfo ******************/
-
-finfot mkfinfo(PPfi1, PPfi2)
- stringId PPfi1;
- stringId PPfi2;
-{
- register struct Sfinfo *pp =
- (struct Sfinfo *) malloc(sizeof(struct Sfinfo));
- pp -> tag = finfo;
- pp -> Xfi1 = PPfi1;
- pp -> Xfi2 = PPfi2;
- return((finfot)pp);
-}
-
-stringId *Rfi1(t)
- struct Sfinfo *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != finfo)
- fprintf(stderr,"fi1: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xfi1);
-}
-
-stringId *Rfi2(t)
- struct Sfinfo *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != finfo)
- fprintf(stderr,"fi2: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xfi2);
-}
+++ /dev/null
-#ifndef finfot_defined
-#define finfot_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- finfo
-} Tfinfot;
-
-typedef struct { Tfinfot tag; } *finfot;
-
-#ifdef __GNUC__
-Tfinfot tfinfot(finfot t);
-extern __inline__ Tfinfot tfinfot(finfot t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tfinfot tfinfot PROTO((finfot));
-#endif /* ! __GNUC__ */
-
-struct Sfinfo {
- Tfinfot tag;
- stringId Xfi1;
- stringId Xfi2;
-};
-
-extern finfot mkfinfo PROTO((stringId, stringId));
-#ifdef __GNUC__
-
-stringId *Rfi1 PROTO((struct Sfinfo *));
-
-extern __inline__ stringId *Rfi1(struct Sfinfo *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != finfo)
- fprintf(stderr,"fi1: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xfi1);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rfi1 PROTO((struct Sfinfo *));
-#endif /* ! __GNUC__ */
-
-#define fi1(xyzxyz) (*Rfi1((struct Sfinfo *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rfi2 PROTO((struct Sfinfo *));
-
-extern __inline__ stringId *Rfi2(struct Sfinfo *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != finfo)
- fprintf(stderr,"fi2: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xfi2);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rfi2 PROTO((struct Sfinfo *));
-#endif /* ! __GNUC__ */
-
-#define fi2(xyzxyz) (*Rfi2((struct Sfinfo *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_finfot where
-import UgenUtil
-import Util
-%}}
-type finfot;
-/*OLD:95/08: nofinfo : < >; */
- finfo : < fi1: stringId; fi2: stringId; >;
-end;
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/hpragma.h"
-
-Thpragma thpragma(t)
- hpragma t;
-{
- return(t -> tag);
-}
-
-
-/************** no_pragma ******************/
-
-hpragma mkno_pragma(void)
-{
- register struct Sno_pragma *pp =
- (struct Sno_pragma *) malloc(sizeof(struct Sno_pragma));
- pp -> tag = no_pragma;
- return((hpragma)pp);
-}
-
-/************** idata_pragma ******************/
-
-hpragma mkidata_pragma(PPgprag_data_constrs, PPgprag_data_specs)
- list PPgprag_data_constrs;
- list PPgprag_data_specs;
-{
- register struct Sidata_pragma *pp =
- (struct Sidata_pragma *) malloc(sizeof(struct Sidata_pragma));
- pp -> tag = idata_pragma;
- pp -> Xgprag_data_constrs = PPgprag_data_constrs;
- pp -> Xgprag_data_specs = PPgprag_data_specs;
- return((hpragma)pp);
-}
-
-list *Rgprag_data_constrs(t)
- struct Sidata_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != idata_pragma)
- fprintf(stderr,"gprag_data_constrs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_data_constrs);
-}
-
-list *Rgprag_data_specs(t)
- struct Sidata_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != idata_pragma)
- fprintf(stderr,"gprag_data_specs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_data_specs);
-}
-
-/************** itype_pragma ******************/
-
-hpragma mkitype_pragma(void)
-{
- register struct Sitype_pragma *pp =
- (struct Sitype_pragma *) malloc(sizeof(struct Sitype_pragma));
- pp -> tag = itype_pragma;
- return((hpragma)pp);
-}
-
-/************** iclas_pragma ******************/
-
-hpragma mkiclas_pragma(PPgprag_clas)
- list PPgprag_clas;
-{
- register struct Siclas_pragma *pp =
- (struct Siclas_pragma *) malloc(sizeof(struct Siclas_pragma));
- pp -> tag = iclas_pragma;
- pp -> Xgprag_clas = PPgprag_clas;
- return((hpragma)pp);
-}
-
-list *Rgprag_clas(t)
- struct Siclas_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iclas_pragma)
- fprintf(stderr,"gprag_clas: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_clas);
-}
-
-/************** iclasop_pragma ******************/
-
-hpragma mkiclasop_pragma(PPgprag_dsel, PPgprag_defm)
- hpragma PPgprag_dsel;
- hpragma PPgprag_defm;
-{
- register struct Siclasop_pragma *pp =
- (struct Siclasop_pragma *) malloc(sizeof(struct Siclasop_pragma));
- pp -> tag = iclasop_pragma;
- pp -> Xgprag_dsel = PPgprag_dsel;
- pp -> Xgprag_defm = PPgprag_defm;
- return((hpragma)pp);
-}
-
-hpragma *Rgprag_dsel(t)
- struct Siclasop_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iclasop_pragma)
- fprintf(stderr,"gprag_dsel: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_dsel);
-}
-
-hpragma *Rgprag_defm(t)
- struct Siclasop_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iclasop_pragma)
- fprintf(stderr,"gprag_defm: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_defm);
-}
-
-/************** iinst_simpl_pragma ******************/
-
-hpragma mkiinst_simpl_pragma(PPgprag_imod_simpl, PPgprag_dfun_simpl)
- stringId PPgprag_imod_simpl;
- hpragma PPgprag_dfun_simpl;
-{
- register struct Siinst_simpl_pragma *pp =
- (struct Siinst_simpl_pragma *) malloc(sizeof(struct Siinst_simpl_pragma));
- pp -> tag = iinst_simpl_pragma;
- pp -> Xgprag_imod_simpl = PPgprag_imod_simpl;
- pp -> Xgprag_dfun_simpl = PPgprag_dfun_simpl;
- return((hpragma)pp);
-}
-
-stringId *Rgprag_imod_simpl(t)
- struct Siinst_simpl_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_simpl_pragma)
- fprintf(stderr,"gprag_imod_simpl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_imod_simpl);
-}
-
-hpragma *Rgprag_dfun_simpl(t)
- struct Siinst_simpl_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_simpl_pragma)
- fprintf(stderr,"gprag_dfun_simpl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_dfun_simpl);
-}
-
-/************** iinst_const_pragma ******************/
-
-hpragma mkiinst_const_pragma(PPgprag_imod_const, PPgprag_dfun_const, PPgprag_constms)
- stringId PPgprag_imod_const;
- hpragma PPgprag_dfun_const;
- list PPgprag_constms;
-{
- register struct Siinst_const_pragma *pp =
- (struct Siinst_const_pragma *) malloc(sizeof(struct Siinst_const_pragma));
- pp -> tag = iinst_const_pragma;
- pp -> Xgprag_imod_const = PPgprag_imod_const;
- pp -> Xgprag_dfun_const = PPgprag_dfun_const;
- pp -> Xgprag_constms = PPgprag_constms;
- return((hpragma)pp);
-}
-
-stringId *Rgprag_imod_const(t)
- struct Siinst_const_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_const_pragma)
- fprintf(stderr,"gprag_imod_const: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_imod_const);
-}
-
-hpragma *Rgprag_dfun_const(t)
- struct Siinst_const_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_const_pragma)
- fprintf(stderr,"gprag_dfun_const: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_dfun_const);
-}
-
-list *Rgprag_constms(t)
- struct Siinst_const_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_const_pragma)
- fprintf(stderr,"gprag_constms: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_constms);
-}
-
-/************** igen_pragma ******************/
-
-hpragma mkigen_pragma(PPgprag_arity, PPgprag_update, PPgprag_deforest, PPgprag_strictness, PPgprag_unfolding, PPgprag_specs)
- hpragma PPgprag_arity;
- hpragma PPgprag_update;
- hpragma PPgprag_deforest;
- hpragma PPgprag_strictness;
- hpragma PPgprag_unfolding;
- list PPgprag_specs;
-{
- register struct Sigen_pragma *pp =
- (struct Sigen_pragma *) malloc(sizeof(struct Sigen_pragma));
- pp -> tag = igen_pragma;
- pp -> Xgprag_arity = PPgprag_arity;
- pp -> Xgprag_update = PPgprag_update;
- pp -> Xgprag_deforest = PPgprag_deforest;
- pp -> Xgprag_strictness = PPgprag_strictness;
- pp -> Xgprag_unfolding = PPgprag_unfolding;
- pp -> Xgprag_specs = PPgprag_specs;
- return((hpragma)pp);
-}
-
-hpragma *Rgprag_arity(t)
- struct Sigen_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_arity: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_arity);
-}
-
-hpragma *Rgprag_update(t)
- struct Sigen_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_update: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_update);
-}
-
-hpragma *Rgprag_deforest(t)
- struct Sigen_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_deforest: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_deforest);
-}
-
-hpragma *Rgprag_strictness(t)
- struct Sigen_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_strictness: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_strictness);
-}
-
-hpragma *Rgprag_unfolding(t)
- struct Sigen_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_unfolding: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfolding);
-}
-
-list *Rgprag_specs(t)
- struct Sigen_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_specs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_specs);
-}
-
-/************** iarity_pragma ******************/
-
-hpragma mkiarity_pragma(PPgprag_arity_val)
- numId PPgprag_arity_val;
-{
- register struct Siarity_pragma *pp =
- (struct Siarity_pragma *) malloc(sizeof(struct Siarity_pragma));
- pp -> tag = iarity_pragma;
- pp -> Xgprag_arity_val = PPgprag_arity_val;
- return((hpragma)pp);
-}
-
-numId *Rgprag_arity_val(t)
- struct Siarity_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iarity_pragma)
- fprintf(stderr,"gprag_arity_val: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_arity_val);
-}
-
-/************** iupdate_pragma ******************/
-
-hpragma mkiupdate_pragma(PPgprag_update_val)
- stringId PPgprag_update_val;
-{
- register struct Siupdate_pragma *pp =
- (struct Siupdate_pragma *) malloc(sizeof(struct Siupdate_pragma));
- pp -> tag = iupdate_pragma;
- pp -> Xgprag_update_val = PPgprag_update_val;
- return((hpragma)pp);
-}
-
-stringId *Rgprag_update_val(t)
- struct Siupdate_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iupdate_pragma)
- fprintf(stderr,"gprag_update_val: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_update_val);
-}
-
-/************** ideforest_pragma ******************/
-
-hpragma mkideforest_pragma(void)
-{
- register struct Sideforest_pragma *pp =
- (struct Sideforest_pragma *) malloc(sizeof(struct Sideforest_pragma));
- pp -> tag = ideforest_pragma;
- return((hpragma)pp);
-}
-
-/************** istrictness_pragma ******************/
-
-hpragma mkistrictness_pragma(PPgprag_strict_spec, PPgprag_strict_wrkr)
- hstring PPgprag_strict_spec;
- hpragma PPgprag_strict_wrkr;
-{
- register struct Sistrictness_pragma *pp =
- (struct Sistrictness_pragma *) malloc(sizeof(struct Sistrictness_pragma));
- pp -> tag = istrictness_pragma;
- pp -> Xgprag_strict_spec = PPgprag_strict_spec;
- pp -> Xgprag_strict_wrkr = PPgprag_strict_wrkr;
- return((hpragma)pp);
-}
-
-hstring *Rgprag_strict_spec(t)
- struct Sistrictness_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != istrictness_pragma)
- fprintf(stderr,"gprag_strict_spec: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_strict_spec);
-}
-
-hpragma *Rgprag_strict_wrkr(t)
- struct Sistrictness_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != istrictness_pragma)
- fprintf(stderr,"gprag_strict_wrkr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_strict_wrkr);
-}
-
-/************** imagic_unfolding_pragma ******************/
-
-hpragma mkimagic_unfolding_pragma(PPgprag_magic_str)
- stringId PPgprag_magic_str;
-{
- register struct Simagic_unfolding_pragma *pp =
- (struct Simagic_unfolding_pragma *) malloc(sizeof(struct Simagic_unfolding_pragma));
- pp -> tag = imagic_unfolding_pragma;
- pp -> Xgprag_magic_str = PPgprag_magic_str;
- return((hpragma)pp);
-}
-
-stringId *Rgprag_magic_str(t)
- struct Simagic_unfolding_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != imagic_unfolding_pragma)
- fprintf(stderr,"gprag_magic_str: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_magic_str);
-}
-
-/************** iunfolding_pragma ******************/
-
-hpragma mkiunfolding_pragma(PPgprag_unfold_guide, PPgprag_unfold_core)
- hpragma PPgprag_unfold_guide;
- coresyn PPgprag_unfold_core;
-{
- register struct Siunfolding_pragma *pp =
- (struct Siunfolding_pragma *) malloc(sizeof(struct Siunfolding_pragma));
- pp -> tag = iunfolding_pragma;
- pp -> Xgprag_unfold_guide = PPgprag_unfold_guide;
- pp -> Xgprag_unfold_core = PPgprag_unfold_core;
- return((hpragma)pp);
-}
-
-hpragma *Rgprag_unfold_guide(t)
- struct Siunfolding_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfolding_pragma)
- fprintf(stderr,"gprag_unfold_guide: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_guide);
-}
-
-coresyn *Rgprag_unfold_core(t)
- struct Siunfolding_pragma *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfolding_pragma)
- fprintf(stderr,"gprag_unfold_core: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_core);
-}
-
-/************** iunfold_always ******************/
-
-hpragma mkiunfold_always(void)
-{
- register struct Siunfold_always *pp =
- (struct Siunfold_always *) malloc(sizeof(struct Siunfold_always));
- pp -> tag = iunfold_always;
- return((hpragma)pp);
-}
-
-/************** iunfold_if_args ******************/
-
-hpragma mkiunfold_if_args(PPgprag_unfold_if_t_args, PPgprag_unfold_if_v_args, PPgprag_unfold_if_con_args, PPgprag_unfold_if_size)
- numId PPgprag_unfold_if_t_args;
- numId PPgprag_unfold_if_v_args;
- stringId PPgprag_unfold_if_con_args;
- numId PPgprag_unfold_if_size;
-{
- register struct Siunfold_if_args *pp =
- (struct Siunfold_if_args *) malloc(sizeof(struct Siunfold_if_args));
- pp -> tag = iunfold_if_args;
- pp -> Xgprag_unfold_if_t_args = PPgprag_unfold_if_t_args;
- pp -> Xgprag_unfold_if_v_args = PPgprag_unfold_if_v_args;
- pp -> Xgprag_unfold_if_con_args = PPgprag_unfold_if_con_args;
- pp -> Xgprag_unfold_if_size = PPgprag_unfold_if_size;
- return((hpragma)pp);
-}
-
-numId *Rgprag_unfold_if_t_args(t)
- struct Siunfold_if_args *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfold_if_args)
- fprintf(stderr,"gprag_unfold_if_t_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_if_t_args);
-}
-
-numId *Rgprag_unfold_if_v_args(t)
- struct Siunfold_if_args *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfold_if_args)
- fprintf(stderr,"gprag_unfold_if_v_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_if_v_args);
-}
-
-stringId *Rgprag_unfold_if_con_args(t)
- struct Siunfold_if_args *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfold_if_args)
- fprintf(stderr,"gprag_unfold_if_con_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_if_con_args);
-}
-
-numId *Rgprag_unfold_if_size(t)
- struct Siunfold_if_args *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfold_if_args)
- fprintf(stderr,"gprag_unfold_if_size: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_if_size);
-}
-
-/************** iname_pragma_pr ******************/
-
-hpragma mkiname_pragma_pr(PPgprag_name_pr1, PPgprag_name_pr2)
- unkId PPgprag_name_pr1;
- hpragma PPgprag_name_pr2;
-{
- register struct Siname_pragma_pr *pp =
- (struct Siname_pragma_pr *) malloc(sizeof(struct Siname_pragma_pr));
- pp -> tag = iname_pragma_pr;
- pp -> Xgprag_name_pr1 = PPgprag_name_pr1;
- pp -> Xgprag_name_pr2 = PPgprag_name_pr2;
- return((hpragma)pp);
-}
-
-unkId *Rgprag_name_pr1(t)
- struct Siname_pragma_pr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iname_pragma_pr)
- fprintf(stderr,"gprag_name_pr1: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_name_pr1);
-}
-
-hpragma *Rgprag_name_pr2(t)
- struct Siname_pragma_pr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iname_pragma_pr)
- fprintf(stderr,"gprag_name_pr2: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_name_pr2);
-}
-
-/************** itype_pragma_pr ******************/
-
-hpragma mkitype_pragma_pr(PPgprag_type_pr1, PPgprag_type_pr2, PPgprag_type_pr3)
- list PPgprag_type_pr1;
- numId PPgprag_type_pr2;
- hpragma PPgprag_type_pr3;
-{
- register struct Sitype_pragma_pr *pp =
- (struct Sitype_pragma_pr *) malloc(sizeof(struct Sitype_pragma_pr));
- pp -> tag = itype_pragma_pr;
- pp -> Xgprag_type_pr1 = PPgprag_type_pr1;
- pp -> Xgprag_type_pr2 = PPgprag_type_pr2;
- pp -> Xgprag_type_pr3 = PPgprag_type_pr3;
- return((hpragma)pp);
-}
-
-list *Rgprag_type_pr1(t)
- struct Sitype_pragma_pr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != itype_pragma_pr)
- fprintf(stderr,"gprag_type_pr1: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_type_pr1);
-}
-
-numId *Rgprag_type_pr2(t)
- struct Sitype_pragma_pr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != itype_pragma_pr)
- fprintf(stderr,"gprag_type_pr2: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_type_pr2);
-}
-
-hpragma *Rgprag_type_pr3(t)
- struct Sitype_pragma_pr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != itype_pragma_pr)
- fprintf(stderr,"gprag_type_pr3: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_type_pr3);
-}
-
-/************** idata_pragma_4s ******************/
-
-hpragma mkidata_pragma_4s(PPgprag_data_spec)
- list PPgprag_data_spec;
-{
- register struct Sidata_pragma_4s *pp =
- (struct Sidata_pragma_4s *) malloc(sizeof(struct Sidata_pragma_4s));
- pp -> tag = idata_pragma_4s;
- pp -> Xgprag_data_spec = PPgprag_data_spec;
- return((hpragma)pp);
-}
-
-list *Rgprag_data_spec(t)
- struct Sidata_pragma_4s *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != idata_pragma_4s)
- fprintf(stderr,"gprag_data_spec: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_data_spec);
-}
+++ /dev/null
-#ifndef hpragma_defined
-#define hpragma_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- no_pragma,
- idata_pragma,
- itype_pragma,
- iclas_pragma,
- iclasop_pragma,
- iinst_simpl_pragma,
- iinst_const_pragma,
- igen_pragma,
- iarity_pragma,
- iupdate_pragma,
- ideforest_pragma,
- istrictness_pragma,
- imagic_unfolding_pragma,
- iunfolding_pragma,
- iunfold_always,
- iunfold_if_args,
- iname_pragma_pr,
- itype_pragma_pr,
- idata_pragma_4s
-} Thpragma;
-
-typedef struct { Thpragma tag; } *hpragma;
-
-#ifdef __GNUC__
-Thpragma thpragma(hpragma t);
-extern __inline__ Thpragma thpragma(hpragma t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Thpragma thpragma PROTO((hpragma));
-#endif /* ! __GNUC__ */
-
-struct Sno_pragma {
- Thpragma tag;
-};
-
-struct Sidata_pragma {
- Thpragma tag;
- list Xgprag_data_constrs;
- list Xgprag_data_specs;
-};
-
-struct Sitype_pragma {
- Thpragma tag;
-};
-
-struct Siclas_pragma {
- Thpragma tag;
- list Xgprag_clas;
-};
-
-struct Siclasop_pragma {
- Thpragma tag;
- hpragma Xgprag_dsel;
- hpragma Xgprag_defm;
-};
-
-struct Siinst_simpl_pragma {
- Thpragma tag;
- stringId Xgprag_imod_simpl;
- hpragma Xgprag_dfun_simpl;
-};
-
-struct Siinst_const_pragma {
- Thpragma tag;
- stringId Xgprag_imod_const;
- hpragma Xgprag_dfun_const;
- list Xgprag_constms;
-};
-
-struct Sigen_pragma {
- Thpragma tag;
- hpragma Xgprag_arity;
- hpragma Xgprag_update;
- hpragma Xgprag_deforest;
- hpragma Xgprag_strictness;
- hpragma Xgprag_unfolding;
- list Xgprag_specs;
-};
-
-struct Siarity_pragma {
- Thpragma tag;
- numId Xgprag_arity_val;
-};
-
-struct Siupdate_pragma {
- Thpragma tag;
- stringId Xgprag_update_val;
-};
-
-struct Sideforest_pragma {
- Thpragma tag;
-};
-
-struct Sistrictness_pragma {
- Thpragma tag;
- hstring Xgprag_strict_spec;
- hpragma Xgprag_strict_wrkr;
-};
-
-struct Simagic_unfolding_pragma {
- Thpragma tag;
- stringId Xgprag_magic_str;
-};
-
-struct Siunfolding_pragma {
- Thpragma tag;
- hpragma Xgprag_unfold_guide;
- coresyn Xgprag_unfold_core;
-};
-
-struct Siunfold_always {
- Thpragma tag;
-};
-
-struct Siunfold_if_args {
- Thpragma tag;
- numId Xgprag_unfold_if_t_args;
- numId Xgprag_unfold_if_v_args;
- stringId Xgprag_unfold_if_con_args;
- numId Xgprag_unfold_if_size;
-};
-
-struct Siname_pragma_pr {
- Thpragma tag;
- unkId Xgprag_name_pr1;
- hpragma Xgprag_name_pr2;
-};
-
-struct Sitype_pragma_pr {
- Thpragma tag;
- list Xgprag_type_pr1;
- numId Xgprag_type_pr2;
- hpragma Xgprag_type_pr3;
-};
-
-struct Sidata_pragma_4s {
- Thpragma tag;
- list Xgprag_data_spec;
-};
-
-extern hpragma mkno_pragma PROTO((void));
-
-extern hpragma mkidata_pragma PROTO((list, list));
-#ifdef __GNUC__
-
-list *Rgprag_data_constrs PROTO((struct Sidata_pragma *));
-
-extern __inline__ list *Rgprag_data_constrs(struct Sidata_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != idata_pragma)
- fprintf(stderr,"gprag_data_constrs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_data_constrs);
-}
-#else /* ! __GNUC__ */
-extern list *Rgprag_data_constrs PROTO((struct Sidata_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_data_constrs(xyzxyz) (*Rgprag_data_constrs((struct Sidata_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgprag_data_specs PROTO((struct Sidata_pragma *));
-
-extern __inline__ list *Rgprag_data_specs(struct Sidata_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != idata_pragma)
- fprintf(stderr,"gprag_data_specs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_data_specs);
-}
-#else /* ! __GNUC__ */
-extern list *Rgprag_data_specs PROTO((struct Sidata_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_data_specs(xyzxyz) (*Rgprag_data_specs((struct Sidata_pragma *) (xyzxyz)))
-
-extern hpragma mkitype_pragma PROTO((void));
-
-extern hpragma mkiclas_pragma PROTO((list));
-#ifdef __GNUC__
-
-list *Rgprag_clas PROTO((struct Siclas_pragma *));
-
-extern __inline__ list *Rgprag_clas(struct Siclas_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iclas_pragma)
- fprintf(stderr,"gprag_clas: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_clas);
-}
-#else /* ! __GNUC__ */
-extern list *Rgprag_clas PROTO((struct Siclas_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_clas(xyzxyz) (*Rgprag_clas((struct Siclas_pragma *) (xyzxyz)))
-
-extern hpragma mkiclasop_pragma PROTO((hpragma, hpragma));
-#ifdef __GNUC__
-
-hpragma *Rgprag_dsel PROTO((struct Siclasop_pragma *));
-
-extern __inline__ hpragma *Rgprag_dsel(struct Siclasop_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iclasop_pragma)
- fprintf(stderr,"gprag_dsel: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_dsel);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_dsel PROTO((struct Siclasop_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_dsel(xyzxyz) (*Rgprag_dsel((struct Siclasop_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_defm PROTO((struct Siclasop_pragma *));
-
-extern __inline__ hpragma *Rgprag_defm(struct Siclasop_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iclasop_pragma)
- fprintf(stderr,"gprag_defm: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_defm);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_defm PROTO((struct Siclasop_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_defm(xyzxyz) (*Rgprag_defm((struct Siclasop_pragma *) (xyzxyz)))
-
-extern hpragma mkiinst_simpl_pragma PROTO((stringId, hpragma));
-#ifdef __GNUC__
-
-stringId *Rgprag_imod_simpl PROTO((struct Siinst_simpl_pragma *));
-
-extern __inline__ stringId *Rgprag_imod_simpl(struct Siinst_simpl_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_simpl_pragma)
- fprintf(stderr,"gprag_imod_simpl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_imod_simpl);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgprag_imod_simpl PROTO((struct Siinst_simpl_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_imod_simpl(xyzxyz) (*Rgprag_imod_simpl((struct Siinst_simpl_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_dfun_simpl PROTO((struct Siinst_simpl_pragma *));
-
-extern __inline__ hpragma *Rgprag_dfun_simpl(struct Siinst_simpl_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_simpl_pragma)
- fprintf(stderr,"gprag_dfun_simpl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_dfun_simpl);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_dfun_simpl PROTO((struct Siinst_simpl_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_dfun_simpl(xyzxyz) (*Rgprag_dfun_simpl((struct Siinst_simpl_pragma *) (xyzxyz)))
-
-extern hpragma mkiinst_const_pragma PROTO((stringId, hpragma, list));
-#ifdef __GNUC__
-
-stringId *Rgprag_imod_const PROTO((struct Siinst_const_pragma *));
-
-extern __inline__ stringId *Rgprag_imod_const(struct Siinst_const_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_const_pragma)
- fprintf(stderr,"gprag_imod_const: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_imod_const);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgprag_imod_const PROTO((struct Siinst_const_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_imod_const(xyzxyz) (*Rgprag_imod_const((struct Siinst_const_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_dfun_const PROTO((struct Siinst_const_pragma *));
-
-extern __inline__ hpragma *Rgprag_dfun_const(struct Siinst_const_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_const_pragma)
- fprintf(stderr,"gprag_dfun_const: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_dfun_const);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_dfun_const PROTO((struct Siinst_const_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_dfun_const(xyzxyz) (*Rgprag_dfun_const((struct Siinst_const_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgprag_constms PROTO((struct Siinst_const_pragma *));
-
-extern __inline__ list *Rgprag_constms(struct Siinst_const_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iinst_const_pragma)
- fprintf(stderr,"gprag_constms: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_constms);
-}
-#else /* ! __GNUC__ */
-extern list *Rgprag_constms PROTO((struct Siinst_const_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_constms(xyzxyz) (*Rgprag_constms((struct Siinst_const_pragma *) (xyzxyz)))
-
-extern hpragma mkigen_pragma PROTO((hpragma, hpragma, hpragma, hpragma, hpragma, list));
-#ifdef __GNUC__
-
-hpragma *Rgprag_arity PROTO((struct Sigen_pragma *));
-
-extern __inline__ hpragma *Rgprag_arity(struct Sigen_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_arity: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_arity);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_arity PROTO((struct Sigen_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_arity(xyzxyz) (*Rgprag_arity((struct Sigen_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_update PROTO((struct Sigen_pragma *));
-
-extern __inline__ hpragma *Rgprag_update(struct Sigen_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_update: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_update);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_update PROTO((struct Sigen_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_update(xyzxyz) (*Rgprag_update((struct Sigen_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_deforest PROTO((struct Sigen_pragma *));
-
-extern __inline__ hpragma *Rgprag_deforest(struct Sigen_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_deforest: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_deforest);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_deforest PROTO((struct Sigen_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_deforest(xyzxyz) (*Rgprag_deforest((struct Sigen_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_strictness PROTO((struct Sigen_pragma *));
-
-extern __inline__ hpragma *Rgprag_strictness(struct Sigen_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_strictness: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_strictness);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_strictness PROTO((struct Sigen_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_strictness(xyzxyz) (*Rgprag_strictness((struct Sigen_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_unfolding PROTO((struct Sigen_pragma *));
-
-extern __inline__ hpragma *Rgprag_unfolding(struct Sigen_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_unfolding: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfolding);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_unfolding PROTO((struct Sigen_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_unfolding(xyzxyz) (*Rgprag_unfolding((struct Sigen_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgprag_specs PROTO((struct Sigen_pragma *));
-
-extern __inline__ list *Rgprag_specs(struct Sigen_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != igen_pragma)
- fprintf(stderr,"gprag_specs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_specs);
-}
-#else /* ! __GNUC__ */
-extern list *Rgprag_specs PROTO((struct Sigen_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_specs(xyzxyz) (*Rgprag_specs((struct Sigen_pragma *) (xyzxyz)))
-
-extern hpragma mkiarity_pragma PROTO((numId));
-#ifdef __GNUC__
-
-numId *Rgprag_arity_val PROTO((struct Siarity_pragma *));
-
-extern __inline__ numId *Rgprag_arity_val(struct Siarity_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iarity_pragma)
- fprintf(stderr,"gprag_arity_val: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_arity_val);
-}
-#else /* ! __GNUC__ */
-extern numId *Rgprag_arity_val PROTO((struct Siarity_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_arity_val(xyzxyz) (*Rgprag_arity_val((struct Siarity_pragma *) (xyzxyz)))
-
-extern hpragma mkiupdate_pragma PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgprag_update_val PROTO((struct Siupdate_pragma *));
-
-extern __inline__ stringId *Rgprag_update_val(struct Siupdate_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iupdate_pragma)
- fprintf(stderr,"gprag_update_val: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_update_val);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgprag_update_val PROTO((struct Siupdate_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_update_val(xyzxyz) (*Rgprag_update_val((struct Siupdate_pragma *) (xyzxyz)))
-
-extern hpragma mkideforest_pragma PROTO((void));
-
-extern hpragma mkistrictness_pragma PROTO((hstring, hpragma));
-#ifdef __GNUC__
-
-hstring *Rgprag_strict_spec PROTO((struct Sistrictness_pragma *));
-
-extern __inline__ hstring *Rgprag_strict_spec(struct Sistrictness_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != istrictness_pragma)
- fprintf(stderr,"gprag_strict_spec: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_strict_spec);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgprag_strict_spec PROTO((struct Sistrictness_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_strict_spec(xyzxyz) (*Rgprag_strict_spec((struct Sistrictness_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_strict_wrkr PROTO((struct Sistrictness_pragma *));
-
-extern __inline__ hpragma *Rgprag_strict_wrkr(struct Sistrictness_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != istrictness_pragma)
- fprintf(stderr,"gprag_strict_wrkr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_strict_wrkr);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_strict_wrkr PROTO((struct Sistrictness_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_strict_wrkr(xyzxyz) (*Rgprag_strict_wrkr((struct Sistrictness_pragma *) (xyzxyz)))
-
-extern hpragma mkimagic_unfolding_pragma PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgprag_magic_str PROTO((struct Simagic_unfolding_pragma *));
-
-extern __inline__ stringId *Rgprag_magic_str(struct Simagic_unfolding_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != imagic_unfolding_pragma)
- fprintf(stderr,"gprag_magic_str: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_magic_str);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgprag_magic_str PROTO((struct Simagic_unfolding_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_magic_str(xyzxyz) (*Rgprag_magic_str((struct Simagic_unfolding_pragma *) (xyzxyz)))
-
-extern hpragma mkiunfolding_pragma PROTO((hpragma, coresyn));
-#ifdef __GNUC__
-
-hpragma *Rgprag_unfold_guide PROTO((struct Siunfolding_pragma *));
-
-extern __inline__ hpragma *Rgprag_unfold_guide(struct Siunfolding_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfolding_pragma)
- fprintf(stderr,"gprag_unfold_guide: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_guide);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_unfold_guide PROTO((struct Siunfolding_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_unfold_guide(xyzxyz) (*Rgprag_unfold_guide((struct Siunfolding_pragma *) (xyzxyz)))
-#ifdef __GNUC__
-
-coresyn *Rgprag_unfold_core PROTO((struct Siunfolding_pragma *));
-
-extern __inline__ coresyn *Rgprag_unfold_core(struct Siunfolding_pragma *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfolding_pragma)
- fprintf(stderr,"gprag_unfold_core: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_core);
-}
-#else /* ! __GNUC__ */
-extern coresyn *Rgprag_unfold_core PROTO((struct Siunfolding_pragma *));
-#endif /* ! __GNUC__ */
-
-#define gprag_unfold_core(xyzxyz) (*Rgprag_unfold_core((struct Siunfolding_pragma *) (xyzxyz)))
-
-extern hpragma mkiunfold_always PROTO((void));
-
-extern hpragma mkiunfold_if_args PROTO((numId, numId, stringId, numId));
-#ifdef __GNUC__
-
-numId *Rgprag_unfold_if_t_args PROTO((struct Siunfold_if_args *));
-
-extern __inline__ numId *Rgprag_unfold_if_t_args(struct Siunfold_if_args *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfold_if_args)
- fprintf(stderr,"gprag_unfold_if_t_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_if_t_args);
-}
-#else /* ! __GNUC__ */
-extern numId *Rgprag_unfold_if_t_args PROTO((struct Siunfold_if_args *));
-#endif /* ! __GNUC__ */
-
-#define gprag_unfold_if_t_args(xyzxyz) (*Rgprag_unfold_if_t_args((struct Siunfold_if_args *) (xyzxyz)))
-#ifdef __GNUC__
-
-numId *Rgprag_unfold_if_v_args PROTO((struct Siunfold_if_args *));
-
-extern __inline__ numId *Rgprag_unfold_if_v_args(struct Siunfold_if_args *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfold_if_args)
- fprintf(stderr,"gprag_unfold_if_v_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_if_v_args);
-}
-#else /* ! __GNUC__ */
-extern numId *Rgprag_unfold_if_v_args PROTO((struct Siunfold_if_args *));
-#endif /* ! __GNUC__ */
-
-#define gprag_unfold_if_v_args(xyzxyz) (*Rgprag_unfold_if_v_args((struct Siunfold_if_args *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rgprag_unfold_if_con_args PROTO((struct Siunfold_if_args *));
-
-extern __inline__ stringId *Rgprag_unfold_if_con_args(struct Siunfold_if_args *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfold_if_args)
- fprintf(stderr,"gprag_unfold_if_con_args: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_if_con_args);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgprag_unfold_if_con_args PROTO((struct Siunfold_if_args *));
-#endif /* ! __GNUC__ */
-
-#define gprag_unfold_if_con_args(xyzxyz) (*Rgprag_unfold_if_con_args((struct Siunfold_if_args *) (xyzxyz)))
-#ifdef __GNUC__
-
-numId *Rgprag_unfold_if_size PROTO((struct Siunfold_if_args *));
-
-extern __inline__ numId *Rgprag_unfold_if_size(struct Siunfold_if_args *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iunfold_if_args)
- fprintf(stderr,"gprag_unfold_if_size: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_unfold_if_size);
-}
-#else /* ! __GNUC__ */
-extern numId *Rgprag_unfold_if_size PROTO((struct Siunfold_if_args *));
-#endif /* ! __GNUC__ */
-
-#define gprag_unfold_if_size(xyzxyz) (*Rgprag_unfold_if_size((struct Siunfold_if_args *) (xyzxyz)))
-
-extern hpragma mkiname_pragma_pr PROTO((unkId, hpragma));
-#ifdef __GNUC__
-
-unkId *Rgprag_name_pr1 PROTO((struct Siname_pragma_pr *));
-
-extern __inline__ unkId *Rgprag_name_pr1(struct Siname_pragma_pr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iname_pragma_pr)
- fprintf(stderr,"gprag_name_pr1: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_name_pr1);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgprag_name_pr1 PROTO((struct Siname_pragma_pr *));
-#endif /* ! __GNUC__ */
-
-#define gprag_name_pr1(xyzxyz) (*Rgprag_name_pr1((struct Siname_pragma_pr *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_name_pr2 PROTO((struct Siname_pragma_pr *));
-
-extern __inline__ hpragma *Rgprag_name_pr2(struct Siname_pragma_pr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != iname_pragma_pr)
- fprintf(stderr,"gprag_name_pr2: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_name_pr2);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_name_pr2 PROTO((struct Siname_pragma_pr *));
-#endif /* ! __GNUC__ */
-
-#define gprag_name_pr2(xyzxyz) (*Rgprag_name_pr2((struct Siname_pragma_pr *) (xyzxyz)))
-
-extern hpragma mkitype_pragma_pr PROTO((list, numId, hpragma));
-#ifdef __GNUC__
-
-list *Rgprag_type_pr1 PROTO((struct Sitype_pragma_pr *));
-
-extern __inline__ list *Rgprag_type_pr1(struct Sitype_pragma_pr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != itype_pragma_pr)
- fprintf(stderr,"gprag_type_pr1: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_type_pr1);
-}
-#else /* ! __GNUC__ */
-extern list *Rgprag_type_pr1 PROTO((struct Sitype_pragma_pr *));
-#endif /* ! __GNUC__ */
-
-#define gprag_type_pr1(xyzxyz) (*Rgprag_type_pr1((struct Sitype_pragma_pr *) (xyzxyz)))
-#ifdef __GNUC__
-
-numId *Rgprag_type_pr2 PROTO((struct Sitype_pragma_pr *));
-
-extern __inline__ numId *Rgprag_type_pr2(struct Sitype_pragma_pr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != itype_pragma_pr)
- fprintf(stderr,"gprag_type_pr2: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_type_pr2);
-}
-#else /* ! __GNUC__ */
-extern numId *Rgprag_type_pr2 PROTO((struct Sitype_pragma_pr *));
-#endif /* ! __GNUC__ */
-
-#define gprag_type_pr2(xyzxyz) (*Rgprag_type_pr2((struct Sitype_pragma_pr *) (xyzxyz)))
-#ifdef __GNUC__
-
-hpragma *Rgprag_type_pr3 PROTO((struct Sitype_pragma_pr *));
-
-extern __inline__ hpragma *Rgprag_type_pr3(struct Sitype_pragma_pr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != itype_pragma_pr)
- fprintf(stderr,"gprag_type_pr3: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_type_pr3);
-}
-#else /* ! __GNUC__ */
-extern hpragma *Rgprag_type_pr3 PROTO((struct Sitype_pragma_pr *));
-#endif /* ! __GNUC__ */
-
-#define gprag_type_pr3(xyzxyz) (*Rgprag_type_pr3((struct Sitype_pragma_pr *) (xyzxyz)))
-
-extern hpragma mkidata_pragma_4s PROTO((list));
-#ifdef __GNUC__
-
-list *Rgprag_data_spec PROTO((struct Sidata_pragma_4s *));
-
-extern __inline__ list *Rgprag_data_spec(struct Sidata_pragma_4s *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != idata_pragma_4s)
- fprintf(stderr,"gprag_data_spec: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgprag_data_spec);
-}
-#else /* ! __GNUC__ */
-extern list *Rgprag_data_spec PROTO((struct Sidata_pragma_4s *));
-#endif /* ! __GNUC__ */
-
-#define gprag_data_spec(xyzxyz) (*Rgprag_data_spec((struct Sidata_pragma_4s *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_hpragma where
-import UgenUtil
-import Util
-
-import U_coresyn
-import U_list
-import U_literal ( U_literal ) -- ditto
-import U_ttype ( U_ttype ) -- interface only
-%}}
-type hpragma;
- no_pragma: < > ;
-
- idata_pragma: < gprag_data_constrs : list; /*of con decls*/
- gprag_data_specs : list; /*specialisations*/ >;
-
- itype_pragma: < >;
-
- iclas_pragma: < gprag_clas : list; /*of gen pragmas*/ >;
-
- iclasop_pragma: < gprag_dsel : hpragma; /* gen pragma: dict selector */
- gprag_defm : hpragma; /* gen pragma: default method */ >;
-
- iinst_simpl_pragma: < gprag_imod_simpl : stringId;
- gprag_dfun_simpl : hpragma; /* gen pragma: of dfun */ >;
-
- iinst_const_pragma: < gprag_imod_const : stringId;
- gprag_dfun_const : hpragma; /* gen pragma: of dfun */
- gprag_constms : list; /* (name, gen pragma) pairs */ >;
-
- igen_pragma: < gprag_arity : hpragma; /* arity */
- gprag_update : hpragma; /* update info */
- gprag_deforest : hpragma; /* deforest info */
- gprag_strictness : hpragma; /* strictness info */
- gprag_unfolding : hpragma; /* unfolding */
- gprag_specs : list; /* (type, gen pragma) pairs */ >;
-
- iarity_pragma: < gprag_arity_val : numId; >;
- iupdate_pragma: < gprag_update_val : stringId; >;
- ideforest_pragma: < >;
- istrictness_pragma: < gprag_strict_spec : hstring;
- gprag_strict_wrkr : hpragma; /*about worker*/ >;
- imagic_unfolding_pragma: < gprag_magic_str : stringId; >;
-
- iunfolding_pragma: < gprag_unfold_guide : hpragma; /* guidance */
- gprag_unfold_core : coresyn; >;
-
- iunfold_always: < >;
- iunfold_if_args: < gprag_unfold_if_t_args : numId;
- gprag_unfold_if_v_args : numId;
- gprag_unfold_if_con_args : stringId;
- gprag_unfold_if_size : numId; >;
-
- iname_pragma_pr: < gprag_name_pr1 : unkId;
- gprag_name_pr2 : hpragma; >;
- itype_pragma_pr: < gprag_type_pr1 : list; /* of maybe types */
- gprag_type_pr2 : numId; /* # dicts to ignore */
- gprag_type_pr3 : hpragma; >;
-
- idata_pragma_4s: < gprag_data_spec : list; /* of maybe types */ >;
-
-end;
+++ /dev/null
-/*
-These routines customise the error messages
-for various bits of the RTS. They are linked
-in instead of the defaults.
-*/
-#include <stdio.h>
-
-#define W_ unsigned long int
-#define I_ long int
-
-void
-ErrorHdrHook (where)
- FILE *where;
-{
- fprintf(where, "\n"); /* no "Fail: " */
-}
-
-
-void
-OutOfHeapHook (request_size, heap_size)
- W_ request_size; /* in bytes */
- W_ heap_size; /* in bytes */
-{
- fprintf(stderr, "GHC's heap exhausted;\nwhile trying to allocate %lu bytes in a %lu-byte heap;\nuse the `-H<size>' option to increase the total heap size.\n",
- request_size,
- heap_size);
-}
-
-void
-StackOverflowHook (stack_size)
- I_ stack_size; /* in bytes */
-{
- fprintf(stderr, "GHC stack-space overflow: current size %ld bytes.\nUse the `-K<size>' option to increase it.\n", stack_size);
-}
-
-#if 0
-/* nothing to add here, really */
-void
-MallocFailHook (request_size, msg)
- I_ request_size; /* in bytes */
- char *msg;
-{
- fprintf(stderr, "malloc: failed on request for %lu bytes\n", request_size);
-}
-#endif /* 0 */
-
-void
-PatErrorHdrHook (where)
- FILE *where;
-{
- fprintf(where, "\n*** Pattern-matching error within GHC!\n\nThis is a compiler bug; please report it to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\nFail: ");
-}
-
-void
-PreTraceHook (where)
- FILE *where;
-{
- fprintf(where, "\n"); /* not "Trace On" */
-}
-
-void
-PostTraceHook (where)
- FILE *where;
-{
- fprintf(where, "\n"); /* not "Trace Off" */
-}
+++ /dev/null
-/* This is the "top-level" file for the *linked-into-the-compiler* parser.
- See also main.c. (WDP 94/10)
-*/
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/**********************************************************************
-* *
-* *
-* The main program *
-* *
-* *
-**********************************************************************/
-
-extern long prog_argc;
-extern char **prog_argv;
-
-#define MAX_HSP_ARGS 64
-long hsp_argc;
-char *hsp_argv[MAX_HSP_ARGS]; /* sigh */
-
-tree
-hspmain()
-{
- int hsp_i, prog_i;
-
- Lnil = mklnil(); /* The null list -- used in lsing, etc. */
- all = mklnil(); /* This should be the list of all derivable types */
-
- /* copy the args we're interested in (first char: comma)
- to hsp_argv; arrange to point after the comma!
- */
- hsp_i = 0;
- for (prog_i = 0; prog_i < prog_argc; prog_i++) {
- if (prog_argv[prog_i][0] == ',') {
- hsp_argv[hsp_i] = &(prog_argv[prog_i][1]);
- hsp_i++;
- }
- }
- hsp_argc = hsp_i; /* set count */
-
- process_args(hsp_argc, hsp_argv); /* HACK */
-
- hash_init();
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"input_file_dir=%s\n",input_file_dir);
-#endif
-
- yyinit();
-
- if (yyparse() != 0) {
- /* There was a syntax error. */
- printf("\n");
- exit(1);
- }
-
- return(root);
-}
+++ /dev/null
-%{
-/**********************************************************************
-* *
-* *
-* LEX grammar for Haskell. *
-* ------------------------ *
-* *
-* (c) Copyright K. Hammond, University of Glasgow, *
-* 10th. February 1989 *
-* *
-* Modification History *
-* -------------------- *
-* *
-* 22/08/91 kh Initial Haskell 1.1 version. *
-* 18/10/91 kh Added 'ccall'. *
-* 19/11/91 kh Tidied generally. *
-* 04/12/91 kh Added Int#. *
-* 31/01/92 kh Haskell 1.2 version. *
-* 19/03/92 Jon Hill Added Data Parallel Notation *
-* 24/04/92 ps Added 'scc'. *
-* 03/06/92 kh Changed Infix/Prelude Handling. *
-* *
-* *
-* Known Problems: *
-* *
-* None, any more. *
-* *
-**********************************************************************/
-
-#include "include.h"
-#include "hsparser-DPH.tab.h"
-#include <stdio.h>
-#include <ctype.h>
-#include "constants.h"
-
-char *input_filename = NULL;
-
-#include "utils.h"
-
-
-/**********************************************************************
-* *
-* *
-* Declarations *
-* *
-* *
-**********************************************************************/
-
-
-extern int yylineno;
-unsigned yylastlineno = 0; /* Line number of previous token */
-unsigned startlineno = 0; /* temp; used to save the line no where something starts */
-int yylastposn = 0; /* Absolute position of last token */
-int yylinestart = 0; /* Absolute position of line start */
-
-static int yyposn = 0;
-
-/* Essential forward declarations */
-
-static int readstring(), readasciiname(), readcomment(),
- lookupascii(), yynewid() /* OLD:, parse_pragma()*/;
-static char escval();
-
-static BOOLEAN incomment = FALSE;
-static unsigned commentdepth = 0;
-
-static BOOLEAN indenteof = FALSE;
-
-/* Pragmas */
-/* OLD: char *pragmatype, *pragmaid, *pragmavalue; */
-
-/* Special file handling for IMPORTS */
-
-static FILE *yyin_save = NULL; /* Saved File Pointer */
-static char *filename_save; /* File Name */
-static int yylineno_save = 0, /* Line Number */
- yyposn_save = 0, /* This Token */
- yylastposn_save = 0, /* Last Token */
- yyindent_save, /* Indentation */
- yylindent_save, /* Left Indentation */
- yytchar_save = 0, /* Next Input Character */
- icontexts_save = 0; /* Indent Context Level */
-static unsigned yylastlineno_save = 0; /* Line Number of Prev. token */
-
-static BOOLEAN leof = FALSE; /* EOF for interfaces */
-
-
-extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */
-extern BOOLEAN ignoreArityPragmas; /* And various specific flavors... */
-extern BOOLEAN ignoreSpecializePragmas;
-extern BOOLEAN ignoreStrictnessPragmas;
-extern BOOLEAN ignoreUpdatePragmas;
-
-
-
-/**********************************************************************
-* *
-* *
-* Layout Processing *
-* *
-* *
-**********************************************************************/
-
-
-/*
- The following section deals with Haskell Layout conventions
- forcing insertion of ; or } as appropriate
-*/
-
-
-static short
- yyindent = 0, /* Current indentation */
- yylindent = 0, /* Indentation of the leftmost char in the current lexeme */
- yyslindent = -1, /* Indentation of the leftmost char in a string */
- yytabindent = 0, /* Indentation before a tab in case we have to backtrack */
- forgetindent = FALSE; /* Don't bother applying indentation rules */
-
-static int yysttok = -1; /* Stacked Token:
- -1 -- no token;
- -ve -- ";" inserted before token
- +ve -- "}" inserted before token
- */
-
-short icontexts = 0; /* Which context we're in */
-
-
-
-/*
- Table of indentations: right bit indicates whether to use
- indentation rules (1 = use rules; 0 = ignore)
-
- partain:
- push one of these "contexts" at every "case" or "where"; the right bit says
- whether user supplied braces,etc., or not. pop appropriately (yyendindent).
-
- ALSO, a push/pop when enter/exit a new file (e.g., on importing). A -1 is
- pushed (the "column" for "module", "interface" and EOF). The -1 from the initial
- push is shown just below.
-
-*/
-
-
-static short indenttab[MAX_CONTEXTS] = { -1 };
-
-#define INDENTPT (indenttab[icontexts]>>1)
-#define INDENTON (indenttab[icontexts]&1)
-
-
-yyshouldindent()
-{
- return(!leof && !forgetindent && INDENTON);
-}
-
-
-/* Enter new context and set new indentation level */
-yysetindent()
-{
-#ifdef DEBUG
- fprintf(stderr,"yysetindent:yyindent=%d,yylindent=%d,INDENTPT[%d]=%d\n",yyindent,yylindent,icontexts,INDENTPT);
-#endif
-
- /* partain: first chk that new indent won't be less than current one;
- this code doesn't make sense to me; yyindent tells the position of the _end_
- of the current token; what that has to do with indenting, I don't know.
- */
-
-
- if(yyindent-1 <= INDENTPT)
- {
- if (INDENTPT == -1)
- return; /* Empty input OK for Haskell 1.1 */
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Layout error -- indentation should be > %d cols",INDENTPT);
- yyerror(errbuf);
- }
- }
- yyentercontext((yylindent << 1) | 1);
-}
-
-
-/* Enter a new context without changing the indentation level */
-
-yyincindent()
-{
-#ifdef DEBUG
- fprintf(stderr,"yyincindent:yyindent=%d,yylindent=%d,INDENTPT[%d]=%d\n",yyindent,yylindent,icontexts,INDENTPT);
-#endif
- yyentercontext(indenttab[icontexts] & ~1);
-}
-
-
-/* Turn off indentation processing, usually because an explicit "{" has been seen */
-
-yyindentoff()
-{
- forgetindent = TRUE;
-}
-
-
-/* Enter a new layout context. */
-
-yyentercontext(indent)
-int indent;
-{
- /* Enter new context and set indentation as specified */
- if(++icontexts >= MAX_CONTEXTS)
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"'wheres' and 'cases' nested too deeply (>%d)", MAX_CONTEXTS-1);
- yyerror(errbuf);
- }
-
- forgetindent = FALSE;
- indenttab[icontexts] = indent;
-#ifdef DEBUG
- fprintf(stderr,"yyentercontext:indent=%d,yyindent=%d,yylindent=%d,INDENTPT[%d]=%d\n",indent,yyindent,yylindent,icontexts,INDENTPT);
-#endif
-}
-
-
-/* Exit a layout context */
-
-yyendindent()
-{
- --icontexts;
-#ifdef DEBUG
- fprintf(stderr,"yyendindent:yyindent=%d,yylindent=%d,INDENTPT[%d]=%d\n",yyindent,yylindent,icontexts,INDENTPT);
-#endif
-}
-
-
-
-
-/*
- * Return checks the indentation level and returns ;, } or the specified token.
- */
-
-#define RETURN(tok) return(Return(tok))
-
-Return(tok)
-int tok;
-{
- if(yyslindent != -1)
- {
- yylindent = yyslindent;
- yyslindent = -1;
- }
- else
- yylindent = yyindent-yyleng;
-
- if (yyshouldindent())
- {
- if (yylindent < INDENTPT)
- {
-#ifdef DEBUG
- fprintf(stderr,"inserted '}' before %d (%d:%d:%d:%d)\n",tok,yylindent,yyindent,yyleng,INDENTPT);
-#endif
- yysttok=tok;
- return(VCCURLY);
- }
-
- else if (yylindent == INDENTPT)
- {
-#ifdef DEBUG
- fprintf(stderr,"inserted ';' before %d (%d:%d)\n",tok,yylindent,INDENTPT);
-#endif
- yysttok = -tok;
- return (SEMI);
- }
- }
- yysttok = -1;
- leof = FALSE;
-#ifdef DEBUG
- fprintf(stderr,"returning %d (%d:%d)\n",tok,yylindent,INDENTPT);
-#endif
- return(tok);
-}
-
-
-/**********************************************************************
-* *
-* *
-* Input Processing for Interfaces *
-* *
-* *
-**********************************************************************/
-
-
-/* setyyin(file) open file as new yyin */
-/* partain: got rid of .ext stuff */
-setyyin(file)
-char *file;
-{
- char fbuf[FILENAME_SIZE];
-
- strcpy(fbuf,file);
-
- yyin_save = yyin;
-
- if((yyin=fopen(fbuf,"r"))==NULL)
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"can't read \"%-.50s\"", fbuf);
- yyerror(errbuf);
- }
-
- yylineno_save = yylineno;
- yylastlineno_save = yylastlineno;
- yylineno = yylastlineno = 0;
-
- yylastposn_save = yylastposn;
- yyposn_save = yyposn;
- yyposn = yylastposn = -1;
-
- filename_save = xmalloc(strlen(input_filename)+1);
- strcpy(filename_save,input_filename);
- new_filename(fbuf);
- yyindent_save = yyindent;
- yylindent_save = yylindent;
- yyindent = yylindent = 0;
- yyentercontext(-1); /* partain: changed this from 0 */
- icontexts_save = icontexts;
- yytchar_save = yytchar;
-#ifdef DEBUG
- fprintf(stderr,"yytchar = %c(%d)\n",yytchar,(int)yytchar);
-#endif
- yysptr = yysbuf;
-#ifdef DEBUG
- fprintf(stderr,"reading %s (%d:%d:%d)\n",input_filename,yyindent_save,yylindent_save,INDENTPT);
-#endif
-}
-
-
-
-/*
- input() is the raw input routine used by yylex()
-*/
-
-#undef input /* so we can define our own versions to handle layout */
-#undef unput
-
-
-static
-input()
-{
- if(yytchar==10)
- yyindent = 0; /* Avoid problems with backtracking over EOL */
-
- yytchar=yytchar==EOF?EOF:(++yyposn,yysptr>yysbuf?U(*--yysptr):getc(yyin));
-
- if(yytchar==10)
- {
- yylinestart = yyposn;
- yylineno++;
- }
-
- if (yytchar == '\t')
- {
- yytabindent = yyindent; /* Remember TAB indentation - only 1, though! */
- yyindent += 8 - (yyindent % 8); /* Tabs stops are 8 columns apart */
- }
- else
- ++yyindent;
-
-
- /* Special EOF processing inserts all missing '}'s into the input stream */
-
- if(yytchar==EOF)
- {
- if(icontexts>icontexts_save && !incomment)
- {
- if(INDENTON)
- {
- indenttab[icontexts] = 0;
- indenteof = TRUE;
- return('\002');
- }
- else
- yyerror("missing '}' at end of file");
- }
-
- else if (yyin_save != NULL)
- {
- fclose(yyin);
- yyin = yyin_save;
- yyin_save = NULL;
- new_filename(filename_save);
- free(filename_save);
- yylineno = yylineno_save;
- yylastlineno = yylastlineno_save;
- yyindent = 0;
- yylindent = 0;
- yyindent = yyindent_save;
- yylindent = yylindent_save;
- yyslindent = -1;
- icontexts = icontexts_save -1;
- icontexts_save = 0;
- leof = TRUE;
- yyposn = yyposn_save;
- yylastposn = yylastposn_save;
-#ifdef DEBUG
- fprintf(stderr,"finished reading interface (%d:%d:%d)\n",yyindent,yylindent,INDENTPT);
-#endif
- return('\001'); /* YUCK */
- }
- else
- return(0);
- }
- else
- return(yytchar);
-}
-
-setstartlineno()
-{
- if(yytchar == 10)
- startlineno = yylineno -1;
- else
- startlineno = yylineno;
-}
-
-
-/*
- * unput() backtracks over a character. With luck it will never backtrack over
- * multiple EOLs and TABs (since these are lexical delimiters).
- */
-
-static
-unput(c)
-char c;
-{
- /* fprintf(stderr,"Unputting %c\n",c); */
-
- yytchar= (c);
-
- if(yytchar=='\n' || yytchar=='\r')
- yylineno--;
-
- *yysptr++=yytchar;
- if(c == '\t')
- yyindent = yytabindent;
- else
- --yyindent;
-
- --yyposn;
-}
-
-
-/*
- * Redefine yylex to check for stacked tokens, yylex1() is the original yylex()
- */
-
-yylex()
-{
- if(yysttok != -1)
- {
- if(yysttok < 0)
- {
- int tok = -yysttok;
- yysttok = -1;
- return(tok);
- }
- RETURN(yysttok);
- }
- else
- {
- /* not quite right, and should take account of stacking */
- yylastlineno = yylineno;
- yylastposn = yyposn;
- return(yylex1());
- }
-}
-
-#define yylex() yylex1()
-%}
-
-%start PRIM
-
-D [0-9]
-O [0-7]
-H [0-9A-Fa-f]
-N {D}+
-S [!#$%&*+./<=>?@\\^|~:]
-NS [^!#$%&*+./<=>?@\\^|~:]
-SId ({S}|~|-){S}*
-Char [ !\"#$%&()*+,\-./0-9:;<=>?@A-Z\[\]^_`a-z{|}~]
-L [A-Z]
-I [A-Za-z]
-i [A-Za-z0-9'_]
-Id {I}({i})*
-A (NUL|SOH|STX|ETX|EOT|ENQ|ACK|BEL|BS|HT|LF|VT|FF|CR|SO|SI|DLE|DC1|DC2|DC3|DC4|NAK|SYN|ETB|CAN|EM|SUB|ESC|FS|GS|RS|US|SP|DEL)
-WS [ \t\n\r\f]*
-
-%e 1000
-%o 2100
-%a 2100
-%p 3600
-%n 490
-%k 350
-
-%%
-
-^"# ".*[\n\r] { char tempf[FILENAME_SIZE];
- sscanf(yytext+1, "%d \"%[^\"]", &yylineno, tempf);
- new_filename(tempf);
- }
-
-^"{-# LINE ".*"-}"[\n\r] { /* partain: pragma-style line directive */
- char tempf[FILENAME_SIZE];
- sscanf(yytext+9, "%d \"%[^\"]", &yylineno, tempf);
- new_filename(tempf);
- }
-
-"{-# ARITY " { if ( ignorePragmas || ignoreArityPragmas ) {
- incomment = 1;
- readcomment();
- incomment = 0;
- } else {
- RETURN(ARITY_PRAGMA);
- }
- }
-"{-# SPECIALIZE " { if ( ignorePragmas || ignoreSpecializePragmas ) {
- incomment = 1;
- readcomment();
- incomment = 0;
- } else {
- RETURN(SPECIALIZE_PRAGMA);
- }
- }
-"{-# STRICTNESS " { if ( ignorePragmas || ignoreStrictnessPragmas ) {
- incomment = 1;
- readcomment();
- incomment = 0;
- } else {
- RETURN(STRICTNESS_PRAGMA);
- }
- }
-"{-# UPDATE " { if ( ignorePragmas || ignoreUpdatePragmas ) {
- incomment = 1;
- readcomment();
- incomment = 0;
- } else {
- RETURN(UPDATE_PRAGMA);
- }
- }
-
-" #-}" { RETURN(END_PRAGMA); }
-
-<PRIM>"void#" { RETURN(VOIDPRIM); }
-<PRIM>{Id}"#" { yynewid(yytext,yyleng);
- RETURN(isconstr(yytext)? CONID: VARID);
- /* Must appear before keywords -- KH */
- }
-
-"case" { RETURN(CASE); }
-"class" { RETURN(CLASS); }
-"data" { RETURN(DATA); }
-"default" { RETURN(DEFAULT); }
-"deriving" { RETURN(DERIVING); }
-"else" { RETURN(ELSE); }
-"hiding" { RETURN(HIDING); }
-"if" { RETURN(IF); }
-"import" { RETURN(IMPORT); }
-"infix" { RETURN(INFIX); }
-"infixl" { RETURN(INFIXL); }
-"infixr" { RETURN(INFIXR); }
-"instance" { RETURN(INSTANCE); }
-"interface" { RETURN(INTERFACE); }
-"module" { RETURN(MODULE); }
-"of" { RETURN(OF); }
-"renaming" { RETURN(RENAMING); }
-"then" { RETURN(THEN); }
-"to" { RETURN(TO); }
-"type" { RETURN(TYPE); }
-"where" { RETURN(WHERE); }
-"in" { RETURN(IN); }
-"let" { RETURN(LET); }
-"ccall" { RETURN(CCALL); }
-"veryDangerousCcall" { RETURN(CCALL_DANGEROUS); }
-"casm" { RETURN(CASM); }
-"veryDangerousCasm" { RETURN(CASM_DANGEROUS); }
-"scc" { RETURN(SCC); }
-
-".." { RETURN(DOTDOT); }
-";" { RETURN(SEMI); }
-"," { RETURN(COMMA); }
-"|" { RETURN(VBAR); }
-"=" { RETURN(EQUAL); }
-"<-" { RETURN(LARROW); }
-"->" { RETURN(RARROW); }
-"=>" { RETURN(DARROW); }
-"::" { RETURN(DCOLON); }
-"(" { RETURN(OPAREN); }
-")" { RETURN(CPAREN); }
-"[" { RETURN(OBRACK); }
-"]" { RETURN(CBRACK); }
-"{" { RETURN(OCURLY); }
-"}" { RETURN(CCURLY); }
-"+" { RETURN(PLUS); }
-"@" { RETURN(AT); }
-"\\" { RETURN(LAMBDA); }
-"_" { RETURN(WILDCARD); }
-"`" { RETURN(BQUOTE); }
-"<<" { RETURN(OPOD); }
-">>" { RETURN(CPOD); }
-"(|" { RETURN(OPROC); }
-"|)" { RETURN(CPROC); }
-"<<-" { RETURN(DRAWNFROM); }
-"<<=" { RETURN(INDEXFROM); }
-
-<PRIM>("-")?{N}"#" {
- yytext[yyleng-1] = '\0'; /* clobber the # first */
- yylval.uid = xstrdup(yytext);
- RETURN(INTPRIM);
- }
-{N} {
- yylval.uid = xstrdup(yytext);
- RETURN(INTEGER);
- }
-
-<PRIM>{N}"."{N}(("e"|"E")("+"|"-")?{N})?"##" {
- yytext[yyleng-2] = '\0'; /* clobber the # first */
- yylval.uid = xstrdup(yytext);
- RETURN(DOUBLEPRIM);
- }
-
-<PRIM>{N}"."{N}(("e"|"E")("+"|"-")?{N})?"#" {
- yytext[yyleng-1] = '\0'; /* clobber the # first */
- yylval.uid = xstrdup(yytext);
- RETURN(FLOATPRIM);
- }
-
-{N}"."{N}(("e"|"E")("+"|"-")?{N})? {
- yylval.uid = xstrdup(yytext);
- RETURN(FLOAT);
- }
-
-
-<PRIM>"``"[^']+"''" { yytext[yyleng-2] = '\0'; /* clobber '' first */
- yynewid(yytext+2,yyleng-2);
- RETURN(CLITLIT);
- }
-
-{Id} { yynewid(yytext,yyleng);
- RETURN(isconstr(yytext)? CONID: VARID);
- }
-
-{SId} { yynewid(yytext,yyleng);
- if(yyleng == 1)
- if (*yytext == '~')
- return( LAZY );
- else if ( *yytext == '-' )
- return( MINUS );
- RETURN(isconstr(yytext)? CONSYM: VARSYM);
- }
-
-<PRIM>"`"{Id}"#`" { yynewid(yytext+1,yyleng-2);
- RETURN(isconstr(yytext+1)? CONSYM: VARSYM);
- }
-
-'{Char}' {
- yytext[2] = '\0';
- yylval.uid = xstrdup(yytext);
- RETURN(CHAR);
-
- /* WDP note:
- we don't yet return CHARPRIMs
- (ToDo)
- */
- }
-
-'\\(a|b|f|n|r|t|v)' {
- yytext[1] = escval(yytext[2]);
- yytext[2] = '\0';
- yylval.uid = xstrdup(yytext);
- RETURN(CHAR);
- }
-
-'\\(\"|\'|\\)' {
- yytext[1] = yytext[2];
- yytext[2] = '\0';
- yylval.uid = xstrdup(yytext);
- RETURN(CHAR);
- }
-
-'\\{A}' { yytext[yyleng-1] = '\0';
- if(strcmp(yytext+2,"DEL")==0)
- {
- yylval.uid = xstrdup("'\177");
- RETURN(CHAR);
- }
- else
- {
- int a = lookupascii(yytext+2);
- if(a >= 0)
- {
- yytext[1] = a;
- yytext[2] = '\0';
- yylval.uid = xstrdup(yytext);
- RETURN(CHAR);
- }
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"invalid ASCII name in character constant: %s",yytext);
- yyerror(errbuf);
- }
- }
- }
-
-'\\{D}+' { if(convchar(yytext+2,yyleng-3,10))
- RETURN(CHAR);
- }
-
-'\\o{O}+' { if(convchar(yytext+3,yyleng-4,8))
- RETURN(CHAR);
- }
-
-'\\x{H}+' { if(convchar(yytext+3,yyleng-4,16))
- RETURN(CHAR);
- }
-
-'\\\^[A-Z\[\\\]^_]' { yytext[1] = yytext[3]-'A'+ 1;
- yytext[2] = '\0';
- yylval.uid = xstrdup(yytext);
- RETURN(CHAR);
- }
-
-'\\\^@' { yytext[1] = '\0'; /* partain: most doubtful... */
- yytext[2] = '\0';
- yylval.uid = xstrdup(yytext);
- RETURN(CHAR);
- }
-
-"\"" {
- readstring();
- yylval.uid = installString(yyleng, yytext);
- RETURN(STRING);
- }
-
-
-"--".*[\n\r] ; /* hm-hm -style comment */
-
-"\001" { if (leof)
- {
- unput(yytchar_save);
- RETURN(LEOF);
- }
-
- fprintf(stderr, "illegal char: %c (%d) in line %d\n",
- yytext[0], yytext[0], yylineno);
- }
-
-"\002" { if (indenteof)
- {
- indenteof = FALSE;
- RETURN(VCCURLY);
- }
-
- fprintf(stderr, "illegal char: %c (%d) in line %d\n",
- yytext[0], yytext[0], yylineno);
- }
-
-[\r\n \t\v\f] ;
-
-. { fprintf(stderr, "illegal char: %c (%d) in line %d\n",
- yytext[0], yytext[0], yylineno);
- }
-
-"{-" {
- incomment = 1;
- readcomment();
- incomment = 0;
- }
-%%
-
-
-/**********************************************************************
-* *
-* *
-* YACC/LEX Initialisation etc. *
-* *
-* *
-**********************************************************************/
-
-
-/*
- We initialise input_filename to "<NONAME>".
- This allows unnamed sources to be piped into the parser.
-*/
-
-yyinit()
-{
- extern BOOLEAN acceptPrim;
-
- input_filename = xstrdup("<NONAME>");
-
- yytchar = '\n';
-
- if(acceptPrim)
- BEGIN PRIM;
-}
-
-
-new_filename(f)
-char *f;
-{
- if(input_filename != NULL)
- free(input_filename);
- input_filename = xstrdup(f);
-}
-
-
-
-yywrap()
-{
- return(1);
-}
-
-
-/**********************************************************************
-* *
-* *
-* Comment Handling *
-* *
-* *
-**********************************************************************/
-
-
-
-/*
- readcomment() reads Haskell nested comments {- ... -}
- Indentation is automatically taken care of since input() is used.
-
- While in principle this could be done using Lex rules, in
- practice it's easier and neater to use special code for this
- and for strings.
-*/
-
-static readcomment()
-{
- int c;
-
- do {
- while ((c = input()) != '-' && !eof(c))
- {
- if(c=='{')
- if ((c=input()) == '-')
- readcomment();
-
- else if (eof(c))
- {
- yyerror("comment not terminated by end of file");
- }
- }
-
- while (c == '-')
- c = input();
-
- if (c == '}')
- break;
-
- if (eof(c))
- {
- yyerror("comment not terminated by end of file");
- }
-
- } while (1);
-}
-
-
-/*
- eof(c) Returns TRUE when EOF read.
-*/
-
-eof(c)
-int c;
-{
- return (c == 0 || c == 1 && leof);
-}
-
-
-
-/**********************************************************************
-* *
-* *
-* Identifier Processing *
-* *
-* *
-**********************************************************************/
-
-
-/*
- yynewid Enters an id of length n into the symbol table.
-*/
-
-static yynewid(yyt,len)
-char *yyt;
-int len;
-{
- char yybuf[1024];
- strcpy(yybuf,yyt);
- yybuf[len] = '\0';
- yylval.uid = installid(yybuf);
-}
-
-
-/*
- isconstr(s) True iff s is a constructor id.
-*/
-
-isconstr(s)
-char *s;
-{
- return(*s == ':' || isupper(*s));
-}
-
-
-
-
-/**********************************************************************
-* *
-* *
-* Character Kind Predicates *
-* *
-* *
-**********************************************************************/
-
-
-/*
- * ishspace(ch) determines whether ch is a valid Haskell space character
- */
-
-
-static int ishspace(ch)
-char ch;
-{
- return(ch == '\n' || ch == ' ' || ch == '\t' || ch == '\v' || ch == '\f');
-}
-
-
-/*
- * isddigit(ch) determines whether ch is a valid Decimal digit
- */
-
-
-static int isddigit(ch)
-char ch;
-{
- return (isdigit(ch));
-}
-
-
-/*
- * ishexdigit(ch) determines whether ch is a valid Hexadecimal digit
- */
-
-
-static int ishexdigit(ch)
-char ch;
-{
- return (isdigit(ch) || (ch >= 'A' && ch <= 'F') || (ch >= 'a' && ch <= 'f'));
-}
-
-/*
- * isodigit(ch) determines whether ch is a valid Octal digit
- */
-
-
-static int isodigit(ch)
-char ch;
-{
- return ((ch >= '0' && ch <= '7'));
-}
-
-
-/**********************************************************************
-* *
-* *
-* Lexical Analysis of Strings -- Gaps and escapes mean that *
-* lex isn't (wo)man enough for this job. *
-* *
-* *
-**********************************************************************/
-
-
-/*
- * readstring() reads a string constant and places it in yytext
- */
-
-static readstring()
-{
- int ch, c;
-
- yyslindent = yyindent-1;
-
- yyleng = 1;
- yytext[1] = '\0';
-
- do
- {
- ch = input();
-
- if (ch == '\\')
- {
- ch = input();
-
- if(isdigit(ch))
- ch = readescnum(isddigit,10,ch);
-
- else if (ch == 'o')
- {
- ch = input();
- if(isodigit(ch))
- ch = readescnum(isodigit,8,ch);
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"strange Octal character code (%c) in string",ch);
- yyerror(errbuf);
- }
- }
-
- else if (ch == 'x')
- {
- ch = input();
- if(ishexdigit(ch))
- ch = readescnum(ishexdigit,16,ch);
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"strange Hexadecimal character code (%c) in string",ch);
- yyerror(errbuf);
- }
- }
-
- else if(ch == '"' || ch == '\\' || ch == '\'')
- /* SKIP */;
-
- else if (isupper(ch))
- {
- if((ch = readasciiname(ch)) == -1)
- yyerror("invalid ASCII name in string");
- }
-
- else if (ch == '^')
- {
- if(isupper(ch = input()) || (ch >= '[' && ch <= '_'))
- ch = ch - 'A' + 1;
- else if (ch == '@')
- ch = '\0';
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"strange control sequence (^%c) in string",ch);
- yyerror(errbuf);
- }
- }
-
- else if (ishspace(ch))
- {
- /* partain: we may want clearer error msgs if \v, \f seen */
-
- while (ch == '\t' || ch == ' ')
- ch = input();
-
- if (ch != '\n' && ch != '\r')
- yyerror("newline not seen when expected in string gap");
- else
- ch = input();
-
- while (ch == '\t' || ch == ' ')
- ch = input();
-
- if(ch != '\\')
- yyerror("trailing \\ not seen when expected in string gap");
-
- ch = -1;
- }
-
- else if (ch == 'a')
- ch = '\007';
-
- else if (ch == 'b')
- ch = '\b';
-
- else if (ch == 'f')
- ch = '\f';
-
- else if (ch == 'n')
- ch = '\n';
-
- else if (ch == 'r')
- ch = '\r';
-
- else if (ch == 't')
- ch = '\t';
-
- else if (ch == 'v')
- ch = '\v';
-
- else if (ch == '&')
- ch = -1;
-
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"invalid escape sequence (\\%c) in string",ch);
- yyerror(errbuf);
- }
- }
-
- else if (ch == '\n' || ch == '\r' || ch == '\f' || ch == '\v' || ch == 0 || ch == '"')
- break;
-
- else if (!isprint(ch) && !ishspace(ch))
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"invalid character (%c) in string",ch);
- yyerror(errbuf);
- }
-
- if((yyleng < YYLMAX-3 && ch != -1) || (yyleng == YYLMAX-3 && (ch == '\t' || ch == '\\')))
- {
- /* The LML back-end treats \\ and \t specially in strings... */
-
- if(ch == '\t' || ch == '\\')
- {
- yytext[yyleng++] = '\\';
- if (ch == '\t')
- ch = 't';
- }
- if(yyleng<YYLMAX-2)
- {
- yytext[yyleng++] = ch;
- yytext[yyleng] = '\0';
- }
- }
- else if (ch != -1)
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"string too long (> %d characters)",YYLMAX-3-2);
- yyerror(errbuf);
- }
- }
- while(1);
-
- if (ch != '"')
- yyerror("string incorrectly terminated");
-
- else
- {
- yytext[yyleng++] = '"';
- yytext[yyleng] = '\0';
- }
-#ifdef DEBUG
- fprintf(stderr,"string: %s (%d chars)\n",yytext,yyleng-2);
-#endif
-}
-
-
-
-/**********************************************************************
-* *
-* *
-* Haskell String and Character Escape Codes *
-* *
-* *
-**********************************************************************/
-
-
-/* Names of ASCII control characters, used in strings and character constants */
-
-static char *asciinames[] =
- {
- "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "BS", "HT",
- "LF", "VT", "FF", "CR", "SO", "SI", "DLE", "DC1", "DC2", "DC3",
- "DC4", "NAK", "SYN", "ETB", "CAN", "EM", "SUB", "ESC", "FS", "GS",
- "RS", "US", "SP", "DEL"
- };
-
-
-/*
- * readasciiname() read ASCII name and translate to an ASCII code
- * -1 indicates invalid name
- */
-
-static int readasciiname(ch)
-int ch;
-{
- char asciiname[4];
-
- asciiname[0] = ch;
- if(!isupper(asciiname[1]= input()))
- {
- unput(asciiname[1]);
- return(-1);
- }
-
- if(!isupper(asciiname[2]=input()))
- {
- /* partain: have to have something extra for DC[1-4] */
- if (asciiname[0] == 'D' && asciiname[1] == 'C' && isdigit(asciiname[2])) {
- asciiname[3] = '\0';
- } else {
- unput(asciiname[2]);
- asciiname[2] = '\0';
- }
- }
- else
- asciiname[3] = '\0';
-
- if (strcmp(asciiname,"DEL") == 0)
- return('\177');
-
- else
- return(lookupascii(asciiname));
-}
-
-
-/*
- lookupascii(ascii) look up ascii in asciinames[]
-
- returns -1 if ascii is not found, otherwise its index.
-*/
-
-static int lookupascii(ascii)
-char *ascii;
-{
- int i;
- for(i='\0'; i <= ' '; ++i)
- if(strcmp(ascii,asciinames[i])==0)
- return(i);
- return(-1);
-}
-
-
-/**********************************************************************
-* *
-* *
-* Numeric Escapes in Characters/Strings *
-* *
-* *
-**********************************************************************/
-
-int convnum(num,numlen,base)
-char *num;
-int numlen, base;
-{
- int i, res = 0, mul;
-
- for (i = numlen-1, mul = 1; i >= 0; --i, mul *= base)
- {
- if(isdigit(num[i]))
- res += (num[i] - '0') * mul;
- else if (isupper(num[i]))
- res += (num[i] - 'A' + 10) * mul;
- else if (islower(num[i]))
- res += (num[i] - 'a' + 10) * mul;
- }
- return(res);
-}
-
-convchar(num,numlen,base)
-char *num;
-int numlen, base;
-{
- int n = convnum(num,numlen,base);
- if (n <= MAX_ESC_CHAR)
- {
- yytext[1] = n;
- yytext[2] = '\0';
- yylval.uid = xstrdup(yytext);
- return(1);
- }
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"ASCII code > %d in character constant",MAX_ESC_CHAR);
- yyerror(errbuf);
- }
-}
-
-readescnum(isadigit,mulbase,ch)
-int (*isadigit)();
-int mulbase;
-int ch;
-{
- char digit[MAX_ESC_DIGITS];
- int digcount;
-
- digcount = 1;
- digit[0] = ch;
-
- while((*isadigit)(ch=input()))
- {
- if(digcount < MAX_ESC_DIGITS)
- digit[digcount] = ch;
- ++digcount;
- }
-
- unput(ch);
-
- if(digcount > MAX_ESC_DIGITS)
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"numeric character code too long (> %d characters) in string",MAX_ESC_DIGITS);
- yyerror(errbuf);
- }
-
- ch = convnum(digit,digcount,mulbase);
-
- if (ch > MAX_ESC_CHAR)
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"character code > ASCII %d in string",MAX_ESC_CHAR);
- yyerror(errbuf);
- }
-
- return(ch);
-}
-
-
-/*
- escval(c) return the value of an escaped character.
-
- \a BELL
- \b BACKSPACE
- \f FORMFEED
- \n NEWLINE
- \r CARRIAGE RETURN
- \t TAB
- \v VERTICAL TAB
-
- These definitions are standard ANSI C values.
-*/
-
-static char escval(c)
-char c;
-{
- return(c == 'a'? '\007': c == 'b'? '\b': c == 'f'? '\f': c == 'n'? '\n':
- c == 'r'? '\r': c == 't'? '\t': c == 'v'? '\v': '\0');
-}
-
-/*
- OLD: Lexical analysis for Haskell pragmas.
-*/
-
-#if 0
-static parse_pragma(s,len)
-char *s;
-int len;
-{
- char pragma_name[1024];
- char identifier[1024];
- char value[1024];
- int i;
-
- *(s+len) = '\0';
-
- while(isspace(*s))
- s++;
-
- /* Pragma name */
- for(i=0; !isspace(*s); ++i, ++s)
- pragma_name[i] = *s;
- pragma_name[i] = '\0';
-
- while(isspace(*s))
- s++;
-
- /* Identifier */
- for(i=0; !isspace(*s); ++i, ++s)
- identifier[i] = *s;
- identifier[i] = '\0';
-
- while(isspace(*s))
- s++;
-
- /* equals */
- s++;
-
- while(isspace(*s))
- s++;
-
- /* Value */
- for(i=0; !isspace(*s); ++i, ++s)
- value[i] = *s;
- value[i] = '\0';
-
- pragmatype = installid(pragma_name);
- pragmaid = installid(identifier);
- pragmavalue = xstrdup(value);
-}
-
-#endif /* 0 */
+++ /dev/null
-/* A lexical scanner generated by flex */
-
-/* Scanner skeleton version:
- * $Header: /srv/cvs/cvs.haskell.org/fptools/ghc/compiler/yaccParser/Attic/hslexer.c,v 1.4 1996/01/23 11:11:20 partain Exp $
- */
-
-#define FLEX_SCANNER
-#define YY_FLEX_MAJOR_VERSION 2
-#define YY_FLEX_MINOR_VERSION 5
-
-#include <stdio.h>
-
-
-/* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */
-#ifdef c_plusplus
-#ifndef __cplusplus
-#define __cplusplus
-#endif
-#endif
-
-
-#ifdef __cplusplus
-
-#include <stdlib.h>
-#include <unistd.h>
-
-/* Use prototypes in function declarations. */
-#define YY_USE_PROTOS
-
-/* The "const" storage-class-modifier is valid. */
-#define YY_USE_CONST
-
-#else /* ! __cplusplus */
-
-#if __STDC__
-
-#define YY_USE_PROTOS
-#define YY_USE_CONST
-
-#endif /* __STDC__ */
-#endif /* ! __cplusplus */
-
-#ifdef __TURBOC__
- #pragma warn -rch
- #pragma warn -use
-#include <io.h>
-#include <stdlib.h>
-#define YY_USE_CONST
-#define YY_USE_PROTOS
-#endif
-
-#ifdef YY_USE_CONST
-#define yyconst const
-#else
-#define yyconst
-#endif
-
-
-#ifdef YY_USE_PROTOS
-#define YY_PROTO(proto) proto
-#else
-#define YY_PROTO(proto) ()
-#endif
-
-/* Returned upon end-of-file. */
-#define YY_NULL 0
-
-/* Promotes a possibly negative, possibly signed char to an unsigned
- * integer for use as an array index. If the signed char is negative,
- * we want to instead treat it as an 8-bit unsigned char, hence the
- * double cast.
- */
-#define YY_SC_TO_UI(c) ((unsigned int) (unsigned char) c)
-
-/* Enter a start condition. This macro really ought to take a parameter,
- * but we do it the disgusting crufty way forced on us by the ()-less
- * definition of BEGIN.
- */
-#define BEGIN yy_start = 1 + 2 *
-
-/* Translate the current start state into a value that can be later handed
- * to BEGIN to return to the state. The YYSTATE alias is for lex
- * compatibility.
- */
-#define YY_START ((yy_start - 1) / 2)
-#define YYSTATE YY_START
-
-/* Action number for EOF rule of a given start state. */
-#define YY_STATE_EOF(state) (YY_END_OF_BUFFER + state + 1)
-
-/* Special action meaning "start processing a new file". */
-#define YY_NEW_FILE yyrestart( yyin )
-
-#define YY_END_OF_BUFFER_CHAR 0
-
-/* Size of default input buffer. */
-#define YY_BUF_SIZE 16384
-
-typedef struct yy_buffer_state *YY_BUFFER_STATE;
-
-extern int yyleng;
-extern FILE *yyin, *yyout;
-
-#define EOB_ACT_CONTINUE_SCAN 0
-#define EOB_ACT_END_OF_FILE 1
-#define EOB_ACT_LAST_MATCH 2
-
-/* The funky do-while in the following #define is used to turn the definition
- * int a single C statement (which needs a semi-colon terminator). This
- * avoids problems with code like:
- *
- * if ( condition_holds )
- * yyless( 5 );
- * else
- * do_something_else();
- *
- * Prior to using the do-while the compiler would get upset at the
- * "else" because it interpreted the "if" statement as being all
- * done when it reached the ';' after the yyless() call.
- */
-
-/* Return all but the first 'n' matched characters back to the input stream. */
-
-#define yyless(n) \
- do \
- { \
- /* Undo effects of setting up yytext. */ \
- *yy_cp = yy_hold_char; \
- yy_c_buf_p = yy_cp = yy_bp + n - YY_MORE_ADJ; \
- YY_DO_BEFORE_ACTION; /* set up yytext again */ \
- } \
- while ( 0 )
-
-#define unput(c) yyunput( c, yytext_ptr )
-
-/* The following is because we cannot portably get our hands on size_t
- * (without autoconf's help, which isn't available because we want
- * flex-generated scanners to compile on their own).
- */
-typedef unsigned int yy_size_t;
-
-
-struct yy_buffer_state
- {
- FILE *yy_input_file;
-
- char *yy_ch_buf; /* input buffer */
- char *yy_buf_pos; /* current position in input buffer */
-
- /* Size of input buffer in bytes, not including room for EOB
- * characters.
- */
- yy_size_t yy_buf_size;
-
- /* Number of characters read into yy_ch_buf, not including EOB
- * characters.
- */
- int yy_n_chars;
-
- /* Whether we "own" the buffer - i.e., we know we created it,
- * and can realloc() it to grow it, and should free() it to
- * delete it.
- */
- int yy_is_our_buffer;
-
- /* Whether this is an "interactive" input source; if so, and
- * if we're using stdio for input, then we want to use getc()
- * instead of fread(), to make sure we stop fetching input after
- * each newline.
- */
- int yy_is_interactive;
-
- /* Whether we're considered to be at the beginning of a line.
- * If so, '^' rules will be active on the next match, otherwise
- * not.
- */
- int yy_at_bol;
-
- /* Whether to try to fill the input buffer when we reach the
- * end of it.
- */
- int yy_fill_buffer;
-
- int yy_buffer_status;
-#define YY_BUFFER_NEW 0
-#define YY_BUFFER_NORMAL 1
- /* When an EOF's been seen but there's still some text to process
- * then we mark the buffer as YY_EOF_PENDING, to indicate that we
- * shouldn't try reading from the input source any more. We might
- * still have a bunch of tokens to match, though, because of
- * possible backing-up.
- *
- * When we actually see the EOF, we change the status to "new"
- * (via yyrestart()), so that the user can continue scanning by
- * just pointing yyin at a new input file.
- */
-#define YY_BUFFER_EOF_PENDING 2
- };
-
-static YY_BUFFER_STATE yy_current_buffer = 0;
-
-/* We provide macros for accessing buffer states in case in the
- * future we want to put the buffer states in a more general
- * "scanner state".
- */
-#define YY_CURRENT_BUFFER yy_current_buffer
-
-
-/* yy_hold_char holds the character lost when yytext is formed. */
-static char yy_hold_char;
-
-static int yy_n_chars; /* number of characters read into yy_ch_buf */
-
-
-int yyleng;
-
-/* Points to current character in buffer. */
-static char *yy_c_buf_p = (char *) 0;
-static int yy_init = 1; /* whether we need to initialize */
-static int yy_start = 0; /* start state number */
-
-/* Flag which is used to allow yywrap()'s to do buffer switches
- * instead of setting up a fresh yyin. A bit of a hack ...
- */
-static int yy_did_buffer_switch_on_eof;
-
-void yyrestart YY_PROTO(( FILE *input_file ));
-
-void yy_switch_to_buffer YY_PROTO(( YY_BUFFER_STATE new_buffer ));
-void yy_load_buffer_state YY_PROTO(( void ));
-YY_BUFFER_STATE yy_create_buffer YY_PROTO(( FILE *file, int size ));
-void yy_delete_buffer YY_PROTO(( YY_BUFFER_STATE b ));
-void yy_init_buffer YY_PROTO(( YY_BUFFER_STATE b, FILE *file ));
-void yy_flush_buffer YY_PROTO(( YY_BUFFER_STATE b ));
-#define YY_FLUSH_BUFFER yy_flush_buffer( yy_current_buffer )
-
-YY_BUFFER_STATE yy_scan_buffer YY_PROTO(( char *base, yy_size_t size ));
-YY_BUFFER_STATE yy_scan_string YY_PROTO(( yyconst char *str ));
-YY_BUFFER_STATE yy_scan_bytes YY_PROTO(( yyconst char *bytes, int len ));
-
-static void *yy_flex_alloc YY_PROTO(( yy_size_t ));
-static void *yy_flex_realloc YY_PROTO(( void *, yy_size_t ));
-static void yy_flex_free YY_PROTO(( void * ));
-
-#define yy_new_buffer yy_create_buffer
-
-#define yy_set_interactive(is_interactive) \
- { \
- if ( ! yy_current_buffer ) \
- yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \
- yy_current_buffer->yy_is_interactive = is_interactive; \
- }
-
-#define yy_set_bol(at_bol) \
- { \
- if ( ! yy_current_buffer ) \
- yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE ); \
- yy_current_buffer->yy_at_bol = at_bol; \
- }
-
-#define YY_AT_BOL() (yy_current_buffer->yy_at_bol)
-
-typedef unsigned char YY_CHAR;
-FILE *yyin = (FILE *) 0, *yyout = (FILE *) 0;
-typedef int yy_state_type;
-extern char *yytext;
-#define yytext_ptr yytext
-
-static yy_state_type yy_get_previous_state YY_PROTO(( void ));
-static yy_state_type yy_try_NUL_trans YY_PROTO(( yy_state_type current_state ));
-static int yy_get_next_buffer YY_PROTO(( void ));
-static void yy_fatal_error YY_PROTO(( yyconst char msg[] ));
-
-/* Done after the current pattern has been matched and before the
- * corresponding action - sets up yytext.
- */
-#define YY_DO_BEFORE_ACTION \
- yytext_ptr = yy_bp; \
- yyleng = (int) (yy_cp - yy_bp); \
- yy_hold_char = *yy_cp; \
- *yy_cp = '\0'; \
- yy_c_buf_p = yy_cp;
-
-#define YY_NUM_RULES 202
-#define YY_END_OF_BUFFER 203
-static yyconst short int yy_accept[743] =
- { 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 191, 191,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 203, 197, 198, 130, 129, 137, 199, 142, 185, 199,
- 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
- 199, 199, 199, 140, 199, 151, 153, 161, 157, 199,
- 163, 155, 159, 199, 189, 122, 133, 127, 92, 93,
- 98, 85, 105, 122, 111, 111, 122, 84, 122, 87,
- 99, 121, 94, 100, 95, 102, 103, 121, 121, 121,
- 121, 121, 121, 121, 121, 121, 121, 121, 96, 86,
- 97, 104, 122, 191, 196, 196, 133, 127, 105, 111,
-
- 111, 102, 103, 189, 127, 122, 111, 197, 121, 121,
- 121, 121, 121, 96, 122, 122, 122, 197, 197, 121,
- 121, 197, 200, 136, 135, 139, 201, 189, 142, 201,
- 185, 201, 201, 201, 201, 201, 201, 201, 201, 201,
- 201, 201, 201, 201, 201, 141, 201, 151, 153, 161,
- 157, 201, 163, 155, 159, 201, 201, 130, 129, 128,
- 185, 0, 0, 152, 0, 162, 0, 0, 0, 175,
- 0, 0, 0, 0, 160, 178, 179, 154, 156, 0,
- 0, 180, 165, 164, 182, 0, 0, 0, 181, 158,
- 184, 186, 187, 189, 122, 133, 132, 127, 126, 188,
-
- 89, 83, 0, 111, 0, 0, 91, 88, 90, 119,
- 121, 120, 0, 120, 121, 121, 121, 121, 121, 121,
- 61, 121, 75, 121, 121, 69, 121, 121, 72, 121,
- 121, 190, 0, 0, 191, 192, 0, 195, 193, 194,
- 0, 133, 132, 127, 0, 0, 110, 0, 111, 0,
- 0, 120, 0, 0, 0, 127, 0, 111, 0, 0,
- 0, 120, 120, 120, 120, 120, 120, 120, 120, 120,
- 120, 120, 120, 120, 120, 120, 120, 0, 121, 121,
- 75, 121, 69, 190, 0, 121, 136, 135, 134, 138,
- 149, 150, 174, 167, 168, 169, 170, 183, 166, 148,
-
- 147, 177, 173, 146, 171, 143, 144, 145, 176, 172,
- 127, 125, 188, 188, 188, 188, 114, 107, 109, 120,
- 120, 121, 121, 121, 121, 121, 121, 121, 121, 121,
- 121, 121, 76, 121, 121, 121, 121, 121, 0, 0,
- 1, 1, 0, 131, 125, 0, 0, 114, 107, 109,
- 120, 120, 0, 0, 0, 0, 0, 0, 18, 19,
- 0, 120, 120, 120, 120, 12, 120, 120, 120, 120,
- 120, 120, 17, 120, 15, 120, 120, 120, 11, 120,
- 120, 6, 120, 120, 120, 120, 14, 120, 120, 120,
- 13, 120, 120, 118, 121, 76, 53, 188, 0, 120,
-
- 54, 121, 56, 121, 121, 59, 121, 121, 121, 121,
- 121, 121, 121, 71, 73, 121, 0, 0, 52, 52,
- 52, 52, 52, 52, 0, 124, 0, 0, 113, 0,
- 106, 108, 120, 120, 123, 0, 46, 0, 101, 120,
- 120, 120, 120, 120, 120, 120, 120, 120, 120, 120,
- 120, 120, 120, 120, 16, 120, 7, 120, 120, 120,
- 120, 120, 120, 120, 120, 120, 120, 120, 120, 118,
- 54, 0, 114, 81, 55, 121, 121, 121, 121, 63,
- 121, 121, 121, 121, 74, 52, 52, 52, 52, 52,
- 52, 52, 0, 112, 0, 114, 120, 120, 115, 0,
-
- 0, 120, 22, 120, 120, 20, 120, 120, 120, 120,
- 120, 120, 120, 120, 120, 120, 120, 116, 120, 120,
- 120, 120, 120, 120, 120, 120, 120, 120, 120, 120,
- 121, 121, 60, 62, 64, 65, 121, 121, 68, 121,
- 52, 52, 52, 52, 52, 52, 52, 0, 79, 120,
- 120, 120, 120, 120, 120, 120, 35, 120, 36, 120,
- 120, 120, 120, 34, 120, 120, 40, 120, 23, 120,
- 120, 38, 117, 120, 120, 39, 120, 57, 121, 121,
- 121, 121, 52, 52, 52, 52, 52, 52, 52, 0,
- 2, 2, 120, 77, 120, 120, 120, 120, 120, 120,
-
- 120, 120, 120, 120, 120, 120, 120, 120, 33, 120,
- 21, 120, 120, 58, 66, 121, 70, 52, 52, 52,
- 52, 52, 52, 52, 120, 120, 120, 120, 41, 120,
- 32, 37, 120, 120, 120, 120, 25, 120, 120, 120,
- 120, 120, 120, 120, 82, 67, 52, 0, 52, 52,
- 48, 52, 52, 80, 120, 120, 120, 29, 120, 30,
- 31, 42, 43, 44, 45, 120, 120, 120, 28, 52,
- 0, 0, 52, 52, 52, 52, 78, 8, 120, 9,
- 24, 120, 120, 52, 0, 51, 50, 52, 52, 120,
- 120, 120, 52, 3, 3, 52, 52, 120, 120, 10,
-
- 52, 52, 47, 120, 120, 52, 52, 27, 120, 5,
- 52, 120, 0, 52, 120, 0, 52, 120, 0, 49,
- 26, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 4, 0
- } ;
-
-static yyconst int yy_ec[256] =
- { 0,
- 1, 1, 1, 1, 1, 1, 1, 1, 2, 3,
- 2, 2, 4, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 5, 6, 7, 8, 9, 10, 11, 12, 13,
- 14, 10, 15, 16, 17, 18, 19, 20, 21, 22,
- 23, 24, 25, 25, 25, 26, 26, 27, 28, 29,
- 30, 31, 10, 32, 33, 34, 35, 36, 37, 38,
- 39, 40, 41, 42, 43, 44, 45, 46, 47, 48,
- 49, 50, 51, 52, 53, 54, 55, 56, 57, 58,
- 59, 60, 61, 62, 63, 64, 65, 66, 67, 68,
-
- 69, 70, 71, 72, 73, 74, 74, 75, 76, 77,
- 78, 79, 74, 80, 81, 82, 83, 84, 85, 86,
- 87, 74, 88, 89, 90, 91, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
-
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 1
- } ;
-
-static yyconst int yy_meta[92] =
- { 0,
- 1, 2, 3, 2, 4, 5, 6, 7, 8, 5,
- 5, 9, 6, 6, 5, 6, 10, 5, 5, 11,
- 11, 11, 11, 11, 11, 11, 5, 6, 5, 5,
- 5, 12, 13, 13, 13, 13, 13, 13, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 15, 16,
- 15, 12, 17, 18, 19, 19, 19, 19, 19, 19,
- 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
- 20, 20, 20, 20, 20, 20, 20, 21, 5, 22,
- 5
-
- } ;
-
-static yyconst short int yy_base[785] =
- { 0,
- 0, 0, 0, 4, 58, 138, 224, 2291, 0, 1,
- 3, 23, 311, 0, 396, 0, 50, 70, 487, 0,
- 2298, 2300, 2300, 2285, 2288, 2300, 2300, 2300, 131, 2260,
- 4, 0, 24, 54, 18, 2243, 2241, 2254, 5, 2240,
- 74, 2239, 2237, 2300, 0, 2300, 2300, 2300, 2300, 145,
- 2300, 2300, 2300, 0, 144, 0, 2281, 2275, 2300, 2300,
- 0, 2300, 5, 2268, 329, 338, 2258, 2300, 2267, 2252,
- 0, 2274, 2300, 0, 2300, 22, 2300, 54, 68, 105,
- 34, 109, 6, 117, 124, 133, 357, 135, 2264, 0,
- 2300, 0, 134, 0, 97, 2, 2273, 2267, 416, 571,
-
- 580, 130, 2214, 317, 0, 17, 591, 652, 197, 336,
- 333, 358, 330, 2260, 0, 2259, 2244, 2211, 2209, 340,
- 349, 2255, 2300, 2264, 2262, 2258, 2300, 366, 2300, 2251,
- 428, 2232, 159, 373, 146, 535, 161, 2215, 2213, 2226,
- 168, 2212, 577, 2211, 2209, 2300, 0, 2300, 2300, 2300,
- 2300, 615, 2300, 2300, 2300, 0, 2243, 2247, 2250, 2300,
- 621, 2214, 2212, 2300, 2209, 2300, 598, 2210, 2216, 2300,
- 2203, 2199, 2215, 290, 2300, 2300, 2300, 2300, 2300, 2206,
- 2204, 2300, 2300, 2207, 2300, 2190, 2211, 2198, 2300, 2300,
- 2300, 630, 0, 659, 0, 2236, 2300, 2230, 2300, 663,
-
- 0, 0, 652, 688, 659, 0, 0, 2300, 0, 2300,
- 2233, 0, 2177, 2172, 364, 365, 401, 648, 620, 602,
- 2230, 55, 661, 577, 618, 2229, 615, 404, 2228, 623,
- 625, 2227, 210, 2161, 0, 0, 2216, 2300, 0, 2300,
- 2144, 2224, 2222, 2217, 726, 737, 2300, 715, 746, 753,
- 0, 152, 2220, 0, 2210, 2214, 759, 785, 2162, 2161,
- 2163, 779, 399, 429, 2159, 2183, 2157, 2182, 751, 414,
- 2168, 2167, 395, 422, 666, 2166, 2137, 0, 575, 715,
- 599, 712, 717, 2300, 2124, 719, 2206, 2204, 2300, 2300,
- 2300, 2300, 2300, 2300, 2300, 2300, 2300, 2300, 2300, 2300,
-
- 2300, 2300, 2300, 2300, 2300, 2300, 2300, 2300, 2300, 2300,
- 2199, 2300, 813, 817, 826, 831, 823, 830, 0, 0,
- 2143, 722, 745, 624, 791, 683, 789, 784, 708, 790,
- 757, 793, 2201, 782, 794, 787, 816, 817, 865, 834,
- 2300, 837, 2131, 2300, 2199, 851, 0, 858, 897, 2198,
- 2124, 2139, 2139, 2194, 2189, 2110, 2191, 915, 2300, 2300,
- 2135, 2146, 847, 2148, 2143, 0, 2156, 2147, 2154, 2138,
- 2155, 2141, 0, 2125, 0, 2135, 2134, 2122, 0, 833,
- 267, 0, 2143, 852, 2132, 2145, 0, 2133, 2147, 2142,
- 0, 2135, 2097, 0, 879, 891, 2300, 909, 934, 2113,
-
- 2167, 853, 2166, 882, 886, 2165, 895, 896, 899, 901,
- 900, 907, 916, 2164, 2163, 917, 928, 418, 940, 985,
- 991, 995, 999, 1003, 2101, 2300, 1001, 2161, 2160, 1014,
- 2300, 2300, 2091, 2091, 2300, 2153, 2300, 1032, 2300, 2112,
- 2100, 2099, 2128, 2097, 2112, 2095, 2106, 881, 2110, 2103,
- 2118, 2120, 2102, 2111, 0, 2087, 0, 2112, 2112, 2108,
- 2102, 2100, 2107, 2108, 2079, 2093, 2090, 2089, 2073, 0,
- 938, 990, 1039, 0, 2129, 942, 945, 959, 960, 970,
- 967, 921, 1011, 954, 2128, 1064, 1068, 1072, 1079, 1083,
- 1087, 1091, 2130, 2300, 1077, 1110, 2071, 2058, 2300, 1090,
-
- 1117, 2082, 0, 2095, 2073, 0, 2066, 2093, 2075, 2063,
- 2075, 2061, 2060, 2059, 2071, 2083, 2056, 0, 2070, 2080,
- 2034, 2017, 2005, 2023, 1066, 1124, 2016, 1999, 1996, 1983,
- 1038, 1097, 2047, 2046, 2045, 2044, 1012, 1098, 2043, 1100,
- 1149, 1153, 1157, 1163, 1167, 1176, 1183, 1118, 2011, 1986,
- 2015, 1997, 1972, 1986, 1985, 1972, 0, 1978, 0, 1963,
- 1952, 1946, 1949, 0, 1918, 1941, 0, 1941, 0, 1906,
- 1913, 0, 1169, 1863, 1880, 0, 1829, 1862, 1111, 1156,
- 1116, 1165, 1198, 1202, 1209, 1217, 1224, 1228, 1238, 1172,
- 2300, 1193, 1833, 1828, 1829, 1827, 1769, 1778, 1735, 1733,
-
- 1744, 1757, 1755, 1729, 1710, 1194, 1720, 1726, 0, 1718,
- 0, 1718, 1671, 1691, 1669, 1207, 1658, 1244, 1248, 1252,
- 1269, 1278, 1284, 1291, 1591, 1617, 1599, 1594, 0, 1580,
- 0, 0, 1588, 1565, 1546, 1532, 0, 1531, 1530, 1528,
- 1538, 1526, 1545, 1509, 0, 1434, 1295, 1416, 1299, 1305,
- 1309, 1314, 1318, 0, 1368, 1367, 1378, 0, 1363, 0,
- 0, 0, 0, 0, 0, 1360, 1386, 1369, 0, 1324,
- 1393, 1241, 1333, 1337, 1346, 1350, 0, 0, 1341, 0,
- 0, 1346, 1309, 1356, 1220, 1361, 1366, 1370, 1374, 1309,
- 1308, 1270, 1217, 2300, 1313, 1335, 1343, 1270, 1238, 0,
-
- 1233, 1339, 1274, 1215, 1226, 1376, 1348, 0, 1206, 1219,
- 1347, 1203, 1188, 1356, 1181, 1146, 1361, 1015, 1011, 1345,
- 0, 993, 995, 950, 946, 940, 966, 909, 750, 682,
- 597, 586, 543, 434, 429, 1415, 1423, 319, 206, 26,
- 2300, 2300, 1449, 1471, 1493, 1515, 1537, 1556, 1567, 1398,
- 1580, 1593, 1612, 1628, 1636, 1656, 1678, 1700, 1718, 1737,
- 1747, 1764, 1780, 1797, 1816, 1838, 1402, 1852, 1872, 1894,
- 1916, 1936, 1953, 1405, 1969, 1989, 1245, 2005, 2022, 2043,
- 1625, 2052, 2072, 2094
- } ;
-
-static yyconst short int yy_def[785] =
- { 0,
- 743, 743, 744, 744, 745, 745, 742, 7, 746, 746,
- 7, 7, 7, 13, 7, 15, 747, 747, 742, 19,
- 742, 742, 742, 748, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 749, 742, 742, 742, 742, 742,
- 742, 742, 742, 750, 742, 751, 752, 753, 742, 742,
- 751, 742, 751, 751, 742, 742, 751, 742, 751, 751,
- 751, 754, 742, 751, 742, 755, 742, 754, 754, 754,
- 754, 754, 754, 754, 754, 754, 754, 754, 742, 751,
- 742, 751, 751, 756, 757, 758, 759, 760, 751, 742,
-
- 742, 755, 761, 742, 762, 99, 742, 755, 763, 763,
- 763, 763, 763, 742, 751, 751, 751, 755, 761, 754,
- 754, 742, 742, 764, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 749, 742, 742, 742,
- 742, 742, 742, 742, 742, 750, 742, 748, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 750, 742, 751, 752, 742, 765, 742, 766,
-
- 751, 751, 742, 742, 742, 767, 751, 742, 751, 742,
- 754, 768, 755, 768, 754, 754, 754, 754, 754, 754,
- 754, 754, 754, 754, 754, 754, 754, 754, 754, 754,
- 754, 742, 769, 742, 770, 771, 771, 742, 772, 742,
- 772, 773, 742, 765, 742, 742, 742, 742, 742, 742,
- 774, 768, 775, 776, 742, 765, 742, 742, 742, 742,
- 742, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 777, 778, 778,
- 778, 778, 778, 742, 742, 754, 779, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
-
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 765, 742, 766, 766, 742, 766, 742, 742, 767, 768,
- 768, 754, 754, 754, 754, 754, 754, 754, 754, 754,
- 754, 754, 754, 754, 754, 754, 754, 754, 780, 769,
- 742, 769, 742, 742, 742, 742, 781, 742, 742, 774,
- 768, 768, 742, 775, 776, 742, 742, 742, 742, 742,
- 742, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 782, 778, 778, 742, 742, 742, 768,
-
- 754, 754, 754, 754, 754, 754, 754, 754, 754, 754,
- 754, 754, 754, 754, 754, 754, 780, 417, 780, 780,
- 780, 780, 780, 780, 742, 742, 742, 781, 742, 742,
- 742, 742, 768, 768, 742, 742, 742, 742, 742, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 782,
- 778, 742, 742, 768, 754, 754, 754, 754, 754, 754,
- 754, 754, 754, 754, 754, 780, 780, 780, 780, 780,
- 780, 780, 742, 742, 742, 742, 768, 768, 742, 742,
-
- 742, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 754, 754, 754, 754, 754, 754, 754, 754, 754, 754,
- 780, 780, 780, 780, 780, 780, 780, 783, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 754, 754, 754,
- 754, 754, 780, 780, 780, 780, 780, 780, 780, 783,
- 742, 783, 768, 768, 768, 768, 768, 768, 768, 768,
-
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 754, 754, 754, 754, 780, 780, 780,
- 780, 780, 780, 780, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 754, 780, 784, 780, 780,
- 780, 780, 780, 768, 768, 768, 768, 768, 768, 768,
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 780,
- 784, 784, 780, 780, 780, 780, 768, 768, 768, 768,
- 768, 768, 768, 780, 784, 780, 780, 780, 780, 768,
- 768, 768, 689, 742, 784, 689, 689, 768, 768, 768,
-
- 689, 689, 689, 768, 768, 689, 689, 768, 768, 742,
- 689, 768, 742, 689, 768, 742, 689, 768, 742, 689,
- 768, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 0, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742
- } ;
-
-static yyconst short int yy_nxt[2392] =
- { 0,
- 23, 23, 23, 23, 23, 23, 23, 23, 742, 97,
- 742, 25, 742, 210, 98, 25, 95, 95, 240, 99,
- 742, 200, 100, 101, 101, 101, 101, 101, 101, 97,
- 93, 742, 165, 742, 98, 201, 246, 180, 742, 99,
- 163, 210, 100, 101, 101, 101, 101, 101, 101, 166,
- 123, 123, 123, 123, 164, 175, 125, 181, 167, 26,
- 168, 210, 210, 26, 28, 102, 103, 169, 176, 28,
- 123, 123, 123, 123, 224, 210, 125, 29, 29, 29,
- 29, 29, 29, 29, 213, 102, 103, 96, 96, 241,
- 30, 31, 32, 33, 34, 35, 36, 37, 170, 171,
-
- 172, 38, 214, 39, 173, 174, 220, 40, 41, 126,
- 42, 43, 210, 237, 183, 741, 210, 44, 215, 45,
- 184, 185, 46, 47, 210, 186, 187, 48, 216, 126,
- 188, 210, 217, 329, 49, 50, 218, 51, 233, 52,
- 210, 53, 210, 54, 28, 194, 194, 194, 194, 28,
- 161, 161, 161, 161, 161, 161, 161, 29, 29, 29,
- 29, 29, 29, 29, 192, 192, 192, 192, 192, 192,
- 30, 31, 32, 33, 34, 35, 36, 37, 221, 219,
- 167, 38, 168, 39, 222, 223, 238, 40, 41, 169,
- 42, 43, 213, 226, 225, 163, 252, 44, 175, 45,
-
- 180, 227, 46, 47, 210, 278, 231, 48, 234, 164,
- 214, 176, 341, 342, 49, 50, 351, 51, 352, 52,
- 181, 53, 740, 54, 22, 55, 55, 55, 55, 56,
- 57, 56, 56, 56, 56, 58, 59, 60, 61, 62,
- 63, 64, 56, 65, 66, 66, 66, 66, 66, 66,
- 67, 68, 69, 70, 56, 71, 72, 72, 72, 72,
- 72, 72, 72, 72, 72, 72, 72, 72, 72, 72,
- 72, 72, 72, 72, 72, 72, 72, 72, 72, 72,
- 72, 72, 73, 74, 75, 56, 76, 77, 72, 72,
- 78, 79, 80, 72, 72, 81, 82, 72, 83, 84,
-
- 72, 85, 72, 86, 72, 87, 72, 72, 88, 72,
- 72, 89, 90, 91, 92, 104, 458, 97, 194, 194,
- 194, 194, 105, 303, 255, 56, 739, 106, 56, 459,
- 107, 107, 107, 107, 107, 107, 107, 210, 278, 56,
- 210, 278, 56, 210, 278, 304, 203, 210, 204, 204,
- 204, 204, 204, 204, 204, 203, 210, 204, 204, 204,
- 204, 204, 204, 204, 210, 210, 278, 194, 194, 194,
- 194, 210, 210, 108, 103, 109, 109, 110, 109, 109,
- 109, 109, 109, 111, 109, 112, 109, 109, 113, 109,
- 109, 109, 109, 109, 109, 109, 109, 109, 114, 283,
-
- 280, 115, 22, 116, 217, 165, 205, 22, 210, 281,
- 56, 210, 117, 56, 206, 22, 22, 22, 22, 22,
- 22, 22, 166, 22, 56, 286, 282, 56, 228, 323,
- 385, 367, 200, 736, 229, 245, 246, 246, 246, 246,
- 246, 246, 386, 230, 322, 368, 201, 161, 161, 161,
- 161, 161, 161, 161, 380, 56, 486, 387, 118, 119,
- 381, 487, 72, 120, 72, 369, 370, 72, 121, 371,
- 72, 72, 336, 72, 388, 72, 382, 72, 389, 735,
- 72, 372, 324, 122, 56, 22, 115, 127, 128, 128,
- 128, 128, 127, 129, 127, 127, 127, 127, 129, 127,
-
- 127, 127, 127, 130, 127, 127, 131, 131, 131, 131,
- 131, 131, 131, 127, 127, 127, 127, 127, 127, 132,
- 133, 134, 135, 136, 137, 138, 139, 127, 127, 127,
- 140, 127, 141, 127, 127, 127, 142, 143, 127, 144,
- 145, 127, 127, 127, 127, 127, 146, 127, 147, 127,
- 127, 148, 149, 127, 127, 127, 150, 127, 127, 127,
- 127, 127, 127, 151, 152, 127, 153, 127, 154, 127,
- 155, 127, 156, 127, 157, 127, 127, 127, 247, 170,
- 171, 172, 210, 278, 210, 173, 174, 247, 248, 734,
- 249, 249, 249, 249, 249, 249, 249, 248, 247, 249,
-
- 249, 249, 249, 249, 249, 249, 210, 278, 257, 210,
- 258, 258, 258, 258, 258, 258, 258, 183, 294, 295,
- 296, 297, 210, 184, 185, 210, 733, 210, 186, 187,
- 210, 210, 210, 188, 192, 192, 192, 192, 192, 192,
- 161, 161, 161, 161, 161, 161, 161, 732, 250, 192,
- 192, 192, 192, 192, 192, 210, 251, 259, 333, 260,
- 194, 194, 194, 194, 314, 315, 316, 314, 210, 328,
- 261, 317, 317, 317, 317, 317, 317, 317, 318, 318,
- 318, 318, 318, 318, 262, 334, 263, 264, 403, 265,
- 210, 335, 266, 338, 267, 268, 269, 270, 271, 272,
-
- 327, 337, 273, 274, 275, 203, 276, 204, 204, 204,
- 204, 204, 204, 204, 213, 210, 390, 325, 252, 210,
- 278, 277, 210, 278, 210, 278, 210, 326, 391, 210,
- 330, 731, 214, 247, 348, 348, 348, 348, 348, 348,
- 348, 331, 332, 257, 247, 246, 246, 246, 246, 246,
- 246, 246, 210, 247, 257, 405, 246, 246, 246, 246,
- 246, 246, 246, 248, 210, 249, 249, 249, 249, 249,
- 249, 249, 349, 349, 349, 349, 349, 349, 358, 358,
- 358, 358, 358, 358, 358, 408, 730, 377, 378, 210,
- 401, 210, 247, 396, 210, 395, 210, 210, 210, 331,
-
- 210, 210, 257, 346, 258, 258, 258, 258, 258, 258,
- 258, 347, 362, 379, 314, 315, 316, 314, 314, 315,
- 316, 314, 363, 210, 210, 402, 364, 398, 398, 398,
- 398, 365, 314, 315, 316, 314, 341, 342, 410, 341,
- 342, 366, 317, 317, 317, 317, 317, 317, 317, 318,
- 318, 318, 318, 318, 318, 404, 407, 406, 413, 399,
- 210, 411, 409, 414, 412, 429, 417, 417, 417, 418,
- 427, 427, 427, 427, 427, 427, 456, 348, 348, 348,
- 348, 348, 348, 348, 415, 441, 210, 278, 461, 210,
- 442, 399, 462, 210, 430, 457, 416, 419, 210, 278,
-
- 421, 443, 210, 210, 431, 422, 210, 210, 210, 423,
- 398, 398, 398, 398, 210, 424, 349, 349, 349, 349,
- 349, 349, 429, 210, 210, 510, 430, 511, 210, 417,
- 417, 417, 417, 475, 358, 358, 358, 358, 358, 358,
- 358, 742, 742, 742, 742, 210, 278, 471, 472, 210,
- 472, 438, 210, 473, 473, 473, 473, 473, 473, 473,
- 419, 210, 729, 421, 476, 481, 210, 210, 422, 477,
- 728, 478, 423, 488, 210, 479, 727, 210, 424, 482,
- 726, 483, 725, 438, 480, 485, 742, 742, 742, 742,
- 538, 484, 742, 742, 742, 742, 742, 742, 742, 742,
-
- 742, 742, 742, 742, 742, 742, 742, 742, 431, 473,
- 473, 473, 473, 473, 473, 473, 531, 532, 210, 210,
- 427, 427, 427, 427, 427, 427, 540, 489, 495, 533,
- 495, 491, 724, 496, 496, 496, 496, 496, 496, 496,
- 490, 534, 723, 537, 535, 210, 500, 722, 500, 536,
- 492, 501, 501, 501, 501, 501, 501, 501, 473, 473,
- 473, 473, 473, 473, 473, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 721, 580, 539,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 496, 496, 496, 496,
-
- 496, 496, 496, 541, 210, 210, 571, 210, 542, 501,
- 501, 501, 501, 501, 501, 501, 544, 429, 210, 578,
- 591, 592, 543, 210, 429, 546, 545, 547, 572, 496,
- 496, 496, 496, 496, 496, 496, 501, 501, 501, 501,
- 501, 501, 501, 573, 573, 573, 573, 573, 573, 573,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 581, 210, 742, 742, 742, 742, 742, 742,
- 742, 742, 210, 579, 591, 592, 582, 742, 742, 742,
- 742, 614, 616, 583, 742, 742, 742, 742, 573, 573,
- 573, 573, 573, 573, 573, 591, 592, 719, 584, 742,
-
- 742, 742, 742, 742, 742, 742, 742, 587, 585, 586,
- 742, 742, 742, 742, 210, 718, 588, 589, 742, 742,
- 742, 742, 694, 695, 615, 742, 742, 742, 742, 742,
- 742, 742, 742, 716, 638, 617, 672, 715, 619, 742,
- 742, 742, 742, 639, 640, 742, 742, 742, 742, 742,
- 742, 742, 648, 742, 742, 742, 742, 672, 620, 713,
- 618, 701, 623, 394, 394, 706, 621, 420, 712, 622,
- 742, 742, 742, 742, 420, 646, 709, 708, 624, 742,
- 742, 742, 742, 420, 649, 742, 742, 742, 742, 705,
- 420, 647, 742, 742, 742, 742, 742, 742, 742, 742,
-
- 742, 742, 742, 742, 704, 650, 742, 742, 742, 742,
- 742, 742, 742, 742, 651, 742, 742, 742, 742, 742,
- 742, 742, 742, 653, 420, 742, 742, 742, 742, 672,
- 685, 420, 700, 673, 742, 742, 742, 742, 742, 742,
- 742, 742, 699, 698, 670, 692, 652, 742, 742, 742,
- 742, 742, 742, 742, 742, 674, 684, 742, 742, 742,
- 742, 676, 742, 742, 742, 742, 675, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 703,
- 710, 702, 707, 711, 686, 420, 691, 714, 687, 420,
- 689, 688, 420, 420, 693, 420, 420, 420, 420, 720,
-
- 420, 717, 420, 690, 420, 420, 420, 696, 193, 672,
- 193, 420, 319, 420, 319, 350, 193, 350, 420, 683,
- 319, 682, 681, 350, 697, 680, 420, 738, 679, 678,
- 677, 697, 672, 420, 737, 737, 737, 737, 737, 737,
- 737, 210, 737, 737, 737, 737, 737, 737, 737, 22,
- 22, 22, 22, 22, 22, 22, 22, 22, 22, 22,
- 22, 22, 22, 22, 22, 22, 22, 22, 22, 22,
- 22, 24, 24, 24, 24, 24, 24, 24, 24, 24,
- 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
- 24, 24, 24, 27, 27, 27, 27, 27, 27, 27,
-
- 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
- 27, 27, 27, 27, 27, 94, 94, 94, 94, 94,
- 94, 94, 94, 94, 94, 94, 94, 94, 94, 94,
- 94, 94, 94, 94, 94, 94, 94, 124, 124, 124,
- 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
- 124, 124, 124, 124, 124, 124, 124, 124, 124, 158,
- 158, 158, 158, 158, 158, 158, 158, 158, 158, 158,
- 158, 669, 158, 158, 158, 158, 158, 158, 191, 191,
- 191, 191, 191, 191, 195, 668, 195, 195, 667, 666,
- 665, 195, 664, 663, 662, 195, 196, 196, 196, 196,
-
- 196, 196, 196, 196, 196, 196, 196, 196, 661, 196,
- 196, 196, 196, 196, 196, 198, 198, 198, 198, 198,
- 198, 198, 198, 198, 198, 198, 198, 660, 198, 198,
- 198, 198, 198, 198, 211, 428, 211, 428, 211, 659,
- 211, 211, 658, 428, 211, 657, 211, 211, 212, 212,
- 656, 655, 212, 654, 212, 212, 235, 235, 235, 235,
- 235, 235, 235, 235, 235, 210, 235, 235, 235, 235,
- 235, 235, 235, 235, 235, 235, 210, 235, 236, 236,
- 236, 236, 236, 236, 236, 236, 236, 236, 236, 236,
- 236, 236, 236, 236, 236, 236, 236, 236, 210, 236,
-
- 239, 239, 239, 239, 239, 239, 239, 239, 239, 239,
- 239, 239, 239, 239, 239, 239, 239, 239, 239, 239,
- 239, 242, 242, 242, 242, 242, 242, 242, 242, 242,
- 242, 242, 242, 645, 242, 242, 242, 242, 242, 242,
- 244, 244, 244, 244, 244, 244, 244, 244, 244, 244,
- 244, 244, 644, 244, 244, 244, 244, 244, 244, 253,
- 253, 643, 642, 641, 253, 253, 253, 256, 256, 256,
- 256, 256, 637, 256, 256, 256, 256, 256, 256, 636,
- 256, 256, 256, 256, 256, 256, 279, 279, 279, 635,
- 279, 634, 279, 279, 633, 632, 279, 631, 279, 279,
-
- 287, 287, 287, 287, 287, 287, 287, 287, 287, 287,
- 287, 287, 630, 287, 287, 287, 287, 287, 287, 311,
- 311, 311, 311, 311, 311, 311, 311, 311, 311, 311,
- 311, 629, 311, 311, 311, 311, 311, 311, 313, 313,
- 313, 313, 313, 313, 313, 313, 313, 313, 313, 313,
- 313, 313, 313, 313, 313, 313, 313, 313, 313, 313,
- 320, 628, 320, 627, 320, 320, 626, 625, 320, 210,
- 320, 320, 340, 340, 340, 340, 340, 340, 340, 340,
- 340, 340, 340, 340, 340, 340, 340, 340, 340, 340,
- 340, 340, 340, 340, 235, 235, 235, 235, 235, 235,
-
- 235, 235, 235, 613, 235, 235, 235, 235, 235, 235,
- 235, 235, 235, 235, 612, 235, 236, 236, 236, 236,
- 236, 236, 236, 236, 236, 611, 236, 236, 236, 236,
- 236, 236, 236, 236, 236, 236, 239, 239, 239, 239,
- 239, 239, 239, 239, 239, 610, 239, 239, 239, 239,
- 239, 239, 239, 239, 239, 239, 242, 242, 242, 242,
- 242, 242, 242, 242, 242, 242, 242, 242, 609, 242,
- 242, 242, 242, 242, 242, 354, 608, 354, 607, 354,
- 606, 354, 354, 605, 604, 354, 603, 354, 354, 355,
- 355, 355, 355, 355, 355, 355, 355, 602, 355, 355,
-
- 355, 355, 355, 355, 355, 355, 355, 355, 355, 355,
- 355, 279, 279, 279, 601, 279, 600, 279, 279, 599,
- 598, 279, 597, 279, 279, 287, 287, 287, 287, 287,
- 287, 287, 287, 287, 287, 287, 287, 596, 287, 287,
- 287, 287, 287, 287, 420, 420, 420, 595, 594, 593,
- 210, 210, 210, 210, 210, 420, 420, 577, 576, 420,
- 470, 575, 470, 574, 470, 470, 570, 569, 470, 568,
- 470, 470, 590, 590, 590, 590, 590, 590, 590, 590,
- 590, 590, 590, 590, 590, 590, 590, 590, 590, 590,
- 590, 590, 590, 590, 671, 671, 567, 671, 671, 671,
-
- 671, 671, 671, 671, 671, 671, 671, 671, 671, 671,
- 671, 671, 671, 671, 671, 671, 566, 565, 564, 563,
- 562, 561, 560, 559, 558, 557, 556, 555, 554, 553,
- 552, 551, 550, 549, 548, 210, 210, 530, 529, 528,
- 527, 526, 525, 524, 523, 522, 521, 520, 519, 518,
- 517, 516, 515, 514, 513, 512, 509, 508, 507, 506,
- 505, 504, 503, 502, 499, 498, 497, 494, 432, 493,
- 210, 210, 210, 210, 210, 474, 469, 468, 467, 466,
- 465, 464, 463, 460, 455, 454, 453, 452, 451, 450,
- 449, 448, 447, 446, 445, 444, 440, 439, 426, 437,
-
- 436, 353, 435, 434, 433, 432, 426, 425, 210, 400,
- 742, 289, 288, 397, 393, 392, 384, 383, 376, 375,
- 374, 373, 361, 360, 359, 357, 356, 353, 345, 344,
- 243, 241, 237, 343, 339, 210, 210, 210, 321, 213,
- 210, 312, 197, 310, 309, 308, 307, 306, 305, 302,
- 301, 300, 299, 298, 293, 292, 291, 160, 159, 284,
- 190, 189, 182, 179, 178, 177, 162, 200, 290, 289,
- 288, 284, 742, 213, 201, 285, 284, 254, 199, 243,
- 232, 210, 209, 208, 207, 202, 199, 197, 190, 189,
- 182, 179, 178, 177, 162, 160, 159, 742, 93, 21,
-
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742
-
- } ;
-
-static yyconst short int yy_chk[2392] =
- { 0,
- 3, 3, 3, 3, 4, 4, 4, 4, 0, 11,
- 0, 3, 0, 83, 11, 4, 9, 10, 96, 11,
- 0, 63, 11, 11, 11, 11, 11, 11, 11, 12,
- 12, 0, 32, 106, 12, 63, 106, 39, 0, 12,
- 31, 81, 12, 12, 12, 12, 12, 12, 12, 32,
- 17, 17, 17, 17, 31, 35, 17, 39, 33, 3,
- 33, 78, 222, 4, 5, 11, 11, 33, 35, 5,
- 18, 18, 18, 18, 83, 79, 18, 5, 5, 5,
- 5, 5, 5, 5, 76, 12, 12, 9, 10, 96,
- 5, 5, 5, 5, 5, 5, 5, 5, 34, 34,
-
- 34, 5, 76, 5, 34, 34, 81, 5, 5, 17,
- 5, 5, 80, 95, 41, 740, 82, 5, 78, 5,
- 41, 41, 5, 5, 84, 41, 41, 5, 78, 18,
- 41, 85, 79, 222, 5, 5, 79, 5, 93, 5,
- 86, 5, 88, 5, 6, 55, 55, 55, 55, 6,
- 29, 29, 29, 29, 29, 29, 29, 6, 6, 6,
- 6, 6, 6, 6, 50, 50, 50, 50, 50, 50,
- 6, 6, 6, 6, 6, 6, 6, 6, 82, 80,
- 135, 6, 135, 6, 82, 82, 95, 6, 6, 135,
- 6, 6, 102, 85, 84, 133, 102, 6, 137, 6,
-
- 141, 86, 6, 6, 109, 109, 88, 6, 93, 133,
- 102, 137, 233, 233, 6, 6, 252, 6, 252, 6,
- 141, 6, 739, 6, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
-
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 13, 381, 13, 104, 104,
- 104, 104, 13, 174, 104, 13, 738, 13, 13, 381,
- 13, 13, 13, 13, 13, 13, 13, 113, 113, 13,
- 111, 111, 13, 110, 110, 174, 65, 120, 65, 65,
- 65, 65, 65, 65, 65, 66, 121, 66, 66, 66,
- 66, 66, 66, 66, 87, 112, 112, 128, 128, 128,
- 128, 215, 216, 13, 13, 13, 13, 13, 13, 13,
- 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
- 13, 13, 13, 13, 13, 13, 13, 13, 13, 113,
-
- 110, 13, 15, 15, 120, 134, 65, 15, 217, 111,
- 15, 228, 15, 15, 65, 15, 15, 15, 15, 15,
- 15, 15, 134, 15, 15, 121, 112, 15, 87, 216,
- 273, 263, 99, 735, 87, 99, 99, 99, 99, 99,
- 99, 99, 273, 87, 215, 263, 99, 131, 131, 131,
- 131, 131, 131, 131, 270, 15, 418, 273, 15, 15,
- 270, 418, 15, 15, 15, 264, 264, 15, 15, 264,
- 15, 15, 228, 15, 274, 15, 270, 15, 274, 734,
- 15, 264, 217, 15, 15, 15, 15, 19, 19, 19,
- 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
-
- 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
- 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
- 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
- 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
- 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
- 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
- 19, 19, 19, 19, 19, 19, 19, 19, 19, 19,
- 19, 19, 19, 19, 19, 19, 19, 19, 100, 136,
- 136, 136, 279, 279, 224, 136, 136, 101, 100, 733,
- 100, 100, 100, 100, 100, 100, 100, 101, 107, 101,
-
- 101, 101, 101, 101, 101, 101, 281, 281, 107, 220,
- 107, 107, 107, 107, 107, 107, 107, 143, 167, 167,
- 167, 167, 227, 143, 143, 225, 732, 219, 143, 143,
- 230, 324, 231, 143, 152, 152, 152, 152, 152, 152,
- 161, 161, 161, 161, 161, 161, 161, 731, 100, 192,
- 192, 192, 192, 192, 192, 218, 100, 108, 224, 108,
- 194, 194, 194, 194, 200, 200, 200, 200, 223, 220,
- 108, 203, 203, 203, 203, 203, 203, 203, 205, 205,
- 205, 205, 205, 205, 108, 225, 108, 108, 324, 108,
- 326, 227, 108, 231, 108, 108, 108, 108, 108, 108,
-
- 219, 230, 108, 108, 108, 204, 108, 204, 204, 204,
- 204, 204, 204, 204, 108, 329, 275, 218, 108, 282,
- 282, 108, 280, 280, 283, 283, 286, 218, 275, 322,
- 223, 730, 108, 245, 248, 248, 248, 248, 248, 248,
- 248, 223, 223, 245, 246, 245, 245, 245, 245, 245,
- 245, 245, 323, 249, 246, 326, 246, 246, 246, 246,
- 246, 246, 246, 249, 331, 249, 249, 249, 249, 249,
- 249, 249, 250, 250, 250, 250, 250, 250, 257, 257,
- 257, 257, 257, 257, 257, 329, 729, 269, 269, 334,
- 322, 328, 258, 282, 336, 280, 327, 330, 325, 286,
-
- 332, 335, 258, 245, 258, 258, 258, 258, 258, 258,
- 258, 245, 262, 269, 313, 313, 313, 313, 314, 314,
- 314, 314, 262, 337, 338, 323, 262, 315, 315, 315,
- 315, 262, 316, 316, 316, 316, 340, 340, 331, 342,
- 342, 262, 317, 317, 317, 317, 317, 317, 317, 318,
- 318, 318, 318, 318, 318, 325, 328, 327, 335, 317,
- 402, 332, 330, 336, 334, 348, 339, 339, 339, 339,
- 346, 346, 346, 346, 346, 346, 380, 348, 348, 348,
- 348, 348, 348, 348, 337, 363, 395, 395, 384, 404,
- 363, 317, 384, 405, 348, 380, 338, 339, 396, 396,
-
- 339, 363, 407, 408, 349, 339, 409, 411, 410, 339,
- 398, 398, 398, 398, 412, 339, 349, 349, 349, 349,
- 349, 349, 358, 413, 416, 448, 348, 448, 482, 417,
- 417, 417, 417, 402, 358, 358, 358, 358, 358, 358,
- 358, 419, 419, 419, 419, 471, 471, 395, 399, 476,
- 399, 358, 477, 399, 399, 399, 399, 399, 399, 399,
- 417, 484, 728, 417, 404, 410, 478, 479, 417, 405,
- 727, 407, 417, 419, 481, 408, 726, 480, 417, 411,
- 725, 412, 724, 358, 409, 416, 420, 420, 420, 420,
- 482, 413, 421, 421, 421, 421, 422, 422, 422, 422,
-
- 423, 423, 423, 423, 424, 424, 424, 424, 427, 472,
- 472, 472, 472, 472, 472, 472, 476, 477, 483, 537,
- 427, 427, 427, 427, 427, 427, 484, 421, 430, 478,
- 430, 423, 723, 430, 430, 430, 430, 430, 430, 430,
- 422, 479, 722, 481, 480, 531, 438, 719, 438, 480,
- 424, 438, 438, 438, 438, 438, 438, 438, 473, 473,
- 473, 473, 473, 473, 473, 486, 486, 486, 486, 487,
- 487, 487, 487, 488, 488, 488, 488, 718, 537, 483,
- 489, 489, 489, 489, 490, 490, 490, 490, 491, 491,
- 491, 491, 492, 492, 492, 492, 495, 495, 495, 495,
-
- 495, 495, 495, 486, 532, 538, 525, 540, 487, 500,
- 500, 500, 500, 500, 500, 500, 489, 496, 579, 531,
- 548, 548, 488, 581, 501, 491, 490, 492, 525, 496,
- 496, 496, 496, 496, 496, 496, 501, 501, 501, 501,
- 501, 501, 501, 526, 526, 526, 526, 526, 526, 526,
- 541, 541, 541, 541, 542, 542, 542, 542, 543, 543,
- 543, 543, 538, 580, 544, 544, 544, 544, 545, 545,
- 545, 545, 582, 532, 590, 590, 540, 546, 546, 546,
- 546, 579, 581, 541, 547, 547, 547, 547, 573, 573,
- 573, 573, 573, 573, 573, 592, 592, 716, 542, 583,
-
- 583, 583, 583, 584, 584, 584, 584, 545, 543, 544,
- 585, 585, 585, 585, 616, 715, 546, 547, 586, 586,
- 586, 586, 685, 685, 580, 587, 587, 587, 587, 588,
- 588, 588, 588, 713, 606, 582, 685, 712, 584, 589,
- 589, 589, 589, 606, 606, 618, 618, 618, 618, 619,
- 619, 619, 619, 620, 620, 620, 620, 672, 585, 710,
- 583, 693, 588, 777, 777, 701, 586, 693, 709, 587,
- 621, 621, 621, 621, 693, 616, 705, 704, 589, 622,
- 622, 622, 622, 701, 620, 623, 623, 623, 623, 699,
- 701, 618, 624, 624, 624, 624, 647, 647, 647, 647,
-
- 649, 649, 649, 649, 698, 621, 650, 650, 650, 650,
- 651, 651, 651, 651, 622, 652, 652, 652, 652, 653,
- 653, 653, 653, 624, 703, 670, 670, 670, 670, 695,
- 672, 703, 692, 649, 673, 673, 673, 673, 674, 674,
- 674, 674, 691, 690, 647, 683, 623, 675, 675, 675,
- 675, 676, 676, 676, 676, 650, 670, 684, 684, 684,
- 684, 653, 686, 686, 686, 686, 652, 687, 687, 687,
- 687, 688, 688, 688, 688, 689, 689, 689, 689, 697,
- 706, 696, 702, 707, 673, 696, 682, 711, 674, 702,
- 676, 675, 696, 697, 684, 720, 702, 711, 707, 717,
-
- 697, 714, 720, 679, 711, 707, 714, 688, 750, 671,
- 750, 717, 767, 714, 767, 774, 750, 774, 717, 668,
- 767, 667, 666, 774, 689, 659, 706, 737, 657, 656,
- 655, 689, 648, 706, 736, 736, 736, 736, 736, 736,
- 736, 646, 737, 737, 737, 737, 737, 737, 737, 743,
- 743, 743, 743, 743, 743, 743, 743, 743, 743, 743,
- 743, 743, 743, 743, 743, 743, 743, 743, 743, 743,
- 743, 744, 744, 744, 744, 744, 744, 744, 744, 744,
- 744, 744, 744, 744, 744, 744, 744, 744, 744, 744,
- 744, 744, 744, 745, 745, 745, 745, 745, 745, 745,
-
- 745, 745, 745, 745, 745, 745, 745, 745, 745, 745,
- 745, 745, 745, 745, 745, 746, 746, 746, 746, 746,
- 746, 746, 746, 746, 746, 746, 746, 746, 746, 746,
- 746, 746, 746, 746, 746, 746, 746, 747, 747, 747,
- 747, 747, 747, 747, 747, 747, 747, 747, 747, 747,
- 747, 747, 747, 747, 747, 747, 747, 747, 747, 748,
- 748, 748, 748, 748, 748, 748, 748, 748, 748, 748,
- 748, 644, 748, 748, 748, 748, 748, 748, 749, 749,
- 749, 749, 749, 749, 751, 643, 751, 751, 642, 641,
- 640, 751, 639, 638, 636, 751, 752, 752, 752, 752,
-
- 752, 752, 752, 752, 752, 752, 752, 752, 635, 752,
- 752, 752, 752, 752, 752, 753, 753, 753, 753, 753,
- 753, 753, 753, 753, 753, 753, 753, 634, 753, 753,
- 753, 753, 753, 753, 754, 781, 754, 781, 754, 633,
- 754, 754, 630, 781, 754, 628, 754, 754, 755, 755,
- 627, 626, 755, 625, 755, 755, 756, 756, 756, 756,
- 756, 756, 756, 756, 756, 617, 756, 756, 756, 756,
- 756, 756, 756, 756, 756, 756, 615, 756, 757, 757,
- 757, 757, 757, 757, 757, 757, 757, 757, 757, 757,
- 757, 757, 757, 757, 757, 757, 757, 757, 614, 757,
-
- 758, 758, 758, 758, 758, 758, 758, 758, 758, 758,
- 758, 758, 758, 758, 758, 758, 758, 758, 758, 758,
- 758, 759, 759, 759, 759, 759, 759, 759, 759, 759,
- 759, 759, 759, 613, 759, 759, 759, 759, 759, 759,
- 760, 760, 760, 760, 760, 760, 760, 760, 760, 760,
- 760, 760, 612, 760, 760, 760, 760, 760, 760, 761,
- 761, 610, 608, 607, 761, 761, 761, 762, 762, 762,
- 762, 762, 605, 762, 762, 762, 762, 762, 762, 604,
- 762, 762, 762, 762, 762, 762, 763, 763, 763, 603,
- 763, 602, 763, 763, 601, 600, 763, 599, 763, 763,
-
- 764, 764, 764, 764, 764, 764, 764, 764, 764, 764,
- 764, 764, 598, 764, 764, 764, 764, 764, 764, 765,
- 765, 765, 765, 765, 765, 765, 765, 765, 765, 765,
- 765, 597, 765, 765, 765, 765, 765, 765, 766, 766,
- 766, 766, 766, 766, 766, 766, 766, 766, 766, 766,
- 766, 766, 766, 766, 766, 766, 766, 766, 766, 766,
- 768, 596, 768, 595, 768, 768, 594, 593, 768, 578,
- 768, 768, 769, 769, 769, 769, 769, 769, 769, 769,
- 769, 769, 769, 769, 769, 769, 769, 769, 769, 769,
- 769, 769, 769, 769, 770, 770, 770, 770, 770, 770,
-
- 770, 770, 770, 577, 770, 770, 770, 770, 770, 770,
- 770, 770, 770, 770, 575, 770, 771, 771, 771, 771,
- 771, 771, 771, 771, 771, 574, 771, 771, 771, 771,
- 771, 771, 771, 771, 771, 771, 772, 772, 772, 772,
- 772, 772, 772, 772, 772, 571, 772, 772, 772, 772,
- 772, 772, 772, 772, 772, 772, 773, 773, 773, 773,
- 773, 773, 773, 773, 773, 773, 773, 773, 570, 773,
- 773, 773, 773, 773, 773, 775, 568, 775, 566, 775,
- 565, 775, 775, 563, 562, 775, 561, 775, 775, 776,
- 776, 776, 776, 776, 776, 776, 776, 560, 776, 776,
-
- 776, 776, 776, 776, 776, 776, 776, 776, 776, 776,
- 776, 778, 778, 778, 558, 778, 556, 778, 778, 555,
- 554, 778, 553, 778, 778, 779, 779, 779, 779, 779,
- 779, 779, 779, 779, 779, 779, 779, 552, 779, 779,
- 779, 779, 779, 779, 780, 780, 780, 551, 550, 549,
- 539, 536, 535, 534, 533, 780, 780, 530, 529, 780,
- 782, 528, 782, 527, 782, 782, 524, 523, 782, 522,
- 782, 782, 783, 783, 783, 783, 783, 783, 783, 783,
- 783, 783, 783, 783, 783, 783, 783, 783, 783, 783,
- 783, 783, 783, 783, 784, 784, 521, 784, 784, 784,
-
- 784, 784, 784, 784, 784, 784, 784, 784, 784, 784,
- 784, 784, 784, 784, 784, 784, 520, 519, 517, 516,
- 515, 514, 513, 512, 511, 510, 509, 508, 507, 505,
- 504, 502, 498, 497, 493, 485, 475, 469, 468, 467,
- 466, 465, 464, 463, 462, 461, 460, 459, 458, 456,
- 454, 453, 452, 451, 450, 449, 447, 446, 445, 444,
- 443, 442, 441, 440, 436, 434, 433, 429, 428, 425,
- 415, 414, 406, 403, 401, 400, 393, 392, 390, 389,
- 388, 386, 385, 383, 378, 377, 376, 374, 372, 371,
- 370, 369, 368, 367, 365, 364, 362, 361, 357, 356,
-
- 355, 354, 353, 352, 351, 350, 345, 343, 333, 321,
- 311, 288, 287, 285, 277, 276, 272, 271, 268, 267,
- 266, 265, 261, 260, 259, 256, 255, 253, 244, 243,
- 242, 241, 237, 234, 232, 229, 226, 221, 214, 213,
- 211, 198, 196, 188, 187, 186, 184, 181, 180, 173,
- 172, 171, 169, 168, 165, 163, 162, 159, 158, 157,
- 145, 144, 142, 140, 139, 138, 132, 130, 126, 125,
- 124, 122, 119, 118, 117, 116, 114, 103, 98, 97,
- 89, 72, 70, 69, 67, 64, 58, 57, 43, 42,
- 40, 38, 37, 36, 30, 25, 24, 21, 8, 742,
-
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742, 742, 742, 742, 742, 742, 742, 742, 742, 742,
- 742
-
- } ;
-
-static yy_state_type yy_last_accepting_state;
-static char *yy_last_accepting_cpos;
-
-/* The intent behind this definition is that it'll catch
- * any uses of REJECT which flex missed.
- */
-#define REJECT reject_used_but_not_detected
-#define yymore() yymore_used_but_not_detected
-#define YY_MORE_ADJ 0
-char *yytext;
-#line 1 "yaccParser/hslexer.flex"
-#define INITIAL 0
-#line 2 "yaccParser/hslexer.flex"
-/**********************************************************************
-* *
-* *
-* LEX grammar for Haskell. *
-* ------------------------ *
-* *
-* (c) Copyright K. Hammond, University of Glasgow, *
-* 10th. February 1989 *
-* *
-* Modification History *
-* -------------------- *
-* *
-* 22/08/91 kh Initial Haskell 1.1 version. *
-* 18/10/91 kh Added 'ccall'. *
-* 19/11/91 kh Tidied generally. *
-* 04/12/91 kh Added Int#. *
-* 31/01/92 kh Haskell 1.2 version. *
-* 24/04/92 ps Added 'scc'. *
-* 03/06/92 kh Changed Infix/Prelude Handling. *
-* 23/08/93 jsm Changed to support flex *
-* *
-* *
-* Known Problems: *
-* *
-* None, any more. *
-* *
-**********************************************************************/
-
-#include "../../includes/config.h"
-
-#include <stdio.h>
-
-#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
-#include <string.h>
-/* An ANSI string.h and pre-ANSI memory.h might conflict. */
-#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
-#include <memory.h>
-#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
-#define index strchr
-#define rindex strrchr
-#define bcopy(s, d, n) memcpy ((d), (s), (n))
-#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
-#define bzero(s, n) memset ((s), 0, (n))
-#else /* not STDC_HEADERS and not HAVE_STRING_H */
-#include <strings.h>
-/* memory.h and strings.h conflict on some systems. */
-#endif /* not STDC_HEADERS and not HAVE_STRING_H */
-
-#include "hspincl.h"
-#include "hsparser.tab.h"
-#include "constants.h"
-#include "utils.h"
-
-/* Our substitute for <ctype.h> */
-
-#define NCHARS 256
-#define _S 0x1
-#define _D 0x2
-#define _H 0x4
-#define _O 0x8
-#define _C 0x10
-
-#define _isconstr(s) (CharTable[*s]&(_C))
-BOOLEAN isconstr PROTO((char *)); /* fwd decl */
-
-static unsigned char CharTable[NCHARS] = {
-/* nul */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* bs */ 0, _S, _S, _S, _S, 0, 0, 0,
-/* dle */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* can */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* sp */ _S, 0, 0, 0, 0, 0, 0, 0,
-/* '(' */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* '0' */ _D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,
-/* '8' */ _D|_H, _D|_H, _C, 0, 0, 0, 0, 0,
-/* '@' */ 0, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _C,
-/* 'H' */ _C, _C, _C, _C, _C, _C, _C, _C,
-/* 'P' */ _C, _C, _C, _C, _C, _C, _C, _C,
-/* 'X' */ _C, _C, _C, 0, 0, 0, 0, 0,
-/* '`' */ 0, _H, _H, _H, _H, _H, _H, 0,
-/* 'h' */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* 'p' */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* 'x' */ 0, 0, 0, 0, 0, 0, 0, 0,
-
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-};
-
-/**********************************************************************
-* *
-* *
-* Declarations *
-* *
-* *
-**********************************************************************/
-
-char *input_filename = NULL; /* Always points to a dynamically allocated string */
-
-/*
- * For my own sanity, things that are not part of the flex skeleton
- * have been renamed as hsXXXXX rather than yyXXXXX. --JSM
- */
-
-static int hslineno = 0; /* Line number at end of token */
-int hsplineno = 0; /* Line number at end of previous token */
-
-static int hscolno = 0; /* Column number at end of token */
-int hspcolno = 0; /* Column number at end of previous token */
-static int hsmlcolno = 0; /* Column number for multiple-rule lexemes */
-
-int startlineno = 0; /* The line number where something starts */
-int endlineno = 0; /* The line number where something ends */
-
-static BOOLEAN noGap = TRUE; /* For checking string gaps */
-static BOOLEAN forgetindent = FALSE; /* Don't bother applying indentation rules */
-
-static int nested_comments; /* For counting comment nesting depth */
-
-/* Hacky definition of yywrap: see flex doc.
-
- If we don't do this, then we'll have to get the default
- yywrap from the flex library, which is often something
- we are not good at locating. This avoids that difficulty.
- (Besides which, this is the way old flexes (pre 2.4.x) did it.)
- WDP 94/09/05
-*/
-#define yywrap() 1
-
-/* Essential forward declarations */
-
-static void hsnewid PROTO((char *, int));
-static void layout_input PROTO((char *, int));
-static void cleartext (NO_ARGS);
-static void addtext PROTO((char *, unsigned));
-static void addchar PROTO((char));
-static char *fetchtext PROTO((unsigned *));
-static void new_filename PROTO((char *));
-static int Return PROTO((int));
-static void hsentercontext PROTO((int));
-
-/* Special file handling for IMPORTS */
-/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */
-
-static YY_BUFFER_STATE hsbuf_save = NULL; /* Saved input buffer */
-static char *filename_save; /* File Name */
-static int hslineno_save = 0, /* Line Number */
- hsplineno_save = 0, /* Line Number of Prev. token */
- hscolno_save = 0, /* Indentation */
- hspcolno_save = 0; /* Left Indentation */
-static short icontexts_save = 0; /* Indent Context Level */
-
-static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */
-extern BOOLEAN etags; /* that which is saved */
-
-extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */
-
-static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */
-
-extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */
-extern int minAcceptablePragmaVersion; /* see documentation in main.c */
-extern int maxAcceptablePragmaVersion;
-extern int thisIfacePragmaVersion;
-
-static int hssttok = -1; /* Stacked Token: -1 -- no token; -ve -- ";"
- * inserted before token +ve -- "}" inserted before
- * token */
-
-short icontexts = 0; /* Which context we're in */
-
-
-
-/*
- Table of indentations: right bit indicates whether to use
- indentation rules (1 = use rules; 0 = ignore)
-
- partain:
- push one of these "contexts" at every "case" or "where"; the right bit says
- whether user supplied braces, etc., or not. pop appropriately (hsendindent).
-
- ALSO, a push/pop when enter/exit a new file (e.g., on importing). A -1 is
- pushed (the "column" for "module", "interface" and EOF). The -1 from the initial
- push is shown just below.
-
-*/
-
-
-static short indenttab[MAX_CONTEXTS] = {-1};
-
-#define INDENTPT (indenttab[icontexts]>>1)
-#define INDENTON (indenttab[icontexts]&1)
-
-#define RETURN(tok) return(Return(tok))
-
-#undef YY_DECL
-#define YY_DECL int yylex1()
-
-/* We should not peek at yy_act, but flex calls us even for the internal action
- triggered on 'end-of-buffer' (This is not true of flex 2.4.4 and up, but
- to support older versions of flex, we'll continue to peek for now.
- */
-#define YY_USER_ACTION \
- if (yy_act != YY_END_OF_BUFFER) layout_input(yytext, yyleng);
-
-#if 0/*debug*/
-#undef YY_BREAK
-#define YY_BREAK if (etags) fprintf(stderr,"%d %d / %d %d / %d\n",hsplineno,hspcolno,hslineno,hscolno,startlineno); break;
-#endif
-
-/* Each time we enter a new start state, we push it onto the state stack.
- Note that the rules do not allow us to underflow or overflow the stack.
- (At least, they shouldn't.) The maximum expected depth is 4:
- 0: Code -> 1: String -> 2: StringEsc -> 3: Comment
-*/
-static int StateStack[5];
-static int StateDepth = -1;
-
-#ifdef HSP_DEBUG
-#define PUSH_STATE(n) do {\
- fprintf(stderr,"Pushing %d (%d)\n", n, StateDepth + 1);\
- StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
-#define POP_STATE do {--StateDepth;\
- fprintf(stderr,"Popping %d (%d)\n", StateStack[StateDepth], StateDepth);\
- BEGIN(StateStack[StateDepth]);} while(0)
-#else
-#define PUSH_STATE(n) do {StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
-#define POP_STATE do {--StateDepth; BEGIN(StateStack[StateDepth]);} while(0)
-#endif
-
-/* The start states are:
- Code -- normal Haskell code (principal lexer)
- GlaExt -- Haskell code with Glasgow extensions
- Comment -- Nested comment processing
- String -- Inside a string literal with backslashes
- StringEsc -- Immediately following a backslash in a string literal
- Char -- Inside a character literal with backslashes
- CharEsc -- Immediately following a backslash in a character literal
-
- Note that the INITIAL state is unused. Also note that these states
- are _exclusive_. All rules should be prefixed with an appropriate
- list of start states.
- */
-#define Char 1
-#define CharEsc 2
-#define Code 3
-#define Comment 4
-#define GlaExt 5
-#define GhcPragma 6
-#define UserPragma 7
-#define String 8
-#define StringEsc 9
-
-
-/* Macros after this point can all be overridden by user definitions in
- * section 1.
- */
-
-#ifndef YY_SKIP_YYWRAP
-#ifdef __cplusplus
-extern "C" int yywrap YY_PROTO(( void ));
-#else
-extern int yywrap YY_PROTO(( void ));
-#endif
-#endif
-
-#ifndef YY_NO_UNPUT
-static void yyunput YY_PROTO(( int c, char *buf_ptr ));
-#endif
-
-#ifndef yytext_ptr
-static void yy_flex_strncpy YY_PROTO(( char *, yyconst char *, int ));
-#endif
-
-#ifndef YY_NO_INPUT
-#ifdef __cplusplus
-static int yyinput YY_PROTO(( void ));
-#else
-static int input YY_PROTO(( void ));
-#endif
-#endif
-
-#if YY_STACK_USED
-static int yy_start_stack_ptr = 0;
-static int yy_start_stack_depth = 0;
-static int *yy_start_stack = 0;
-#ifndef YY_NO_PUSH_STATE
-static void yy_push_state YY_PROTO(( int new_state ));
-#endif
-#ifndef YY_NO_POP_STATE
-static void yy_pop_state YY_PROTO(( void ));
-#endif
-#ifndef YY_NO_TOP_STATE
-static int yy_top_state YY_PROTO(( void ));
-#endif
-
-#else
-#define YY_NO_PUSH_STATE 1
-#define YY_NO_POP_STATE 1
-#define YY_NO_TOP_STATE 1
-#endif
-
-#ifdef YY_MALLOC_DECL
-YY_MALLOC_DECL
-#else
-#if __STDC__
-#ifndef __cplusplus
-#include <stdlib.h>
-#endif
-#else
-/* Just try to get by without declaring the routines. This will fail
- * miserably on non-ANSI systems for which sizeof(size_t) != sizeof(int)
- * or sizeof(void*) != sizeof(int).
- */
-#endif
-#endif
-
-/* Amount of stuff to slurp up with each read. */
-#ifndef YY_READ_BUF_SIZE
-#define YY_READ_BUF_SIZE 8192
-#endif
-
-/* Copy whatever the last rule matched to the standard output. */
-
-#ifndef ECHO
-/* This used to be an fputs(), but since the string might contain NUL's,
- * we now use fwrite().
- */
-#define ECHO (void) fwrite( yytext, yyleng, 1, yyout )
-#endif
-
-/* Gets input and stuffs it into "buf". number of characters read, or YY_NULL,
- * is returned in "result".
- */
-#ifndef YY_INPUT
-#define YY_INPUT(buf,result,max_size) \
- if ( yy_current_buffer->yy_is_interactive ) \
- { \
- int c = '*', n; \
- for ( n = 0; n < max_size && \
- (c = getc( yyin )) != EOF && c != '\n'; ++n ) \
- buf[n] = (char) c; \
- if ( c == '\n' ) \
- buf[n++] = (char) c; \
- if ( c == EOF && ferror( yyin ) ) \
- YY_FATAL_ERROR( "input in flex scanner failed" ); \
- result = n; \
- } \
- else if ( ((result = fread( buf, 1, max_size, yyin )) == 0) \
- && ferror( yyin ) ) \
- YY_FATAL_ERROR( "input in flex scanner failed" );
-#endif
-
-/* No semi-colon after return; correct usage is to write "yyterminate();" -
- * we don't want an extra ';' after the "return" because that will cause
- * some compilers to complain about unreachable statements.
- */
-#ifndef yyterminate
-#define yyterminate() return YY_NULL
-#endif
-
-/* Number of entries by which start-condition stack grows. */
-#ifndef YY_START_STACK_INCR
-#define YY_START_STACK_INCR 25
-#endif
-
-/* Report a fatal error. */
-#ifndef YY_FATAL_ERROR
-#define YY_FATAL_ERROR(msg) yy_fatal_error( msg )
-#endif
-
-/* Default declaration of generated scanner - a define so the user can
- * easily add parameters.
- */
-#ifndef YY_DECL
-#define YY_DECL int yylex YY_PROTO(( void ))
-#endif
-
-/* Code executed at the beginning of each rule, after yytext and yyleng
- * have been set up.
- */
-#ifndef YY_USER_ACTION
-#define YY_USER_ACTION
-#endif
-
-/* Code executed at the end of each rule. */
-#ifndef YY_BREAK
-#define YY_BREAK break;
-#endif
-
-#define YY_RULE_SETUP \
- if ( yyleng > 0 ) \
- yy_current_buffer->yy_at_bol = \
- (yytext[yyleng - 1] == '\n'); \
- YY_USER_ACTION
-
-YY_DECL
- {
- register yy_state_type yy_current_state;
- register char *yy_cp, *yy_bp;
- register int yy_act;
-
-#line 277 "yaccParser/hslexer.flex"
-
-
-
- /*
- * Special GHC pragma rules. Do we need a start state for interface files,
- * so these won't be matched in source files? --JSM
- */
-
-
-
- if ( yy_init )
- {
- yy_init = 0;
-
-#ifdef YY_USER_INIT
- YY_USER_INIT;
-#endif
-
- if ( ! yy_start )
- yy_start = 1; /* first start state */
-
- if ( ! yyin )
- yyin = stdin;
-
- if ( ! yyout )
- yyout = stdout;
-
- if ( ! yy_current_buffer )
- yy_current_buffer =
- yy_create_buffer( yyin, YY_BUF_SIZE );
-
- yy_load_buffer_state();
- }
-
- while ( 1 ) /* loops until end-of-file is reached */
- {
- yy_cp = yy_c_buf_p;
-
- /* Support of yytext. */
- *yy_cp = yy_hold_char;
-
- /* yy_bp points to the position in yy_ch_buf of the start of
- * the current run.
- */
- yy_bp = yy_cp;
-
- yy_current_state = yy_start;
- yy_current_state += YY_AT_BOL();
-yy_match:
- do
- {
- register YY_CHAR yy_c = yy_ec[YY_SC_TO_UI(*yy_cp)];
- if ( yy_accept[yy_current_state] )
- {
- yy_last_accepting_state = yy_current_state;
- yy_last_accepting_cpos = yy_cp;
- }
- while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
- {
- yy_current_state = (int) yy_def[yy_current_state];
- if ( yy_current_state >= 743 )
- yy_c = yy_meta[(unsigned int) yy_c];
- }
- yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c];
- ++yy_cp;
- }
- while ( yy_base[yy_current_state] != 2300 );
-
-yy_find_action:
- yy_act = yy_accept[yy_current_state];
- if ( yy_act == 0 )
- { /* have to back up */
- yy_cp = yy_last_accepting_cpos;
- yy_current_state = yy_last_accepting_state;
- yy_act = yy_accept[yy_current_state];
- }
-
- YY_DO_BEFORE_ACTION;
-
-
-do_action: /* This label is used only to access EOF actions. */
-
-
- switch ( yy_act )
- { /* beginning of action switch */
- case 0: /* must back up */
- /* undo the effects of YY_DO_BEFORE_ACTION */
- *yy_cp = yy_hold_char;
- yy_cp = yy_last_accepting_cpos;
- yy_current_state = yy_last_accepting_state;
- goto yy_find_action;
-
-case 1:
-YY_RULE_SETUP
-#line 286 "yaccParser/hslexer.flex"
-{
- char tempf[FILENAME_SIZE];
- sscanf(yytext+1, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
- YY_BREAK
-case 2:
-YY_RULE_SETUP
-#line 293 "yaccParser/hslexer.flex"
-{
- char tempf[FILENAME_SIZE];
- sscanf(yytext+5, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
- YY_BREAK
-case 3:
-YY_RULE_SETUP
-#line 300 "yaccParser/hslexer.flex"
-{
- /* partain: pragma-style line directive */
- char tempf[FILENAME_SIZE];
- sscanf(yytext+9, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
- YY_BREAK
-case 4:
-YY_RULE_SETUP
-#line 307 "yaccParser/hslexer.flex"
-{
- sscanf(yytext+33,"%d ",&thisIfacePragmaVersion);
- }
- YY_BREAK
-case 5:
-YY_RULE_SETUP
-#line 310 "yaccParser/hslexer.flex"
-{
- if ( ignorePragmas ||
- thisIfacePragmaVersion < minAcceptablePragmaVersion ||
- thisIfacePragmaVersion > maxAcceptablePragmaVersion) {
- nested_comments = 1;
- PUSH_STATE(Comment);
- } else {
- PUSH_STATE(GhcPragma);
- RETURN(GHC_PRAGMA);
- }
- }
- YY_BREAK
-case 6:
-YY_RULE_SETUP
-#line 321 "yaccParser/hslexer.flex"
-{ RETURN(NO_PRAGMA); }
- YY_BREAK
-case 7:
-YY_RULE_SETUP
-#line 322 "yaccParser/hslexer.flex"
-{ RETURN(NOINFO_PRAGMA); }
- YY_BREAK
-case 8:
-YY_RULE_SETUP
-#line 323 "yaccParser/hslexer.flex"
-{ RETURN(ABSTRACT_PRAGMA); }
- YY_BREAK
-case 9:
-YY_RULE_SETUP
-#line 324 "yaccParser/hslexer.flex"
-{ RETURN(DEFOREST_PRAGMA); }
- YY_BREAK
-case 10:
-YY_RULE_SETUP
-#line 325 "yaccParser/hslexer.flex"
-{ RETURN(SPECIALISE_PRAGMA); }
- YY_BREAK
-case 11:
-YY_RULE_SETUP
-#line 326 "yaccParser/hslexer.flex"
-{ RETURN(MODNAME_PRAGMA); }
- YY_BREAK
-case 12:
-YY_RULE_SETUP
-#line 327 "yaccParser/hslexer.flex"
-{ RETURN(ARITY_PRAGMA); }
- YY_BREAK
-case 13:
-YY_RULE_SETUP
-#line 328 "yaccParser/hslexer.flex"
-{ RETURN(UPDATE_PRAGMA); }
- YY_BREAK
-case 14:
-YY_RULE_SETUP
-#line 329 "yaccParser/hslexer.flex"
-{ RETURN(STRICTNESS_PRAGMA); }
- YY_BREAK
-case 15:
-YY_RULE_SETUP
-#line 330 "yaccParser/hslexer.flex"
-{ RETURN(KIND_PRAGMA); }
- YY_BREAK
-case 16:
-YY_RULE_SETUP
-#line 331 "yaccParser/hslexer.flex"
-{ RETURN(MAGIC_UNFOLDING_PRAGMA); }
- YY_BREAK
-case 17:
-YY_RULE_SETUP
-#line 332 "yaccParser/hslexer.flex"
-{ RETURN(UNFOLDING_PRAGMA); }
- YY_BREAK
-case 18:
-YY_RULE_SETUP
-#line 334 "yaccParser/hslexer.flex"
-{ RETURN(COCON); }
- YY_BREAK
-case 19:
-YY_RULE_SETUP
-#line 335 "yaccParser/hslexer.flex"
-{ RETURN(COPRIM); }
- YY_BREAK
-case 20:
-YY_RULE_SETUP
-#line 336 "yaccParser/hslexer.flex"
-{ RETURN(COAPP); }
- YY_BREAK
-case 21:
-YY_RULE_SETUP
-#line 337 "yaccParser/hslexer.flex"
-{ RETURN(COTYAPP); }
- YY_BREAK
-case 22:
-YY_RULE_SETUP
-#line 338 "yaccParser/hslexer.flex"
-{ RETURN(CO_ALG_ALTS); }
- YY_BREAK
-case 23:
-YY_RULE_SETUP
-#line 339 "yaccParser/hslexer.flex"
-{ RETURN(CO_PRIM_ALTS); }
- YY_BREAK
-case 24:
-YY_RULE_SETUP
-#line 340 "yaccParser/hslexer.flex"
-{ RETURN(CO_NO_DEFAULT); }
- YY_BREAK
-case 25:
-YY_RULE_SETUP
-#line 341 "yaccParser/hslexer.flex"
-{ RETURN(CO_LETREC); }
- YY_BREAK
-case 26:
-YY_RULE_SETUP
-#line 343 "yaccParser/hslexer.flex"
-{ RETURN(CO_PRELUDE_DICTS_CC); }
- YY_BREAK
-case 27:
-YY_RULE_SETUP
-#line 344 "yaccParser/hslexer.flex"
-{ RETURN(CO_ALL_DICTS_CC); }
- YY_BREAK
-case 28:
-YY_RULE_SETUP
-#line 345 "yaccParser/hslexer.flex"
-{ RETURN(CO_USER_CC); }
- YY_BREAK
-case 29:
-YY_RULE_SETUP
-#line 346 "yaccParser/hslexer.flex"
-{ RETURN(CO_AUTO_CC); }
- YY_BREAK
-case 30:
-YY_RULE_SETUP
-#line 347 "yaccParser/hslexer.flex"
-{ RETURN(CO_DICT_CC); }
- YY_BREAK
-case 31:
-YY_RULE_SETUP
-#line 349 "yaccParser/hslexer.flex"
-{ RETURN(CO_DUPD_CC); }
- YY_BREAK
-case 32:
-YY_RULE_SETUP
-#line 350 "yaccParser/hslexer.flex"
-{ RETURN(CO_CAF_CC); }
- YY_BREAK
-case 33:
-YY_RULE_SETUP
-#line 352 "yaccParser/hslexer.flex"
-{ RETURN(CO_SDSEL_ID); }
- YY_BREAK
-case 34:
-YY_RULE_SETUP
-#line 353 "yaccParser/hslexer.flex"
-{ RETURN(CO_METH_ID); }
- YY_BREAK
-case 35:
-YY_RULE_SETUP
-#line 354 "yaccParser/hslexer.flex"
-{ RETURN(CO_DEFM_ID); }
- YY_BREAK
-case 36:
-YY_RULE_SETUP
-#line 355 "yaccParser/hslexer.flex"
-{ RETURN(CO_DFUN_ID); }
- YY_BREAK
-case 37:
-YY_RULE_SETUP
-#line 356 "yaccParser/hslexer.flex"
-{ RETURN(CO_CONSTM_ID); }
- YY_BREAK
-case 38:
-YY_RULE_SETUP
-#line 357 "yaccParser/hslexer.flex"
-{ RETURN(CO_SPEC_ID); }
- YY_BREAK
-case 39:
-YY_RULE_SETUP
-#line 358 "yaccParser/hslexer.flex"
-{ RETURN(CO_WRKR_ID); }
- YY_BREAK
-case 40:
-YY_RULE_SETUP
-#line 359 "yaccParser/hslexer.flex"
-{ RETURN(CO_ORIG_NM); /* fully-qualified original name*/ }
- YY_BREAK
-case 41:
-YY_RULE_SETUP
-#line 361 "yaccParser/hslexer.flex"
-{ RETURN(UNFOLD_ALWAYS); }
- YY_BREAK
-case 42:
-YY_RULE_SETUP
-#line 362 "yaccParser/hslexer.flex"
-{ RETURN(UNFOLD_IF_ARGS); }
- YY_BREAK
-case 43:
-YY_RULE_SETUP
-#line 364 "yaccParser/hslexer.flex"
-{ RETURN(NOREP_INTEGER); }
- YY_BREAK
-case 44:
-YY_RULE_SETUP
-#line 365 "yaccParser/hslexer.flex"
-{ RETURN(NOREP_RATIONAL); }
- YY_BREAK
-case 45:
-YY_RULE_SETUP
-#line 366 "yaccParser/hslexer.flex"
-{ RETURN(NOREP_STRING); }
- YY_BREAK
-case 46:
-YY_RULE_SETUP
-#line 368 "yaccParser/hslexer.flex"
-{ POP_STATE; RETURN(END_PRAGMA); }
- YY_BREAK
-case 47:
-YY_RULE_SETUP
-#line 370 "yaccParser/hslexer.flex"
-{
- PUSH_STATE(UserPragma);
- RETURN(SPECIALISE_UPRAGMA);
- }
- YY_BREAK
-case 48:
-YY_RULE_SETUP
-#line 374 "yaccParser/hslexer.flex"
-{
- PUSH_STATE(UserPragma);
- RETURN(INLINE_UPRAGMA);
- }
- YY_BREAK
-case 49:
-YY_RULE_SETUP
-#line 378 "yaccParser/hslexer.flex"
-{
- PUSH_STATE(UserPragma);
- RETURN(MAGIC_UNFOLDING_UPRAGMA);
- }
- YY_BREAK
-case 50:
-YY_RULE_SETUP
-#line 382 "yaccParser/hslexer.flex"
-{
- PUSH_STATE(UserPragma);
- RETURN(DEFOREST_UPRAGMA);
- }
- YY_BREAK
-case 51:
-YY_RULE_SETUP
-#line 386 "yaccParser/hslexer.flex"
-{
- PUSH_STATE(UserPragma);
- RETURN(ABSTRACT_UPRAGMA);
- }
- YY_BREAK
-case 52:
-YY_RULE_SETUP
-#line 390 "yaccParser/hslexer.flex"
-{
- fprintf(stderr, "Warning: \"%s\", line %d: Unrecognised pragma '",
- input_filename, hsplineno);
- format_string(stderr, (unsigned char *) yytext, yyleng);
- fputs("'\n", stderr);
- nested_comments = 1;
- PUSH_STATE(Comment);
- }
- YY_BREAK
-case 53:
-YY_RULE_SETUP
-#line 398 "yaccParser/hslexer.flex"
-{ POP_STATE; RETURN(END_UPRAGMA); }
- YY_BREAK
-
- /*
- * Haskell keywords. `scc' is actually a Glasgow extension, but it is
- * intentionally accepted as a keyword even for normal <Code>.
- */
-
-case 54:
-YY_RULE_SETUP
-#line 407 "yaccParser/hslexer.flex"
-{ RETURN(CASE); }
- YY_BREAK
-case 55:
-YY_RULE_SETUP
-#line 408 "yaccParser/hslexer.flex"
-{ RETURN(CLASS); }
- YY_BREAK
-case 56:
-YY_RULE_SETUP
-#line 409 "yaccParser/hslexer.flex"
-{ RETURN(DATA); }
- YY_BREAK
-case 57:
-YY_RULE_SETUP
-#line 410 "yaccParser/hslexer.flex"
-{ RETURN(DEFAULT); }
- YY_BREAK
-case 58:
-YY_RULE_SETUP
-#line 411 "yaccParser/hslexer.flex"
-{ RETURN(DERIVING); }
- YY_BREAK
-case 59:
-YY_RULE_SETUP
-#line 412 "yaccParser/hslexer.flex"
-{ RETURN(ELSE); }
- YY_BREAK
-case 60:
-YY_RULE_SETUP
-#line 413 "yaccParser/hslexer.flex"
-{ RETURN(HIDING); }
- YY_BREAK
-case 61:
-YY_RULE_SETUP
-#line 414 "yaccParser/hslexer.flex"
-{ RETURN(IF); }
- YY_BREAK
-case 62:
-YY_RULE_SETUP
-#line 415 "yaccParser/hslexer.flex"
-{ RETURN(IMPORT); }
- YY_BREAK
-case 63:
-YY_RULE_SETUP
-#line 416 "yaccParser/hslexer.flex"
-{ RETURN(INFIX); }
- YY_BREAK
-case 64:
-YY_RULE_SETUP
-#line 417 "yaccParser/hslexer.flex"
-{ RETURN(INFIXL); }
- YY_BREAK
-case 65:
-YY_RULE_SETUP
-#line 418 "yaccParser/hslexer.flex"
-{ RETURN(INFIXR); }
- YY_BREAK
-case 66:
-YY_RULE_SETUP
-#line 419 "yaccParser/hslexer.flex"
-{ RETURN(INSTANCE); }
- YY_BREAK
-case 67:
-YY_RULE_SETUP
-#line 420 "yaccParser/hslexer.flex"
-{ RETURN(INTERFACE); }
- YY_BREAK
-case 68:
-YY_RULE_SETUP
-#line 421 "yaccParser/hslexer.flex"
-{ RETURN(MODULE); }
- YY_BREAK
-case 69:
-YY_RULE_SETUP
-#line 422 "yaccParser/hslexer.flex"
-{ RETURN(OF); }
- YY_BREAK
-case 70:
-YY_RULE_SETUP
-#line 423 "yaccParser/hslexer.flex"
-{ RETURN(RENAMING); }
- YY_BREAK
-case 71:
-YY_RULE_SETUP
-#line 424 "yaccParser/hslexer.flex"
-{ RETURN(THEN); }
- YY_BREAK
-case 72:
-YY_RULE_SETUP
-#line 425 "yaccParser/hslexer.flex"
-{ RETURN(TO); }
- YY_BREAK
-case 73:
-YY_RULE_SETUP
-#line 426 "yaccParser/hslexer.flex"
-{ RETURN(TYPE); }
- YY_BREAK
-case 74:
-YY_RULE_SETUP
-#line 427 "yaccParser/hslexer.flex"
-{ RETURN(WHERE); }
- YY_BREAK
-case 75:
-YY_RULE_SETUP
-#line 428 "yaccParser/hslexer.flex"
-{ RETURN(IN); }
- YY_BREAK
-case 76:
-YY_RULE_SETUP
-#line 429 "yaccParser/hslexer.flex"
-{ RETURN(LET); }
- YY_BREAK
-case 77:
-YY_RULE_SETUP
-#line 430 "yaccParser/hslexer.flex"
-{ RETURN(CCALL); }
- YY_BREAK
-case 78:
-YY_RULE_SETUP
-#line 431 "yaccParser/hslexer.flex"
-{ RETURN(CCALL_GC); }
- YY_BREAK
-case 79:
-YY_RULE_SETUP
-#line 432 "yaccParser/hslexer.flex"
-{ RETURN(CASM); }
- YY_BREAK
-case 80:
-YY_RULE_SETUP
-#line 433 "yaccParser/hslexer.flex"
-{ RETURN(CASM_GC); }
- YY_BREAK
-case 81:
-YY_RULE_SETUP
-#line 434 "yaccParser/hslexer.flex"
-{ RETURN(SCC); }
- YY_BREAK
-case 82:
-YY_RULE_SETUP
-#line 435 "yaccParser/hslexer.flex"
-{ RETURN(FORALL); }
- YY_BREAK
-
- /*
- * Haskell operators. Nothing special about these.
- */
-
-case 83:
-YY_RULE_SETUP
-#line 443 "yaccParser/hslexer.flex"
-{ RETURN(DOTDOT); }
- YY_BREAK
-case 84:
-YY_RULE_SETUP
-#line 444 "yaccParser/hslexer.flex"
-{ RETURN(SEMI); }
- YY_BREAK
-case 85:
-YY_RULE_SETUP
-#line 445 "yaccParser/hslexer.flex"
-{ RETURN(COMMA); }
- YY_BREAK
-case 86:
-YY_RULE_SETUP
-#line 446 "yaccParser/hslexer.flex"
-{ RETURN(VBAR); }
- YY_BREAK
-case 87:
-YY_RULE_SETUP
-#line 447 "yaccParser/hslexer.flex"
-{ RETURN(EQUAL); }
- YY_BREAK
-case 88:
-YY_RULE_SETUP
-#line 448 "yaccParser/hslexer.flex"
-{ RETURN(LARROW); }
- YY_BREAK
-case 89:
-YY_RULE_SETUP
-#line 449 "yaccParser/hslexer.flex"
-{ RETURN(RARROW); }
- YY_BREAK
-case 90:
-YY_RULE_SETUP
-#line 450 "yaccParser/hslexer.flex"
-{ RETURN(DARROW); }
- YY_BREAK
-case 91:
-YY_RULE_SETUP
-#line 451 "yaccParser/hslexer.flex"
-{ RETURN(DCOLON); }
- YY_BREAK
-case 92:
-YY_RULE_SETUP
-#line 452 "yaccParser/hslexer.flex"
-{ RETURN(OPAREN); }
- YY_BREAK
-case 93:
-YY_RULE_SETUP
-#line 453 "yaccParser/hslexer.flex"
-{ RETURN(CPAREN); }
- YY_BREAK
-case 94:
-YY_RULE_SETUP
-#line 454 "yaccParser/hslexer.flex"
-{ RETURN(OBRACK); }
- YY_BREAK
-case 95:
-YY_RULE_SETUP
-#line 455 "yaccParser/hslexer.flex"
-{ RETURN(CBRACK); }
- YY_BREAK
-case 96:
-YY_RULE_SETUP
-#line 456 "yaccParser/hslexer.flex"
-{ RETURN(OCURLY); }
- YY_BREAK
-case 97:
-YY_RULE_SETUP
-#line 457 "yaccParser/hslexer.flex"
-{ RETURN(CCURLY); }
- YY_BREAK
-case 98:
-YY_RULE_SETUP
-#line 458 "yaccParser/hslexer.flex"
-{ RETURN(PLUS); }
- YY_BREAK
-case 99:
-YY_RULE_SETUP
-#line 459 "yaccParser/hslexer.flex"
-{ RETURN(AT); }
- YY_BREAK
-case 100:
-YY_RULE_SETUP
-#line 460 "yaccParser/hslexer.flex"
-{ RETURN(LAMBDA); }
- YY_BREAK
-case 101:
-YY_RULE_SETUP
-#line 461 "yaccParser/hslexer.flex"
-{ RETURN(TYLAMBDA); }
- YY_BREAK
-case 102:
-YY_RULE_SETUP
-#line 462 "yaccParser/hslexer.flex"
-{ RETURN(WILDCARD); }
- YY_BREAK
-case 103:
-YY_RULE_SETUP
-#line 463 "yaccParser/hslexer.flex"
-{ RETURN(BQUOTE); }
- YY_BREAK
-case 104:
-YY_RULE_SETUP
-#line 464 "yaccParser/hslexer.flex"
-{ RETURN(LAZY); }
- YY_BREAK
-case 105:
-YY_RULE_SETUP
-#line 465 "yaccParser/hslexer.flex"
-{ RETURN(MINUS); }
- YY_BREAK
-
- /*
- * Integers and (for Glasgow extensions) primitive integers. Note that
- * we pass all of the text on to the parser, because flex/C can't handle
- * arbitrary precision numbers.
- */
-
-case 106:
-YY_RULE_SETUP
-#line 475 "yaccParser/hslexer.flex"
-{ /* octal */
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
- YY_BREAK
-case 107:
-YY_RULE_SETUP
-#line 479 "yaccParser/hslexer.flex"
-{ /* octal */
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
- YY_BREAK
-case 108:
-YY_RULE_SETUP
-#line 483 "yaccParser/hslexer.flex"
-{ /* hexadecimal */
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
- YY_BREAK
-case 109:
-YY_RULE_SETUP
-#line 487 "yaccParser/hslexer.flex"
-{ /* hexadecimal */
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
- YY_BREAK
-case 110:
-YY_RULE_SETUP
-#line 491 "yaccParser/hslexer.flex"
-{
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
- YY_BREAK
-case 111:
-YY_RULE_SETUP
-#line 495 "yaccParser/hslexer.flex"
-{
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
- YY_BREAK
-
- /*
- * Floats and (for Glasgow extensions) primitive floats/doubles.
- */
-
-case 112:
-YY_RULE_SETUP
-#line 506 "yaccParser/hslexer.flex"
-{
- yylval.uid = xstrndup(yytext, yyleng - 2);
- RETURN(DOUBLEPRIM);
- }
- YY_BREAK
-case 113:
-YY_RULE_SETUP
-#line 510 "yaccParser/hslexer.flex"
-{
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(FLOATPRIM);
- }
- YY_BREAK
-case 114:
-YY_RULE_SETUP
-#line 514 "yaccParser/hslexer.flex"
-{
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(FLOAT);
- }
- YY_BREAK
-
- /*
- * Funky ``foo'' style C literals for Glasgow extensions
- */
-
-case 115:
-YY_RULE_SETUP
-#line 525 "yaccParser/hslexer.flex"
-{
- hsnewid(yytext + 2, yyleng - 4);
- RETURN(CLITLIT);
- }
- YY_BREAK
-
- /*
- * Identifiers, both variables and operators. The trailing hash is allowed
- * for Glasgow extensions.
- */
-
-case 116:
-YY_RULE_SETUP
-#line 537 "yaccParser/hslexer.flex"
-{ hsnewid(yytext, yyleng); RETURN(CONID); }
- YY_BREAK
-case 117:
-YY_RULE_SETUP
-#line 538 "yaccParser/hslexer.flex"
-{ hsnewid(yytext, yyleng); RETURN(CONID); }
- YY_BREAK
-case 118:
-YY_RULE_SETUP
-#line 539 "yaccParser/hslexer.flex"
-{ hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); }
- YY_BREAK
-
-/* These SHOULDNAE work in "Code" (sigh) */
-
-case 119:
-YY_RULE_SETUP
-#line 544 "yaccParser/hslexer.flex"
-{
- if (! (nonstandardFlag || in_interface)) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
- hsperror(errbuf);
- }
- hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONID : VARID);
- }
- YY_BREAK
-case 120:
-YY_RULE_SETUP
-#line 553 "yaccParser/hslexer.flex"
-{
- if (! (nonstandardFlag || in_interface)) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext);
- hsperror(errbuf);
- }
- hsnewid(yytext, yyleng);
- RETURN(isconstr(yytext) ? CONID : VARID);
- /* NB: ^^^^^^^^ : not the macro! */
- }
- YY_BREAK
-case 121:
-YY_RULE_SETUP
-#line 563 "yaccParser/hslexer.flex"
-{
- hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONID : VARID);
- }
- YY_BREAK
-case 122:
-YY_RULE_SETUP
-#line 567 "yaccParser/hslexer.flex"
-{
- hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONSYM : VARSYM);
- }
- YY_BREAK
-
- /* Why is `{Id}#` matched this way, and `{Id}` lexed as three tokens? --JSM */
-
- /* Because we can make the former well-behaved (we defined them).
-
- Sadly, the latter is defined by Haskell, which allows such
- la-la land constructs as `{-a 900-line comment-} foo`. (WDP 94/12)
- */
-
-case 123:
-YY_RULE_SETUP
-#line 582 "yaccParser/hslexer.flex"
-{
- hsnewid(yytext + 1, yyleng - 2);
- RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM);
- }
- YY_BREAK
-
- /*
- * Character literals. The first form is the quick form, for character
- * literals that don't contain backslashes. Literals with backslashes are
- * lexed through multiple rules. First, we match the open ' and as many
- * normal characters as possible. This puts us into the <Char> state, where
- * a backslash is legal. Then, we match the backslash and move into the
- * <CharEsc> state. When we drop out of <CharEsc>, we collect more normal
- * characters and the close '. We may end up with too many characters, but
- * this allows us to easily share the lex rules with strings. Excess characters
- * are ignored with a warning.
- */
-
-case 124:
-YY_RULE_SETUP
-#line 601 "yaccParser/hslexer.flex"
-{
- yylval.uhstring = installHstring(1, yytext+1);
- RETURN(CHARPRIM);
- }
- YY_BREAK
-case 125:
-YY_RULE_SETUP
-#line 605 "yaccParser/hslexer.flex"
-{
- yylval.uhstring = installHstring(1, yytext+1);
- RETURN(CHAR);
- }
- YY_BREAK
-case 126:
-YY_RULE_SETUP
-#line 609 "yaccParser/hslexer.flex"
-{char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "'' is not a valid character (or string) literal\n");
- hsperror(errbuf);
- }
- YY_BREAK
-case 127:
-YY_RULE_SETUP
-#line 613 "yaccParser/hslexer.flex"
-{
- hsmlcolno = hspcolno;
- cleartext();
- addtext(yytext+1, yyleng-1);
- PUSH_STATE(Char);
- }
- YY_BREAK
-case 128:
-YY_RULE_SETUP
-#line 619 "yaccParser/hslexer.flex"
-{
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng - 2);
- text = fetchtext(&length);
-
- if (! (nonstandardFlag || in_interface)) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "`Char-hash' literals are non-standard: %s\n", text);
- hsperror(errbuf);
- }
-
- if (length > 1) {
- fprintf(stderr, "\"%s\", line %d, column %d: Unboxed character literal '",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) text, length);
- fputs("' too long\n", stderr);
- hsperror("");
- }
- yylval.uhstring = installHstring(1, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(CHARPRIM);
- }
- YY_BREAK
-case 129:
-YY_RULE_SETUP
-#line 644 "yaccParser/hslexer.flex"
-{
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng - 1);
- text = fetchtext(&length);
-
- if (length > 1) {
- fprintf(stderr, "\"%s\", line %d, column %d: Character literal '",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) text, length);
- fputs("' too long\n", stderr);
- hsperror("");
- }
- yylval.uhstring = installHstring(1, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(CHAR);
- }
- YY_BREAK
-case 130:
-YY_RULE_SETUP
-#line 663 "yaccParser/hslexer.flex"
-{ addtext(yytext, yyleng); }
- YY_BREAK
-
- /*
- * String literals. The first form is the quick form, for string literals
- * that don't contain backslashes. Literals with backslashes are lexed
- * through multiple rules. First, we match the open " and as many normal
- * characters as possible. This puts us into the <String> state, where
- * a backslash is legal. Then, we match the backslash and move into the
- * <StringEsc> state. When we drop out of <StringEsc>, we collect more normal
- * characters, moving back and forth between <String> and <StringEsc> as more
- * backslashes are encountered. (We may even digress into <Comment> mode if we
- * find a comment in a gap between backslashes.) Finally, we read the last chunk
- * of normal characters and the close ".
- */
-
-case 131:
-YY_RULE_SETUP
-#line 681 "yaccParser/hslexer.flex"
-{
- yylval.uhstring = installHstring(yyleng-3, yytext+1);
- /* the -3 accounts for the " on front, "# on the end */
- RETURN(STRINGPRIM);
- }
- YY_BREAK
-case 132:
-YY_RULE_SETUP
-#line 686 "yaccParser/hslexer.flex"
-{
- yylval.uhstring = installHstring(yyleng-2, yytext+1);
- RETURN(STRING);
- }
- YY_BREAK
-case 133:
-YY_RULE_SETUP
-#line 690 "yaccParser/hslexer.flex"
-{
- hsmlcolno = hspcolno;
- cleartext();
- addtext(yytext+1, yyleng-1);
- PUSH_STATE(String);
- }
- YY_BREAK
-case 134:
-YY_RULE_SETUP
-#line 696 "yaccParser/hslexer.flex"
-{
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng-2);
- text = fetchtext(&length);
-
- if (! (nonstandardFlag || in_interface)) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "`String-hash' literals are non-standard: %s\n", text);
- hsperror(errbuf);
- }
-
- yylval.uhstring = installHstring(length, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(STRINGPRIM);
- }
- YY_BREAK
-case 135:
-YY_RULE_SETUP
-#line 714 "yaccParser/hslexer.flex"
-{
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng-1);
- text = fetchtext(&length);
-
- yylval.uhstring = installHstring(length, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(STRING);
- }
- YY_BREAK
-case 136:
-YY_RULE_SETUP
-#line 726 "yaccParser/hslexer.flex"
-{ addtext(yytext, yyleng); }
- YY_BREAK
-
- /*
- * Character and string escapes are roughly the same, but strings have the
- * extra `\&' sequence which is not allowed for characters. Also, comments
- * are allowed in the <StringEsc> state. (See the comment section much
- * further down.)
- *
- * NB: Backslashes and tabs are stored in strings as themselves.
- * But if we print them (in printtree.c), they must go out as
- * "\\\\" and "\\t" respectively. (This is because of the bogus
- * intermediate format that the parser produces. It uses '\t' fpr end of
- * string, so it needs to be able to escape tabs, which means that it
- * also needs to be able to escape the escape character ('\\'). Sigh.
- */
-
-case 137:
-YY_RULE_SETUP
-#line 744 "yaccParser/hslexer.flex"
-{ PUSH_STATE(CharEsc); }
- YY_BREAK
-case 138:
-YY_RULE_SETUP
-#line 745 "yaccParser/hslexer.flex"
-/* Ignore */ ;
- YY_BREAK
-case 139:
-YY_RULE_SETUP
-#line 746 "yaccParser/hslexer.flex"
-{ PUSH_STATE(StringEsc); noGap = TRUE; }
- YY_BREAK
-case 140:
-YY_RULE_SETUP
-#line 748 "yaccParser/hslexer.flex"
-{ addchar(*yytext); POP_STATE; }
- YY_BREAK
-case 141:
-YY_RULE_SETUP
-#line 749 "yaccParser/hslexer.flex"
-{ if (noGap) { addchar(*yytext); } POP_STATE; }
- YY_BREAK
-case 142:
-YY_RULE_SETUP
-#line 751 "yaccParser/hslexer.flex"
-{ addchar(*yytext); POP_STATE; }
- YY_BREAK
-case 143:
-YY_RULE_SETUP
-#line 752 "yaccParser/hslexer.flex"
-{ addchar('\000'); POP_STATE; }
- YY_BREAK
-case 144:
-YY_RULE_SETUP
-#line 753 "yaccParser/hslexer.flex"
-{ addchar('\001'); POP_STATE; }
- YY_BREAK
-case 145:
-YY_RULE_SETUP
-#line 754 "yaccParser/hslexer.flex"
-{ addchar('\002'); POP_STATE; }
- YY_BREAK
-case 146:
-YY_RULE_SETUP
-#line 755 "yaccParser/hslexer.flex"
-{ addchar('\003'); POP_STATE; }
- YY_BREAK
-case 147:
-YY_RULE_SETUP
-#line 756 "yaccParser/hslexer.flex"
-{ addchar('\004'); POP_STATE; }
- YY_BREAK
-case 148:
-YY_RULE_SETUP
-#line 757 "yaccParser/hslexer.flex"
-{ addchar('\005'); POP_STATE; }
- YY_BREAK
-case 149:
-YY_RULE_SETUP
-#line 758 "yaccParser/hslexer.flex"
-{ addchar('\006'); POP_STATE; }
- YY_BREAK
-case 150:
-#line 760 "yaccParser/hslexer.flex"
-case 151:
-YY_RULE_SETUP
-#line 760 "yaccParser/hslexer.flex"
-{ addchar('\007'); POP_STATE; }
- YY_BREAK
-case 152:
-#line 762 "yaccParser/hslexer.flex"
-case 153:
-YY_RULE_SETUP
-#line 762 "yaccParser/hslexer.flex"
-{ addchar('\010'); POP_STATE; }
- YY_BREAK
-case 154:
-#line 764 "yaccParser/hslexer.flex"
-case 155:
-YY_RULE_SETUP
-#line 764 "yaccParser/hslexer.flex"
-{ addchar('\011'); POP_STATE; }
- YY_BREAK
-case 156:
-#line 766 "yaccParser/hslexer.flex"
-case 157:
-YY_RULE_SETUP
-#line 766 "yaccParser/hslexer.flex"
-{ addchar('\012'); POP_STATE; }
- YY_BREAK
-case 158:
-#line 768 "yaccParser/hslexer.flex"
-case 159:
-YY_RULE_SETUP
-#line 768 "yaccParser/hslexer.flex"
-{ addchar('\013'); POP_STATE; }
- YY_BREAK
-case 160:
-#line 770 "yaccParser/hslexer.flex"
-case 161:
-YY_RULE_SETUP
-#line 770 "yaccParser/hslexer.flex"
-{ addchar('\014'); POP_STATE; }
- YY_BREAK
-case 162:
-#line 772 "yaccParser/hslexer.flex"
-case 163:
-YY_RULE_SETUP
-#line 772 "yaccParser/hslexer.flex"
-{ addchar('\015'); POP_STATE; }
- YY_BREAK
-case 164:
-YY_RULE_SETUP
-#line 773 "yaccParser/hslexer.flex"
-{ addchar('\016'); POP_STATE; }
- YY_BREAK
-case 165:
-YY_RULE_SETUP
-#line 774 "yaccParser/hslexer.flex"
-{ addchar('\017'); POP_STATE; }
- YY_BREAK
-case 166:
-YY_RULE_SETUP
-#line 775 "yaccParser/hslexer.flex"
-{ addchar('\020'); POP_STATE; }
- YY_BREAK
-case 167:
-YY_RULE_SETUP
-#line 776 "yaccParser/hslexer.flex"
-{ addchar('\021'); POP_STATE; }
- YY_BREAK
-case 168:
-YY_RULE_SETUP
-#line 777 "yaccParser/hslexer.flex"
-{ addchar('\022'); POP_STATE; }
- YY_BREAK
-case 169:
-YY_RULE_SETUP
-#line 778 "yaccParser/hslexer.flex"
-{ addchar('\023'); POP_STATE; }
- YY_BREAK
-case 170:
-YY_RULE_SETUP
-#line 779 "yaccParser/hslexer.flex"
-{ addchar('\024'); POP_STATE; }
- YY_BREAK
-case 171:
-YY_RULE_SETUP
-#line 780 "yaccParser/hslexer.flex"
-{ addchar('\025'); POP_STATE; }
- YY_BREAK
-case 172:
-YY_RULE_SETUP
-#line 781 "yaccParser/hslexer.flex"
-{ addchar('\026'); POP_STATE; }
- YY_BREAK
-case 173:
-YY_RULE_SETUP
-#line 782 "yaccParser/hslexer.flex"
-{ addchar('\027'); POP_STATE; }
- YY_BREAK
-case 174:
-YY_RULE_SETUP
-#line 783 "yaccParser/hslexer.flex"
-{ addchar('\030'); POP_STATE; }
- YY_BREAK
-case 175:
-YY_RULE_SETUP
-#line 784 "yaccParser/hslexer.flex"
-{ addchar('\031'); POP_STATE; }
- YY_BREAK
-case 176:
-YY_RULE_SETUP
-#line 785 "yaccParser/hslexer.flex"
-{ addchar('\032'); POP_STATE; }
- YY_BREAK
-case 177:
-YY_RULE_SETUP
-#line 786 "yaccParser/hslexer.flex"
-{ addchar('\033'); POP_STATE; }
- YY_BREAK
-case 178:
-YY_RULE_SETUP
-#line 787 "yaccParser/hslexer.flex"
-{ addchar('\034'); POP_STATE; }
- YY_BREAK
-case 179:
-YY_RULE_SETUP
-#line 788 "yaccParser/hslexer.flex"
-{ addchar('\035'); POP_STATE; }
- YY_BREAK
-case 180:
-YY_RULE_SETUP
-#line 789 "yaccParser/hslexer.flex"
-{ addchar('\036'); POP_STATE; }
- YY_BREAK
-case 181:
-YY_RULE_SETUP
-#line 790 "yaccParser/hslexer.flex"
-{ addchar('\037'); POP_STATE; }
- YY_BREAK
-case 182:
-YY_RULE_SETUP
-#line 791 "yaccParser/hslexer.flex"
-{ addchar('\040'); POP_STATE; }
- YY_BREAK
-case 183:
-YY_RULE_SETUP
-#line 792 "yaccParser/hslexer.flex"
-{ addchar('\177'); POP_STATE; }
- YY_BREAK
-case 184:
-YY_RULE_SETUP
-#line 793 "yaccParser/hslexer.flex"
-{ char c = yytext[1] - '@'; addchar(c); POP_STATE; }
- YY_BREAK
-case 185:
-YY_RULE_SETUP
-#line 794 "yaccParser/hslexer.flex"
-{
- int i = strtol(yytext, NULL, 10);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
- YY_BREAK
-case 186:
-YY_RULE_SETUP
-#line 806 "yaccParser/hslexer.flex"
-{
- int i = strtol(yytext + 1, NULL, 8);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
- YY_BREAK
-case 187:
-YY_RULE_SETUP
-#line 818 "yaccParser/hslexer.flex"
-{
- int i = strtol(yytext + 1, NULL, 16);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
- YY_BREAK
-
- /*
- * Simple comments and whitespace. Normally, we would just ignore these, but
- * in case we're processing a string escape, we need to note that we've seen
- * a gap.
- *
- * Note that we cater for a comment line that *doesn't* end in a newline.
- * This is incorrect, strictly speaking, but seems like the right thing
- * to do. Reported by Rajiv Mirani. (WDP 95/08)
- */
-
-case 188:
-#line 844 "yaccParser/hslexer.flex"
-case 189:
-YY_RULE_SETUP
-#line 844 "yaccParser/hslexer.flex"
-{ noGap = FALSE; }
- YY_BREAK
-
- /*
- * Nested comments. The major complication here is in trying to match the
- * longest lexemes possible, for better performance. (See the flex document.)
- * That's why the rules look so bizarre.
- */
-
-case 190:
-YY_RULE_SETUP
-#line 854 "yaccParser/hslexer.flex"
-{
- noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment);
- }
- YY_BREAK
-case 191:
-#line 859 "yaccParser/hslexer.flex"
-case 192:
-#line 860 "yaccParser/hslexer.flex"
-case 193:
-YY_RULE_SETUP
-#line 860 "yaccParser/hslexer.flex"
-;
- YY_BREAK
-case 194:
-YY_RULE_SETUP
-#line 861 "yaccParser/hslexer.flex"
-{ nested_comments++; }
- YY_BREAK
-case 195:
-YY_RULE_SETUP
-#line 862 "yaccParser/hslexer.flex"
-{ if (--nested_comments == 0) POP_STATE; }
- YY_BREAK
-case 196:
-YY_RULE_SETUP
-#line 863 "yaccParser/hslexer.flex"
-;
- YY_BREAK
-
- /*
- * Illegal characters. This used to be a single rule, but we might as well
- * pass on as much information as we have, so now we indicate our state in
- * the error message.
- */
-
-case 197:
-YY_RULE_SETUP
-#line 873 "yaccParser/hslexer.flex"
-{
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- }
- YY_BREAK
-case 198:
-YY_RULE_SETUP
-#line 880 "yaccParser/hslexer.flex"
-{
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a character literal\n", stderr);
- hsperror("");
- }
- YY_BREAK
-case 199:
-YY_RULE_SETUP
-#line 887 "yaccParser/hslexer.flex"
-{
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character escape: `\\",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- }
- YY_BREAK
-case 200:
-YY_RULE_SETUP
-#line 894 "yaccParser/hslexer.flex"
-{ if (nonstandardFlag) {
- addtext(yytext, yyleng);
- } else {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a string literal\n", stderr);
- hsperror("");
- }
- }
- YY_BREAK
-case 201:
-YY_RULE_SETUP
-#line 904 "yaccParser/hslexer.flex"
-{
- if (noGap) {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal string escape: `\\",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- } else {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a string gap\n", stderr);
- hsperror("");
- }
- }
- YY_BREAK
-
- /*
- * End of file. In any sub-state, this is an error. However, for the primary
- * <Code> and <GlaExt> states, this is perfectly normal. We just return an EOF
- * and let the yylex() wrapper deal with whatever has to be done next (e.g.
- * adding virtual close curlies, or closing an interface and returning to the
- * primary source file.
- *
- * Note that flex does not call YY_USER_ACTION for <<EOF>> rules. Hence the
- * line/column advancement has to be done by hand.
- */
-
-case YY_STATE_EOF(Char):
-case YY_STATE_EOF(CharEsc):
-#line 933 "yaccParser/hslexer.flex"
-{
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated character literal");
- }
- YY_BREAK
-case YY_STATE_EOF(Comment):
-#line 937 "yaccParser/hslexer.flex"
-{
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated comment");
- }
- YY_BREAK
-case YY_STATE_EOF(String):
-case YY_STATE_EOF(StringEsc):
-#line 941 "yaccParser/hslexer.flex"
-{
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated string literal");
- }
- YY_BREAK
-case YY_STATE_EOF(GhcPragma):
-#line 945 "yaccParser/hslexer.flex"
-{
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated interface pragma");
- }
- YY_BREAK
-case YY_STATE_EOF(UserPragma):
-#line 949 "yaccParser/hslexer.flex"
-{
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated user-specified pragma");
- }
- YY_BREAK
-case YY_STATE_EOF(Code):
-case YY_STATE_EOF(GlaExt):
-#line 953 "yaccParser/hslexer.flex"
-{ hsplineno = hslineno; hspcolno = hscolno; return(EOF); }
- YY_BREAK
-case 202:
-YY_RULE_SETUP
-#line 955 "yaccParser/hslexer.flex"
-YY_FATAL_ERROR( "flex scanner jammed" );
- YY_BREAK
-case YY_STATE_EOF(INITIAL):
- yyterminate();
-
- case YY_END_OF_BUFFER:
- {
- /* Amount of text matched not including the EOB char. */
- int yy_amount_of_matched_text = (int) (yy_cp - yytext_ptr) - 1;
-
- /* Undo the effects of YY_DO_BEFORE_ACTION. */
- *yy_cp = yy_hold_char;
-
- if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_NEW )
- {
- /* We're scanning a new file or input source. It's
- * possible that this happened because the user
- * just pointed yyin at a new source and called
- * yylex(). If so, then we have to assure
- * consistency between yy_current_buffer and our
- * globals. Here is the right place to do so, because
- * this is the first action (other than possibly a
- * back-up) that will match for the new input source.
- */
- yy_n_chars = yy_current_buffer->yy_n_chars;
- yy_current_buffer->yy_input_file = yyin;
- yy_current_buffer->yy_buffer_status = YY_BUFFER_NORMAL;
- }
-
- /* Note that here we test for yy_c_buf_p "<=" to the position
- * of the first EOB in the buffer, since yy_c_buf_p will
- * already have been incremented past the NUL character
- * (since all states make transitions on EOB to the
- * end-of-buffer state). Contrast this with the test
- * in input().
- */
- if ( yy_c_buf_p <= &yy_current_buffer->yy_ch_buf[yy_n_chars] )
- { /* This was really a NUL. */
- yy_state_type yy_next_state;
-
- yy_c_buf_p = yytext_ptr + yy_amount_of_matched_text;
-
- yy_current_state = yy_get_previous_state();
-
- /* Okay, we're now positioned to make the NUL
- * transition. We couldn't have
- * yy_get_previous_state() go ahead and do it
- * for us because it doesn't know how to deal
- * with the possibility of jamming (and we don't
- * want to build jamming into it because then it
- * will run more slowly).
- */
-
- yy_next_state = yy_try_NUL_trans( yy_current_state );
-
- yy_bp = yytext_ptr + YY_MORE_ADJ;
-
- if ( yy_next_state )
- {
- /* Consume the NUL. */
- yy_cp = ++yy_c_buf_p;
- yy_current_state = yy_next_state;
- goto yy_match;
- }
-
- else
- {
- yy_cp = yy_c_buf_p;
- goto yy_find_action;
- }
- }
-
- else switch ( yy_get_next_buffer() )
- {
- case EOB_ACT_END_OF_FILE:
- {
- yy_did_buffer_switch_on_eof = 0;
-
- if ( yywrap() )
- {
- /* Note: because we've taken care in
- * yy_get_next_buffer() to have set up
- * yytext, we can now set up
- * yy_c_buf_p so that if some total
- * hoser (like flex itself) wants to
- * call the scanner after we return the
- * YY_NULL, it'll still work - another
- * YY_NULL will get returned.
- */
- yy_c_buf_p = yytext_ptr + YY_MORE_ADJ;
-
- yy_act = YY_STATE_EOF(YY_START);
- goto do_action;
- }
-
- else
- {
- if ( ! yy_did_buffer_switch_on_eof )
- YY_NEW_FILE;
- }
- break;
- }
-
- case EOB_ACT_CONTINUE_SCAN:
- yy_c_buf_p =
- yytext_ptr + yy_amount_of_matched_text;
-
- yy_current_state = yy_get_previous_state();
-
- yy_cp = yy_c_buf_p;
- yy_bp = yytext_ptr + YY_MORE_ADJ;
- goto yy_match;
-
- case EOB_ACT_LAST_MATCH:
- yy_c_buf_p =
- &yy_current_buffer->yy_ch_buf[yy_n_chars];
-
- yy_current_state = yy_get_previous_state();
-
- yy_cp = yy_c_buf_p;
- yy_bp = yytext_ptr + YY_MORE_ADJ;
- goto yy_find_action;
- }
- break;
- }
-
- default:
- YY_FATAL_ERROR(
- "fatal flex scanner internal error--no action found" );
- } /* end of action switch */
- } /* end of scanning one token */
- } /* end of yylex */
-
-
-/* yy_get_next_buffer - try to read in a new buffer
- *
- * Returns a code representing an action:
- * EOB_ACT_LAST_MATCH -
- * EOB_ACT_CONTINUE_SCAN - continue scanning from current position
- * EOB_ACT_END_OF_FILE - end of file
- */
-
-static int yy_get_next_buffer()
- {
- register char *dest = yy_current_buffer->yy_ch_buf;
- register char *source = yytext_ptr;
- register int number_to_move, i;
- int ret_val;
-
- if ( yy_c_buf_p > &yy_current_buffer->yy_ch_buf[yy_n_chars + 1] )
- YY_FATAL_ERROR(
- "fatal flex scanner internal error--end of buffer missed" );
-
- if ( yy_current_buffer->yy_fill_buffer == 0 )
- { /* Don't try to fill the buffer, so this is an EOF. */
- if ( yy_c_buf_p - yytext_ptr - YY_MORE_ADJ == 1 )
- {
- /* We matched a singled characater, the EOB, so
- * treat this as a final EOF.
- */
- return EOB_ACT_END_OF_FILE;
- }
-
- else
- {
- /* We matched some text prior to the EOB, first
- * process it.
- */
- return EOB_ACT_LAST_MATCH;
- }
- }
-
- /* Try to read more data. */
-
- /* First move last chars to start of buffer. */
- number_to_move = (int) (yy_c_buf_p - yytext_ptr) - 1;
-
- for ( i = 0; i < number_to_move; ++i )
- *(dest++) = *(source++);
-
- if ( yy_current_buffer->yy_buffer_status == YY_BUFFER_EOF_PENDING )
- /* don't do the read, it's not guaranteed to return an EOF,
- * just force an EOF
- */
- yy_n_chars = 0;
-
- else
- {
- int num_to_read =
- yy_current_buffer->yy_buf_size - number_to_move - 1;
-
- while ( num_to_read <= 0 )
- { /* Not enough room in the buffer - grow it. */
-#ifdef YY_USES_REJECT
- YY_FATAL_ERROR(
-"input buffer overflow, can't enlarge buffer because scanner uses REJECT" );
-#else
-
- /* just a shorter name for the current buffer */
- YY_BUFFER_STATE b = yy_current_buffer;
-
- int yy_c_buf_p_offset =
- (int) (yy_c_buf_p - b->yy_ch_buf);
-
- if ( b->yy_is_our_buffer )
- {
- int new_size = b->yy_buf_size * 2;
-
- if ( new_size <= 0 )
- b->yy_buf_size += b->yy_buf_size / 8;
- else
- b->yy_buf_size *= 2;
-
- b->yy_ch_buf = (char *)
- /* Include room in for 2 EOB chars. */
- yy_flex_realloc( (void *) b->yy_ch_buf,
- b->yy_buf_size + 2 );
- }
- else
- /* Can't grow it, we don't own it. */
- b->yy_ch_buf = 0;
-
- if ( ! b->yy_ch_buf )
- YY_FATAL_ERROR(
- "fatal error - scanner input buffer overflow" );
-
- yy_c_buf_p = &b->yy_ch_buf[yy_c_buf_p_offset];
-
- num_to_read = yy_current_buffer->yy_buf_size -
- number_to_move - 1;
-#endif
- }
-
- if ( num_to_read > YY_READ_BUF_SIZE )
- num_to_read = YY_READ_BUF_SIZE;
-
- /* Read in more data. */
- YY_INPUT( (&yy_current_buffer->yy_ch_buf[number_to_move]),
- yy_n_chars, num_to_read );
- }
-
- if ( yy_n_chars == 0 )
- {
- if ( number_to_move == YY_MORE_ADJ )
- {
- ret_val = EOB_ACT_END_OF_FILE;
- yyrestart( yyin );
- }
-
- else
- {
- ret_val = EOB_ACT_LAST_MATCH;
- yy_current_buffer->yy_buffer_status =
- YY_BUFFER_EOF_PENDING;
- }
- }
-
- else
- ret_val = EOB_ACT_CONTINUE_SCAN;
-
- yy_n_chars += number_to_move;
- yy_current_buffer->yy_ch_buf[yy_n_chars] = YY_END_OF_BUFFER_CHAR;
- yy_current_buffer->yy_ch_buf[yy_n_chars + 1] = YY_END_OF_BUFFER_CHAR;
-
- yytext_ptr = &yy_current_buffer->yy_ch_buf[0];
-
- return ret_val;
- }
-
-
-/* yy_get_previous_state - get the state just before the EOB char was reached */
-
-static yy_state_type yy_get_previous_state()
- {
- register yy_state_type yy_current_state;
- register char *yy_cp;
-
- yy_current_state = yy_start;
- yy_current_state += YY_AT_BOL();
-
- for ( yy_cp = yytext_ptr + YY_MORE_ADJ; yy_cp < yy_c_buf_p; ++yy_cp )
- {
- register YY_CHAR yy_c = (*yy_cp ? yy_ec[YY_SC_TO_UI(*yy_cp)] : 1);
- if ( yy_accept[yy_current_state] )
- {
- yy_last_accepting_state = yy_current_state;
- yy_last_accepting_cpos = yy_cp;
- }
- while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
- {
- yy_current_state = (int) yy_def[yy_current_state];
- if ( yy_current_state >= 743 )
- yy_c = yy_meta[(unsigned int) yy_c];
- }
- yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c];
- }
-
- return yy_current_state;
- }
-
-
-/* yy_try_NUL_trans - try to make a transition on the NUL character
- *
- * synopsis
- * next_state = yy_try_NUL_trans( current_state );
- */
-
-#ifdef YY_USE_PROTOS
-static yy_state_type yy_try_NUL_trans( yy_state_type yy_current_state )
-#else
-static yy_state_type yy_try_NUL_trans( yy_current_state )
-yy_state_type yy_current_state;
-#endif
- {
- register int yy_is_jam;
- register char *yy_cp = yy_c_buf_p;
-
- register YY_CHAR yy_c = 1;
- if ( yy_accept[yy_current_state] )
- {
- yy_last_accepting_state = yy_current_state;
- yy_last_accepting_cpos = yy_cp;
- }
- while ( yy_chk[yy_base[yy_current_state] + yy_c] != yy_current_state )
- {
- yy_current_state = (int) yy_def[yy_current_state];
- if ( yy_current_state >= 743 )
- yy_c = yy_meta[(unsigned int) yy_c];
- }
- yy_current_state = yy_nxt[yy_base[yy_current_state] + (unsigned int) yy_c];
- yy_is_jam = (yy_current_state == 742);
-
- return yy_is_jam ? 0 : yy_current_state;
- }
-
-
-#ifndef YY_NO_UNPUT
-#ifdef YY_USE_PROTOS
-static void yyunput( int c, register char *yy_bp )
-#else
-static void yyunput( c, yy_bp )
-int c;
-register char *yy_bp;
-#endif
- {
- register char *yy_cp = yy_c_buf_p;
-
- /* undo effects of setting up yytext */
- *yy_cp = yy_hold_char;
-
- if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 )
- { /* need to shift things up to make room */
- /* +2 for EOB chars. */
- register int number_to_move = yy_n_chars + 2;
- register char *dest = &yy_current_buffer->yy_ch_buf[
- yy_current_buffer->yy_buf_size + 2];
- register char *source =
- &yy_current_buffer->yy_ch_buf[number_to_move];
-
- while ( source > yy_current_buffer->yy_ch_buf )
- *--dest = *--source;
-
- yy_cp += (int) (dest - source);
- yy_bp += (int) (dest - source);
- yy_n_chars = yy_current_buffer->yy_buf_size;
-
- if ( yy_cp < yy_current_buffer->yy_ch_buf + 2 )
- YY_FATAL_ERROR( "flex scanner push-back overflow" );
- }
-
- *--yy_cp = (char) c;
-
-
- yytext_ptr = yy_bp;
- yy_hold_char = *yy_cp;
- yy_c_buf_p = yy_cp;
- }
-#endif /* ifndef YY_NO_UNPUT */
-
-
-#ifdef __cplusplus
-static int yyinput()
-#else
-static int input()
-#endif
- {
- int c;
-
- *yy_c_buf_p = yy_hold_char;
-
- if ( *yy_c_buf_p == YY_END_OF_BUFFER_CHAR )
- {
- /* yy_c_buf_p now points to the character we want to return.
- * If this occurs *before* the EOB characters, then it's a
- * valid NUL; if not, then we've hit the end of the buffer.
- */
- if ( yy_c_buf_p < &yy_current_buffer->yy_ch_buf[yy_n_chars] )
- /* This was really a NUL. */
- *yy_c_buf_p = '\0';
-
- else
- { /* need more input */
- yytext_ptr = yy_c_buf_p;
- ++yy_c_buf_p;
-
- switch ( yy_get_next_buffer() )
- {
- case EOB_ACT_END_OF_FILE:
- {
- if ( yywrap() )
- {
- yy_c_buf_p =
- yytext_ptr + YY_MORE_ADJ;
- return EOF;
- }
-
- if ( ! yy_did_buffer_switch_on_eof )
- YY_NEW_FILE;
-#ifdef __cplusplus
- return yyinput();
-#else
- return input();
-#endif
- }
-
- case EOB_ACT_CONTINUE_SCAN:
- yy_c_buf_p = yytext_ptr + YY_MORE_ADJ;
- break;
-
- case EOB_ACT_LAST_MATCH:
-#ifdef __cplusplus
- YY_FATAL_ERROR(
- "unexpected last match in yyinput()" );
-#else
- YY_FATAL_ERROR(
- "unexpected last match in input()" );
-#endif
- }
- }
- }
-
- c = *(unsigned char *) yy_c_buf_p; /* cast for 8-bit char's */
- *yy_c_buf_p = '\0'; /* preserve yytext */
- yy_hold_char = *++yy_c_buf_p;
-
- yy_current_buffer->yy_at_bol = (c == '\n');
-
- return c;
- }
-
-
-#ifdef YY_USE_PROTOS
-void yyrestart( FILE *input_file )
-#else
-void yyrestart( input_file )
-FILE *input_file;
-#endif
- {
- if ( ! yy_current_buffer )
- yy_current_buffer = yy_create_buffer( yyin, YY_BUF_SIZE );
-
- yy_init_buffer( yy_current_buffer, input_file );
- yy_load_buffer_state();
- }
-
-
-#ifdef YY_USE_PROTOS
-void yy_switch_to_buffer( YY_BUFFER_STATE new_buffer )
-#else
-void yy_switch_to_buffer( new_buffer )
-YY_BUFFER_STATE new_buffer;
-#endif
- {
- if ( yy_current_buffer == new_buffer )
- return;
-
- if ( yy_current_buffer )
- {
- /* Flush out information for old buffer. */
- *yy_c_buf_p = yy_hold_char;
- yy_current_buffer->yy_buf_pos = yy_c_buf_p;
- yy_current_buffer->yy_n_chars = yy_n_chars;
- }
-
- yy_current_buffer = new_buffer;
- yy_load_buffer_state();
-
- /* We don't actually know whether we did this switch during
- * EOF (yywrap()) processing, but the only time this flag
- * is looked at is after yywrap() is called, so it's safe
- * to go ahead and always set it.
- */
- yy_did_buffer_switch_on_eof = 1;
- }
-
-
-#ifdef YY_USE_PROTOS
-void yy_load_buffer_state( void )
-#else
-void yy_load_buffer_state()
-#endif
- {
- yy_n_chars = yy_current_buffer->yy_n_chars;
- yytext_ptr = yy_c_buf_p = yy_current_buffer->yy_buf_pos;
- yyin = yy_current_buffer->yy_input_file;
- yy_hold_char = *yy_c_buf_p;
- }
-
-
-#ifdef YY_USE_PROTOS
-YY_BUFFER_STATE yy_create_buffer( FILE *file, int size )
-#else
-YY_BUFFER_STATE yy_create_buffer( file, size )
-FILE *file;
-int size;
-#endif
- {
- YY_BUFFER_STATE b;
-
- b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) );
- if ( ! b )
- YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" );
-
- b->yy_buf_size = size;
-
- /* yy_ch_buf has to be 2 characters longer than the size given because
- * we need to put in 2 end-of-buffer characters.
- */
- b->yy_ch_buf = (char *) yy_flex_alloc( b->yy_buf_size + 2 );
- if ( ! b->yy_ch_buf )
- YY_FATAL_ERROR( "out of dynamic memory in yy_create_buffer()" );
-
- b->yy_is_our_buffer = 1;
-
- yy_init_buffer( b, file );
-
- return b;
- }
-
-
-#ifdef YY_USE_PROTOS
-void yy_delete_buffer( YY_BUFFER_STATE b )
-#else
-void yy_delete_buffer( b )
-YY_BUFFER_STATE b;
-#endif
- {
- if ( ! b )
- return;
-
- if ( b == yy_current_buffer )
- yy_current_buffer = (YY_BUFFER_STATE) 0;
-
- if ( b->yy_is_our_buffer )
- yy_flex_free( (void *) b->yy_ch_buf );
-
- yy_flex_free( (void *) b );
- }
-
-
-#ifndef YY_ALWAYS_INTERACTIVE
-#ifndef YY_NEVER_INTERACTIVE
-extern int isatty YY_PROTO(( int ));
-#endif
-#endif
-
-#ifdef YY_USE_PROTOS
-void yy_init_buffer( YY_BUFFER_STATE b, FILE *file )
-#else
-void yy_init_buffer( b, file )
-YY_BUFFER_STATE b;
-FILE *file;
-#endif
-
-
- {
- yy_flush_buffer( b );
-
- b->yy_input_file = file;
- b->yy_fill_buffer = 1;
-
-#if YY_ALWAYS_INTERACTIVE
- b->yy_is_interactive = 1;
-#else
-#if YY_NEVER_INTERACTIVE
- b->yy_is_interactive = 0;
-#else
- b->yy_is_interactive = file ? (isatty( fileno(file) ) > 0) : 0;
-#endif
-#endif
- }
-
-
-#ifdef YY_USE_PROTOS
-void yy_flush_buffer( YY_BUFFER_STATE b )
-#else
-void yy_flush_buffer( b )
-YY_BUFFER_STATE b;
-#endif
-
- {
- b->yy_n_chars = 0;
-
- /* We always need two end-of-buffer characters. The first causes
- * a transition to the end-of-buffer state. The second causes
- * a jam in that state.
- */
- b->yy_ch_buf[0] = YY_END_OF_BUFFER_CHAR;
- b->yy_ch_buf[1] = YY_END_OF_BUFFER_CHAR;
-
- b->yy_buf_pos = &b->yy_ch_buf[0];
-
- b->yy_at_bol = 1;
- b->yy_buffer_status = YY_BUFFER_NEW;
-
- if ( b == yy_current_buffer )
- yy_load_buffer_state();
- }
-
-
-#ifndef YY_NO_SCAN_BUFFER
-#ifdef YY_USE_PROTOS
-YY_BUFFER_STATE yy_scan_buffer( char *base, yy_size_t size )
-#else
-YY_BUFFER_STATE yy_scan_buffer( base, size )
-char *base;
-yy_size_t size;
-#endif
- {
- YY_BUFFER_STATE b;
-
- if ( size < 2 ||
- base[size-2] != YY_END_OF_BUFFER_CHAR ||
- base[size-1] != YY_END_OF_BUFFER_CHAR )
- /* They forgot to leave room for the EOB's. */
- return 0;
-
- b = (YY_BUFFER_STATE) yy_flex_alloc( sizeof( struct yy_buffer_state ) );
- if ( ! b )
- YY_FATAL_ERROR( "out of dynamic memory in yy_scan_buffer()" );
-
- b->yy_buf_size = size - 2; /* "- 2" to take care of EOB's */
- b->yy_buf_pos = b->yy_ch_buf = base;
- b->yy_is_our_buffer = 0;
- b->yy_input_file = 0;
- b->yy_n_chars = b->yy_buf_size;
- b->yy_is_interactive = 0;
- b->yy_at_bol = 1;
- b->yy_fill_buffer = 0;
- b->yy_buffer_status = YY_BUFFER_NEW;
-
- yy_switch_to_buffer( b );
-
- return b;
- }
-#endif
-
-
-#ifndef YY_NO_SCAN_STRING
-#ifdef YY_USE_PROTOS
-YY_BUFFER_STATE yy_scan_string( yyconst char *str )
-#else
-YY_BUFFER_STATE yy_scan_string( str )
-yyconst char *str;
-#endif
- {
- int len;
- for ( len = 0; str[len]; ++len )
- ;
-
- return yy_scan_bytes( str, len );
- }
-#endif
-
-
-#ifndef YY_NO_SCAN_BYTES
-#ifdef YY_USE_PROTOS
-YY_BUFFER_STATE yy_scan_bytes( yyconst char *bytes, int len )
-#else
-YY_BUFFER_STATE yy_scan_bytes( bytes, len )
-yyconst char *bytes;
-int len;
-#endif
- {
- YY_BUFFER_STATE b;
- char *buf;
- yy_size_t n;
- int i;
-
- /* Get memory for full buffer, including space for trailing EOB's. */
- n = len + 2;
- buf = (char *) yy_flex_alloc( n );
- if ( ! buf )
- YY_FATAL_ERROR( "out of dynamic memory in yy_scan_bytes()" );
-
- for ( i = 0; i < len; ++i )
- buf[i] = bytes[i];
-
- buf[len] = buf[len+1] = YY_END_OF_BUFFER_CHAR;
-
- b = yy_scan_buffer( buf, n );
- if ( ! b )
- YY_FATAL_ERROR( "bad buffer in yy_scan_bytes()" );
-
- /* It's okay to grow etc. this buffer, and we should throw it
- * away when we're done.
- */
- b->yy_is_our_buffer = 1;
-
- return b;
- }
-#endif
-
-
-#ifndef YY_NO_PUSH_STATE
-#ifdef YY_USE_PROTOS
-static void yy_push_state( int new_state )
-#else
-static void yy_push_state( new_state )
-int new_state;
-#endif
- {
- if ( yy_start_stack_ptr >= yy_start_stack_depth )
- {
- yy_size_t new_size;
-
- yy_start_stack_depth += YY_START_STACK_INCR;
- new_size = yy_start_stack_depth * sizeof( int );
-
- if ( ! yy_start_stack )
- yy_start_stack = (int *) yy_flex_alloc( new_size );
-
- else
- yy_start_stack = (int *) yy_flex_realloc(
- (void *) yy_start_stack, new_size );
-
- if ( ! yy_start_stack )
- YY_FATAL_ERROR(
- "out of memory expanding start-condition stack" );
- }
-
- yy_start_stack[yy_start_stack_ptr++] = YY_START;
-
- BEGIN(new_state);
- }
-#endif
-
-
-#ifndef YY_NO_POP_STATE
-static void yy_pop_state()
- {
- if ( --yy_start_stack_ptr < 0 )
- YY_FATAL_ERROR( "start-condition stack underflow" );
-
- BEGIN(yy_start_stack[yy_start_stack_ptr]);
- }
-#endif
-
-
-#ifndef YY_NO_TOP_STATE
-static int yy_top_state()
- {
- return yy_start_stack[yy_start_stack_ptr - 1];
- }
-#endif
-
-#ifndef YY_EXIT_FAILURE
-#define YY_EXIT_FAILURE 2
-#endif
-
-#ifdef YY_USE_PROTOS
-static void yy_fatal_error( yyconst char msg[] )
-#else
-static void yy_fatal_error( msg )
-char msg[];
-#endif
- {
- (void) fprintf( stderr, "%s\n", msg );
- exit( YY_EXIT_FAILURE );
- }
-
-
-
-/* Redefine yyless() so it works in section 3 code. */
-
-#undef yyless
-#define yyless(n) \
- do \
- { \
- /* Undo effects of setting up yytext. */ \
- yytext[yyleng] = yy_hold_char; \
- yy_c_buf_p = yytext + n - YY_MORE_ADJ; \
- yy_hold_char = *yy_c_buf_p; \
- *yy_c_buf_p = '\0'; \
- yyleng = n; \
- } \
- while ( 0 )
-
-
-/* Internal utility routines. */
-
-#ifndef yytext_ptr
-#ifdef YY_USE_PROTOS
-static void yy_flex_strncpy( char *s1, yyconst char *s2, int n )
-#else
-static void yy_flex_strncpy( s1, s2, n )
-char *s1;
-yyconst char *s2;
-int n;
-#endif
- {
- register int i;
- for ( i = 0; i < n; ++i )
- s1[i] = s2[i];
- }
-#endif
-
-
-#ifdef YY_USE_PROTOS
-static void *yy_flex_alloc( yy_size_t size )
-#else
-static void *yy_flex_alloc( size )
-yy_size_t size;
-#endif
- {
- return (void *) malloc( size );
- }
-
-#ifdef YY_USE_PROTOS
-static void *yy_flex_realloc( void *ptr, yy_size_t size )
-#else
-static void *yy_flex_realloc( ptr, size )
-void *ptr;
-yy_size_t size;
-#endif
- {
- /* The cast to (char *) in the following accommodates both
- * implementations that use char* generic pointers, and those
- * that use void* generic pointers. It works with the latter
- * because both ANSI C and C++ allow castless assignment from
- * any pointer type to void*, and deal with argument conversions
- * as though doing an assignment.
- */
- return (void *) realloc( (char *) ptr, size );
- }
-
-#ifdef YY_USE_PROTOS
-static void yy_flex_free( void *ptr )
-#else
-static void yy_flex_free( ptr )
-void *ptr;
-#endif
- {
- free( ptr );
- }
-
-#if YY_MAIN
-int main()
- {
- yylex();
- return 0;
- }
-#endif
-#line 955 "yaccParser/hslexer.flex"
-
-
-/**********************************************************************
-* *
-* *
-* YACC/LEX Initialisation etc. *
-* *
-* *
-**********************************************************************/
-
-/*
- We initialise input_filename to "<stdin>".
- This allows unnamed sources to be piped into the parser.
-*/
-
-extern BOOLEAN acceptPrim;
-
-void
-yyinit(void)
-{
- input_filename = xstrdup("<stdin>");
-
- /* We must initialize the input buffer _now_, because we call
- setyyin _before_ calling yylex for the first time! */
- yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE));
-
- if (acceptPrim)
- PUSH_STATE(GlaExt);
- else
- PUSH_STATE(Code);
-}
-
-static void
-new_filename(char *f) /* This looks pretty dodgy to me (WDP) */
-{
- if (input_filename != NULL)
- free(input_filename);
- input_filename = xstrdup(f);
-}
-
-/**********************************************************************
-* *
-* *
-* Layout Processing *
-* *
-* *
-**********************************************************************/
-
-/*
- The following section deals with Haskell Layout conventions
- forcing insertion of ; or } as appropriate
-*/
-
-static BOOLEAN
-hsshouldindent(void)
-{
- return (!forgetindent && INDENTON);
-}
-
-
-/* Enter new context and set new indentation level */
-void
-hssetindent(void)
-{
-#ifdef HSP_DEBUG
- fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-
- /*
- * partain: first chk that new indent won't be less than current one; this code
- * doesn't make sense to me; hscolno tells the position of the _end_ of the
- * current token; what that has to do with indenting, I don't know.
- */
-
-
- if (hscolno - 1 <= INDENTPT) {
- if (INDENTPT == -1)
- return; /* Empty input OK for Haskell 1.1 */
- else {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "Layout error -- indentation should be > %d cols", INDENTPT);
- hsperror(errbuf);
- }
- }
- hsentercontext((hspcolno << 1) | 1);
-}
-
-
-/* Enter a new context without changing the indentation level */
-void
-hsincindent(void)
-{
-#ifdef HSP_DEBUG
- fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
- hsentercontext(indenttab[icontexts] & ~1);
-}
-
-
-/* Turn off indentation processing, usually because an explicit "{" has been seen */
-void
-hsindentoff(void)
-{
- forgetindent = TRUE;
-}
-
-
-/* Enter a new layout context. */
-static void
-hsentercontext(int indent)
-{
- /* Enter new context and set indentation as specified */
- if (++icontexts >= MAX_CONTEXTS) {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "`wheres' and `cases' nested too deeply (>%d)", MAX_CONTEXTS - 1);
- hsperror(errbuf);
- }
- forgetindent = FALSE;
- indenttab[icontexts] = indent;
-#ifdef HSP_DEBUG
- fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-}
-
-
-/* Exit a layout context */
-void
-hsendindent(void)
-{
- --icontexts;
-#ifdef HSP_DEBUG
- fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-}
-
-/*
- * Return checks the indentation level and returns ;, } or the specified token.
- */
-
-static int
-Return(int tok)
-{
-#ifdef HSP_DEBUG
- extern int yyleng;
-#endif
-
- if (hsshouldindent()) {
- if (hspcolno < INDENTPT) {
-#ifdef HSP_DEBUG
- fprintf(stderr, "inserted '}' before %d (%d:%d:%d:%d)\n", tok, hspcolno, hscolno, yyleng, INDENTPT);
-#endif
- hssttok = tok;
- return (VCCURLY);
- } else if (hspcolno == INDENTPT) {
-#ifdef HSP_DEBUG
- fprintf(stderr, "inserted ';' before %d (%d:%d)\n", tok, hspcolno, INDENTPT);
-#endif
- hssttok = -tok;
- return (SEMI);
- }
- }
- hssttok = -1;
-#ifdef HSP_DEBUG
- fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT);
-#endif
- return (tok);
-}
-
-
-/*
- * Redefine yylex to check for stacked tokens, yylex1() is the original yylex()
- */
-int
-yylex()
-{
- int tok;
- static BOOLEAN eof = FALSE;
-
- if (!eof) {
- if (hssttok != -1) {
- if (hssttok < 0) {
- tok = -hssttok;
- hssttok = -1;
- return tok;
- }
- RETURN(hssttok);
- } else {
- endlineno = hslineno;
- if ((tok = yylex1()) != EOF)
- return tok;
- else
- eof = TRUE;
- }
- }
- if (icontexts > icontexts_save) {
- if (INDENTON) {
- eof = TRUE;
- indenttab[icontexts] = 0;
- return (VCCURLY);
- } else
- hsperror("missing '}' at end of file");
- } else if (hsbuf_save != NULL) {
- fclose(yyin);
- yy_delete_buffer(YY_CURRENT_BUFFER);
- yy_switch_to_buffer(hsbuf_save);
- hsbuf_save = NULL;
- new_filename(filename_save);
- free(filename_save);
- hslineno = hslineno_save;
- hsplineno = hsplineno_save;
- hscolno = hscolno_save;
- hspcolno = hspcolno_save;
- etags = etags_save;
- in_interface = FALSE;
- icontexts = icontexts_save - 1;
- icontexts_save = 0;
-#ifdef HSP_DEBUG
- fprintf(stderr, "finished reading interface (%d:%d:%d)\n", hscolno, hspcolno, INDENTPT);
-#endif
- eof = FALSE;
- RETURN(LEOF);
- } else {
- yyterminate();
- }
- abort(); /* should never get here! */
- return(0);
-}
-
-/**********************************************************************
-* *
-* *
-* Input Processing for Interfaces *
-* *
-* *
-**********************************************************************/
-
-/* setyyin(file) open file as new lex input buffer */
-extern FILE *yyin;
-
-void
-setyyin(char *file)
-{
- hsbuf_save = YY_CURRENT_BUFFER;
- if ((yyin = fopen(file, "r")) == NULL) {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "can't read \"%-.50s\"", file);
- hsperror(errbuf);
- }
- yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE));
-
- hslineno_save = hslineno;
- hsplineno_save = hsplineno;
- hslineno = hsplineno = 1;
-
- filename_save = input_filename;
- input_filename = NULL;
- new_filename(file);
- hscolno_save = hscolno;
- hspcolno_save = hspcolno;
- hscolno = hspcolno = 0;
- in_interface = TRUE;
- etags_save = etags; /* do not do "etags" stuff in interfaces */
- etags = 0; /* We remember whether we are doing it in
- the module, so we can restore it later [WDP 94/09] */
- hsentercontext(-1); /* partain: changed this from 0 */
- icontexts_save = icontexts;
-#ifdef HSP_DEBUG
- fprintf(stderr, "reading %s (%d:%d:%d)\n", input_filename, hscolno_save, hspcolno_save, INDENTPT);
-#endif
-}
-
-static void
-layout_input(char *text, int len)
-{
-#ifdef HSP_DEBUG
- fprintf(stderr, "Scanning \"%s\"\n", text);
-#endif
-
- hsplineno = hslineno;
- hspcolno = hscolno;
-
- while (len-- > 0) {
- switch (*text++) {
- case '\n':
- case '\r':
- case '\f':
- hslineno++;
- hscolno = 0;
- break;
- case '\t':
- hscolno += 8 - (hscolno % 8); /* Tabs stops are 8 columns apart */
- break;
- case '\v':
- break;
- default:
- ++hscolno;
- break;
- }
- }
-}
-
-void
-setstartlineno(void)
-{
- startlineno = hsplineno;
-#if 1/*etags*/
-#else
- if (etags)
- fprintf(stderr,"%u\tsetstartlineno (col %u)\n",startlineno,hscolno);
-#endif
-}
-
-/**********************************************************************
-* *
-* *
-* Text Caching *
-* *
-* *
-**********************************************************************/
-
-#define CACHE_SIZE YY_BUF_SIZE
-
-static struct {
- unsigned allocated;
- unsigned next;
- char *text;
-} textcache = { 0, 0, NULL };
-
-static void
-cleartext(void)
-{
-/* fprintf(stderr, "cleartext\n"); */
- textcache.next = 0;
- if (textcache.allocated == 0) {
- textcache.allocated = CACHE_SIZE;
- textcache.text = xmalloc(CACHE_SIZE);
- }
-}
-
-static void
-addtext(char *text, unsigned length)
-{
-/* fprintf(stderr, "addtext: %d %s\n", length, text); */
-
- if (length == 0)
- return;
-
- if (textcache.next + length + 1 >= textcache.allocated) {
- textcache.allocated += length + CACHE_SIZE;
- textcache.text = xrealloc(textcache.text, textcache.allocated);
- }
- bcopy(text, textcache.text + textcache.next, length);
- textcache.next += length;
-}
-
-static void
-addchar(char c)
-{
-/* fprintf(stderr, "addchar: %c\n", c); */
-
- if (textcache.next + 2 >= textcache.allocated) {
- textcache.allocated += CACHE_SIZE;
- textcache.text = xrealloc(textcache.text, textcache.allocated);
- }
- textcache.text[textcache.next++] = c;
-}
-
-static char *
-fetchtext(unsigned *length)
-{
-/* fprintf(stderr, "fetchtext: %d\n", textcache.next); */
-
- *length = textcache.next;
- textcache.text[textcache.next] = '\0';
- return textcache.text;
-}
-
-/**********************************************************************
-* *
-* *
-* Identifier Processing *
-* *
-* *
-**********************************************************************/
-
-/*
- hsnewid Enters an id of length n into the symbol table.
-*/
-
-static void
-hsnewid(char *name, int length)
-{
- char save = name[length];
-
- name[length] = '\0';
- yylval.uid = installid(name);
- name[length] = save;
-}
-
-BOOLEAN
-isconstr(char *s) /* walks past leading underscores before using the macro */
-{
- char *temp = s;
-
- for ( ; temp != NULL && *temp == '_' ; temp++ );
-
- return _isconstr(temp);
-}
+++ /dev/null
-%{
-/**********************************************************************
-* *
-* *
-* LEX grammar for Haskell. *
-* ------------------------ *
-* *
-* (c) Copyright K. Hammond, University of Glasgow, *
-* 10th. February 1989 *
-* *
-* Modification History *
-* -------------------- *
-* *
-* 22/08/91 kh Initial Haskell 1.1 version. *
-* 18/10/91 kh Added 'ccall'. *
-* 19/11/91 kh Tidied generally. *
-* 04/12/91 kh Added Int#. *
-* 31/01/92 kh Haskell 1.2 version. *
-* 24/04/92 ps Added 'scc'. *
-* 03/06/92 kh Changed Infix/Prelude Handling. *
-* 23/08/93 jsm Changed to support flex *
-* *
-* *
-* Known Problems: *
-* *
-* None, any more. *
-* *
-**********************************************************************/
-
-#include "../../includes/config.h"
-
-#include <stdio.h>
-
-#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
-#include <string.h>
-/* An ANSI string.h and pre-ANSI memory.h might conflict. */
-#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
-#include <memory.h>
-#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
-#define index strchr
-#define rindex strrchr
-#define bcopy(s, d, n) memcpy ((d), (s), (n))
-#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
-#define bzero(s, n) memset ((s), 0, (n))
-#else /* not STDC_HEADERS and not HAVE_STRING_H */
-#include <strings.h>
-/* memory.h and strings.h conflict on some systems. */
-#endif /* not STDC_HEADERS and not HAVE_STRING_H */
-
-#include "hspincl.h"
-#include "hsparser.tab.h"
-#include "constants.h"
-#include "utils.h"
-
-/* Our substitute for <ctype.h> */
-
-#define NCHARS 256
-#define _S 0x1
-#define _D 0x2
-#define _H 0x4
-#define _O 0x8
-#define _C 0x10
-
-#define _isconstr(s) (CharTable[*s]&(_C))
-BOOLEAN isconstr PROTO((char *)); /* fwd decl */
-
-static unsigned char CharTable[NCHARS] = {
-/* nul */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* bs */ 0, _S, _S, _S, _S, 0, 0, 0,
-/* dle */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* can */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* sp */ _S, 0, 0, 0, 0, 0, 0, 0,
-/* '(' */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* '0' */ _D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,_D|_H|_O,
-/* '8' */ _D|_H, _D|_H, _C, 0, 0, 0, 0, 0,
-/* '@' */ 0, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _H|_C, _C,
-/* 'H' */ _C, _C, _C, _C, _C, _C, _C, _C,
-/* 'P' */ _C, _C, _C, _C, _C, _C, _C, _C,
-/* 'X' */ _C, _C, _C, 0, 0, 0, 0, 0,
-/* '`' */ 0, _H, _H, _H, _H, _H, _H, 0,
-/* 'h' */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* 'p' */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* 'x' */ 0, 0, 0, 0, 0, 0, 0, 0,
-
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-/* */ 0, 0, 0, 0, 0, 0, 0, 0,
-};
-
-/**********************************************************************
-* *
-* *
-* Declarations *
-* *
-* *
-**********************************************************************/
-
-char *input_filename = NULL; /* Always points to a dynamically allocated string */
-
-/*
- * For my own sanity, things that are not part of the flex skeleton
- * have been renamed as hsXXXXX rather than yyXXXXX. --JSM
- */
-
-static int hslineno = 0; /* Line number at end of token */
-int hsplineno = 0; /* Line number at end of previous token */
-
-static int hscolno = 0; /* Column number at end of token */
-int hspcolno = 0; /* Column number at end of previous token */
-static int hsmlcolno = 0; /* Column number for multiple-rule lexemes */
-
-int startlineno = 0; /* The line number where something starts */
-int endlineno = 0; /* The line number where something ends */
-
-static BOOLEAN noGap = TRUE; /* For checking string gaps */
-static BOOLEAN forgetindent = FALSE; /* Don't bother applying indentation rules */
-
-static int nested_comments; /* For counting comment nesting depth */
-
-/* Hacky definition of yywrap: see flex doc.
-
- If we don't do this, then we'll have to get the default
- yywrap from the flex library, which is often something
- we are not good at locating. This avoids that difficulty.
- (Besides which, this is the way old flexes (pre 2.4.x) did it.)
- WDP 94/09/05
-*/
-#define yywrap() 1
-
-/* Essential forward declarations */
-
-static void hsnewid PROTO((char *, int));
-static void layout_input PROTO((char *, int));
-static void cleartext (NO_ARGS);
-static void addtext PROTO((char *, unsigned));
-static void addchar PROTO((char));
-static char *fetchtext PROTO((unsigned *));
-static void new_filename PROTO((char *));
-static int Return PROTO((int));
-static void hsentercontext PROTO((int));
-
-/* Special file handling for IMPORTS */
-/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */
-
-static YY_BUFFER_STATE hsbuf_save = NULL; /* Saved input buffer */
-static char *filename_save; /* File Name */
-static int hslineno_save = 0, /* Line Number */
- hsplineno_save = 0, /* Line Number of Prev. token */
- hscolno_save = 0, /* Indentation */
- hspcolno_save = 0; /* Left Indentation */
-static short icontexts_save = 0; /* Indent Context Level */
-
-static BOOLEAN etags_save; /* saved: whether doing etags stuff or not */
-extern BOOLEAN etags; /* that which is saved */
-
-extern BOOLEAN nonstandardFlag; /* Glasgow extensions allowed */
-
-static BOOLEAN in_interface = FALSE; /* TRUE if we are reading a .hi file */
-
-extern BOOLEAN ignorePragmas; /* True when we should ignore pragmas */
-extern int minAcceptablePragmaVersion; /* see documentation in main.c */
-extern int maxAcceptablePragmaVersion;
-extern int thisIfacePragmaVersion;
-
-static int hssttok = -1; /* Stacked Token: -1 -- no token; -ve -- ";"
- * inserted before token +ve -- "}" inserted before
- * token */
-
-short icontexts = 0; /* Which context we're in */
-
-
-
-/*
- Table of indentations: right bit indicates whether to use
- indentation rules (1 = use rules; 0 = ignore)
-
- partain:
- push one of these "contexts" at every "case" or "where"; the right bit says
- whether user supplied braces, etc., or not. pop appropriately (hsendindent).
-
- ALSO, a push/pop when enter/exit a new file (e.g., on importing). A -1 is
- pushed (the "column" for "module", "interface" and EOF). The -1 from the initial
- push is shown just below.
-
-*/
-
-
-static short indenttab[MAX_CONTEXTS] = {-1};
-
-#define INDENTPT (indenttab[icontexts]>>1)
-#define INDENTON (indenttab[icontexts]&1)
-
-#define RETURN(tok) return(Return(tok))
-
-#undef YY_DECL
-#define YY_DECL int yylex1()
-
-/* We should not peek at yy_act, but flex calls us even for the internal action
- triggered on 'end-of-buffer' (This is not true of flex 2.4.4 and up, but
- to support older versions of flex, we'll continue to peek for now.
- */
-#define YY_USER_ACTION \
- if (yy_act != YY_END_OF_BUFFER) layout_input(yytext, yyleng);
-
-#if 0/*debug*/
-#undef YY_BREAK
-#define YY_BREAK if (etags) fprintf(stderr,"%d %d / %d %d / %d\n",hsplineno,hspcolno,hslineno,hscolno,startlineno); break;
-#endif
-
-/* Each time we enter a new start state, we push it onto the state stack.
- Note that the rules do not allow us to underflow or overflow the stack.
- (At least, they shouldn't.) The maximum expected depth is 4:
- 0: Code -> 1: String -> 2: StringEsc -> 3: Comment
-*/
-static int StateStack[5];
-static int StateDepth = -1;
-
-#ifdef HSP_DEBUG
-#define PUSH_STATE(n) do {\
- fprintf(stderr,"Pushing %d (%d)\n", n, StateDepth + 1);\
- StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
-#define POP_STATE do {--StateDepth;\
- fprintf(stderr,"Popping %d (%d)\n", StateStack[StateDepth], StateDepth);\
- BEGIN(StateStack[StateDepth]);} while(0)
-#else
-#define PUSH_STATE(n) do {StateStack[++StateDepth] = (n); BEGIN(n);} while(0)
-#define POP_STATE do {--StateDepth; BEGIN(StateStack[StateDepth]);} while(0)
-#endif
-
-%}
-
-/* The start states are:
- Code -- normal Haskell code (principal lexer)
- GlaExt -- Haskell code with Glasgow extensions
- Comment -- Nested comment processing
- String -- Inside a string literal with backslashes
- StringEsc -- Immediately following a backslash in a string literal
- Char -- Inside a character literal with backslashes
- CharEsc -- Immediately following a backslash in a character literal
-
- Note that the INITIAL state is unused. Also note that these states
- are _exclusive_. All rules should be prefixed with an appropriate
- list of start states.
- */
-
-%x Char CharEsc Code Comment GlaExt GhcPragma UserPragma String StringEsc
-
-D [0-9]
-O [0-7]
-H [0-9A-Fa-f]
-N {D}+
-F {N}"."{N}(("e"|"E")("+"|"-")?{N})?
-S [!#$%&*+./<=>?@\\^|~:]
-SId ({S}|~|-){S}*
-CHAR [ !#$%&()*+,\-./0-9:;<=>?@A-Z\[\]^_`a-z{|}~]
-L [A-Z]
-I [A-Za-z]
-i [A-Za-z0-9'_]
-Id {I}({i})*
-WS [ \t\n\r\f\v]
-CNTRL [@A-Z\[\\\]^_]
-NL [\n\r]
-
-%%
-
-%{
- /*
- * Special GHC pragma rules. Do we need a start state for interface files,
- * so these won't be matched in source files? --JSM
- */
-%}
-
-<Code,GlaExt>^"# ".*{NL} {
- char tempf[FILENAME_SIZE];
- sscanf(yytext+1, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
-
-<Code,GlaExt>^"#line ".*{NL} {
- char tempf[FILENAME_SIZE];
- sscanf(yytext+5, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
-
-<Code,GlaExt>"{-# LINE ".*"-}"{NL} {
- /* partain: pragma-style line directive */
- char tempf[FILENAME_SIZE];
- sscanf(yytext+9, "%d \"%[^\"]", &hslineno, tempf);
- new_filename(tempf);
- hsplineno = hslineno; hscolno = 0; hspcolno = 0;
- }
-<Code,GlaExt>"{-# GHC_PRAGMA INTERFACE VERSION "{D}+" #-}" {
- sscanf(yytext+33,"%d ",&thisIfacePragmaVersion);
- }
-<Code,GlaExt>"{-# GHC_PRAGMA " {
- if ( ignorePragmas ||
- thisIfacePragmaVersion < minAcceptablePragmaVersion ||
- thisIfacePragmaVersion > maxAcceptablePragmaVersion) {
- nested_comments = 1;
- PUSH_STATE(Comment);
- } else {
- PUSH_STATE(GhcPragma);
- RETURN(GHC_PRAGMA);
- }
- }
-<GhcPragma>"_N_" { RETURN(NO_PRAGMA); }
-<GhcPragma>"_NI_" { RETURN(NOINFO_PRAGMA); }
-<GhcPragma>"_ABSTRACT_" { RETURN(ABSTRACT_PRAGMA); }
-<GhcPragma>"_DEFOREST_" { RETURN(DEFOREST_PRAGMA); }
-<GhcPragma>"_SPECIALISE_" { RETURN(SPECIALISE_PRAGMA); }
-<GhcPragma>"_M_" { RETURN(MODNAME_PRAGMA); }
-<GhcPragma>"_A_" { RETURN(ARITY_PRAGMA); }
-<GhcPragma>"_U_" { RETURN(UPDATE_PRAGMA); }
-<GhcPragma>"_S_" { RETURN(STRICTNESS_PRAGMA); }
-<GhcPragma>"_K_" { RETURN(KIND_PRAGMA); }
-<GhcPragma>"_MF_" { RETURN(MAGIC_UNFOLDING_PRAGMA); }
-<GhcPragma>"_F_" { RETURN(UNFOLDING_PRAGMA); }
-
-<GhcPragma>"_!_" { RETURN(COCON); }
-<GhcPragma>"_#_" { RETURN(COPRIM); }
-<GhcPragma>"_APP_" { RETURN(COAPP); }
-<GhcPragma>"_TYAPP_" { RETURN(COTYAPP); }
-<GhcPragma>"_ALG_" { RETURN(CO_ALG_ALTS); }
-<GhcPragma>"_PRIM_" { RETURN(CO_PRIM_ALTS); }
-<GhcPragma>"_NO_DEFLT_" { RETURN(CO_NO_DEFAULT); }
-<GhcPragma>"_LETREC_" { RETURN(CO_LETREC); }
-
-<GhcPragma>"_PRELUDE_DICTS_CC_" { RETURN(CO_PRELUDE_DICTS_CC); }
-<GhcPragma>"_ALL_DICTS_CC_" { RETURN(CO_ALL_DICTS_CC); }
-<GhcPragma>"_USER_CC_" { RETURN(CO_USER_CC); }
-<GhcPragma>"_AUTO_CC_" { RETURN(CO_AUTO_CC); }
-<GhcPragma>"_DICT_CC_" { RETURN(CO_DICT_CC); }
-
-<GhcPragma>"_DUPD_CC_" { RETURN(CO_DUPD_CC); }
-<GhcPragma>"_CAF_CC_" { RETURN(CO_CAF_CC); }
-
-<GhcPragma>"_SDSEL_" { RETURN(CO_SDSEL_ID); }
-<GhcPragma>"_METH_" { RETURN(CO_METH_ID); }
-<GhcPragma>"_DEFM_" { RETURN(CO_DEFM_ID); }
-<GhcPragma>"_DFUN_" { RETURN(CO_DFUN_ID); }
-<GhcPragma>"_CONSTM_" { RETURN(CO_CONSTM_ID); }
-<GhcPragma>"_SPEC_" { RETURN(CO_SPEC_ID); }
-<GhcPragma>"_WRKR_" { RETURN(CO_WRKR_ID); }
-<GhcPragma>"_ORIG_" { RETURN(CO_ORIG_NM); /* fully-qualified original name*/ }
-
-<GhcPragma>"_ALWAYS_" { RETURN(UNFOLD_ALWAYS); }
-<GhcPragma>"_IF_ARGS_" { RETURN(UNFOLD_IF_ARGS); }
-
-<GhcPragma>"_NOREP_I_" { RETURN(NOREP_INTEGER); }
-<GhcPragma>"_NOREP_R_" { RETURN(NOREP_RATIONAL); }
-<GhcPragma>"_NOREP_S_" { RETURN(NOREP_STRING); }
-
-<GhcPragma>" #-}" { POP_STATE; RETURN(END_PRAGMA); }
-
-<Code,GlaExt>"{-#"{WS}*"SPECIALI"[SZ]E {
- PUSH_STATE(UserPragma);
- RETURN(SPECIALISE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"INLINE" {
- PUSH_STATE(UserPragma);
- RETURN(INLINE_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"MAGIC_UNFOLDING" {
- PUSH_STATE(UserPragma);
- RETURN(MAGIC_UNFOLDING_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"DEFOREST" {
- PUSH_STATE(UserPragma);
- RETURN(DEFOREST_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*"ABSTRACT" {
- PUSH_STATE(UserPragma);
- RETURN(ABSTRACT_UPRAGMA);
- }
-<Code,GlaExt>"{-#"{WS}*[A-Z_]+ {
- fprintf(stderr, "Warning: \"%s\", line %d: Unrecognised pragma '",
- input_filename, hsplineno);
- format_string(stderr, (unsigned char *) yytext, yyleng);
- fputs("'\n", stderr);
- nested_comments = 1;
- PUSH_STATE(Comment);
- }
-<UserPragma>"#-}" { POP_STATE; RETURN(END_UPRAGMA); }
-
-%{
- /*
- * Haskell keywords. `scc' is actually a Glasgow extension, but it is
- * intentionally accepted as a keyword even for normal <Code>.
- */
-%}
-
-<Code,GlaExt,GhcPragma>"case" { RETURN(CASE); }
-<Code,GlaExt>"class" { RETURN(CLASS); }
-<Code,GlaExt,UserPragma>"data" { RETURN(DATA); }
-<Code,GlaExt>"default" { RETURN(DEFAULT); }
-<Code,GlaExt>"deriving" { RETURN(DERIVING); }
-<Code,GlaExt>"else" { RETURN(ELSE); }
-<Code,GlaExt>"hiding" { RETURN(HIDING); }
-<Code,GlaExt>"if" { RETURN(IF); }
-<Code,GlaExt>"import" { RETURN(IMPORT); }
-<Code,GlaExt>"infix" { RETURN(INFIX); }
-<Code,GlaExt>"infixl" { RETURN(INFIXL); }
-<Code,GlaExt>"infixr" { RETURN(INFIXR); }
-<Code,GlaExt,UserPragma>"instance" { RETURN(INSTANCE); }
-<Code,GlaExt>"interface" { RETURN(INTERFACE); }
-<Code,GlaExt>"module" { RETURN(MODULE); }
-<Code,GlaExt,GhcPragma>"of" { RETURN(OF); }
-<Code,GlaExt>"renaming" { RETURN(RENAMING); }
-<Code,GlaExt>"then" { RETURN(THEN); }
-<Code,GlaExt>"to" { RETURN(TO); }
-<Code,GlaExt>"type" { RETURN(TYPE); }
-<Code,GlaExt>"where" { RETURN(WHERE); }
-<Code,GlaExt,GhcPragma>"in" { RETURN(IN); }
-<Code,GlaExt,GhcPragma>"let" { RETURN(LET); }
-<GlaExt,GhcPragma>"_ccall_" { RETURN(CCALL); }
-<GlaExt,GhcPragma>"_ccall_GC_" { RETURN(CCALL_GC); }
-<GlaExt,GhcPragma>"_casm_" { RETURN(CASM); }
-<GlaExt,GhcPragma>"_casm_GC_" { RETURN(CASM_GC); }
-<Code,GlaExt,GhcPragma>"_scc_" { RETURN(SCC); }
-<GhcPragma>"_forall_" { RETURN(FORALL); }
-
-%{
- /*
- * Haskell operators. Nothing special about these.
- */
-%}
-
-<Code,GlaExt>".." { RETURN(DOTDOT); }
-<Code,GlaExt,GhcPragma>";" { RETURN(SEMI); }
-<Code,GlaExt,GhcPragma,UserPragma>"," { RETURN(COMMA); }
-<Code,GlaExt,GhcPragma>"|" { RETURN(VBAR); }
-<Code,GlaExt,GhcPragma,UserPragma>"=" { RETURN(EQUAL); }
-<Code,GlaExt>"<-" { RETURN(LARROW); }
-<Code,GlaExt,GhcPragma,UserPragma>"->" { RETURN(RARROW); }
-<Code,GlaExt,GhcPragma,UserPragma>"=>" { RETURN(DARROW); }
-<Code,GlaExt,GhcPragma,UserPragma>"::" { RETURN(DCOLON); }
-<Code,GlaExt,GhcPragma,UserPragma>"(" { RETURN(OPAREN); }
-<Code,GlaExt,GhcPragma,UserPragma>")" { RETURN(CPAREN); }
-<Code,GlaExt,GhcPragma,UserPragma>"[" { RETURN(OBRACK); }
-<Code,GlaExt,GhcPragma,UserPragma>"]" { RETURN(CBRACK); }
-<Code,GlaExt,GhcPragma>"{" { RETURN(OCURLY); }
-<Code,GlaExt,GhcPragma>"}" { RETURN(CCURLY); }
-<Code,GlaExt>"+" { RETURN(PLUS); }
-<Code,GlaExt>"@" { RETURN(AT); }
-<Code,GlaExt,GhcPragma>"\\" { RETURN(LAMBDA); }
-<GhcPragma>"_/\\_" { RETURN(TYLAMBDA); }
-<Code,GlaExt>"_" { RETURN(WILDCARD); }
-<Code,GlaExt,GhcPragma>"`" { RETURN(BQUOTE); }
-<Code,GlaExt>"~" { RETURN(LAZY); }
-<Code,GlaExt>"-" { RETURN(MINUS); }
-
-%{
- /*
- * Integers and (for Glasgow extensions) primitive integers. Note that
- * we pass all of the text on to the parser, because flex/C can't handle
- * arbitrary precision numbers.
- */
-%}
-
-<GlaExt>("-")?"0o"{O}+"#" { /* octal */
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
-<Code,GlaExt>"0o"{O}+ { /* octal */
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
-<GlaExt>("-")?"0x"{H}+"#" { /* hexadecimal */
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
-<Code,GlaExt>"0x"{H}+ { /* hexadecimal */
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
-<GlaExt,GhcPragma>("-")?{N}"#" {
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(INTPRIM);
- }
-<Code,GlaExt,GhcPragma>{N} {
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(INTEGER);
- }
-
-%{
- /*
- * Floats and (for Glasgow extensions) primitive floats/doubles.
- */
-%}
-
-<GlaExt,GhcPragma>("-")?{F}"##" {
- yylval.uid = xstrndup(yytext, yyleng - 2);
- RETURN(DOUBLEPRIM);
- }
-<GlaExt,GhcPragma>("-")?{F}"#" {
- yylval.uid = xstrndup(yytext, yyleng - 1);
- RETURN(FLOATPRIM);
- }
-<Code,GlaExt>{F} {
- yylval.uid = xstrndup(yytext, yyleng);
- RETURN(FLOAT);
- }
-
-%{
- /*
- * Funky ``foo'' style C literals for Glasgow extensions
- */
-%}
-
-<GlaExt,GhcPragma>"``"[^']+"''" {
- hsnewid(yytext + 2, yyleng - 4);
- RETURN(CLITLIT);
- }
-
-%{
- /*
- * Identifiers, both variables and operators. The trailing hash is allowed
- * for Glasgow extensions.
- */
-%}
-
-<GhcPragma>"_NIL_" { hsnewid(yytext, yyleng); RETURN(CONID); }
-<GhcPragma>"_TUP_"{D}+ { hsnewid(yytext, yyleng); RETURN(CONID); }
-<GhcPragma>[a-z]{i}*"$"[a-z]{i}* { hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); }
-
-%{
-/* These SHOULDNAE work in "Code" (sigh) */
-%}
-<Code,GlaExt,GhcPragma,UserPragma>{Id}"#" {
- if (! (nonstandardFlag || in_interface)) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
- hsperror(errbuf);
- }
- hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONID : VARID);
- }
-<Code,GlaExt,GhcPragma,UserPragma>_+{Id} {
- if (! (nonstandardFlag || in_interface)) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Non-standard identifier (leading underscore): %s\n", yytext);
- hsperror(errbuf);
- }
- hsnewid(yytext, yyleng);
- RETURN(isconstr(yytext) ? CONID : VARID);
- /* NB: ^^^^^^^^ : not the macro! */
- }
-<Code,GlaExt,GhcPragma,UserPragma>{Id} {
- hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONID : VARID);
- }
-<Code,GlaExt,GhcPragma,UserPragma>{SId} {
- hsnewid(yytext, yyleng);
- RETURN(_isconstr(yytext) ? CONSYM : VARSYM);
- }
-
-%{
- /* Why is `{Id}#` matched this way, and `{Id}` lexed as three tokens? --JSM */
-
- /* Because we can make the former well-behaved (we defined them).
-
- Sadly, the latter is defined by Haskell, which allows such
- la-la land constructs as `{-a 900-line comment-} foo`. (WDP 94/12)
- */
-%}
-
-<GlaExt,GhcPragma,UserPragma>"`"{Id}"#`" {
- hsnewid(yytext + 1, yyleng - 2);
- RETURN(_isconstr(yytext+1) ? CONSYM : VARSYM);
- }
-
-%{
- /*
- * Character literals. The first form is the quick form, for character
- * literals that don't contain backslashes. Literals with backslashes are
- * lexed through multiple rules. First, we match the open ' and as many
- * normal characters as possible. This puts us into the <Char> state, where
- * a backslash is legal. Then, we match the backslash and move into the
- * <CharEsc> state. When we drop out of <CharEsc>, we collect more normal
- * characters and the close '. We may end up with too many characters, but
- * this allows us to easily share the lex rules with strings. Excess characters
- * are ignored with a warning.
- */
-%}
-
-<GlaExt,GhcPragma>'({CHAR}|"\"")"'#" {
- yylval.uhstring = installHstring(1, yytext+1);
- RETURN(CHARPRIM);
- }
-<Code,GlaExt>'({CHAR}|"\"")' {
- yylval.uhstring = installHstring(1, yytext+1);
- RETURN(CHAR);
- }
-<Code,GlaExt>'' {char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "'' is not a valid character (or string) literal\n");
- hsperror(errbuf);
- }
-<Code,GlaExt,GhcPragma>'({CHAR}|"\"")* {
- hsmlcolno = hspcolno;
- cleartext();
- addtext(yytext+1, yyleng-1);
- PUSH_STATE(Char);
- }
-<Char>({CHAR}|"\"")*'# {
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng - 2);
- text = fetchtext(&length);
-
- if (! (nonstandardFlag || in_interface)) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "`Char-hash' literals are non-standard: %s\n", text);
- hsperror(errbuf);
- }
-
- if (length > 1) {
- fprintf(stderr, "\"%s\", line %d, column %d: Unboxed character literal '",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) text, length);
- fputs("' too long\n", stderr);
- hsperror("");
- }
- yylval.uhstring = installHstring(1, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(CHARPRIM);
- }
-<Char>({CHAR}|"\"")*' {
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng - 1);
- text = fetchtext(&length);
-
- if (length > 1) {
- fprintf(stderr, "\"%s\", line %d, column %d: Character literal '",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) text, length);
- fputs("' too long\n", stderr);
- hsperror("");
- }
- yylval.uhstring = installHstring(1, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(CHAR);
- }
-<Char>({CHAR}|"\"")+ { addtext(yytext, yyleng); }
-
-
-%{
- /*
- * String literals. The first form is the quick form, for string literals
- * that don't contain backslashes. Literals with backslashes are lexed
- * through multiple rules. First, we match the open " and as many normal
- * characters as possible. This puts us into the <String> state, where
- * a backslash is legal. Then, we match the backslash and move into the
- * <StringEsc> state. When we drop out of <StringEsc>, we collect more normal
- * characters, moving back and forth between <String> and <StringEsc> as more
- * backslashes are encountered. (We may even digress into <Comment> mode if we
- * find a comment in a gap between backslashes.) Finally, we read the last chunk
- * of normal characters and the close ".
- */
-%}
-
-<GlaExt,GhcPragma>"\""({CHAR}|"'")*"\""# {
- yylval.uhstring = installHstring(yyleng-3, yytext+1);
- /* the -3 accounts for the " on front, "# on the end */
- RETURN(STRINGPRIM);
- }
-<Code,GlaExt,GhcPragma>"\""({CHAR}|"'")*"\"" {
- yylval.uhstring = installHstring(yyleng-2, yytext+1);
- RETURN(STRING);
- }
-<Code,GlaExt,GhcPragma>"\""({CHAR}|"'")* {
- hsmlcolno = hspcolno;
- cleartext();
- addtext(yytext+1, yyleng-1);
- PUSH_STATE(String);
- }
-<String>({CHAR}|"'")*"\"#" {
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng-2);
- text = fetchtext(&length);
-
- if (! (nonstandardFlag || in_interface)) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "`String-hash' literals are non-standard: %s\n", text);
- hsperror(errbuf);
- }
-
- yylval.uhstring = installHstring(length, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(STRINGPRIM);
- }
-<String>({CHAR}|"'")*"\"" {
- unsigned length;
- char *text;
-
- addtext(yytext, yyleng-1);
- text = fetchtext(&length);
-
- yylval.uhstring = installHstring(length, text);
- hspcolno = hsmlcolno;
- POP_STATE;
- RETURN(STRING);
- }
-<String>({CHAR}|"'")+ { addtext(yytext, yyleng); }
-
-%{
- /*
- * Character and string escapes are roughly the same, but strings have the
- * extra `\&' sequence which is not allowed for characters. Also, comments
- * are allowed in the <StringEsc> state. (See the comment section much
- * further down.)
- *
- * NB: Backslashes and tabs are stored in strings as themselves.
- * But if we print them (in printtree.c), they must go out as
- * "\\\\" and "\\t" respectively. (This is because of the bogus
- * intermediate format that the parser produces. It uses '\t' fpr end of
- * string, so it needs to be able to escape tabs, which means that it
- * also needs to be able to escape the escape character ('\\'). Sigh.
- */
-%}
-
-<Char>\\ { PUSH_STATE(CharEsc); }
-<String>\\& /* Ignore */ ;
-<String>\\ { PUSH_STATE(StringEsc); noGap = TRUE; }
-
-<CharEsc>\\ { addchar(*yytext); POP_STATE; }
-<StringEsc>\\ { if (noGap) { addchar(*yytext); } POP_STATE; }
-
-<CharEsc,StringEsc>["'] { addchar(*yytext); POP_STATE; }
-<CharEsc,StringEsc>NUL { addchar('\000'); POP_STATE; }
-<CharEsc,StringEsc>SOH { addchar('\001'); POP_STATE; }
-<CharEsc,StringEsc>STX { addchar('\002'); POP_STATE; }
-<CharEsc,StringEsc>ETX { addchar('\003'); POP_STATE; }
-<CharEsc,StringEsc>EOT { addchar('\004'); POP_STATE; }
-<CharEsc,StringEsc>ENQ { addchar('\005'); POP_STATE; }
-<CharEsc,StringEsc>ACK { addchar('\006'); POP_STATE; }
-<CharEsc,StringEsc>BEL |
-<CharEsc,StringEsc>a { addchar('\007'); POP_STATE; }
-<CharEsc,StringEsc>BS |
-<CharEsc,StringEsc>b { addchar('\010'); POP_STATE; }
-<CharEsc,StringEsc>HT |
-<CharEsc,StringEsc>t { addchar('\011'); POP_STATE; }
-<CharEsc,StringEsc>LF |
-<CharEsc,StringEsc>n { addchar('\012'); POP_STATE; }
-<CharEsc,StringEsc>VT |
-<CharEsc,StringEsc>v { addchar('\013'); POP_STATE; }
-<CharEsc,StringEsc>FF |
-<CharEsc,StringEsc>f { addchar('\014'); POP_STATE; }
-<CharEsc,StringEsc>CR |
-<CharEsc,StringEsc>r { addchar('\015'); POP_STATE; }
-<CharEsc,StringEsc>SO { addchar('\016'); POP_STATE; }
-<CharEsc,StringEsc>SI { addchar('\017'); POP_STATE; }
-<CharEsc,StringEsc>DLE { addchar('\020'); POP_STATE; }
-<CharEsc,StringEsc>DC1 { addchar('\021'); POP_STATE; }
-<CharEsc,StringEsc>DC2 { addchar('\022'); POP_STATE; }
-<CharEsc,StringEsc>DC3 { addchar('\023'); POP_STATE; }
-<CharEsc,StringEsc>DC4 { addchar('\024'); POP_STATE; }
-<CharEsc,StringEsc>NAK { addchar('\025'); POP_STATE; }
-<CharEsc,StringEsc>SYN { addchar('\026'); POP_STATE; }
-<CharEsc,StringEsc>ETB { addchar('\027'); POP_STATE; }
-<CharEsc,StringEsc>CAN { addchar('\030'); POP_STATE; }
-<CharEsc,StringEsc>EM { addchar('\031'); POP_STATE; }
-<CharEsc,StringEsc>SUB { addchar('\032'); POP_STATE; }
-<CharEsc,StringEsc>ESC { addchar('\033'); POP_STATE; }
-<CharEsc,StringEsc>FS { addchar('\034'); POP_STATE; }
-<CharEsc,StringEsc>GS { addchar('\035'); POP_STATE; }
-<CharEsc,StringEsc>RS { addchar('\036'); POP_STATE; }
-<CharEsc,StringEsc>US { addchar('\037'); POP_STATE; }
-<CharEsc,StringEsc>SP { addchar('\040'); POP_STATE; }
-<CharEsc,StringEsc>DEL { addchar('\177'); POP_STATE; }
-<CharEsc,StringEsc>"^"{CNTRL} { char c = yytext[1] - '@'; addchar(c); POP_STATE; }
-<CharEsc,StringEsc>{D}+ {
- int i = strtol(yytext, NULL, 10);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
-<CharEsc,StringEsc>o{O}+ {
- int i = strtol(yytext + 1, NULL, 8);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
-<CharEsc,StringEsc>x{H}+ {
- int i = strtol(yytext + 1, NULL, 16);
- if (i < NCHARS) {
- addchar((char) i);
- } else {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf, "Numeric escape \"\\%s\" out of range\n",
- yytext);
- hsperror(errbuf);
- }
- POP_STATE;
- }
-
-%{
- /*
- * Simple comments and whitespace. Normally, we would just ignore these, but
- * in case we're processing a string escape, we need to note that we've seen
- * a gap.
- *
- * Note that we cater for a comment line that *doesn't* end in a newline.
- * This is incorrect, strictly speaking, but seems like the right thing
- * to do. Reported by Rajiv Mirani. (WDP 95/08)
- */
-%}
-
-<Code,GlaExt,StringEsc>"--".*{NL}?{WS}* |
-<Code,GlaExt,GhcPragma,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
-
-%{
- /*
- * Nested comments. The major complication here is in trying to match the
- * longest lexemes possible, for better performance. (See the flex document.)
- * That's why the rules look so bizarre.
- */
-%}
-
-<Code,GlaExt,GhcPragma,UserPragma,StringEsc>"{-" {
- noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment);
- }
-
-<Comment>[^-{]* |
-<Comment>"-"+[^-{}]+ |
-<Comment>"{"+[^-{}]+ ;
-<Comment>"{-" { nested_comments++; }
-<Comment>"-}" { if (--nested_comments == 0) POP_STATE; }
-<Comment>(.|\n) ;
-
-%{
- /*
- * Illegal characters. This used to be a single rule, but we might as well
- * pass on as much information as we have, so now we indicate our state in
- * the error message.
- */
-%}
-
-<INITIAL,Code,GlaExt,GhcPragma,UserPragma>(.|\n) {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- }
-<Char>(.|\n) {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a character literal\n", stderr);
- hsperror("");
- }
-<CharEsc>(.|\n) {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character escape: `\\",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- }
-<String>(.|\n) { if (nonstandardFlag) {
- addtext(yytext, yyleng);
- } else {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a string literal\n", stderr);
- hsperror("");
- }
- }
-<StringEsc>(.|\n) {
- if (noGap) {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal string escape: `\\",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("'\n", stderr);
- hsperror("");
- } else {
- fprintf(stderr, "\"%s\", line %d, column %d: Illegal character: `",
- input_filename, hsplineno, hspcolno + 1);
- format_string(stderr, (unsigned char *) yytext, 1);
- fputs("' in a string gap\n", stderr);
- hsperror("");
- }
- }
-
-%{
- /*
- * End of file. In any sub-state, this is an error. However, for the primary
- * <Code> and <GlaExt> states, this is perfectly normal. We just return an EOF
- * and let the yylex() wrapper deal with whatever has to be done next (e.g.
- * adding virtual close curlies, or closing an interface and returning to the
- * primary source file.
- *
- * Note that flex does not call YY_USER_ACTION for <<EOF>> rules. Hence the
- * line/column advancement has to be done by hand.
- */
-%}
-
-<Char,CharEsc><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated character literal");
- }
-<Comment><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated comment");
- }
-<String,StringEsc><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated string literal");
- }
-<GhcPragma><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated interface pragma");
- }
-<UserPragma><<EOF>> {
- hsplineno = hslineno; hspcolno = hscolno;
- hsperror("unterminated user-specified pragma");
- }
-<Code,GlaExt><<EOF>> { hsplineno = hslineno; hspcolno = hscolno; return(EOF); }
-
-%%
-
-/**********************************************************************
-* *
-* *
-* YACC/LEX Initialisation etc. *
-* *
-* *
-**********************************************************************/
-
-/*
- We initialise input_filename to "<stdin>".
- This allows unnamed sources to be piped into the parser.
-*/
-
-extern BOOLEAN acceptPrim;
-
-void
-yyinit(void)
-{
- input_filename = xstrdup("<stdin>");
-
- /* We must initialize the input buffer _now_, because we call
- setyyin _before_ calling yylex for the first time! */
- yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE));
-
- if (acceptPrim)
- PUSH_STATE(GlaExt);
- else
- PUSH_STATE(Code);
-}
-
-static void
-new_filename(char *f) /* This looks pretty dodgy to me (WDP) */
-{
- if (input_filename != NULL)
- free(input_filename);
- input_filename = xstrdup(f);
-}
-
-/**********************************************************************
-* *
-* *
-* Layout Processing *
-* *
-* *
-**********************************************************************/
-
-/*
- The following section deals with Haskell Layout conventions
- forcing insertion of ; or } as appropriate
-*/
-
-static BOOLEAN
-hsshouldindent(void)
-{
- return (!forgetindent && INDENTON);
-}
-
-
-/* Enter new context and set new indentation level */
-void
-hssetindent(void)
-{
-#ifdef HSP_DEBUG
- fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-
- /*
- * partain: first chk that new indent won't be less than current one; this code
- * doesn't make sense to me; hscolno tells the position of the _end_ of the
- * current token; what that has to do with indenting, I don't know.
- */
-
-
- if (hscolno - 1 <= INDENTPT) {
- if (INDENTPT == -1)
- return; /* Empty input OK for Haskell 1.1 */
- else {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "Layout error -- indentation should be > %d cols", INDENTPT);
- hsperror(errbuf);
- }
- }
- hsentercontext((hspcolno << 1) | 1);
-}
-
-
-/* Enter a new context without changing the indentation level */
-void
-hsincindent(void)
-{
-#ifdef HSP_DEBUG
- fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
- hsentercontext(indenttab[icontexts] & ~1);
-}
-
-
-/* Turn off indentation processing, usually because an explicit "{" has been seen */
-void
-hsindentoff(void)
-{
- forgetindent = TRUE;
-}
-
-
-/* Enter a new layout context. */
-static void
-hsentercontext(int indent)
-{
- /* Enter new context and set indentation as specified */
- if (++icontexts >= MAX_CONTEXTS) {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "`wheres' and `cases' nested too deeply (>%d)", MAX_CONTEXTS - 1);
- hsperror(errbuf);
- }
- forgetindent = FALSE;
- indenttab[icontexts] = indent;
-#ifdef HSP_DEBUG
- fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-}
-
-
-/* Exit a layout context */
-void
-hsendindent(void)
-{
- --icontexts;
-#ifdef HSP_DEBUG
- fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
-#endif
-}
-
-/*
- * Return checks the indentation level and returns ;, } or the specified token.
- */
-
-static int
-Return(int tok)
-{
-#ifdef HSP_DEBUG
- extern int yyleng;
-#endif
-
- if (hsshouldindent()) {
- if (hspcolno < INDENTPT) {
-#ifdef HSP_DEBUG
- fprintf(stderr, "inserted '}' before %d (%d:%d:%d:%d)\n", tok, hspcolno, hscolno, yyleng, INDENTPT);
-#endif
- hssttok = tok;
- return (VCCURLY);
- } else if (hspcolno == INDENTPT) {
-#ifdef HSP_DEBUG
- fprintf(stderr, "inserted ';' before %d (%d:%d)\n", tok, hspcolno, INDENTPT);
-#endif
- hssttok = -tok;
- return (SEMI);
- }
- }
- hssttok = -1;
-#ifdef HSP_DEBUG
- fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT);
-#endif
- return (tok);
-}
-
-
-/*
- * Redefine yylex to check for stacked tokens, yylex1() is the original yylex()
- */
-int
-yylex()
-{
- int tok;
- static BOOLEAN eof = FALSE;
-
- if (!eof) {
- if (hssttok != -1) {
- if (hssttok < 0) {
- tok = -hssttok;
- hssttok = -1;
- return tok;
- }
- RETURN(hssttok);
- } else {
- endlineno = hslineno;
- if ((tok = yylex1()) != EOF)
- return tok;
- else
- eof = TRUE;
- }
- }
- if (icontexts > icontexts_save) {
- if (INDENTON) {
- eof = TRUE;
- indenttab[icontexts] = 0;
- return (VCCURLY);
- } else
- hsperror("missing '}' at end of file");
- } else if (hsbuf_save != NULL) {
- fclose(yyin);
- yy_delete_buffer(YY_CURRENT_BUFFER);
- yy_switch_to_buffer(hsbuf_save);
- hsbuf_save = NULL;
- new_filename(filename_save);
- free(filename_save);
- hslineno = hslineno_save;
- hsplineno = hsplineno_save;
- hscolno = hscolno_save;
- hspcolno = hspcolno_save;
- etags = etags_save;
- in_interface = FALSE;
- icontexts = icontexts_save - 1;
- icontexts_save = 0;
-#ifdef HSP_DEBUG
- fprintf(stderr, "finished reading interface (%d:%d:%d)\n", hscolno, hspcolno, INDENTPT);
-#endif
- eof = FALSE;
- RETURN(LEOF);
- } else {
- yyterminate();
- }
- abort(); /* should never get here! */
- return(0);
-}
-
-/**********************************************************************
-* *
-* *
-* Input Processing for Interfaces *
-* *
-* *
-**********************************************************************/
-
-/* setyyin(file) open file as new lex input buffer */
-extern FILE *yyin;
-
-void
-setyyin(char *file)
-{
- hsbuf_save = YY_CURRENT_BUFFER;
- if ((yyin = fopen(file, "r")) == NULL) {
- char errbuf[ERR_BUF_SIZE];
-
- sprintf(errbuf, "can't read \"%-.50s\"", file);
- hsperror(errbuf);
- }
- yy_switch_to_buffer(yy_create_buffer(yyin, YY_BUF_SIZE));
-
- hslineno_save = hslineno;
- hsplineno_save = hsplineno;
- hslineno = hsplineno = 1;
-
- filename_save = input_filename;
- input_filename = NULL;
- new_filename(file);
- hscolno_save = hscolno;
- hspcolno_save = hspcolno;
- hscolno = hspcolno = 0;
- in_interface = TRUE;
- etags_save = etags; /* do not do "etags" stuff in interfaces */
- etags = 0; /* We remember whether we are doing it in
- the module, so we can restore it later [WDP 94/09] */
- hsentercontext(-1); /* partain: changed this from 0 */
- icontexts_save = icontexts;
-#ifdef HSP_DEBUG
- fprintf(stderr, "reading %s (%d:%d:%d)\n", input_filename, hscolno_save, hspcolno_save, INDENTPT);
-#endif
-}
-
-static void
-layout_input(char *text, int len)
-{
-#ifdef HSP_DEBUG
- fprintf(stderr, "Scanning \"%s\"\n", text);
-#endif
-
- hsplineno = hslineno;
- hspcolno = hscolno;
-
- while (len-- > 0) {
- switch (*text++) {
- case '\n':
- case '\r':
- case '\f':
- hslineno++;
- hscolno = 0;
- break;
- case '\t':
- hscolno += 8 - (hscolno % 8); /* Tabs stops are 8 columns apart */
- break;
- case '\v':
- break;
- default:
- ++hscolno;
- break;
- }
- }
-}
-
-void
-setstartlineno(void)
-{
- startlineno = hsplineno;
-#if 1/*etags*/
-#else
- if (etags)
- fprintf(stderr,"%u\tsetstartlineno (col %u)\n",startlineno,hscolno);
-#endif
-}
-
-/**********************************************************************
-* *
-* *
-* Text Caching *
-* *
-* *
-**********************************************************************/
-
-#define CACHE_SIZE YY_BUF_SIZE
-
-static struct {
- unsigned allocated;
- unsigned next;
- char *text;
-} textcache = { 0, 0, NULL };
-
-static void
-cleartext(void)
-{
-/* fprintf(stderr, "cleartext\n"); */
- textcache.next = 0;
- if (textcache.allocated == 0) {
- textcache.allocated = CACHE_SIZE;
- textcache.text = xmalloc(CACHE_SIZE);
- }
-}
-
-static void
-addtext(char *text, unsigned length)
-{
-/* fprintf(stderr, "addtext: %d %s\n", length, text); */
-
- if (length == 0)
- return;
-
- if (textcache.next + length + 1 >= textcache.allocated) {
- textcache.allocated += length + CACHE_SIZE;
- textcache.text = xrealloc(textcache.text, textcache.allocated);
- }
- bcopy(text, textcache.text + textcache.next, length);
- textcache.next += length;
-}
-
-static void
-addchar(char c)
-{
-/* fprintf(stderr, "addchar: %c\n", c); */
-
- if (textcache.next + 2 >= textcache.allocated) {
- textcache.allocated += CACHE_SIZE;
- textcache.text = xrealloc(textcache.text, textcache.allocated);
- }
- textcache.text[textcache.next++] = c;
-}
-
-static char *
-fetchtext(unsigned *length)
-{
-/* fprintf(stderr, "fetchtext: %d\n", textcache.next); */
-
- *length = textcache.next;
- textcache.text[textcache.next] = '\0';
- return textcache.text;
-}
-
-/**********************************************************************
-* *
-* *
-* Identifier Processing *
-* *
-* *
-**********************************************************************/
-
-/*
- hsnewid Enters an id of length n into the symbol table.
-*/
-
-static void
-hsnewid(char *name, int length)
-{
- char save = name[length];
-
- name[length] = '\0';
- yylval.uid = installid(name);
- name[length] = save;
-}
-
-BOOLEAN
-isconstr(char *s) /* walks past leading underscores before using the macro */
-{
- char *temp = s;
-
- for ( ; temp != NULL && *temp == '_' ; temp++ );
-
- return _isconstr(temp);
-}
+++ /dev/null
-/**************************************************************************
-* File: hsparser.y *
-* *
-* Author: Maria M. Gutierrez *
-* Modified by: Kevin Hammond *
-* Last date revised: December 13 1991. KH. *
-* Modification: o Haskell 1.1 Syntax. *
-* o Data Parallel Syntax. *
-* *
-* *
-* Description: This file contains the LALR(1) grammar for Haskell. *
-* *
-* Entry Point: module *
-* *
-* Problems: None known. *
-* *
-* *
-* LALR(1) Syntax for Haskell 1.2 + Data Parallelism *
-* *
-**************************************************************************/
-
-
-%{
-#ifdef DEBUG
-# define YYDEBUG 1
-#endif
-
-#include <stdio.h>
-#include <ctype.h>
-#include <string.h>
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-
-
-/**********************************************************************
-* *
-* *
-* Imported Variables and Functions *
-* *
-* *
-**********************************************************************/
-
-extern BOOLEAN nonstandardFlag;
-extern BOOLEAN expect_ccurly;
-extern BOOLEAN etags;
-
-extern BOOLEAN ispatt PROTO((tree, BOOLEAN));
-extern tree function PROTO((tree));
-
-static char modname[MODNAME_SIZE];
-static char *the_module_name;
-static char iface_name[MODNAME_SIZE];
-static char interface_filename[FILENAME_SIZE];
-
-static list module_exports; /* Exported entities */
-static list prelude_imports; /* Entities imported from the Prelude */
-
-extern list all; /* All valid deriving classes */
-
-extern tree niltree;
-extern list Lnil;
-
-extern tree root;
-
-/* For FN, PREVPATT and SAMEFN macros */
-extern tree fns[];
-extern short samefn[];
-extern tree prevpatt[];
-extern short icontexts;
-
-
-/* Line Numbers */
-extern int hsplineno;
-extern int startlineno;
-
-/**********************************************************************
-* *
-* *
-* Fixity and Precedence Declarations *
-* *
-* *
-**********************************************************************/
-
-list fixlist;
-static int Fixity = 0, Precedence = 0;
-struct infix;
-
-char *ineg();
-
-static BOOLEAN hidden = FALSE; /* Set when HIDING used */
-
-extern BOOLEAN inpat; /* True when parsing a pattern */
-extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */
-
-%}
-
-%union {
- tree utree;
- list ulist;
- ttype uttype;
- atype uatype;
- binding ubinding;
- pbinding upbinding;
- finfot ufinfo;
- impidt uimpid;
- entidt uentid;
- id uid;
- int uint;
- float ufloat;
- char *ustring;
- hpragma uhpragma;
-}
-
-
-/**********************************************************************
-* *
-* *
-* These are lexemes. *
-* *
-* *
-**********************************************************************/
-
-
-%token VARID CONID
- VARSYM CONSYM MINUS
-
-%token INTEGER FLOAT CHAR STRING
- CHARPRIM INTPRIM FLOATPRIM DOUBLEPRIM
- CLITLIT VOIDPRIM
-
-
-
-/**********************************************************************
-* *
-* *
-* Special Symbols *
-* *
-* *
-**********************************************************************/
-
-%token OCURLY CCURLY VCCURLY SEMI
-%token OBRACK CBRACK OPAREN CPAREN
-%token COMMA BQUOTE
-%token OPOD CPOD OPROC CPROC
-
-
-/**********************************************************************
-* *
-* *
-* Reserved Operators *
-* *
-* *
-**********************************************************************/
-
-%token RARROW
-%token VBAR EQUAL DARROW DOTDOT
-%token DCOLON LARROW
-%token WILDCARD AT LAZY LAMBDA
-%token DRAWNFROM INDEXFROM
-
-
-/**********************************************************************
-* *
-* *
-* Reserved Identifiers *
-* *
-* *
-**********************************************************************/
-
-%token LET IN
-%token WHERE CASE OF
-%token TYPE DATA CLASS INSTANCE DEFAULT
-%token INFIX INFIXL INFIXR
-%token MODULE IMPORT INTERFACE HIDING
-%token CCALL CCALL_DANGEROUS CASM CASM_DANGEROUS SCC
-
-%token IF THEN ELSE
-%token RENAMING DERIVING TO
-
-/**********************************************************************
-* *
-* *
-* Special Symbols for the Lexer *
-* *
-* *
-**********************************************************************/
-
-%token LEOF
-%token ARITY_PRAGMA SPECIALIZE_PRAGMA STRICTNESS_PRAGMA UPDATE_PRAGMA
-%token END_PRAGMA
-
-/**********************************************************************
-* *
-* *
-* Precedences of the various tokens *
-* *
-* *
-**********************************************************************/
-
-
-%left CASE LET IN LAMBDA
- IF ELSE CCALL CCALL_DANGEROUS
- CASM CASM_DANGEROUS SCC AT
-
-%left VARSYM CONSYM PLUS MINUS BQUOTE
-
-%left DCOLON
-
-%left SEMI COMMA
-
-%left OCURLY OBRACK OPAREN
-
-%left OPOD OPROC
-
-%left EQUAL
-
-%right DARROW
-%right RARROW
-
-
-
-/**********************************************************************
-* *
-* *
-* Type Declarations *
-* *
-* *
-**********************************************************************/
-
-
-%type <ulist> alt alts altrest quals vars varsrest cons
- tyvars constrs dtypes types atypes
- exps pats context context_list tyvar_list
- maybeexports export_list
- impspec maybeimpspec import_list
- impdecls maybeimpdecls impdecl
- renaming renamings renaming_list
- tyclses tycls_list
- gdrhs gdpat valrhs valrhs1
- lampats
- upto
- cexp
- tyvar_pids
- parquals
- pragmas
-
-
-%type <utree> exp dexp fexp kexp oexp aexp literal
- tuple list sequence comprehension qual qualrest
- gd
- apat bpat pat apatc conpat dpat fpat opat aapat
- dpatk fpatk opatk aapatk
- texps
- processor parqual
-
-%type <uid> MINUS VARID CONID VARSYM CONSYM
- var vark con conk varop varop1 conop op op1
- varid conid varsym consym minus plus
- tycls tycon modid ccallid
-
-%type <ubinding> topdecl topdecls
- typed datad classd instd defaultd
- decl decls valdef valdefs sign
- iimport iimports maybeiimports
- ityped idatad iclassd iinstd ivarsd
- itopdecl itopdecls
- maybe_where
- interface readinterface ibody
- cbody rinst
- impdecl_rest
-
-%type <uttype> simple simple_long type atype btype ttype ntatype inst class
- tyvar
-
-%type <uatype> constr
-
-%type <ustring> STRING FLOAT INTEGER CHARPRIM INTPRIM FLOATPRIM DOUBLEPRIM CLITLIT VOIDPRIM
-%type <uint> CHAR
-%type <uentid> export import
-%type <uhpragma> pragma
-
-
-/**********************************************************************
-* *
-* *
-* Start Symbol for the Parser *
-* *
-* *
-**********************************************************************/
-
-%start pmodule
-
-
-%%
-
-pmodule : readprelude module
- ;
-
-module : MODULE modid maybeexports
- { the_module_name = $2; module_exports = $3; }
- WHERE body
- | { the_module_name = install_literal("Main"); module_exports = Lnil; }
- body
- ;
-
-body : ocurly maybeimpdecls maybefixes topdecls ccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4);
- }
- | vocurly maybeimpdecls maybefixes topdecls vccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4);
- }
-
- | vocurly impdecls vccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind());
- }
- | ocurly impdecls ccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind());
- }
-
-/* Adds 1 S/R, 2 R/R conflicts, alternatives add 3 R/R conflicts */
- | vocurly maybeimpdecls vccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind());
- }
- | ocurly maybeimpdecls ccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind());
- }
- ;
-
-
-maybeexports : /* empty */ { $$ = Lnil; }
- | OPAREN export_list CPAREN { $$ = $2; }
- ;
-
-export_list:
- export { $$ = lsing($1); }
- | export_list COMMA export { $$ = lapp($1,$3); }
- ;
-
-export :
- var { $$ = mkentid($1); }
- | tycon { $$ = mkenttype($1); }
- | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
- | tycon OPAREN cons CPAREN
- { $$ = mkenttypecons($1,$3);
- /* should be a datatype with cons representing all constructors */
- }
- | tycon OPAREN vars CPAREN
- { $$ = mkentclass($1,$3);
- /* should be a class with vars representing all Class operations */
- }
- | tycon OPAREN CPAREN
- { $$ = mkentclass($1,Lnil);
- /* "tycon" should be a class with no operations */
- }
- | tycon DOTDOT
- { $$ = mkentmod($1);
- /* "tycon" is a module id (but "modid" is bad for your identifier's health [KH]) */
- }
- ;
-
-
-impspec : OPAREN import_list CPAREN { $$ = $2; hidden = FALSE; }
- | HIDING OPAREN import_list CPAREN { $$ = $3; hidden = TRUE; }
- | OPAREN CPAREN { $$ = Lnil; hidden = FALSE; }
- ;
-
-maybeimpspec : /* empty */ { $$ = Lnil; }
- | impspec { $$ = $1; }
- ;
-
-import_list:
- import { $$ = lsing($1); }
- | import_list COMMA import { $$ = lapp($1,$3); }
- ;
-
-import :
- var { $$ = mkentid($1); }
- | tycon { $$ = mkenttype($1); }
- | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
- | tycon OPAREN cons CPAREN
- { $$ = mkenttypecons($1,$3);
- /* should be a datatype with cons representing all constructors */
- }
- | tycon OPAREN vars CPAREN
- { $$ = mkentclass($1,$3);
- /* should be a class with vars representing all Class operations */
- }
- | tycon OPAREN CPAREN
- { $$ = mkentclass($1,Lnil);
- /* "tycon" should be a class with no operations */
- }
- ;
-
-
-pragmas:
- pragma { $$ = lsing($1); }
- | pragmas pragma { $$ = lapp($1,$2); }
- | /* empty */ { $$ = Lnil; }
- ;
-
-pragma:
- ARITY_PRAGMA var EQUAL INTEGER END_PRAGMA
- { $$ = mkarity_pragma($2,$4); }
-
- | SPECIALIZE_PRAGMA var EQUAL ivarsd END_PRAGMA
- { $$ = mkspecialize_pragma($2, $4); }
-
- | STRICTNESS_PRAGMA var EQUAL STRING pragmas END_PRAGMA
- { $$ = mkstrictness_pragma($2, $4, $5); }
-
- | UPDATE_PRAGMA var EQUAL INTEGER END_PRAGMA
- { $$ = mkupdate_pragma($2, $4); }
- ;
-
-
-readprelude :
- {
- if ( implicitPrelude ) {
- find_module_on_imports_dirlist("Prelude",TRUE,interface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename);
- }
- setyyin(interface_filename);
- enteriscope();
- }
- readinterface
- {
- binding prelude = mkimport(installid(iface_name),Lnil,Lnil,$2,xstrdup(interface_filename),hsplineno);
- prelude_imports = implicitPrelude? lsing(prelude): Lnil;
- }
- ;
-
-maybeimpdecls : /* empty */ { $$ = Lnil; }
- | impdecls SEMI { $$ = $1; }
- ;
-
-impdecls: impdecl { $$ = $1; }
- | impdecls SEMI impdecl { $$ = lconc($1,$3); }
- ;
-
-impdecl : IMPORT modid
- { /* filename returned in "interface_filename" */
- char *module_name = id_to_string($2);
- find_module_on_imports_dirlist(module_name,FALSE,interface_filename);
- setyyin(interface_filename);
- enteriscope();
- if(strcmp(module_name,"Prelude")==0)
- prelude_imports = Lnil;
- }
- impdecl_rest
- {
- if (hidden)
- $4->tag = hiding;
- $$ = lsing($4);
- }
-
-impdecl_rest:
- readinterface maybeimpspec
- { $$ = mkimport(installid(iface_name),$2,Lnil,$1,xstrdup(interface_filename),hsplineno); }
- /* WDP: uncertain about those hsplinenos */
- | readinterface maybeimpspec RENAMING renamings
- { $$ = mkimport(installid(iface_name),$2,$4,$1,xstrdup(interface_filename),hsplineno); }
- ;
-
-readinterface:
- interface LEOF
- {
- exposeis(); /* partain: expose infix ops at level i+1 to level i */
- $$ = $1;
- }
- ;
-
-renamings: OPAREN renaming_list CPAREN { $$ = $2; }
- ;
-
-renaming_list: renaming { $$ = lsing($1); }
- | renaming_list COMMA renaming { $$ = lapp($1,$3); }
- ;
-
-renaming: var TO var { $$ = ldub($1,$3); }
- | con TO con { $$ = ldub($1,$3); }
- ;
-
-maybeiimports : /* empty */ { $$ = mknullbind(); }
- | iimports SEMI { $$ = $1; }
- ;
-
-iimports : iimports SEMI iimport { $$ = mkabind($1,$3); }
- | iimport { $$ = $1; }
- ;
-
-iimport : importkey modid OPAREN import_list CPAREN
- { $$ = mkmbind($2,$4,Lnil,startlineno); }
- | importkey modid OPAREN import_list CPAREN RENAMING renamings
- { $$ = mkmbind($2,$4,$7,startlineno); }
- ;
-
-
-interface:
- INTERFACE modid
- { fixlist = Lnil;
- strcpy(iface_name, id_to_string($2));
- }
- WHERE ibody
- {
- /* WDP: not only do we not check the module name
- but we take the one in the interface to be what we really want
- -- we need this for Prelude jiggery-pokery. (Blech. KH)
- ToDo: possibly revert....
- checkmodname(modname,id_to_string($2));
- */
- $$ = $5;
- }
- ;
-
-
-ibody : ocurly maybeiimports maybefixes itopdecls ccurly
- {
- $$ = mkabind($2,$4);
- }
- | ocurly iimports ccurly
- {
- $$ = $2;
- }
- | vocurly maybeiimports maybefixes itopdecls vccurly
- {
- $$ = mkabind($2,$4);
- }
- | vocurly iimports vccurly
- {
- $$ = $2;
- }
- ;
-
-maybefixes: /* empty */
- | fixes SEMI
- ;
-
-
-fixes : fixes SEMI fix
- | fix
- ;
-
-fix : INFIXL INTEGER
- { Precedence = checkfixity($2); Fixity = INFIXL; }
- ops
- | INFIXR INTEGER
- { Precedence = checkfixity($2); Fixity = INFIXR; }
- ops
- | INFIX INTEGER
- { Precedence = checkfixity($2); Fixity = INFIX; }
- ops
- | INFIXL
- { Fixity = INFIXL; Precedence = 9; }
- ops
- | INFIXR
- { Fixity = INFIXR; Precedence = 9; }
- ops
- | INFIX
- { Fixity = INFIX; Precedence = 9; }
- ops
- ;
-
-ops : op { makeinfix(id_to_string($1),Fixity,Precedence); }
- | ops COMMA op { makeinfix(id_to_string($3),Fixity,Precedence); }
- ;
-
-topdecls: topdecls SEMI topdecl
- {
- if($1 != NULL)
- if($3 != NULL)
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- else
- $$ = $1;
- else
- $$ = $3;
- SAMEFN = 0;
- }
- | topdecl
- ;
-
-topdecl : typed { $$ = $1; }
- | datad { $$ = $1; }
- | classd { $$ = $1; }
- | instd { $$ = $1; }
- | defaultd { $$ = $1; }
- | decl { $$ = $1; }
- ;
-
-typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno,mkno_pramga()); }
- ;
-
-
-datad : datakey context DARROW simple EQUAL constrs
- { $$ = mktbind($2,$4,$6,all,startlineno,mkno_pragma()); }
- | datakey simple EQUAL constrs
- { $$ = mktbind(Lnil,$2,$4,all,startlineno,mkno_pragma()); }
- | datakey context DARROW simple EQUAL constrs DERIVING tyclses
- { $$ = mktbind($2,$4,$6,$8,startlineno,mkno_pragma()); }
- | datakey simple EQUAL constrs DERIVING tyclses
- { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mkno_pragma()); }
- ;
-
-classd : classkey context DARROW class cbody { $$ = mkcbind($2,$4,$5,startlineno,Lnil); }
- | classkey class cbody { $$ = mkcbind(Lnil,$2,$3,startlineno,Lnil); }
- ;
-
-cbody : /* empty */ { $$ = mknullbind(); }
- | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; }
- | WHERE vocurly decls vccurly { checkorder($3); $$ =$3; }
- ;
-
-
-instd : instkey context DARROW tycls inst rinst { $$ = mkibind($2,$4,$5,$6,startlineno,Lnil); }
- | instkey tycls inst rinst { $$ = mkibind(Lnil,$2,$3,$4,startlineno,Lnil); }
- ;
-
-rinst : /* empty */ { $$ = mknullbind(); }
- | WHERE ocurly valdefs ccurly { $$ = $3; }
- | WHERE vocurly valdefs vccurly { $$ = $3; }
- ;
-
-inst : tycon { $$ = mktname($1,Lnil); }
- | OPAREN simple_long CPAREN { $$ = $2; }
- /* partain?: "simple" requires k >= 0, not k > 0 (hence "simple_long" hack) */
- | OPAREN tyvar_list CPAREN { $$ = mkttuple($2); }
- | OPAREN CPAREN { $$ = mkttuple(Lnil); }
- | OBRACK tyvar CBRACK { $$ = mktllist($2); }
- | OPAREN tyvar RARROW tyvar CPAREN { $$ = mktfun($2,$4); }
- | OPOD tyvar CPOD { $$ = mktpod($2); }
- | OPROC tyvar_pids SEMI tyvar CPROC { $$ = mktproc($2,$4); }
- | OPOD tyvar_pids SEMI tyvar CPOD { $$ = mktpod(mktproc($2,$4));}
- | OPOD OPROC tyvar_pids SEMI tyvar CPROC CPOD
- { $$ = mktpod(mktproc($3,$5)); }
- ;
-
-/* Note (hilly) : Similar to tyvar_list except k>=1 not k>=2 */
-
-tyvar_pids : tyvar COMMA tyvar_pids { $$ = mklcons($1,$3); }
- | tyvar { $$ = lsing($1); }
- ;
-
-defaultd: defaultkey dtypes
- {
- $$ = mkdbind($2,startlineno);
- }
- ;
-
-dtypes : OPAREN type COMMA types CPAREN { $$ = mklcons($2,$4); }
- | ttype { $$ = lsing($1); }
-/* Omitting this forces () to be the *type* (), which never defaults. This is a KLUDGE */
-/* | OPAREN CPAREN { $$ = Lnil; }*/
- ;
-
-decls : decls SEMI decl
- {
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- }
- | decl
- ;
-
-/* partain: this "DCOLON context" vs "DCOLON type" is a problem,
- because you can't distinguish between
-
- foo :: (Baz a, Baz a)
- bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
-
- with one token of lookahead. The HACK is to have "DCOLON ttype"
- [tuple type] in the first case, then check that it has the right
- form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
- context. Blaach!
- (FIXED 90/06/06)
-*/
-
-decl : vars DCOLON type DARROW type iclasop_pragma
- { /* type2context.c for code */
- $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6);
- PREVPATT = NULL;
- FN = NULL;
- SAMEFN = 0;
- }
- | sign
- | valdef
- | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
- ;
-
-sign : vars DCOLON type iclasop_pragma
- {
- $$ = mksbind($1,$3,startlineno,$4);
- PREVPATT = NULL;
- FN = NULL;
- SAMEFN = 0;
- }
- ;
-
-
-
-itopdecls : itopdecls SEMI itopdecl { $$ = mkabind($1,$3); }
- | itopdecl { $$ = $1; }
- ;
-
-itopdecl: ityped { $$ = $1; }
- | idatad { $$ = $1; }
- | iclassd { $$ = $1; }
- | iinstd { $$ = $1; }
- | ivarsd { $$ = $1; }
- | /* empty */ { $$ = mknullbind(); }
- ;
-
- /* partain: see comment elsewhere about why "type", not "context" */
-ivarsd : vars DCOLON type DARROW type ival_pragma
- { $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6); }
- | vars DCOLON type ival_pragma
- { $$ = mksbind($1,$3,startlineno,$4); }
- ;
-
-ityped : typekey simple EQUAL type itype_pragma { $$ = mknbind($2,$4,startlineno,$5); }
- ;
-
-idatad : datakey context DARROW simple idata_pragma { $$ = mktbind($2,$4,Lnil,Lnil,startlineno,$5); }
- | datakey simple idata_pragma { $$ = mktbind(Lnil,$2,Lnil,Lnil,startlineno,$3); }
- | datakey context DARROW simple EQUAL constrs { $$ = mktbind($2,$4,$6,Lnil,startlineno,mk_nopragma()); }
- | datakey simple EQUAL constrs { $$ = mktbind(Lnil,$2,$4,Lnil,startlineno,mk_nopragma()); }
- | datakey context DARROW simple EQUAL constrs DERIVING tyclses { $$ = mktbind($2,$4,$6,$8,startlineno,mk_nopragma()); }
- | datakey simple EQUAL constrs DERIVING tyclses { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mk_nopragma()); }
- ;
-
-
-iclassd : classkey context DARROW class cbody pragmas
- { $$ = mkcbind($2,$4,$5,startlineno,$6); }
- | classkey class cbody pragmas
- { $$ = mkcbind(Lnil,$2,$3,startlineno,$4); }
- ;
-
-iinstd : instkey context DARROW tycls inst pragmas
- { $$ = mkibind($2,$4,$5,mknullbind(),startlineno,$6); }
- | instkey tycls inst pragmas
- { $$ = mkibind(Lnil,$2,$3,mknullbind(),startlineno,$4); }
- ;
-
-
-/* obsolete: "(C a, ...)" cause r/r conflict, resolved in favour of context rather than type */
-
-class : tycon tyvar { $$ = mktname($1,lsing($2)); }
- /* partain: changed "tycls" to "tycon" */
- ;
-
-types : types COMMA type { $$ = lapp($1,$3); }
- | type { $$ = lsing($1); }
- ;
-
-type : btype { $$ = $1; }
- | btype RARROW type { $$ = mktfun($1,$3); }
-
-btype : atype { $$ = $1; }
- | tycon atypes { $$ = mktname($1,$2); }
- ;
-
-atypes : atypes atype { $$ = lapp($1,$2); }
- | atype { $$ = lsing($1); }
- ;
-
-/* The split with ntatype allows us to use the same syntax for defaults as for types */
-ttype : ntatype { $$ = $1; }
- | btype RARROW type { $$ = mktfun($1,$3); }
- | tycon atypes { $$ = mktname($1,$2); }
- ;
-
-atype : ntatype
- | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
- ;
-
-ntatype : tyvar { $$ = $1; }
- | tycon { $$ = mktname($1,Lnil); }
- | OPAREN CPAREN { $$ = mkttuple(Lnil); }
- | OPAREN type CPAREN { $$ = $2; }
- | OBRACK type CBRACK { $$ = mktllist($2); }
- | OPOD type CPOD { $$ = mktpod($2); }
- | OPROC types SEMI type CPROC { $$ = mktproc($2,$4); }
- | OPOD types SEMI type CPOD { $$ = mktpod(mktproc($2,$4));}
- ;
-
-
-simple : tycon { $$ = mktname($1,Lnil); }
- | tycon tyvars { $$ = mktname($1,$2); }
- ;
-
-
-simple_long : tycon tyvars { $$ = mktname($1,$2); }
- ; /* partain: see comment in "inst" */
-
-
-constrs : constrs VBAR constr { $$ = lapp($1,$3); }
- | constr { $$ = lsing($1); }
- ;
-
-/* Using tycon rather than con avoids 5 S/R errors */
-constr : tycon atypes { $$ = mkatc($1,$2,hsplineno); }
- | OPAREN consym CPAREN atypes { $$ = mkatc($2,$4,hsplineno); }
- | tycon { $$ = mkatc($1,Lnil,hsplineno); }
- | OPAREN consym CPAREN { $$ = mkatc($2,Lnil,hsplineno); }
- | btype conop btype { $$ = mkatc($2, ldub($1,$3), hsplineno); }
- ;
-
-tyclses : OPAREN tycls_list CPAREN { $$ = $2; }
- | OPAREN CPAREN { $$ = Lnil; }
- | tycls { $$ = lsing($1); }
- ;
-
-tycls_list: tycls COMMA tycls_list { $$ = mklcons($1,$3); }
- | tycls { $$ = lsing($1); }
- ;
-
-context : OPAREN context_list CPAREN { $$ = $2; }
- | class { $$ = lsing($1); }
- ;
-
-context_list: class COMMA context_list { $$ = mklcons($1,$3); }
- | class { $$ = lsing($1); }
- ;
-
-valdefs : valdefs SEMI valdef
- {
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- }
- | valdef { $$ = $1; }
- | /* empty */ { $$ = mknullbind(); }
- ;
-
-
-vars : vark COMMA varsrest { $$ = mklcons($1,$3); }
- | vark { $$ = lsing($1); }
- ;
-
-varsrest: varsrest COMMA var { $$ = lapp($1,$3); }
- | var { $$ = lsing($1); }
- ;
-
-cons : cons COMMA con { $$ = lapp($1,$3); }
- | con { $$ = lsing($1); }
- ;
-
-
-valdef : opatk
- {
- tree fn = function($1);
-
- PREVPATT = $1;
-
- if(ttree(fn) == ident)
- {
- checksamefn(gident(fn));
- FN = fn;
- }
-
- else if (ttree(fn) == tinfixop && ttree(ginfun((struct Sap *) fn)) == ident)
- {
- checksamefn(gident(ginfun((struct Sap *) fn)));
- FN = ginfun((struct Sap *) fn);
- }
-
- else if(etags)
- printf("%u\n",startlineno);
- }
- valrhs
- {
- if(ispatt($1,TRUE))
- {
- $$ = mkpbind($3, startlineno);
- FN = NULL;
- SAMEFN = 0;
- }
- else
- $$ = mkfbind($3,startlineno);
-
- PREVPATT = NULL;
- }
- ;
-
-valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); }
- ;
-
-valrhs1 : gdrhs
- | EQUAL exp { $$ = lsing(mktruecase($2)); }
- ;
-
-gdrhs : gd EQUAL exp { $$ = lsing(ldub($1,$3)); }
- | gd EQUAL exp gdrhs { $$ = mklcons(ldub($1,$3),$4); }
- ;
-
-maybe_where:
- WHERE ocurly decls ccurly { $$ = $3; }
- | WHERE vocurly decls vccurly { $$ = $3; }
- | /* empty */ { $$ = mknullbind(); }
- ;
-
-gd : VBAR oexp { $$ = $2; }
- ;
-
-
-lampats : apat lampats { $$ = mklcons($1,$2); }
- | apat { $$ = lsing($1); }
- ;
-
-
-/*
- Changed as above to allow for contexts!
- KH@21/12/92
-*/
-
-
-exp : oexp DCOLON type DARROW type { $$ = mkrestr($1,mkcontext(type2context($3),$5)); }
- | oexp DCOLON type { $$ = mkrestr($1,$3); }
- | oexp
- ;
-
-/*
- Operators must be left-associative at the same precedence
- for prec. parsing to work.
-*/
-
- /* Infix operator application */
-oexp : dexp
- | oexp op oexp %prec PLUS
- { $$ = mkinfixop($2,$1,$3); precparse($$); }
- ;
-
-/*
- This comes here because of the funny precedence rules concerning
- prefix minus.
-*/
-
-
-dexp : MINUS kexp { $$ = mknegate($2); }
- | kexp
- ;
-
-/*
- let/if/lambda/case have higher precedence than infix operators.
-*/
-
-kexp : LAMBDA
- { /* enteriscope(); /? I don't understand this -- KH */
- hsincindent(); /* added by partain; push new context for */
- /* FN = NULL; not actually concerned about */
- FN = NULL; /* indenting */
- $<uint>$ = hsplineno; /* remember current line number */
- }
- lampats
- { hsendindent(); /* added by partain */
- /* exitiscope(); /? Also not understood */
- }
- RARROW exp /* lambda abstraction */
- {
- $$ = mklambda($3, $6, $<uint>2);
- }
-
- /* Let Expression */
- | LET ocurly decls ccurly IN exp { $$ = mklet($3,$6); }
- | LET vocurly decls vccurly IN exp { $$ = mklet($3,$6); }
-
- /* If Expression */
- | IF exp THEN exp ELSE exp { $$ = mkife($2,$4,$6); }
-
- /* Case Expression */
- | CASE exp OF ocurly alts ccurly { $$ = mkcasee($2,$5); }
- | CASE exp OF vocurly alts vccurly { $$ = mkcasee($2,$5); }
-
- /* CCALL/CASM Expression */
- | CCALL ccallid cexp { $$ = mkccall($2,installid("n"),$3); }
- | CCALL ccallid { $$ = mkccall($2,installid("n"),Lnil); }
- | CCALL_DANGEROUS ccallid cexp { $$ = mkccall($2,installid("p"),$3); }
- | CCALL_DANGEROUS ccallid { $$ = mkccall($2,installid("p"),Lnil); }
- | CASM CLITLIT cexp { $$ = mkccall($2,installid("N"),$3); }
- | CASM CLITLIT { $$ = mkccall($2,installid("N"),Lnil); }
- | CASM_DANGEROUS CLITLIT cexp { $$ = mkccall($2,installid("P"),$3); }
- | CASM_DANGEROUS CLITLIT { $$ = mkccall($2,installid("P"),Lnil); }
-
- /* SCC Expression */
- | SCC STRING exp
- { extern BOOLEAN ignoreSCC;
- extern BOOLEAN warnSCC;
- extern char * input_filename;
-
- if (ignoreSCC) {
- if (warnSCC)
- fprintf(stderr,
- "\"%s\", line %d: scc (`set [profiling] cost centre') ignored\n",
- input_filename, hsplineno);
- $$ = $3;
- } else {
- $$ = mkscc($2, $3);
- }
- }
- | fexp
- ;
-
-
-
- /* Function application */
-fexp : fexp aexp { $$ = mkap($1,$2); }
- | aexp
- ;
-
-cexp : cexp aexp { $$ = lapp($1,$2); }
- | aexp { $$ = lsing($1); }
- ;
-
-
-/*
- The mkpars are so that infix parsing doesn't get confused.
-
- KH.
-*/
-
- /* Simple Expressions */
-aexp : var { $$ = mkident($1); }
- | con { $$ = mkident($1); }
- | literal
- | OPAREN exp CPAREN { $$ = mkpar($2); }
- | OPAREN oexp op CPAREN { checkprec($2,$3,FALSE); $$ = mklsection($2,$3); }
- | OPAREN op1 oexp CPAREN { checkprec($3,$2,TRUE); $$ = mkrsection($2,$3); }
-
- /* structures */
- | tuple
- | list { $$ = mkpar($1); }
- | sequence { $$ = mkpar($1); }
- | comprehension { $$ = mkpar($1); }
- | OPOD exp VBAR parquals CPOD { $$ = mkparzf($2,$4); }
- | OPOD exps CPOD { $$ = mkpod($2); }
- | processor { $$ = mkpar($1); }
-
- /* These only occur in patterns */
- | var AT aexp { checkinpat(); $$ = mkas($1,$3); }
- | WILDCARD { checkinpat(); $$ = mkwildp(); }
- | LAZY aexp { checkinpat(); $$ = mklazyp($2); }
- ;
-
-
-processor : OPROC exps SEMI exp CPROC { $$ = mkproc($2,$4); }
- ;
-
-parquals : parquals COMMA parqual { $$ = lapp($1,$3); }
- | parqual { $$ = lsing($1); }
- ;
-
-parqual : exp { $$ = mkparfilt($1); }
- | processor DRAWNFROM exp
- { $$ = mkpardgen($1,$3);
- checkpatt($1);
- }
- | processor INDEXFROM exp
- { $$ = mkparigen($1,$3);
- checkpatt(gprocdata($1));
- }
- ;
-
-
-/*
- LHS patterns are parsed in a similar way to
- expressions. This avoids the horrible non-LRness
- which occurs with the 1.1 syntax.
-
- The xpatk business is to do with accurately recording
- the starting line for definitions.
-*/
-
-/*TESTTEST
-bind : opatk
- | vark lampats
- { $$ = mkap($1,$2); }
- | opatk varop opat %prec PLUS
- {
- $$ = mkinfixop($2,$1,$3);
- }
- ;
-
-opatk : dpatk
- | opatk conop opat %prec PLUS
- {
- $$ = mkinfixop($2,$1,$3);
- precparse($$);
- }
- ;
-
-*/
-
-opatk : dpatk
- | opatk op opat %prec PLUS
- {
- $$ = mkinfixop($2,$1,$3);
-
- if(isconstr(id_to_string($2)))
- precparse($$);
- else
- {
- checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */
- checkprec($3,$2,TRUE); /* then check the right pattern */
- }
- }
- ;
-
-opat : dpat
- | opat op opat %prec PLUS
- {
- $$ = mkinfixop($2,$1,$3);
-
- if(isconstr(id_to_string($2)))
- precparse($$);
- else
- {
- checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */
- checkprec($3,$2,TRUE); /* then check the right pattern */
- }
- }
- ;
-
-/*
- This comes here because of the funny precedence rules concerning
- prefix minus.
-*/
-
-
-dpat : MINUS fpat { $$ = mknegate($2); }
- | fpat
- ;
-
- /* Function application */
-fpat : fpat aapat { $$ = mkap($1,$2); }
- | aapat
- ;
-
-dpatk : minuskey fpat { $$ = mknegate($2); }
- | fpatk
- ;
-
- /* Function application */
-fpatk : fpatk aapat { $$ = mkap($1,$2); }
- | aapatk
- ;
-
-aapat : con { $$ = mkident($1); }
- | var { $$ = mkident($1); }
- | var AT apat { $$ = mkas($1,$3); }
- | literal { $$ = $1; }
- | WILDCARD { $$ = mkwildp(); }
- | OPAREN CPAREN { $$ = mktuple(Lnil); }
- | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); }
- | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); }
- | OPAREN opat CPAREN { $$ = mkpar($2); }
- | OPAREN opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | OBRACK pats CBRACK { $$ = mkllist($2); }
- | OBRACK CBRACK { $$ = mkllist(Lnil); }
- | LAZY apat { $$ = mklazyp($2); }
- | OPROC pats SEMI apat CPROC { $$ = mkproc($2,$4); }
- ;
-
-aapatk : conk { $$ = mkident($1); }
- | vark { $$ = mkident($1); }
- | vark AT apat { $$ = mkas($1,$3); }
- | literal { $$ = $1; setstartlineno(); }
- | WILDCARD { $$ = mkwildp(); setstartlineno(); }
- | oparenkey CPAREN { $$ = mktuple(Lnil); }
- | oparenkey var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); }
- | oparenkey WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); }
- | oparenkey opat CPAREN { $$ = mkpar($2); }
- | oparenkey opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | obrackkey pats CBRACK { $$ = mkllist($2); }
- | obrackkey CBRACK { $$ = mkllist(Lnil); }
- | lazykey apat { $$ = mklazyp($2); }
- | oprockey pats SEMI opat CPROC { $$ = mkproc($2,$4); }
- ;
-
-
-/*
- The mkpars are so that infix parsing doesn't get confused.
-
- KH.
-*/
-
-tuple : OPAREN exp COMMA texps CPAREN
- { if (ttree($4) == tuple)
- $$ = mktuple(mklcons($2, gtuplelist($4)));
- else
- $$ = mktuple(ldub($2, $4));
- }
- | OPAREN CPAREN
- { $$ = mktuple(Lnil); }
- ;
-
-texps : exp COMMA texps
- { if (ttree($3) == tuple)
- $$ = mktuple(mklcons($1, gtuplelist($3)));
- else
- $$ = mktuple(ldub($1, $3));
- }
- | exp { $$ = mkpar($1); }
- ;
-
-
-list : OBRACK CBRACK { $$ = mkllist(Lnil); }
- | OBRACK exps CBRACK { $$ = mkllist($2); }
- ;
-
-exps : exp COMMA exps { $$ = mklcons($1,$3); }
- | exp { $$ = lsing($1); }
- ;
-
-
-sequence: OBRACK exp COMMA exp DOTDOT upto CBRACK {$$ = mkeenum($2,lsing($4),$6);}
- | OBRACK exp DOTDOT upto CBRACK { $$ = mkeenum($2,Lnil,$4); }
- ;
-
-comprehension: OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); }
- ;
-
-quals : quals COMMA qual { $$ = lapp($1,$3); }
- | qual { $$ = lsing($1); }
- ;
-
-qual : { inpat = TRUE; } exp { inpat = FALSE; } qualrest
- { if ($4 == NULL)
- $$ = mkguard($2);
- else
- {
- checkpatt($2);
- if(ttree($4)==def)
- {
- tree prevpatt_save = PREVPATT;
- PREVPATT = $2;
- $$ = mkdef(mkpbind(lsing(createpat(lsing(mktruecase((tree)(ggdef($4)))),mknullbind())),hsplineno));
- PREVPATT = prevpatt_save;
- }
- else
- $$ = mkqual($2,$4);
- }
- }
- ;
-
-qualrest: LARROW exp { $$ = $2; }
-/* OLD:
- | EQUAL exp
- { if(nonstandardFlag)
- $$ = mkdef($2);
- else
- hsperror("Definitions in comprehensions are not standard Haskell");
- }
-*/
- | /* empty */ { $$ = NULL; }
- ;
-
-
-alts : alts SEMI alt { $$ = lconc($1,$3); }
- | alt { $$ = $1; }
- ;
-
-alt : pat
- { PREVPATT = $1; }
- altrest
- { $$ = $3;
- PREVPATT = NULL;
- }
- | /* empty */ { $$ = Lnil; }
- ;
-
-altrest : gdpat maybe_where { $$ = lsing(createpat($1,$2)); }
- | RARROW exp maybe_where { $$ = lsing(createpat(lsing(mktruecase($2)),$3)); }
- ;
-
-gdpat : gd RARROW exp gdpat { $$ = mklcons(ldub($1,$3),$4); }
- | gd RARROW exp { $$ = lsing(ldub($1,$3)); }
- ;
-
-upto : /* empty */ { $$ = Lnil; }
- | exp { $$ = lsing($1); }
- ;
-
-pats : pat COMMA pats { $$ = mklcons($1,$3); }
- | pat { $$ = lsing($1); }
- ;
-
-pat : bpat
- | pat conop bpat { $$ = mkinfixop($2,$1,$3); precparse($$); }
- ;
-
-bpat : apatc
- | conpat
- | MINUS INTEGER { $$ = mkinteger(ineg($2)); }
- | MINUS FLOAT { $$ = mkfloatr(ineg($2)); }
- ;
-
-conpat : con { $$ = mkident($1); }
- | conpat apat { $$ = mkap($1,$2); }
- ;
-
-apat : con { $$ = mkident($1); }
- | apatc
- ;
-
-apatc : var { $$ = mkident($1); }
- | var AT apat { $$ = mkas($1,$3); }
- | literal { $$ = $1; }
- | WILDCARD { $$ = mkwildp(); }
- | OPAREN CPAREN { $$ = mktuple(Lnil); }
- | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); }
- | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); }
- | OPAREN pat CPAREN { $$ = mkpar($2); }
- | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | OBRACK pats CBRACK { $$ = mkllist($2); }
- | OBRACK CBRACK { $$ = mkllist(Lnil); }
- | LAZY apat { $$ = mklazyp($2); }
- | OPROC pats SEMI apat CPROC { $$ = mkproc($2,$4); }
- ;
-
-/*
-patk : bpatk
- | patk conop bpat { $$ = mkinfixop($2,$1,$3); precparse($$); }
- ;
-
-bpatk : apatck
- | conpatk
- | minuskey INTEGER { $$ = mkinteger(ineg($2)); }
- | minuskey FLOAT { $$ = mkfloatr(ineg($2)); }
- ;
-
-conpatk : conk { $$ = mkident($1); }
- | conpatk apat { $$ = mkap($1,$2); }
- ;
-
-apatck : vark { $$ = mkident($1); }
- | vark AT apat { $$ = mkas($1,$3); }
- | literal { $$ = $1; setstartlineno(); }
- | WILDCARD { $$ = mkwildp(); setstartlineno(); }
- | oparenkey CPAREN { $$ = mktuple(Lnil); }
- | oparenkey var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); }
- | oparenkey WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); }
- | oparenkey pat CPAREN { $$ = mkpar($2); }
- | oparenkey pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | obrackkey pats CBRACK { $$ = mkllist($2); }
- | obrackkey CBRACK { $$ = mkllist(Lnil); }
- | lazykey apat { $$ = mklazyp($2); }
- | oprockey pats SEMI opat CPROC { $$ = mkproc($2,$4); }
- ;
-*/
-
-literal : INTEGER { $$ = mkinteger($1); }
- | FLOAT { $$ = mkfloatr($1); }
- | CHAR { $$ = mkcharr($1); }
- | STRING { $$ = mkstring($1); }
- | CHARPRIM { $$ = mkcharprim($1); }
- | INTPRIM { $$ = mkintprim($1); }
- | FLOATPRIM { $$ = mkfloatprim($1); }
- | DOUBLEPRIM { $$ = mkdoubleprim($1); }
- | CLITLIT { $$ = mkclitlit($1); }
- | VOIDPRIM { $$ = mkvoidprim(); }
- ;
-
-
-/* Keywords which record the line start */
-
-importkey: IMPORT { setstartlineno(); }
- ;
-
-datakey : DATA { setstartlineno();
- if(etags)
- printf("%u\n",startlineno);
- }
- ;
-
-typekey : TYPE { setstartlineno();
- if(etags)
- printf("%u\n",startlineno);
- }
- ;
-
-instkey : INSTANCE { setstartlineno();
- if(etags)
- printf("%u\n",startlineno);
- }
- ;
-
-defaultkey: DEFAULT { setstartlineno(); }
- ;
-
-classkey: CLASS { setstartlineno();
- if(etags)
- printf("%u\n",startlineno);
- }
- ;
-
-minuskey: MINUS { setstartlineno(); }
- ;
-
-oparenkey: OPAREN { setstartlineno(); }
- ;
-
-obrackkey: OBRACK { setstartlineno(); }
- ;
-
-lazykey : LAZY { setstartlineno(); }
- ;
-
-oprockey: OPROC { setstartlineno(); }
- ;
-
-
-/* Non "-" op, used in right sections -- KH */
-op1 : conop
- | varop1
- ;
-
-op : conop
- | varop
- ;
-
-varop : varsym
- | BQUOTE varid BQUOTE { $$ = $2; }
- ;
-
-/* Non-minus varop, used in right sections */
-varop1 : VARSYM
- | plus
- | BQUOTE varid BQUOTE { $$ = $2; }
- ;
-
-conop : consym
- | BQUOTE conid BQUOTE { $$ = $2; }
- ;
-
-consym : CONSYM
- ;
-
-varsym : VARSYM
- | plus
- | minus
- ;
-
-minus : MINUS { $$ = install_literal("-"); }
- ;
-
-plus : PLUS { $$ = install_literal("+"); }
- ;
-
-var : VARID
- | OPAREN varsym CPAREN { $$ = $2; }
- ;
-
-vark : VARID { setstartlineno(); $$ = $1; }
- | oparenkey varsym CPAREN { $$ = $2; }
- ;
-
-/* tycon used here to eliminate 11 spurious R/R errors -- KH */
-con : tycon
- | OPAREN consym CPAREN { $$ = $2; }
- ;
-
-conk : tycon { setstartlineno(); $$ = $1; }
- | oparenkey consym CPAREN { $$ = $2; }
- ;
-
-varid : VARID
- ;
-
-conid : CONID
- ;
-
-ccallid : varid
- | conid
- ;
-
-/* partain: "tyvar_list" must be at least 2 elements long (defn of "inst") */
-tyvar_list: tyvar COMMA tyvar_list { $$ = mklcons($1,$3); }
- | tyvar COMMA tyvar { $$ = mklcons($1,lsing($3)); }
- ;
-
-tyvars : tyvar tyvars { $$ = mklcons($1,$2); }
- | tyvar { $$ = lsing($1); }
- ;
-
-tyvar : VARID { $$ = mknamedtvar($1); }
- ;
-
-tycls : tycon
- /* partain: "aconid"->"tycon" got rid of a r/r conflict
- (and introduced >= 2 s/r's ...)
- */
- ;
-
-tycon : conid
- ;
-
-modid : CONID
- ;
-
-
-ocurly : layout OCURLY { hsincindent(); }
-
-vocurly : layout { hssetindent(); }
- ;
-
-layout : { hsindentoff(); }
- ;
-
-ccurly :
- CCURLY
- {
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- }
- ;
-
-vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; }
- ;
-
-vccurly1:
- VCCURLY
- {
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- }
- | error
- {
- yyerrok;
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- }
- ;
-
-%%
+++ /dev/null
-
-/* A Bison parser, made from yaccParser/hsparser.y with Bison version GNU Bison version 1.24
- */
-
-#define YYBISON 1 /* Identify Bison output. */
-
-#define VARID 258
-#define CONID 259
-#define VARSYM 260
-#define CONSYM 261
-#define MINUS 262
-#define INTEGER 263
-#define FLOAT 264
-#define CHAR 265
-#define STRING 266
-#define CHARPRIM 267
-#define STRINGPRIM 268
-#define INTPRIM 269
-#define FLOATPRIM 270
-#define DOUBLEPRIM 271
-#define CLITLIT 272
-#define OCURLY 273
-#define CCURLY 274
-#define VCCURLY 275
-#define SEMI 276
-#define OBRACK 277
-#define CBRACK 278
-#define OPAREN 279
-#define CPAREN 280
-#define COMMA 281
-#define BQUOTE 282
-#define RARROW 283
-#define VBAR 284
-#define EQUAL 285
-#define DARROW 286
-#define DOTDOT 287
-#define DCOLON 288
-#define LARROW 289
-#define WILDCARD 290
-#define AT 291
-#define LAZY 292
-#define LAMBDA 293
-#define LET 294
-#define IN 295
-#define WHERE 296
-#define CASE 297
-#define OF 298
-#define TYPE 299
-#define DATA 300
-#define CLASS 301
-#define INSTANCE 302
-#define DEFAULT 303
-#define INFIX 304
-#define INFIXL 305
-#define INFIXR 306
-#define MODULE 307
-#define IMPORT 308
-#define INTERFACE 309
-#define HIDING 310
-#define CCALL 311
-#define CCALL_GC 312
-#define CASM 313
-#define CASM_GC 314
-#define SCC 315
-#define IF 316
-#define THEN 317
-#define ELSE 318
-#define RENAMING 319
-#define DERIVING 320
-#define TO 321
-#define LEOF 322
-#define GHC_PRAGMA 323
-#define END_PRAGMA 324
-#define NO_PRAGMA 325
-#define NOINFO_PRAGMA 326
-#define ABSTRACT_PRAGMA 327
-#define SPECIALISE_PRAGMA 328
-#define MODNAME_PRAGMA 329
-#define ARITY_PRAGMA 330
-#define UPDATE_PRAGMA 331
-#define STRICTNESS_PRAGMA 332
-#define KIND_PRAGMA 333
-#define UNFOLDING_PRAGMA 334
-#define MAGIC_UNFOLDING_PRAGMA 335
-#define DEFOREST_PRAGMA 336
-#define SPECIALISE_UPRAGMA 337
-#define INLINE_UPRAGMA 338
-#define MAGIC_UNFOLDING_UPRAGMA 339
-#define ABSTRACT_UPRAGMA 340
-#define DEFOREST_UPRAGMA 341
-#define END_UPRAGMA 342
-#define TYLAMBDA 343
-#define COCON 344
-#define COPRIM 345
-#define COAPP 346
-#define COTYAPP 347
-#define FORALL 348
-#define TYVAR_TEMPLATE_ID 349
-#define CO_ALG_ALTS 350
-#define CO_PRIM_ALTS 351
-#define CO_NO_DEFAULT 352
-#define CO_LETREC 353
-#define CO_SDSEL_ID 354
-#define CO_METH_ID 355
-#define CO_DEFM_ID 356
-#define CO_DFUN_ID 357
-#define CO_CONSTM_ID 358
-#define CO_SPEC_ID 359
-#define CO_WRKR_ID 360
-#define CO_ORIG_NM 361
-#define UNFOLD_ALWAYS 362
-#define UNFOLD_IF_ARGS 363
-#define NOREP_INTEGER 364
-#define NOREP_RATIONAL 365
-#define NOREP_STRING 366
-#define CO_PRELUDE_DICTS_CC 367
-#define CO_ALL_DICTS_CC 368
-#define CO_USER_CC 369
-#define CO_AUTO_CC 370
-#define CO_DICT_CC 371
-#define CO_CAF_CC 372
-#define CO_DUPD_CC 373
-#define PLUS 374
-
-#line 22 "yaccParser/hsparser.y"
-
-#ifdef HSP_DEBUG
-# define YYDEBUG 1
-#endif
-
-#include <stdio.h>
-#include <ctype.h>
-#include <string.h>
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/**********************************************************************
-* *
-* *
-* Imported Variables and Functions *
-* *
-* *
-**********************************************************************/
-
-static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
-
-extern BOOLEAN nonstandardFlag;
-extern BOOLEAN etags;
-
-extern VOID find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
-
-extern char *input_filename;
-static char *the_module_name;
-static char iface_name[MODNAME_SIZE];
-static char interface_filename[FILENAME_SIZE];
-
-static list module_exports; /* Exported entities */
-static list prelude_core_import, prelude_imports;
- /* Entities imported from the Prelude */
-
-extern list all; /* All valid deriving classes */
-
-extern tree niltree;
-extern list Lnil;
-
-extern tree root;
-
-/* For FN, PREVPATT and SAMEFN macros */
-extern tree fns[];
-extern short samefn[];
-extern tree prevpatt[];
-extern short icontexts;
-
-/* Line Numbers */
-extern int hsplineno, hspcolno;
-extern int startlineno;
-
-
-/**********************************************************************
-* *
-* *
-* Fixity and Precedence Declarations *
-* *
-* *
-**********************************************************************/
-
-/* OLD 95/08: list fixlist; */
-static int Fixity = 0, Precedence = 0;
-struct infix;
-
-char *ineg PROTO((char *));
-
-static BOOLEAN hidden = FALSE; /* Set when HIDING used */
-
-extern BOOLEAN inpat; /* True when parsing a pattern */
-extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */
-extern BOOLEAN haskell1_3Flag; /* True if we are attempting (proto)Haskell 1.3 */
-
-extern int thisIfacePragmaVersion;
-
-#line 99 "yaccParser/hsparser.y"
-typedef union {
- tree utree;
- list ulist;
- ttype uttype;
- atype uatype;
- binding ubinding;
- pbinding upbinding;
- finfot ufinfo;
- entidt uentid;
- id uid;
- literal uliteral;
- int uint;
- float ufloat;
- char *ustring;
- hstring uhstring;
- hpragma uhpragma;
- coresyn ucoresyn;
-} YYSTYPE;
-
-#ifndef YYLTYPE
-typedef
- struct yyltype
- {
- int timestamp;
- int first_line;
- int first_column;
- int last_line;
- int last_column;
- char *text;
- }
- yyltype;
-
-#define YYLTYPE yyltype
-#endif
-
-#include <stdio.h>
-
-#ifndef __cplusplus
-#ifndef __STDC__
-#define const
-#endif
-#endif
-
-
-
-#define YYFINAL 1105
-#define YYFLAG -32768
-#define YYNTBASE 120
-
-#define YYTRANSLATE(x) ((unsigned)(x) <= 374 ? yytranslate[x] : 343)
-
-static const char yytranslate[] = { 0,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 2, 2, 2, 2, 2, 1, 2, 3, 4, 5,
- 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 20, 21, 22, 23, 24, 25,
- 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,
- 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
- 46, 47, 48, 49, 50, 51, 52, 53, 54, 55,
- 56, 57, 58, 59, 60, 61, 62, 63, 64, 65,
- 66, 67, 68, 69, 70, 71, 72, 73, 74, 75,
- 76, 77, 78, 79, 80, 81, 82, 83, 84, 85,
- 86, 87, 88, 89, 90, 91, 92, 93, 94, 95,
- 96, 97, 98, 99, 100, 101, 102, 103, 104, 105,
- 106, 107, 108, 109, 110, 111, 112, 113, 114, 115,
- 116, 117, 118, 119
-};
-
-#if YYDEBUG != 0
-static const short yyprhs[] = { 0,
- 0, 4, 5, 12, 13, 16, 22, 28, 32, 36,
- 40, 44, 45, 49, 51, 55, 57, 59, 64, 69,
- 74, 78, 81, 85, 90, 93, 94, 96, 98, 102,
- 104, 106, 111, 116, 121, 125, 130, 134, 135, 138,
- 139, 141, 145, 149, 153, 154, 158, 159, 164, 165,
- 170, 176, 177, 180, 181, 185, 186, 188, 195, 197,
- 200, 202, 205, 207, 209, 211, 214, 218, 222, 223,
- 225, 228, 232, 234, 240, 242, 246, 248, 251, 253,
- 257, 263, 265, 269, 271, 273, 275, 279, 285, 289,
- 294, 299, 304, 311, 316, 320, 326, 333, 342, 349,
- 355, 357, 359, 363, 367, 368, 371, 377, 378, 381,
- 386, 388, 392, 394, 398, 402, 405, 410, 417, 424,
- 431, 433, 435, 437, 439, 443, 447, 451, 457, 464,
- 470, 473, 477, 481, 483, 485, 494, 503, 512, 521,
- 523, 524, 527, 533, 536, 540, 542, 546, 548, 550,
- 552, 555, 557, 561, 564, 568, 570, 574, 576, 578,
- 582, 584, 586, 587, 590, 591, 594, 595, 598, 600,
- 604, 605, 610, 613, 618, 621, 625, 627, 631, 635,
- 639, 640, 643, 645, 649, 655, 663, 664, 670, 676,
- 680, 686, 690, 691, 694, 696, 700, 701, 706, 707,
- 712, 713, 718, 719, 723, 724, 728, 729, 733, 735,
- 739, 741, 745, 747, 749, 751, 753, 755, 757, 762,
- 769, 774, 783, 790, 796, 800, 801, 806, 811, 818,
- 823, 824, 829, 834, 836, 841, 847, 850, 854, 860,
- 862, 867, 873, 876, 880, 886, 889, 895, 897, 899,
- 903, 910, 915, 921, 927, 933, 938, 943, 947, 951,
- 953, 954, 955, 957, 959, 963, 965, 969, 971, 975,
- 977, 979, 981, 983, 985, 986, 993, 998, 1004, 1010,
- 1014, 1022, 1028, 1037, 1044, 1051, 1056, 1063, 1068, 1071,
- 1073, 1077, 1079, 1083, 1088, 1090, 1093, 1096, 1098, 1100,
- 1104, 1107, 1109, 1115, 1117, 1119, 1122, 1126, 1130, 1137,
- 1139, 1141, 1144, 1146, 1150, 1153, 1158, 1160, 1164, 1168,
- 1172, 1175, 1177, 1179, 1183, 1187, 1189, 1191, 1195, 1196,
- 1198, 1202, 1208, 1213, 1218, 1220, 1224, 1226, 1228, 1232,
- 1234, 1238, 1239, 1243, 1246, 1248, 1251, 1255, 1260, 1265,
- 1270, 1271, 1274, 1277, 1279, 1285, 1289, 1291, 1293, 1297,
- 1300, 1302, 1303, 1304, 1311, 1318, 1325, 1332, 1339, 1346,
- 1350, 1353, 1357, 1360, 1364, 1367, 1371, 1374, 1378, 1380,
- 1383, 1385, 1388, 1390, 1392, 1394, 1396, 1400, 1405, 1410,
- 1412, 1414, 1416, 1418, 1422, 1424, 1427, 1429, 1433, 1435,
- 1439, 1442, 1444, 1447, 1449, 1452, 1454, 1457, 1459, 1461,
- 1463, 1467, 1469, 1471, 1474, 1480, 1484, 1490, 1494, 1497,
- 1500, 1502, 1504, 1508, 1510, 1512, 1515, 1521, 1525, 1531,
- 1535, 1538, 1541, 1547, 1550, 1552, 1556, 1559, 1563, 1565,
- 1569, 1577, 1583, 1589, 1591, 1595, 1596, 1597, 1602, 1605,
- 1606, 1608, 1612, 1613, 1617, 1618, 1621, 1625, 1630, 1634,
- 1635, 1637, 1641, 1643, 1645, 1649, 1651, 1653, 1656, 1659,
- 1661, 1664, 1666, 1668, 1670, 1674, 1676, 1678, 1681, 1687,
- 1691, 1697, 1701, 1704, 1707, 1709, 1711, 1713, 1715, 1717,
- 1719, 1721, 1723, 1725, 1727, 1731, 1734, 1738, 1741, 1743,
- 1745, 1747, 1749, 1751, 1753, 1755, 1757, 1759, 1761, 1763,
- 1765, 1767, 1769, 1771, 1773, 1777, 1779, 1781, 1785, 1787,
- 1791, 1793, 1795, 1797, 1799, 1801, 1803, 1807, 1809, 1813,
- 1815, 1819, 1821, 1825, 1827, 1829, 1831, 1835, 1837, 1840,
- 1842, 1844, 1846, 1848, 1851, 1853, 1854, 1856, 1857, 1860,
- 1862
-};
-
-static const short yyrhs[] = { 184,
- 186, 121, 0, 0, 313, 335, 125, 122, 41, 124,
- 0, 0, 123, 124, 0, 336, 188, 203, 213, 339,
- 0, 337, 188, 203, 213, 340, 0, 337, 189, 340,
- 0, 336, 189, 339, 0, 337, 188, 340, 0, 336,
- 188, 339, 0, 0, 24, 126, 25, 0, 127, 0,
- 126, 26, 127, 0, 325, 0, 334, 0, 334, 24,
- 32, 25, 0, 334, 24, 256, 25, 0, 334, 24,
- 254, 25, 0, 334, 24, 25, 0, 334, 32, 0,
- 24, 130, 25, 0, 55, 24, 130, 25, 0, 24,
- 25, 0, 0, 128, 0, 131, 0, 130, 26, 131,
- 0, 325, 0, 334, 0, 334, 24, 32, 25, 0,
- 334, 24, 256, 25, 0, 334, 24, 254, 25, 0,
- 334, 24, 25, 0, 68, 246, 133, 69, 0, 68,
- 133, 69, 0, 0, 73, 134, 0, 0, 135, 0,
- 134, 26, 135, 0, 22, 154, 23, 0, 68, 72,
- 69, 0, 0, 68, 150, 69, 0, 0, 68, 142,
- 142, 69, 0, 0, 68, 140, 142, 69, 0, 68,
- 140, 142, 156, 69, 0, 0, 74, 335, 0, 0,
- 68, 142, 69, 0, 0, 71, 0, 143, 144, 145,
- 146, 148, 151, 0, 70, 0, 75, 8, 0, 70,
- 0, 76, 8, 0, 70, 0, 81, 0, 70, 0,
- 77, 89, 0, 77, 11, 147, 0, 18, 142, 19,
- 0, 0, 70, 0, 80, 326, 0, 79, 149, 158,
- 0, 107, 0, 108, 8, 8, 4, 8, 0, 142,
- 0, 150, 26, 142, 0, 70, 0, 73, 152, 0,
- 153, 0, 152, 26, 153, 0, 22, 154, 23, 8,
- 147, 0, 155, 0, 154, 26, 155, 0, 70, 0,
- 239, 0, 157, 0, 156, 26, 157, 0, 325, 30,
- 18, 142, 19, 0, 325, 30, 142, 0, 38, 172,
- 28, 158, 0, 88, 177, 28, 158, 0, 89, 327,
- 179, 174, 0, 89, 106, 335, 327, 179, 174, 0,
- 90, 171, 179, 174, 0, 91, 158, 174, 0, 92,
- 158, 18, 181, 19, 0, 42, 158, 43, 18, 159,
- 19, 0, 39, 18, 173, 30, 158, 19, 40, 158,
- 0, 98, 18, 165, 19, 40, 158, 0, 60, 18,
- 167, 19, 158, 0, 305, 0, 170, 0, 95, 160,
- 164, 0, 96, 162, 164, 0, 0, 160, 161, 0,
- 170, 172, 28, 158, 21, 0, 0, 162, 163, 0,
- 305, 28, 158, 21, 0, 97, 0, 173, 28, 158,
- 0, 166, 0, 165, 21, 166, 0, 173, 30, 158,
- 0, 112, 169, 0, 113, 11, 11, 169, 0, 114,
- 11, 11, 11, 169, 168, 0, 115, 170, 11, 11,
- 169, 168, 0, 116, 170, 11, 11, 169, 168, 0,
- 70, 0, 117, 0, 70, 0, 118, 0, 99, 334,
- 334, 0, 100, 334, 325, 0, 101, 334, 325, 0,
- 102, 334, 24, 181, 25, 0, 103, 334, 325, 24,
- 181, 25, 0, 104, 170, 22, 182, 23, 0, 105,
- 170, 0, 106, 335, 325, 0, 106, 335, 327, 0,
- 325, 0, 327, 0, 24, 56, 329, 18, 179, 181,
- 19, 25, 0, 24, 57, 329, 18, 179, 181, 19,
- 25, 0, 24, 58, 305, 18, 179, 181, 19, 25,
- 0, 24, 59, 305, 18, 179, 181, 19, 25, 0,
- 3, 0, 0, 172, 173, 0, 24, 3, 33, 181,
- 25, 0, 22, 23, 0, 22, 175, 23, 0, 176,
- 0, 175, 26, 176, 0, 305, 0, 170, 0, 3,
- 0, 177, 3, 0, 94, 0, 178, 26, 94, 0,
- 22, 23, 0, 22, 180, 23, 0, 181, 0, 180,
- 26, 181, 0, 239, 0, 183, 0, 182, 26, 183,
- 0, 70, 0, 181, 0, 0, 185, 193, 0, 0,
- 187, 193, 0, 0, 189, 21, 0, 190, 0, 189,
- 21, 190, 0, 0, 53, 335, 191, 192, 0, 193,
- 129, 0, 193, 129, 64, 194, 0, 200, 67, 0,
- 24, 195, 25, 0, 196, 0, 195, 26, 196, 0,
- 325, 66, 325, 0, 327, 66, 327, 0, 0, 198,
- 21, 0, 199, 0, 198, 21, 199, 0, 306, 335,
- 24, 130, 25, 0, 306, 335, 24, 130, 25, 64,
- 194, 0, 0, 54, 335, 201, 41, 202, 0, 336,
- 197, 203, 230, 339, 0, 336, 198, 339, 0, 337,
- 197, 203, 230, 340, 0, 337, 198, 340, 0, 0,
- 204, 21, 0, 205, 0, 204, 21, 205, 0, 0,
- 50, 8, 206, 212, 0, 0, 51, 8, 207, 212,
- 0, 0, 49, 8, 208, 212, 0, 0, 50, 209,
- 212, 0, 0, 51, 210, 212, 0, 0, 49, 211,
- 212, 0, 318, 0, 212, 26, 318, 0, 214, 0,
- 213, 21, 214, 0, 215, 0, 216, 0, 217, 0,
- 219, 0, 223, 0, 226, 0, 308, 245, 30, 239,
- 0, 307, 250, 31, 245, 30, 246, 0, 307, 245,
- 30, 246, 0, 307, 250, 31, 245, 30, 246, 65,
- 248, 0, 307, 245, 30, 246, 65, 248, 0, 311,
- 250, 31, 237, 218, 0, 311, 237, 218, 0, 0,
- 41, 336, 225, 339, 0, 41, 337, 225, 340, 0,
- 309, 250, 31, 333, 221, 220, 0, 309, 333, 222,
- 220, 0, 0, 41, 336, 252, 339, 0, 41, 337,
- 252, 340, 0, 334, 0, 24, 334, 331, 25, 0,
- 24, 332, 26, 330, 25, 0, 24, 25, 0, 22,
- 332, 23, 0, 24, 332, 28, 332, 25, 0, 334,
- 0, 24, 334, 241, 25, 0, 24, 239, 26, 238,
- 25, 0, 24, 25, 0, 22, 239, 23, 0, 24,
- 240, 28, 239, 25, 0, 310, 224, 0, 24, 239,
- 26, 238, 25, 0, 242, 0, 226, 0, 225, 21,
- 226, 0, 254, 33, 239, 31, 239, 138, 0, 254,
- 33, 239, 138, 0, 82, 326, 33, 228, 87, 0,
- 82, 47, 4, 222, 87, 0, 82, 45, 334, 241,
- 87, 0, 83, 326, 227, 87, 0, 84, 326, 326,
- 87, 0, 86, 326, 87, 0, 85, 334, 87, 0,
- 257, 0, 0, 0, 4, 0, 229, 0, 228, 26,
- 229, 0, 239, 0, 239, 30, 326, 0, 231, 0,
- 230, 21, 231, 0, 233, 0, 234, 0, 235, 0,
- 236, 0, 232, 0, 0, 254, 33, 239, 31, 239,
- 141, 0, 254, 33, 239, 141, 0, 308, 245, 30,
- 239, 136, 0, 307, 250, 31, 245, 132, 0, 307,
- 245, 132, 0, 307, 250, 31, 245, 30, 246, 132,
- 0, 307, 245, 30, 246, 132, 0, 307, 250, 31,
- 245, 30, 246, 65, 248, 0, 307, 245, 30, 246,
- 65, 248, 0, 311, 250, 31, 237, 137, 218, 0,
- 311, 237, 137, 218, 0, 309, 250, 31, 333, 222,
- 139, 0, 309, 333, 222, 139, 0, 334, 332, 0,
- 239, 0, 238, 26, 239, 0, 240, 0, 240, 28,
- 239, 0, 93, 178, 31, 239, 0, 243, 0, 334,
- 241, 0, 241, 243, 0, 243, 0, 244, 0, 240,
- 28, 239, 0, 334, 241, 0, 244, 0, 24, 239,
- 26, 238, 25, 0, 332, 0, 334, 0, 24, 25,
- 0, 24, 239, 25, 0, 22, 239, 23, 0, 18,
- 18, 4, 239, 19, 19, 0, 94, 0, 334, 0,
- 334, 331, 0, 247, 0, 246, 29, 247, 0, 334,
- 241, 0, 24, 6, 25, 241, 0, 334, 0, 24,
- 6, 25, 0, 240, 321, 240, 0, 24, 249, 25,
- 0, 24, 25, 0, 333, 0, 333, 0, 249, 26,
- 333, 0, 24, 251, 25, 0, 237, 0, 237, 0,
- 251, 26, 237, 0, 0, 253, 0, 252, 21, 253,
- 0, 82, 326, 33, 228, 87, 0, 83, 326, 227,
- 87, 0, 84, 326, 326, 87, 0, 257, 0, 326,
- 26, 255, 0, 326, 0, 325, 0, 255, 26, 325,
- 0, 327, 0, 256, 26, 327, 0, 0, 274, 258,
- 259, 0, 260, 262, 0, 261, 0, 30, 265, 0,
- 263, 30, 265, 0, 263, 30, 265, 261, 0, 41,
- 336, 225, 339, 0, 41, 337, 225, 340, 0, 0,
- 29, 266, 0, 303, 264, 0, 303, 0, 266, 33,
- 239, 31, 239, 0, 266, 33, 239, 0, 266, 0,
- 267, 0, 266, 318, 266, 0, 7, 268, 0, 268,
- 0, 0, 0, 38, 269, 264, 270, 28, 265, 0,
- 39, 336, 225, 339, 40, 265, 0, 39, 337, 225,
- 340, 40, 265, 0, 61, 265, 62, 265, 63, 265,
- 0, 42, 265, 43, 336, 293, 339, 0, 42, 265,
- 43, 337, 293, 340, 0, 56, 329, 272, 0, 56,
- 329, 0, 57, 329, 272, 0, 57, 329, 0, 58,
- 17, 272, 0, 58, 17, 0, 59, 17, 272, 0,
- 59, 17, 0, 60, 11, 265, 0, 271, 0, 271,
- 273, 0, 273, 0, 272, 273, 0, 273, 0, 325,
- 0, 327, 0, 305, 0, 24, 265, 25, 0, 24,
- 266, 318, 25, 0, 24, 317, 266, 25, 0, 282,
- 0, 284, 0, 286, 0, 287, 0, 325, 36, 273,
- 0, 35, 0, 37, 273, 0, 278, 0, 274, 318,
- 275, 0, 276, 0, 275, 318, 275, 0, 7, 277,
- 0, 277, 0, 277, 280, 0, 280, 0, 312, 277,
- 0, 279, 0, 279, 280, 0, 281, 0, 327, 0,
- 325, 0, 325, 36, 303, 0, 305, 0, 35, 0,
- 24, 25, 0, 24, 325, 119, 8, 25, 0, 24,
- 275, 25, 0, 24, 275, 26, 299, 25, 0, 22,
- 299, 23, 0, 22, 23, 0, 37, 303, 0, 328,
- 0, 326, 0, 326, 36, 303, 0, 305, 0, 35,
- 0, 314, 25, 0, 314, 325, 119, 8, 25, 0,
- 314, 275, 25, 0, 314, 275, 26, 299, 25, 0,
- 315, 299, 23, 0, 315, 23, 0, 316, 303, 0,
- 24, 265, 26, 283, 25, 0, 24, 25, 0, 265,
- 0, 265, 26, 283, 0, 22, 23, 0, 22, 285,
- 23, 0, 265, 0, 265, 26, 285, 0, 22, 265,
- 26, 265, 32, 298, 23, 0, 22, 265, 32, 298,
- 23, 0, 22, 265, 29, 288, 23, 0, 289, 0,
- 288, 26, 289, 0, 0, 0, 290, 265, 291, 292,
- 0, 34, 265, 0, 0, 294, 0, 293, 21, 294,
- 0, 0, 300, 295, 296, 0, 0, 297, 262, 0,
- 28, 265, 262, 0, 263, 28, 265, 297, 0, 263,
- 28, 265, 0, 0, 265, 0, 300, 26, 299, 0,
- 300, 0, 301, 0, 300, 321, 301, 0, 304, 0,
- 302, 0, 7, 8, 0, 7, 9, 0, 327, 0,
- 302, 303, 0, 327, 0, 304, 0, 325, 0, 325,
- 36, 303, 0, 305, 0, 35, 0, 24, 25, 0,
- 24, 325, 119, 8, 25, 0, 24, 300, 25, 0,
- 24, 300, 26, 299, 25, 0, 22, 299, 23, 0,
- 22, 23, 0, 37, 303, 0, 8, 0, 9, 0,
- 10, 0, 11, 0, 12, 0, 13, 0, 14, 0,
- 15, 0, 16, 0, 17, 0, 17, 78, 4, 0,
- 109, 8, 0, 110, 8, 8, 0, 111, 11, 0,
- 53, 0, 45, 0, 44, 0, 47, 0, 48, 0,
- 46, 0, 7, 0, 52, 0, 24, 0, 22, 0,
- 37, 0, 321, 0, 320, 0, 321, 0, 319, 0,
- 322, 0, 27, 3, 27, 0, 5, 0, 324, 0,
- 27, 3, 27, 0, 6, 0, 27, 4, 27, 0,
- 5, 0, 324, 0, 323, 0, 7, 0, 119, 0,
- 3, 0, 24, 322, 25, 0, 3, 0, 314, 322,
- 25, 0, 334, 0, 24, 6, 25, 0, 334, 0,
- 314, 6, 25, 0, 3, 0, 4, 0, 332, 0,
- 330, 26, 332, 0, 332, 0, 331, 332, 0, 3,
- 0, 334, 0, 4, 0, 4, 0, 338, 18, 0,
- 338, 0, 0, 19, 0, 0, 341, 342, 0, 20,
- 0, 1, 0
-};
-
-#endif
-
-#if YYDEBUG != 0
-static const short yyrline[] = { 0,
- 329, 332, 334, 335, 337, 340, 344, 349, 353, 359,
- 363, 370, 371, 374, 376, 379, 381, 382, 383, 387,
- 391, 395, 402, 403, 404, 407, 408, 411, 413, 416,
- 418, 419, 420, 424, 428, 436, 439, 441, 444, 447,
- 450, 452, 456, 460, 462, 465, 467, 470, 473, 477,
- 481, 484, 488, 491, 495, 498, 502, 505, 509, 511,
- 514, 516, 519, 521, 524, 526, 529, 533, 535, 537,
- 539, 541, 545, 548, 552, 554, 557, 559, 562, 564,
- 567, 572, 574, 577, 579, 582, 584, 587, 598, 608,
- 611, 613, 615, 617, 619, 621, 623, 625, 627, 629,
- 631, 632, 635, 638, 642, 644, 647, 652, 654, 657,
- 661, 663, 666, 668, 671, 675, 677, 678, 680, 682,
- 685, 686, 688, 689, 691, 693, 694, 695, 697, 699,
- 701, 702, 703, 704, 705, 708, 711, 713, 715, 717,
- 720, 722, 725, 728, 730, 733, 735, 738, 740, 743,
- 745, 748, 750, 753, 755, 758, 760, 763, 783, 785,
- 788, 790, 795, 810, 817, 831, 838, 839, 842, 843,
- 846, 868, 874, 878, 882, 890, 893, 895, 898, 899,
- 902, 903, 906, 907, 910, 912, 917, 922, 935, 939,
- 943, 947, 953, 954, 958, 959, 962, 965, 965, 968,
- 968, 971, 971, 974, 974, 977, 977, 980, 982, 983,
- 986, 987, 1006, 1007, 1008, 1009, 1010, 1011, 1014, 1018,
- 1020, 1022, 1024, 1028, 1029, 1032, 1033, 1034, 1037, 1038,
- 1041, 1042, 1043, 1046, 1047, 1048, 1049, 1050, 1051, 1054,
- 1055, 1056, 1057, 1058, 1059, 1062, 1065, 1066, 1073, 1074,
- 1103, 1108, 1121, 1127, 1133, 1139, 1145, 1151, 1157, 1165,
- 1166, 1169, 1171, 1173, 1175, 1178, 1180, 1182, 1183, 1186,
- 1187, 1188, 1189, 1190, 1191, 1195, 1197, 1201, 1205, 1207,
- 1209, 1211, 1213, 1215, 1219, 1221, 1225, 1227, 1234, 1238,
- 1239, 1242, 1243, 1245, 1248, 1249, 1252, 1253, 1257, 1258,
- 1259, 1262, 1263, 1266, 1267, 1268, 1269, 1270, 1272, 1274,
- 1278, 1279, 1282, 1283, 1287, 1288, 1289, 1290, 1291, 1294,
- 1295, 1296, 1299, 1300, 1303, 1304, 1307, 1308, 1311, 1312,
- 1313, 1326, 1333, 1339, 1345, 1349, 1350, 1353, 1354, 1357,
- 1358, 1362, 1388, 1402, 1405, 1406, 1409, 1410, 1413, 1415,
- 1416, 1419, 1423, 1424, 1434, 1435, 1436, 1445, 1446, 1456,
- 1457, 1464, 1472, 1475, 1481, 1482, 1485, 1488, 1489, 1492,
- 1493, 1494, 1495, 1496, 1497, 1498, 1499, 1502, 1513, 1518,
- 1519, 1522, 1523, 1533, 1534, 1535, 1536, 1537, 1538, 1541,
- 1542, 1543, 1544, 1547, 1548, 1549, 1562, 1563, 1577, 1578,
- 1598, 1599, 1603, 1604, 1607, 1608, 1612, 1613, 1616, 1617,
- 1618, 1619, 1620, 1621, 1622, 1626, 1627, 1628, 1629, 1630,
- 1633, 1634, 1635, 1636, 1637, 1638, 1639, 1643, 1644, 1645,
- 1646, 1647, 1651, 1657, 1666, 1667, 1677, 1678, 1681, 1683,
- 1698, 1699, 1702, 1705, 1706, 1709, 1709, 1710, 1730, 1731,
- 1734, 1735, 1738, 1741, 1744, 1747, 1748, 1751, 1752, 1755,
- 1756, 1759, 1760, 1764, 1765, 1768, 1769, 1770, 1771, 1774,
- 1775, 1778, 1779, 1782, 1783, 1784, 1785, 1786, 1787, 1791,
- 1792, 1793, 1794, 1795, 1798, 1800, 1801, 1802, 1803, 1804,
- 1805, 1806, 1807, 1808, 1809, 1810, 1811, 1812, 1818, 1821,
- 1831, 1841, 1852, 1855, 1865, 1868, 1878, 1881, 1884, 1890,
- 1891, 1894, 1895, 1898, 1899, 1903, 1904, 1905, 1908, 1909,
- 1912, 1913, 1914, 1917, 1920, 1923, 1924, 1927, 1928, 1932,
- 1933, 1936, 1937, 1940, 1941, 1944, 1945, 1948, 1949, 1952,
- 1955, 1961, 1964, 1968, 1970, 1973, 1976, 1984, 1984, 1987,
- 1993
-};
-
-static const char * const yytname[] = { "$","error","$undefined.","VARID",
-"CONID","VARSYM","CONSYM","MINUS","INTEGER","FLOAT","CHAR","STRING","CHARPRIM",
-"STRINGPRIM","INTPRIM","FLOATPRIM","DOUBLEPRIM","CLITLIT","OCURLY","CCURLY",
-"VCCURLY","SEMI","OBRACK","CBRACK","OPAREN","CPAREN","COMMA","BQUOTE","RARROW",
-"VBAR","EQUAL","DARROW","DOTDOT","DCOLON","LARROW","WILDCARD","AT","LAZY","LAMBDA",
-"LET","IN","WHERE","CASE","OF","TYPE","DATA","CLASS","INSTANCE","DEFAULT","INFIX",
-"INFIXL","INFIXR","MODULE","IMPORT","INTERFACE","HIDING","CCALL","CCALL_GC",
-"CASM","CASM_GC","SCC","IF","THEN","ELSE","RENAMING","DERIVING","TO","LEOF",
-"GHC_PRAGMA","END_PRAGMA","NO_PRAGMA","NOINFO_PRAGMA","ABSTRACT_PRAGMA","SPECIALISE_PRAGMA",
-"MODNAME_PRAGMA","ARITY_PRAGMA","UPDATE_PRAGMA","STRICTNESS_PRAGMA","KIND_PRAGMA",
-"UNFOLDING_PRAGMA","MAGIC_UNFOLDING_PRAGMA","DEFOREST_PRAGMA","SPECIALISE_UPRAGMA",
-"INLINE_UPRAGMA","MAGIC_UNFOLDING_UPRAGMA","ABSTRACT_UPRAGMA","DEFOREST_UPRAGMA",
-"END_UPRAGMA","TYLAMBDA","COCON","COPRIM","COAPP","COTYAPP","FORALL","TYVAR_TEMPLATE_ID",
-"CO_ALG_ALTS","CO_PRIM_ALTS","CO_NO_DEFAULT","CO_LETREC","CO_SDSEL_ID","CO_METH_ID",
-"CO_DEFM_ID","CO_DFUN_ID","CO_CONSTM_ID","CO_SPEC_ID","CO_WRKR_ID","CO_ORIG_NM",
-"UNFOLD_ALWAYS","UNFOLD_IF_ARGS","NOREP_INTEGER","NOREP_RATIONAL","NOREP_STRING",
-"CO_PRELUDE_DICTS_CC","CO_ALL_DICTS_CC","CO_USER_CC","CO_AUTO_CC","CO_DICT_CC",
-"CO_CAF_CC","CO_DUPD_CC","PLUS","pmodule","module","@1","@2","body","maybeexports",
-"export_list","export","impspec","maybeimpspec","import_list","import","idata_pragma",
-"idata_pragma_specs","idata_pragma_specslist","idata_pragma_spectypes","itype_pragma",
-"iclas_pragma","iclasop_pragma","iinst_pragma","modname_pragma","ival_pragma",
-"gen_pragma","arity_pragma","update_pragma","deforest_pragma","strictness_pragma",
-"worker_info","unfolding_pragma","unfolding_guidance","gen_pragma_list","type_pragma_pairs_maybe",
-"type_pragma_pairs","type_pragma_pair","type_maybes","type_maybe","name_pragma_pairs",
-"name_pragma_pair","core_expr","core_case_alts","core_alg_alts","core_alg_alt",
-"core_prim_alts","core_prim_alt","core_default","corec_binds","corec_bind","co_scc",
-"co_caf","co_dupd","core_id","co_primop","core_binders","core_binder","core_atoms",
-"core_atom_list","core_atom","core_tyvars","core_tv_templates","core_types",
-"core_type_list","core_type","core_type_maybes","core_type_maybe","readpreludecore",
-"@3","readprelude","@4","maybeimpdecls","impdecls","impdecl","@5","impdecl_rest",
-"readinterface","renamings","renaming_list","renaming","maybeiimports","iimports",
-"iimport","interface","@6","ibody","maybefixes","fixes","fix","@7","@8","@9",
-"@10","@11","@12","ops","topdecls","topdecl","typed","datad","classd","cbody",
-"instd","rinst","restrict_inst","general_inst","defaultd","dtypes","decls","decl",
-"howto_inline_maybe","types_and_maybe_ids","type_and_maybe_id","itopdecls","itopdecl",
-"ivarsd","ityped","idatad","iclassd","iinstd","class","types","type","btype",
-"atypes","ttype","atype","ntatype","simple","constrs","constr","tyclses","tycls_list",
-"context","context_list","instdefs","instdef","vars","varsrest","cons","valdef",
-"@13","valrhs","valrhs1","gdrhs","maybe_where","gd","lampats","exp","oexp","dexp",
-"kexp","@14","@15","fexp","cexp","aexp","opatk","opat","dpat","fpat","dpatk",
-"fpatk","aapat","aapatk","tuple","texps","list","list_exps","sequence","comprehension",
-"quals","qual","@16","@17","qualrest","alts","alt","@18","altrest","gdpat","upto",
-"pats","pat","bpat","conpat","apat","apatc","lit_constant","importkey","datakey",
-"typekey","instkey","defaultkey","classkey","minuskey","modulekey","oparenkey",
-"obrackkey","lazykey","op1","op","varop","varop1","conop","varsym","minus","plus",
-"var","vark","con","conk","ccallid","tyvar_list","tyvars","tyvar","tycls","tycon",
-"modid","ocurly","vocurly","layout","ccurly","vccurly","@19","vccurly1",""
-};
-#endif
-
-static const short yyr1[] = { 0,
- 120, 122, 121, 123, 121, 124, 124, 124, 124, 124,
- 124, 125, 125, 126, 126, 127, 127, 127, 127, 127,
- 127, 127, 128, 128, 128, 129, 129, 130, 130, 131,
- 131, 131, 131, 131, 131, 132, 132, 132, 133, 133,
- 134, 134, 135, 136, 136, 137, 137, 138, 138, 139,
- 139, 139, 140, 140, 141, 141, 142, 142, 143, 143,
- 144, 144, 145, 145, 146, 146, 146, 147, 147, 148,
- 148, 148, 149, 149, 150, 150, 151, 151, 152, 152,
- 153, 154, 154, 155, 155, 156, 156, 157, 157, 158,
- 158, 158, 158, 158, 158, 158, 158, 158, 158, 158,
- 158, 158, 159, 159, 160, 160, 161, 162, 162, 163,
- 164, 164, 165, 165, 166, 167, 167, 167, 167, 167,
- 168, 168, 169, 169, 170, 170, 170, 170, 170, 170,
- 170, 170, 170, 170, 170, 171, 171, 171, 171, 171,
- 172, 172, 173, 174, 174, 175, 175, 176, 176, 177,
- 177, 178, 178, 179, 179, 180, 180, 181, 182, 182,
- 183, 183, 185, 184, 187, 186, 188, 188, 189, 189,
- 191, 190, 192, 192, 193, 194, 195, 195, 196, 196,
- 197, 197, 198, 198, 199, 199, 201, 200, 202, 202,
- 202, 202, 203, 203, 204, 204, 206, 205, 207, 205,
- 208, 205, 209, 205, 210, 205, 211, 205, 212, 212,
- 213, 213, 214, 214, 214, 214, 214, 214, 215, 216,
- 216, 216, 216, 217, 217, 218, 218, 218, 219, 219,
- 220, 220, 220, 221, 221, 221, 221, 221, 221, 222,
- 222, 222, 222, 222, 222, 223, 224, 224, 225, 225,
- 226, 226, 226, 226, 226, 226, 226, 226, 226, 226,
- 226, 227, 227, 228, 228, 229, 229, 230, 230, 231,
- 231, 231, 231, 231, 231, 232, 232, 233, 234, 234,
- 234, 234, 234, 234, 235, 235, 236, 236, 237, 238,
- 238, 239, 239, 239, 240, 240, 241, 241, 242, 242,
- 242, 243, 243, 244, 244, 244, 244, 244, 244, 244,
- 245, 245, 246, 246, 247, 247, 247, 247, 247, 248,
- 248, 248, 249, 249, 250, 250, 251, 251, 252, 252,
- 252, 253, 253, 253, 253, 254, 254, 255, 255, 256,
- 256, 258, 257, 259, 260, 260, 261, 261, 262, 262,
- 262, 263, 264, 264, 265, 265, 265, 266, 266, 267,
- 267, 269, 270, 268, 268, 268, 268, 268, 268, 268,
- 268, 268, 268, 268, 268, 268, 268, 268, 268, 271,
- 271, 272, 272, 273, 273, 273, 273, 273, 273, 273,
- 273, 273, 273, 273, 273, 273, 274, 274, 275, 275,
- 276, 276, 277, 277, 278, 278, 279, 279, 280, 280,
- 280, 280, 280, 280, 280, 280, 280, 280, 280, 280,
- 281, 281, 281, 281, 281, 281, 281, 281, 281, 281,
- 281, 281, 282, 282, 283, 283, 284, 284, 285, 285,
- 286, 286, 287, 288, 288, 290, 291, 289, 292, 292,
- 293, 293, 295, 294, 294, 296, 296, 297, 297, 298,
- 298, 299, 299, 300, 300, 301, 301, 301, 301, 302,
- 302, 303, 303, 304, 304, 304, 304, 304, 304, 304,
- 304, 304, 304, 304, 305, 305, 305, 305, 305, 305,
- 305, 305, 305, 305, 305, 305, 305, 305, 306, 307,
- 308, 309, 310, 311, 312, 313, 314, 315, 316, 317,
- 317, 318, 318, 319, 319, 320, 320, 320, 321, 321,
- 322, 322, 322, 323, 324, 325, 325, 326, 326, 327,
- 327, 328, 328, 329, 329, 330, 330, 331, 331, 332,
- 333, 334, 335, 336, 337, 338, 339, 341, 340, 342,
- 342
-};
-
-static const short yyr2[] = { 0,
- 3, 0, 6, 0, 2, 5, 5, 3, 3, 3,
- 3, 0, 3, 1, 3, 1, 1, 4, 4, 4,
- 3, 2, 3, 4, 2, 0, 1, 1, 3, 1,
- 1, 4, 4, 4, 3, 4, 3, 0, 2, 0,
- 1, 3, 3, 3, 0, 3, 0, 4, 0, 4,
- 5, 0, 2, 0, 3, 0, 1, 6, 1, 2,
- 1, 2, 1, 1, 1, 2, 3, 3, 0, 1,
- 2, 3, 1, 5, 1, 3, 1, 2, 1, 3,
- 5, 1, 3, 1, 1, 1, 3, 5, 3, 4,
- 4, 4, 6, 4, 3, 5, 6, 8, 6, 5,
- 1, 1, 3, 3, 0, 2, 5, 0, 2, 4,
- 1, 3, 1, 3, 3, 2, 4, 6, 6, 6,
- 1, 1, 1, 1, 3, 3, 3, 5, 6, 5,
- 2, 3, 3, 1, 1, 8, 8, 8, 8, 1,
- 0, 2, 5, 2, 3, 1, 3, 1, 1, 1,
- 2, 1, 3, 2, 3, 1, 3, 1, 1, 3,
- 1, 1, 0, 2, 0, 2, 0, 2, 1, 3,
- 0, 4, 2, 4, 2, 3, 1, 3, 3, 3,
- 0, 2, 1, 3, 5, 7, 0, 5, 5, 3,
- 5, 3, 0, 2, 1, 3, 0, 4, 0, 4,
- 0, 4, 0, 3, 0, 3, 0, 3, 1, 3,
- 1, 3, 1, 1, 1, 1, 1, 1, 4, 6,
- 4, 8, 6, 5, 3, 0, 4, 4, 6, 4,
- 0, 4, 4, 1, 4, 5, 2, 3, 5, 1,
- 4, 5, 2, 3, 5, 2, 5, 1, 1, 3,
- 6, 4, 5, 5, 5, 4, 4, 3, 3, 1,
- 0, 0, 1, 1, 3, 1, 3, 1, 3, 1,
- 1, 1, 1, 1, 0, 6, 4, 5, 5, 3,
- 7, 5, 8, 6, 6, 4, 6, 4, 2, 1,
- 3, 1, 3, 4, 1, 2, 2, 1, 1, 3,
- 2, 1, 5, 1, 1, 2, 3, 3, 6, 1,
- 1, 2, 1, 3, 2, 4, 1, 3, 3, 3,
- 2, 1, 1, 3, 3, 1, 1, 3, 0, 1,
- 3, 5, 4, 4, 1, 3, 1, 1, 3, 1,
- 3, 0, 3, 2, 1, 2, 3, 4, 4, 4,
- 0, 2, 2, 1, 5, 3, 1, 1, 3, 2,
- 1, 0, 0, 6, 6, 6, 6, 6, 6, 3,
- 2, 3, 2, 3, 2, 3, 2, 3, 1, 2,
- 1, 2, 1, 1, 1, 1, 3, 4, 4, 1,
- 1, 1, 1, 3, 1, 2, 1, 3, 1, 3,
- 2, 1, 2, 1, 2, 1, 2, 1, 1, 1,
- 3, 1, 1, 2, 5, 3, 5, 3, 2, 2,
- 1, 1, 3, 1, 1, 2, 5, 3, 5, 3,
- 2, 2, 5, 2, 1, 3, 2, 3, 1, 3,
- 7, 5, 5, 1, 3, 0, 0, 4, 2, 0,
- 1, 3, 0, 3, 0, 2, 3, 4, 3, 0,
- 1, 3, 1, 1, 3, 1, 1, 2, 2, 1,
- 2, 1, 1, 1, 3, 1, 1, 2, 5, 3,
- 5, 3, 2, 2, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 3, 2, 3, 2, 1, 1,
- 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 1, 1, 1, 1, 3, 1, 1, 3, 1, 3,
- 1, 1, 1, 1, 1, 1, 3, 1, 3, 1,
- 3, 1, 3, 1, 1, 1, 3, 1, 2, 1,
- 1, 1, 1, 2, 1, 0, 1, 0, 2, 1,
- 1
-};
-
-static const short yydefact[] = { 163,
- 165, 0, 4, 0, 0, 164, 0, 506, 1, 546,
- 0, 166, 543, 187, 175, 5, 167, 167, 545, 12,
- 0, 0, 193, 0, 169, 193, 548, 544, 0, 2,
- 546, 171, 547, 207, 203, 205, 261, 0, 195, 11,
- 168, 9, 261, 10, 0, 8, 526, 542, 0, 0,
- 14, 16, 17, 0, 188, 181, 181, 0, 201, 0,
- 197, 0, 199, 0, 528, 505, 485, 486, 487, 488,
- 489, 490, 491, 492, 493, 494, 508, 507, 425, 509,
- 501, 500, 504, 502, 503, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 211, 213, 214, 215, 216, 217,
- 218, 0, 260, 342, 397, 406, 408, 424, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 422, 421, 532,
- 194, 170, 548, 551, 550, 549, 521, 524, 525, 0,
- 523, 522, 13, 0, 0, 22, 546, 499, 193, 0,
- 183, 0, 193, 548, 172, 26, 0, 519, 0, 208,
- 209, 513, 512, 514, 0, 204, 0, 206, 0, 0,
- 0, 0, 0, 262, 0, 0, 0, 496, 0, 498,
- 261, 6, 0, 0, 0, 0, 0, 413, 0, 407,
- 412, 410, 409, 530, 0, 326, 0, 0, 311, 0,
- 311, 0, 0, 541, 540, 0, 0, 0, 310, 246,
- 0, 248, 295, 299, 304, 305, 226, 0, 0, 405,
- 404, 0, 524, 426, 0, 399, 402, 0, 410, 0,
- 0, 431, 0, 477, 0, 0, 463, 464, 467, 466,
- 476, 474, 470, 432, 473, 472, 0, 0, 196, 7,
- 527, 15, 507, 21, 0, 0, 0, 337, 340, 3,
- 275, 182, 190, 0, 275, 192, 0, 0, 27, 173,
- 202, 0, 0, 0, 198, 200, 495, 0, 0, 0,
- 263, 0, 0, 259, 258, 497, 212, 0, 0, 49,
- 292, 302, 305, 0, 0, 343, 351, 345, 0, 0,
- 398, 419, 0, 0, 414, 0, 410, 420, 0, 327,
- 0, 0, 0, 312, 538, 0, 538, 0, 0, 0,
- 231, 240, 289, 0, 0, 306, 0, 0, 301, 298,
- 305, 546, 225, 0, 403, 533, 401, 428, 0, 0,
- 529, 0, 468, 469, 483, 0, 524, 478, 0, 474,
- 484, 430, 0, 0, 0, 471, 0, 336, 338, 423,
- 18, 20, 19, 0, 0, 268, 274, 270, 271, 272,
- 273, 0, 0, 0, 0, 0, 184, 0, 548, 25,
- 0, 28, 30, 31, 0, 0, 515, 520, 210, 0,
- 0, 0, 264, 266, 256, 257, 0, 152, 0, 0,
- 0, 252, 0, 296, 0, 0, 0, 395, 0, 362,
- 546, 0, 0, 0, 0, 0, 0, 0, 352, 358,
- 361, 379, 381, 390, 391, 392, 393, 386, 384, 385,
- 346, 357, 546, 344, 0, 418, 531, 416, 0, 0,
- 411, 325, 0, 0, 0, 221, 313, 317, 0, 539,
- 219, 0, 541, 0, 243, 0, 292, 305, 546, 230,
- 0, 308, 307, 0, 300, 297, 261, 261, 226, 0,
- 400, 0, 482, 480, 0, 0, 462, 465, 475, 0,
- 0, 341, 275, 189, 0, 38, 0, 0, 0, 0,
- 47, 0, 0, 191, 23, 0, 0, 0, 0, 174,
- 255, 254, 0, 253, 0, 0, 0, 0, 49, 59,
- 57, 0, 0, 0, 293, 360, 437, 439, 0, 516,
- 519, 524, 434, 0, 0, 357, 0, 511, 510, 517,
- 396, 0, 261, 261, 0, 534, 535, 371, 373, 375,
- 377, 0, 0, 0, 380, 0, 0, 261, 261, 347,
- 0, 0, 328, 0, 0, 0, 0, 315, 0, 0,
- 0, 231, 234, 244, 0, 0, 296, 329, 329, 0,
- 0, 290, 0, 249, 548, 224, 429, 427, 0, 0,
- 339, 269, 56, 0, 40, 280, 0, 0, 0, 52,
- 0, 226, 0, 185, 29, 35, 0, 0, 0, 24,
- 0, 0, 177, 0, 0, 265, 267, 0, 153, 294,
- 251, 60, 0, 61, 0, 0, 0, 446, 460, 438,
- 0, 387, 0, 0, 0, 363, 354, 0, 548, 546,
- 370, 383, 372, 374, 376, 378, 0, 359, 394, 356,
- 0, 548, 348, 417, 415, 318, 319, 314, 0, 223,
- 322, 220, 0, 237, 0, 0, 229, 0, 293, 241,
- 0, 0, 0, 0, 330, 335, 422, 548, 0, 247,
- 0, 261, 227, 228, 481, 479, 0, 0, 277, 38,
- 0, 0, 40, 38, 45, 0, 54, 288, 75, 0,
- 286, 47, 0, 32, 34, 33, 176, 0, 0, 0,
- 303, 48, 62, 63, 64, 0, 439, 440, 0, 444,
- 0, 461, 0, 518, 435, 0, 388, 389, 0, 353,
- 0, 0, 455, 455, 382, 0, 0, 349, 350, 316,
- 321, 0, 323, 0, 238, 0, 0, 0, 242, 245,
- 0, 262, 0, 0, 232, 233, 309, 291, 250, 56,
- 0, 0, 282, 0, 39, 41, 37, 0, 0, 279,
- 0, 278, 52, 0, 0, 0, 46, 226, 186, 178,
- 179, 180, 65, 0, 0, 0, 460, 443, 446, 447,
- 442, 0, 433, 0, 0, 0, 0, 451, 453, 548,
- 0, 355, 320, 0, 222, 0, 536, 0, 235, 0,
- 0, 0, 331, 276, 55, 284, 84, 0, 82, 85,
- 0, 36, 38, 0, 287, 53, 0, 76, 285, 69,
- 66, 70, 0, 0, 0, 439, 0, 445, 450, 436,
- 364, 365, 366, 455, 368, 0, 369, 367, 324, 236,
- 0, 239, 0, 333, 334, 43, 0, 42, 0, 281,
- 44, 50, 0, 86, 0, 0, 67, 73, 0, 0,
- 71, 77, 0, 58, 441, 0, 448, 452, 0, 0,
- 454, 351, 537, 332, 83, 283, 0, 51, 0, 0,
- 0, 141, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 72,
- 102, 101, 134, 135, 0, 78, 79, 449, 351, 0,
- 456, 87, 0, 89, 68, 0, 0, 0, 0, 0,
- 150, 0, 0, 0, 140, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 131, 0, 0, 0,
- 457, 459, 0, 0, 0, 0, 142, 0, 0, 0,
- 0, 0, 0, 0, 0, 151, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 95, 0, 0, 113,
- 0, 125, 126, 127, 0, 0, 0, 132, 133, 0,
- 80, 458, 88, 74, 0, 90, 0, 0, 123, 124,
- 116, 0, 0, 0, 0, 0, 91, 0, 154, 0,
- 156, 158, 92, 0, 0, 0, 0, 94, 144, 149,
- 0, 146, 148, 0, 0, 0, 0, 0, 0, 161,
- 162, 0, 159, 69, 0, 0, 105, 108, 0, 0,
- 0, 0, 0, 100, 0, 155, 0, 0, 0, 0,
- 0, 145, 0, 96, 0, 114, 115, 128, 0, 130,
- 0, 81, 0, 0, 0, 0, 97, 117, 0, 0,
- 0, 93, 157, 0, 0, 0, 0, 147, 99, 129,
- 160, 143, 0, 0, 111, 106, 103, 141, 0, 109,
- 104, 0, 0, 0, 0, 0, 0, 0, 0, 98,
- 0, 0, 0, 121, 122, 118, 119, 120, 0, 0,
- 0, 0, 0, 112, 0, 136, 137, 138, 139, 0,
- 110, 107, 0, 0, 0
-};
-
-static const short yydefgoto[] = { 1103,
- 9, 54, 10, 16, 30, 50, 51, 259, 260, 371,
- 372, 576, 672, 745, 746, 752, 582, 392, 678, 755,
- 669, 503, 504, 606, 696, 765, 847, 815, 850, 680,
- 854, 896, 897, 798, 799, 843, 844, 890, 1019, 1045,
- 1066, 1046, 1070, 1067, 959, 960, 945, 1086, 981, 891,
- 917, 907, 937, 957, 1001, 1002, 912, 389, 950, 990,
- 1011, 1012, 1013, 1, 2, 3, 4, 23, 24, 25,
- 58, 145, 6, 490, 592, 593, 139, 140, 141, 7,
- 21, 55, 37, 38, 39, 155, 157, 147, 62, 64,
- 60, 150, 94, 95, 96, 97, 98, 323, 99, 450,
- 552, 311, 100, 200, 563, 564, 272, 382, 383, 355,
- 356, 357, 358, 359, 360, 361, 186, 561, 992, 281,
- 319, 202, 203, 282, 187, 436, 437, 640, 722, 188,
- 301, 654, 655, 102, 348, 247, 103, 174, 286, 287,
- 288, 424, 289, 616, 702, 422, 410, 411, 522, 709,
- 412, 621, 413, 104, 215, 216, 217, 105, 106, 211,
- 107, 414, 706, 415, 698, 416, 417, 699, 700, 701,
- 819, 857, 777, 778, 826, 861, 862, 703, 226, 227,
- 228, 229, 617, 230, 418, 142, 109, 110, 111, 112,
- 113, 114, 11, 162, 116, 117, 517, 151, 152, 518,
- 153, 154, 131, 132, 419, 118, 420, 119, 528, 786,
- 304, 205, 641, 184, 14, 17, 18, 19, 40, 44,
- 45, 126
-};
-
-static const short yypact[] = {-32768,
--32768, 35, 61, 35, 113,-32768, 163,-32768,-32768,-32768,
- 113,-32768,-32768,-32768,-32768,-32768, 232, 232, 275, 287,
- 346, 113, 470, 612,-32768, 747, 312,-32768, 546,-32768,
--32768,-32768,-32768, 454, 466, 490, 1745, 353,-32768,-32768,
- 232,-32768, 1745,-32768, 314,-32768,-32768,-32768, 194, 165,
--32768,-32768, 338, 482,-32768, 458, 458, 35,-32768, 74,
--32768, 74,-32768, 74,-32768,-32768,-32768,-32768,-32768,-32768,
--32768,-32768,-32768,-32768,-32768, 467,-32768,-32768,-32768,-32768,
--32768,-32768,-32768,-32768,-32768, 372, 301, 301, 564, 301,
- 555, 567, 609, 661,-32768,-32768,-32768,-32768,-32768,-32768,
--32768, 605,-32768, 74,-32768, 2552,-32768,-32768, 295, 564,
- 295, 1056, 295, 2552, 1171, 2358, 2587, 404,-32768,-32768,
- 747,-32768, 623,-32768,-32768,-32768,-32768,-32768,-32768, 627,
--32768,-32768,-32768, 546, 755,-32768,-32768,-32768, 747, 667,
--32768, 113, 747, 637,-32768, 221, 74,-32768, 687, 640,
--32768,-32768,-32768,-32768, 74, 640, 74, 640, 679, 564,
- 694, 194, 672, 709, 301, 647, 669,-32768, 744,-32768,
- 1745,-32768, 1011, 691, 2475, 2405, 1455,-32768, 2587,-32768,
--32768, 758,-32768,-32768, 564,-32768, 782, 778, 811, 807,
- 811, 809, 409, 811,-32768, 831, 1011, 441,-32768,-32768,
- 829,-32768,-32768, 857,-32768, 1097, 296, 852, 811, 2552,
--32768, 870, 2552,-32768, 283,-32768, 2552, 877, 146, 731,
- 2440,-32768, 1572,-32768, 2587, 883, 559,-32768, 2587,-32768,
--32768, 887,-32768,-32768,-32768,-32768, 408, 2587,-32768,-32768,
--32768,-32768, 903,-32768, 886, 906, 735, 902,-32768,-32768,
- 321, 458,-32768, 921, 321,-32768, 537, 927,-32768, 895,
- 640, 928, 931, 74, 640, 640,-32768, 1097, 409, 1011,
--32768, 874, 876,-32768,-32768,-32768,-32768, 441, 871, 29,
- 939,-32768, 1097, 2079, 2079,-32768, 930,-32768, 943, 2552,
--32768,-32768, 945, 944,-32768, 474, 159,-32768, 2587,-32768,
- 776, 1108, 564, 811, 949, 1011,-32768, 564, 1011, 711,
- 933,-32768,-32768, 971, 958,-32768, 781, 1011, 983,-32768,
--32768,-32768,-32768, 564,-32768,-32768, 2552,-32768, 2517, 2475,
--32768, 974,-32768,-32768,-32768, 960, 731,-32768, 512, 177,
--32768,-32768, 2517, 980, 2517,-32768, 2587, 962,-32768,-32768,
--32768,-32768,-32768, 355, 697,-32768,-32768,-32768,-32768,-32768,
--32768, 966, 295, 564, 295, 295,-32768, 546, 982,-32768,
- 794,-32768,-32768, 978, 546, 985,-32768,-32768,-32768, 632,
- 923, 57,-32768, 988,-32768,-32768, 827,-32768, 552, 1011,
- 633,-32768, 1011, 1097, 2138, 1925, 1374,-32768, 2629,-32768,
--32768, 2079, 851, 851, 995, 996, 1008, 2079, 74,-32768,
--32768, 2629,-32768,-32768,-32768,-32768,-32768,-32768, 984,-32768,
--32768, 128,-32768,-32768, 2079,-32768,-32768,-32768, 2517, 1013,
--32768,-32768, 564, 706, 415, 63,-32768, 719, 994,-32768,
--32768, 597,-32768, 1002,-32768, 1001, 1010, 1097,-32768,-32768,
- 1011,-32768,-32768, 1011,-32768,-32768, 2197, 2197, 989, 1015,
--32768, 1017,-32768,-32768, 2517, 1037,-32768,-32768,-32768, 408,
- 903,-32768, 321,-32768, 1011, 89, 1021, 1016, 1024, 409,
- 155, 1027, 845,-32768,-32768, 546, 786, 849, 570,-32768,
--32768,-32768, 1011,-32768, 301, 1011, 967, 1011, 998,-32768,
--32768, 1055, 633, 414,-32768,-32768,-32768, 613, 1044, 1043,
- 944, 2138,-32768, 873, 855, 128, 2079,-32768,-32768, 1045,
--32768, 2587, 2197, 2197, 1029,-32768,-32768, 2629, 2629, 2629,
- 2629, 2079, 1031, 2079,-32768, 2629, 1011, 2197, 2197, 1050,
- 1048, 1058,-32768, 1059, 1097, 1108, 568, 838, 1108, 811,
- 339, 933,-32768,-32768, 1011, 1011, 1019, 2323, 2323, 1075,
- 861,-32768, 734,-32768, 1074,-32768,-32768,-32768, 1071, 1077,
--32768,-32768, 263, 1108, 1047,-32768, 564, 1011, 564, 1038,
- 633, 989, 564, 1035,-32768,-32768, 1082, 1083, 872,-32768,
- 250, 875,-32768, 1051, 1052,-32768,-32768, 879,-32768,-32768,
--32768,-32768, 1040,-32768, 1102, 3, 2079,-32768, 2079,-32768,
- 1087,-32768, 2079, 2002, 366,-32768, 2587, 734, 1074,-32768,
- 2629,-32768, 2629, 2629, 2629,-32768, 2079,-32768,-32768, 1085,
- 734, 1074,-32768,-32768,-32768, 1097,-32768,-32768, 444,-32768,
--32768, 242, 1099,-32768, 590, 811,-32768, 891, 1098,-32768,
- 301, 301, 301, 753,-32768,-32768, 1088, 1104, 1110, 1103,
- 1011, 2197,-32768,-32768,-32768,-32768, 1011, 633,-32768, 387,
- 1105, 1064, 18, 211, 1066, 409, 1061,-32768,-32768, 181,
--32768, 1072, 985,-32768,-32768,-32768,-32768, 570, 408, 355,
--32768,-32768,-32768,-32768,-32768, 41, 476,-32768, 220,-32768,
- 2079,-32768, 1123,-32768, 1122, 1124,-32768,-32768, 1125,-32768,
- 1111, 1112, 2517, 2517,-32768, 1092, 1011,-32768,-32768, 1097,
--32768, 894,-32768, 568,-32768, 811, 811, 75,-32768,-32768,
- 1127, 709, 301, 2323,-32768,-32768,-32768,-32768,-32768, 1090,
- 1093, 568,-32768, 860, 1130,-32768,-32768, 1094, 1108,-32768,
- 1089,-32768, 1038, 113, 633, 633,-32768, 989,-32768,-32768,
--32768,-32768,-32768, 32, 477, 2079, 2079,-32768,-32768,-32768,
--32768, 2079,-32768, 2079, 2079, 2079, 756,-32768, 415, 1143,
- 2079,-32768,-32768, 564,-32768, 896,-32768, 1140,-32768, 1011,
- 1079, 1080,-32768,-32768,-32768,-32768,-32768, 420,-32768,-32768,
- 1105,-32768, 405, 1101,-32768,-32768, 43,-32768,-32768, 1150,
--32768,-32768, 826, 301, 578, 1145, 1166,-32768, 1156,-32768,
--32768,-32768,-32768, 2517,-32768, 907,-32768,-32768,-32768,-32768,
- 811,-32768, 64,-32768,-32768,-32768, 860,-32768, 568,-32768,
--32768,-32768, 261,-32768, 1162, 633,-32768,-32768, 1186, 1616,
--32768,-32768, 1178,-32768,-32768, 2079,-32768,-32768, 2079, 1175,
--32768, 930,-32768,-32768,-32768,-32768, 408,-32768, 333, 1185,
- 1197,-32768, 1189, 1616, 1191, 1207, 174, 453, 1616, 1616,
- 1193, 564, 564, 564, 564, 564, 573, 573, 113,-32768,
--32768,-32768,-32768,-32768, 860, 1188,-32768,-32768, 930, 2079,
--32768,-32768, 633,-32768,-32768, 1211, 360, 1192, 1176, 635,
--32768, 329, 113, 1196,-32768, 777, 1196, 1198, 1204, 1192,
- 564, 408, 408, 1199, 408, 1202,-32768, 570, 599, 1178,
--32768, 1050, 1206, 1218, 1225, 1616,-32768, 1201, 1216, 59,
- 1227, 1229, 573, 573, 1210,-32768, 1616, 355, 506, 1198,
- 851, 851, 981, 981, 1198, 2155,-32768, 1011, 762,-32768,
- 1212,-32768,-32768,-32768, 1011, 1217, 938,-32768,-32768, 1236,
--32768,-32768,-32768,-32768, 1213,-32768, 1616, 842,-32768,-32768,
--32768, 1237, 1238, 1239, 1241, 1616,-32768, 1196,-32768, 606,
--32768,-32768,-32768, 1235, 1240, 1243, 1244,-32768,-32768,-32768,
- 617,-32768,-32768, 1245, 1215, 1192, 1616, 1231, 1011,-32768,
--32768, 641,-32768, 1150, 1011, 1247,-32768,-32768, 1248, 59,
- 1246, 1252, 1257,-32768, 1198,-32768, 1011, 1196, 1196, 1196,
- 1196,-32768, 2214,-32768, 1616,-32768,-32768,-32768, 1249,-32768,
- 938,-32768, 1251, 1230, 665, 815,-32768,-32768, 59, 59,
- 59,-32768,-32768, 1011, 1011, 1011, 1011,-32768,-32768,-32768,
--32768,-32768, 1616, 119,-32768,-32768,-32768,-32768, 1250,-32768,
--32768, 1255, 147, 147, 147, 1254, 1260, 1265, 1266,-32768,
- 585, 1616, 1616,-32768,-32768,-32768,-32768,-32768, 1261, 1262,
- 1263, 1264, 1616,-32768, 1270,-32768,-32768,-32768,-32768, 1271,
--32768,-32768, 1269, 1293,-32768
-};
-
-static const short yypgoto[] = {-32768,
--32768,-32768,-32768, 1134,-32768,-32768, 1160,-32768,-32768, 22,
- 810, -599, 622,-32768, 496,-32768, 616, 800, 547,-32768,
- 561, -483,-32768,-32768,-32768,-32768, 290,-32768,-32768,-32768,
--32768,-32768, 375, 411, 471,-32768, 440, -290,-32768,-32768,
--32768,-32768,-32768, 264,-32768, 303,-32768, -131, -537, -785,
--32768, 243, -826, -664,-32768, 280,-32768,-32768, -777,-32768,
- -362,-32768, 273,-32768,-32768,-32768,-32768, 1297, 1301, 1279,
--32768,-32768, 65, 639,-32768, 643, 1272, 1275, 1081,-32768,
--32768,-32768, 24,-32768, 1219,-32768,-32768,-32768,-32768,-32768,
--32768, 292, 1280, 1168,-32768,-32768,-32768, -430,-32768, 789,
--32768, -247,-32768,-32768, -129, -34, 610, 553, 853, 1095,
- 882,-32768,-32768,-32768,-32768,-32768, -89, -441, 71, -78,
- -251,-32768, 34, 1232, -82, -510, 799, -666,-32768, -60,
--32768, 788, 614, -95,-32768, 881, -497,-32768,-32768,-32768,
- 819, -541, -789, 743, 10, -259,-32768, -338,-32768,-32768,
--32768, 317, 76,-32768, -105,-32768, -48,-32768,-32768, -68,
--32768,-32768, 589,-32768, 968,-32768,-32768,-32768, 594,-32768,
--32768,-32768, 652, 548,-32768,-32768, 438, 604, -117, -210,
- 1028,-32768, -63, -84, -7,-32768, -224, -207, -206,-32768,
- -199,-32768,-32768, -32,-32768,-32768,-32768, -62,-32768,-32768,
- -208, -47,-32768, 977, -29, -72, 1022,-32768, -397,-32768,
- 729, -168, -103, 779, -10, -25, 4,-32768, -20, -17,
--32768,-32768
-};
-
-
-#define YYLAST 2740
-
-
-static const short yytable[] = { 52,
- 20, 130, 101, 42, 115, 56, 529, 193, 101, 46,
- 115, 32, 339, 163, 164, 165, 380, 167, 345, 603,
- 305, 381, 307, 207, 409, 313, 363, 190, 566, 108,
- 363, 394, 235, 201, 57, 108, 860, 180, 642, 246,
- 313, 175, 810, 364, 365, 47, 546, 364, 365, 43,
- 192, 366, 208, 234, 598, 366, 506, 785, 293, 390,
- 656, 656, 248, 670, 673, 210, 49, 218, 12, 291,
- 743, 296, 694, 172, 750, 796, 182, 195, 127, 148,
- 128, 938, 493, 695, 182, 219, 232, 232, 5, 493,
- 671, 546, 273, 961, 235, 300, 391, 679, 181, 789,
- 149, 926, 927, 336, 52, 240, 181, 181, 231, 231,
- 763, 842, 8, 648, 218, 298, 13, 764, 574, 253,
- 811, 975, 146, 127, 294, 128, 256, 547, 979, 130,
- 345, 254, 127, 148, 128, 440, 101, 516, 115, 955,
- 235, 325, 860, 494, 235, 182, 232, 297, 325, 232,
- 864, 681, 330, 235, 149, 362, 575, 984, 985, 362,
- 537, 341, 251, 108, 327, 346, 255, 181, 231, 181,
- 1000, 231, 866, 506, 350, 130, 980, 48, 248, 961,
- 182, 299, 248, 182, 741, -326, 548, 182, 519, 133,
- 134, 232, 129, 340, 299, 232, 557, 471, 127, 232,
- 128, 379, 181, 840, 442, 181, 756, 349, 232, 181,
- 1025, 460, 347, 231, 235, 231, 1084, 231, 1069, 1069,
- 439, 231, 581, 435, 461, 467, 545, 373, 330, 15,
- 231, 447, 580, 330, 459, 431, 656, 129, 803, 320,
- 749, 327, 768, 280, 257, 769, 129, 1000, 363, 757,
- 1054, 1055, 1056, 1057, 127, 294, 128, 615, 325, 1068,
- 182, 480, 235, 1085, 332, 364, 365, 315, 317, 232,
- 546, 807, 808, 366, 628, 258, 481, 430, 575, 913,
- 476, 478, 181, 469, 22, 993, 867, 127, 148, 128,
- 998, 231, 28, 667, 421, 466, 457, 182, 48, 232,
- 182, 320, 477, 65, 479, 482, 724, 328, 329, 149,
- 29, 541, 129, 232, 124, 232, 320, 232, 185, 181,
- 901, 231, 181, 65, 78, 458, -326, 809, 565, 868,
- 668, 946, 41, 125, 474, 231, 322, 231, 373, 231,
- 384, 195, 48, 543, 78, 373, 534, 569, 387, 130,
- 903, 484, 456, 156, 628, 158, 947, 931, 48, 534,
- 1052, 135, 870, 644, 81, 82, 83, 84, 129, 136,
- 127, 148, 128, 121, 65, 523, 441, 362, 471, 444,
- 446, 643, 645, 935, 720, 904, 31, 936, 455, 483,
- 708, 588, 149, 618, 619, 78, 488, 538, 330, 232,
- 248, 129, 500, 501, 524, 508, 515, 502, 631, 632,
- 47, 525, 48, 456, 248, 546, 160, 533, 161, 933,
- 148, 231, 597, 558, 115, 115, 539, 456, 753, 237,
- 309, 49, 310, 546, 540, 232, -337, 235, 261, 238,
- 571, 344, 836, 195, 48, 837, 265, 48, 266, 108,
- 108, 742, 559, 614, 575, 915, 373, 231, 196, 594,
- 499, 59, 197, 505, 278, 316, 637, 435, 721, 839,
- 435, 320, 575, 61, 521, 676, 916, 307, 127, 148,
- 128, 320, 1048, 604, 129, 657, 657, 535, 33, 605,
- 115, 115, 232, 682, 674, 435, 435, 63, 428, 429,
- 149, 766, 779, 779, 387, 115, 115, 767, 195, 48,
- 138, 1073, 1074, 1075, 231, 108, 108, 148, 34, 35,
- 36, 560, 137, 196, 562, 115, 115, 197, 989, 278,
- 108, 108, 235, 279, 199, 723, 464, 465, 344, 47,
- 48, 626, 663, 130, 159, 573, 812, 664, 47, 48,
- 108, 108, 534, 994, 995, 813, 814, 787, 788, 440,
- 49, 370, 168, 384, 148, 534, 562, 48, 600, 49,
- 345, 48, 47, 48, 169, 47, 48, 497, 731, 732,
- 733, 456, 498, 909, 343, 344, 991, 232, 918, 919,
- 456, 639, 129, 591, 713, 1004, 591, 711, 279, 199,
- 48, 712, 1008, 622, 622, 622, 622, 630, 935, 231,
- 718, 629, 1093, 779, 719, 726, 697, 727, 550, 170,
- 551, 970, 705, 714, 837, 562, 649, 739, 1026, 115,
- 33, 1027, 41, 735, 195, 48, 716, 173, 607, 1032,
- 736, 608, 1033, 171, 609, 976, 1039, 852, 675, 196,
- 853, 241, 1043, 197, 108, 278, 987, 252, 594, 761,
- 792, 657, 863, 1040, 1053, 264, 1041, 47, 48, 320,
- 435, 882, 883, 884, 885, 886, 887, 888, 889, 33,
- 829, 171, 267, 232, 232, 33, 1016, 252, 1064, 262,
- 263, 1076, 1077, 1078, 1079, 1024, 715, 269, 715, 715,
- 715, 115, 500, 501, 270, 231, 231, 502, 195, 48,
- 770, 544, 271, 195, 48, 33, 1037, 473, 491, 284,
- 285, 195, 48, 196, -305, 199, 108, 197, 196, 278,
- 316, 738, 197, 274, 278, 445, 196, 740, 333, 334,
- 197, 851, 278, 806, 1059, -305, 940, 941, 942, 943,
- 944, 276, 33, 456, 662, 275, 825, 65, 48, 353,
- 354, 1065, 827, 882, 883, 884, 885, 886, 887, 888,
- 889, 33, 1080, 734, 33, 816, 824, 845, 243, 244,
- 1005, 705, 1006, 821, 822, 823, 245, 782, 65, 48,
- 828, 1094, 1095, 299, 232, 34, 35, 36, 279, 199,
- 432, 433, 1100, 279, 199, 453, 454, 53, 303, 243,
- 586, 302, 199, 195, 800, 120, 231, 587, 485, 486,
- 893, 120, 67, 68, 69, 70, 71, 72, 73, 74,
- 75, 76, 951, 952, 953, 954, 306, 845, 935, 308,
- 195, 48, 892, -296, 893, 623, 624, 625, 314, 893,
- 893, 453, 496, 526, 527, 196, 318, 893, 893, 197,
- 384, 278, 195, 48, -296, 898, 892, 166, 899, 584,
- 486, 892, 892, 590, 486, 611, 263, 196, 928, 612,
- 613, 197, 324, 278, -302, 660, 661, 189, 191, 194,
- 206, 209, 963, 964, 326, 966, 686, 354, 968, 687,
- 688, 331, 948, 691, 661, 342, 893, 800, 294, 932,
- 351, 1065, 53, 893, 893, 729, 661, 893, 783, 784,
- 830, 831, 347, 91, 92, 93, 893, 237, 892, 797,
- 352, 199, 848, 849, 859, 284, 1017, 1018, 268, 892,
- 195, 48, 1087, 1088, 368, 996, 997, 893, 1003, 120,
- 375, 283, 279, 199, 377, 196, 893, 378, 376, 197,
- 385, 278, 386, 209, 388, 800, 393, 426, 427, 892,
- 423, 312, 425, 449, 451, 283, 283, 893, 892, -289,
- 452, 462, 463, 263, 321, 195, 48, 470, 67, 68,
- 69, 70, 71, 72, 73, 74, 75, 76, 475, 892,
- 196, 487, 473, 893, 197, 893, 278, 1010, 489, 492,
- -296, 530, 531, 195, 48, 893, 130, 495, 532, 536,
- 542, 195, 48, 549, 554, 1003, 555, 892, 196, 322,
- 279, 199, 197, 893, 278, 374, 196, 556, 1072, 567,
- 197, 568, 278, 650, 570, 578, 321, 312, 283, 195,
- 48, 577, 893, 893, 579, 892, 283, 583, 195, 48,
- 599, 321, 602, 893, 196, 391, 610, -521, 197, -522,
- 434, 620, 634, 196, 892, 892, 199, 197, 284, 198,
- 438, 191, 635, 636, 283, 892, 443, 283, 448, 91,
- 92, 93, 627, 659, 662, 665, 283, 321, 683, 195,
- 48, 666, 209, 279, 199, 677, 684, 685, 692, 693,
- 195, 48, 199, 704, 196, 717, 689, 690, 197, 671,
- 278, 725, 730, 238, 734, 196, 744, 183, 737, 197,
- -303, 434, 747, 751, 754, 183, 183, 233, 236, 581,
- 199, 189, 191, 194, 209, 771, 374, 772, 773, 199,
- 775, 776, 774, 374, 781, 801, 249, 668, 321, 790,
- 804, 795, 802, 824, 832, 834, 835, 846, 283, 841,
- 766, 283, 321, 47, 48, 127, 212, 213, 67, 68,
- 69, 70, 71, 72, 73, 74, 75, 76, 855, 856,
- 199, 869, 176, 871, 177, 214, 183, 233, 183, 895,
- 236, 199, 900, 905, 906, 178, 908, 179, 910, 911,
- 920, 209, 283, 930, 934, 935, 321, 949, 939, 956,
- 553, 958, 965, 967, 973, 974, 321, 975, 986, 283,
- 977, 183, 283, 978, 183, 120, 120, 982, 183, 983,
- 1009, 1007, 233, 1014, 233, 1015, 236, 1020, 1021, 1022,
- 236, 1023, 1028, 283, 1035, 1038, 1049, 1029, 312, 236,
- 1030, 1031, 1050, 1034, 374, 1044, 1047, 1051, 1104, 1063,
- 250, 283, 1089, 1060, 283, 1062, 283, 1082, 1090, 91,
- 92, 93, 1083, 1091, 1092, 1096, 1097, 1098, 1099, 129,
- 1101, 1102, 1105, 242, 748, 585, 838, 758, 601, 805,
- 794, 120, 120, 1042, 971, 929, 902, 865, 1036, 1071,
- 1081, 183, 1058, 1061, 26, 283, 120, 120, 27, 122,
- 236, 759, 123, 283, 438, 443, 321, 438, 143, 646,
- 760, 144, 367, 283, 283, 321, 120, 120, 277, 239,
- 647, 791, 833, 204, 638, 596, 658, 793, 183, 369,
- 233, 183, 438, 438, 572, 191, 283, 443, 633, 710,
- 820, 209, 818, 509, 233, 780, 233, 589, 236, 972,
- 817, 858, 468, 520, 728, 472, 47, 48, 510, 511,
- 512, 67, 68, 69, 70, 71, 72, 73, 74, 75,
- 76, 0, 0, 0, 0, 396, 0, 397, 513, 0,
- 514, 0, 0, 0, 0, 0, 0, 0, 398, 0,
- 399, 400, 401, 0, 321, 402, 0, 443, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 403,
- 404, 405, 406, 407, 408, 0, 0, 0, 0, 283,
- 120, 0, 0, 0, 0, 283, 0, 0, 0, 0,
- 233, 0, 0, 0, 312, 0, 0, 47, 48, 127,
- 294, 213, 67, 68, 69, 70, 71, 72, 73, 74,
- 75, 76, 0, 0, 0, 0, 176, 0, 177, 295,
- 0, 0, 91, 92, 93, 0, 233, 0, 0, 178,
- 0, 179, 129, 0, 0, 283, 0, 0, 321, 0,
- 0, 0, 443, 0, 0, 0, 0, 0, 249, 0,
- 595, 0, 120, 0, 0, 0, 0, 0, 0, 0,
- 443, 0, 283, 0, 0, 0, 0, 438, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 236, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 443, 91, 92, 93, 0, 0, 283, 0,
- 0, 0, 0, 129, 47, 48, 127, 294, 337, 67,
- 68, 69, 70, 71, 72, 73, 74, 75, 76, 0,
- 0, 0, 0, 221, 0, 223, 338, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 224, 0, 225, 0,
- 0, 0, 0, 0, 0, 283, 0, 443, 47, 48,
- 0, 0, 0, 67, 68, 69, 70, 71, 72, 73,
- 74, 75, 76, 0, 0, 0, 0, 0, 236, 591,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 872, 873, 0, 0, 874, 0, 0,
- 921, 922, 923, 924, 925, 0, 0, 0, 0, 0,
- 0, 0, 0, 283, 0, 875, 0, 0, 0, 0,
- 91, 92, 93, 0, 0, 0, 0, 0, 0, 0,
- 129, 0, 0, 0, 0, 0, 0, 0, 0, 962,
- 0, 0, 0, 876, 877, 878, 879, 880, 0, 595,
- 0, 762, 0, 881, 882, 883, 884, 885, 886, 887,
- 888, 889, 0, 0, 91, 92, 93, 283, 0, 0,
- 0, 0, 0, 0, 233, 233, 283, 0, 0, 0,
- 0, 0, 0, 283, 0, 283, 0, 65, 48, 0,
- 0, 66, 67, 68, 69, 70, 71, 72, 73, 74,
- 75, 76, 0, 0, 0, 0, 77, 0, 78, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 79,
- 0, 80, 0, 0, 0, 0, 0, 283, 81, 82,
- 83, 84, 85, 283, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 283, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 283,
- 0, 0, 0, 0, 0, 0, 86, 87, 88, 89,
- 90, 0, 283, 283, 283, 283, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 233, 0, 0, 0, 0,
- 0, 0, 0, 91, 92, 93, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 894, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 894, 0, 0, 914, 0,
- 894, 894, 0, 0, 0, 0, 0, 0, 894, 894,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 47, 48, 0,
- 0, 395, 67, 68, 69, 70, 71, 72, 73, 74,
- 75, 76, 0, 0, 0, 0, 396, 507, 397, 969,
- 0, 0, 0, 0, 0, 0, 0, 894, 0, 398,
- 0, 399, 400, 401, 894, 894, 402, 0, 894, 988,
- 0, 0, 0, 0, 0, 0, 0, 894, 0, 0,
- 403, 404, 405, 406, 407, 408, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 894, 0,
- 0, 0, 0, 0, 47, 48, 0, 894, 395, 67,
- 68, 69, 70, 71, 72, 73, 74, 75, 76, 0,
- 0, 0, 0, 396, 0, 397, 707, 0, 894, 0,
- 0, 0, 0, 91, 92, 93, 398, 0, 399, 400,
- 401, 0, 0, 402, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 894, 0, 894, 403, 404, 405,
- 406, 407, 408, 0, 0, 0, 894, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 47, 48, 0, 894, 395, 67, 68, 69, 70,
- 71, 72, 73, 74, 75, 76, 0, 0, 0, 0,
- 396, 0, 397, 894, 894, 0, 0, 0, 0, 0,
- 91, 92, 93, 398, 894, 399, 400, 401, 0, 0,
- 402, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 403, 404, 405, 406, 407, 408,
- 47, 48, 0, 0, 0, 67, 68, 69, 70, 71,
- 72, 73, 74, 75, 76, 0, 0, 47, 48, 396,
- 0, 397, 67, 68, 69, 70, 71, 72, 73, 74,
- 75, 76, 398, 0, 399, 400, 401, 999, 591, 402,
- 0, 0, 0, 0, 0, 0, 0, 91, 92, 93,
- 0, 0, 0, 403, 404, 405, 406, 407, 408, 65,
- 48, 0, 0, 66, 67, 68, 69, 70, 71, 72,
- 73, 74, 75, 76, 0, 0, 47, 48, 77, 0,
- 78, 67, 68, 69, 70, 71, 72, 73, 74, 75,
- 76, 79, 0, 80, 0, 0, 0, 591, 0, 0,
- 0, 0, 0, 0, 0, 0, 91, 92, 93, 0,
- 0, 0, 0, 882, 883, 884, 885, 886, 887, 888,
- 889, 0, 0, 91, 92, 93, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 86, 87,
- 88, 89, 90, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 91, 92, 93, 0, 0,
- 0, 0, 882, 883, 884, 885, 886, 887, 888, 889,
- 0, 0, 91, 92, 93, 65, 48, 0, 0, 66,
- 67, 68, 69, 70, 71, 72, 73, 74, 75, 76,
- 0, 0, 0, 0, 77, 0, 78, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 79, 0, 80,
- 47, 48, 0, 0, 220, 67, 68, 69, 70, 71,
- 72, 73, 74, 75, 76, 0, 0, 0, 0, 221,
- 222, 223, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 224, 0, 225, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 651, 652, 653, 47, 48, 0,
- 0, 220, 67, 68, 69, 70, 71, 72, 73, 74,
- 75, 76, 0, 0, 0, 0, 221, 292, 223, 0,
- 0, 91, 92, 93, 0, 0, 0, 0, 0, 224,
- 0, 225, 47, 48, 0, 0, 220, 67, 68, 69,
- 70, 71, 72, 73, 74, 75, 76, 0, 0, 0,
- 0, 221, 335, 223, 0, 0, 91, 92, 93, 0,
- 0, 0, 0, 0, 224, 0, 225, 47, 48, 0,
- 0, 290, 67, 68, 69, 70, 71, 72, 73, 74,
- 75, 76, 0, 0, 0, 0, 176, 0, 177, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 178,
- 0, 179, 0, 91, 92, 93, 0, 0, 0, 47,
- 48, 0, 0, 220, 67, 68, 69, 70, 71, 72,
- 73, 74, 75, 76, 0, 0, 0, 0, 221, 0,
- 223, 0, 0, 0, 0, 0, 0, 0, 91, 92,
- 93, 224, 0, 225, 47, 48, 0, 0, 0, 67,
- 68, 69, 70, 71, 72, 73, 74, 75, 76, 0,
- 0, 0, 0, 176, 0, 177, 0, 0, 0, 0,
- 0, 0, 0, 91, 92, 93, 178, 0, 179, 47,
- 48, 0, 0, 0, 67, 68, 69, 70, 71, 72,
- 73, 74, 75, 76, 0, 0, 0, 0, 221, 0,
- 223, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 224, 0, 225, 0, 91, 92, 93, 0, 0,
- 0, 47, 48, 0, 0, 0, 67, 68, 69, 70,
- 71, 72, 73, 74, 75, 76, 0, 0, 0, 0,
- 396, 0, 397, 0, 0, 0, 0, 0, 0, 0,
- 91, 92, 93, 398, 0, 399, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 91, 92, 93, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 91, 92, 93
-};
-
-static const short yycheck[] = { 29,
- 11, 49, 37, 24, 37, 31, 404, 111, 43, 27,
- 43, 22, 223, 86, 87, 88, 268, 90, 227, 503,
- 189, 269, 191, 113, 284, 194, 251, 110, 459, 37,
- 255, 283, 117, 112, 31, 43, 826, 106, 549, 135,
- 209, 104, 11, 251, 251, 3, 29, 255, 255, 26,
- 111, 251, 113, 117, 496, 255, 395, 724, 176, 31,
- 558, 559, 135, 574, 575, 114, 24, 115, 4, 175,
- 670, 177, 70, 94, 674, 742, 106, 3, 5, 6,
- 7, 908, 26, 81, 114, 115, 116, 117, 54, 26,
- 73, 29, 165, 920, 179, 185, 68, 581, 106, 25,
- 27, 887, 888, 221, 134, 123, 114, 115, 116, 117,
- 70, 69, 52, 555, 162, 179, 4, 77, 30, 140,
- 89, 3, 58, 5, 6, 7, 144, 65, 70, 177,
- 339, 142, 5, 6, 7, 304, 171, 397, 171, 917,
- 225, 210, 932, 87, 229, 175, 176, 177, 217, 179,
- 87, 582, 215, 238, 27, 251, 68, 943, 944, 255,
- 33, 225, 139, 171, 213, 229, 143, 175, 176, 177,
- 956, 179, 839, 512, 238, 223, 118, 4, 251, 1006,
- 210, 36, 255, 213, 668, 31, 438, 217, 397, 25,
- 26, 221, 119, 223, 36, 225, 448, 24, 5, 229,
- 7, 264, 210, 803, 308, 213, 26, 237, 238, 217,
- 988, 329, 36, 221, 299, 223, 70, 225, 1045, 1046,
- 303, 229, 68, 302, 330, 343, 435, 257, 291, 67,
- 238, 310, 480, 296, 324, 299, 734, 119, 749, 206,
- 30, 290, 23, 173, 24, 26, 119, 1033, 473, 69,
- 1028, 1029, 1030, 1031, 5, 6, 7, 517, 327, 1045,
- 290, 365, 347, 117, 119, 473, 473, 197, 198, 299,
- 29, 755, 756, 473, 534, 55, 366, 119, 68, 106,
- 363, 364, 290, 347, 53, 950, 26, 5, 6, 7,
- 955, 299, 18, 31, 285, 119, 322, 327, 4, 329,
- 330, 268, 363, 3, 365, 366, 65, 25, 26, 27,
- 24, 429, 119, 343, 1, 345, 283, 347, 24, 327,
- 862, 329, 330, 3, 24, 322, 31, 758, 458, 69,
- 68, 3, 21, 20, 355, 343, 41, 345, 368, 347,
- 270, 3, 4, 433, 24, 375, 409, 465, 278, 397,
- 18, 369, 319, 62, 614, 64, 28, 899, 4, 422,
- 1025, 24, 846, 25, 44, 45, 46, 47, 119, 32,
- 5, 6, 7, 21, 3, 401, 306, 473, 24, 309,
- 310, 550, 551, 24, 636, 869, 41, 28, 318, 368,
- 25, 487, 27, 523, 524, 24, 375, 423, 461, 429,
- 473, 119, 70, 71, 401, 396, 397, 75, 538, 539,
- 3, 402, 4, 380, 487, 29, 45, 408, 47, 903,
- 6, 429, 495, 449, 457, 458, 423, 394, 676, 26,
- 22, 24, 24, 29, 425, 465, 33, 522, 147, 36,
- 470, 27, 23, 3, 4, 26, 155, 4, 157, 457,
- 458, 65, 449, 516, 68, 3, 486, 465, 18, 489,
- 390, 8, 22, 393, 24, 25, 545, 546, 25, 65,
- 549, 438, 68, 8, 399, 579, 24, 646, 5, 6,
- 7, 448, 1020, 70, 119, 558, 559, 412, 19, 76,
- 523, 524, 522, 583, 577, 574, 575, 8, 25, 26,
- 27, 26, 713, 714, 434, 538, 539, 32, 3, 4,
- 53, 1049, 1050, 1051, 522, 523, 524, 6, 49, 50,
- 51, 451, 41, 18, 454, 558, 559, 22, 23, 24,
- 538, 539, 617, 93, 94, 639, 25, 26, 27, 3,
- 4, 532, 563, 591, 78, 475, 70, 565, 3, 4,
- 558, 559, 615, 951, 952, 79, 80, 726, 727, 728,
- 24, 25, 8, 493, 6, 628, 496, 4, 498, 24,
- 779, 4, 3, 4, 8, 3, 4, 26, 651, 652,
- 653, 548, 31, 874, 26, 27, 949, 617, 879, 880,
- 557, 24, 119, 24, 620, 958, 24, 618, 93, 94,
- 4, 619, 965, 528, 529, 530, 531, 537, 24, 617,
- 631, 536, 28, 824, 632, 26, 607, 28, 22, 11,
- 24, 23, 613, 620, 26, 555, 556, 662, 23, 662,
- 19, 26, 21, 654, 3, 4, 627, 33, 26, 23,
- 658, 29, 26, 21, 32, 936, 1009, 70, 578, 18,
- 73, 25, 1015, 22, 662, 24, 947, 21, 688, 689,
- 733, 734, 831, 23, 1027, 26, 26, 3, 4, 636,
- 749, 99, 100, 101, 102, 103, 104, 105, 106, 19,
- 784, 21, 4, 713, 714, 19, 977, 21, 24, 3,
- 4, 1054, 1055, 1056, 1057, 986, 621, 4, 623, 624,
- 625, 734, 70, 71, 33, 713, 714, 75, 3, 4,
- 701, 6, 4, 3, 4, 19, 1007, 21, 87, 29,
- 30, 3, 4, 18, 6, 94, 734, 22, 18, 24,
- 25, 661, 22, 87, 24, 25, 18, 667, 8, 9,
- 22, 814, 24, 754, 1035, 27, 112, 113, 114, 115,
- 116, 8, 19, 720, 21, 87, 777, 3, 4, 25,
- 26, 97, 780, 99, 100, 101, 102, 103, 104, 105,
- 106, 19, 1063, 21, 19, 766, 21, 807, 24, 25,
- 19, 772, 21, 774, 775, 776, 32, 717, 3, 4,
- 781, 1082, 1083, 36, 824, 49, 50, 51, 93, 94,
- 25, 26, 1093, 93, 94, 25, 26, 29, 31, 24,
- 25, 30, 94, 3, 744, 37, 824, 32, 25, 26,
- 850, 43, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 56, 57, 58, 59, 30, 867, 24, 31,
- 3, 4, 850, 6, 874, 529, 530, 531, 18, 879,
- 880, 25, 26, 3, 4, 18, 28, 887, 888, 22,
- 790, 24, 3, 4, 27, 856, 874, 89, 859, 25,
- 26, 879, 880, 25, 26, 3, 4, 18, 889, 25,
- 26, 22, 31, 24, 28, 25, 26, 109, 110, 111,
- 112, 113, 922, 923, 25, 925, 25, 26, 928, 25,
- 26, 25, 913, 25, 26, 23, 936, 837, 6, 900,
- 25, 97, 134, 943, 944, 25, 26, 947, 25, 26,
- 25, 26, 36, 109, 110, 111, 956, 26, 936, 70,
- 25, 94, 107, 108, 28, 29, 95, 96, 160, 947,
- 3, 4, 1074, 1075, 24, 953, 954, 977, 956, 171,
- 24, 173, 93, 94, 27, 18, 986, 27, 64, 22,
- 87, 24, 87, 185, 94, 895, 28, 23, 25, 977,
- 41, 193, 30, 41, 4, 197, 198, 1007, 986, 31,
- 23, 8, 23, 4, 206, 3, 4, 26, 8, 9,
- 10, 11, 12, 13, 14, 15, 16, 17, 33, 1007,
- 18, 24, 21, 1033, 22, 1035, 24, 70, 24, 87,
- 28, 17, 17, 3, 4, 1045, 1064, 30, 11, 36,
- 8, 3, 4, 30, 23, 1033, 26, 1035, 18, 41,
- 93, 94, 22, 1063, 24, 257, 18, 28, 1046, 25,
- 22, 25, 24, 25, 8, 30, 268, 269, 270, 3,
- 4, 31, 1082, 1083, 31, 1063, 278, 31, 3, 4,
- 94, 283, 8, 1093, 18, 68, 23, 25, 22, 25,
- 24, 43, 25, 18, 1082, 1083, 94, 22, 29, 24,
- 302, 303, 25, 25, 306, 1093, 308, 309, 310, 109,
- 110, 111, 62, 19, 21, 25, 318, 319, 64, 3,
- 4, 25, 324, 93, 94, 68, 25, 25, 69, 8,
- 3, 4, 94, 27, 18, 31, 66, 66, 22, 73,
- 24, 23, 25, 36, 21, 18, 22, 106, 19, 22,
- 28, 24, 69, 68, 74, 114, 115, 116, 117, 68,
- 94, 363, 364, 365, 366, 23, 368, 26, 25, 94,
- 40, 40, 28, 375, 63, 26, 135, 68, 380, 33,
- 72, 69, 69, 21, 25, 87, 87, 18, 390, 69,
- 26, 393, 394, 3, 4, 5, 6, 7, 8, 9,
- 10, 11, 12, 13, 14, 15, 16, 17, 23, 34,
- 94, 30, 22, 8, 24, 25, 175, 176, 177, 22,
- 179, 94, 28, 19, 8, 35, 18, 37, 18, 3,
- 18, 433, 434, 26, 4, 24, 438, 22, 43, 22,
- 442, 18, 24, 22, 19, 8, 448, 3, 19, 451,
- 30, 210, 454, 18, 213, 457, 458, 11, 217, 11,
- 24, 30, 221, 8, 223, 33, 225, 11, 11, 11,
- 229, 11, 18, 475, 40, 25, 11, 18, 480, 238,
- 18, 18, 11, 19, 486, 19, 19, 11, 0, 40,
- 137, 493, 19, 25, 496, 25, 498, 28, 19, 109,
- 110, 111, 28, 19, 19, 25, 25, 25, 25, 119,
- 21, 21, 0, 134, 673, 486, 801, 682, 499, 753,
- 740, 523, 524, 1014, 930, 895, 867, 837, 1006, 1046,
- 1068, 290, 1033, 1041, 18, 537, 538, 539, 18, 41,
- 299, 683, 43, 545, 546, 547, 548, 549, 57, 551,
- 688, 57, 252, 555, 556, 557, 558, 559, 171, 121,
- 552, 732, 790, 112, 546, 493, 559, 734, 327, 255,
- 329, 330, 574, 575, 473, 577, 578, 579, 540, 617,
- 772, 583, 769, 396, 343, 714, 345, 487, 347, 932,
- 767, 824, 345, 397, 646, 354, 3, 4, 5, 6,
- 7, 8, 9, 10, 11, 12, 13, 14, 15, 16,
- 17, -1, -1, -1, -1, 22, -1, 24, 25, -1,
- 27, -1, -1, -1, -1, -1, -1, -1, 35, -1,
- 37, 38, 39, -1, 636, 42, -1, 639, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 56,
- 57, 58, 59, 60, 61, -1, -1, -1, -1, 661,
- 662, -1, -1, -1, -1, 667, -1, -1, -1, -1,
- 429, -1, -1, -1, 676, -1, -1, 3, 4, 5,
- 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, -1, -1, -1, -1, 22, -1, 24, 25,
- -1, -1, 109, 110, 111, -1, 465, -1, -1, 35,
- -1, 37, 119, -1, -1, 717, -1, -1, 720, -1,
- -1, -1, 724, -1, -1, -1, -1, -1, 487, -1,
- 489, -1, 734, -1, -1, -1, -1, -1, -1, -1,
- 742, -1, 744, -1, -1, -1, -1, 749, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 522, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 784, 109, 110, 111, -1, -1, 790, -1,
- -1, -1, -1, 119, 3, 4, 5, 6, 7, 8,
- 9, 10, 11, 12, 13, 14, 15, 16, 17, -1,
- -1, -1, -1, 22, -1, 24, 25, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 35, -1, 37, -1,
- -1, -1, -1, -1, -1, 837, -1, 839, 3, 4,
- -1, -1, -1, 8, 9, 10, 11, 12, 13, 14,
- 15, 16, 17, -1, -1, -1, -1, -1, 617, 24,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 38, 39, -1, -1, 42, -1, -1,
- 882, 883, 884, 885, 886, -1, -1, -1, -1, -1,
- -1, -1, -1, 895, -1, 60, -1, -1, -1, -1,
- 109, 110, 111, -1, -1, -1, -1, -1, -1, -1,
- 119, -1, -1, -1, -1, -1, -1, -1, -1, 921,
- -1, -1, -1, 88, 89, 90, 91, 92, -1, 688,
- -1, 690, -1, 98, 99, 100, 101, 102, 103, 104,
- 105, 106, -1, -1, 109, 110, 111, 949, -1, -1,
- -1, -1, -1, -1, 713, 714, 958, -1, -1, -1,
- -1, -1, -1, 965, -1, 967, -1, 3, 4, -1,
- -1, 7, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, -1, -1, -1, -1, 22, -1, 24, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 35,
- -1, 37, -1, -1, -1, -1, -1, 1009, 44, 45,
- 46, 47, 48, 1015, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 1027, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 1041,
- -1, -1, -1, -1, -1, -1, 82, 83, 84, 85,
- 86, -1, 1054, 1055, 1056, 1057, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 824, -1, -1, -1, -1,
- -1, -1, -1, 109, 110, 111, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 850, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 874, -1, -1, 877, -1,
- 879, 880, -1, -1, -1, -1, -1, -1, 887, 888,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 3, 4, -1,
- -1, 7, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, -1, -1, -1, -1, 22, 23, 24, 928,
- -1, -1, -1, -1, -1, -1, -1, 936, -1, 35,
- -1, 37, 38, 39, 943, 944, 42, -1, 947, 948,
- -1, -1, -1, -1, -1, -1, -1, 956, -1, -1,
- 56, 57, 58, 59, 60, 61, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 977, -1,
- -1, -1, -1, -1, 3, 4, -1, 986, 7, 8,
- 9, 10, 11, 12, 13, 14, 15, 16, 17, -1,
- -1, -1, -1, 22, -1, 24, 25, -1, 1007, -1,
- -1, -1, -1, 109, 110, 111, 35, -1, 37, 38,
- 39, -1, -1, 42, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 1033, -1, 1035, 56, 57, 58,
- 59, 60, 61, -1, -1, -1, 1045, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 3, 4, -1, 1063, 7, 8, 9, 10, 11,
- 12, 13, 14, 15, 16, 17, -1, -1, -1, -1,
- 22, -1, 24, 1082, 1083, -1, -1, -1, -1, -1,
- 109, 110, 111, 35, 1093, 37, 38, 39, -1, -1,
- 42, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 56, 57, 58, 59, 60, 61,
- 3, 4, -1, -1, -1, 8, 9, 10, 11, 12,
- 13, 14, 15, 16, 17, -1, -1, 3, 4, 22,
- -1, 24, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 35, -1, 37, 38, 39, 23, 24, 42,
- -1, -1, -1, -1, -1, -1, -1, 109, 110, 111,
- -1, -1, -1, 56, 57, 58, 59, 60, 61, 3,
- 4, -1, -1, 7, 8, 9, 10, 11, 12, 13,
- 14, 15, 16, 17, -1, -1, 3, 4, 22, -1,
- 24, 8, 9, 10, 11, 12, 13, 14, 15, 16,
- 17, 35, -1, 37, -1, -1, -1, 24, -1, -1,
- -1, -1, -1, -1, -1, -1, 109, 110, 111, -1,
- -1, -1, -1, 99, 100, 101, 102, 103, 104, 105,
- 106, -1, -1, 109, 110, 111, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 82, 83,
- 84, 85, 86, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 109, 110, 111, -1, -1,
- -1, -1, 99, 100, 101, 102, 103, 104, 105, 106,
- -1, -1, 109, 110, 111, 3, 4, -1, -1, 7,
- 8, 9, 10, 11, 12, 13, 14, 15, 16, 17,
- -1, -1, -1, -1, 22, -1, 24, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 35, -1, 37,
- 3, 4, -1, -1, 7, 8, 9, 10, 11, 12,
- 13, 14, 15, 16, 17, -1, -1, -1, -1, 22,
- 23, 24, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 35, -1, 37, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 82, 83, 84, 3, 4, -1,
- -1, 7, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, -1, -1, -1, -1, 22, 23, 24, -1,
- -1, 109, 110, 111, -1, -1, -1, -1, -1, 35,
- -1, 37, 3, 4, -1, -1, 7, 8, 9, 10,
- 11, 12, 13, 14, 15, 16, 17, -1, -1, -1,
- -1, 22, 23, 24, -1, -1, 109, 110, 111, -1,
- -1, -1, -1, -1, 35, -1, 37, 3, 4, -1,
- -1, 7, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, -1, -1, -1, -1, 22, -1, 24, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 35,
- -1, 37, -1, 109, 110, 111, -1, -1, -1, 3,
- 4, -1, -1, 7, 8, 9, 10, 11, 12, 13,
- 14, 15, 16, 17, -1, -1, -1, -1, 22, -1,
- 24, -1, -1, -1, -1, -1, -1, -1, 109, 110,
- 111, 35, -1, 37, 3, 4, -1, -1, -1, 8,
- 9, 10, 11, 12, 13, 14, 15, 16, 17, -1,
- -1, -1, -1, 22, -1, 24, -1, -1, -1, -1,
- -1, -1, -1, 109, 110, 111, 35, -1, 37, 3,
- 4, -1, -1, -1, 8, 9, 10, 11, 12, 13,
- 14, 15, 16, 17, -1, -1, -1, -1, 22, -1,
- 24, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 35, -1, 37, -1, 109, 110, 111, -1, -1,
- -1, 3, 4, -1, -1, -1, 8, 9, 10, 11,
- 12, 13, 14, 15, 16, 17, -1, -1, -1, -1,
- 22, -1, 24, -1, -1, -1, -1, -1, -1, -1,
- 109, 110, 111, 35, -1, 37, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 109, 110, 111, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 109, 110, 111
-};
-/* -*-C-*- Note some compilers choke on comments on `#line' lines. */
-#line 3 "/usr/local/gnu/share/bison.simple"
-
-/* Skeleton output parser for bison,
- Copyright (C) 1984, 1989, 1990 Free Software Foundation, Inc.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2, or (at your option)
- any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
-
-/* As a special exception, when this file is copied by Bison into a
- Bison output file, you may use that output file without restriction.
- This special exception was added by the Free Software Foundation
- in version 1.24 of Bison. */
-
-#ifndef alloca
-#ifdef __GNUC__
-#define alloca __builtin_alloca
-#else /* not GNU C. */
-#if (!defined (__STDC__) && defined (sparc)) || defined (__sparc__) || defined (__sparc) || defined (__sgi)
-#include <alloca.h>
-#else /* not sparc */
-#if defined (MSDOS) && !defined (__TURBOC__)
-#include <malloc.h>
-#else /* not MSDOS, or __TURBOC__ */
-#if defined(_AIX)
-#include <malloc.h>
- #pragma alloca
-#else /* not MSDOS, __TURBOC__, or _AIX */
-#ifdef __hpux
-#ifdef __cplusplus
-extern "C" {
-void *alloca (unsigned int);
-};
-#else /* not __cplusplus */
-void *alloca ();
-#endif /* not __cplusplus */
-#endif /* __hpux */
-#endif /* not _AIX */
-#endif /* not MSDOS, or __TURBOC__ */
-#endif /* not sparc. */
-#endif /* not GNU C. */
-#endif /* alloca not defined. */
-
-/* This is the parser code that is written into each bison parser
- when the %semantic_parser declaration is not specified in the grammar.
- It was written by Richard Stallman by simplifying the hairy parser
- used when %semantic_parser is specified. */
-
-/* Note: there must be only one dollar sign in this file.
- It is replaced by the list of actions, each action
- as one case of the switch. */
-
-#define yyerrok (yyerrstatus = 0)
-#define yyclearin (yychar = YYEMPTY)
-#define YYEMPTY -2
-#define YYEOF 0
-#define YYACCEPT return(0)
-#define YYABORT return(1)
-#define YYERROR goto yyerrlab1
-/* Like YYERROR except do call yyerror.
- This remains here temporarily to ease the
- transition to the new meaning of YYERROR, for GCC.
- Once GCC version 2 has supplanted version 1, this can go. */
-#define YYFAIL goto yyerrlab
-#define YYRECOVERING() (!!yyerrstatus)
-#define YYBACKUP(token, value) \
-do \
- if (yychar == YYEMPTY && yylen == 1) \
- { yychar = (token), yylval = (value); \
- yychar1 = YYTRANSLATE (yychar); \
- YYPOPSTACK; \
- goto yybackup; \
- } \
- else \
- { yyerror ("syntax error: cannot back up"); YYERROR; } \
-while (0)
-
-#define YYTERROR 1
-#define YYERRCODE 256
-
-#ifndef YYPURE
-#define YYLEX yylex()
-#endif
-
-#ifdef YYPURE
-#ifdef YYLSP_NEEDED
-#ifdef YYLEX_PARAM
-#define YYLEX yylex(&yylval, &yylloc, YYLEX_PARAM)
-#else
-#define YYLEX yylex(&yylval, &yylloc)
-#endif
-#else /* not YYLSP_NEEDED */
-#ifdef YYLEX_PARAM
-#define YYLEX yylex(&yylval, YYLEX_PARAM)
-#else
-#define YYLEX yylex(&yylval)
-#endif
-#endif /* not YYLSP_NEEDED */
-#endif
-
-/* If nonreentrant, generate the variables here */
-
-#ifndef YYPURE
-
-int yychar; /* the lookahead symbol */
-YYSTYPE yylval; /* the semantic value of the */
- /* lookahead symbol */
-
-#ifdef YYLSP_NEEDED
-YYLTYPE yylloc; /* location data for the lookahead */
- /* symbol */
-#endif
-
-int yynerrs; /* number of parse errors so far */
-#endif /* not YYPURE */
-
-#if YYDEBUG != 0
-int yydebug; /* nonzero means print parse trace */
-/* Since this is uninitialized, it does not stop multiple parsers
- from coexisting. */
-#endif
-
-/* YYINITDEPTH indicates the initial size of the parser's stacks */
-
-#ifndef YYINITDEPTH
-#define YYINITDEPTH 200
-#endif
-
-/* YYMAXDEPTH is the maximum size the stacks can grow to
- (effective only if the built-in stack extension method is used). */
-
-#if YYMAXDEPTH == 0
-#undef YYMAXDEPTH
-#endif
-
-#ifndef YYMAXDEPTH
-#define YYMAXDEPTH 10000
-#endif
-
-/* Prevent warning if -Wstrict-prototypes. */
-#ifdef __GNUC__
-int yyparse (void);
-#endif
-\f
-#if __GNUC__ > 1 /* GNU C and GNU C++ define this. */
-#define __yy_memcpy(FROM,TO,COUNT) __builtin_memcpy(TO,FROM,COUNT)
-#else /* not GNU C or C++ */
-#ifndef __cplusplus
-
-/* This is the most reliable way to avoid incompatibilities
- in available built-in functions on various systems. */
-static void
-__yy_memcpy (from, to, count)
- char *from;
- char *to;
- int count;
-{
- register char *f = from;
- register char *t = to;
- register int i = count;
-
- while (i-- > 0)
- *t++ = *f++;
-}
-
-#else /* __cplusplus */
-
-/* This is the most reliable way to avoid incompatibilities
- in available built-in functions on various systems. */
-static void
-__yy_memcpy (char *from, char *to, int count)
-{
- register char *f = from;
- register char *t = to;
- register int i = count;
-
- while (i-- > 0)
- *t++ = *f++;
-}
-
-#endif
-#endif
-\f
-#line 192 "/usr/local/gnu/share/bison.simple"
-
-/* The user can define YYPARSE_PARAM as the name of an argument to be passed
- into yyparse. The argument should have type void *.
- It should actually point to an object.
- Grammar actions can access the variable by casting it
- to the proper pointer type. */
-
-#ifdef YYPARSE_PARAM
-#define YYPARSE_PARAM_DECL void *YYPARSE_PARAM;
-#else
-#define YYPARSE_PARAM
-#define YYPARSE_PARAM_DECL
-#endif
-
-int
-yyparse(YYPARSE_PARAM)
- YYPARSE_PARAM_DECL
-{
- register int yystate;
- register int yyn;
- register short *yyssp;
- register YYSTYPE *yyvsp;
- int yyerrstatus; /* number of tokens to shift before error messages enabled */
- int yychar1 = 0; /* lookahead token as an internal (translated) token number */
-
- short yyssa[YYINITDEPTH]; /* the state stack */
- YYSTYPE yyvsa[YYINITDEPTH]; /* the semantic value stack */
-
- short *yyss = yyssa; /* refer to the stacks thru separate pointers */
- YYSTYPE *yyvs = yyvsa; /* to allow yyoverflow to reallocate them elsewhere */
-
-#ifdef YYLSP_NEEDED
- YYLTYPE yylsa[YYINITDEPTH]; /* the location stack */
- YYLTYPE *yyls = yylsa;
- YYLTYPE *yylsp;
-
-#define YYPOPSTACK (yyvsp--, yyssp--, yylsp--)
-#else
-#define YYPOPSTACK (yyvsp--, yyssp--)
-#endif
-
- int yystacksize = YYINITDEPTH;
-
-#ifdef YYPURE
- int yychar;
- YYSTYPE yylval;
- int yynerrs;
-#ifdef YYLSP_NEEDED
- YYLTYPE yylloc;
-#endif
-#endif
-
- YYSTYPE yyval; /* the variable used to return */
- /* semantic values from the action */
- /* routines */
-
- int yylen;
-
-#if YYDEBUG != 0
- if (yydebug)
- fprintf(stderr, "Starting parse\n");
-#endif
-
- yystate = 0;
- yyerrstatus = 0;
- yynerrs = 0;
- yychar = YYEMPTY; /* Cause a token to be read. */
-
- /* Initialize stack pointers.
- Waste one element of value and location stack
- so that they stay on the same level as the state stack.
- The wasted elements are never initialized. */
-
- yyssp = yyss - 1;
- yyvsp = yyvs;
-#ifdef YYLSP_NEEDED
- yylsp = yyls;
-#endif
-
-/* Push a new state, which is found in yystate . */
-/* In all cases, when you get here, the value and location stacks
- have just been pushed. so pushing a state here evens the stacks. */
-yynewstate:
-
- *++yyssp = yystate;
-
- if (yyssp >= yyss + yystacksize - 1)
- {
- /* Give user a chance to reallocate the stack */
- /* Use copies of these so that the &'s don't force the real ones into memory. */
- YYSTYPE *yyvs1 = yyvs;
- short *yyss1 = yyss;
-#ifdef YYLSP_NEEDED
- YYLTYPE *yyls1 = yyls;
-#endif
-
- /* Get the current used size of the three stacks, in elements. */
- int size = yyssp - yyss + 1;
-
-#ifdef yyoverflow
- /* Each stack pointer address is followed by the size of
- the data in use in that stack, in bytes. */
-#ifdef YYLSP_NEEDED
- /* This used to be a conditional around just the two extra args,
- but that might be undefined if yyoverflow is a macro. */
- yyoverflow("parser stack overflow",
- &yyss1, size * sizeof (*yyssp),
- &yyvs1, size * sizeof (*yyvsp),
- &yyls1, size * sizeof (*yylsp),
- &yystacksize);
-#else
- yyoverflow("parser stack overflow",
- &yyss1, size * sizeof (*yyssp),
- &yyvs1, size * sizeof (*yyvsp),
- &yystacksize);
-#endif
-
- yyss = yyss1; yyvs = yyvs1;
-#ifdef YYLSP_NEEDED
- yyls = yyls1;
-#endif
-#else /* no yyoverflow */
- /* Extend the stack our own way. */
- if (yystacksize >= YYMAXDEPTH)
- {
- yyerror("parser stack overflow");
- return 2;
- }
- yystacksize *= 2;
- if (yystacksize > YYMAXDEPTH)
- yystacksize = YYMAXDEPTH;
- yyss = (short *) alloca (yystacksize * sizeof (*yyssp));
- __yy_memcpy ((char *)yyss1, (char *)yyss, size * sizeof (*yyssp));
- yyvs = (YYSTYPE *) alloca (yystacksize * sizeof (*yyvsp));
- __yy_memcpy ((char *)yyvs1, (char *)yyvs, size * sizeof (*yyvsp));
-#ifdef YYLSP_NEEDED
- yyls = (YYLTYPE *) alloca (yystacksize * sizeof (*yylsp));
- __yy_memcpy ((char *)yyls1, (char *)yyls, size * sizeof (*yylsp));
-#endif
-#endif /* no yyoverflow */
-
- yyssp = yyss + size - 1;
- yyvsp = yyvs + size - 1;
-#ifdef YYLSP_NEEDED
- yylsp = yyls + size - 1;
-#endif
-
-#if YYDEBUG != 0
- if (yydebug)
- fprintf(stderr, "Stack size increased to %d\n", yystacksize);
-#endif
-
- if (yyssp >= yyss + yystacksize - 1)
- YYABORT;
- }
-
-#if YYDEBUG != 0
- if (yydebug)
- fprintf(stderr, "Entering state %d\n", yystate);
-#endif
-
- goto yybackup;
- yybackup:
-
-/* Do appropriate processing given the current state. */
-/* Read a lookahead token if we need one and don't already have one. */
-/* yyresume: */
-
- /* First try to decide what to do without reference to lookahead token. */
-
- yyn = yypact[yystate];
- if (yyn == YYFLAG)
- goto yydefault;
-
- /* Not known => get a lookahead token if don't already have one. */
-
- /* yychar is either YYEMPTY or YYEOF
- or a valid token in external form. */
-
- if (yychar == YYEMPTY)
- {
-#if YYDEBUG != 0
- if (yydebug)
- fprintf(stderr, "Reading a token: ");
-#endif
- yychar = YYLEX;
- }
-
- /* Convert token to internal form (in yychar1) for indexing tables with */
-
- if (yychar <= 0) /* This means end of input. */
- {
- yychar1 = 0;
- yychar = YYEOF; /* Don't call YYLEX any more */
-
-#if YYDEBUG != 0
- if (yydebug)
- fprintf(stderr, "Now at end of input.\n");
-#endif
- }
- else
- {
- yychar1 = YYTRANSLATE(yychar);
-
-#if YYDEBUG != 0
- if (yydebug)
- {
- fprintf (stderr, "Next token is %d (%s", yychar, yytname[yychar1]);
- /* Give the individual parser a way to print the precise meaning
- of a token, for further debugging info. */
-#ifdef YYPRINT
- YYPRINT (stderr, yychar, yylval);
-#endif
- fprintf (stderr, ")\n");
- }
-#endif
- }
-
- yyn += yychar1;
- if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != yychar1)
- goto yydefault;
-
- yyn = yytable[yyn];
-
- /* yyn is what to do for this token type in this state.
- Negative => reduce, -yyn is rule number.
- Positive => shift, yyn is new state.
- New state is final state => don't bother to shift,
- just return success.
- 0, or most negative number => error. */
-
- if (yyn < 0)
- {
- if (yyn == YYFLAG)
- goto yyerrlab;
- yyn = -yyn;
- goto yyreduce;
- }
- else if (yyn == 0)
- goto yyerrlab;
-
- if (yyn == YYFINAL)
- YYACCEPT;
-
- /* Shift the lookahead token. */
-
-#if YYDEBUG != 0
- if (yydebug)
- fprintf(stderr, "Shifting token %d (%s), ", yychar, yytname[yychar1]);
-#endif
-
- /* Discard the token being shifted unless it is eof. */
- if (yychar != YYEOF)
- yychar = YYEMPTY;
-
- *++yyvsp = yylval;
-#ifdef YYLSP_NEEDED
- *++yylsp = yylloc;
-#endif
-
- /* count tokens shifted since error; after three, turn off error status. */
- if (yyerrstatus) yyerrstatus--;
-
- yystate = yyn;
- goto yynewstate;
-
-/* Do the default action for the current state. */
-yydefault:
-
- yyn = yydefact[yystate];
- if (yyn == 0)
- goto yyerrlab;
-
-/* Do a reduction. yyn is the number of a rule to reduce with. */
-yyreduce:
- yylen = yyr2[yyn];
- if (yylen > 0)
- yyval = yyvsp[1-yylen]; /* implement default value of the action */
-
-#if YYDEBUG != 0
- if (yydebug)
- {
- int i;
-
- fprintf (stderr, "Reducing via rule %d (line %d), ",
- yyn, yyrline[yyn]);
-
- /* Print the symbols being reduced, and their result. */
- for (i = yyprhs[yyn]; yyrhs[i] > 0; i++)
- fprintf (stderr, "%s ", yytname[yyrhs[i]]);
- fprintf (stderr, " -> %s\n", yytname[yyr1[yyn]]);
- }
-#endif
-
-
- switch (yyn) {
-
-case 2:
-#line 333 "yaccParser/hsparser.y"
-{ the_module_name = yyvsp[-1].uid; module_exports = yyvsp[0].ulist; ;
- break;}
-case 4:
-#line 335 "yaccParser/hsparser.y"
-{ the_module_name = install_literal("Main"); module_exports = Lnil; ;
- break;}
-case 6:
-#line 341 "yaccParser/hsparser.y"
-{
- root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-3].ulist),module_exports,yyvsp[-1].ubinding,startlineno);
- ;
- break;}
-case 7:
-#line 345 "yaccParser/hsparser.y"
-{
- root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-3].ulist),module_exports,yyvsp[-1].ubinding,startlineno);
- ;
- break;}
-case 8:
-#line 350 "yaccParser/hsparser.y"
-{
- root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-1].ulist),module_exports,mknullbind(),startlineno);
- ;
- break;}
-case 9:
-#line 354 "yaccParser/hsparser.y"
-{
- root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-1].ulist),module_exports,mknullbind(),startlineno);
- ;
- break;}
-case 10:
-#line 360 "yaccParser/hsparser.y"
-{
- root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-1].ulist),module_exports,mknullbind(),startlineno);
- ;
- break;}
-case 11:
-#line 364 "yaccParser/hsparser.y"
-{
- root = mkhmodule(the_module_name,lconc(prelude_imports,yyvsp[-1].ulist),module_exports,mknullbind(),startlineno);
- ;
- break;}
-case 12:
-#line 370 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 13:
-#line 371 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; ;
- break;}
-case 14:
-#line 375 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uentid); ;
- break;}
-case 15:
-#line 376 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uentid); ;
- break;}
-case 16:
-#line 380 "yaccParser/hsparser.y"
-{ yyval.uentid = mkentid(yyvsp[0].uid); ;
- break;}
-case 17:
-#line 381 "yaccParser/hsparser.y"
-{ yyval.uentid = mkenttype(yyvsp[0].uid); ;
- break;}
-case 18:
-#line 382 "yaccParser/hsparser.y"
-{ yyval.uentid = mkenttypeall(yyvsp[-3].uid); ;
- break;}
-case 19:
-#line 384 "yaccParser/hsparser.y"
-{ yyval.uentid = mkenttypecons(yyvsp[-3].uid,yyvsp[-1].ulist);
- /* should be a datatype with cons representing all constructors */
- ;
- break;}
-case 20:
-#line 388 "yaccParser/hsparser.y"
-{ yyval.uentid = mkentclass(yyvsp[-3].uid,yyvsp[-1].ulist);
- /* should be a class with vars representing all Class operations */
- ;
- break;}
-case 21:
-#line 392 "yaccParser/hsparser.y"
-{ yyval.uentid = mkentclass(yyvsp[-2].uid,Lnil);
- /* "tycon" should be a class with no operations */
- ;
- break;}
-case 22:
-#line 396 "yaccParser/hsparser.y"
-{ yyval.uentid = mkentmod(yyvsp[-1].uid);
- /* "tycon" is a module id (but "modid" is bad for your identifier's health [KH]) */
- ;
- break;}
-case 23:
-#line 402 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; hidden = FALSE; ;
- break;}
-case 24:
-#line 403 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; hidden = TRUE; ;
- break;}
-case 25:
-#line 404 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; hidden = FALSE; ;
- break;}
-case 26:
-#line 407 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 27:
-#line 408 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[0].ulist; ;
- break;}
-case 28:
-#line 412 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uentid); ;
- break;}
-case 29:
-#line 413 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uentid); ;
- break;}
-case 30:
-#line 417 "yaccParser/hsparser.y"
-{ yyval.uentid = mkentid(yyvsp[0].uid); ;
- break;}
-case 31:
-#line 418 "yaccParser/hsparser.y"
-{ yyval.uentid = mkenttype(yyvsp[0].uid); ;
- break;}
-case 32:
-#line 419 "yaccParser/hsparser.y"
-{ yyval.uentid = mkenttypeall(yyvsp[-3].uid); ;
- break;}
-case 33:
-#line 421 "yaccParser/hsparser.y"
-{ yyval.uentid = mkenttypecons(yyvsp[-3].uid,yyvsp[-1].ulist);
- /* should be a datatype with cons representing all constructors */
- ;
- break;}
-case 34:
-#line 425 "yaccParser/hsparser.y"
-{ yyval.uentid = mkentclass(yyvsp[-3].uid,yyvsp[-1].ulist);
- /* should be a class with vars representing all Class operations */
- ;
- break;}
-case 35:
-#line 429 "yaccParser/hsparser.y"
-{ yyval.uentid = mkentclass(yyvsp[-2].uid,Lnil);
- /* "tycon" should be a class with no operations */
- ;
- break;}
-case 36:
-#line 438 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkidata_pragma(yyvsp[-2].ulist, yyvsp[-1].ulist); ;
- break;}
-case 37:
-#line 440 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkidata_pragma(Lnil, yyvsp[-1].ulist); ;
- break;}
-case 38:
-#line 441 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 39:
-#line 446 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[0].ulist; ;
- break;}
-case 40:
-#line 447 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 41:
-#line 451 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uhpragma); ;
- break;}
-case 42:
-#line 453 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uhpragma); ;
- break;}
-case 43:
-#line 457 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkidata_pragma_4s(yyvsp[-1].ulist); ;
- break;}
-case 44:
-#line 461 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkitype_pragma(); ;
- break;}
-case 45:
-#line 462 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 46:
-#line 466 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiclas_pragma(yyvsp[-1].ulist); ;
- break;}
-case 47:
-#line 467 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 48:
-#line 472 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiclasop_pragma(yyvsp[-2].uhpragma, yyvsp[-1].uhpragma); ;
- break;}
-case 49:
-#line 474 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 50:
-#line 479 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiinst_simpl_pragma(yyvsp[-2].uid, yyvsp[-1].uhpragma); ;
- break;}
-case 51:
-#line 482 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiinst_const_pragma(yyvsp[-3].uid, yyvsp[-2].uhpragma, yyvsp[-1].ulist); ;
- break;}
-case 52:
-#line 485 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 53:
-#line 490 "yaccParser/hsparser.y"
-{ yyval.uid = yyvsp[0].uid; ;
- break;}
-case 54:
-#line 492 "yaccParser/hsparser.y"
-{ yyval.uid = install_literal(""); ;
- break;}
-case 55:
-#line 497 "yaccParser/hsparser.y"
-{ yyval.uhpragma = yyvsp[-1].uhpragma; ;
- break;}
-case 56:
-#line 499 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 57:
-#line 504 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 58:
-#line 506 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkigen_pragma(yyvsp[-5].uhpragma, yyvsp[-4].uhpragma, yyvsp[-3].uhpragma, yyvsp[-2].uhpragma, yyvsp[-1].uhpragma, yyvsp[0].ulist); ;
- break;}
-case 59:
-#line 510 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 60:
-#line 511 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiarity_pragma(yyvsp[0].ustring); ;
- break;}
-case 61:
-#line 515 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 62:
-#line 516 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiupdate_pragma(yyvsp[0].ustring); ;
- break;}
-case 63:
-#line 520 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 64:
-#line 521 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkideforest_pragma(); ;
- break;}
-case 65:
-#line 525 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 66:
-#line 526 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkistrictness_pragma(installHstring(1, "B"),
- /* _!_ = COCON = bottom */ mkno_pragma());
- ;
- break;}
-case 67:
-#line 530 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkistrictness_pragma(yyvsp[-1].uhstring, yyvsp[0].uhpragma); ;
- break;}
-case 68:
-#line 534 "yaccParser/hsparser.y"
-{ yyval.uhpragma = yyvsp[-1].uhpragma; ;
- break;}
-case 69:
-#line 535 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 70:
-#line 538 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkno_pragma(); ;
- break;}
-case 71:
-#line 540 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkimagic_unfolding_pragma(yyvsp[0].uid); ;
- break;}
-case 72:
-#line 542 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiunfolding_pragma(yyvsp[-1].uhpragma, yyvsp[0].ucoresyn); ;
- break;}
-case 73:
-#line 547 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiunfold_always(); ;
- break;}
-case 74:
-#line 549 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiunfold_if_args(yyvsp[-3].ustring, yyvsp[-2].ustring, yyvsp[-1].uid, yyvsp[0].ustring); ;
- break;}
-case 75:
-#line 553 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uhpragma); ;
- break;}
-case 76:
-#line 554 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uhpragma); ;
- break;}
-case 77:
-#line 558 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 78:
-#line 559 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[0].ulist; ;
- break;}
-case 79:
-#line 563 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uhpragma); ;
- break;}
-case 80:
-#line 564 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uhpragma); ;
- break;}
-case 81:
-#line 569 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkitype_pragma_pr(yyvsp[-3].ulist, yyvsp[-1].ustring, yyvsp[0].uhpragma); ;
- break;}
-case 82:
-#line 573 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 83:
-#line 574 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uttype); ;
- break;}
-case 84:
-#line 578 "yaccParser/hsparser.y"
-{ yyval.uttype = mkty_maybe_nothing(); ;
- break;}
-case 85:
-#line 579 "yaccParser/hsparser.y"
-{ yyval.uttype = mkty_maybe_just(yyvsp[0].uttype); ;
- break;}
-case 86:
-#line 583 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uhpragma); ;
- break;}
-case 87:
-#line 584 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uhpragma); ;
- break;}
-case 88:
-#line 593 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiname_pragma_pr(yyvsp[-4].uid, yyvsp[-1].uhpragma); ;
- break;}
-case 89:
-#line 599 "yaccParser/hsparser.y"
-{ yyval.uhpragma = mkiname_pragma_pr(yyvsp[-2].uid, yyvsp[0].uhpragma); ;
- break;}
-case 90:
-#line 610 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcolam(yyvsp[-2].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 91:
-#line 612 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcotylam(yyvsp[-2].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 92:
-#line 614 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcocon(mkco_id(yyvsp[-2].uid), yyvsp[-1].ulist, yyvsp[0].ulist); ;
- break;}
-case 93:
-#line 616 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcocon(mkco_orig_id(yyvsp[-3].uid,yyvsp[-2].uid), yyvsp[-1].ulist, yyvsp[0].ulist); ;
- break;}
-case 94:
-#line 618 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcoprim(yyvsp[-2].ucoresyn, yyvsp[-1].ulist, yyvsp[0].ulist); ;
- break;}
-case 95:
-#line 620 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcoapp(yyvsp[-1].ucoresyn, yyvsp[0].ulist); ;
- break;}
-case 96:
-#line 622 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcotyapp(yyvsp[-3].ucoresyn, yyvsp[-1].uttype); ;
- break;}
-case 97:
-#line 624 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcocase(yyvsp[-4].ucoresyn, yyvsp[-1].ucoresyn); ;
- break;}
-case 98:
-#line 626 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcolet(mkcononrec(yyvsp[-5].ucoresyn, yyvsp[-3].ucoresyn), yyvsp[0].ucoresyn); ;
- break;}
-case 99:
-#line 628 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcolet(mkcorec(yyvsp[-3].ulist), yyvsp[0].ucoresyn); ;
- break;}
-case 100:
-#line 630 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcoscc(yyvsp[-2].ucoresyn, yyvsp[0].ucoresyn); ;
- break;}
-case 101:
-#line 631 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcoliteral(yyvsp[0].uliteral); ;
- break;}
-case 102:
-#line 632 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcovar(yyvsp[0].ucoresyn); ;
- break;}
-case 103:
-#line 637 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcoalg_alts(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 104:
-#line 639 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcoprim_alts(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 105:
-#line 643 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 106:
-#line 644 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 107:
-#line 648 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcoalg_alt(yyvsp[-4].ucoresyn, yyvsp[-3].ulist, yyvsp[-1].ucoresyn); ;
- break;}
-case 108:
-#line 653 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 109:
-#line 654 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 110:
-#line 658 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcoprim_alt(yyvsp[-3].uliteral, yyvsp[-1].ucoresyn); ;
- break;}
-case 111:
-#line 662 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkconodeflt(); ;
- break;}
-case 112:
-#line 663 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcobinddeflt(yyvsp[-2].ucoresyn, yyvsp[0].ucoresyn); ;
- break;}
-case 113:
-#line 667 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].ucoresyn); ;
- break;}
-case 114:
-#line 668 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 115:
-#line 672 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcorec_pair(yyvsp[-2].ucoresyn, yyvsp[0].ucoresyn); ;
- break;}
-case 116:
-#line 676 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_preludedictscc(yyvsp[0].ucoresyn); ;
- break;}
-case 117:
-#line 677 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_alldictscc(yyvsp[-2].uhstring,yyvsp[-1].uhstring,yyvsp[0].ucoresyn); ;
- break;}
-case 118:
-#line 679 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_usercc(yyvsp[-4].uhstring,yyvsp[-3].uhstring,yyvsp[-2].uhstring,yyvsp[-1].ucoresyn,yyvsp[0].ucoresyn); ;
- break;}
-case 119:
-#line 681 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_autocc(yyvsp[-4].ucoresyn,yyvsp[-3].uhstring,yyvsp[-2].uhstring,yyvsp[-1].ucoresyn,yyvsp[0].ucoresyn); ;
- break;}
-case 120:
-#line 683 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_dictcc(yyvsp[-4].ucoresyn,yyvsp[-3].uhstring,yyvsp[-2].uhstring,yyvsp[-1].ucoresyn,yyvsp[0].ucoresyn); ;
- break;}
-case 121:
-#line 685 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_scc_noncaf(); ;
- break;}
-case 122:
-#line 686 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_scc_caf(); ;
- break;}
-case 123:
-#line 688 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_scc_nondupd(); ;
- break;}
-case 124:
-#line 689 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_scc_dupd(); ;
- break;}
-case 125:
-#line 692 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_sdselid(yyvsp[-1].uid, yyvsp[0].uid); ;
- break;}
-case 126:
-#line 693 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_classopid(yyvsp[-1].uid, yyvsp[0].uid); ;
- break;}
-case 127:
-#line 694 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_defmid(yyvsp[-1].uid, yyvsp[0].uid); ;
- break;}
-case 128:
-#line 696 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_dfunid(yyvsp[-3].uid, yyvsp[-1].uttype); ;
- break;}
-case 129:
-#line 698 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_constmid(yyvsp[-4].uid, yyvsp[-3].uid, yyvsp[-1].uttype); ;
- break;}
-case 130:
-#line 700 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_specid(yyvsp[-3].ucoresyn, yyvsp[-1].ulist); ;
- break;}
-case 131:
-#line 701 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_wrkrid(yyvsp[0].ucoresyn); ;
- break;}
-case 132:
-#line 702 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_orig_id(yyvsp[-1].uid, yyvsp[0].uid); ;
- break;}
-case 133:
-#line 703 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_orig_id(yyvsp[-1].uid, yyvsp[0].uid); ;
- break;}
-case 134:
-#line 704 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_id(yyvsp[0].uid); ;
- break;}
-case 135:
-#line 705 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_id(yyvsp[0].uid); ;
- break;}
-case 136:
-#line 710 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_ccall(yyvsp[-5].uid,0,yyvsp[-3].ulist,yyvsp[-2].uttype); ;
- break;}
-case 137:
-#line 712 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_ccall(yyvsp[-5].uid,1,yyvsp[-3].ulist,yyvsp[-2].uttype); ;
- break;}
-case 138:
-#line 714 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_casm(yyvsp[-5].uliteral,0,yyvsp[-3].ulist,yyvsp[-2].uttype); ;
- break;}
-case 139:
-#line 716 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_casm(yyvsp[-5].uliteral,1,yyvsp[-3].ulist,yyvsp[-2].uttype); ;
- break;}
-case 140:
-#line 717 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkco_primop(yyvsp[0].uid); ;
- break;}
-case 141:
-#line 721 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 142:
-#line 722 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 143:
-#line 726 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcobinder(yyvsp[-3].uid, yyvsp[-1].uttype); ;
- break;}
-case 144:
-#line 729 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 145:
-#line 730 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; ;
- break;}
-case 146:
-#line 734 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].ucoresyn); ;
- break;}
-case 147:
-#line 735 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].ucoresyn); ;
- break;}
-case 148:
-#line 739 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcolit(yyvsp[0].uliteral); ;
- break;}
-case 149:
-#line 740 "yaccParser/hsparser.y"
-{ yyval.ucoresyn = mkcolocal(yyvsp[0].ucoresyn); ;
- break;}
-case 150:
-#line 744 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uid); ;
- break;}
-case 151:
-#line 745 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].uid); ;
- break;}
-case 152:
-#line 749 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uid); ;
- break;}
-case 153:
-#line 750 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uid); ;
- break;}
-case 154:
-#line 754 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 155:
-#line 755 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; ;
- break;}
-case 156:
-#line 759 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 157:
-#line 760 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uttype); ;
- break;}
-case 158:
-#line 764 "yaccParser/hsparser.y"
-{ yyval.uttype = yyvsp[0].uttype; ;
- break;}
-case 159:
-#line 784 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 160:
-#line 785 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].uttype); ;
- break;}
-case 161:
-#line 789 "yaccParser/hsparser.y"
-{ yyval.uttype = mkty_maybe_nothing(); ;
- break;}
-case 162:
-#line 790 "yaccParser/hsparser.y"
-{ yyval.uttype = mkty_maybe_just(yyvsp[0].uttype); ;
- break;}
-case 163:
-#line 796 "yaccParser/hsparser.y"
-{
- if ( implicitPrelude && !etags ) {
- /* we try to avoid reading interfaces when etagging */
- find_module_on_imports_dirlist(
- (haskell1_3Flag) ? "PrelCore13" : "PreludeCore",
- TRUE,interface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename);
- }
- thisIfacePragmaVersion = 0;
- setyyin(interface_filename);
- enteriscope();
- ;
- break;}
-case 164:
-#line 810 "yaccParser/hsparser.y"
-{
- binding prelude_core = mkimport(installid(iface_name),Lnil,Lnil,yyvsp[0].ubinding,xstrdup(interface_filename),hsplineno);
- prelude_core_import = implicitPrelude? lsing(prelude_core): Lnil;
-
- ;
- break;}
-case 165:
-#line 818 "yaccParser/hsparser.y"
-{
- if ( implicitPrelude && !etags ) {
- find_module_on_imports_dirlist(
- ( haskell1_3Flag ) ? "Prel13" : "Prelude",
- TRUE,interface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename);
- }
- thisIfacePragmaVersion = 0;
- setyyin(interface_filename);
- enteriscope();
- ;
- break;}
-case 166:
-#line 831 "yaccParser/hsparser.y"
-{
- binding prelude = mkimport(installid(iface_name),Lnil,Lnil,yyvsp[0].ubinding,xstrdup(interface_filename),hsplineno);
- prelude_imports = (! implicitPrelude) ? Lnil
- : lconc(prelude_core_import,lsing(prelude));
- ;
- break;}
-case 167:
-#line 838 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 168:
-#line 839 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; ;
- break;}
-case 169:
-#line 842 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[0].ulist; ;
- break;}
-case 170:
-#line 843 "yaccParser/hsparser.y"
-{ yyval.ulist = lconc(yyvsp[-2].ulist,yyvsp[0].ulist); ;
- break;}
-case 171:
-#line 847 "yaccParser/hsparser.y"
-{ /* filename returned in "interface_filename" */
- char *module_name = id_to_string(yyvsp[0].uid);
- if ( ! etags ) {
- find_module_on_imports_dirlist(
- (haskell1_3Flag && strcmp(module_name, "Prelude") == 0)
- ? "Prel13" : module_name,
- FALSE, interface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename);
- }
- thisIfacePragmaVersion = 0;
- setyyin(interface_filename);
- enteriscope();
- if (strcmp(module_name,"PreludeCore")==0) {
- hsperror("Cannot explicitly import `PreludeCore'");
-
- } else if (strcmp(module_name,"Prelude")==0) {
- prelude_imports = prelude_core_import; /* unavoidable */
- }
- ;
- break;}
-case 172:
-#line 868 "yaccParser/hsparser.y"
-{
- if (hidden)
- yyvsp[0].ubinding->tag = hiding;
- yyval.ulist = lsing(yyvsp[0].ubinding);
- ;
- break;}
-case 173:
-#line 876 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkimport(installid(iface_name),yyvsp[0].ulist,Lnil,yyvsp[-1].ubinding,xstrdup(interface_filename),hsplineno); ;
- break;}
-case 174:
-#line 879 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkimport(installid(iface_name),yyvsp[-2].ulist,yyvsp[0].ulist,yyvsp[-3].ubinding,xstrdup(interface_filename),hsplineno); ;
- break;}
-case 175:
-#line 884 "yaccParser/hsparser.y"
-{
- exposeis(); /* partain: expose infix ops at level i+1 to level i */
- yyval.ubinding = yyvsp[-1].ubinding;
- ;
- break;}
-case 176:
-#line 890 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; ;
- break;}
-case 177:
-#line 894 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].ulist); ;
- break;}
-case 178:
-#line 895 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist, yyvsp[0].ulist); ;
- break;}
-case 179:
-#line 898 "yaccParser/hsparser.y"
-{ yyval.ulist = ldub(yyvsp[-2].uid,yyvsp[0].uid); ;
- break;}
-case 180:
-#line 899 "yaccParser/hsparser.y"
-{ yyval.ulist = ldub(yyvsp[-2].uid,yyvsp[0].uid); ;
- break;}
-case 181:
-#line 902 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknullbind(); ;
- break;}
-case 182:
-#line 903 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[-1].ubinding; ;
- break;}
-case 183:
-#line 906 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 184:
-#line 907 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding); ;
- break;}
-case 185:
-#line 911 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkmbind(yyvsp[-3].uid,yyvsp[-1].ulist,Lnil,startlineno); ;
- break;}
-case 186:
-#line 913 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkmbind(yyvsp[-5].uid,yyvsp[-3].ulist,yyvsp[0].ulist,startlineno); ;
- break;}
-case 187:
-#line 919 "yaccParser/hsparser.y"
-{ /* OLD 95/08: fixlist = Lnil; */
- strcpy(iface_name, id_to_string(yyvsp[0].uid));
- ;
- break;}
-case 188:
-#line 923 "yaccParser/hsparser.y"
-{
- /* WDP: not only do we not check the module name
- but we take the one in the interface to be what we really want
- -- we need this for Prelude jiggery-pokery. (Blech. KH)
- ToDo: possibly revert....
- checkmodname(modname,id_to_string($2));
- */
- yyval.ubinding = yyvsp[0].ubinding;
- ;
- break;}
-case 189:
-#line 936 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkabind(yyvsp[-3].ubinding,yyvsp[-1].ubinding);
- ;
- break;}
-case 190:
-#line 940 "yaccParser/hsparser.y"
-{
- yyval.ubinding = yyvsp[-1].ubinding;
- ;
- break;}
-case 191:
-#line 944 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkabind(yyvsp[-3].ubinding,yyvsp[-1].ubinding);
- ;
- break;}
-case 192:
-#line 948 "yaccParser/hsparser.y"
-{
- yyval.ubinding = yyvsp[-1].ubinding;
- ;
- break;}
-case 197:
-#line 963 "yaccParser/hsparser.y"
-{ Precedence = checkfixity(yyvsp[0].ustring); Fixity = INFIXL; ;
- break;}
-case 199:
-#line 966 "yaccParser/hsparser.y"
-{ Precedence = checkfixity(yyvsp[0].ustring); Fixity = INFIXR; ;
- break;}
-case 201:
-#line 969 "yaccParser/hsparser.y"
-{ Precedence = checkfixity(yyvsp[0].ustring); Fixity = INFIX; ;
- break;}
-case 203:
-#line 972 "yaccParser/hsparser.y"
-{ Fixity = INFIXL; Precedence = 9; ;
- break;}
-case 205:
-#line 975 "yaccParser/hsparser.y"
-{ Fixity = INFIXR; Precedence = 9; ;
- break;}
-case 207:
-#line 978 "yaccParser/hsparser.y"
-{ Fixity = INFIX; Precedence = 9; ;
- break;}
-case 209:
-#line 982 "yaccParser/hsparser.y"
-{ makeinfix(id_to_string(yyvsp[0].uid),Fixity,Precedence); ;
- break;}
-case 210:
-#line 983 "yaccParser/hsparser.y"
-{ makeinfix(id_to_string(yyvsp[0].uid),Fixity,Precedence); ;
- break;}
-case 212:
-#line 988 "yaccParser/hsparser.y"
-{
- if(yyvsp[-2].ubinding != NULL)
- if(yyvsp[0].ubinding != NULL)
- if(SAMEFN)
- {
- extendfn(yyvsp[-2].ubinding,yyvsp[0].ubinding);
- yyval.ubinding = yyvsp[-2].ubinding;
- }
- else
- yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding);
- else
- yyval.ubinding = yyvsp[-2].ubinding;
- else
- yyval.ubinding = yyvsp[0].ubinding;
- SAMEFN = 0;
- ;
- break;}
-case 213:
-#line 1006 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 214:
-#line 1007 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 215:
-#line 1008 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 216:
-#line 1009 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 217:
-#line 1010 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 218:
-#line 1011 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 219:
-#line 1014 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknbind(yyvsp[-2].uttype,yyvsp[0].uttype,startlineno,mkno_pragma()); ;
- break;}
-case 220:
-#line 1019 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(yyvsp[-4].ulist,yyvsp[-2].uttype,yyvsp[0].ulist,all,startlineno,mkno_pragma()); ;
- break;}
-case 221:
-#line 1021 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(Lnil,yyvsp[-2].uttype,yyvsp[0].ulist,all,startlineno,mkno_pragma()); ;
- break;}
-case 222:
-#line 1023 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(yyvsp[-6].ulist,yyvsp[-4].uttype,yyvsp[-2].ulist,yyvsp[0].ulist,startlineno,mkno_pragma()); ;
- break;}
-case 223:
-#line 1025 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(Lnil,yyvsp[-4].uttype,yyvsp[-2].ulist,yyvsp[0].ulist,startlineno,mkno_pragma()); ;
- break;}
-case 224:
-#line 1028 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkcbind(yyvsp[-3].ulist,yyvsp[-1].uttype,yyvsp[0].ubinding,startlineno,mkno_pragma()); ;
- break;}
-case 225:
-#line 1029 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkcbind(Lnil,yyvsp[-1].uttype,yyvsp[0].ubinding,startlineno,mkno_pragma()); ;
- break;}
-case 226:
-#line 1032 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknullbind(); ;
- break;}
-case 227:
-#line 1033 "yaccParser/hsparser.y"
-{ checkorder(yyvsp[-1].ubinding); yyval.ubinding = yyvsp[-1].ubinding; ;
- break;}
-case 228:
-#line 1034 "yaccParser/hsparser.y"
-{ checkorder(yyvsp[-1].ubinding); yyval.ubinding =yyvsp[-1].ubinding; ;
- break;}
-case 229:
-#line 1037 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkibind(yyvsp[-4].ulist,yyvsp[-2].uid,yyvsp[-1].uttype,yyvsp[0].ubinding,startlineno,mkno_pragma()); ;
- break;}
-case 230:
-#line 1038 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkibind(Lnil,yyvsp[-2].uid,yyvsp[-1].uttype,yyvsp[0].ubinding,startlineno,mkno_pragma()); ;
- break;}
-case 231:
-#line 1041 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknullbind(); ;
- break;}
-case 232:
-#line 1042 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[-1].ubinding; ;
- break;}
-case 233:
-#line 1043 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[-1].ubinding; ;
- break;}
-case 234:
-#line 1046 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[0].uid,Lnil); ;
- break;}
-case 235:
-#line 1047 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[-2].uid,yyvsp[-1].ulist); ;
- break;}
-case 236:
-#line 1048 "yaccParser/hsparser.y"
-{ yyval.uttype = mkttuple(mklcons(yyvsp[-3].uttype,yyvsp[-1].ulist)); ;
- break;}
-case 237:
-#line 1049 "yaccParser/hsparser.y"
-{ yyval.uttype = mkttuple(Lnil); ;
- break;}
-case 238:
-#line 1050 "yaccParser/hsparser.y"
-{ yyval.uttype = mktllist(yyvsp[-1].uttype); ;
- break;}
-case 239:
-#line 1051 "yaccParser/hsparser.y"
-{ yyval.uttype = mktfun(yyvsp[-3].uttype,yyvsp[-1].uttype); ;
- break;}
-case 240:
-#line 1054 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[0].uid,Lnil); ;
- break;}
-case 241:
-#line 1055 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[-2].uid,yyvsp[-1].ulist); ;
- break;}
-case 242:
-#line 1056 "yaccParser/hsparser.y"
-{ yyval.uttype = mkttuple(mklcons(yyvsp[-3].uttype,yyvsp[-1].ulist)); ;
- break;}
-case 243:
-#line 1057 "yaccParser/hsparser.y"
-{ yyval.uttype = mkttuple(Lnil); ;
- break;}
-case 244:
-#line 1058 "yaccParser/hsparser.y"
-{ yyval.uttype = mktllist(yyvsp[-1].uttype); ;
- break;}
-case 245:
-#line 1059 "yaccParser/hsparser.y"
-{ yyval.uttype = mktfun(yyvsp[-3].uttype,yyvsp[-1].uttype); ;
- break;}
-case 246:
-#line 1062 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkdbind(yyvsp[0].ulist,startlineno); ;
- break;}
-case 247:
-#line 1065 "yaccParser/hsparser.y"
-{ yyval.ulist = mklcons(yyvsp[-3].uttype,yyvsp[-1].ulist); ;
- break;}
-case 248:
-#line 1066 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 250:
-#line 1075 "yaccParser/hsparser.y"
-{
- if(SAMEFN)
- {
- extendfn(yyvsp[-2].ubinding,yyvsp[0].ubinding);
- yyval.ubinding = yyvsp[-2].ubinding;
- }
- else
- yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding);
- ;
- break;}
-case 251:
-#line 1104 "yaccParser/hsparser.y"
-{ /* type2context.c for code */
- yyval.ubinding = mksbind(yyvsp[-5].ulist,mkcontext(type2context(yyvsp[-3].uttype),yyvsp[-1].uttype),startlineno,yyvsp[0].uhpragma);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 252:
-#line 1109 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mksbind(yyvsp[-3].ulist,yyvsp[-1].uttype,startlineno,yyvsp[0].uhpragma);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 253:
-#line 1122 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkvspec_uprag(yyvsp[-3].uid, yyvsp[-1].ulist, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 254:
-#line 1128 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkispec_uprag(yyvsp[-2].uid, yyvsp[-1].uttype, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 255:
-#line 1134 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkdspec_uprag(yyvsp[-2].uid, yyvsp[-1].ulist, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 256:
-#line 1140 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkinline_uprag(yyvsp[-2].uid, yyvsp[-1].ulist, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 257:
-#line 1146 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkmagicuf_uprag(yyvsp[-2].uid, yyvsp[-1].uid, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 258:
-#line 1152 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkdeforest_uprag(yyvsp[-1].uid, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 259:
-#line 1158 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkabstract_uprag(yyvsp[-1].uid, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 261:
-#line 1166 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; ;
- break;}
-case 262:
-#line 1170 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 263:
-#line 1171 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uid); ;
- break;}
-case 264:
-#line 1174 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].ubinding); ;
- break;}
-case 265:
-#line 1175 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].ubinding); ;
- break;}
-case 266:
-#line 1179 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkvspec_ty_and_id(yyvsp[0].uttype,Lnil); ;
- break;}
-case 267:
-#line 1180 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkvspec_ty_and_id(yyvsp[-2].uttype,lsing(yyvsp[0].uid)); ;
- break;}
-case 268:
-#line 1182 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 269:
-#line 1183 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding); ;
- break;}
-case 270:
-#line 1186 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 271:
-#line 1187 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 272:
-#line 1188 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 273:
-#line 1189 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 274:
-#line 1190 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 275:
-#line 1191 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknullbind(); ;
- break;}
-case 276:
-#line 1196 "yaccParser/hsparser.y"
-{ yyval.ubinding = mksbind(yyvsp[-5].ulist,mkcontext(type2context(yyvsp[-3].uttype),yyvsp[-1].uttype),startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 277:
-#line 1198 "yaccParser/hsparser.y"
-{ yyval.ubinding = mksbind(yyvsp[-3].ulist,yyvsp[-1].uttype,startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 278:
-#line 1202 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknbind(yyvsp[-3].uttype,yyvsp[-1].uttype,startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 279:
-#line 1206 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(yyvsp[-3].ulist,yyvsp[-1].uttype,Lnil,Lnil,startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 280:
-#line 1208 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(Lnil,yyvsp[-1].uttype,Lnil,Lnil,startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 281:
-#line 1210 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(yyvsp[-5].ulist,yyvsp[-3].uttype,yyvsp[-1].ulist,Lnil,startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 282:
-#line 1212 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(Lnil,yyvsp[-3].uttype,yyvsp[-1].ulist,Lnil,startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 283:
-#line 1214 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(yyvsp[-6].ulist,yyvsp[-4].uttype,yyvsp[-2].ulist,yyvsp[0].ulist,startlineno,mkno_pragma()); ;
- break;}
-case 284:
-#line 1216 "yaccParser/hsparser.y"
-{ yyval.ubinding = mktbind(Lnil,yyvsp[-4].uttype,yyvsp[-2].ulist,yyvsp[0].ulist,startlineno,mkno_pragma()); ;
- break;}
-case 285:
-#line 1220 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkcbind(yyvsp[-4].ulist,yyvsp[-2].uttype,yyvsp[0].ubinding,startlineno,yyvsp[-1].uhpragma); ;
- break;}
-case 286:
-#line 1222 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkcbind(Lnil,yyvsp[-2].uttype,yyvsp[0].ubinding,startlineno,yyvsp[-1].uhpragma); ;
- break;}
-case 287:
-#line 1226 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkibind(yyvsp[-4].ulist,yyvsp[-2].uid,yyvsp[-1].uttype,mknullbind(),startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 288:
-#line 1228 "yaccParser/hsparser.y"
-{ yyval.ubinding = mkibind(Lnil,yyvsp[-2].uid,yyvsp[-1].uttype,mknullbind(),startlineno,yyvsp[0].uhpragma); ;
- break;}
-case 289:
-#line 1234 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[-1].uid,lsing(yyvsp[0].uttype)); ;
- break;}
-case 290:
-#line 1238 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 291:
-#line 1239 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uttype); ;
- break;}
-case 292:
-#line 1242 "yaccParser/hsparser.y"
-{ yyval.uttype = yyvsp[0].uttype; ;
- break;}
-case 293:
-#line 1243 "yaccParser/hsparser.y"
-{ yyval.uttype = mktfun(yyvsp[-2].uttype,yyvsp[0].uttype); ;
- break;}
-case 294:
-#line 1246 "yaccParser/hsparser.y"
-{ yyval.uttype = mkuniforall(yyvsp[-2].ulist, yyvsp[0].uttype); ;
- break;}
-case 295:
-#line 1248 "yaccParser/hsparser.y"
-{ yyval.uttype = yyvsp[0].uttype; ;
- break;}
-case 296:
-#line 1249 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[-1].uid,yyvsp[0].ulist); ;
- break;}
-case 297:
-#line 1252 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-1].ulist,yyvsp[0].uttype); ;
- break;}
-case 298:
-#line 1253 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 299:
-#line 1257 "yaccParser/hsparser.y"
-{ yyval.uttype = yyvsp[0].uttype; ;
- break;}
-case 300:
-#line 1258 "yaccParser/hsparser.y"
-{ yyval.uttype = mktfun(yyvsp[-2].uttype,yyvsp[0].uttype); ;
- break;}
-case 301:
-#line 1259 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[-1].uid,yyvsp[0].ulist); ;
- break;}
-case 303:
-#line 1263 "yaccParser/hsparser.y"
-{ yyval.uttype = mkttuple(mklcons(yyvsp[-3].uttype,yyvsp[-1].ulist)); ;
- break;}
-case 304:
-#line 1266 "yaccParser/hsparser.y"
-{ yyval.uttype = yyvsp[0].uttype; ;
- break;}
-case 305:
-#line 1267 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[0].uid,Lnil); ;
- break;}
-case 306:
-#line 1268 "yaccParser/hsparser.y"
-{ yyval.uttype = mkttuple(Lnil); ;
- break;}
-case 307:
-#line 1269 "yaccParser/hsparser.y"
-{ yyval.uttype = yyvsp[-1].uttype; ;
- break;}
-case 308:
-#line 1270 "yaccParser/hsparser.y"
-{ yyval.uttype = mktllist(yyvsp[-1].uttype); ;
- break;}
-case 309:
-#line 1273 "yaccParser/hsparser.y"
-{ yyval.uttype = mkunidict(yyvsp[-3].uid, yyvsp[-2].uttype); ;
- break;}
-case 310:
-#line 1274 "yaccParser/hsparser.y"
-{ yyval.uttype = mkunityvartemplate(yyvsp[0].uid); ;
- break;}
-case 311:
-#line 1278 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[0].uid,Lnil); ;
- break;}
-case 312:
-#line 1279 "yaccParser/hsparser.y"
-{ yyval.uttype = mktname(yyvsp[-1].uid,yyvsp[0].ulist); ;
- break;}
-case 313:
-#line 1282 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uatype); ;
- break;}
-case 314:
-#line 1283 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uatype); ;
- break;}
-case 315:
-#line 1287 "yaccParser/hsparser.y"
-{ yyval.uatype = mkatc(yyvsp[-1].uid,yyvsp[0].ulist,hsplineno); ;
- break;}
-case 316:
-#line 1288 "yaccParser/hsparser.y"
-{ yyval.uatype = mkatc(yyvsp[-2].uid,yyvsp[0].ulist,hsplineno); ;
- break;}
-case 317:
-#line 1289 "yaccParser/hsparser.y"
-{ yyval.uatype = mkatc(yyvsp[0].uid,Lnil,hsplineno); ;
- break;}
-case 318:
-#line 1290 "yaccParser/hsparser.y"
-{ yyval.uatype = mkatc(yyvsp[-1].uid,Lnil,hsplineno); ;
- break;}
-case 319:
-#line 1291 "yaccParser/hsparser.y"
-{ yyval.uatype = mkatc(yyvsp[-1].uid, ldub(yyvsp[-2].uttype,yyvsp[0].uttype),hsplineno); ;
- break;}
-case 320:
-#line 1294 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; ;
- break;}
-case 321:
-#line 1295 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 322:
-#line 1296 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uid); ;
- break;}
-case 323:
-#line 1299 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uid); ;
- break;}
-case 324:
-#line 1300 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uid); ;
- break;}
-case 325:
-#line 1303 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[-1].ulist; ;
- break;}
-case 326:
-#line 1304 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 327:
-#line 1307 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 328:
-#line 1308 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uttype); ;
- break;}
-case 329:
-#line 1311 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknullbind(); ;
- break;}
-case 330:
-#line 1312 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[0].ubinding; ;
- break;}
-case 331:
-#line 1314 "yaccParser/hsparser.y"
-{
- if(SAMEFN)
- {
- extendfn(yyvsp[-2].ubinding,yyvsp[0].ubinding);
- yyval.ubinding = yyvsp[-2].ubinding;
- }
- else
- yyval.ubinding = mkabind(yyvsp[-2].ubinding,yyvsp[0].ubinding);
- ;
- break;}
-case 332:
-#line 1328 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkvspec_uprag(yyvsp[-3].uid, yyvsp[-1].ulist, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 333:
-#line 1334 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkinline_uprag(yyvsp[-2].uid, yyvsp[-1].ulist, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 334:
-#line 1340 "yaccParser/hsparser.y"
-{
- yyval.ubinding = mkmagicuf_uprag(yyvsp[-2].uid, yyvsp[-1].uid, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- ;
- break;}
-case 336:
-#line 1349 "yaccParser/hsparser.y"
-{ yyval.ulist = mklcons(yyvsp[-2].uid,yyvsp[0].ulist); ;
- break;}
-case 337:
-#line 1350 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uid); ;
- break;}
-case 338:
-#line 1353 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uid); ;
- break;}
-case 339:
-#line 1354 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uid); ;
- break;}
-case 340:
-#line 1357 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uid); ;
- break;}
-case 341:
-#line 1358 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uid); ;
- break;}
-case 342:
-#line 1363 "yaccParser/hsparser.y"
-{
- tree fn = function(yyvsp[0].utree);
-
- PREVPATT = yyvsp[0].utree;
-
- if(ttree(fn) == ident)
- {
- checksamefn(gident((struct Sident *) fn));
- FN = fn;
- }
-
- else if (ttree(fn) == tinfixop && ttree(ginfun((struct Sap *) fn)) == ident)
- {
- checksamefn(gident((struct Sident *) (ginfun((struct Sap *) fn))));
- FN = ginfun((struct Sap *) fn);
- }
-
- else if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tvaldef\n",startlineno);
-#endif
- ;
- break;}
-case 343:
-#line 1388 "yaccParser/hsparser.y"
-{
- if ( lhs_is_patt(yyvsp[-2].utree) )
- {
- yyval.ubinding = mkpbind(yyvsp[0].ulist, startlineno);
- FN = NULL;
- SAMEFN = 0;
- }
- else /* lhs is function */
- yyval.ubinding = mkfbind(yyvsp[0].ulist,startlineno);
-
- PREVPATT = NULL;
- ;
- break;}
-case 344:
-#line 1402 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(createpat(yyvsp[-1].ulist, yyvsp[0].ubinding)); ;
- break;}
-case 346:
-#line 1406 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(mktruecase(yyvsp[0].utree)); ;
- break;}
-case 347:
-#line 1409 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(ldub(yyvsp[-2].utree,yyvsp[0].utree)); ;
- break;}
-case 348:
-#line 1410 "yaccParser/hsparser.y"
-{ yyval.ulist = mklcons(ldub(yyvsp[-3].utree,yyvsp[-1].utree),yyvsp[0].ulist); ;
- break;}
-case 349:
-#line 1414 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[-1].ubinding; ;
- break;}
-case 350:
-#line 1415 "yaccParser/hsparser.y"
-{ yyval.ubinding = yyvsp[-1].ubinding; ;
- break;}
-case 351:
-#line 1416 "yaccParser/hsparser.y"
-{ yyval.ubinding = mknullbind(); ;
- break;}
-case 352:
-#line 1419 "yaccParser/hsparser.y"
-{ yyval.utree = yyvsp[0].utree; ;
- break;}
-case 353:
-#line 1423 "yaccParser/hsparser.y"
-{ yyval.ulist = mklcons(yyvsp[-1].utree,yyvsp[0].ulist); ;
- break;}
-case 354:
-#line 1424 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].utree); ;
- break;}
-case 355:
-#line 1434 "yaccParser/hsparser.y"
-{ yyval.utree = mkrestr(yyvsp[-4].utree,mkcontext(type2context(yyvsp[-2].uttype),yyvsp[0].uttype)); ;
- break;}
-case 356:
-#line 1435 "yaccParser/hsparser.y"
-{ yyval.utree = mkrestr(yyvsp[-2].utree,yyvsp[0].uttype); ;
- break;}
-case 359:
-#line 1447 "yaccParser/hsparser.y"
-{ yyval.utree = mkinfixop(yyvsp[-1].uid,yyvsp[-2].utree,yyvsp[0].utree); precparse(yyval.utree); ;
- break;}
-case 360:
-#line 1456 "yaccParser/hsparser.y"
-{ yyval.utree = mknegate(yyvsp[0].utree); ;
- break;}
-case 362:
-#line 1465 "yaccParser/hsparser.y"
-{ /* enteriscope(); /? I don't understand this -- KH */
- hsincindent(); /* added by partain; push new context for */
- /* FN = NULL; not actually concerned about */
- FN = NULL; /* indenting */
- yyval.uint = hsplineno; /* remember current line number */
- ;
- break;}
-case 363:
-#line 1472 "yaccParser/hsparser.y"
-{ hsendindent(); /* added by partain */
- /* exitiscope(); /? Also not understood */
- ;
- break;}
-case 364:
-#line 1476 "yaccParser/hsparser.y"
-{
- yyval.utree = mklambda(yyvsp[-3].ulist, yyvsp[0].utree, yyvsp[-4].uint);
- ;
- break;}
-case 365:
-#line 1481 "yaccParser/hsparser.y"
-{ yyval.utree = mklet(yyvsp[-3].ubinding,yyvsp[0].utree); ;
- break;}
-case 366:
-#line 1482 "yaccParser/hsparser.y"
-{ yyval.utree = mklet(yyvsp[-3].ubinding,yyvsp[0].utree); ;
- break;}
-case 367:
-#line 1485 "yaccParser/hsparser.y"
-{ yyval.utree = mkife(yyvsp[-4].utree,yyvsp[-2].utree,yyvsp[0].utree); ;
- break;}
-case 368:
-#line 1488 "yaccParser/hsparser.y"
-{ yyval.utree = mkcasee(yyvsp[-4].utree,yyvsp[-1].ulist); ;
- break;}
-case 369:
-#line 1489 "yaccParser/hsparser.y"
-{ yyval.utree = mkcasee(yyvsp[-4].utree,yyvsp[-1].ulist); ;
- break;}
-case 370:
-#line 1492 "yaccParser/hsparser.y"
-{ yyval.utree = mkccall(yyvsp[-1].uid,installid("n"),yyvsp[0].ulist); ;
- break;}
-case 371:
-#line 1493 "yaccParser/hsparser.y"
-{ yyval.utree = mkccall(yyvsp[0].uid,installid("n"),Lnil); ;
- break;}
-case 372:
-#line 1494 "yaccParser/hsparser.y"
-{ yyval.utree = mkccall(yyvsp[-1].uid,installid("p"),yyvsp[0].ulist); ;
- break;}
-case 373:
-#line 1495 "yaccParser/hsparser.y"
-{ yyval.utree = mkccall(yyvsp[0].uid,installid("p"),Lnil); ;
- break;}
-case 374:
-#line 1496 "yaccParser/hsparser.y"
-{ yyval.utree = mkccall(yyvsp[-1].ustring,installid("N"),yyvsp[0].ulist); ;
- break;}
-case 375:
-#line 1497 "yaccParser/hsparser.y"
-{ yyval.utree = mkccall(yyvsp[0].ustring,installid("N"),Lnil); ;
- break;}
-case 376:
-#line 1498 "yaccParser/hsparser.y"
-{ yyval.utree = mkccall(yyvsp[-1].ustring,installid("P"),yyvsp[0].ulist); ;
- break;}
-case 377:
-#line 1499 "yaccParser/hsparser.y"
-{ yyval.utree = mkccall(yyvsp[0].ustring,installid("P"),Lnil); ;
- break;}
-case 378:
-#line 1503 "yaccParser/hsparser.y"
-{ if (ignoreSCC) {
- if (warnSCC)
- fprintf(stderr,
- "\"%s\", line %d: _scc_ (`set [profiling] cost centre') ignored\n",
- input_filename, hsplineno);
- yyval.utree = yyvsp[0].utree;
- } else {
- yyval.utree = mkscc(yyvsp[-1].uhstring, yyvsp[0].utree);
- }
- ;
- break;}
-case 380:
-#line 1518 "yaccParser/hsparser.y"
-{ yyval.utree = mkap(yyvsp[-1].utree,yyvsp[0].utree); ;
- break;}
-case 382:
-#line 1522 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-1].ulist,yyvsp[0].utree); ;
- break;}
-case 383:
-#line 1523 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].utree); ;
- break;}
-case 384:
-#line 1533 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 385:
-#line 1534 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 386:
-#line 1535 "yaccParser/hsparser.y"
-{ yyval.utree = mklit(yyvsp[0].uliteral); ;
- break;}
-case 387:
-#line 1536 "yaccParser/hsparser.y"
-{ yyval.utree = mkpar(yyvsp[-1].utree); ;
- break;}
-case 388:
-#line 1537 "yaccParser/hsparser.y"
-{ checkprec(yyvsp[-2].utree,yyvsp[-1].uid,FALSE); yyval.utree = mklsection(yyvsp[-2].utree,yyvsp[-1].uid); ;
- break;}
-case 389:
-#line 1538 "yaccParser/hsparser.y"
-{ checkprec(yyvsp[-1].utree,yyvsp[-2].uid,TRUE); yyval.utree = mkrsection(yyvsp[-2].uid,yyvsp[-1].utree); ;
- break;}
-case 391:
-#line 1542 "yaccParser/hsparser.y"
-{ yyval.utree = mkpar(yyvsp[0].utree); ;
- break;}
-case 392:
-#line 1543 "yaccParser/hsparser.y"
-{ yyval.utree = mkpar(yyvsp[0].utree); ;
- break;}
-case 393:
-#line 1544 "yaccParser/hsparser.y"
-{ yyval.utree = mkpar(yyvsp[0].utree); ;
- break;}
-case 394:
-#line 1547 "yaccParser/hsparser.y"
-{ checkinpat(); yyval.utree = mkas(yyvsp[-2].uid,yyvsp[0].utree); ;
- break;}
-case 395:
-#line 1548 "yaccParser/hsparser.y"
-{ checkinpat(); yyval.utree = mkwildp(); ;
- break;}
-case 396:
-#line 1549 "yaccParser/hsparser.y"
-{ checkinpat(); yyval.utree = mklazyp(yyvsp[0].utree); ;
- break;}
-case 398:
-#line 1564 "yaccParser/hsparser.y"
-{
- yyval.utree = mkinfixop(yyvsp[-1].uid,yyvsp[-2].utree,yyvsp[0].utree);
-
- if(isconstr(id_to_string(yyvsp[-1].uid)))
- precparse(yyval.utree);
- else
- {
- checkprec(yyvsp[-2].utree,yyvsp[-1].uid,FALSE); /* Check the precedence of the left pattern */
- checkprec(yyvsp[0].utree,yyvsp[-1].uid,TRUE); /* then check the right pattern */
- }
- ;
- break;}
-case 400:
-#line 1579 "yaccParser/hsparser.y"
-{
- yyval.utree = mkinfixop(yyvsp[-1].uid,yyvsp[-2].utree,yyvsp[0].utree);
-
- if(isconstr(id_to_string(yyvsp[-1].uid)))
- precparse(yyval.utree);
- else
- {
- checkprec(yyvsp[-2].utree,yyvsp[-1].uid,FALSE); /* Check the precedence of the left pattern */
- checkprec(yyvsp[0].utree,yyvsp[-1].uid,TRUE); /* then check the right pattern */
- }
- ;
- break;}
-case 401:
-#line 1598 "yaccParser/hsparser.y"
-{ yyval.utree = mknegate(yyvsp[0].utree); ;
- break;}
-case 403:
-#line 1603 "yaccParser/hsparser.y"
-{ yyval.utree = mkap(yyvsp[-1].utree,yyvsp[0].utree); ;
- break;}
-case 405:
-#line 1607 "yaccParser/hsparser.y"
-{ yyval.utree = mknegate(yyvsp[0].utree); ;
- break;}
-case 407:
-#line 1612 "yaccParser/hsparser.y"
-{ yyval.utree = mkap(yyvsp[-1].utree,yyvsp[0].utree); ;
- break;}
-case 409:
-#line 1616 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 410:
-#line 1617 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 411:
-#line 1618 "yaccParser/hsparser.y"
-{ yyval.utree = mkas(yyvsp[-2].uid,yyvsp[0].utree); ;
- break;}
-case 412:
-#line 1619 "yaccParser/hsparser.y"
-{ yyval.utree = mklit(yyvsp[0].uliteral); ;
- break;}
-case 413:
-#line 1620 "yaccParser/hsparser.y"
-{ yyval.utree = mkwildp(); ;
- break;}
-case 414:
-#line 1621 "yaccParser/hsparser.y"
-{ yyval.utree = mktuple(Lnil); ;
- break;}
-case 415:
-#line 1622 "yaccParser/hsparser.y"
-{ yyval.utree = mkplusp(mkident(yyvsp[-3].uid),mkinteger(yyvsp[-1].ustring)); ;
- break;}
-case 416:
-#line 1626 "yaccParser/hsparser.y"
-{ yyval.utree = mkpar(yyvsp[-1].utree); ;
- break;}
-case 417:
-#line 1627 "yaccParser/hsparser.y"
-{ yyval.utree = mktuple(mklcons(yyvsp[-3].utree,yyvsp[-1].ulist)); ;
- break;}
-case 418:
-#line 1628 "yaccParser/hsparser.y"
-{ yyval.utree = mkllist(yyvsp[-1].ulist); ;
- break;}
-case 419:
-#line 1629 "yaccParser/hsparser.y"
-{ yyval.utree = mkllist(Lnil); ;
- break;}
-case 420:
-#line 1630 "yaccParser/hsparser.y"
-{ yyval.utree = mklazyp(yyvsp[0].utree); ;
- break;}
-case 421:
-#line 1633 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 422:
-#line 1634 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 423:
-#line 1635 "yaccParser/hsparser.y"
-{ yyval.utree = mkas(yyvsp[-2].uid,yyvsp[0].utree); ;
- break;}
-case 424:
-#line 1636 "yaccParser/hsparser.y"
-{ yyval.utree = mklit(yyvsp[0].uliteral); setstartlineno(); ;
- break;}
-case 425:
-#line 1637 "yaccParser/hsparser.y"
-{ yyval.utree = mkwildp(); setstartlineno(); ;
- break;}
-case 426:
-#line 1638 "yaccParser/hsparser.y"
-{ yyval.utree = mktuple(Lnil); ;
- break;}
-case 427:
-#line 1639 "yaccParser/hsparser.y"
-{ yyval.utree = mkplusp(mkident(yyvsp[-3].uid),mkinteger(yyvsp[-1].ustring)); ;
- break;}
-case 428:
-#line 1643 "yaccParser/hsparser.y"
-{ yyval.utree = mkpar(yyvsp[-1].utree); ;
- break;}
-case 429:
-#line 1644 "yaccParser/hsparser.y"
-{ yyval.utree = mktuple(mklcons(yyvsp[-3].utree,yyvsp[-1].ulist)); ;
- break;}
-case 430:
-#line 1645 "yaccParser/hsparser.y"
-{ yyval.utree = mkllist(yyvsp[-1].ulist); ;
- break;}
-case 431:
-#line 1646 "yaccParser/hsparser.y"
-{ yyval.utree = mkllist(Lnil); ;
- break;}
-case 432:
-#line 1647 "yaccParser/hsparser.y"
-{ yyval.utree = mklazyp(yyvsp[0].utree); ;
- break;}
-case 433:
-#line 1652 "yaccParser/hsparser.y"
-{ if (ttree(yyvsp[-1].utree) == tuple)
- yyval.utree = mktuple(mklcons(yyvsp[-3].utree, gtuplelist((struct Stuple *) yyvsp[-1].utree)));
- else
- yyval.utree = mktuple(ldub(yyvsp[-3].utree, yyvsp[-1].utree));
- ;
- break;}
-case 434:
-#line 1658 "yaccParser/hsparser.y"
-{ yyval.utree = mktuple(Lnil); ;
- break;}
-case 435:
-#line 1666 "yaccParser/hsparser.y"
-{ yyval.utree = mkpar(yyvsp[0].utree); ;
- break;}
-case 436:
-#line 1668 "yaccParser/hsparser.y"
-{ if (ttree(yyvsp[0].utree) == tuple)
- yyval.utree = mktuple(mklcons(yyvsp[-2].utree, gtuplelist((struct Stuple *) yyvsp[0].utree)));
- else
- yyval.utree = mktuple(ldub(yyvsp[-2].utree, yyvsp[0].utree));
- ;
- break;}
-case 437:
-#line 1677 "yaccParser/hsparser.y"
-{ yyval.utree = mkllist(Lnil); ;
- break;}
-case 438:
-#line 1678 "yaccParser/hsparser.y"
-{ yyval.utree = mkllist(yyvsp[-1].ulist); ;
- break;}
-case 439:
-#line 1682 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].utree); ;
- break;}
-case 440:
-#line 1683 "yaccParser/hsparser.y"
-{ yyval.ulist = mklcons(yyvsp[-2].utree, yyvsp[0].ulist); ;
- break;}
-case 441:
-#line 1698 "yaccParser/hsparser.y"
-{yyval.utree = mkeenum(yyvsp[-5].utree,lsing(yyvsp[-3].utree),yyvsp[-1].ulist);;
- break;}
-case 442:
-#line 1699 "yaccParser/hsparser.y"
-{ yyval.utree = mkeenum(yyvsp[-3].utree,Lnil,yyvsp[-1].ulist); ;
- break;}
-case 443:
-#line 1702 "yaccParser/hsparser.y"
-{ yyval.utree = mkcomprh(yyvsp[-3].utree,yyvsp[-1].ulist); ;
- break;}
-case 444:
-#line 1705 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].utree); ;
- break;}
-case 445:
-#line 1706 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].utree); ;
- break;}
-case 446:
-#line 1709 "yaccParser/hsparser.y"
-{ inpat = TRUE; ;
- break;}
-case 447:
-#line 1709 "yaccParser/hsparser.y"
-{ inpat = FALSE; ;
- break;}
-case 448:
-#line 1710 "yaccParser/hsparser.y"
-{ if (yyvsp[0].utree == NULL) {
- patternOrExpr(/*wanted:*/ LEGIT_EXPR,yyvsp[-2].utree);
- yyval.utree = mkguard(yyvsp[-2].utree);
- } else {
- patternOrExpr(/*wanted:*/ LEGIT_PATT,yyvsp[-2].utree);
- yyval.utree = mkqual(yyvsp[-2].utree,yyvsp[0].utree);
-/* OLD: WDP 95/08
- if(ttree($4)==def)
- {
- tree prevpatt_save = PREVPATT;
- PREVPATT = $2;
- $$ = mkdef((tree) mkpbind(lsing(createpat(lsing(mktruecase(ggdef((struct Sdef *) $4))),mknullbind())),hsplineno));
- PREVPATT = prevpatt_save;
- }
- else
-*/
- }
- ;
- break;}
-case 449:
-#line 1730 "yaccParser/hsparser.y"
-{ yyval.utree = yyvsp[0].utree; ;
- break;}
-case 450:
-#line 1731 "yaccParser/hsparser.y"
-{ yyval.utree = NULL; ;
- break;}
-case 451:
-#line 1734 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[0].ulist; ;
- break;}
-case 452:
-#line 1735 "yaccParser/hsparser.y"
-{ yyval.ulist = lconc(yyvsp[-2].ulist,yyvsp[0].ulist); ;
- break;}
-case 453:
-#line 1739 "yaccParser/hsparser.y"
-{ PREVPATT = yyvsp[0].utree; ;
- break;}
-case 454:
-#line 1741 "yaccParser/hsparser.y"
-{ yyval.ulist = yyvsp[0].ulist;
- PREVPATT = NULL;
- ;
- break;}
-case 455:
-#line 1744 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 456:
-#line 1747 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(createpat(yyvsp[-1].ulist, yyvsp[0].ubinding)); ;
- break;}
-case 457:
-#line 1748 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(createpat(lsing(mktruecase(yyvsp[-1].utree)), yyvsp[0].ubinding)); ;
- break;}
-case 458:
-#line 1751 "yaccParser/hsparser.y"
-{ yyval.ulist = mklcons(ldub(yyvsp[-3].utree,yyvsp[-1].utree),yyvsp[0].ulist); ;
- break;}
-case 459:
-#line 1752 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(ldub(yyvsp[-2].utree,yyvsp[0].utree)); ;
- break;}
-case 460:
-#line 1755 "yaccParser/hsparser.y"
-{ yyval.ulist = Lnil; ;
- break;}
-case 461:
-#line 1756 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].utree); ;
- break;}
-case 462:
-#line 1759 "yaccParser/hsparser.y"
-{ yyval.ulist = mklcons(yyvsp[-2].utree, yyvsp[0].ulist); ;
- break;}
-case 463:
-#line 1760 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].utree); ;
- break;}
-case 465:
-#line 1765 "yaccParser/hsparser.y"
-{ yyval.utree = mkinfixop(yyvsp[-1].uid,yyvsp[-2].utree,yyvsp[0].utree); precparse(yyval.utree); ;
- break;}
-case 468:
-#line 1770 "yaccParser/hsparser.y"
-{ yyval.utree = mklit(mkinteger(ineg(yyvsp[0].ustring))); ;
- break;}
-case 469:
-#line 1771 "yaccParser/hsparser.y"
-{ yyval.utree = mklit(mkfloatr(ineg(yyvsp[0].ustring))); ;
- break;}
-case 470:
-#line 1774 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 471:
-#line 1775 "yaccParser/hsparser.y"
-{ yyval.utree = mkap(yyvsp[-1].utree,yyvsp[0].utree); ;
- break;}
-case 472:
-#line 1778 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 474:
-#line 1782 "yaccParser/hsparser.y"
-{ yyval.utree = mkident(yyvsp[0].uid); ;
- break;}
-case 475:
-#line 1783 "yaccParser/hsparser.y"
-{ yyval.utree = mkas(yyvsp[-2].uid,yyvsp[0].utree); ;
- break;}
-case 476:
-#line 1784 "yaccParser/hsparser.y"
-{ yyval.utree = mklit(yyvsp[0].uliteral); ;
- break;}
-case 477:
-#line 1785 "yaccParser/hsparser.y"
-{ yyval.utree = mkwildp(); ;
- break;}
-case 478:
-#line 1786 "yaccParser/hsparser.y"
-{ yyval.utree = mktuple(Lnil); ;
- break;}
-case 479:
-#line 1787 "yaccParser/hsparser.y"
-{ yyval.utree = mkplusp(mkident(yyvsp[-3].uid),mkinteger(yyvsp[-1].ustring)); ;
- break;}
-case 480:
-#line 1791 "yaccParser/hsparser.y"
-{ yyval.utree = mkpar(yyvsp[-1].utree); ;
- break;}
-case 481:
-#line 1792 "yaccParser/hsparser.y"
-{ yyval.utree = mktuple(mklcons(yyvsp[-3].utree,yyvsp[-1].ulist)); ;
- break;}
-case 482:
-#line 1793 "yaccParser/hsparser.y"
-{ yyval.utree = mkllist(yyvsp[-1].ulist); ;
- break;}
-case 483:
-#line 1794 "yaccParser/hsparser.y"
-{ yyval.utree = mkllist(Lnil); ;
- break;}
-case 484:
-#line 1795 "yaccParser/hsparser.y"
-{ yyval.utree = mklazyp(yyvsp[0].utree); ;
- break;}
-case 485:
-#line 1799 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkinteger(yyvsp[0].ustring); ;
- break;}
-case 486:
-#line 1800 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkfloatr(yyvsp[0].ustring); ;
- break;}
-case 487:
-#line 1801 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkcharr(yyvsp[0].uhstring); ;
- break;}
-case 488:
-#line 1802 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkstring(yyvsp[0].uhstring); ;
- break;}
-case 489:
-#line 1803 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkcharprim(yyvsp[0].uhstring); ;
- break;}
-case 490:
-#line 1804 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkstringprim(yyvsp[0].uhstring); ;
- break;}
-case 491:
-#line 1805 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkintprim(yyvsp[0].ustring); ;
- break;}
-case 492:
-#line 1806 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkfloatprim(yyvsp[0].ustring); ;
- break;}
-case 493:
-#line 1807 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkdoubleprim(yyvsp[0].ustring); ;
- break;}
-case 494:
-#line 1808 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkclitlit(yyvsp[0].ustring, ""); ;
- break;}
-case 495:
-#line 1809 "yaccParser/hsparser.y"
-{ yyval.uliteral = mkclitlit(yyvsp[-2].ustring, yyvsp[0].uid); ;
- break;}
-case 496:
-#line 1810 "yaccParser/hsparser.y"
-{ yyval.uliteral = mknorepi(yyvsp[0].ustring); ;
- break;}
-case 497:
-#line 1811 "yaccParser/hsparser.y"
-{ yyval.uliteral = mknorepr(yyvsp[-1].ustring, yyvsp[0].ustring); ;
- break;}
-case 498:
-#line 1812 "yaccParser/hsparser.y"
-{ yyval.uliteral = mknoreps(yyvsp[0].uhstring); ;
- break;}
-case 499:
-#line 1818 "yaccParser/hsparser.y"
-{ setstartlineno(); ;
- break;}
-case 500:
-#line 1821 "yaccParser/hsparser.y"
-{ setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tdata\n",startlineno);
-#endif
- ;
- break;}
-case 501:
-#line 1831 "yaccParser/hsparser.y"
-{ setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\ttype\n",startlineno);
-#endif
- ;
- break;}
-case 502:
-#line 1841 "yaccParser/hsparser.y"
-{ setstartlineno();
-#if 1/*etags*/
-/* OUT: if(etags)
- printf("%u\n",startlineno);
-*/
-#else
- fprintf(stderr,"%u\tinstance\n",startlineno);
-#endif
- ;
- break;}
-case 503:
-#line 1852 "yaccParser/hsparser.y"
-{ setstartlineno(); ;
- break;}
-case 504:
-#line 1855 "yaccParser/hsparser.y"
-{ setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tclass\n",startlineno);
-#endif
- ;
- break;}
-case 505:
-#line 1865 "yaccParser/hsparser.y"
-{ setstartlineno(); ;
- break;}
-case 506:
-#line 1868 "yaccParser/hsparser.y"
-{ setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tmodule\n",startlineno);
-#endif
- ;
- break;}
-case 507:
-#line 1878 "yaccParser/hsparser.y"
-{ setstartlineno(); ;
- break;}
-case 508:
-#line 1881 "yaccParser/hsparser.y"
-{ setstartlineno(); ;
- break;}
-case 509:
-#line 1884 "yaccParser/hsparser.y"
-{ setstartlineno(); ;
- break;}
-case 515:
-#line 1899 "yaccParser/hsparser.y"
-{ yyval.uid = yyvsp[-1].uid; ;
- break;}
-case 518:
-#line 1905 "yaccParser/hsparser.y"
-{ yyval.uid = yyvsp[-1].uid; ;
- break;}
-case 520:
-#line 1909 "yaccParser/hsparser.y"
-{ yyval.uid = yyvsp[-1].uid; ;
- break;}
-case 524:
-#line 1917 "yaccParser/hsparser.y"
-{ yyval.uid = install_literal("-"); ;
- break;}
-case 525:
-#line 1920 "yaccParser/hsparser.y"
-{ yyval.uid = install_literal("+"); ;
- break;}
-case 527:
-#line 1924 "yaccParser/hsparser.y"
-{ yyval.uid = yyvsp[-1].uid; ;
- break;}
-case 528:
-#line 1927 "yaccParser/hsparser.y"
-{ setstartlineno(); yyval.uid = yyvsp[0].uid; ;
- break;}
-case 529:
-#line 1928 "yaccParser/hsparser.y"
-{ yyval.uid = yyvsp[-1].uid; ;
- break;}
-case 531:
-#line 1933 "yaccParser/hsparser.y"
-{ yyval.uid = yyvsp[-1].uid; ;
- break;}
-case 532:
-#line 1936 "yaccParser/hsparser.y"
-{ setstartlineno(); yyval.uid = yyvsp[0].uid; ;
- break;}
-case 533:
-#line 1937 "yaccParser/hsparser.y"
-{ yyval.uid = yyvsp[-1].uid; ;
- break;}
-case 536:
-#line 1944 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 537:
-#line 1945 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-2].ulist,yyvsp[0].uttype); ;
- break;}
-case 538:
-#line 1948 "yaccParser/hsparser.y"
-{ yyval.ulist = lsing(yyvsp[0].uttype); ;
- break;}
-case 539:
-#line 1949 "yaccParser/hsparser.y"
-{ yyval.ulist = lapp(yyvsp[-1].ulist, yyvsp[0].uttype); ;
- break;}
-case 540:
-#line 1952 "yaccParser/hsparser.y"
-{ yyval.uttype = mknamedtvar(yyvsp[0].uid); ;
- break;}
-case 544:
-#line 1968 "yaccParser/hsparser.y"
-{ hsincindent(); ;
- break;}
-case 545:
-#line 1970 "yaccParser/hsparser.y"
-{ hssetindent(); ;
- break;}
-case 546:
-#line 1973 "yaccParser/hsparser.y"
-{ hsindentoff(); ;
- break;}
-case 547:
-#line 1978 "yaccParser/hsparser.y"
-{
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- ;
- break;}
-case 548:
-#line 1984 "yaccParser/hsparser.y"
-{ expect_ccurly = 1; ;
- break;}
-case 549:
-#line 1984 "yaccParser/hsparser.y"
-{ expect_ccurly = 0; ;
- break;}
-case 550:
-#line 1989 "yaccParser/hsparser.y"
-{
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- ;
- break;}
-case 551:
-#line 1994 "yaccParser/hsparser.y"
-{
- yyerrok;
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- ;
- break;}
-}
- /* the action file gets copied in in place of this dollarsign */
-#line 487 "/usr/local/gnu/share/bison.simple"
-\f
- yyvsp -= yylen;
- yyssp -= yylen;
-#ifdef YYLSP_NEEDED
- yylsp -= yylen;
-#endif
-
-#if YYDEBUG != 0
- if (yydebug)
- {
- short *ssp1 = yyss - 1;
- fprintf (stderr, "state stack now");
- while (ssp1 != yyssp)
- fprintf (stderr, " %d", *++ssp1);
- fprintf (stderr, "\n");
- }
-#endif
-
- *++yyvsp = yyval;
-
-#ifdef YYLSP_NEEDED
- yylsp++;
- if (yylen == 0)
- {
- yylsp->first_line = yylloc.first_line;
- yylsp->first_column = yylloc.first_column;
- yylsp->last_line = (yylsp-1)->last_line;
- yylsp->last_column = (yylsp-1)->last_column;
- yylsp->text = 0;
- }
- else
- {
- yylsp->last_line = (yylsp+yylen-1)->last_line;
- yylsp->last_column = (yylsp+yylen-1)->last_column;
- }
-#endif
-
- /* Now "shift" the result of the reduction.
- Determine what state that goes to,
- based on the state we popped back to
- and the rule number reduced by. */
-
- yyn = yyr1[yyn];
-
- yystate = yypgoto[yyn - YYNTBASE] + *yyssp;
- if (yystate >= 0 && yystate <= YYLAST && yycheck[yystate] == *yyssp)
- yystate = yytable[yystate];
- else
- yystate = yydefgoto[yyn - YYNTBASE];
-
- goto yynewstate;
-
-yyerrlab: /* here on detecting error */
-
- if (! yyerrstatus)
- /* If not already recovering from an error, report this error. */
- {
- ++yynerrs;
-
-#ifdef YYERROR_VERBOSE
- yyn = yypact[yystate];
-
- if (yyn > YYFLAG && yyn < YYLAST)
- {
- int size = 0;
- char *msg;
- int x, count;
-
- count = 0;
- /* Start X at -yyn if nec to avoid negative indexes in yycheck. */
- for (x = (yyn < 0 ? -yyn : 0);
- x < (sizeof(yytname) / sizeof(char *)); x++)
- if (yycheck[x + yyn] == x)
- size += strlen(yytname[x]) + 15, count++;
- msg = (char *) malloc(size + 15);
- if (msg != 0)
- {
- strcpy(msg, "parse error");
-
- if (count < 5)
- {
- count = 0;
- for (x = (yyn < 0 ? -yyn : 0);
- x < (sizeof(yytname) / sizeof(char *)); x++)
- if (yycheck[x + yyn] == x)
- {
- strcat(msg, count == 0 ? ", expecting `" : " or `");
- strcat(msg, yytname[x]);
- strcat(msg, "'");
- count++;
- }
- }
- yyerror(msg);
- free(msg);
- }
- else
- yyerror ("parse error; also virtual memory exceeded");
- }
- else
-#endif /* YYERROR_VERBOSE */
- yyerror("parse error");
- }
-
- goto yyerrlab1;
-yyerrlab1: /* here on error raised explicitly by an action */
-
- if (yyerrstatus == 3)
- {
- /* if just tried and failed to reuse lookahead token after an error, discard it. */
-
- /* return failure if at end of input */
- if (yychar == YYEOF)
- YYABORT;
-
-#if YYDEBUG != 0
- if (yydebug)
- fprintf(stderr, "Discarding token %d (%s).\n", yychar, yytname[yychar1]);
-#endif
-
- yychar = YYEMPTY;
- }
-
- /* Else will try to reuse lookahead token
- after shifting the error token. */
-
- yyerrstatus = 3; /* Each real token shifted decrements this */
-
- goto yyerrhandle;
-
-yyerrdefault: /* current state does not do anything special for the error token. */
-
-#if 0
- /* This is wrong; only states that explicitly want error tokens
- should shift them. */
- yyn = yydefact[yystate]; /* If its default is to accept any token, ok. Otherwise pop it.*/
- if (yyn) goto yydefault;
-#endif
-
-yyerrpop: /* pop the current state because it cannot handle the error token */
-
- if (yyssp == yyss) YYABORT;
- yyvsp--;
- yystate = *--yyssp;
-#ifdef YYLSP_NEEDED
- yylsp--;
-#endif
-
-#if YYDEBUG != 0
- if (yydebug)
- {
- short *ssp1 = yyss - 1;
- fprintf (stderr, "Error: state stack now");
- while (ssp1 != yyssp)
- fprintf (stderr, " %d", *++ssp1);
- fprintf (stderr, "\n");
- }
-#endif
-
-yyerrhandle:
-
- yyn = yypact[yystate];
- if (yyn == YYFLAG)
- goto yyerrdefault;
-
- yyn += YYTERROR;
- if (yyn < 0 || yyn > YYLAST || yycheck[yyn] != YYTERROR)
- goto yyerrdefault;
-
- yyn = yytable[yyn];
- if (yyn < 0)
- {
- if (yyn == YYFLAG)
- goto yyerrpop;
- yyn = -yyn;
- goto yyreduce;
- }
- else if (yyn == 0)
- goto yyerrpop;
-
- if (yyn == YYFINAL)
- YYACCEPT;
-
-#if YYDEBUG != 0
- if (yydebug)
- fprintf(stderr, "Shifting error token, ");
-#endif
-
- *++yyvsp = yylval;
-#ifdef YYLSP_NEEDED
- *++yylsp = yylloc;
-#endif
-
- yystate = yyn;
- goto yynewstate;
-}
-#line 2001 "yaccParser/hsparser.y"
-
-
-/**********************************************************************
-* *
-* Error Processing and Reporting *
-* *
-* (This stuff is here in case we want to use Yacc macros and such.) *
-* *
-**********************************************************************/
-
-/* The parser calls "hsperror" when it sees a
- `report this and die' error. It sets the stage
- and calls "yyerror".
-
- There should be no direct calls in the parser to
- "yyerror", except for the one from "hsperror". Thus,
- the only other calls will be from the error productions
- introduced by yacc/bison/whatever.
-
- We need to be able to recognise the from-error-production
- case, because we sometimes want to say, "Oh, never mind",
- because the layout rule kicks into action and may save
- the day. [WDP]
-*/
-
-static BOOLEAN error_and_I_mean_it = FALSE;
-
-void
-hsperror(s)
- char *s;
-{
- error_and_I_mean_it = TRUE;
- yyerror(s);
-}
-
-extern char *yytext;
-extern int yyleng;
-
-void
-yyerror(s)
- char *s;
-{
- /* We want to be able to distinguish 'error'-raised yyerrors
- from yyerrors explicitly coded by the parser hacker.
- */
- if (expect_ccurly && ! error_and_I_mean_it ) {
- /*NOTHING*/;
-
- } else {
- fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ",
- input_filename, hsplineno, hspcolno + 1, s);
-
- if (yyleng == 1 && *yytext == '\0')
- fprintf(stderr, "<EOF>");
-
- else {
- fputc('"', stderr);
- format_string(stderr, (unsigned char *) yytext, yyleng);
- fputc('"', stderr);
- }
- fputc('\n', stderr);
-
- /* a common problem */
- if (strcmp(yytext, "#") == 0)
- fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
-
- exit(1);
- }
-}
-
-void
-format_string(fp, s, len)
- FILE *fp;
- unsigned char *s;
- int len;
-{
- while (len-- > 0) {
- switch (*s) {
- case '\0': fputs("\\NUL", fp); break;
- case '\007': fputs("\\a", fp); break;
- case '\010': fputs("\\b", fp); break;
- case '\011': fputs("\\t", fp); break;
- case '\012': fputs("\\n", fp); break;
- case '\013': fputs("\\v", fp); break;
- case '\014': fputs("\\f", fp); break;
- case '\015': fputs("\\r", fp); break;
- case '\033': fputs("\\ESC", fp); break;
- case '\034': fputs("\\FS", fp); break;
- case '\035': fputs("\\GS", fp); break;
- case '\036': fputs("\\RS", fp); break;
- case '\037': fputs("\\US", fp); break;
- case '\177': fputs("\\DEL", fp); break;
- default:
- if (*s >= ' ')
- fputc(*s, fp);
- else
- fprintf(fp, "\\^%c", *s + '@');
- break;
- }
- s++;
- }
-}
+++ /dev/null
-typedef union {
- tree utree;
- list ulist;
- ttype uttype;
- atype uatype;
- binding ubinding;
- pbinding upbinding;
- finfot ufinfo;
- entidt uentid;
- id uid;
- literal uliteral;
- int uint;
- float ufloat;
- char *ustring;
- hstring uhstring;
- hpragma uhpragma;
- coresyn ucoresyn;
-} YYSTYPE;
-#define VARID 258
-#define CONID 259
-#define VARSYM 260
-#define CONSYM 261
-#define MINUS 262
-#define INTEGER 263
-#define FLOAT 264
-#define CHAR 265
-#define STRING 266
-#define CHARPRIM 267
-#define STRINGPRIM 268
-#define INTPRIM 269
-#define FLOATPRIM 270
-#define DOUBLEPRIM 271
-#define CLITLIT 272
-#define OCURLY 273
-#define CCURLY 274
-#define VCCURLY 275
-#define SEMI 276
-#define OBRACK 277
-#define CBRACK 278
-#define OPAREN 279
-#define CPAREN 280
-#define COMMA 281
-#define BQUOTE 282
-#define RARROW 283
-#define VBAR 284
-#define EQUAL 285
-#define DARROW 286
-#define DOTDOT 287
-#define DCOLON 288
-#define LARROW 289
-#define WILDCARD 290
-#define AT 291
-#define LAZY 292
-#define LAMBDA 293
-#define LET 294
-#define IN 295
-#define WHERE 296
-#define CASE 297
-#define OF 298
-#define TYPE 299
-#define DATA 300
-#define CLASS 301
-#define INSTANCE 302
-#define DEFAULT 303
-#define INFIX 304
-#define INFIXL 305
-#define INFIXR 306
-#define MODULE 307
-#define IMPORT 308
-#define INTERFACE 309
-#define HIDING 310
-#define CCALL 311
-#define CCALL_GC 312
-#define CASM 313
-#define CASM_GC 314
-#define SCC 315
-#define IF 316
-#define THEN 317
-#define ELSE 318
-#define RENAMING 319
-#define DERIVING 320
-#define TO 321
-#define LEOF 322
-#define GHC_PRAGMA 323
-#define END_PRAGMA 324
-#define NO_PRAGMA 325
-#define NOINFO_PRAGMA 326
-#define ABSTRACT_PRAGMA 327
-#define SPECIALISE_PRAGMA 328
-#define MODNAME_PRAGMA 329
-#define ARITY_PRAGMA 330
-#define UPDATE_PRAGMA 331
-#define STRICTNESS_PRAGMA 332
-#define KIND_PRAGMA 333
-#define UNFOLDING_PRAGMA 334
-#define MAGIC_UNFOLDING_PRAGMA 335
-#define DEFOREST_PRAGMA 336
-#define SPECIALISE_UPRAGMA 337
-#define INLINE_UPRAGMA 338
-#define MAGIC_UNFOLDING_UPRAGMA 339
-#define ABSTRACT_UPRAGMA 340
-#define DEFOREST_UPRAGMA 341
-#define END_UPRAGMA 342
-#define TYLAMBDA 343
-#define COCON 344
-#define COPRIM 345
-#define COAPP 346
-#define COTYAPP 347
-#define FORALL 348
-#define TYVAR_TEMPLATE_ID 349
-#define CO_ALG_ALTS 350
-#define CO_PRIM_ALTS 351
-#define CO_NO_DEFAULT 352
-#define CO_LETREC 353
-#define CO_SDSEL_ID 354
-#define CO_METH_ID 355
-#define CO_DEFM_ID 356
-#define CO_DFUN_ID 357
-#define CO_CONSTM_ID 358
-#define CO_SPEC_ID 359
-#define CO_WRKR_ID 360
-#define CO_ORIG_NM 361
-#define UNFOLD_ALWAYS 362
-#define UNFOLD_IF_ARGS 363
-#define NOREP_INTEGER 364
-#define NOREP_RATIONAL 365
-#define NOREP_STRING 366
-#define CO_PRELUDE_DICTS_CC 367
-#define CO_ALL_DICTS_CC 368
-#define CO_USER_CC 369
-#define CO_AUTO_CC 370
-#define CO_DICT_CC 371
-#define CO_CAF_CC 372
-#define CO_DUPD_CC 373
-#define PLUS 374
-
-
-extern YYSTYPE yylval;
+++ /dev/null
-/**************************************************************************
-* File: hsparser.y *
-* *
-* Author: Maria M. Gutierrez *
-* Modified by: Kevin Hammond *
-* Last date revised: December 13 1991. KH. *
-* Modification: Haskell 1.1 Syntax. *
-* *
-* *
-* Description: This file contains the LALR(1) grammar for Haskell. *
-* *
-* Entry Point: module *
-* *
-* Problems: None known. *
-* *
-* *
-* LALR(1) Syntax for Haskell 1.2 *
-* *
-**************************************************************************/
-
-
-%{
-#ifdef HSP_DEBUG
-# define YYDEBUG 1
-#endif
-
-#include <stdio.h>
-#include <ctype.h>
-#include <string.h>
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/**********************************************************************
-* *
-* *
-* Imported Variables and Functions *
-* *
-* *
-**********************************************************************/
-
-static BOOLEAN expect_ccurly = FALSE; /* Used to signal that a CCURLY could be inserted here */
-
-extern BOOLEAN nonstandardFlag;
-extern BOOLEAN etags;
-
-extern VOID find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
-
-extern char *input_filename;
-static char *the_module_name;
-static char iface_name[MODNAME_SIZE];
-static char interface_filename[FILENAME_SIZE];
-
-static list module_exports; /* Exported entities */
-static list prelude_core_import, prelude_imports;
- /* Entities imported from the Prelude */
-
-extern list all; /* All valid deriving classes */
-
-extern tree niltree;
-extern list Lnil;
-
-extern tree root;
-
-/* For FN, PREVPATT and SAMEFN macros */
-extern tree fns[];
-extern short samefn[];
-extern tree prevpatt[];
-extern short icontexts;
-
-/* Line Numbers */
-extern int hsplineno, hspcolno;
-extern int startlineno;
-
-
-/**********************************************************************
-* *
-* *
-* Fixity and Precedence Declarations *
-* *
-* *
-**********************************************************************/
-
-/* OLD 95/08: list fixlist; */
-static int Fixity = 0, Precedence = 0;
-struct infix;
-
-char *ineg PROTO((char *));
-
-static BOOLEAN hidden = FALSE; /* Set when HIDING used */
-
-extern BOOLEAN inpat; /* True when parsing a pattern */
-extern BOOLEAN implicitPrelude; /* True when we should read the Prelude if not given */
-extern BOOLEAN haskell1_3Flag; /* True if we are attempting (proto)Haskell 1.3 */
-
-extern int thisIfacePragmaVersion;
-%}
-
-%union {
- tree utree;
- list ulist;
- ttype uttype;
- atype uatype;
- binding ubinding;
- pbinding upbinding;
- finfot ufinfo;
- entidt uentid;
- id uid;
- literal uliteral;
- int uint;
- float ufloat;
- char *ustring;
- hstring uhstring;
- hpragma uhpragma;
- coresyn ucoresyn;
-}
-
-
-/**********************************************************************
-* *
-* *
-* These are lexemes. *
-* *
-* *
-**********************************************************************/
-
-
-%token VARID CONID
- VARSYM CONSYM MINUS
-
-%token INTEGER FLOAT CHAR STRING
- CHARPRIM STRINGPRIM INTPRIM FLOATPRIM
- DOUBLEPRIM CLITLIT
-
-
-
-/**********************************************************************
-* *
-* *
-* Special Symbols *
-* *
-* *
-**********************************************************************/
-
-%token OCURLY CCURLY VCCURLY SEMI
-%token OBRACK CBRACK OPAREN CPAREN
-%token COMMA BQUOTE
-
-
-/**********************************************************************
-* *
-* *
-* Reserved Operators *
-* *
-* *
-**********************************************************************/
-
-%token RARROW
-%token VBAR EQUAL DARROW DOTDOT
-%token DCOLON LARROW
-%token WILDCARD AT LAZY LAMBDA
-
-
-/**********************************************************************
-* *
-* *
-* Reserved Identifiers *
-* *
-* *
-**********************************************************************/
-
-%token LET IN
-%token WHERE CASE OF
-%token TYPE DATA CLASS INSTANCE DEFAULT
-%token INFIX INFIXL INFIXR
-%token MODULE IMPORT INTERFACE HIDING
-%token CCALL CCALL_GC CASM CASM_GC SCC
-
-%token IF THEN ELSE
-%token RENAMING DERIVING TO
-
-/**********************************************************************
-* *
-* *
-* Special Symbols for the Lexer *
-* *
-* *
-**********************************************************************/
-
-%token LEOF
-%token GHC_PRAGMA END_PRAGMA NO_PRAGMA NOINFO_PRAGMA
-%token ABSTRACT_PRAGMA SPECIALISE_PRAGMA MODNAME_PRAGMA
-%token ARITY_PRAGMA UPDATE_PRAGMA STRICTNESS_PRAGMA KIND_PRAGMA
-%token UNFOLDING_PRAGMA MAGIC_UNFOLDING_PRAGMA DEFOREST_PRAGMA
-%token SPECIALISE_UPRAGMA INLINE_UPRAGMA MAGIC_UNFOLDING_UPRAGMA
-%token ABSTRACT_UPRAGMA DEFOREST_UPRAGMA END_UPRAGMA
-%token TYLAMBDA COCON COPRIM COAPP COTYAPP FORALL TYVAR_TEMPLATE_ID
-%token CO_ALG_ALTS CO_PRIM_ALTS CO_NO_DEFAULT CO_LETREC
-%token CO_SDSEL_ID CO_METH_ID CO_DEFM_ID CO_DFUN_ID CO_CONSTM_ID
-%token CO_SPEC_ID CO_WRKR_ID CO_ORIG_NM
-%token UNFOLD_ALWAYS UNFOLD_IF_ARGS
-%token NOREP_INTEGER NOREP_RATIONAL NOREP_STRING
-%token CO_PRELUDE_DICTS_CC CO_ALL_DICTS_CC CO_USER_CC CO_AUTO_CC CO_DICT_CC
-%token CO_CAF_CC CO_DUPD_CC
-
-/**********************************************************************
-* *
-* *
-* Precedences of the various tokens *
-* *
-* *
-**********************************************************************/
-
-
-%left CASE LET IN LAMBDA
- IF ELSE CCALL CCALL_GC
- CASM CASM_GC SCC AT
-
-%left VARSYM CONSYM PLUS MINUS BQUOTE
-
-%left DCOLON
-
-%left SEMI COMMA
-
-%left OCURLY OBRACK OPAREN
-
-%left EQUAL
-
-%right DARROW
-%right RARROW
-
-
-
-/**********************************************************************
-* *
-* *
-* Type Declarations *
-* *
-* *
-**********************************************************************/
-
-
-%type <ulist> alt alts altrest quals vars varsrest cons
- tyvars constrs dtypes types atypes
- types_and_maybe_ids
- list_exps pats context context_list tyvar_list
- maybeexports export_list
- impspec maybeimpspec import_list
- impdecls maybeimpdecls impdecl
- renaming renamings renaming_list
- tyclses tycls_list
- gdrhs gdpat valrhs valrhs1
- lampats
- upto
- cexp
- idata_pragma_specs idata_pragma_specslist
- gen_pragma_list type_pragma_pairs
- type_pragma_pairs_maybe name_pragma_pairs
- type_maybes
- howto_inline_maybe
- core_binders core_tyvars core_tv_templates
- core_types core_type_list
- core_atoms core_atom_list
- core_alg_alts core_prim_alts corec_binds
- core_type_maybes
-
-%type <uliteral> lit_constant
-
-%type <utree> exp dexp fexp kexp oexp aexp
- tuple list sequence comprehension qual qualrest
- gd
- apat bpat pat apatc conpat dpat fpat opat aapat
- dpatk fpatk opatk aapatk
- texps
-
-%type <uid> MINUS VARID CONID VARSYM CONSYM TYVAR_TEMPLATE_ID
- var vark con conk varop varop1 conop op op1
- varsym minus plus
- tycls tycon modid ccallid modname_pragma
-
-%type <ubinding> topdecl topdecls
- typed datad classd instd defaultd
- decl decls valdef instdef instdefs
- iimport iimports maybeiimports
- ityped idatad iclassd iinstd ivarsd
- itopdecl itopdecls
- maybe_where
- interface readinterface ibody
- cbody rinst
- impdecl_rest
- type_and_maybe_id
-
-%type <uttype> simple type atype btype ttype ntatype
- class restrict_inst general_inst tyvar type_maybe
- core_type core_type_maybe
-
-%type <uatype> constr
-
-%type <ustring> FLOAT INTEGER INTPRIM
- FLOATPRIM DOUBLEPRIM CLITLIT
-%type <uhstring> STRING STRINGPRIM CHAR CHARPRIM
-%type <uentid> export import
-
-%type <uhpragma> idata_pragma idata_pragma_spectypes
- itype_pragma iclas_pragma iclasop_pragma
- iinst_pragma gen_pragma ival_pragma arity_pragma
- update_pragma strictness_pragma worker_info
- deforest_pragma
- unfolding_pragma unfolding_guidance type_pragma_pair
- name_pragma_pair
-
-%type <ucoresyn> core_expr core_case_alts core_id core_binder core_atom
- core_alg_alt core_prim_alt core_default corec_bind
- co_primop co_scc co_caf co_dupd
-
-/**********************************************************************
-* *
-* *
-* Start Symbol for the Parser *
-* *
-* *
-**********************************************************************/
-
-%start pmodule
-
-
-%%
-
-pmodule : readpreludecore readprelude module
- ;
-
-module : modulekey modid maybeexports
- { the_module_name = $2; module_exports = $3; }
- WHERE body
- | { the_module_name = install_literal("Main"); module_exports = Lnil; }
- body
- ;
-
- /* all the startlinenos in mkhmodules are bogus (WDP) */
-body : ocurly maybeimpdecls maybefixes topdecls ccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4,startlineno);
- }
- | vocurly maybeimpdecls maybefixes topdecls vccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,$4,startlineno);
- }
-
- | vocurly impdecls vccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno);
- }
- | ocurly impdecls ccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno);
- }
-
-/* Adds 1 S/R, 2 R/R conflicts, alternatives add 3 R/R conflicts */
- | vocurly maybeimpdecls vccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno);
- }
- | ocurly maybeimpdecls ccurly
- {
- root = mkhmodule(the_module_name,lconc(prelude_imports,$2),module_exports,mknullbind(),startlineno);
- }
- ;
-
-
-maybeexports : /* empty */ { $$ = Lnil; }
- | OPAREN export_list CPAREN { $$ = $2; }
- ;
-
-export_list:
- export { $$ = lsing($1); }
- | export_list COMMA export { $$ = lapp($1, $3); }
- ;
-
-export :
- var { $$ = mkentid($1); }
- | tycon { $$ = mkenttype($1); }
- | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
- | tycon OPAREN cons CPAREN
- { $$ = mkenttypecons($1,$3);
- /* should be a datatype with cons representing all constructors */
- }
- | tycon OPAREN vars CPAREN
- { $$ = mkentclass($1,$3);
- /* should be a class with vars representing all Class operations */
- }
- | tycon OPAREN CPAREN
- { $$ = mkentclass($1,Lnil);
- /* "tycon" should be a class with no operations */
- }
- | tycon DOTDOT
- { $$ = mkentmod($1);
- /* "tycon" is a module id (but "modid" is bad for your identifier's health [KH]) */
- }
- ;
-
-
-impspec : OPAREN import_list CPAREN { $$ = $2; hidden = FALSE; }
- | HIDING OPAREN import_list CPAREN { $$ = $3; hidden = TRUE; }
- | OPAREN CPAREN { $$ = Lnil; hidden = FALSE; }
- ;
-
-maybeimpspec : /* empty */ { $$ = Lnil; }
- | impspec { $$ = $1; }
- ;
-
-import_list:
- import { $$ = lsing($1); }
- | import_list COMMA import { $$ = lapp($1, $3); }
- ;
-
-import :
- var { $$ = mkentid($1); }
- | tycon { $$ = mkenttype($1); }
- | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); }
- | tycon OPAREN cons CPAREN
- { $$ = mkenttypecons($1,$3);
- /* should be a datatype with cons representing all constructors */
- }
- | tycon OPAREN vars CPAREN
- { $$ = mkentclass($1,$3);
- /* should be a class with vars representing all Class operations */
- }
- | tycon OPAREN CPAREN
- { $$ = mkentclass($1,Lnil);
- /* "tycon" should be a class with no operations */
- }
- ;
-
-/* -- interface pragma stuff: ------------------------------------- */
-
-idata_pragma:
- GHC_PRAGMA constrs idata_pragma_specs END_PRAGMA
- { $$ = mkidata_pragma($2, $3); }
- | GHC_PRAGMA idata_pragma_specs END_PRAGMA
- { $$ = mkidata_pragma(Lnil, $2); }
- | /* empty */ { $$ = mkno_pragma(); }
- ;
-
-idata_pragma_specs :
- SPECIALISE_PRAGMA idata_pragma_specslist
- { $$ = $2; }
- | /* empty */ { $$ = Lnil; }
- ;
-
-idata_pragma_specslist:
- idata_pragma_spectypes { $$ = lsing($1); }
- | idata_pragma_specslist COMMA idata_pragma_spectypes
- { $$ = lapp($1, $3); }
- ;
-
-idata_pragma_spectypes:
- OBRACK type_maybes CBRACK { $$ = mkidata_pragma_4s($2); }
- ;
-
-itype_pragma:
- GHC_PRAGMA ABSTRACT_PRAGMA END_PRAGMA { $$ = mkitype_pragma(); }
- | /* empty */ { $$ = mkno_pragma(); }
- ;
-
-iclas_pragma:
- GHC_PRAGMA gen_pragma_list END_PRAGMA { $$ = mkiclas_pragma($2); }
- | /* empty */ { $$ = mkno_pragma(); }
- ;
-
-iclasop_pragma:
- GHC_PRAGMA gen_pragma gen_pragma END_PRAGMA
- { $$ = mkiclasop_pragma($2, $3); }
- | /* empty */
- { $$ = mkno_pragma(); }
- ;
-
-iinst_pragma:
- GHC_PRAGMA modname_pragma gen_pragma END_PRAGMA
- { $$ = mkiinst_simpl_pragma($2, $3); }
-
- | GHC_PRAGMA modname_pragma gen_pragma name_pragma_pairs END_PRAGMA
- { $$ = mkiinst_const_pragma($2, $3, $4); }
-
- | /* empty */
- { $$ = mkno_pragma(); }
- ;
-
-modname_pragma:
- MODNAME_PRAGMA modid
- { $$ = $2; }
- | /* empty */
- { $$ = install_literal(""); }
- ;
-
-ival_pragma:
- GHC_PRAGMA gen_pragma END_PRAGMA
- { $$ = $2; }
- | /* empty */
- { $$ = mkno_pragma(); }
- ;
-
-gen_pragma:
- NOINFO_PRAGMA
- { $$ = mkno_pragma(); }
- | arity_pragma update_pragma deforest_pragma strictness_pragma unfolding_pragma type_pragma_pairs_maybe
- { $$ = mkigen_pragma($1, $2, $3, $4, $5, $6); }
- ;
-
-arity_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | ARITY_PRAGMA INTEGER { $$ = mkiarity_pragma($2); }
- ;
-
-update_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | UPDATE_PRAGMA INTEGER { $$ = mkiupdate_pragma($2); }
- ;
-
-deforest_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | DEFOREST_PRAGMA { $$ = mkideforest_pragma(); }
- ;
-
-strictness_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | STRICTNESS_PRAGMA COCON { $$ = mkistrictness_pragma(installHstring(1, "B"),
- /* _!_ = COCON = bottom */ mkno_pragma());
- }
- | STRICTNESS_PRAGMA STRING worker_info
- { $$ = mkistrictness_pragma($2, $3); }
- ;
-
-worker_info:
- OCURLY gen_pragma CCURLY { $$ = $2; }
- | /* empty */ { $$ = mkno_pragma(); }
-
-unfolding_pragma:
- NO_PRAGMA { $$ = mkno_pragma(); }
- | MAGIC_UNFOLDING_PRAGMA vark
- { $$ = mkimagic_unfolding_pragma($2); }
- | UNFOLDING_PRAGMA unfolding_guidance core_expr
- { $$ = mkiunfolding_pragma($2, $3); }
- ;
-
-unfolding_guidance:
- UNFOLD_ALWAYS
- { $$ = mkiunfold_always(); }
- | UNFOLD_IF_ARGS INTEGER INTEGER CONID INTEGER
- { $$ = mkiunfold_if_args($2, $3, $4, $5); }
- ;
-
-gen_pragma_list:
- gen_pragma { $$ = lsing($1); }
- | gen_pragma_list COMMA gen_pragma { $$ = lapp($1, $3); }
- ;
-
-type_pragma_pairs_maybe:
- NO_PRAGMA { $$ = Lnil; }
- | SPECIALISE_PRAGMA type_pragma_pairs { $$ = $2; }
- ;
-
-type_pragma_pairs:
- type_pragma_pair { $$ = lsing($1); }
- | type_pragma_pairs COMMA type_pragma_pair { $$ = lapp($1, $3); }
- ;
-
-type_pragma_pair:
- OBRACK type_maybes CBRACK INTEGER worker_info
- { $$ = mkitype_pragma_pr($2, $4, $5); }
- ;
-
-type_maybes:
- type_maybe { $$ = lsing($1); }
- | type_maybes COMMA type_maybe { $$ = lapp($1, $3); }
- ;
-
-type_maybe:
- NO_PRAGMA { $$ = mkty_maybe_nothing(); }
- | type { $$ = mkty_maybe_just($1); }
- ;
-
-name_pragma_pairs:
- name_pragma_pair { $$ = lsing($1); }
- | name_pragma_pairs COMMA name_pragma_pair { $$ = lapp($1, $3); }
- ;
-
-name_pragma_pair:
- /* if the gen_pragma concludes with a *comma*- */
- /* separated SPECs list, we get a parse error; */
- /* we have to bracket the gen_pragma */
-
- var EQUAL OCURLY gen_pragma CCURLY
- { $$ = mkiname_pragma_pr($1, $4); }
-
- /* we keep the old form for backwards compatability */
- /* ToDo: rm */
-
- | var EQUAL gen_pragma
- { $$ = mkiname_pragma_pr($1, $3); }
-
- /* need bracketed form when we have spec pragmas to avoid list confusion */
- ;
-
-/* -- end of interface pragma stuff ------------------------------- */
-
-/* -- core syntax stuff ------------------------------------------- */
-
-core_expr:
- LAMBDA core_binders RARROW core_expr
- { $$ = mkcolam($2, $4); }
- | TYLAMBDA core_tyvars RARROW core_expr
- { $$ = mkcotylam($2, $4); }
- | COCON con core_types core_atoms
- { $$ = mkcocon(mkco_id($2), $3, $4); }
- | COCON CO_ORIG_NM modid con core_types core_atoms
- { $$ = mkcocon(mkco_orig_id($3,$4), $5, $6); }
- | COPRIM co_primop core_types core_atoms
- { $$ = mkcoprim($2, $3, $4); }
- | COAPP core_expr core_atoms
- { $$ = mkcoapp($2, $3); }
- | COTYAPP core_expr OCURLY core_type CCURLY
- { $$ = mkcotyapp($2, $4); }
- | CASE core_expr OF OCURLY core_case_alts CCURLY
- { $$ = mkcocase($2, $5); }
- | LET OCURLY core_binder EQUAL core_expr CCURLY IN core_expr
- { $$ = mkcolet(mkcononrec($3, $5), $8); }
- | CO_LETREC OCURLY corec_binds CCURLY IN core_expr
- { $$ = mkcolet(mkcorec($3), $6); }
- | SCC OCURLY co_scc CCURLY core_expr
- { $$ = mkcoscc($3, $5); }
- | lit_constant { $$ = mkcoliteral($1); }
- | core_id { $$ = mkcovar($1); }
- ;
-
-core_case_alts :
- CO_ALG_ALTS core_alg_alts core_default
- { $$ = mkcoalg_alts($2, $3); }
- | CO_PRIM_ALTS core_prim_alts core_default
- { $$ = mkcoprim_alts($2, $3); }
- ;
-
-core_alg_alts :
- /* empty */ { $$ = Lnil; }
- | core_alg_alts core_alg_alt { $$ = lapp($1, $2); }
- ;
-
-core_alg_alt:
- core_id core_binders RARROW core_expr SEMI { $$ = mkcoalg_alt($1, $2, $4); }
- /* core_id is really too generous */
- ;
-
-core_prim_alts :
- /* empty */ { $$ = Lnil; }
- | core_prim_alts core_prim_alt { $$ = lapp($1, $2); }
- ;
-
-core_prim_alt:
- lit_constant RARROW core_expr SEMI { $$ = mkcoprim_alt($1, $3); }
- ;
-
-core_default:
- CO_NO_DEFAULT { $$ = mkconodeflt(); }
- | core_binder RARROW core_expr { $$ = mkcobinddeflt($1, $3); }
- ;
-
-corec_binds:
- corec_bind { $$ = lsing($1); }
- | corec_binds SEMI corec_bind { $$ = lapp($1, $3); }
- ;
-
-corec_bind:
- core_binder EQUAL core_expr { $$ = mkcorec_pair($1, $3); }
- ;
-
-co_scc :
- CO_PRELUDE_DICTS_CC co_dupd { $$ = mkco_preludedictscc($2); }
- | CO_ALL_DICTS_CC STRING STRING co_dupd { $$ = mkco_alldictscc($2,$3,$4); }
- | CO_USER_CC STRING STRING STRING co_dupd co_caf
- { $$ = mkco_usercc($2,$3,$4,$5,$6); }
- | CO_AUTO_CC core_id STRING STRING co_dupd co_caf
- { $$ = mkco_autocc($2,$3,$4,$5,$6); }
- | CO_DICT_CC core_id STRING STRING co_dupd co_caf
- { $$ = mkco_dictcc($2,$3,$4,$5,$6); }
-
-co_caf : NO_PRAGMA { $$ = mkco_scc_noncaf(); }
- | CO_CAF_CC { $$ = mkco_scc_caf(); }
-
-co_dupd : NO_PRAGMA { $$ = mkco_scc_nondupd(); }
- | CO_DUPD_CC { $$ = mkco_scc_dupd(); }
-
-core_id: /* more to come?? */
- CO_SDSEL_ID tycon tycon { $$ = mkco_sdselid($2, $3); }
- | CO_METH_ID tycon var { $$ = mkco_classopid($2, $3); }
- | CO_DEFM_ID tycon var { $$ = mkco_defmid($2, $3); }
- | CO_DFUN_ID tycon OPAREN core_type CPAREN
- { $$ = mkco_dfunid($2, $4); }
- | CO_CONSTM_ID tycon var OPAREN core_type CPAREN
- { $$ = mkco_constmid($2, $3, $5); }
- | CO_SPEC_ID core_id OBRACK core_type_maybes CBRACK
- { $$ = mkco_specid($2, $4); }
- | CO_WRKR_ID core_id { $$ = mkco_wrkrid($2); }
- | CO_ORIG_NM modid var { $$ = mkco_orig_id($2, $3); }
- | CO_ORIG_NM modid con { $$ = mkco_orig_id($2, $3); }
- | var { $$ = mkco_id($1); }
- | con { $$ = mkco_id($1); }
- ;
-
-co_primop :
- OPAREN CCALL ccallid OCURLY core_types core_type CCURLY CPAREN
- { $$ = mkco_ccall($3,0,$5,$6); }
- | OPAREN CCALL_GC ccallid OCURLY core_types core_type CCURLY CPAREN
- { $$ = mkco_ccall($3,1,$5,$6); }
- | OPAREN CASM lit_constant OCURLY core_types core_type CCURLY CPAREN
- { $$ = mkco_casm($3,0,$5,$6); }
- | OPAREN CASM_GC lit_constant OCURLY core_types core_type CCURLY CPAREN
- { $$ = mkco_casm($3,1,$5,$6); }
- | VARID { $$ = mkco_primop($1); }
- ;
-
-core_binders :
- /* empty */ { $$ = Lnil; }
- | core_binders core_binder { $$ = lapp($1, $2); }
- ;
-
-core_binder :
- OPAREN VARID DCOLON core_type CPAREN { $$ = mkcobinder($2, $4); }
-
-core_atoms :
- OBRACK CBRACK { $$ = Lnil; }
- | OBRACK core_atom_list CBRACK { $$ = $2; }
- ;
-
-core_atom_list :
- core_atom { $$ = lsing($1); }
- | core_atom_list COMMA core_atom { $$ = lapp($1, $3); }
- ;
-
-core_atom :
- lit_constant { $$ = mkcolit($1); }
- | core_id { $$ = mkcolocal($1); }
- ;
-
-core_tyvars :
- VARID { $$ = lsing($1); }
- | core_tyvars VARID { $$ = lapp($1, $2); }
- ;
-
-core_tv_templates :
- TYVAR_TEMPLATE_ID { $$ = lsing($1); }
- | core_tv_templates COMMA TYVAR_TEMPLATE_ID { $$ = lapp($1, $3); }
- ;
-
-core_types :
- OBRACK CBRACK { $$ = Lnil; }
- | OBRACK core_type_list CBRACK { $$ = $2; }
- ;
-
-core_type_list :
- core_type { $$ = lsing($1); }
- | core_type_list COMMA core_type { $$ = lapp($1, $3); }
- ;
-
-core_type :
- type { $$ = $1; }
- ;
-
-/*
-core_type :
- FORALL core_tv_templates DARROW core_type
- { $$ = mkuniforall($2, $4); }
- | OCURLY OCURLY CONID core_type CCURLY CCURLY RARROW core_type
- { $$ = mktfun(mkunidict($3, $4), $8); }
- | OCURLY OCURLY CONID core_type CCURLY CCURLY
- { $$ = mkunidict($3, $4); }
- | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN RARROW core_type
- { $$ = mktfun(mkttuple(mklcons(mkunidict($4, $5), $9)), $12); }
- | OPAREN OCURLY OCURLY CONID core_type CCURLY CCURLY COMMA core_type_list CPAREN
- { $$ = mkttuple(mklcons(mkunidict($4,$5), $9)); }
- | type { $$ = $1; }
- ;
-*/
-
-core_type_maybes:
- core_type_maybe { $$ = lsing($1); }
- | core_type_maybes COMMA core_type_maybe { $$ = lapp($1, $3); }
- ;
-
-core_type_maybe:
- NO_PRAGMA { $$ = mkty_maybe_nothing(); }
- | core_type { $$ = mkty_maybe_just($1); }
- ;
-
-/* -- end of core syntax stuff ------------------------------------ */
-
-readpreludecore :
- {
- if ( implicitPrelude && !etags ) {
- /* we try to avoid reading interfaces when etagging */
- find_module_on_imports_dirlist(
- (haskell1_3Flag) ? "PrelCore13" : "PreludeCore",
- TRUE,interface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename);
- }
- thisIfacePragmaVersion = 0;
- setyyin(interface_filename);
- enteriscope();
- }
- readinterface
- {
- binding prelude_core = mkimport(installid(iface_name),Lnil,Lnil,$2,xstrdup(interface_filename),hsplineno);
- prelude_core_import = implicitPrelude? lsing(prelude_core): Lnil;
-
- }
- ;
-
-readprelude :
- {
- if ( implicitPrelude && !etags ) {
- find_module_on_imports_dirlist(
- ( haskell1_3Flag ) ? "Prel13" : "Prelude",
- TRUE,interface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename);
- }
- thisIfacePragmaVersion = 0;
- setyyin(interface_filename);
- enteriscope();
- }
- readinterface
- {
- binding prelude = mkimport(installid(iface_name),Lnil,Lnil,$2,xstrdup(interface_filename),hsplineno);
- prelude_imports = (! implicitPrelude) ? Lnil
- : lconc(prelude_core_import,lsing(prelude));
- }
- ;
-
-maybeimpdecls : /* empty */ { $$ = Lnil; }
- | impdecls SEMI { $$ = $1; }
- ;
-
-impdecls: impdecl { $$ = $1; }
- | impdecls SEMI impdecl { $$ = lconc($1,$3); }
- ;
-
-impdecl : IMPORT modid
- { /* filename returned in "interface_filename" */
- char *module_name = id_to_string($2);
- if ( ! etags ) {
- find_module_on_imports_dirlist(
- (haskell1_3Flag && strcmp(module_name, "Prelude") == 0)
- ? "Prel13" : module_name,
- FALSE, interface_filename);
- } else {
- find_module_on_imports_dirlist("PreludeNull_",TRUE,interface_filename);
- }
- thisIfacePragmaVersion = 0;
- setyyin(interface_filename);
- enteriscope();
- if (strcmp(module_name,"PreludeCore")==0) {
- hsperror("Cannot explicitly import `PreludeCore'");
-
- } else if (strcmp(module_name,"Prelude")==0) {
- prelude_imports = prelude_core_import; /* unavoidable */
- }
- }
- impdecl_rest
- {
- if (hidden)
- $4->tag = hiding;
- $$ = lsing($4);
- }
-
-impdecl_rest:
- readinterface maybeimpspec
- { $$ = mkimport(installid(iface_name),$2,Lnil,$1,xstrdup(interface_filename),hsplineno); }
- /* WDP: uncertain about those hsplinenos */
- | readinterface maybeimpspec RENAMING renamings
- { $$ = mkimport(installid(iface_name),$2,$4,$1,xstrdup(interface_filename),hsplineno); }
- ;
-
-readinterface:
- interface LEOF
- {
- exposeis(); /* partain: expose infix ops at level i+1 to level i */
- $$ = $1;
- }
- ;
-
-renamings: OPAREN renaming_list CPAREN { $$ = $2; }
- ;
-
-renaming_list:
- renaming { $$ = lsing($1); }
- | renaming_list COMMA renaming { $$ = lapp($1, $3); }
- ;
-
-renaming: var TO var { $$ = ldub($1,$3); }
- | con TO con { $$ = ldub($1,$3); }
- ;
-
-maybeiimports : /* empty */ { $$ = mknullbind(); }
- | iimports SEMI { $$ = $1; }
- ;
-
-iimports : iimport { $$ = $1; }
- | iimports SEMI iimport { $$ = mkabind($1,$3); }
- ;
-
-iimport : importkey modid OPAREN import_list CPAREN
- { $$ = mkmbind($2,$4,Lnil,startlineno); }
- | importkey modid OPAREN import_list CPAREN RENAMING renamings
- { $$ = mkmbind($2,$4,$7,startlineno); }
- ;
-
-
-interface:
- INTERFACE modid
- { /* OLD 95/08: fixlist = Lnil; */
- strcpy(iface_name, id_to_string($2));
- }
- WHERE ibody
- {
- /* WDP: not only do we not check the module name
- but we take the one in the interface to be what we really want
- -- we need this for Prelude jiggery-pokery. (Blech. KH)
- ToDo: possibly revert....
- checkmodname(modname,id_to_string($2));
- */
- $$ = $5;
- }
- ;
-
-
-ibody : ocurly maybeiimports maybefixes itopdecls ccurly
- {
- $$ = mkabind($2,$4);
- }
- | ocurly iimports ccurly
- {
- $$ = $2;
- }
- | vocurly maybeiimports maybefixes itopdecls vccurly
- {
- $$ = mkabind($2,$4);
- }
- | vocurly iimports vccurly
- {
- $$ = $2;
- }
- ;
-
-maybefixes: /* empty */
- | fixes SEMI
- ;
-
-
-fixes : fix
- | fixes SEMI fix
- ;
-
-fix : INFIXL INTEGER
- { Precedence = checkfixity($2); Fixity = INFIXL; }
- ops
- | INFIXR INTEGER
- { Precedence = checkfixity($2); Fixity = INFIXR; }
- ops
- | INFIX INTEGER
- { Precedence = checkfixity($2); Fixity = INFIX; }
- ops
- | INFIXL
- { Fixity = INFIXL; Precedence = 9; }
- ops
- | INFIXR
- { Fixity = INFIXR; Precedence = 9; }
- ops
- | INFIX
- { Fixity = INFIX; Precedence = 9; }
- ops
- ;
-
-ops : op { makeinfix(id_to_string($1),Fixity,Precedence); }
- | ops COMMA op { makeinfix(id_to_string($3),Fixity,Precedence); }
- ;
-
-topdecls: topdecl
- | topdecls SEMI topdecl
- {
- if($1 != NULL)
- if($3 != NULL)
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- else
- $$ = $1;
- else
- $$ = $3;
- SAMEFN = 0;
- }
- ;
-
-topdecl : typed { $$ = $1; }
- | datad { $$ = $1; }
- | classd { $$ = $1; }
- | instd { $$ = $1; }
- | defaultd { $$ = $1; }
- | decl { $$ = $1; }
- ;
-
-typed : typekey simple EQUAL type { $$ = mknbind($2,$4,startlineno,mkno_pragma()); }
- ;
-
-
-datad : datakey context DARROW simple EQUAL constrs
- { $$ = mktbind($2,$4,$6,all,startlineno,mkno_pragma()); }
- | datakey simple EQUAL constrs
- { $$ = mktbind(Lnil,$2,$4,all,startlineno,mkno_pragma()); }
- | datakey context DARROW simple EQUAL constrs DERIVING tyclses
- { $$ = mktbind($2,$4,$6,$8,startlineno,mkno_pragma()); }
- | datakey simple EQUAL constrs DERIVING tyclses
- { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mkno_pragma()); }
- ;
-
-classd : classkey context DARROW class cbody { $$ = mkcbind($2,$4,$5,startlineno,mkno_pragma()); }
- | classkey class cbody { $$ = mkcbind(Lnil,$2,$3,startlineno,mkno_pragma()); }
- ;
-
-cbody : /* empty */ { $$ = mknullbind(); }
- | WHERE ocurly decls ccurly { checkorder($3); $$ = $3; }
- | WHERE vocurly decls vccurly { checkorder($3); $$ =$3; }
- ;
-
-instd : instkey context DARROW tycls restrict_inst rinst { $$ = mkibind($2,$4,$5,$6,startlineno,mkno_pragma()); }
- | instkey tycls general_inst rinst { $$ = mkibind(Lnil,$2,$3,$4,startlineno,mkno_pragma()); }
- ;
-
-rinst : /* empty */ { $$ = mknullbind(); }
- | WHERE ocurly instdefs ccurly { $$ = $3; }
- | WHERE vocurly instdefs vccurly { $$ = $3; }
- ;
-
-restrict_inst : tycon { $$ = mktname($1,Lnil); }
- | OPAREN tycon tyvars CPAREN { $$ = mktname($2,$3); }
- | OPAREN tyvar COMMA tyvar_list CPAREN { $$ = mkttuple(mklcons($2,$4)); }
- | OPAREN CPAREN { $$ = mkttuple(Lnil); }
- | OBRACK tyvar CBRACK { $$ = mktllist($2); }
- | OPAREN tyvar RARROW tyvar CPAREN { $$ = mktfun($2,$4); }
- ;
-
-general_inst : tycon { $$ = mktname($1,Lnil); }
- | OPAREN tycon atypes CPAREN { $$ = mktname($2,$3); }
- | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
- | OPAREN CPAREN { $$ = mkttuple(Lnil); }
- | OBRACK type CBRACK { $$ = mktllist($2); }
- | OPAREN btype RARROW type CPAREN { $$ = mktfun($2,$4); }
- ;
-
-defaultd: defaultkey dtypes { $$ = mkdbind($2,startlineno); }
- ;
-
-dtypes : OPAREN type COMMA types CPAREN { $$ = mklcons($2,$4); }
- | ttype { $$ = lsing($1); }
-/* Omitting the next forces () to be the *type* (), which never defaults.
- This is a KLUDGE. (Putting this in adds piles of r/r conflicts.)
-*/
-/* | OPAREN CPAREN { $$ = Lnil; }*/
- ;
-
-decls : decl
- | decls SEMI decl
- {
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- }
- ;
-
-/* partain: this "DCOLON context" vs "DCOLON type" is a problem,
- because you can't distinguish between
-
- foo :: (Baz a, Baz a)
- bar :: (Baz a, Baz a) => [a] -> [a] -> [a]
-
- with one token of lookahead. The HACK is to have "DCOLON ttype"
- [tuple type] in the first case, then check that it has the right
- form C a, or (C1 a, C2 b, ... Cn z) and convert it into a
- context. Blaach!
- (FIXED 90/06/06)
-
- Note: if there is an iclasop_pragma there, then we must be
- doing a class-op in an interface -- unless the user is up
- to real mischief (ugly, but likely to work).
-*/
-
-decl : vars DCOLON type DARROW type iclasop_pragma
- { /* type2context.c for code */
- $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
- | vars DCOLON type iclasop_pragma
- {
- $$ = mksbind($1,$3,startlineno,$4);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- /* User-specified pragmas come in as "signatures"...
- They are similar in that they can appear anywhere in the module,
- and have to be "joined up" with their related entity.
-
- Have left out the case specialising to an overloaded type.
- Let's get real, OK? (WDP)
- */
- | SPECIALISE_UPRAGMA vark DCOLON types_and_maybe_ids END_UPRAGMA
- {
- $$ = mkvspec_uprag($2, $4, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | SPECIALISE_UPRAGMA INSTANCE CONID general_inst END_UPRAGMA
- {
- $$ = mkispec_uprag($3, $4, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | SPECIALISE_UPRAGMA DATA tycon atypes END_UPRAGMA
- {
- $$ = mkdspec_uprag($3, $4, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | INLINE_UPRAGMA vark howto_inline_maybe END_UPRAGMA
- {
- $$ = mkinline_uprag($2, $3, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | MAGIC_UNFOLDING_UPRAGMA vark vark END_UPRAGMA
- {
- $$ = mkmagicuf_uprag($2, $3, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | DEFOREST_UPRAGMA vark END_UPRAGMA
- {
- $$ = mkdeforest_uprag($2, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | ABSTRACT_UPRAGMA tycon END_UPRAGMA
- {
- $$ = mkabstract_uprag($2, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- /* end of user-specified pragmas */
-
- | valdef
- | /* empty */ { $$ = mknullbind(); PREVPATT = NULL; FN = NULL; SAMEFN = 0; }
- ;
-
-howto_inline_maybe :
- /* empty */ { $$ = Lnil; }
- | CONID { $$ = lsing($1); }
-
-types_and_maybe_ids :
- type_and_maybe_id { $$ = lsing($1); }
- | types_and_maybe_ids COMMA type_and_maybe_id { $$ = lapp($1,$3); }
- ;
-
-type_and_maybe_id :
- type { $$ = mkvspec_ty_and_id($1,Lnil); }
- | type EQUAL vark { $$ = mkvspec_ty_and_id($1,lsing($3)); }
-
-itopdecls : itopdecl { $$ = $1; }
- | itopdecls SEMI itopdecl { $$ = mkabind($1,$3); }
- ;
-
-itopdecl: ityped { $$ = $1; }
- | idatad { $$ = $1; }
- | iclassd { $$ = $1; }
- | iinstd { $$ = $1; }
- | ivarsd { $$ = $1; }
- | /* empty */ { $$ = mknullbind(); }
- ;
-
- /* partain: see comment elsewhere about why "type", not "context" */
-ivarsd : vars DCOLON type DARROW type ival_pragma
- { $$ = mksbind($1,mkcontext(type2context($3),$5),startlineno,$6); }
- | vars DCOLON type ival_pragma
- { $$ = mksbind($1,$3,startlineno,$4); }
- ;
-
-ityped : typekey simple EQUAL type itype_pragma
- { $$ = mknbind($2,$4,startlineno,$5); }
- ;
-
-idatad : datakey context DARROW simple idata_pragma
- { $$ = mktbind($2,$4,Lnil,Lnil,startlineno,$5); }
- | datakey simple idata_pragma
- { $$ = mktbind(Lnil,$2,Lnil,Lnil,startlineno,$3); }
- | datakey context DARROW simple EQUAL constrs idata_pragma
- { $$ = mktbind($2,$4,$6,Lnil,startlineno,$7); }
- | datakey simple EQUAL constrs idata_pragma
- { $$ = mktbind(Lnil,$2,$4,Lnil,startlineno,$5); }
- | datakey context DARROW simple EQUAL constrs DERIVING tyclses
- { $$ = mktbind($2,$4,$6,$8,startlineno,mkno_pragma()); }
- | datakey simple EQUAL constrs DERIVING tyclses
- { $$ = mktbind(Lnil,$2,$4,$6,startlineno,mkno_pragma()); }
- ;
-
-iclassd : classkey context DARROW class iclas_pragma cbody
- { $$ = mkcbind($2,$4,$6,startlineno,$5); }
- | classkey class iclas_pragma cbody
- { $$ = mkcbind(Lnil,$2,$4,startlineno,$3); }
- ;
-
-iinstd : instkey context DARROW tycls general_inst iinst_pragma
- { $$ = mkibind($2,$4,$5,mknullbind(),startlineno,$6); }
- | instkey tycls general_inst iinst_pragma
- { $$ = mkibind(Lnil,$2,$3,mknullbind(),startlineno,$4); }
- ;
-
-
-/* obsolete: "(C a, ...)" cause r/r conflict, resolved in favour of context rather than type */
-
-class : tycon tyvar { $$ = mktname($1,lsing($2)); }
- /* partain: changed "tycls" to "tycon" */
- ;
-
-types : type { $$ = lsing($1); }
- | types COMMA type { $$ = lapp($1,$3); }
- ;
-
-type : btype { $$ = $1; }
- | btype RARROW type { $$ = mktfun($1,$3); }
-
- | FORALL core_tv_templates DARROW type
- { $$ = mkuniforall($2, $4); }
-
-btype : atype { $$ = $1; }
- | tycon atypes { $$ = mktname($1,$2); }
- ;
-
-atypes : atypes atype { $$ = lapp($1,$2); }
- | atype { $$ = lsing($1); }
- ;
-
-/* The split with ntatype allows us to use the same syntax for defaults as for types */
-ttype : ntatype { $$ = $1; }
- | btype RARROW type { $$ = mktfun($1,$3); }
- | tycon atypes { $$ = mktname($1,$2); }
- ;
-
-atype : ntatype
- | OPAREN type COMMA types CPAREN { $$ = mkttuple(mklcons($2,$4)); }
- ;
-
-ntatype : tyvar { $$ = $1; }
- | tycon { $$ = mktname($1,Lnil); }
- | OPAREN CPAREN { $$ = mkttuple(Lnil); }
- | OPAREN type CPAREN { $$ = $2; }
- | OBRACK type CBRACK { $$ = mktllist($2); }
-
- | OCURLY OCURLY CONID type CCURLY CCURLY
- { $$ = mkunidict($3, $4); }
- | TYVAR_TEMPLATE_ID { $$ = mkunityvartemplate($1); }
- ;
-
-
-simple : tycon { $$ = mktname($1,Lnil); }
- | tycon tyvars { $$ = mktname($1,$2); }
- ;
-
-constrs : constr { $$ = lsing($1); }
- | constrs VBAR constr { $$ = lapp($1,$3); }
- ;
-
-/* Using tycon rather than con avoids 5 S/R errors */
-constr : tycon atypes { $$ = mkatc($1,$2,hsplineno); }
- | OPAREN CONSYM CPAREN atypes { $$ = mkatc($2,$4,hsplineno); }
- | tycon { $$ = mkatc($1,Lnil,hsplineno); }
- | OPAREN CONSYM CPAREN { $$ = mkatc($2,Lnil,hsplineno); }
- | btype conop btype { $$ = mkatc($2, ldub($1,$3),hsplineno); }
- ;
-
-tyclses : OPAREN tycls_list CPAREN { $$ = $2; }
- | OPAREN CPAREN { $$ = Lnil; }
- | tycls { $$ = lsing($1); }
- ;
-
-tycls_list: tycls { $$ = lsing($1); }
- | tycls_list COMMA tycls { $$ = lapp($1,$3); }
- ;
-
-context : OPAREN context_list CPAREN { $$ = $2; }
- | class { $$ = lsing($1); }
- ;
-
-context_list: class { $$ = lsing($1); }
- | context_list COMMA class { $$ = lapp($1,$3); }
- ;
-
-instdefs : /* empty */ { $$ = mknullbind(); }
- | instdef { $$ = $1; }
- | instdefs SEMI instdef
- {
- if(SAMEFN)
- {
- extendfn($1,$3);
- $$ = $1;
- }
- else
- $$ = mkabind($1,$3);
- }
- ;
-
-/* instdef: same as valdef, except certain user-pragmas may appear */
-instdef :
- SPECIALISE_UPRAGMA vark DCOLON types_and_maybe_ids END_UPRAGMA
- {
- $$ = mkvspec_uprag($2, $4, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | INLINE_UPRAGMA vark howto_inline_maybe END_UPRAGMA
- {
- $$ = mkinline_uprag($2, $3, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | MAGIC_UNFOLDING_UPRAGMA vark vark END_UPRAGMA
- {
- $$ = mkmagicuf_uprag($2, $3, startlineno);
- PREVPATT = NULL; FN = NULL; SAMEFN = 0;
- }
-
- | valdef
- ;
-
-
-vars : vark COMMA varsrest { $$ = mklcons($1,$3); }
- | vark { $$ = lsing($1); }
- ;
-
-varsrest: var { $$ = lsing($1); }
- | varsrest COMMA var { $$ = lapp($1,$3); }
- ;
-
-cons : con { $$ = lsing($1); }
- | cons COMMA con { $$ = lapp($1,$3); }
- ;
-
-
-valdef : opatk
- {
- tree fn = function($1);
-
- PREVPATT = $1;
-
- if(ttree(fn) == ident)
- {
- checksamefn(gident((struct Sident *) fn));
- FN = fn;
- }
-
- else if (ttree(fn) == tinfixop && ttree(ginfun((struct Sap *) fn)) == ident)
- {
- checksamefn(gident((struct Sident *) (ginfun((struct Sap *) fn))));
- FN = ginfun((struct Sap *) fn);
- }
-
- else if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tvaldef\n",startlineno);
-#endif
- }
- valrhs
- {
- if ( lhs_is_patt($1) )
- {
- $$ = mkpbind($3, startlineno);
- FN = NULL;
- SAMEFN = 0;
- }
- else /* lhs is function */
- $$ = mkfbind($3,startlineno);
-
- PREVPATT = NULL;
- }
- ;
-
-valrhs : valrhs1 maybe_where { $$ = lsing(createpat($1, $2)); }
- ;
-
-valrhs1 : gdrhs
- | EQUAL exp { $$ = lsing(mktruecase($2)); }
- ;
-
-gdrhs : gd EQUAL exp { $$ = lsing(ldub($1,$3)); }
- | gd EQUAL exp gdrhs { $$ = mklcons(ldub($1,$3),$4); }
- ;
-
-maybe_where:
- WHERE ocurly decls ccurly { $$ = $3; }
- | WHERE vocurly decls vccurly { $$ = $3; }
- | /* empty */ { $$ = mknullbind(); }
- ;
-
-gd : VBAR oexp { $$ = $2; }
- ;
-
-
-lampats : apat lampats { $$ = mklcons($1,$2); }
- | apat { $$ = lsing($1); }
- /* right recursion? (WDP) */
- ;
-
-
-/*
- Changed as above to allow for contexts!
- KH@21/12/92
-*/
-
-exp : oexp DCOLON type DARROW type { $$ = mkrestr($1,mkcontext(type2context($3),$5)); }
- | oexp DCOLON type { $$ = mkrestr($1,$3); }
- | oexp
- ;
-
-/*
- Operators must be left-associative at the same precedence
- for prec. parsing to work.
-*/
-
- /* Infix operator application */
-oexp : dexp
- | oexp op oexp %prec PLUS
- { $$ = mkinfixop($2,$1,$3); precparse($$); }
- ;
-
-/*
- This comes here because of the funny precedence rules concerning
- prefix minus.
-*/
-
-
-dexp : MINUS kexp { $$ = mknegate($2); }
- | kexp
- ;
-
-/*
- let/if/lambda/case have higher precedence than infix operators.
-*/
-
-kexp : LAMBDA
- { /* enteriscope(); /? I don't understand this -- KH */
- hsincindent(); /* added by partain; push new context for */
- /* FN = NULL; not actually concerned about */
- FN = NULL; /* indenting */
- $<uint>$ = hsplineno; /* remember current line number */
- }
- lampats
- { hsendindent(); /* added by partain */
- /* exitiscope(); /? Also not understood */
- }
- RARROW exp /* lambda abstraction */
- {
- $$ = mklambda($3, $6, $<uint>2);
- }
-
- /* Let Expression */
- | LET ocurly decls ccurly IN exp { $$ = mklet($3,$6); }
- | LET vocurly decls vccurly IN exp { $$ = mklet($3,$6); }
-
- /* If Expression */
- | IF exp THEN exp ELSE exp { $$ = mkife($2,$4,$6); }
-
- /* Case Expression */
- | CASE exp OF ocurly alts ccurly { $$ = mkcasee($2,$5); }
- | CASE exp OF vocurly alts vccurly { $$ = mkcasee($2,$5); }
-
- /* CCALL/CASM Expression */
- | CCALL ccallid cexp { $$ = mkccall($2,installid("n"),$3); }
- | CCALL ccallid { $$ = mkccall($2,installid("n"),Lnil); }
- | CCALL_GC ccallid cexp { $$ = mkccall($2,installid("p"),$3); }
- | CCALL_GC ccallid { $$ = mkccall($2,installid("p"),Lnil); }
- | CASM CLITLIT cexp { $$ = mkccall($2,installid("N"),$3); }
- | CASM CLITLIT { $$ = mkccall($2,installid("N"),Lnil); }
- | CASM_GC CLITLIT cexp { $$ = mkccall($2,installid("P"),$3); }
- | CASM_GC CLITLIT { $$ = mkccall($2,installid("P"),Lnil); }
-
- /* SCC Expression */
- | SCC STRING exp
- { if (ignoreSCC) {
- if (warnSCC)
- fprintf(stderr,
- "\"%s\", line %d: _scc_ (`set [profiling] cost centre') ignored\n",
- input_filename, hsplineno);
- $$ = $3;
- } else {
- $$ = mkscc($2, $3);
- }
- }
- | fexp
- ;
-
-
- /* Function application */
-fexp : fexp aexp { $$ = mkap($1,$2); }
- | aexp
- ;
-
-cexp : cexp aexp { $$ = lapp($1,$2); }
- | aexp { $$ = lsing($1); }
- ;
-
-/*
- The mkpars are so that infix parsing doesn't get confused.
-
- KH.
-*/
-
- /* Simple Expressions */
-aexp : var { $$ = mkident($1); }
- | con { $$ = mkident($1); }
- | lit_constant { $$ = mklit($1); }
- | OPAREN exp CPAREN { $$ = mkpar($2); }
- | OPAREN oexp op CPAREN { checkprec($2,$3,FALSE); $$ = mklsection($2,$3); }
- | OPAREN op1 oexp CPAREN { checkprec($3,$2,TRUE); $$ = mkrsection($2,$3); }
-
- /* structures */
- | tuple
- | list { $$ = mkpar($1); }
- | sequence { $$ = mkpar($1); }
- | comprehension { $$ = mkpar($1); }
-
- /* These only occur in patterns */
- | var AT aexp { checkinpat(); $$ = mkas($1,$3); }
- | WILDCARD { checkinpat(); $$ = mkwildp(); }
- | LAZY aexp { checkinpat(); $$ = mklazyp($2); }
- ;
-
-
-/*
- LHS patterns are parsed in a similar way to
- expressions. This avoids the horrible non-LRness
- which occurs with the 1.1 syntax.
-
- The xpatk business is to do with accurately recording
- the starting line for definitions.
-*/
-
-opatk : dpatk
- | opatk op opat %prec PLUS
- {
- $$ = mkinfixop($2,$1,$3);
-
- if(isconstr(id_to_string($2)))
- precparse($$);
- else
- {
- checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */
- checkprec($3,$2,TRUE); /* then check the right pattern */
- }
- }
- ;
-
-opat : dpat
- | opat op opat %prec PLUS
- {
- $$ = mkinfixop($2,$1,$3);
-
- if(isconstr(id_to_string($2)))
- precparse($$);
- else
- {
- checkprec($1,$2,FALSE); /* Check the precedence of the left pattern */
- checkprec($3,$2,TRUE); /* then check the right pattern */
- }
- }
- ;
-
-/*
- This comes here because of the funny precedence rules concerning
- prefix minus.
-*/
-
-
-dpat : MINUS fpat { $$ = mknegate($2); }
- | fpat
- ;
-
- /* Function application */
-fpat : fpat aapat { $$ = mkap($1,$2); }
- | aapat
- ;
-
-dpatk : minuskey fpat { $$ = mknegate($2); }
- | fpatk
- ;
-
- /* Function application */
-fpatk : fpatk aapat { $$ = mkap($1,$2); }
- | aapatk
- ;
-
-aapat : con { $$ = mkident($1); }
- | var { $$ = mkident($1); }
- | var AT apat { $$ = mkas($1,$3); }
- | lit_constant { $$ = mklit($1); }
- | WILDCARD { $$ = mkwildp(); }
- | OPAREN CPAREN { $$ = mktuple(Lnil); }
- | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); }
-/* GHC cannot do these anyway. WDP 93/11/15
- | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); }
-*/
- | OPAREN opat CPAREN { $$ = mkpar($2); }
- | OPAREN opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | OBRACK pats CBRACK { $$ = mkllist($2); }
- | OBRACK CBRACK { $$ = mkllist(Lnil); }
- | LAZY apat { $$ = mklazyp($2); }
- ;
-
-aapatk : conk { $$ = mkident($1); }
- | vark { $$ = mkident($1); }
- | vark AT apat { $$ = mkas($1,$3); }
- | lit_constant { $$ = mklit($1); setstartlineno(); }
- | WILDCARD { $$ = mkwildp(); setstartlineno(); }
- | oparenkey CPAREN { $$ = mktuple(Lnil); }
- | oparenkey var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); }
-/* GHC no cannae do (WDP 95/05)
- | oparenkey WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); }
-*/
- | oparenkey opat CPAREN { $$ = mkpar($2); }
- | oparenkey opat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | obrackkey pats CBRACK { $$ = mkllist($2); }
- | obrackkey CBRACK { $$ = mkllist(Lnil); }
- | lazykey apat { $$ = mklazyp($2); }
- ;
-
-
-tuple : OPAREN exp COMMA texps CPAREN
- { if (ttree($4) == tuple)
- $$ = mktuple(mklcons($2, gtuplelist((struct Stuple *) $4)));
- else
- $$ = mktuple(ldub($2, $4));
- }
- | OPAREN CPAREN
- { $$ = mktuple(Lnil); }
- ;
-
-/*
- The mkpar is so that infix parsing doesn't get confused.
-
- KH.
-*/
-texps : exp { $$ = mkpar($1); }
- | exp COMMA texps
- { if (ttree($3) == tuple)
- $$ = mktuple(mklcons($1, gtuplelist((struct Stuple *) $3)));
- else
- $$ = mktuple(ldub($1, $3));
- }
- /* right recursion? WDP */
- ;
-
-
-list : OBRACK CBRACK { $$ = mkllist(Lnil); }
- | OBRACK list_exps CBRACK { $$ = mkllist($2); }
- ;
-
-list_exps :
- exp { $$ = lsing($1); }
- | exp COMMA list_exps { $$ = mklcons($1, $3); }
- /* right recursion? (WDP)
-
- It has to be this way, though, otherwise you
- may do the wrong thing to distinguish between...
-
- [ e1 , e2 .. ] -- an enumeration ...
- [ e1 , e2 , e3 ] -- a list
-
- (In fact, if you change the grammar and throw yacc/bison
- at it, it *will* do the wrong thing [WDP 94/06])
- */
- ;
-
-
-sequence: OBRACK exp COMMA exp DOTDOT upto CBRACK {$$ = mkeenum($2,lsing($4),$6);}
- | OBRACK exp DOTDOT upto CBRACK { $$ = mkeenum($2,Lnil,$4); }
- ;
-
-comprehension: OBRACK exp VBAR quals CBRACK { $$ = mkcomprh($2,$4); }
- ;
-
-quals : qual { $$ = lsing($1); }
- | quals COMMA qual { $$ = lapp($1,$3); }
- ;
-
-qual : { inpat = TRUE; } exp { inpat = FALSE; } qualrest
- { if ($4 == NULL) {
- patternOrExpr(/*wanted:*/ LEGIT_EXPR,$2);
- $$ = mkguard($2);
- } else {
- patternOrExpr(/*wanted:*/ LEGIT_PATT,$2);
- $$ = mkqual($2,$4);
-/* OLD: WDP 95/08
- if(ttree($4)==def)
- {
- tree prevpatt_save = PREVPATT;
- PREVPATT = $2;
- $$ = mkdef((tree) mkpbind(lsing(createpat(lsing(mktruecase(ggdef((struct Sdef *) $4))),mknullbind())),hsplineno));
- PREVPATT = prevpatt_save;
- }
- else
-*/
- }
- }
- ;
-
-qualrest: LARROW exp { $$ = $2; }
- | /* empty */ { $$ = NULL; }
- ;
-
-alts : alt { $$ = $1; }
- | alts SEMI alt { $$ = lconc($1,$3); }
- ;
-
-alt : pat
- { PREVPATT = $1; }
- altrest
- { $$ = $3;
- PREVPATT = NULL;
- }
- | /* empty */ { $$ = Lnil; }
- ;
-
-altrest : gdpat maybe_where { $$ = lsing(createpat($1, $2)); }
- | RARROW exp maybe_where { $$ = lsing(createpat(lsing(mktruecase($2)), $3)); }
- ;
-
-gdpat : gd RARROW exp gdpat { $$ = mklcons(ldub($1,$3),$4); }
- | gd RARROW exp { $$ = lsing(ldub($1,$3)); }
- ;
-
-upto : /* empty */ { $$ = Lnil; }
- | exp { $$ = lsing($1); }
- ;
-
-pats : pat COMMA pats { $$ = mklcons($1, $3); }
- | pat { $$ = lsing($1); }
- /* right recursion? (WDP) */
- ;
-
-pat : bpat
- | pat conop bpat { $$ = mkinfixop($2,$1,$3); precparse($$); }
- ;
-
-bpat : apatc
- | conpat
- | MINUS INTEGER { $$ = mklit(mkinteger(ineg($2))); }
- | MINUS FLOAT { $$ = mklit(mkfloatr(ineg($2))); }
- ;
-
-conpat : con { $$ = mkident($1); }
- | conpat apat { $$ = mkap($1,$2); }
- ;
-
-apat : con { $$ = mkident($1); }
- | apatc
- ;
-
-apatc : var { $$ = mkident($1); }
- | var AT apat { $$ = mkas($1,$3); }
- | lit_constant { $$ = mklit($1); }
- | WILDCARD { $$ = mkwildp(); }
- | OPAREN CPAREN { $$ = mktuple(Lnil); }
- | OPAREN var PLUS INTEGER CPAREN { $$ = mkplusp(mkident($2),mkinteger($4)); }
-/* GHC no cannae do (WDP 95/05)
- | OPAREN WILDCARD PLUS INTEGER CPAREN { $$ = mkplusp(mkwildp(),mkinteger($4)); }
-*/
- | OPAREN pat CPAREN { $$ = mkpar($2); }
- | OPAREN pat COMMA pats CPAREN { $$ = mktuple(mklcons($2,$4)); }
- | OBRACK pats CBRACK { $$ = mkllist($2); }
- | OBRACK CBRACK { $$ = mkllist(Lnil); }
- | LAZY apat { $$ = mklazyp($2); }
- ;
-
-lit_constant:
- INTEGER { $$ = mkinteger($1); }
- | FLOAT { $$ = mkfloatr($1); }
- | CHAR { $$ = mkcharr($1); }
- | STRING { $$ = mkstring($1); }
- | CHARPRIM { $$ = mkcharprim($1); }
- | STRINGPRIM { $$ = mkstringprim($1); }
- | INTPRIM { $$ = mkintprim($1); }
- | FLOATPRIM { $$ = mkfloatprim($1); }
- | DOUBLEPRIM { $$ = mkdoubleprim($1); }
- | CLITLIT /* yurble yurble */ { $$ = mkclitlit($1, ""); }
- | CLITLIT KIND_PRAGMA CONID { $$ = mkclitlit($1, $3); }
- | NOREP_INTEGER INTEGER { $$ = mknorepi($2); }
- | NOREP_RATIONAL INTEGER INTEGER { $$ = mknorepr($2, $3); }
- | NOREP_STRING STRING { $$ = mknoreps($2); }
- ;
-
-
-/* Keywords which record the line start */
-
-importkey: IMPORT { setstartlineno(); }
- ;
-
-datakey : DATA { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tdata\n",startlineno);
-#endif
- }
- ;
-
-typekey : TYPE { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\ttype\n",startlineno);
-#endif
- }
- ;
-
-instkey : INSTANCE { setstartlineno();
-#if 1/*etags*/
-/* OUT: if(etags)
- printf("%u\n",startlineno);
-*/
-#else
- fprintf(stderr,"%u\tinstance\n",startlineno);
-#endif
- }
- ;
-
-defaultkey: DEFAULT { setstartlineno(); }
- ;
-
-classkey: CLASS { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tclass\n",startlineno);
-#endif
- }
- ;
-
-minuskey: MINUS { setstartlineno(); }
- ;
-
-modulekey: MODULE { setstartlineno();
- if(etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tmodule\n",startlineno);
-#endif
- }
- ;
-
-oparenkey: OPAREN { setstartlineno(); }
- ;
-
-obrackkey: OBRACK { setstartlineno(); }
- ;
-
-lazykey : LAZY { setstartlineno(); }
- ;
-
-
-
-/* Non "-" op, used in right sections -- KH */
-op1 : conop
- | varop1
- ;
-
-op : conop
- | varop
- ;
-
-varop : varsym
- | BQUOTE VARID BQUOTE { $$ = $2; }
- ;
-
-/* Non-minus varop, used in right sections */
-varop1 : VARSYM
- | plus
- | BQUOTE VARID BQUOTE { $$ = $2; }
- ;
-
-conop : CONSYM
- | BQUOTE CONID BQUOTE { $$ = $2; }
- ;
-
-varsym : VARSYM
- | plus
- | minus
- ;
-
-minus : MINUS { $$ = install_literal("-"); }
- ;
-
-plus : PLUS { $$ = install_literal("+"); }
- ;
-
-var : VARID
- | OPAREN varsym CPAREN { $$ = $2; }
- ;
-
-vark : VARID { setstartlineno(); $$ = $1; }
- | oparenkey varsym CPAREN { $$ = $2; }
- ;
-
-/* tycon used here to eliminate 11 spurious R/R errors -- KH */
-con : tycon
- | OPAREN CONSYM CPAREN { $$ = $2; }
- ;
-
-conk : tycon { setstartlineno(); $$ = $1; }
- | oparenkey CONSYM CPAREN { $$ = $2; }
- ;
-
-ccallid : VARID
- | CONID
- ;
-
-tyvar_list: tyvar { $$ = lsing($1); }
- | tyvar_list COMMA tyvar { $$ = lapp($1,$3); }
- ;
-
-tyvars : tyvar { $$ = lsing($1); }
- | tyvars tyvar { $$ = lapp($1, $2); }
- ;
-
-tyvar : VARID { $$ = mknamedtvar($1); }
- ;
-
-tycls : tycon
- /* partain: "aconid"->"tycon" got rid of a r/r conflict
- (and introduced >= 2 s/r's ...)
- */
- ;
-
-tycon : CONID
- ;
-
-modid : CONID
- ;
-
-
-ocurly : layout OCURLY { hsincindent(); }
-
-vocurly : layout { hssetindent(); }
- ;
-
-layout : { hsindentoff(); }
- ;
-
-ccurly :
- CCURLY
- {
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- }
- ;
-
-vccurly : { expect_ccurly = 1; } vccurly1 { expect_ccurly = 0; }
- ;
-
-vccurly1:
- VCCURLY
- {
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- }
- | error
- {
- yyerrok;
- FN = NULL; SAMEFN = 0; PREVPATT = NULL;
- hsendindent();
- }
- ;
-
-%%
-
-/**********************************************************************
-* *
-* Error Processing and Reporting *
-* *
-* (This stuff is here in case we want to use Yacc macros and such.) *
-* *
-**********************************************************************/
-
-/* The parser calls "hsperror" when it sees a
- `report this and die' error. It sets the stage
- and calls "yyerror".
-
- There should be no direct calls in the parser to
- "yyerror", except for the one from "hsperror". Thus,
- the only other calls will be from the error productions
- introduced by yacc/bison/whatever.
-
- We need to be able to recognise the from-error-production
- case, because we sometimes want to say, "Oh, never mind",
- because the layout rule kicks into action and may save
- the day. [WDP]
-*/
-
-static BOOLEAN error_and_I_mean_it = FALSE;
-
-void
-hsperror(s)
- char *s;
-{
- error_and_I_mean_it = TRUE;
- yyerror(s);
-}
-
-extern char *yytext;
-extern int yyleng;
-
-void
-yyerror(s)
- char *s;
-{
- /* We want to be able to distinguish 'error'-raised yyerrors
- from yyerrors explicitly coded by the parser hacker.
- */
- if (expect_ccurly && ! error_and_I_mean_it ) {
- /*NOTHING*/;
-
- } else {
- fprintf(stderr, "\"%s\", line %d, column %d: %s on input: ",
- input_filename, hsplineno, hspcolno + 1, s);
-
- if (yyleng == 1 && *yytext == '\0')
- fprintf(stderr, "<EOF>");
-
- else {
- fputc('"', stderr);
- format_string(stderr, (unsigned char *) yytext, yyleng);
- fputc('"', stderr);
- }
- fputc('\n', stderr);
-
- /* a common problem */
- if (strcmp(yytext, "#") == 0)
- fprintf(stderr, "\t(Perhaps you forgot a `-cpp' or `-fglasgow-exts' flag?)\n");
-
- exit(1);
- }
-}
-
-void
-format_string(fp, s, len)
- FILE *fp;
- unsigned char *s;
- int len;
-{
- while (len-- > 0) {
- switch (*s) {
- case '\0': fputs("\\NUL", fp); break;
- case '\007': fputs("\\a", fp); break;
- case '\010': fputs("\\b", fp); break;
- case '\011': fputs("\\t", fp); break;
- case '\012': fputs("\\n", fp); break;
- case '\013': fputs("\\v", fp); break;
- case '\014': fputs("\\f", fp); break;
- case '\015': fputs("\\r", fp); break;
- case '\033': fputs("\\ESC", fp); break;
- case '\034': fputs("\\FS", fp); break;
- case '\035': fputs("\\GS", fp); break;
- case '\036': fputs("\\RS", fp); break;
- case '\037': fputs("\\US", fp); break;
- case '\177': fputs("\\DEL", fp); break;
- default:
- if (*s >= ' ')
- fputc(*s, fp);
- else
- fprintf(fp, "\\^%c", *s + '@');
- break;
- }
- s++;
- }
-}
+++ /dev/null
-#ifndef HSPINCL_H
-#define HSPINCL_H
-
-#include "../../includes/config.h"
-
-#if __STDC__
-#define PROTO(x) x
-#define NO_ARGS void
-#define CONST const
-#define VOID void
-#define VOID_STAR void *
-#define VOLATILE volatile
-#else
-#define PROTO(x) ()
-#define NO_ARGS /* no args */
-#define CONST /* no const */
-#define VOID void /* hope for the best... */
-#define VOID_STAR long *
-#define VOLATILE /* no volatile */
-#endif /* ! __STDC__ */
-
-#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
-#include <string.h>
-/* An ANSI string.h and pre-ANSI memory.h might conflict. */
-#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H)
-#include <memory.h>
-#endif /* not STDC_HEADERS and HAVE_MEMORY_H */
-#define index strchr
-#define rindex strrchr
-#define bcopy(s, d, n) memcpy ((d), (s), (n))
-#define bcmp(s1, s2, n) memcmp ((s1), (s2), (n))
-#define bzero(s, n) memset ((s), 0, (n))
-#else /* not STDC_HEADERS and not HAVE_STRING_H */
-#include <strings.h>
-/* memory.h and strings.h conflict on some systems. */
-#endif /* not STDC_HEADERS and not HAVE_STRING_H */
-
-#ifdef HAVE_MALLOC_H
-#include <malloc.h>
-#endif
-#ifdef HAVE_STDLIB_H
-#include <stdlib.h>
-#endif
-
-#include "id.h"
-#include "literal.h"
-#include "list.h"
-#ifdef DPH
-#include "ttype-DPH.h"
-#else
-#include "ttype.h"
-#endif
-#include "atype.h"
-#include "coresyn.h"
-#include "hpragma.h"
-#include "binding.h"
-#include "finfot.h"
-/*#include "impidt.h"*/
-#include "entidt.h"
-#ifdef DPH
-#include "tree-DPH.h"
-#else
-#define infixTree tree
-#include "tree.h"
-#endif
-#include "pbinding.h"
-
-extern char *input_filename;
-
-extern tree *Rginfun PROTO((struct Sap *));
-extern tree *Rginarg1 PROTO((struct Sap *));
-extern tree *Rginarg2 PROTO((struct Sap *));
-
-#endif /* HSPINCL_H */
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Identifier Processing *
-* *
-* *
-**********************************************************************/
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "id.h"
-#include "utils.h"
-
-/* partain: special version for strings that may have NULs (etc) in them
- (used in UgenUtil.lhs)
-*/
-long
-get_hstring_len(hs)
- hstring hs;
-{
- return(hs->len);
-}
-
-char *
-get_hstring_bytes(hs)
- hstring hs;
-{
- return(hs->bytes);
-}
-
-hstring
-installHstring(length, s)
- int length;
- char *s;
-{
- char *p;
- hstring str;
- int i;
-
-/* fprintf(stderr, "installHstring: %d, %s\n",length, s); */
-
- if (length > 999999) { /* too long */
- fprintf(stderr,"String length more than six digits\n");
- exit(1);
- } else if (length < 0) { /* too short */
- fprintf(stderr,"String length < 0 !!\n");
- abort();
- }
-
- /* alloc the struct and store the length */
- str = (hstring) xmalloc(sizeof(Hstring));
- str->len = length;
-
- if (length == 0) {
- str->bytes = NULL;
-
- } else {
- p = xmalloc(length);
-
- /* now store the string */
- for (i = 0; i < length; i++) {
- p[i] = s[i];
- }
- str->bytes = p;
- }
- return str;
-}
-
-
-/**********************************************************************
-* *
-* *
-* Hashed Identifiers *
-* *
-* *
-**********************************************************************/
-
-
-extern BOOLEAN hashIds; /* Whether to use hashed ids. */
-
-unsigned hash_table_size = HASH_TABLE_SIZE;
-
-static char **hashtab = NULL;
-
-static unsigned max_hash_table_entries = 0;
-
-void
-hash_init()
-{
- if(!hashIds) {
- /*NOTHING*/;
-
- } else {
-
- /* Create an initialised hash table */
- hashtab = (char **) calloc( hash_table_size, sizeof(char *) );
- if(hashtab == NULL)
- {
- fprintf(stderr,"Cannot allocate a hash table with %d entries -- insufficient memory\n",hash_table_size);
- exit(1);
- }
-#ifdef HSP_DEBUG
- fprintf(stderr,"hashtab = %x\n",hashtab);
-#endif
-
- /* Allow no more than 90% occupancy -- Divide first to avoid overflows with BIG tables! */
- max_hash_table_entries = (hash_table_size / 10) * 9;
- }
-}
-
-void
-print_hash_table()
-{
- if(hashIds)
- {
- unsigned i;
-
- printf("%u ",hash_table_size);
-
- for(i=0; i < hash_table_size; ++i)
- if(hashtab[i] != NULL)
- printf("(%u,%s) ",i,hashtab[i]);
- }
-}
-
-
-long int
-hash_index(ident)
- id ident;
-{
- return((char **) /* YURGH */ ident - hashtab);
-}
-
-
-/*
- The hash function. Returns 0 for Null strings.
-*/
-
-static unsigned hash_fn(char *ident)
-{
- unsigned len = (unsigned) strlen(ident);
- unsigned res;
-
- if(*ident == '\0')
- return( 0 );
-
- /* does not work well for hash tables with more than 35K elements */
- res = (((unsigned)ident[0]*631)+((unsigned)ident[len/2-1]*217)+((unsigned)ident[len-1]*43)+len)
- % hash_table_size;
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"\"%s\" hashes to %d\n",ident,res);
-#endif
- return(res);
-}
-
-
-/*
- Install a literal identifier, such as "+" in hsparser.
- If we are not using hashing, just return the string.
-*/
-
-id
-install_literal(s)
- char *s;
-{
- return( hashIds? installid(s): s);
-}
-
-
-char *
-id_to_string(sp)
- id sp;
-{
- return( hashIds? *(char **)sp: (char *)sp );
-}
-
-id
-installid(s)
- char *s;
-{
- unsigned hash, count;
-
- if(!hashIds)
- return(xstrdup(s));
-
- for(hash = hash_fn(s),count=0; count<max_hash_table_entries; ++hash,++count)
- {
- if (hash >= hash_table_size) hash = 0;
-
- if(hashtab[hash] == NULL)
- {
- hashtab[hash] = xstrdup(s);
-#ifdef HSP_DEBUG
- fprintf(stderr,"New Hash Entry %x\n",(char *)&hashtab[hash]);
-#endif
- if ( count >= 100 ) {
- fprintf(stderr, "installid: %d collisions for %s\n", count, s);
- }
-
- return((char *)&hashtab[hash]);
- }
-
- if(strcmp(hashtab[hash],s) == 0)
- {
-#ifdef HSP_DEBUG
- fprintf(stderr,"Old Hash Entry %x (%s)\n",(char *)&hashtab[hash],hashtab[hash]);
-#endif
- if ( count >= 100 ) {
- fprintf(stderr, "installid: %d collisions for %s\n", count, s);
- }
-
- return((char *)&hashtab[hash]);
- }
- }
- fprintf(stderr,"Hash Table Contains more than %d entries -- make larger?\n",max_hash_table_entries);
- exit(1);
-}
-
-
-/**********************************************************************
-* *
-* *
-* Memory Allocation *
-* *
-* *
-**********************************************************************/
-
-/* Malloc with error checking */
-
-char *
-xmalloc(length)
-unsigned length;
-{
- char *stuff = malloc(length);
-
- if (stuff == NULL) {
- fprintf(stderr, "xmalloc failed on a request for %d bytes\n", length);
- exit(1);
- }
- return (stuff);
-}
-
-char *
-xrealloc(ptr, length)
-char *ptr;
-unsigned length;
-{
- char *stuff = realloc(ptr, length);
-
- if (stuff == NULL) {
- fprintf(stderr, "xrealloc failed on a request for %d bytes\n", length);
- exit(1);
- }
- return (stuff);
-}
-
-/* Strdup with error checking */
-
-char *
-xstrdup(s)
-char *s;
-{
- unsigned len = strlen(s);
- return xstrndup(s, len);
-}
-
-/*
- * Strdup for possibly unterminated strings (e.g. substrings of longer strings)
- * with error checking. Handles NULs as well.
- */
-
-char *
-xstrndup(s, len)
-char *s;
-unsigned len;
-{
- char *p = xmalloc(len + 1);
-
- bcopy(s, p, len);
- p[len] = '\0';
-
- return (p);
-}
+++ /dev/null
-#ifndef ID_H
-#define ID_H
-
-typedef char *id;
-typedef id unkId; /* synonym */
-typedef id stringId; /* synonym */
-typedef id numId; /* synonym, for now */
-
-typedef struct { long len; char *bytes; } Hstring;
-typedef Hstring *hstring;
-
-long get_hstring_len PROTO((hstring));
-char *get_hstring_bytes PROTO((hstring));
-
-#endif
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/impidt.h"
-Timpidt timpidt(t)
- impidt t;
-{
- return(t -> tag);
-}
-
-
-/************** impid ******************/
-
-impidt mkimpid(PPgimpid, PPgimptype, PPgimpfinfo, PPgivline)
- id PPgimpid;
- ttype PPgimptype;
- finfot PPgimpfinfo;
- long PPgivline;
-{
- register struct Simpid *pp =
- (struct Simpid *) malloc(sizeof(struct Simpid));
- pp -> tag = impid;
- pp -> Xgimpid = PPgimpid;
- pp -> Xgimptype = PPgimptype;
- pp -> Xgimpfinfo = PPgimpfinfo;
- pp -> Xgivline = PPgivline;
- return((impidt)pp);
-}
-
-id *Rgimpid(t)
- struct Simpid *t;
-{
- if(t -> tag != impid)
- fprintf(stderr,"gimpid: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpid);
-}
-
-ttype *Rgimptype(t)
- struct Simpid *t;
-{
- if(t -> tag != impid)
- fprintf(stderr,"gimptype: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimptype);
-}
-
-finfot *Rgimpfinfo(t)
- struct Simpid *t;
-{
- if(t -> tag != impid)
- fprintf(stderr,"gimpfinfo: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpfinfo);
-}
-
-long *Rgivline(t)
- struct Simpid *t;
-{
- if(t -> tag != impid)
- fprintf(stderr,"givline: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgivline);
-}
-
-/************** imptype ******************/
-
-impidt mkimptype(PPgimptypec, PPgimptypet, PPgimptyped, PPgitline)
- list PPgimptypec;
- ttype PPgimptypet;
- list PPgimptyped;
- long PPgitline;
-{
- register struct Simptype *pp =
- (struct Simptype *) malloc(sizeof(struct Simptype));
- pp -> tag = imptype;
- pp -> Xgimptypec = PPgimptypec;
- pp -> Xgimptypet = PPgimptypet;
- pp -> Xgimptyped = PPgimptyped;
- pp -> Xgitline = PPgitline;
- return((impidt)pp);
-}
-
-list *Rgimptypec(t)
- struct Simptype *t;
-{
- if(t -> tag != imptype)
- fprintf(stderr,"gimptypec: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimptypec);
-}
-
-ttype *Rgimptypet(t)
- struct Simptype *t;
-{
- if(t -> tag != imptype)
- fprintf(stderr,"gimptypet: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimptypet);
-}
-
-list *Rgimptyped(t)
- struct Simptype *t;
-{
- if(t -> tag != imptype)
- fprintf(stderr,"gimptyped: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimptyped);
-}
-
-long *Rgitline(t)
- struct Simptype *t;
-{
- if(t -> tag != imptype)
- fprintf(stderr,"gitline: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgitline);
-}
-
-/************** impsyn ******************/
-
-impidt mkimpsyn(PPgimpsynti, PPgimpsynts, PPgisline)
- ttype PPgimpsynti;
- ttype PPgimpsynts;
- long PPgisline;
-{
- register struct Simpsyn *pp =
- (struct Simpsyn *) malloc(sizeof(struct Simpsyn));
- pp -> tag = impsyn;
- pp -> Xgimpsynti = PPgimpsynti;
- pp -> Xgimpsynts = PPgimpsynts;
- pp -> Xgisline = PPgisline;
- return((impidt)pp);
-}
-
-ttype *Rgimpsynti(t)
- struct Simpsyn *t;
-{
- if(t -> tag != impsyn)
- fprintf(stderr,"gimpsynti: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpsynti);
-}
-
-ttype *Rgimpsynts(t)
- struct Simpsyn *t;
-{
- if(t -> tag != impsyn)
- fprintf(stderr,"gimpsynts: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpsynts);
-}
-
-long *Rgisline(t)
- struct Simpsyn *t;
-{
- if(t -> tag != impsyn)
- fprintf(stderr,"gisline: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgisline);
-}
-
-/************** impeqtype ******************/
-
-impidt mkimpeqtype(PPgimpeqtype)
- binding PPgimpeqtype;
-{
- register struct Simpeqtype *pp =
- (struct Simpeqtype *) malloc(sizeof(struct Simpeqtype));
- pp -> tag = impeqtype;
- pp -> Xgimpeqtype = PPgimpeqtype;
- return((impidt)pp);
-}
-
-binding *Rgimpeqtype(t)
- struct Simpeqtype *t;
-{
- if(t -> tag != impeqtype)
- fprintf(stderr,"gimpeqtype: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpeqtype);
-}
-
-/************** impclass ******************/
-
-impidt mkimpclass(PPgimpclassc, PPgimpclasst, PPgimpclassw, PPgicline)
- list PPgimpclassc;
- ttype PPgimpclasst;
- list PPgimpclassw;
- long PPgicline;
-{
- register struct Simpclass *pp =
- (struct Simpclass *) malloc(sizeof(struct Simpclass));
- pp -> tag = impclass;
- pp -> Xgimpclassc = PPgimpclassc;
- pp -> Xgimpclasst = PPgimpclasst;
- pp -> Xgimpclassw = PPgimpclassw;
- pp -> Xgicline = PPgicline;
- return((impidt)pp);
-}
-
-list *Rgimpclassc(t)
- struct Simpclass *t;
-{
- if(t -> tag != impclass)
- fprintf(stderr,"gimpclassc: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpclassc);
-}
-
-ttype *Rgimpclasst(t)
- struct Simpclass *t;
-{
- if(t -> tag != impclass)
- fprintf(stderr,"gimpclasst: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpclasst);
-}
-
-list *Rgimpclassw(t)
- struct Simpclass *t;
-{
- if(t -> tag != impclass)
- fprintf(stderr,"gimpclassw: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpclassw);
-}
-
-long *Rgicline(t)
- struct Simpclass *t;
-{
- if(t -> tag != impclass)
- fprintf(stderr,"gicline: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgicline);
-}
-
-/************** impinst ******************/
-
-impidt mkimpinst(PPgimpinstc, PPgimpinstid, PPgimpinstt, PPgiiline)
- list PPgimpinstc;
- id PPgimpinstid;
- ttype PPgimpinstt;
- long PPgiiline;
-{
- register struct Simpinst *pp =
- (struct Simpinst *) malloc(sizeof(struct Simpinst));
- pp -> tag = impinst;
- pp -> Xgimpinstc = PPgimpinstc;
- pp -> Xgimpinstid = PPgimpinstid;
- pp -> Xgimpinstt = PPgimpinstt;
- pp -> Xgiiline = PPgiiline;
- return((impidt)pp);
-}
-
-list *Rgimpinstc(t)
- struct Simpinst *t;
-{
- if(t -> tag != impinst)
- fprintf(stderr,"gimpinstc: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpinstc);
-}
-
-id *Rgimpinstid(t)
- struct Simpinst *t;
-{
- if(t -> tag != impinst)
- fprintf(stderr,"gimpinstid: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpinstid);
-}
-
-ttype *Rgimpinstt(t)
- struct Simpinst *t;
-{
- if(t -> tag != impinst)
- fprintf(stderr,"gimpinstt: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpinstt);
-}
-
-long *Rgiiline(t)
- struct Simpinst *t;
-{
- if(t -> tag != impinst)
- fprintf(stderr,"giiline: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgiiline);
-}
-
-/************** impmod ******************/
-
-impidt mkimpmod(PPgimpmodn, PPgimpmodimp, PPgimpmodren, PPgimline)
- id PPgimpmodn;
- list PPgimpmodimp;
- list PPgimpmodren;
- long PPgimline;
-{
- register struct Simpmod *pp =
- (struct Simpmod *) malloc(sizeof(struct Simpmod));
- pp -> tag = impmod;
- pp -> Xgimpmodn = PPgimpmodn;
- pp -> Xgimpmodimp = PPgimpmodimp;
- pp -> Xgimpmodren = PPgimpmodren;
- pp -> Xgimline = PPgimline;
- return((impidt)pp);
-}
-
-id *Rgimpmodn(t)
- struct Simpmod *t;
-{
- if(t -> tag != impmod)
- fprintf(stderr,"gimpmodn: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpmodn);
-}
-
-list *Rgimpmodimp(t)
- struct Simpmod *t;
-{
- if(t -> tag != impmod)
- fprintf(stderr,"gimpmodimp: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpmodimp);
-}
-
-list *Rgimpmodren(t)
- struct Simpmod *t;
-{
- if(t -> tag != impmod)
- fprintf(stderr,"gimpmodren: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimpmodren);
-}
-
-long *Rgimline(t)
- struct Simpmod *t;
-{
- if(t -> tag != impmod)
- fprintf(stderr,"gimline: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgimline);
-}
+++ /dev/null
-#ifndef impidt_defined
-#define impidt_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- impid,
- imptype,
- impsyn,
- impeqtype,
- impclass,
- impinst,
- impmod
-} Timpidt;
-
-typedef struct { Timpidt tag; } *impidt;
-
-/* Compatibility defines */
-extern Timpidt timpidt PROTO((impidt));
-
-struct Simpid {
- Timpidt tag;
- id Xgimpid;
- ttype Xgimptype;
- finfot Xgimpfinfo;
- long Xgivline;
-};
-
-struct Simptype {
- Timpidt tag;
- list Xgimptypec;
- ttype Xgimptypet;
- list Xgimptyped;
- long Xgitline;
-};
-
-struct Simpsyn {
- Timpidt tag;
- ttype Xgimpsynti;
- ttype Xgimpsynts;
- long Xgisline;
-};
-
-struct Simpeqtype {
- Timpidt tag;
- binding Xgimpeqtype;
-};
-
-struct Simpclass {
- Timpidt tag;
- list Xgimpclassc;
- ttype Xgimpclasst;
- list Xgimpclassw;
- long Xgicline;
-};
-
-struct Simpinst {
- Timpidt tag;
- list Xgimpinstc;
- id Xgimpinstid;
- ttype Xgimpinstt;
- long Xgiiline;
-};
-
-struct Simpmod {
- Timpidt tag;
- id Xgimpmodn;
- list Xgimpmodimp;
- list Xgimpmodren;
- long Xgimline;
-};
-
-#endif
-extern impidt mkimpid PROTO((id, ttype, finfot, long));
-extern id *Rgimpid PROTO((struct Simpid *));
-#define gimpid(xyzxyz) (*Rgimpid((struct Simpid *) (xyzxyz)))
-extern ttype *Rgimptype PROTO((struct Simpid *));
-#define gimptype(xyzxyz) (*Rgimptype((struct Simpid *) (xyzxyz)))
-extern finfot *Rgimpfinfo PROTO((struct Simpid *));
-#define gimpfinfo(xyzxyz) (*Rgimpfinfo((struct Simpid *) (xyzxyz)))
-extern long *Rgivline PROTO((struct Simpid *));
-#define givline(xyzxyz) (*Rgivline((struct Simpid *) (xyzxyz)))
-
-extern impidt mkimptype PROTO((list, ttype, list, long));
-extern list *Rgimptypec PROTO((struct Simptype *));
-#define gimptypec(xyzxyz) (*Rgimptypec((struct Simptype *) (xyzxyz)))
-extern ttype *Rgimptypet PROTO((struct Simptype *));
-#define gimptypet(xyzxyz) (*Rgimptypet((struct Simptype *) (xyzxyz)))
-extern list *Rgimptyped PROTO((struct Simptype *));
-#define gimptyped(xyzxyz) (*Rgimptyped((struct Simptype *) (xyzxyz)))
-extern long *Rgitline PROTO((struct Simptype *));
-#define gitline(xyzxyz) (*Rgitline((struct Simptype *) (xyzxyz)))
-
-extern impidt mkimpsyn PROTO((ttype, ttype, long));
-extern ttype *Rgimpsynti PROTO((struct Simpsyn *));
-#define gimpsynti(xyzxyz) (*Rgimpsynti((struct Simpsyn *) (xyzxyz)))
-extern ttype *Rgimpsynts PROTO((struct Simpsyn *));
-#define gimpsynts(xyzxyz) (*Rgimpsynts((struct Simpsyn *) (xyzxyz)))
-extern long *Rgisline PROTO((struct Simpsyn *));
-#define gisline(xyzxyz) (*Rgisline((struct Simpsyn *) (xyzxyz)))
-
-extern impidt mkimpeqtype PROTO((binding));
-extern binding *Rgimpeqtype PROTO((struct Simpeqtype *));
-#define gimpeqtype(xyzxyz) (*Rgimpeqtype((struct Simpeqtype *) (xyzxyz)))
-
-extern impidt mkimpclass PROTO((list, ttype, list, long));
-extern list *Rgimpclassc PROTO((struct Simpclass *));
-#define gimpclassc(xyzxyz) (*Rgimpclassc((struct Simpclass *) (xyzxyz)))
-extern ttype *Rgimpclasst PROTO((struct Simpclass *));
-#define gimpclasst(xyzxyz) (*Rgimpclasst((struct Simpclass *) (xyzxyz)))
-extern list *Rgimpclassw PROTO((struct Simpclass *));
-#define gimpclassw(xyzxyz) (*Rgimpclassw((struct Simpclass *) (xyzxyz)))
-extern long *Rgicline PROTO((struct Simpclass *));
-#define gicline(xyzxyz) (*Rgicline((struct Simpclass *) (xyzxyz)))
-
-extern impidt mkimpinst PROTO((list, id, ttype, long));
-extern list *Rgimpinstc PROTO((struct Simpinst *));
-#define gimpinstc(xyzxyz) (*Rgimpinstc((struct Simpinst *) (xyzxyz)))
-extern id *Rgimpinstid PROTO((struct Simpinst *));
-#define gimpinstid(xyzxyz) (*Rgimpinstid((struct Simpinst *) (xyzxyz)))
-extern ttype *Rgimpinstt PROTO((struct Simpinst *));
-#define gimpinstt(xyzxyz) (*Rgimpinstt((struct Simpinst *) (xyzxyz)))
-extern long *Rgiiline PROTO((struct Simpinst *));
-#define giiline(xyzxyz) (*Rgiiline((struct Simpinst *) (xyzxyz)))
-
-extern impidt mkimpmod PROTO((id, list, list, long));
-extern id *Rgimpmodn PROTO((struct Simpmod *));
-#define gimpmodn(xyzxyz) (*Rgimpmodn((struct Simpmod *) (xyzxyz)))
-extern list *Rgimpmodimp PROTO((struct Simpmod *));
-#define gimpmodimp(xyzxyz) (*Rgimpmodimp((struct Simpmod *) (xyzxyz)))
-extern list *Rgimpmodren PROTO((struct Simpmod *));
-#define gimpmodren(xyzxyz) (*Rgimpmodren((struct Simpmod *) (xyzxyz)))
-extern long *Rgimline PROTO((struct Simpmod *));
-#define gimline(xyzxyz) (*Rgimline((struct Simpmod *) (xyzxyz)))
-
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Import Directory List Handling *
-* *
-* *
-**********************************************************************/
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#else
-#ifdef HAVE_TYPES_H
-#include <types.h>
-#endif
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_SYS_FILE_H
-#include <sys/file.h>
-#endif
-
-#ifndef HAVE_ACCESS
-#define R_OK "r"
-#define F_OK "r"
-short
-access(const char *fileName, const char *mode)
-{
- FILE *fp = fopen(fileName, mode);
- if (fp != NULL) {
- (void) fclose(fp);
- return 0;
- }
- return 1;
-}
-#endif /* HAVE_ACCESS */
-
-
-list imports_dirlist, sys_imports_dirlist; /* The imports lists */
-extern char HiSuffix[];
-extern char PreludeHiSuffix[];
-/* OLD 95/08: extern BOOLEAN ExplicitHiSuffixGiven; */
-
-#define MAX_MATCH 16
-
-/*
- This finds a module along the imports directory list.
-*/
-
-void
-find_module_on_imports_dirlist(char *module_name, BOOLEAN is_sys_import, char *returned_filename)
-{
- char try[FILENAME_SIZE];
-
- list imports_dirs;
-
-#ifdef HAVE_STAT
- struct stat sbuf[MAX_MATCH];
-#endif
-
- int no_of_matches = 0;
- BOOLEAN tried_source_dir = FALSE;
-
- char *try_end;
- char *suffix_to_use = (is_sys_import) ? PreludeHiSuffix : HiSuffix;
- char *suffix_to_report = suffix_to_use; /* save this for reporting, because we
- might change suffix_to_use later */
- int modname_len = strlen(module_name);
-
- /*
- Check every directory in (sys_)imports_dirlist for the imports file.
- The first directory in the list is the source directory.
- */
- for (imports_dirs = (is_sys_import) ? sys_imports_dirlist : imports_dirlist;
- tlist(imports_dirs) == lcons;
- imports_dirs = ltl(imports_dirs))
- {
- char *dir = (char *) lhd(imports_dirs);
- strcpy(try, dir);
-
- try_end = try + strlen(try);
-
-#ifdef macintosh /* ToDo: use DIR_SEP_CHAR */
- if (*(try_end - 1) != ':')
- strcpy (try_end++, ":");
-#else
- if (*(try_end - 1) != '/')
- strcpy (try_end++, "/");
-#endif /* ! macintosh */
-
- strcpy(try_end, module_name);
-
- strcpy(try_end+modname_len, suffix_to_use);
-
- /* See whether the file exists and is readable. */
- if (access (try,R_OK) == 0)
- {
- if ( no_of_matches == 0 )
- strcpy(returned_filename, try);
-
- /* Return as soon as a match is found in the source directory. */
- if (!tried_source_dir)
- return;
-
-#ifdef HAVE_STAT
- if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 )
- {
- int i;
- for (i = 0; i < no_of_matches; i++)
- {
- if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev &&
- sbuf[no_of_matches].st_ino == sbuf[i].st_ino)
- goto next; /* Skip dups */
- }
- }
-#endif /* HAVE_STAT */
- no_of_matches++;
- }
- else if (access (try,F_OK) == 0)
- fprintf(stderr,"Warning: %s exists, but is not readable\n",try);
-
- next:
- tried_source_dir = TRUE;
- }
-
- if ( no_of_matches == 0 && ! is_sys_import ) { /* Nothing so far */
-
- /* If we are explicitly meddling about with .hi suffixes,
- then some system-supplied modules may need to be looked
- for with PreludeHiSuffix; unsavoury but true...
- */
- suffix_to_use = PreludeHiSuffix;
-
- for (imports_dirs = sys_imports_dirlist;
- tlist(imports_dirs) == lcons;
- imports_dirs = ltl(imports_dirs))
- {
- char *dir = (char *) lhd(imports_dirs);
- strcpy(try, dir);
-
- try_end = try + strlen(try);
-
-#ifdef macintosh /* ToDo: use DIR_SEP_STRING */
- if (*(try_end - 1) != ':')
- strcpy (try_end++, ":");
-#else
- if (*(try_end - 1) != '/')
- strcpy (try_end++, "/");
-#endif /* ! macintosh */
-
- strcpy(try_end, module_name);
-
- strcpy(try_end+modname_len, suffix_to_use);
-
- /* See whether the file exists and is readable. */
- if (access (try,R_OK) == 0)
- {
- if ( no_of_matches == 0 )
- strcpy(returned_filename, try);
-
-#ifdef HAVE_STAT
- if ( no_of_matches < MAX_MATCH && stat(try, sbuf + no_of_matches) == 0 )
- {
- int i;
- for (i = 0; i < no_of_matches; i++)
- {
- if ( sbuf[no_of_matches].st_dev == sbuf[i].st_dev &&
- sbuf[no_of_matches].st_ino == sbuf[i].st_ino)
- goto next_again; /* Skip dups */
- }
- }
-#endif /* HAVE_STAT */
- no_of_matches++;
- }
- else if (access (try,F_OK) == 0)
- fprintf(stderr,"Warning: %s exists, but is not readable\n",try);
- next_again:
- /*NOTHING*/;
- }
- }
-
- /* Error checking */
-
- switch ( no_of_matches ) {
- default:
- fprintf(stderr,"Warning: found %d %s files for module \"%s\"\n",
- no_of_matches, suffix_to_report, module_name);
- break;
- case 0:
- {
- char disaster_msg[MODNAME_SIZE+1000];
- sprintf(disaster_msg,"can't find interface (%s) file for module \"%s\"%s",
- suffix_to_report, module_name,
- (strncmp(module_name, "PreludeGlaIO", 12) == 0)
- ? "\n(The PreludeGlaIO interface no longer exists);"
- :(
- (strncmp(module_name, "PreludePrimIO", 13) == 0)
- ? "\n(The PreludePrimIO interface no longer exists -- just use PreludeGlaST);"
- :(
- (strncmp(module_name, "Prelude", 7) == 0)
- ? "\n(Perhaps you forgot a `-fglasgow-exts' flag?);"
- : ""
- )));
- hsperror(disaster_msg);
- break;
- }
- case 1:
- /* Everything is fine */
- break;
- }
-}
+++ /dev/null
-/*
- * Infix operator stuff -- modified from LML
- */
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#ifdef DPH
-#include "hsparser-DPH.tab.h"
-#else
-#include "hsparser.tab.h"
-#endif
-#include "constants.h"
-#include "utils.h"
-
-static short iscope = 1;
-
-static struct infix {
- char *iname;
- short ilen;
- short ifixity;
- short iprecedence;
-} infixtab[INFIX_SCOPES][MAX_INFIX] =
- {
- /*
- Name Len Fixity Precedence
- */
- "$", 1, INFIXR, 0,
- ":=", 2, INFIX, 1,
- "||", 2, INFIXR, 2,
- "&&", 2, INFIXR, 3,
- "==", 2, INFIX, 4,
- "/=", 2, INFIX, 4,
- "<", 1, INFIX, 4,
- "<=", 2, INFIX, 4,
- ">", 1, INFIX, 4,
- ">=", 2, INFIX, 4,
- "elem", 4, INFIX, 4,
- "notElem", 7, INFIX, 4,
- "\\\\", 2, INFIX, 5,
- ":", 1, INFIXR, 5,
- "++", 2, INFIXR, 5,
- "+", 1, INFIXL, 6,
- "-", 1, INFIXL, 6,
- ":+", 2, INFIX, 6,
- "*", 1, INFIXL, 7,
- "/", 1, INFIXL, 7,
- "mod", 3, INFIXL, 7,
- "div", 3, INFIXL, 7,
- "rem", 3, INFIXL, 7,
- "quot", 4, INFIXL, 7,
- ":%", 2, INFIXL, 7, /* possibly wrong; should be omitted? */
- "%", 1, INFIXL, 7,
- "**", 2, INFIXR, 8,
- "^", 1, INFIXR, 8,
- "^^", 2, INFIXR, 8,
- "!", 1, INFIXL, 9,
- "!!", 2, INFIXL, 9,
- "//", 2, INFIXL, 9,
- ".", 1, INFIXR, 9
-};
-
-
-#define NFIX 31 /* The number of predefined operators */
-#define ninfix (ninfixtab[iscope])
-static int ninfixtab[INFIX_SCOPES] = {NFIX,0}; /* # of predefined operators */
-static char infixstr[MAX_ISTR];
-static char *infixp = infixstr;
-
-/* An "iscope" is an "infix scope": the scope of infix declarations
- (either the main module or an interface) */
-
-void
-enteriscope()
-{
- if(++iscope > INFIX_SCOPES)
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Too many infix scopes (> %d)\n",INFIX_SCOPES);
- }
- ninfix = 0;
-}
-
-#if 0
-/* UNUSED */
-void
-exitiscope()
-{
- --iscope;
-}
-#endif
-
-void
-exposeis()
-{
- int i;
- --iscope;
-
- for (i=0; i < ninfixtab[iscope+1]; ++i)
- {
- struct infix *ip = infixtab[iscope+1] + i;
- makeinfix(install_literal(ip->iname),ip->ifixity,ip->iprecedence);
- }
-}
-
-
-static int
-ionelookup(id name, int iscope)
-{
- int i;
- char *iname = id_to_string(name);
-
- for(i = 0; i < ninfixtab[iscope]; i++)
- {
- if(strcmp(iname,infixtab[iscope][i].iname)==0)
- return(i);
- }
-
- return(-1);
-}
-
-
-struct infix *
-infixlookup(name)
- id name;
-{
- int i;
- for (i=iscope; i >= 0; --i)
- {
- int n = ionelookup(name,i);
- if (n >= 0)
- return (infixtab[i]+n);
- }
- return (NULL);
-}
-
-int
-nfixes()
-{
- return ninfix;
-}
-
-char *
-fixop(int n)
-{
- return infixtab[iscope][n].iname;
-}
-
-char *
-fixtype(int n)
-{
- switch(infixtab[iscope][n].ifixity) {
- case INFIXL:
- return "infixl";
-
- case INFIXR:
- return "infixr";
-
- case INFIX:
- return "infix";
-
- default : return 0;
- /* Why might it return 0 ?? (WDP 94/11) */
- }
-}
-
-#if 0
-/* UNUSED? */
-int
-fixity(n)
- int n;
-{
-#ifdef HSP_DEBUG
- fprintf(stderr,"fixity of %s (at %d) is %d\n",infixtab[iscope][n].iname,n,infixtab[iscope][n].ifixity);
-#endif
- return(n < 0? INFIXL: infixtab[iscope][n].ifixity);
-}
-#endif /* 0 */
-
-
-long int
-precedence(n)
- int n;
-{
-#ifdef HSP_DEBUG
- fprintf(stderr,"precedence of %s (at %d) is %d\n",infixtab[iscope][n].iname,n,infixtab[iscope][n].iprecedence);
-#endif
- return(n < 0? 9: infixtab[iscope][n].iprecedence);
-}
-
-
-int
-pfixity(ip)
- struct infix *ip;
-{
-#ifdef HSP_DEBUG
- fprintf(stderr,"fixity of %s is %d\n",ip->iname,ip->ifixity);
-#endif
- return(ip == NULL? INFIXL: ip->ifixity);
-}
-
-int
-pprecedence(ip)
- struct infix *ip;
-{
-#ifdef HSP_DEBUG
- fprintf(stderr,"precedence of %s (at %d) is %d\n",ip->iname,ip->iprecedence);
-#endif
- return(ip == NULL? 9: ip->iprecedence);
-}
-
-
-void
-makeinfix(ssi, fixity, precedence)
- id ssi;
- int fixity, precedence;
-{
- register int i, l;
- char s[1000];
- char *ss = id_to_string(ssi);
-
- for(i=0; i < ninfix; ++i)
- {
- if(strcmp(ss,infixtab[iscope][i].iname)==0)
- {
- /* Allow duplicate definitions if they are identical */
- if(infixtab[iscope][i].ifixity!=fixity ||
- infixtab[iscope][i].iprecedence!=precedence )
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"(%s) already declared to be %s %d\n",
- ss,
- fixtype(i),
- infixtab[iscope][i].iprecedence);
- hsperror(errbuf);
- }
- return;
- }
- }
-
- strcpy(s, ss);
- l = strlen(s);
- s[l] = 0;
-
- if (ninfix >= MAX_INFIX || infixp+l+1 >= &infixstr[MAX_ISTR]) {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Too many Infix identifiers (> %d)",MAX_INFIX);
- hsperror(errbuf);
- }
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"adding %s (was %s), fixity=%d, prec=%d\n",s,ss,fixity,precedence);
-#endif
- infixtab[iscope][ninfix].iname = infixp;
- strcpy(infixp, s);
- infixp += l+1;
- infixtab[iscope][ninfix].ifixity = fixity;
- infixtab[iscope][ninfix].iprecedence = precedence;
- infixtab[iscope][ninfix].ilen = l-1;
- ninfix++;
-}
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/list.h"
-
-Tlist tlist(t)
- list t;
-{
- return(t -> tag);
-}
-
-
-/************** lcons ******************/
-
-list mklcons(PPlhd, PPltl)
- VOID_STAR PPlhd;
- list PPltl;
-{
- register struct Slcons *pp =
- (struct Slcons *) malloc(sizeof(struct Slcons));
- pp -> tag = lcons;
- pp -> Xlhd = PPlhd;
- pp -> Xltl = PPltl;
- return((list)pp);
-}
-
-VOID_STAR *Rlhd(t)
- struct Slcons *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lcons)
- fprintf(stderr,"lhd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xlhd);
-}
-
-list *Rltl(t)
- struct Slcons *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lcons)
- fprintf(stderr,"ltl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xltl);
-}
-
-/************** lnil ******************/
-
-list mklnil(void)
-{
- register struct Slnil *pp =
- (struct Slnil *) malloc(sizeof(struct Slnil));
- pp -> tag = lnil;
- return((list)pp);
-}
+++ /dev/null
-#ifndef list_defined
-#define list_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- lcons,
- lnil
-} Tlist;
-
-typedef struct { Tlist tag; } *list;
-
-#ifdef __GNUC__
-Tlist tlist(list t);
-extern __inline__ Tlist tlist(list t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tlist tlist PROTO((list));
-#endif /* ! __GNUC__ */
-
-struct Slcons {
- Tlist tag;
- VOID_STAR Xlhd;
- list Xltl;
-};
-
-struct Slnil {
- Tlist tag;
-};
-
-extern list mklcons PROTO((VOID_STAR, list));
-#ifdef __GNUC__
-
-VOID_STAR *Rlhd PROTO((struct Slcons *));
-
-extern __inline__ VOID_STAR *Rlhd(struct Slcons *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lcons)
- fprintf(stderr,"lhd: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xlhd);
-}
-#else /* ! __GNUC__ */
-extern VOID_STAR *Rlhd PROTO((struct Slcons *));
-#endif /* ! __GNUC__ */
-
-#define lhd(xyzxyz) (*Rlhd((struct Slcons *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rltl PROTO((struct Slcons *));
-
-extern __inline__ list *Rltl(struct Slcons *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lcons)
- fprintf(stderr,"ltl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xltl);
-}
-#else /* ! __GNUC__ */
-extern list *Rltl PROTO((struct Slcons *));
-#endif /* ! __GNUC__ */
-
-#define ltl(xyzxyz) (*Rltl((struct Slcons *) (xyzxyz)))
-
-extern list mklnil PROTO((void));
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_list where
-import UgenUtil
-import Util
-%}}
-type list;
- lcons : < lhd : VOID_STAR;
- ltl : list; >;
- lnil : <>;
-end;
+++ /dev/null
-/*
- Implementation of optimally compiled list comprehensions using Wadler's algorithm from
- Peyton-Jones "Implementation of Functional Programming Languages", 1987
-
- TQ transforms a list of qualifiers (either boolean expressions or generators) into a
- single expression which implements the list comprehension.
-
- TE << [E || Q] >> = TQ << [E || Q] ++ [] >>
-
- TQ << [E || p <- L1, Q] ++ L2 >> =
-
- h ( TE << L1 >> ) where
- h = us -> case us in
- [] -> TE << L2 >>
- (u : us') ->
- (TE << p >> -> ( TQ << [E || Q] ++ (h us') >> )) u
- */
-
-tree TQ(quals,l2)
-list quals, l2;
-{
- tree qualh;
- list rest;
-
- if(tlist(quals) == lnil)
- return(mkcons(zfexpr,l2));
-
- qualh = (tree) lhd(quals);
- rest = ltl(quals);
-
- if(ttree(qualh) != qual)
- return(mkif(qualh,TQ(rest,l2),l2));
-
- {
- tree h = mkident(uniqueident("Zh%d")),
- u = mkident(uniqueident("Iu%d")),
- us = mkident(uniqueident("Ius%d")),
- pat = gqpat(qualh);
-
- pbinding tq = mkppat(gqpat(qualh),TQ(rest,mkap(h,us)));
-
-
- return(
- mkletv(
- mkrbind(
- mkpbind(
- lsing(
- mkppat(h,
- mklam(us,
- mkcasee(us,
- ldub(
- mkppat(niltree,l2),
- mkppat(
- mkcons(u,us),
- mkcasee(u,lsing(tq))
-/*
- replaces the following code which elides patterns in list comprehensions a la M*****a
-
- mkcasee(u,
- ttree(pat) == ident && !isconstr(gident(pat))?
- lsing(tq):
- ldub(tq,mkppat(mkident("_"),mkap(h,us))))
-*/
- )))))))),
- mkap(h,gqexp(qualh))));
- }
-}
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/literal.h"
-
-Tliteral tliteral(t)
- literal t;
-{
- return(t -> tag);
-}
-
-
-/************** integer ******************/
-
-literal mkinteger(PPginteger)
- stringId PPginteger;
-{
- register struct Sinteger *pp =
- (struct Sinteger *) malloc(sizeof(struct Sinteger));
- pp -> tag = integer;
- pp -> Xginteger = PPginteger;
- return((literal)pp);
-}
-
-stringId *Rginteger(t)
- struct Sinteger *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != integer)
- fprintf(stderr,"ginteger: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xginteger);
-}
-
-/************** intprim ******************/
-
-literal mkintprim(PPgintprim)
- stringId PPgintprim;
-{
- register struct Sintprim *pp =
- (struct Sintprim *) malloc(sizeof(struct Sintprim));
- pp -> tag = intprim;
- pp -> Xgintprim = PPgintprim;
- return((literal)pp);
-}
-
-stringId *Rgintprim(t)
- struct Sintprim *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != intprim)
- fprintf(stderr,"gintprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgintprim);
-}
-
-/************** floatr ******************/
-
-literal mkfloatr(PPgfloatr)
- stringId PPgfloatr;
-{
- register struct Sfloatr *pp =
- (struct Sfloatr *) malloc(sizeof(struct Sfloatr));
- pp -> tag = floatr;
- pp -> Xgfloatr = PPgfloatr;
- return((literal)pp);
-}
-
-stringId *Rgfloatr(t)
- struct Sfloatr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != floatr)
- fprintf(stderr,"gfloatr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfloatr);
-}
-
-/************** doubleprim ******************/
-
-literal mkdoubleprim(PPgdoubleprim)
- stringId PPgdoubleprim;
-{
- register struct Sdoubleprim *pp =
- (struct Sdoubleprim *) malloc(sizeof(struct Sdoubleprim));
- pp -> tag = doubleprim;
- pp -> Xgdoubleprim = PPgdoubleprim;
- return((literal)pp);
-}
-
-stringId *Rgdoubleprim(t)
- struct Sdoubleprim *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != doubleprim)
- fprintf(stderr,"gdoubleprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdoubleprim);
-}
-
-/************** floatprim ******************/
-
-literal mkfloatprim(PPgfloatprim)
- stringId PPgfloatprim;
-{
- register struct Sfloatprim *pp =
- (struct Sfloatprim *) malloc(sizeof(struct Sfloatprim));
- pp -> tag = floatprim;
- pp -> Xgfloatprim = PPgfloatprim;
- return((literal)pp);
-}
-
-stringId *Rgfloatprim(t)
- struct Sfloatprim *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != floatprim)
- fprintf(stderr,"gfloatprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfloatprim);
-}
-
-/************** charr ******************/
-
-literal mkcharr(PPgchar)
- hstring PPgchar;
-{
- register struct Scharr *pp =
- (struct Scharr *) malloc(sizeof(struct Scharr));
- pp -> tag = charr;
- pp -> Xgchar = PPgchar;
- return((literal)pp);
-}
-
-hstring *Rgchar(t)
- struct Scharr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != charr)
- fprintf(stderr,"gchar: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgchar);
-}
-
-/************** charprim ******************/
-
-literal mkcharprim(PPgcharprim)
- hstring PPgcharprim;
-{
- register struct Scharprim *pp =
- (struct Scharprim *) malloc(sizeof(struct Scharprim));
- pp -> tag = charprim;
- pp -> Xgcharprim = PPgcharprim;
- return((literal)pp);
-}
-
-hstring *Rgcharprim(t)
- struct Scharprim *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != charprim)
- fprintf(stderr,"gcharprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcharprim);
-}
-
-/************** string ******************/
-
-literal mkstring(PPgstring)
- hstring PPgstring;
-{
- register struct Sstring *pp =
- (struct Sstring *) malloc(sizeof(struct Sstring));
- pp -> tag = string;
- pp -> Xgstring = PPgstring;
- return((literal)pp);
-}
-
-hstring *Rgstring(t)
- struct Sstring *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != string)
- fprintf(stderr,"gstring: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgstring);
-}
-
-/************** stringprim ******************/
-
-literal mkstringprim(PPgstringprim)
- hstring PPgstringprim;
-{
- register struct Sstringprim *pp =
- (struct Sstringprim *) malloc(sizeof(struct Sstringprim));
- pp -> tag = stringprim;
- pp -> Xgstringprim = PPgstringprim;
- return((literal)pp);
-}
-
-hstring *Rgstringprim(t)
- struct Sstringprim *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != stringprim)
- fprintf(stderr,"gstringprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgstringprim);
-}
-
-/************** clitlit ******************/
-
-literal mkclitlit(PPgclitlit, PPgclitlit_kind)
- stringId PPgclitlit;
- stringId PPgclitlit_kind;
-{
- register struct Sclitlit *pp =
- (struct Sclitlit *) malloc(sizeof(struct Sclitlit));
- pp -> tag = clitlit;
- pp -> Xgclitlit = PPgclitlit;
- pp -> Xgclitlit_kind = PPgclitlit_kind;
- return((literal)pp);
-}
-
-stringId *Rgclitlit(t)
- struct Sclitlit *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != clitlit)
- fprintf(stderr,"gclitlit: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgclitlit);
-}
-
-stringId *Rgclitlit_kind(t)
- struct Sclitlit *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != clitlit)
- fprintf(stderr,"gclitlit_kind: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgclitlit_kind);
-}
-
-/************** norepi ******************/
-
-literal mknorepi(PPgnorepi)
- stringId PPgnorepi;
-{
- register struct Snorepi *pp =
- (struct Snorepi *) malloc(sizeof(struct Snorepi));
- pp -> tag = norepi;
- pp -> Xgnorepi = PPgnorepi;
- return((literal)pp);
-}
-
-stringId *Rgnorepi(t)
- struct Snorepi *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != norepi)
- fprintf(stderr,"gnorepi: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnorepi);
-}
-
-/************** norepr ******************/
-
-literal mknorepr(PPgnorepr_n, PPgnorepr_d)
- stringId PPgnorepr_n;
- stringId PPgnorepr_d;
-{
- register struct Snorepr *pp =
- (struct Snorepr *) malloc(sizeof(struct Snorepr));
- pp -> tag = norepr;
- pp -> Xgnorepr_n = PPgnorepr_n;
- pp -> Xgnorepr_d = PPgnorepr_d;
- return((literal)pp);
-}
-
-stringId *Rgnorepr_n(t)
- struct Snorepr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != norepr)
- fprintf(stderr,"gnorepr_n: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnorepr_n);
-}
-
-stringId *Rgnorepr_d(t)
- struct Snorepr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != norepr)
- fprintf(stderr,"gnorepr_d: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnorepr_d);
-}
-
-/************** noreps ******************/
-
-literal mknoreps(PPgnoreps)
- hstring PPgnoreps;
-{
- register struct Snoreps *pp =
- (struct Snoreps *) malloc(sizeof(struct Snoreps));
- pp -> tag = noreps;
- pp -> Xgnoreps = PPgnoreps;
- return((literal)pp);
-}
-
-hstring *Rgnoreps(t)
- struct Snoreps *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != noreps)
- fprintf(stderr,"gnoreps: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnoreps);
-}
+++ /dev/null
-#ifndef literal_defined
-#define literal_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- integer,
- intprim,
- floatr,
- doubleprim,
- floatprim,
- charr,
- charprim,
- string,
- stringprim,
- clitlit,
- norepi,
- norepr,
- noreps
-} Tliteral;
-
-typedef struct { Tliteral tag; } *literal;
-
-#ifdef __GNUC__
-Tliteral tliteral(literal t);
-extern __inline__ Tliteral tliteral(literal t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tliteral tliteral PROTO((literal));
-#endif /* ! __GNUC__ */
-
-struct Sinteger {
- Tliteral tag;
- stringId Xginteger;
-};
-
-struct Sintprim {
- Tliteral tag;
- stringId Xgintprim;
-};
-
-struct Sfloatr {
- Tliteral tag;
- stringId Xgfloatr;
-};
-
-struct Sdoubleprim {
- Tliteral tag;
- stringId Xgdoubleprim;
-};
-
-struct Sfloatprim {
- Tliteral tag;
- stringId Xgfloatprim;
-};
-
-struct Scharr {
- Tliteral tag;
- hstring Xgchar;
-};
-
-struct Scharprim {
- Tliteral tag;
- hstring Xgcharprim;
-};
-
-struct Sstring {
- Tliteral tag;
- hstring Xgstring;
-};
-
-struct Sstringprim {
- Tliteral tag;
- hstring Xgstringprim;
-};
-
-struct Sclitlit {
- Tliteral tag;
- stringId Xgclitlit;
- stringId Xgclitlit_kind;
-};
-
-struct Snorepi {
- Tliteral tag;
- stringId Xgnorepi;
-};
-
-struct Snorepr {
- Tliteral tag;
- stringId Xgnorepr_n;
- stringId Xgnorepr_d;
-};
-
-struct Snoreps {
- Tliteral tag;
- hstring Xgnoreps;
-};
-
-extern literal mkinteger PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rginteger PROTO((struct Sinteger *));
-
-extern __inline__ stringId *Rginteger(struct Sinteger *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != integer)
- fprintf(stderr,"ginteger: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xginteger);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rginteger PROTO((struct Sinteger *));
-#endif /* ! __GNUC__ */
-
-#define ginteger(xyzxyz) (*Rginteger((struct Sinteger *) (xyzxyz)))
-
-extern literal mkintprim PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgintprim PROTO((struct Sintprim *));
-
-extern __inline__ stringId *Rgintprim(struct Sintprim *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != intprim)
- fprintf(stderr,"gintprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgintprim);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgintprim PROTO((struct Sintprim *));
-#endif /* ! __GNUC__ */
-
-#define gintprim(xyzxyz) (*Rgintprim((struct Sintprim *) (xyzxyz)))
-
-extern literal mkfloatr PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgfloatr PROTO((struct Sfloatr *));
-
-extern __inline__ stringId *Rgfloatr(struct Sfloatr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != floatr)
- fprintf(stderr,"gfloatr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfloatr);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgfloatr PROTO((struct Sfloatr *));
-#endif /* ! __GNUC__ */
-
-#define gfloatr(xyzxyz) (*Rgfloatr((struct Sfloatr *) (xyzxyz)))
-
-extern literal mkdoubleprim PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgdoubleprim PROTO((struct Sdoubleprim *));
-
-extern __inline__ stringId *Rgdoubleprim(struct Sdoubleprim *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != doubleprim)
- fprintf(stderr,"gdoubleprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdoubleprim);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgdoubleprim PROTO((struct Sdoubleprim *));
-#endif /* ! __GNUC__ */
-
-#define gdoubleprim(xyzxyz) (*Rgdoubleprim((struct Sdoubleprim *) (xyzxyz)))
-
-extern literal mkfloatprim PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgfloatprim PROTO((struct Sfloatprim *));
-
-extern __inline__ stringId *Rgfloatprim(struct Sfloatprim *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != floatprim)
- fprintf(stderr,"gfloatprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfloatprim);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgfloatprim PROTO((struct Sfloatprim *));
-#endif /* ! __GNUC__ */
-
-#define gfloatprim(xyzxyz) (*Rgfloatprim((struct Sfloatprim *) (xyzxyz)))
-
-extern literal mkcharr PROTO((hstring));
-#ifdef __GNUC__
-
-hstring *Rgchar PROTO((struct Scharr *));
-
-extern __inline__ hstring *Rgchar(struct Scharr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != charr)
- fprintf(stderr,"gchar: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgchar);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgchar PROTO((struct Scharr *));
-#endif /* ! __GNUC__ */
-
-#define gchar(xyzxyz) (*Rgchar((struct Scharr *) (xyzxyz)))
-
-extern literal mkcharprim PROTO((hstring));
-#ifdef __GNUC__
-
-hstring *Rgcharprim PROTO((struct Scharprim *));
-
-extern __inline__ hstring *Rgcharprim(struct Scharprim *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != charprim)
- fprintf(stderr,"gcharprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcharprim);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgcharprim PROTO((struct Scharprim *));
-#endif /* ! __GNUC__ */
-
-#define gcharprim(xyzxyz) (*Rgcharprim((struct Scharprim *) (xyzxyz)))
-
-extern literal mkstring PROTO((hstring));
-#ifdef __GNUC__
-
-hstring *Rgstring PROTO((struct Sstring *));
-
-extern __inline__ hstring *Rgstring(struct Sstring *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != string)
- fprintf(stderr,"gstring: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgstring);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgstring PROTO((struct Sstring *));
-#endif /* ! __GNUC__ */
-
-#define gstring(xyzxyz) (*Rgstring((struct Sstring *) (xyzxyz)))
-
-extern literal mkstringprim PROTO((hstring));
-#ifdef __GNUC__
-
-hstring *Rgstringprim PROTO((struct Sstringprim *));
-
-extern __inline__ hstring *Rgstringprim(struct Sstringprim *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != stringprim)
- fprintf(stderr,"gstringprim: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgstringprim);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgstringprim PROTO((struct Sstringprim *));
-#endif /* ! __GNUC__ */
-
-#define gstringprim(xyzxyz) (*Rgstringprim((struct Sstringprim *) (xyzxyz)))
-
-extern literal mkclitlit PROTO((stringId, stringId));
-#ifdef __GNUC__
-
-stringId *Rgclitlit PROTO((struct Sclitlit *));
-
-extern __inline__ stringId *Rgclitlit(struct Sclitlit *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != clitlit)
- fprintf(stderr,"gclitlit: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgclitlit);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgclitlit PROTO((struct Sclitlit *));
-#endif /* ! __GNUC__ */
-
-#define gclitlit(xyzxyz) (*Rgclitlit((struct Sclitlit *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rgclitlit_kind PROTO((struct Sclitlit *));
-
-extern __inline__ stringId *Rgclitlit_kind(struct Sclitlit *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != clitlit)
- fprintf(stderr,"gclitlit_kind: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgclitlit_kind);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgclitlit_kind PROTO((struct Sclitlit *));
-#endif /* ! __GNUC__ */
-
-#define gclitlit_kind(xyzxyz) (*Rgclitlit_kind((struct Sclitlit *) (xyzxyz)))
-
-extern literal mknorepi PROTO((stringId));
-#ifdef __GNUC__
-
-stringId *Rgnorepi PROTO((struct Snorepi *));
-
-extern __inline__ stringId *Rgnorepi(struct Snorepi *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != norepi)
- fprintf(stderr,"gnorepi: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnorepi);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgnorepi PROTO((struct Snorepi *));
-#endif /* ! __GNUC__ */
-
-#define gnorepi(xyzxyz) (*Rgnorepi((struct Snorepi *) (xyzxyz)))
-
-extern literal mknorepr PROTO((stringId, stringId));
-#ifdef __GNUC__
-
-stringId *Rgnorepr_n PROTO((struct Snorepr *));
-
-extern __inline__ stringId *Rgnorepr_n(struct Snorepr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != norepr)
- fprintf(stderr,"gnorepr_n: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnorepr_n);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgnorepr_n PROTO((struct Snorepr *));
-#endif /* ! __GNUC__ */
-
-#define gnorepr_n(xyzxyz) (*Rgnorepr_n((struct Snorepr *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rgnorepr_d PROTO((struct Snorepr *));
-
-extern __inline__ stringId *Rgnorepr_d(struct Snorepr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != norepr)
- fprintf(stderr,"gnorepr_d: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnorepr_d);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgnorepr_d PROTO((struct Snorepr *));
-#endif /* ! __GNUC__ */
-
-#define gnorepr_d(xyzxyz) (*Rgnorepr_d((struct Snorepr *) (xyzxyz)))
-
-extern literal mknoreps PROTO((hstring));
-#ifdef __GNUC__
-
-hstring *Rgnoreps PROTO((struct Snoreps *));
-
-extern __inline__ hstring *Rgnoreps(struct Snoreps *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != noreps)
- fprintf(stderr,"gnoreps: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnoreps);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgnoreps PROTO((struct Snoreps *));
-#endif /* ! __GNUC__ */
-
-#define gnoreps(xyzxyz) (*Rgnoreps((struct Snoreps *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_literal where
-import UgenUtil
-import Util
-%}}
-type literal;
- integer : < ginteger : stringId; >;
- intprim : < gintprim : stringId; >;
- floatr : < gfloatr : stringId; >;
- doubleprim : < gdoubleprim : stringId; >;
- floatprim : < gfloatprim : stringId; >;
- charr : < gchar : hstring; >;
- charprim : < gcharprim : hstring; >;
- string : < gstring : hstring; >;
- stringprim : < gstringprim : hstring; >;
- clitlit : < gclitlit : stringId;
- gclitlit_kind : stringId; >;
- norepi : < gnorepi : stringId; >;
- norepr : < gnorepr_n : stringId;
- gnorepr_d : stringId; >;
- noreps : < gnoreps : hstring; >;
-end;
+++ /dev/null
-/* This is the "top-level" file for the *standalone* hsp parser.
- See also hsclink.c. (WDP 94/10)
-*/
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/*OLD:static char *progname;*/ /* The name of the program. */
-
-
-/**********************************************************************
-* *
-* *
-* The main program *
-* *
-* *
-**********************************************************************/
-
-int
-main(int argc, char **argv)
-{
- Lnil = mklnil(); /* The null list -- used in lsing, etc. */
- all = mklnil(); /* This should be the list of all derivable types */
-
- process_args(argc,argv);
-
- hash_init();
-
-#ifdef HSP_DEBUG
- fprintf(stderr,"input_file_dir=%s\n",input_file_dir);
-#endif
-
- yyinit();
-
- if(yyparse() == 0 && !etags)
- {
- /* No syntax errors. */
- pprogram(root);
- printf("\n");
- exit(0);
- }
- else if(etags)
- {
- exit(0);
- }
- else
- {
- /* There was a syntax error. */
- printf("\n");
- exit(1);
- }
-}
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/pbinding.h"
-
-Tpbinding tpbinding(t)
- pbinding t;
-{
- return(t -> tag);
-}
-
-
-/************** pgrhs ******************/
-
-pbinding mkpgrhs(PPggpat, PPggdexprs, PPggbind, PPggfuncname, PPggline)
- tree PPggpat;
- list PPggdexprs;
- binding PPggbind;
- stringId PPggfuncname;
- long PPggline;
-{
- register struct Spgrhs *pp =
- (struct Spgrhs *) malloc(sizeof(struct Spgrhs));
- pp -> tag = pgrhs;
- pp -> Xggpat = PPggpat;
- pp -> Xggdexprs = PPggdexprs;
- pp -> Xggbind = PPggbind;
- pp -> Xggfuncname = PPggfuncname;
- pp -> Xggline = PPggline;
- return((pbinding)pp);
-}
-
-tree *Rggpat(t)
- struct Spgrhs *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggpat: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggpat);
-}
-
-list *Rggdexprs(t)
- struct Spgrhs *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggdexprs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggdexprs);
-}
-
-binding *Rggbind(t)
- struct Spgrhs *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggbind: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggbind);
-}
-
-stringId *Rggfuncname(t)
- struct Spgrhs *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggfuncname: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggfuncname);
-}
-
-long *Rggline(t)
- struct Spgrhs *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggline);
-}
+++ /dev/null
-#ifndef pbinding_defined
-#define pbinding_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- pgrhs
-} Tpbinding;
-
-typedef struct { Tpbinding tag; } *pbinding;
-
-#ifdef __GNUC__
-Tpbinding tpbinding(pbinding t);
-extern __inline__ Tpbinding tpbinding(pbinding t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tpbinding tpbinding PROTO((pbinding));
-#endif /* ! __GNUC__ */
-
-struct Spgrhs {
- Tpbinding tag;
- tree Xggpat;
- list Xggdexprs;
- binding Xggbind;
- stringId Xggfuncname;
- long Xggline;
-};
-
-extern pbinding mkpgrhs PROTO((tree, list, binding, stringId, long));
-#ifdef __GNUC__
-
-tree *Rggpat PROTO((struct Spgrhs *));
-
-extern __inline__ tree *Rggpat(struct Spgrhs *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggpat: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggpat);
-}
-#else /* ! __GNUC__ */
-extern tree *Rggpat PROTO((struct Spgrhs *));
-#endif /* ! __GNUC__ */
-
-#define ggpat(xyzxyz) (*Rggpat((struct Spgrhs *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rggdexprs PROTO((struct Spgrhs *));
-
-extern __inline__ list *Rggdexprs(struct Spgrhs *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggdexprs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggdexprs);
-}
-#else /* ! __GNUC__ */
-extern list *Rggdexprs PROTO((struct Spgrhs *));
-#endif /* ! __GNUC__ */
-
-#define ggdexprs(xyzxyz) (*Rggdexprs((struct Spgrhs *) (xyzxyz)))
-#ifdef __GNUC__
-
-binding *Rggbind PROTO((struct Spgrhs *));
-
-extern __inline__ binding *Rggbind(struct Spgrhs *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggbind: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggbind);
-}
-#else /* ! __GNUC__ */
-extern binding *Rggbind PROTO((struct Spgrhs *));
-#endif /* ! __GNUC__ */
-
-#define ggbind(xyzxyz) (*Rggbind((struct Spgrhs *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rggfuncname PROTO((struct Spgrhs *));
-
-extern __inline__ stringId *Rggfuncname(struct Spgrhs *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggfuncname: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggfuncname);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rggfuncname PROTO((struct Spgrhs *));
-#endif /* ! __GNUC__ */
-
-#define ggfuncname(xyzxyz) (*Rggfuncname((struct Spgrhs *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rggline PROTO((struct Spgrhs *));
-
-extern __inline__ long *Rggline(struct Spgrhs *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != pgrhs)
- fprintf(stderr,"ggline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggline);
-}
-#else /* ! __GNUC__ */
-extern long *Rggline PROTO((struct Spgrhs *));
-#endif /* ! __GNUC__ */
-
-#define ggline(xyzxyz) (*Rggline((struct Spgrhs *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_pbinding where
-import UgenUtil
-import Util
-
-import U_binding
-import U_coresyn ( U_coresyn ) -- interface only
-import U_hpragma ( U_hpragma ) -- interface only
-import U_list
-import U_literal ( U_literal ) -- ditto
-import U_treeHACK
-import U_ttype ( U_ttype ) -- ditto
-%}}
-type pbinding;
- pgrhs : < ggpat : tree;
- ggdexprs : list;
- ggbind : binding;
- ggfuncname : stringId;
- ggline : long; >;
-end;
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Syntax Tree Printing Routines *
-* *
-* *
-**********************************************************************/
-
-
-#define COMPACT TRUE /* No spaces in output -- #undef this for debugging */
-
-
-#include <stdio.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/* fwd decls, necessary and otherwise */
-static void ptree PROTO( (tree) );
-static void plist PROTO( (void (*)(/*NOT WORTH IT: void * */), list) );
-static void pid PROTO( (id) );
-static void pstr PROTO( (char *) );
-static void pbool PROTO( (BOOLEAN) );
-static void prbind PROTO( (binding) );
-static void pttype PROTO( (ttype) );
-static void patype PROTO( (atype) );
-static void pentid PROTO( (entidt) );
-static void prename PROTO( (list) );
-static void pfixes PROTO( (void) );
-static void ppbinding PROTO((pbinding));
-static void pgrhses PROTO( (list) );
-static void ppragma PROTO( (hpragma) );
-static void pcoresyn PROTO((coresyn));
-
-extern char *fixop PROTO((int));
-extern char *fixtype PROTO((int));
-
-extern char *input_filename;
-extern BOOLEAN hashIds;
-
-/* How to print tags */
-
-#if COMPACT
-#define PUTTAG(c) putchar(c);
-#define PUTTAGSTR(s) printf("%s",(s));
-#else
-#define PUTTAG(c) putchar(c); \
- putchar(' ');
-#define PUTTAGSTR(s) printf("%s",(s)); \
- putchar(' ');
-#endif
-
-
-/* Performs a post order walk of the tree
- to print it.
-*/
-
-void
-pprogram(t)
-tree t;
-{
- print_hash_table();
- ptree(t);
-}
-
-/* print_string: we must escape \t and \\, as described in
- char/string lexer comments. (WDP 94/11)
-*/
-static void
-print_string(hstring str)
-{
- char *gs;
- char c;
- int i, str_length;
-
- putchar('#');
- str_length = str->len;
- gs = str->bytes;
-
- for (i = 0; i < str_length; i++) {
- c = gs[i];
- if ( c == '\t' ) {
- putchar('\\');
- putchar('t');
- } else if ( c == '\\' ) {
- putchar('\\');
- putchar('\\');
- } else {
- putchar(gs[i]);
- }
- }
- putchar('\t');
-}
-
-static int
-get_character(hstring str)
-{
- int c = (int)((str->bytes)[0]);
-
- if (str->len != 1) { /* ToDo: assert */
- fprintf(stderr, "get_character: length != 1? (%ld: %s)\n", str->len, str->bytes);
- }
-
- if (c < 0) {
- c += 256; /* "This is not a hack" -- KH */
- }
-
- return(c);
-}
-
-static void
-pliteral(literal t)
-{
- switch(tliteral(t)) {
- case integer:
- PUTTAG('4');
- pstr(ginteger(t));
- break;
- case intprim:
- PUTTAG('H');
- pstr(gintprim(t));
- break;
- case floatr:
- PUTTAG('F');
- pstr(gfloatr(t));
- break;
- case doubleprim:
- PUTTAG('J');
- pstr(gdoubleprim(t));
- break;
- case floatprim:
- PUTTAG('K');
- pstr(gfloatprim(t));
- break;
- case charr:
- PUTTAG('C');
- /* Changed %d to %u, since negative chars
- make little sense -- KH @ 16/4/91
- */
- printf("#%u\t", get_character(gchar(t)));
- break;
- case charprim:
- PUTTAG('P');
- printf("#%u\t", get_character(gcharprim(t)));
- break;
- case string:
- PUTTAG('S');
- print_string(gstring(t));
- break;
- case stringprim:
- PUTTAG('V');
- print_string(gstringprim(t));
- break;
- case clitlit:
- PUTTAG('Y');
- pstr(gclitlit(t));
- pstr(gclitlit_kind(t));
- break;
-
- case norepi:
- PUTTAG('I');
- pstr(gnorepi(t));
- break;
- case norepr:
- PUTTAG('R');
- pstr(gnorepr_n(t));
- pstr(gnorepr_d(t));
- break;
- case noreps:
- PUTTAG('s');
- print_string(gnoreps(t));
- break;
- default:
- error("Bad pliteral");
- }
-}
-
-static void
-ptree(t)
- tree t;
-{
-again:
- switch(ttree(t)) {
- case par: t = gpare(t); goto again;
- case hmodule:
- PUTTAG('M');
- printf("#%lu\t",ghmodline(t));
- pid(ghname(t));
- pstr(input_filename);
- prbind(ghmodlist(t));
- pfixes();
- plist(prbind, ghimplist(t));
- plist(pentid, ghexplist(t));
- break;
- case ident:
- PUTTAG('i');
- pid(gident(t));
- break;
- case lit:
- PUTTAG('C');
- pliteral(glit(t));
- break;
-
- case ap:
- PUTTAG('a');
- ptree(gfun(t));
- ptree(garg(t));
- break;
- case lsection:
- PUTTAG('(');
- ptree(glsexp(t));
- pid(glsop(t));
- break;
- case rsection:
- PUTTAG(')');
- pid(grsop(t));
- ptree(grsexp(t));
- break;
- case tinfixop:
- PUTTAG('@');
- ptree(ginarg1((struct Sap *)t));
- pid(gident(ginfun((struct Sap *)t)));
- ptree(ginarg2((struct Sap *)t));
- break;
-
- case lambda:
- PUTTAG('l');
- printf("#%lu\t",glamline(t));
- plist(ptree,glampats(t));
- ptree(glamexpr(t));
- break;
-
- case let:
- PUTTAG('E');
- prbind(gletvdeflist(t));
- ptree(gletvexpr(t));
- break;
- case casee:
- PUTTAG('c');
- ptree(gcaseexpr(t));
- plist(ppbinding, gcasebody(t));
- break;
- case ife:
- PUTTAG('b');
- ptree(gifpred(t));
- ptree(gifthen(t));
- ptree(gifelse(t));
- break;
- case tuple:
- PUTTAG(',');
- plist(ptree,gtuplelist(t));
- break;
- case eenum:
- PUTTAG('.');
- ptree(gefrom(t));
- plist(ptree,gestep(t));
- plist(ptree,geto(t));
- break;
- case llist:
- PUTTAG(':');
- plist(ptree,gllist(t));
- break;
- case negate:
- PUTTAG('-');
- ptree(gnexp(t));
- break;
- case comprh:
- PUTTAG('Z');
- ptree(gcexp(t));
- plist(ptree,gcquals(t));
- break;
- case qual:
- PUTTAG('G');
- ptree(gqpat(t));
- ptree(gqexp(t));
- break;
- case guard:
- PUTTAG('g');
- ptree(ggexp(t));
- break;
- case def:
- PUTTAG('=');
- ptree(ggdef(t)); /* was: prbind (WDP 94/10) */
- break;
- case as:
- PUTTAG('s');
- pid(gasid(t));
- ptree(gase(t));
- break;
- case lazyp:
- PUTTAG('~');
- ptree(glazyp(t));
- break;
- case plusp:
- PUTTAG('+');
- ptree(gplusp(t));
- pliteral(gplusi(t));
- break;
- case wildp:
- PUTTAG('_');
- break;
- case restr:
- PUTTAG('R');
- ptree(grestre(t));
- pttype(grestrt(t));
- break;
- case ccall:
- PUTTAG('j');
- pstr(gccid(t));
- pstr(gccinfo(t));
- plist(ptree,gccargs(t));
- break;
- case scc:
- PUTTAG('k');
- print_string(gsccid(t));
- ptree(gsccexp(t));
- break;
-#ifdef DPH
- case parzf:
- PUTTAG('5');
- ptree(gpzfexp(t));
- plist(ptree,gpzfqual(t));
- break;
- case pod:
- PUTTAG('6');
- plist(ptree,gpod(t));
- break;
- case proc:
- PUTTAG('O');
- plist(ptree,gprocid(t));
- ptree(gprocdata(t));
- break;
- case pardgen:
- PUTTAG('0');
- ptree(gdproc(t));
- ptree(gdexp(t));
- break;
- case parigen:
- PUTTAG('w');
- ptree(giproc(t));
- ptree(giexp(t));
- break;
- case parfilt:
- PUTTAG('I');
- ptree(gpfilt(t));
- break;
-#endif /* DPH */
-
- default:
- error("Bad ptree");
- }
-}
-
-static void
-plist(fun, l)
- void (*fun)(/* NOT WORTH IT: void * */);
- list l;
-{
- if (tlist(l) == lcons) {
- PUTTAG('L');
- (*fun)(lhd(l));
- plist(fun, ltl(l));
- } else {
- PUTTAG('N');
- }
-}
-
-static void
-pid(i)
- id i;
-{
- if(hashIds)
- printf("!%lu\t", hash_index(i));
- else
- printf("#%s\t", id_to_string(i));
-}
-
-static void
-pstr(i)
- char *i;
-{
- printf("#%s\t", i);
-}
-
-static void
-prbind(b)
- binding b;
-{
- switch(tbinding(b)) {
- case tbind:
- PUTTAG('t');
- printf("#%lu\t",gtline(b));
- plist(pttype, gtbindc(b));
- plist(pid, gtbindd(b));
- pttype(gtbindid(b));
- plist(patype, gtbindl(b));
- ppragma(gtpragma(b));
- break;
- case nbind :
- PUTTAG('n');
- printf("#%lu\t",gnline(b));
- pttype(gnbindid(b));
- pttype(gnbindas(b));
- ppragma(gnpragma(b));
- break;
- case pbind :
- PUTTAG('p');
- printf("#%lu\t",gpline(b));
- plist(ppbinding, gpbindl(b));
- break;
- case fbind :
- PUTTAG('f');
- printf("#%lu\t",gfline(b));
- plist(ppbinding, gfbindl(b));
- break;
- case abind :
- PUTTAG('A');
- prbind(gabindfst(b));
- prbind(gabindsnd(b));
- break;
- case cbind :
- PUTTAG('$');
- printf("#%lu\t",gcline(b));
- plist(pttype,gcbindc(b));
- pttype(gcbindid(b));
- prbind(gcbindw(b));
- ppragma(gcpragma(b));
- break;
- case ibind :
- PUTTAG('%');
- printf("#%lu\t",giline(b));
- plist(pttype,gibindc(b));
- pid(gibindid(b));
- pttype(gibindi(b));
- prbind(gibindw(b));
- ppragma(gipragma(b));
- break;
- case dbind :
- PUTTAG('D');
- printf("#%lu\t",gdline(b));
- plist(pttype,gdbindts(b));
- break;
-
- /* signature(-like) things, including user pragmas */
- case sbind :
- PUTTAGSTR("St");
- printf("#%lu\t",gsline(b));
- plist(pid,gsbindids(b));
- pttype(gsbindid(b));
- ppragma(gspragma(b));
- break;
-
- case vspec_uprag:
- PUTTAGSTR("Ss");
- printf("#%lu\t",gvspec_line(b));
- pid(gvspec_id(b));
- plist(pttype,gvspec_tys(b));
- break;
- case ispec_uprag:
- PUTTAGSTR("SS");
- printf("#%lu\t",gispec_line(b));
- pid(gispec_clas(b));
- pttype(gispec_ty(b));
- break;
- case inline_uprag:
- PUTTAGSTR("Si");
- printf("#%lu\t",ginline_line(b));
- pid(ginline_id(b));
- plist(pid,ginline_howto(b));
- break;
- case deforest_uprag:
- PUTTAGSTR("Sd");
- printf("#%lu\t",gdeforest_line(b));
- pid(gdeforest_id(b));
- break;
- case magicuf_uprag:
- PUTTAGSTR("Su");
- printf("#%lu\t",gmagicuf_line(b));
- pid(gmagicuf_id(b));
- pid(gmagicuf_str(b));
- break;
- case abstract_uprag:
- PUTTAGSTR("Sa");
- printf("#%lu\t",gabstract_line(b));
- pid(gabstract_id(b));
- break;
- case dspec_uprag:
- PUTTAGSTR("Sd");
- printf("#%lu\t",gdspec_line(b));
- pid(gdspec_id(b));
- plist(pttype,gdspec_tys(b));
- break;
-
- /* end of signature(-like) things */
-
- case mbind:
- PUTTAG('7');
- printf("#%lu\t",gmline(b));
- pid(gmbindmodn(b));
- plist(pentid,gmbindimp(b));
- plist(prename,gmbindren(b));
- break;
- case import:
- PUTTAG('e');
- printf("#%lu\t",giebindline(b));
- pstr(giebindfile(b));
- pid(giebindmod(b));
- plist(pentid,giebindexp(b));
- plist(prename,giebindren(b));
- prbind(giebinddef(b));
- break;
- case hiding:
- PUTTAG('h');
- printf("#%lu\t",gihbindline(b));
- pstr(gihbindfile(b));
- pid(gihbindmod(b));
- plist(pentid,gihbindexp(b));
- plist(prename,gihbindren(b));
- prbind(gihbinddef(b));
- break;
- case nullbind :
- PUTTAG('B');
- break;
- default : error("Bad prbind");
- break;
- }
-}
-
-static void
-pttype(t)
- ttype t;
-{
- switch (tttype(t)) {
- case tname : PUTTAG('T');
- pid(gtypeid(t));
- plist(pttype, gtypel(t));
- break;
- case namedtvar : PUTTAG('y');
- pid(gnamedtvar(t));
- break;
- case tllist : PUTTAG(':');
- pttype(gtlist(t));
- break;
- case ttuple : PUTTAG(',');
- plist(pttype,gttuple(t));
- break;
- case tfun : PUTTAG('>');
- pttype(gtfun(t));
- pttype(gtarg(t));
- break;
- case context : PUTTAG('3');
- plist(pttype,gtcontextl(t));
- pttype(gtcontextt(t));
- break;
-
- case unidict : PUTTAGSTR("2A");
- pid(gunidict_clas(t));
- pttype(gunidict_ty(t));
- break;
- case unityvartemplate : PUTTAGSTR("2B");
- pid(gunityvartemplate(t));
- break;
- case uniforall : PUTTAGSTR("2C");
- plist(pid,guniforall_tv(t));
- pttype(guniforall_ty(t));
- break;
-
- case ty_maybe_nothing : PUTTAGSTR("2D");
- break;
- case ty_maybe_just: PUTTAGSTR("2E");
- pttype(gty_maybe(t));
- break;
-
-#ifdef DPH
- case tproc :
- PUTTAG('u');
- plist(pttype,gtpid(t));
- pttype(gtdata(t));
- break;
- case tpod :
- PUTTAG('v');
- pttype(gtpod(t));
- break;
-#endif
- default : error("bad pttype");
- }
-}
-
-static void
-patype(a)
- atype a;
-{
- switch (tatype(a)) {
- case atc :
- PUTTAG('1');
- printf("#%lu\t",gatcline(a));
- pid(gatcid(a));
- plist(pttype, gatctypel(a));
- break;
- default : fprintf(stderr, "Bad tag in abstree %d\n", tatype(a));
- exit(1);
- }
-}
-
-
-static void
-pentid(i)
- entidt i;
-{
- switch (tentidt(i)) {
- case entid : PUTTAG('x');
- pid(gentid(i));
- break;
- case enttype : PUTTAG('X');
- pid(gitentid(i));
- break;
- case enttypeall : PUTTAG('z');
- pid(gatentid(i));
- break;
- case entmod : PUTTAG('m');
- pid(gmentid(i));
- break;
- case enttypecons: PUTTAG('8');
- pid(gctentid(i));
- plist(pid,gctentcons(i));
- break;
- case entclass : PUTTAG('9');
- pid(gcentid(i));
- plist(pid,gcentops(i));
- break;
- default :
- error("Bad pentid");
- }
-}
-
-
-static void
-prename(l)
- list l;
-{
- pid(lhd(l));
- pid(lhd(ltl(l)));
-}
-
-
-static void
-pfixes()
-{
- int m = nfixes(), i;
- char *s;
-
- for(i = 0; i < m; i++) {
- s = fixtype(i);
- if (s) {
- PUTTAG('L');
- pstr(fixop(i));
- pstr(fixtype(i));
- printf("#%lu\t",precedence(i));
- }
- }
- PUTTAG('N');
-}
-
-
-static void
-ppbinding(p)
- pbinding p;
-{
- switch(tpbinding(p)) {
- case pgrhs : PUTTAG('W');
- printf("#%lu\t",ggline(p));
- pid(ggfuncname(p));
- ptree(ggpat(p));
- plist(pgrhses,ggdexprs(p));
- prbind(ggbind(p));
- break;
- default :
- error("Bad pbinding");
- }
-}
-
-
-static void
-pgrhses(l)
- list l;
-{
- ptree(lhd(l)); /* Guard */
- ptree(lhd(ltl(l))); /* Expression */
-}
-
-static void
-ppragma(p)
- hpragma p;
-{
- switch(thpragma(p)) {
- case no_pragma: PUTTAGSTR("PN");
- break;
- case idata_pragma: PUTTAGSTR("Pd");
- plist(patype, gprag_data_constrs(p));
- plist(ppragma, gprag_data_specs(p));
- break;
- case itype_pragma: PUTTAGSTR("Pt");
- break;
- case iclas_pragma: PUTTAGSTR("Pc");
- plist(ppragma, gprag_clas(p));
- break;
- case iclasop_pragma: PUTTAGSTR("Po");
- ppragma(gprag_dsel(p));
- ppragma(gprag_defm(p));
- break;
-
- case iinst_simpl_pragma: PUTTAGSTR("Pis");
- pid(gprag_imod_simpl(p));
- ppragma(gprag_dfun_simpl(p));
- break;
- case iinst_const_pragma: PUTTAGSTR("Pic");
- pid(gprag_imod_const(p));
- ppragma(gprag_dfun_const(p));
- plist(ppragma, gprag_constms(p));
- break;
-
- case igen_pragma: PUTTAGSTR("Pg");
- ppragma(gprag_arity(p));
- ppragma(gprag_update(p));
- ppragma(gprag_deforest(p));
- ppragma(gprag_strictness(p));
- ppragma(gprag_unfolding(p));
- plist(ppragma, gprag_specs(p));
- break;
- case iarity_pragma: PUTTAGSTR("PA");
- pid(gprag_arity_val(p));
- break;
- case iupdate_pragma: PUTTAGSTR("Pu");
- pid(gprag_update_val(p));
- break;
- case ideforest_pragma: PUTTAGSTR("PD");
- break;
- case istrictness_pragma: PUTTAGSTR("PS");
- print_string(gprag_strict_spec(p));
- ppragma(gprag_strict_wrkr(p));
- break;
- case imagic_unfolding_pragma: PUTTAGSTR("PM");
- pid(gprag_magic_str(p));
- break;
-
- case iunfolding_pragma: PUTTAGSTR("PU");
- ppragma(gprag_unfold_guide(p));
- pcoresyn(gprag_unfold_core(p));
- break;
-
- case iunfold_always: PUTTAGSTR("Px");
- break;
- case iunfold_if_args: PUTTAGSTR("Py");
- pid(gprag_unfold_if_t_args(p));
- pid(gprag_unfold_if_v_args(p));
- pid(gprag_unfold_if_con_args(p));
- pid(gprag_unfold_if_size(p));
- break;
-
- case iname_pragma_pr: PUTTAGSTR("P1");
- pid(gprag_name_pr1(p));
- ppragma(gprag_name_pr2(p));
- break;
- case itype_pragma_pr: PUTTAGSTR("P2");
- plist(pttype, gprag_type_pr1(p));
- pid(gprag_type_pr2(p));
- ppragma(gprag_type_pr3(p));
- break;
-
- case idata_pragma_4s: PUTTAGSTR("P4");
- plist(pttype, gprag_data_spec(p));
- break;
-
- default: error("Bad Pragma");
- }
-}
-
-static void
-pbool(b)
- BOOLEAN b;
-{
- if (b) {
- putchar('T');
- } else {
- putchar('F');
- }
-}
-
-static void
-pcoresyn(p)
- coresyn p;
-{
- switch(tcoresyn(p)) {
- case cobinder: PUTTAGSTR("Fa");
- pid(gcobinder_v(p));
- pttype(gcobinder_ty(p));
- break;
-
- case colit: PUTTAGSTR("Fb");
- pliteral(gcolit(p));
- break;
- case colocal: PUTTAGSTR("Fc");
- pcoresyn(gcolocal_v(p));
- break;
-
- case cononrec: PUTTAGSTR("Fd");
- pcoresyn(gcononrec_b(p));
- pcoresyn(gcononrec_rhs(p));
- break;
- case corec: PUTTAGSTR("Fe");
- plist(pcoresyn,gcorec(p));
- break;
- case corec_pair: PUTTAGSTR("Ff");
- pcoresyn(gcorec_b(p));
- pcoresyn(gcorec_rhs(p));
- break;
-
- case covar: PUTTAGSTR("Fg");
- pcoresyn(gcovar(p));
- break;
- case coliteral: PUTTAGSTR("Fh");
- pliteral(gcoliteral(p));
- break;
- case cocon: PUTTAGSTR("Fi");
- pcoresyn(gcocon_con(p));
- plist(pttype, gcocon_tys(p));
- plist(pcoresyn, gcocon_args(p));
- break;
- case coprim: PUTTAGSTR("Fj");
- pcoresyn(gcoprim_op(p));
- plist(pttype, gcoprim_tys(p));
- plist(pcoresyn, gcoprim_args(p));
- break;
- case colam: PUTTAGSTR("Fk");
- plist(pcoresyn, gcolam_vars(p));
- pcoresyn(gcolam_body(p));
- break;
- case cotylam: PUTTAGSTR("Fl");
- plist(pid, gcotylam_tvs(p));
- pcoresyn(gcotylam_body(p));
- break;
- case coapp: PUTTAGSTR("Fm");
- pcoresyn(gcoapp_fun(p));
- plist(pcoresyn, gcoapp_args(p));
- break;
- case cotyapp: PUTTAGSTR("Fn");
- pcoresyn(gcotyapp_e(p));
- pttype(gcotyapp_t(p));
- break;
- case cocase: PUTTAGSTR("Fo");
- pcoresyn(gcocase_s(p));
- pcoresyn(gcocase_alts(p));
- break;
- case colet: PUTTAGSTR("Fp");
- pcoresyn(gcolet_bind(p));
- pcoresyn(gcolet_body(p));
- break;
- case coscc: PUTTAGSTR("Fz"); /* out of order! */
- pcoresyn(gcoscc_scc(p));
- pcoresyn(gcoscc_body(p));
- break;
-
- case coalg_alts: PUTTAGSTR("Fq");
- plist(pcoresyn, gcoalg_alts(p));
- pcoresyn(gcoalg_deflt(p));
- break;
- case coalg_alt: PUTTAGSTR("Fr");
- pcoresyn(gcoalg_con(p));
- plist(pcoresyn, gcoalg_bs(p));
- pcoresyn(gcoalg_rhs(p));
- break;
- case coprim_alts: PUTTAGSTR("Fs");
- plist(pcoresyn, gcoprim_alts(p));
- pcoresyn(gcoprim_deflt(p));
- break;
- case coprim_alt: PUTTAGSTR("Ft");
- pliteral(gcoprim_lit(p));
- pcoresyn(gcoprim_rhs(p));
- break;
- case conodeflt: PUTTAGSTR("Fu");
- break;
- case cobinddeflt: PUTTAGSTR("Fv");
- pcoresyn(gcobinddeflt_v(p));
- pcoresyn(gcobinddeflt_rhs(p));
- break;
-
- case co_primop: PUTTAGSTR("Fw");
- pid(gco_primop(p));
- break;
- case co_ccall: PUTTAGSTR("Fx");
- pbool(gco_ccall_may_gc(p));
- pid(gco_ccall(p));
- plist(pttype, gco_ccall_arg_tys(p));
- pttype(gco_ccall_res_ty(p));
- break;
- case co_casm: PUTTAGSTR("Fy");
- pbool(gco_casm_may_gc(p));
- pliteral(gco_casm(p));
- plist(pttype, gco_casm_arg_tys(p));
- pttype(gco_casm_res_ty(p));
- break;
-
- /* Cost-centre stuff */
- case co_preludedictscc: PUTTAGSTR("F?a");
- pcoresyn(gco_preludedictscc_dupd(p));
- break;
- case co_alldictscc: PUTTAGSTR("F?b");
- print_string(gco_alldictscc_m(p));
- print_string(gco_alldictscc_g(p));
- pcoresyn(gco_alldictscc_dupd(p));
- break;
- case co_usercc: PUTTAGSTR("F?c");
- print_string(gco_usercc_n(p));
- print_string(gco_usercc_m(p));
- print_string(gco_usercc_g(p));
- pcoresyn(gco_usercc_dupd(p));
- pcoresyn(gco_usercc_cafd(p));
- break;
- case co_autocc: PUTTAGSTR("F?d");
- pcoresyn(gco_autocc_i(p));
- print_string(gco_autocc_m(p));
- print_string(gco_autocc_g(p));
- pcoresyn(gco_autocc_dupd(p));
- pcoresyn(gco_autocc_cafd(p));
- break;
- case co_dictcc: PUTTAGSTR("F?e");
- pcoresyn(gco_dictcc_i(p));
- print_string(gco_dictcc_m(p));
- print_string(gco_dictcc_g(p));
- pcoresyn(gco_dictcc_dupd(p));
- pcoresyn(gco_dictcc_cafd(p));
- break;
-
- case co_scc_noncaf: PUTTAGSTR("F?f");
- break;
- case co_scc_caf: PUTTAGSTR("F?g");
- break;
- case co_scc_nondupd: PUTTAGSTR("F?h");
- break;
- case co_scc_dupd: PUTTAGSTR("F?i");
- break;
-
- /* Id stuff */
- case co_id: PUTTAGSTR("F1");
- pid(gco_id(p));
- break;
- case co_orig_id: PUTTAGSTR("F9");
- pid(gco_orig_id_m(p));
- pid(gco_orig_id_n(p));
- break;
- case co_sdselid: PUTTAGSTR("F2");
- pid(gco_sdselid_c(p));
- pid(gco_sdselid_sc(p));
- break;
- case co_classopid: PUTTAGSTR("F3");
- pid(gco_classopid_c(p));
- pid(gco_classopid_o(p));
- break;
- case co_defmid: PUTTAGSTR("F4");
- pid(gco_defmid_c(p));
- pid(gco_defmid_op(p));
- break;
- case co_dfunid: PUTTAGSTR("F5");
- pid(gco_dfunid_c(p));
- pttype(gco_dfunid_ty(p));
- break;
- case co_constmid: PUTTAGSTR("F6");
- pid(gco_constmid_c(p));
- pid(gco_constmid_op(p));
- pttype(gco_constmid_ty(p));
- break;
- case co_specid: PUTTAGSTR("F7");
- pcoresyn(gco_specid_un(p));
- plist(pttype,gco_specid_tys(p));
- break;
- case co_wrkrid: PUTTAGSTR("F8");
- pcoresyn(gco_wrkrid_un(p));
- break;
- /* more to come?? */
-
- default : error("Bad Core syntax");
- }
-}
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Syntax-related Utility Functions *
-* *
-* *
-**********************************************************************/
-
-#include <stdio.h>
-#include <ctype.h>
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-#ifdef DPH
-#include "tree-DPH.h"
-#else
-#include "tree.h"
-#endif
-
-/*
- This file, syntax.c, is used both for the regular parser
- and for parseint; however, we use the tab.h file from
- the regular parser. This could get us in trouble...
-*/
-#ifdef DPH
-#include "hsparser-DPH.tab.h"
-#else
-#include "hsparser.tab.h"
-#endif /* Data Parallel Haskell */
-
-/* Imported values */
-extern short icontexts;
-extern list Lnil;
-extern unsigned endlineno, startlineno;
-extern BOOLEAN hashIds, etags;
-
-/* Forward Declarations */
-
-char *ineg PROTO((char *));
-static tree unparen PROTO((tree));
-static void is_conapp_patt PROTO((int, tree, tree));
-static void rearrangeprec PROTO((tree, tree));
-static void error_if_expr_wanted PROTO((int, char *));
-static void error_if_patt_wanted PROTO((int, char *));
-
-tree fns[MAX_CONTEXTS] = { NULL };
-short samefn[MAX_CONTEXTS] = { 0 };
-tree prevpatt[MAX_CONTEXTS] = { NULL };
-
-BOOLEAN inpat = FALSE;
-
-static BOOLEAN checkorder2 PROTO((binding, BOOLEAN));
-static BOOLEAN checksig PROTO((BOOLEAN, binding));
-
-/*
- check infix value in range 0..9
-*/
-
-
-int
-checkfixity(vals)
- char *vals;
-{
- int value;
- sscanf(vals,"%d",&value);
-
- if (value < 0 || value > 9)
- {
- int oldvalue = value;
- value = value < 0 ? 0 : 9;
- fprintf(stderr,"Precedence must be between 0 and 9 (value given: %d, changed to %d)\n",
- oldvalue,value);
- }
- return(value);
-}
-
-
-/*
- Check Previous Pattern usage
-*/
-
-/* UNUSED:
-void
-checkprevpatt()
-{
- if (PREVPATT == NULL)
- hsperror("\"'\" used before a function definition");
-}
-*/
-
-void
-checksamefn(fn)
- char *fn;
-{
- SAMEFN = (hashIds && fn == (char *)FN) || (FN != NULL && strcmp(fn,gident(FN)) == 0);
- if(!SAMEFN && etags)
-#if 1/*etags*/
- printf("%u\n",startlineno);
-#else
- fprintf(stderr,"%u\tchecksamefn:%s\n",startlineno,fn);
-#endif
-}
-
-
-/*
- Check that a list of types is a list of contexts
-*/
-
-#if 0
-/* UNUSED */
-void
-checkcontext(context)
- list context;
-{
- ttype ty; list tl;
- int valid;
-
- while (tlist(context) == lcons)
- {
- ty = (ttype) lhd(context);
- valid = tttype(ty) == tname;
- if (valid)
- {
- tl = gtypel(ty);
- valid = tlist(tl) != lnil && tlist(ltl(tl)) == lnil && tttype((ttype) lhd(tl)) == namedtvar;
- }
-
- if (!valid)
- hsperror("Not a valid context");
-
- context = ltl(context);
- }
-}
-#endif /* 0 */
-
-void
-checkinpat()
-{
- if(!inpat)
- hsperror("syntax error");
-}
-
-/* ------------------------------------------------------------------------
-*/
-
-void
-patternOrExpr(int wanted, tree e)
- /* see utils.h for what args are */
-{
- switch(ttree(e))
- {
- case ident: /* a pattern or expr */
- break;
-
- case wildp:
- error_if_expr_wanted(wanted, "wildcard in expression");
- break;
-
- case lit:
- switch (tliteral(glit(e))) {
- case integer:
- case intprim:
- case floatr:
- case doubleprim:
- case floatprim:
- case string:
- case stringprim:
- case charr:
- case charprim:
- break; /* pattern or expr */
-
- case clitlit:
- error_if_patt_wanted(wanted, "``literal-literal'' in pattern");
-
- default: /* the others only occur in pragmas */
- hsperror("not a valid literal pattern or expression");
- }
- break;
-
- case negate:
- { tree sub = gnexp(e);
- if (ttree(sub) != lit) {
- error_if_patt_wanted(wanted, "\"-\" applied to a non-literal");
- } else {
- literal l = glit(sub);
-
- if (tliteral(l) != integer && tliteral(l) != floatr) {
- error_if_patt_wanted(wanted, "\"-\" applied to a non-number");
- }
- }
- patternOrExpr(wanted, sub);
- }
- break;
-
- case ap:
- {
- tree f = gfun(e);
- tree a = garg(e);
-
- is_conapp_patt(wanted, f, a); /* does nothing unless wanted == LEGIT_PATT */
- patternOrExpr(wanted, f);
- patternOrExpr(wanted, a);
- }
- break;
-
- case as:
- error_if_expr_wanted(wanted, "`as'-pattern instead of an expression");
- patternOrExpr(wanted, gase(e));
- break;
-
- case lazyp:
- error_if_expr_wanted(wanted, "irrefutable pattern instead of an expression");
- patternOrExpr(wanted, glazyp(e));
- break;
-
- case plusp:
- patternOrExpr(wanted, gplusp(e));
- break;
-
- case tinfixop:
- {
- tree f = ginfun((struct Sap *)e),
- a1 = ginarg1((struct Sap *)e),
- a2 = ginarg2((struct Sap *)e);
-
- struct Splusp *e_plus;
-
- patternOrExpr(wanted, a1);
- patternOrExpr(wanted, a2);
-
- if (wanted == LEGIT_PATT) {
- if (ttree(f) == ident && strcmp(id_to_string(gident(f)),"+")==0) {
-
- if(ttree(a2) != lit || tliteral((literal) ttree(a2)) != integer)
- hsperror("non-integer in (n+k) pattern");
-
- if(ttree(a1) == wildp || (ttree(a1) == ident && !isconstr(gident(a1))))
- {
- e->tag = plusp;
- e_plus = (struct Splusp *) e;
- *Rgplusp(e_plus) = a1;
- *Rgplusi(e_plus) = glit(a2);
- }
- else
- hsperror("non-variable in (n+k) pattern");
-
- } else {
- if(ttree(f) == ident && !isconstr(gident(f)))
- hsperror("variable application in pattern");
- }
- }
- }
- break;
-
- case tuple:
- {
- list tup;
- for (tup = gtuplelist(e); tlist(tup) == lcons; tup = ltl(tup)) {
- patternOrExpr(wanted, lhd(tup));
- }
- }
- break;
-
- case par: /* parenthesised */
- patternOrExpr(wanted, gpare(e));
- break;
-
- case llist:
- {
- list l;
- for (l = gllist(e); tlist(l) == lcons; l = ltl(l)) {
- patternOrExpr(wanted, lhd(l));
- }
- }
- break;
-
-#ifdef DPH
- case proc:
- {
- list pids;
- for (pids = gprocid(e); tlist(pids) == lcons; pids = ltl(pids)) {
- patternOrExpr(wanted, lhd(pids));
- }
- patternOrExpr(wanted, gprocdata(e));
- }
- break;
-#endif /* DPH */
-
- case lambda:
- case let:
- case casee:
- case ife:
- case restr:
- case comprh:
- case lsection:
- case rsection:
- case eenum:
- case ccall:
- case scc:
- error_if_patt_wanted(wanted, "unexpected construct in a pattern");
- break;
-
- default:
- hsperror("not a pattern or expression");
- }
-}
-
-static void
-is_conapp_patt(int wanted, tree f, tree a)
-{
- if (wanted == LEGIT_EXPR)
- return; /* that was easy */
-
- switch(ttree(f))
- {
- case ident:
- if (isconstr(gident(f)))
- {
- patternOrExpr(wanted, a);
- return;
- }
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"not a constructor application -- %s",gident(f));
- hsperror(errbuf);
- }
-
- case ap:
- is_conapp_patt(wanted, gfun(f), garg(f));
- patternOrExpr(wanted, a);
- return;
-
- case par:
- is_conapp_patt(wanted, gpare(f), a);
- break;
-
- case tuple:
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"tuple pattern `applied' to arguments (missing comma?)");
- hsperror(errbuf);
- }
- break;
-
- default:
- hsperror("not a constructor application");
- }
-}
-
-static void
-error_if_expr_wanted(int wanted, char *msg)
-{
- if (wanted == LEGIT_EXPR)
- hsperror(msg);
-}
-
-static void
-error_if_patt_wanted(int wanted, char *msg)
-{
- if (wanted == LEGIT_PATT)
- hsperror(msg);
-}
-
-/* ---------------------------------------------------------------------- */
-
-static BOOLEAN /* return TRUE if LHS is a pattern; FALSE if a function */
-is_patt_or_fun(tree e, BOOLEAN outer_level)
- /* "outer_level" only needed because x+y is a *function* at
- the "outer level", but an n+k *pattern* at
- any "inner" level. Sigh. */
-{
- switch(ttree(e))
- {
- case lit:
- switch (tliteral(glit(e))) {
- case integer:
- case intprim:
- case floatr:
- case doubleprim:
- case floatprim:
- case string:
- case charr:
- case charprim:
- case stringprim:
- return TRUE;
- default:
- hsperror("Literal is not a valid LHS");
- }
-
- case wildp:
- return TRUE;
-
- case as:
- case lazyp:
- case plusp:
- case llist:
- case tuple:
- case negate:
-#ifdef DPH
- case proc:
-#endif
- patternOrExpr(LEGIT_PATT, e);
- return TRUE;
-
- case ident:
- return(TRUE);
- /* This change might break ap infixop below. BEWARE.
- return (isconstr(gident(e)));
- */
-
- case ap:
- {
- tree a = garg(e);
- /* do not "unparen", otherwise the error
- fromInteger ((x,y) {-no comma-} z)
- will be missed.
- */
- tree fn = function(e);
-
-/*fprintf(stderr,"ap:f=%d %s (%d),a=%d %s\n",ttree(gfun(e)),(ttree(gfun(e)) == ident) ? (gident(gfun(e))) : "",ttree(fn),ttree(garg(e)),(ttree(garg(e)) == ident) ? (gident(garg(e))) : "");*/
- patternOrExpr(LEGIT_PATT, a);
-
- if(ttree(fn) == ident)
- return(isconstr(gident(fn)));
-
- else if(ttree(fn) == tinfixop)
- return(is_patt_or_fun(fn, TRUE/*still at "outer level"*/));
-
- else
- hsperror("Not a legal pattern binding in LHS");
- }
-
- case tinfixop:
- {
- tree f = ginfun((struct Sap *)e),
- a1 = unparen(ginarg1((struct Sap *)e)),
- a2 = unparen(ginarg2((struct Sap *)e));
-
- struct Splusp *e_plus;
-
- /* Even function definitions must have pattern arguments */
- patternOrExpr(LEGIT_PATT, a1);
- patternOrExpr(LEGIT_PATT, a2);
-
- if (ttree(f) == ident)
- {
- if(strcmp(id_to_string(gident(f)),"+")==0 && ttree(a1) == ident)
- {
- /* n+k is a function at the top level */
- if(outer_level || ttree(a2) != lit || tliteral((literal) ttree(a2)) != integer)
- return FALSE;
-
- e->tag = plusp;
- e_plus = (struct Splusp *) e;
- *Rgplusp(e_plus) = a1;
- *Rgplusi(e_plus) = glit(a2);
- return TRUE;
- }
- else
- return(isconstr(gident(f)));
- }
-
- else
- hsperror("Strange infix op");
- }
-
- case par:
- return(is_patt_or_fun(gpare(e), FALSE /*no longer at "outer level"*/));
-
- /* Anything else must be an illegal LHS */
- default:
- hsperror("Not a valid LHS");
- }
-
- abort(); /* should never get here */
- return(FALSE);
-}
-
-/* interface for the outside world */
-BOOLEAN
-lhs_is_patt(e)
- tree e;
-{
- return(is_patt_or_fun(e, TRUE /*outer-level*/));
-}
-
-/*
- Return the function at the root of a series of applications.
-*/
-
-tree
-function(e)
- tree e;
-{
- switch (ttree(e))
- {
- case ap:
- patternOrExpr(LEGIT_PATT, garg(e));
- return(function(gfun(e)));
-
- case par:
- return(function(gpare(e)));
-
- default:
- return(e);
- }
-}
-
-
-static tree
-unparen(e)
- tree e;
-{
- while (ttree(e) == par)
- e = gpare(e);
-
- return(e);
-}
-
-
-/*
- Extend a function by adding a new definition to its list of bindings.
-*/
-
-void
-extendfn(bind,rule)
-binding bind;
-binding rule;
-{
-/* fprintf(stderr,"extending binding (%d)\n",tbinding(bind));*/
- if(tbinding(bind) == abind)
- bind = gabindsnd(bind);
-
- if(tbinding(bind) == pbind)
- gpbindl(bind) = lconc(gpbindl(bind), gpbindl(rule));
- else if(tbinding(bind) == fbind)
- gfbindl(bind) = lconc(gfbindl(bind), gfbindl(rule));
- else
- fprintf(stderr,"bind error in decl (%d)\n",tbinding(bind));
-}
-
-/*
-
- Precedence Parser for Haskell. By default operators are left-associative,
- so it is only necessary to rearrange the parse tree where the new operator
- has a greater precedence than the existing one, or where two operators have
- the same precedence and are both right-associative. Error conditions are
- handled.
-
- Note: Prefix negation has the same precedence as infix minus.
- The algorithm must thus take account of explicit negates.
-*/
-
-void
-precparse(tree t)
-{
-#if 0
-# ifdef HSP_DEBUG
- fprintf(stderr,"precparse %x\n",ttree(t));
-# endif
-#endif
- if(ttree(t) == tinfixop)
- {
- tree left = ginarg1((struct Sap *)t);
-
-#if 0
-# ifdef HSP_DEBUG
- fprintf(stderr,"precparse:t=");ptree(t);printf("\nleft=");ptree(left);printf("\n");
-# endif
-#endif
-
- if(ttree(left) == negate)
- {
- id tid = gident(ginfun((struct Sap *)t));
- struct infix *ttabpos = infixlookup(tid);
- struct infix *ntabpos = infixlookup(install_literal("-")); /* This should be static, but C won't allow that. */
-
- if(pprecedence(ntabpos) < pprecedence(ttabpos))
- {
- tree right = ginarg2((struct Sap *)t);
- t->tag = negate;
- gnexp(t) = mkinfixop(tid,gnexp(left),right);
- }
- }
-
- else if(ttree(left) == tinfixop)
- {
- id lid = gident(ginfun((struct Sap *)left)),
- tid = gident(ginfun((struct Sap *)t));
-
- struct infix *lefttabpos = infixlookup(lid),
- *ttabpos = infixlookup(tid);
-
-#if 0
-# ifdef HSP_DEBUG
- fprintf(stderr,"precparse: lid=%s; tid=%s,ltab=%d,ttab=%d\n",
- id_to_string(lid),id_to_string(tid),pprecedence(lefttabpos),pprecedence(ttabpos));
-# endif
-#endif
-
- if (pprecedence(lefttabpos) < pprecedence(ttabpos))
- rearrangeprec(left,t);
-
- else if (pprecedence(lefttabpos) == pprecedence(ttabpos))
- {
- if(pfixity(lefttabpos) == INFIXR && pfixity(ttabpos) == INFIXR)
- rearrangeprec(left,t);
-
- else if(pfixity(lefttabpos) == INFIXL && pfixity(ttabpos) == INFIXL)
- /* SKIP */;
-
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Cannot mix %s and %s in the same infix expression",
- id_to_string(lid), id_to_string(tid));
- hsperror(errbuf);
- }
- }
- }
- }
-}
-
-
-/*
- Rearrange a tree to effectively insert an operator in the correct place.
- The recursive call to precparse ensures this filters down as necessary.
-*/
-
-static void
-rearrangeprec(tree t1, tree t2)
-{
- tree arg3 = ginarg2((struct Sap *)t2);
- id id1 = gident(ginfun((struct Sap *)t1)),
- id2 = gident(ginfun((struct Sap *)t2));
- gident(ginfun((struct Sap *)t1)) = id2;
- gident(ginfun((struct Sap *)t2)) = id1;
-
- ginarg2((struct Sap *)t2) = t1;
- ginarg1((struct Sap *)t2) = ginarg1((struct Sap *)t1);
- ginarg1((struct Sap *)t1) = ginarg2((struct Sap *)t1);
- ginarg2((struct Sap *)t1) = arg3;
- precparse(t1);
-}
-
-pbinding
-createpat(guards,where)
- list guards;
- binding where;
-{
- char *func;
-
- if(FN != NULL)
- func = gident(FN);
- else
- func = install_literal("");
-
- /* I don't think I need to allocate func here -- KH */
- return(mkpgrhs(PREVPATT,guards,where,func,endlineno));
-}
-
-
-list
-mktruecase(expr)
- tree expr;
-{
-/* partain: want a more magical symbol ???
- return(ldub(mkbool(1),expr));
-*/
- return(ldub(mkident(install_literal("__o")),expr)); /* __otherwise */
-}
-
-
-char *
-ineg(i)
- char *i;
-{
- char *p = xmalloc(strlen(i)+2);
-
- *p = '-';
- strcpy(p+1,i);
- return(p);
-}
-
-#if 0
-/* UNUSED: at the moment */
-void
-checkmodname(import,interface)
- id import, interface;
-{
- if(strcmp(import,interface) != 0)
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"interface name (%s) does not agree with import name (%s)",interface,import);
- hsperror(errbuf);
- }
-}
-#endif /* 0 */
-
-/*
- Check the ordering of declarations in a cbody.
- All signatures must appear before any declarations.
-*/
-
-void
-checkorder(decls)
- binding decls;
-{
- /* The ordering must be correct for a singleton */
- if(tbinding(decls)!=abind)
- return;
-
- checkorder2(decls,TRUE);
-}
-
-static BOOLEAN
-checkorder2(decls,sigs)
- binding decls;
- BOOLEAN sigs;
-{
- while(tbinding(decls)==abind)
- {
- /* Perform a left-traversal if necessary */
- binding left = gabindfst(decls);
- if(tbinding(left)==abind)
- sigs = checkorder2(left,sigs);
- else
- sigs = checksig(sigs,left);
- decls = gabindsnd(decls);
- }
-
- return(checksig(sigs,decls));
-}
-
-
-static BOOLEAN
-checksig(sig,decl)
- BOOLEAN sig;
- binding decl;
-{
- BOOLEAN issig = tbinding(decl) == sbind || tbinding(decl) == nullbind;
- if(!sig && issig)
- hsperror("Signature appears after definition in class body");
-
- return(issig);
-}
-
-
-/*
- Check the precedence of a pattern or expression to ensure that
- sections and function definitions have the correct parse.
-*/
-
-void
-checkprec(exp,fn,right)
- tree exp;
- id fn;
- BOOLEAN right;
-{
- if(ttree(exp) == tinfixop)
- {
- struct infix *ftabpos = infixlookup(fn);
- struct infix *etabpos = infixlookup(gident(ginfun((struct Sap *)exp)));
-
- if (pprecedence(etabpos) > pprecedence(ftabpos) ||
- (pprecedence(etabpos) == pprecedence(ftabpos) &&
- ((pfixity(etabpos) == INFIXR && pfixity(ftabpos) == INFIXR && right) ||
- ((pfixity(etabpos) == INFIXL && pfixity(ftabpos) == INFIXL && !right)))))
- /* SKIP */;
-
- else
- {
- char errbuf[ERR_BUF_SIZE];
- sprintf(errbuf,"Cannot mix %s and %s on a LHS or in a section",
- id_to_string(fn), id_to_string(gident(ginfun((struct Sap *)exp))));
- hsperror(errbuf);
- }
- }
-}
-
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_tree where
-import UgenUtil
-import Util
-%}}
-type tree;
- hmodule : < ghname : id;
- ghimplist : list;
- ghexplist : list;
- ghmodlist : binding;
- ghmodline : unsigned; >;
- ident : < gident : id; >;
- integer : < ginteger : id; >;
- intprim : < gintprim : id; >;
- floatr : < gfloatr : id; >;
- doubleprim : < gdoubleprim : id; >;
- floatprim : < gfloatprim : id; >;
- charr : < gchar : id; >;
- charprim : < gcharprim : id; >;
- clitlit : < gclitlit : id; >;
- voidprim : < >;
- string : < gstring : id; >;
- tuple : < gtuplelist : list; >;
- ap : < gfun : tree;
- garg : tree; >;
- lambda : < glampats : list;
- glamexpr : tree;
- glamline : unsigned; >;
- let : < gletvdeflist : binding;
- gletvexpr : tree; >;
- casee : < gcaseexpr : tree;
- gcasebody : list; >;
- ife : < gifpred : tree;
- gifthen : tree;
- gifelse : tree; >;
- par : < gpare : tree; >;
- as : < gasid : id;
- gase : tree; >;
- lazyp : < glazyp : tree; >;
- plusp : < gplusp : tree;
- gplusi : tree; >;
- wildp : < >;
- restr : < grestre : tree;
- grestrt : ttype; >;
- comprh : < gcexp : tree;
- gcquals : list; >;
- qual : < gqpat : tree;
- gqexp : tree; >;
- guard : < ggexp : tree; >;
- def : < ggdef : binding; >;
- tinfixop: < gdummy : tree; >;
- lsection: < glsexp : tree;
- glsop : id; >;
- rsection: < grsop : id;
- grsexp : tree; >;
- eenum : < gefrom : tree;
- gestep : list;
- geto : list; >;
- llist : < gllist : list; >;
- ccall : < gccid : id;
- gccinfo : id;
- gccargs : list; >;
- scc : < gsccid : id;
- gsccexp : tree; >;
- negate : < gnexp : tree; >;
- parzf : < gpzfexp : tree;
- gpzfqual : list; >;
- pardgen : < gdproc : tree;
- gdexp : tree; >;
- parigen : < giproc : tree;
- giexp : tree; >;
- parfilt : < gpfilt : tree; >;
- pod : < gpod : list; >;
- proc : < gprocid : list;
- gprocdata : tree; >;
-
-end;
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/tree.h"
-
-Ttree ttree(t)
- tree t;
-{
- return(t -> tag);
-}
-
-
-/************** hmodule ******************/
-
-tree mkhmodule(PPghname, PPghimplist, PPghexplist, PPghmodlist, PPghmodline)
- stringId PPghname;
- list PPghimplist;
- list PPghexplist;
- binding PPghmodlist;
- long PPghmodline;
-{
- register struct Shmodule *pp =
- (struct Shmodule *) malloc(sizeof(struct Shmodule));
- pp -> tag = hmodule;
- pp -> Xghname = PPghname;
- pp -> Xghimplist = PPghimplist;
- pp -> Xghexplist = PPghexplist;
- pp -> Xghmodlist = PPghmodlist;
- pp -> Xghmodline = PPghmodline;
- return((tree)pp);
-}
-
-stringId *Rghname(t)
- struct Shmodule *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghname: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghname);
-}
-
-list *Rghimplist(t)
- struct Shmodule *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghimplist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghimplist);
-}
-
-list *Rghexplist(t)
- struct Shmodule *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghexplist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghexplist);
-}
-
-binding *Rghmodlist(t)
- struct Shmodule *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghmodlist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghmodlist);
-}
-
-long *Rghmodline(t)
- struct Shmodule *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghmodline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghmodline);
-}
-
-/************** ident ******************/
-
-tree mkident(PPgident)
- unkId PPgident;
-{
- register struct Sident *pp =
- (struct Sident *) malloc(sizeof(struct Sident));
- pp -> tag = ident;
- pp -> Xgident = PPgident;
- return((tree)pp);
-}
-
-unkId *Rgident(t)
- struct Sident *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ident)
- fprintf(stderr,"gident: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgident);
-}
-
-/************** lit ******************/
-
-tree mklit(PPglit)
- literal PPglit;
-{
- register struct Slit *pp =
- (struct Slit *) malloc(sizeof(struct Slit));
- pp -> tag = lit;
- pp -> Xglit = PPglit;
- return((tree)pp);
-}
-
-literal *Rglit(t)
- struct Slit *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lit)
- fprintf(stderr,"glit: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglit);
-}
-
-/************** tuple ******************/
-
-tree mktuple(PPgtuplelist)
- list PPgtuplelist;
-{
- register struct Stuple *pp =
- (struct Stuple *) malloc(sizeof(struct Stuple));
- pp -> tag = tuple;
- pp -> Xgtuplelist = PPgtuplelist;
- return((tree)pp);
-}
-
-list *Rgtuplelist(t)
- struct Stuple *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tuple)
- fprintf(stderr,"gtuplelist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtuplelist);
-}
-
-/************** ap ******************/
-
-tree mkap(PPgfun, PPgarg)
- tree PPgfun;
- tree PPgarg;
-{
- register struct Sap *pp =
- (struct Sap *) malloc(sizeof(struct Sap));
- pp -> tag = ap;
- pp -> Xgfun = PPgfun;
- pp -> Xgarg = PPgarg;
- return((tree)pp);
-}
-
-tree *Rgfun(t)
- struct Sap *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ap)
- fprintf(stderr,"gfun: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfun);
-}
-
-tree *Rgarg(t)
- struct Sap *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ap)
- fprintf(stderr,"garg: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgarg);
-}
-
-/************** lambda ******************/
-
-tree mklambda(PPglampats, PPglamexpr, PPglamline)
- list PPglampats;
- tree PPglamexpr;
- long PPglamline;
-{
- register struct Slambda *pp =
- (struct Slambda *) malloc(sizeof(struct Slambda));
- pp -> tag = lambda;
- pp -> Xglampats = PPglampats;
- pp -> Xglamexpr = PPglamexpr;
- pp -> Xglamline = PPglamline;
- return((tree)pp);
-}
-
-list *Rglampats(t)
- struct Slambda *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lambda)
- fprintf(stderr,"glampats: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglampats);
-}
-
-tree *Rglamexpr(t)
- struct Slambda *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lambda)
- fprintf(stderr,"glamexpr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglamexpr);
-}
-
-long *Rglamline(t)
- struct Slambda *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lambda)
- fprintf(stderr,"glamline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglamline);
-}
-
-/************** let ******************/
-
-tree mklet(PPgletvdeflist, PPgletvexpr)
- binding PPgletvdeflist;
- tree PPgletvexpr;
-{
- register struct Slet *pp =
- (struct Slet *) malloc(sizeof(struct Slet));
- pp -> tag = let;
- pp -> Xgletvdeflist = PPgletvdeflist;
- pp -> Xgletvexpr = PPgletvexpr;
- return((tree)pp);
-}
-
-binding *Rgletvdeflist(t)
- struct Slet *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != let)
- fprintf(stderr,"gletvdeflist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgletvdeflist);
-}
-
-tree *Rgletvexpr(t)
- struct Slet *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != let)
- fprintf(stderr,"gletvexpr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgletvexpr);
-}
-
-/************** casee ******************/
-
-tree mkcasee(PPgcaseexpr, PPgcasebody)
- tree PPgcaseexpr;
- list PPgcasebody;
-{
- register struct Scasee *pp =
- (struct Scasee *) malloc(sizeof(struct Scasee));
- pp -> tag = casee;
- pp -> Xgcaseexpr = PPgcaseexpr;
- pp -> Xgcasebody = PPgcasebody;
- return((tree)pp);
-}
-
-tree *Rgcaseexpr(t)
- struct Scasee *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != casee)
- fprintf(stderr,"gcaseexpr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcaseexpr);
-}
-
-list *Rgcasebody(t)
- struct Scasee *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != casee)
- fprintf(stderr,"gcasebody: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcasebody);
-}
-
-/************** ife ******************/
-
-tree mkife(PPgifpred, PPgifthen, PPgifelse)
- tree PPgifpred;
- tree PPgifthen;
- tree PPgifelse;
-{
- register struct Sife *pp =
- (struct Sife *) malloc(sizeof(struct Sife));
- pp -> tag = ife;
- pp -> Xgifpred = PPgifpred;
- pp -> Xgifthen = PPgifthen;
- pp -> Xgifelse = PPgifelse;
- return((tree)pp);
-}
-
-tree *Rgifpred(t)
- struct Sife *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ife)
- fprintf(stderr,"gifpred: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgifpred);
-}
-
-tree *Rgifthen(t)
- struct Sife *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ife)
- fprintf(stderr,"gifthen: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgifthen);
-}
-
-tree *Rgifelse(t)
- struct Sife *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ife)
- fprintf(stderr,"gifelse: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgifelse);
-}
-
-/************** par ******************/
-
-tree mkpar(PPgpare)
- tree PPgpare;
-{
- register struct Spar *pp =
- (struct Spar *) malloc(sizeof(struct Spar));
- pp -> tag = par;
- pp -> Xgpare = PPgpare;
- return((tree)pp);
-}
-
-tree *Rgpare(t)
- struct Spar *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != par)
- fprintf(stderr,"gpare: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgpare);
-}
-
-/************** as ******************/
-
-tree mkas(PPgasid, PPgase)
- unkId PPgasid;
- tree PPgase;
-{
- register struct Sas *pp =
- (struct Sas *) malloc(sizeof(struct Sas));
- pp -> tag = as;
- pp -> Xgasid = PPgasid;
- pp -> Xgase = PPgase;
- return((tree)pp);
-}
-
-unkId *Rgasid(t)
- struct Sas *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != as)
- fprintf(stderr,"gasid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgasid);
-}
-
-tree *Rgase(t)
- struct Sas *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != as)
- fprintf(stderr,"gase: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgase);
-}
-
-/************** lazyp ******************/
-
-tree mklazyp(PPglazyp)
- tree PPglazyp;
-{
- register struct Slazyp *pp =
- (struct Slazyp *) malloc(sizeof(struct Slazyp));
- pp -> tag = lazyp;
- pp -> Xglazyp = PPglazyp;
- return((tree)pp);
-}
-
-tree *Rglazyp(t)
- struct Slazyp *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lazyp)
- fprintf(stderr,"glazyp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglazyp);
-}
-
-/************** plusp ******************/
-
-tree mkplusp(PPgplusp, PPgplusi)
- tree PPgplusp;
- literal PPgplusi;
-{
- register struct Splusp *pp =
- (struct Splusp *) malloc(sizeof(struct Splusp));
- pp -> tag = plusp;
- pp -> Xgplusp = PPgplusp;
- pp -> Xgplusi = PPgplusi;
- return((tree)pp);
-}
-
-tree *Rgplusp(t)
- struct Splusp *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != plusp)
- fprintf(stderr,"gplusp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgplusp);
-}
-
-literal *Rgplusi(t)
- struct Splusp *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != plusp)
- fprintf(stderr,"gplusi: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgplusi);
-}
-
-/************** wildp ******************/
-
-tree mkwildp(void)
-{
- register struct Swildp *pp =
- (struct Swildp *) malloc(sizeof(struct Swildp));
- pp -> tag = wildp;
- return((tree)pp);
-}
-
-/************** restr ******************/
-
-tree mkrestr(PPgrestre, PPgrestrt)
- tree PPgrestre;
- ttype PPgrestrt;
-{
- register struct Srestr *pp =
- (struct Srestr *) malloc(sizeof(struct Srestr));
- pp -> tag = restr;
- pp -> Xgrestre = PPgrestre;
- pp -> Xgrestrt = PPgrestrt;
- return((tree)pp);
-}
-
-tree *Rgrestre(t)
- struct Srestr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != restr)
- fprintf(stderr,"grestre: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgrestre);
-}
-
-ttype *Rgrestrt(t)
- struct Srestr *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != restr)
- fprintf(stderr,"grestrt: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgrestrt);
-}
-
-/************** comprh ******************/
-
-tree mkcomprh(PPgcexp, PPgcquals)
- tree PPgcexp;
- list PPgcquals;
-{
- register struct Scomprh *pp =
- (struct Scomprh *) malloc(sizeof(struct Scomprh));
- pp -> tag = comprh;
- pp -> Xgcexp = PPgcexp;
- pp -> Xgcquals = PPgcquals;
- return((tree)pp);
-}
-
-tree *Rgcexp(t)
- struct Scomprh *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != comprh)
- fprintf(stderr,"gcexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcexp);
-}
-
-list *Rgcquals(t)
- struct Scomprh *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != comprh)
- fprintf(stderr,"gcquals: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcquals);
-}
-
-/************** qual ******************/
-
-tree mkqual(PPgqpat, PPgqexp)
- tree PPgqpat;
- tree PPgqexp;
-{
- register struct Squal *pp =
- (struct Squal *) malloc(sizeof(struct Squal));
- pp -> tag = qual;
- pp -> Xgqpat = PPgqpat;
- pp -> Xgqexp = PPgqexp;
- return((tree)pp);
-}
-
-tree *Rgqpat(t)
- struct Squal *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != qual)
- fprintf(stderr,"gqpat: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgqpat);
-}
-
-tree *Rgqexp(t)
- struct Squal *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != qual)
- fprintf(stderr,"gqexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgqexp);
-}
-
-/************** guard ******************/
-
-tree mkguard(PPggexp)
- tree PPggexp;
-{
- register struct Sguard *pp =
- (struct Sguard *) malloc(sizeof(struct Sguard));
- pp -> tag = guard;
- pp -> Xggexp = PPggexp;
- return((tree)pp);
-}
-
-tree *Rggexp(t)
- struct Sguard *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != guard)
- fprintf(stderr,"ggexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggexp);
-}
-
-/************** def ******************/
-
-tree mkdef(PPggdef)
- tree PPggdef;
-{
- register struct Sdef *pp =
- (struct Sdef *) malloc(sizeof(struct Sdef));
- pp -> tag = def;
- pp -> Xggdef = PPggdef;
- return((tree)pp);
-}
-
-tree *Rggdef(t)
- struct Sdef *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != def)
- fprintf(stderr,"ggdef: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggdef);
-}
-
-/************** tinfixop ******************/
-
-tree mktinfixop(PPgdummy)
- infixTree PPgdummy;
-{
- register struct Stinfixop *pp =
- (struct Stinfixop *) malloc(sizeof(struct Stinfixop));
- pp -> tag = tinfixop;
- pp -> Xgdummy = PPgdummy;
- return((tree)pp);
-}
-
-infixTree *Rgdummy(t)
- struct Stinfixop *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tinfixop)
- fprintf(stderr,"gdummy: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdummy);
-}
-
-/************** lsection ******************/
-
-tree mklsection(PPglsexp, PPglsop)
- tree PPglsexp;
- unkId PPglsop;
-{
- register struct Slsection *pp =
- (struct Slsection *) malloc(sizeof(struct Slsection));
- pp -> tag = lsection;
- pp -> Xglsexp = PPglsexp;
- pp -> Xglsop = PPglsop;
- return((tree)pp);
-}
-
-tree *Rglsexp(t)
- struct Slsection *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lsection)
- fprintf(stderr,"glsexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglsexp);
-}
-
-unkId *Rglsop(t)
- struct Slsection *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lsection)
- fprintf(stderr,"glsop: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglsop);
-}
-
-/************** rsection ******************/
-
-tree mkrsection(PPgrsop, PPgrsexp)
- unkId PPgrsop;
- tree PPgrsexp;
-{
- register struct Srsection *pp =
- (struct Srsection *) malloc(sizeof(struct Srsection));
- pp -> tag = rsection;
- pp -> Xgrsop = PPgrsop;
- pp -> Xgrsexp = PPgrsexp;
- return((tree)pp);
-}
-
-unkId *Rgrsop(t)
- struct Srsection *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != rsection)
- fprintf(stderr,"grsop: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgrsop);
-}
-
-tree *Rgrsexp(t)
- struct Srsection *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != rsection)
- fprintf(stderr,"grsexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgrsexp);
-}
-
-/************** eenum ******************/
-
-tree mkeenum(PPgefrom, PPgestep, PPgeto)
- tree PPgefrom;
- list PPgestep;
- list PPgeto;
-{
- register struct Seenum *pp =
- (struct Seenum *) malloc(sizeof(struct Seenum));
- pp -> tag = eenum;
- pp -> Xgefrom = PPgefrom;
- pp -> Xgestep = PPgestep;
- pp -> Xgeto = PPgeto;
- return((tree)pp);
-}
-
-tree *Rgefrom(t)
- struct Seenum *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != eenum)
- fprintf(stderr,"gefrom: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgefrom);
-}
-
-list *Rgestep(t)
- struct Seenum *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != eenum)
- fprintf(stderr,"gestep: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgestep);
-}
-
-list *Rgeto(t)
- struct Seenum *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != eenum)
- fprintf(stderr,"geto: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgeto);
-}
-
-/************** llist ******************/
-
-tree mkllist(PPgllist)
- list PPgllist;
-{
- register struct Sllist *pp =
- (struct Sllist *) malloc(sizeof(struct Sllist));
- pp -> tag = llist;
- pp -> Xgllist = PPgllist;
- return((tree)pp);
-}
-
-list *Rgllist(t)
- struct Sllist *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != llist)
- fprintf(stderr,"gllist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgllist);
-}
-
-/************** ccall ******************/
-
-tree mkccall(PPgccid, PPgccinfo, PPgccargs)
- stringId PPgccid;
- stringId PPgccinfo;
- list PPgccargs;
-{
- register struct Sccall *pp =
- (struct Sccall *) malloc(sizeof(struct Sccall));
- pp -> tag = ccall;
- pp -> Xgccid = PPgccid;
- pp -> Xgccinfo = PPgccinfo;
- pp -> Xgccargs = PPgccargs;
- return((tree)pp);
-}
-
-stringId *Rgccid(t)
- struct Sccall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ccall)
- fprintf(stderr,"gccid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgccid);
-}
-
-stringId *Rgccinfo(t)
- struct Sccall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ccall)
- fprintf(stderr,"gccinfo: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgccinfo);
-}
-
-list *Rgccargs(t)
- struct Sccall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ccall)
- fprintf(stderr,"gccargs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgccargs);
-}
-
-/************** scc ******************/
-
-tree mkscc(PPgsccid, PPgsccexp)
- hstring PPgsccid;
- tree PPgsccexp;
-{
- register struct Sscc *pp =
- (struct Sscc *) malloc(sizeof(struct Sscc));
- pp -> tag = scc;
- pp -> Xgsccid = PPgsccid;
- pp -> Xgsccexp = PPgsccexp;
- return((tree)pp);
-}
-
-hstring *Rgsccid(t)
- struct Sscc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != scc)
- fprintf(stderr,"gsccid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsccid);
-}
-
-tree *Rgsccexp(t)
- struct Sscc *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != scc)
- fprintf(stderr,"gsccexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsccexp);
-}
-
-/************** negate ******************/
-
-tree mknegate(PPgnexp)
- tree PPgnexp;
-{
- register struct Snegate *pp =
- (struct Snegate *) malloc(sizeof(struct Snegate));
- pp -> tag = negate;
- pp -> Xgnexp = PPgnexp;
- return((tree)pp);
-}
-
-tree *Rgnexp(t)
- struct Snegate *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != negate)
- fprintf(stderr,"gnexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnexp);
-}
+++ /dev/null
-#ifndef tree_defined
-#define tree_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- hmodule,
- ident,
- lit,
- tuple,
- ap,
- lambda,
- let,
- casee,
- ife,
- par,
- as,
- lazyp,
- plusp,
- wildp,
- restr,
- comprh,
- qual,
- guard,
- def,
- tinfixop,
- lsection,
- rsection,
- eenum,
- llist,
- ccall,
- scc,
- negate
-} Ttree;
-
-typedef struct { Ttree tag; } *tree;
-
-#ifdef __GNUC__
-Ttree ttree(tree t);
-extern __inline__ Ttree ttree(tree t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Ttree ttree PROTO((tree));
-#endif /* ! __GNUC__ */
-
-struct Shmodule {
- Ttree tag;
- stringId Xghname;
- list Xghimplist;
- list Xghexplist;
- binding Xghmodlist;
- long Xghmodline;
-};
-
-struct Sident {
- Ttree tag;
- unkId Xgident;
-};
-
-struct Slit {
- Ttree tag;
- literal Xglit;
-};
-
-struct Stuple {
- Ttree tag;
- list Xgtuplelist;
-};
-
-struct Sap {
- Ttree tag;
- tree Xgfun;
- tree Xgarg;
-};
-
-struct Slambda {
- Ttree tag;
- list Xglampats;
- tree Xglamexpr;
- long Xglamline;
-};
-
-struct Slet {
- Ttree tag;
- binding Xgletvdeflist;
- tree Xgletvexpr;
-};
-
-struct Scasee {
- Ttree tag;
- tree Xgcaseexpr;
- list Xgcasebody;
-};
-
-struct Sife {
- Ttree tag;
- tree Xgifpred;
- tree Xgifthen;
- tree Xgifelse;
-};
-
-struct Spar {
- Ttree tag;
- tree Xgpare;
-};
-
-struct Sas {
- Ttree tag;
- unkId Xgasid;
- tree Xgase;
-};
-
-struct Slazyp {
- Ttree tag;
- tree Xglazyp;
-};
-
-struct Splusp {
- Ttree tag;
- tree Xgplusp;
- literal Xgplusi;
-};
-
-struct Swildp {
- Ttree tag;
-};
-
-struct Srestr {
- Ttree tag;
- tree Xgrestre;
- ttype Xgrestrt;
-};
-
-struct Scomprh {
- Ttree tag;
- tree Xgcexp;
- list Xgcquals;
-};
-
-struct Squal {
- Ttree tag;
- tree Xgqpat;
- tree Xgqexp;
-};
-
-struct Sguard {
- Ttree tag;
- tree Xggexp;
-};
-
-struct Sdef {
- Ttree tag;
- tree Xggdef;
-};
-
-struct Stinfixop {
- Ttree tag;
- infixTree Xgdummy;
-};
-
-struct Slsection {
- Ttree tag;
- tree Xglsexp;
- unkId Xglsop;
-};
-
-struct Srsection {
- Ttree tag;
- unkId Xgrsop;
- tree Xgrsexp;
-};
-
-struct Seenum {
- Ttree tag;
- tree Xgefrom;
- list Xgestep;
- list Xgeto;
-};
-
-struct Sllist {
- Ttree tag;
- list Xgllist;
-};
-
-struct Sccall {
- Ttree tag;
- stringId Xgccid;
- stringId Xgccinfo;
- list Xgccargs;
-};
-
-struct Sscc {
- Ttree tag;
- hstring Xgsccid;
- tree Xgsccexp;
-};
-
-struct Snegate {
- Ttree tag;
- tree Xgnexp;
-};
-
-extern tree mkhmodule PROTO((stringId, list, list, binding, long));
-#ifdef __GNUC__
-
-stringId *Rghname PROTO((struct Shmodule *));
-
-extern __inline__ stringId *Rghname(struct Shmodule *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghname: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghname);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rghname PROTO((struct Shmodule *));
-#endif /* ! __GNUC__ */
-
-#define ghname(xyzxyz) (*Rghname((struct Shmodule *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rghimplist PROTO((struct Shmodule *));
-
-extern __inline__ list *Rghimplist(struct Shmodule *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghimplist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghimplist);
-}
-#else /* ! __GNUC__ */
-extern list *Rghimplist PROTO((struct Shmodule *));
-#endif /* ! __GNUC__ */
-
-#define ghimplist(xyzxyz) (*Rghimplist((struct Shmodule *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rghexplist PROTO((struct Shmodule *));
-
-extern __inline__ list *Rghexplist(struct Shmodule *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghexplist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghexplist);
-}
-#else /* ! __GNUC__ */
-extern list *Rghexplist PROTO((struct Shmodule *));
-#endif /* ! __GNUC__ */
-
-#define ghexplist(xyzxyz) (*Rghexplist((struct Shmodule *) (xyzxyz)))
-#ifdef __GNUC__
-
-binding *Rghmodlist PROTO((struct Shmodule *));
-
-extern __inline__ binding *Rghmodlist(struct Shmodule *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghmodlist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghmodlist);
-}
-#else /* ! __GNUC__ */
-extern binding *Rghmodlist PROTO((struct Shmodule *));
-#endif /* ! __GNUC__ */
-
-#define ghmodlist(xyzxyz) (*Rghmodlist((struct Shmodule *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rghmodline PROTO((struct Shmodule *));
-
-extern __inline__ long *Rghmodline(struct Shmodule *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != hmodule)
- fprintf(stderr,"ghmodline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xghmodline);
-}
-#else /* ! __GNUC__ */
-extern long *Rghmodline PROTO((struct Shmodule *));
-#endif /* ! __GNUC__ */
-
-#define ghmodline(xyzxyz) (*Rghmodline((struct Shmodule *) (xyzxyz)))
-
-extern tree mkident PROTO((unkId));
-#ifdef __GNUC__
-
-unkId *Rgident PROTO((struct Sident *));
-
-extern __inline__ unkId *Rgident(struct Sident *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ident)
- fprintf(stderr,"gident: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgident);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgident PROTO((struct Sident *));
-#endif /* ! __GNUC__ */
-
-#define gident(xyzxyz) (*Rgident((struct Sident *) (xyzxyz)))
-
-extern tree mklit PROTO((literal));
-#ifdef __GNUC__
-
-literal *Rglit PROTO((struct Slit *));
-
-extern __inline__ literal *Rglit(struct Slit *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lit)
- fprintf(stderr,"glit: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglit);
-}
-#else /* ! __GNUC__ */
-extern literal *Rglit PROTO((struct Slit *));
-#endif /* ! __GNUC__ */
-
-#define glit(xyzxyz) (*Rglit((struct Slit *) (xyzxyz)))
-
-extern tree mktuple PROTO((list));
-#ifdef __GNUC__
-
-list *Rgtuplelist PROTO((struct Stuple *));
-
-extern __inline__ list *Rgtuplelist(struct Stuple *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tuple)
- fprintf(stderr,"gtuplelist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtuplelist);
-}
-#else /* ! __GNUC__ */
-extern list *Rgtuplelist PROTO((struct Stuple *));
-#endif /* ! __GNUC__ */
-
-#define gtuplelist(xyzxyz) (*Rgtuplelist((struct Stuple *) (xyzxyz)))
-
-extern tree mkap PROTO((tree, tree));
-#ifdef __GNUC__
-
-tree *Rgfun PROTO((struct Sap *));
-
-extern __inline__ tree *Rgfun(struct Sap *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ap)
- fprintf(stderr,"gfun: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgfun);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgfun PROTO((struct Sap *));
-#endif /* ! __GNUC__ */
-
-#define gfun(xyzxyz) (*Rgfun((struct Sap *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rgarg PROTO((struct Sap *));
-
-extern __inline__ tree *Rgarg(struct Sap *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ap)
- fprintf(stderr,"garg: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgarg);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgarg PROTO((struct Sap *));
-#endif /* ! __GNUC__ */
-
-#define garg(xyzxyz) (*Rgarg((struct Sap *) (xyzxyz)))
-
-extern tree mklambda PROTO((list, tree, long));
-#ifdef __GNUC__
-
-list *Rglampats PROTO((struct Slambda *));
-
-extern __inline__ list *Rglampats(struct Slambda *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lambda)
- fprintf(stderr,"glampats: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglampats);
-}
-#else /* ! __GNUC__ */
-extern list *Rglampats PROTO((struct Slambda *));
-#endif /* ! __GNUC__ */
-
-#define glampats(xyzxyz) (*Rglampats((struct Slambda *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rglamexpr PROTO((struct Slambda *));
-
-extern __inline__ tree *Rglamexpr(struct Slambda *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lambda)
- fprintf(stderr,"glamexpr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglamexpr);
-}
-#else /* ! __GNUC__ */
-extern tree *Rglamexpr PROTO((struct Slambda *));
-#endif /* ! __GNUC__ */
-
-#define glamexpr(xyzxyz) (*Rglamexpr((struct Slambda *) (xyzxyz)))
-#ifdef __GNUC__
-
-long *Rglamline PROTO((struct Slambda *));
-
-extern __inline__ long *Rglamline(struct Slambda *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lambda)
- fprintf(stderr,"glamline: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglamline);
-}
-#else /* ! __GNUC__ */
-extern long *Rglamline PROTO((struct Slambda *));
-#endif /* ! __GNUC__ */
-
-#define glamline(xyzxyz) (*Rglamline((struct Slambda *) (xyzxyz)))
-
-extern tree mklet PROTO((binding, tree));
-#ifdef __GNUC__
-
-binding *Rgletvdeflist PROTO((struct Slet *));
-
-extern __inline__ binding *Rgletvdeflist(struct Slet *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != let)
- fprintf(stderr,"gletvdeflist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgletvdeflist);
-}
-#else /* ! __GNUC__ */
-extern binding *Rgletvdeflist PROTO((struct Slet *));
-#endif /* ! __GNUC__ */
-
-#define gletvdeflist(xyzxyz) (*Rgletvdeflist((struct Slet *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rgletvexpr PROTO((struct Slet *));
-
-extern __inline__ tree *Rgletvexpr(struct Slet *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != let)
- fprintf(stderr,"gletvexpr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgletvexpr);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgletvexpr PROTO((struct Slet *));
-#endif /* ! __GNUC__ */
-
-#define gletvexpr(xyzxyz) (*Rgletvexpr((struct Slet *) (xyzxyz)))
-
-extern tree mkcasee PROTO((tree, list));
-#ifdef __GNUC__
-
-tree *Rgcaseexpr PROTO((struct Scasee *));
-
-extern __inline__ tree *Rgcaseexpr(struct Scasee *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != casee)
- fprintf(stderr,"gcaseexpr: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcaseexpr);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgcaseexpr PROTO((struct Scasee *));
-#endif /* ! __GNUC__ */
-
-#define gcaseexpr(xyzxyz) (*Rgcaseexpr((struct Scasee *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcasebody PROTO((struct Scasee *));
-
-extern __inline__ list *Rgcasebody(struct Scasee *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != casee)
- fprintf(stderr,"gcasebody: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcasebody);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcasebody PROTO((struct Scasee *));
-#endif /* ! __GNUC__ */
-
-#define gcasebody(xyzxyz) (*Rgcasebody((struct Scasee *) (xyzxyz)))
-
-extern tree mkife PROTO((tree, tree, tree));
-#ifdef __GNUC__
-
-tree *Rgifpred PROTO((struct Sife *));
-
-extern __inline__ tree *Rgifpred(struct Sife *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ife)
- fprintf(stderr,"gifpred: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgifpred);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgifpred PROTO((struct Sife *));
-#endif /* ! __GNUC__ */
-
-#define gifpred(xyzxyz) (*Rgifpred((struct Sife *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rgifthen PROTO((struct Sife *));
-
-extern __inline__ tree *Rgifthen(struct Sife *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ife)
- fprintf(stderr,"gifthen: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgifthen);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgifthen PROTO((struct Sife *));
-#endif /* ! __GNUC__ */
-
-#define gifthen(xyzxyz) (*Rgifthen((struct Sife *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rgifelse PROTO((struct Sife *));
-
-extern __inline__ tree *Rgifelse(struct Sife *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ife)
- fprintf(stderr,"gifelse: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgifelse);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgifelse PROTO((struct Sife *));
-#endif /* ! __GNUC__ */
-
-#define gifelse(xyzxyz) (*Rgifelse((struct Sife *) (xyzxyz)))
-
-extern tree mkpar PROTO((tree));
-#ifdef __GNUC__
-
-tree *Rgpare PROTO((struct Spar *));
-
-extern __inline__ tree *Rgpare(struct Spar *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != par)
- fprintf(stderr,"gpare: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgpare);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgpare PROTO((struct Spar *));
-#endif /* ! __GNUC__ */
-
-#define gpare(xyzxyz) (*Rgpare((struct Spar *) (xyzxyz)))
-
-extern tree mkas PROTO((unkId, tree));
-#ifdef __GNUC__
-
-unkId *Rgasid PROTO((struct Sas *));
-
-extern __inline__ unkId *Rgasid(struct Sas *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != as)
- fprintf(stderr,"gasid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgasid);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgasid PROTO((struct Sas *));
-#endif /* ! __GNUC__ */
-
-#define gasid(xyzxyz) (*Rgasid((struct Sas *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rgase PROTO((struct Sas *));
-
-extern __inline__ tree *Rgase(struct Sas *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != as)
- fprintf(stderr,"gase: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgase);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgase PROTO((struct Sas *));
-#endif /* ! __GNUC__ */
-
-#define gase(xyzxyz) (*Rgase((struct Sas *) (xyzxyz)))
-
-extern tree mklazyp PROTO((tree));
-#ifdef __GNUC__
-
-tree *Rglazyp PROTO((struct Slazyp *));
-
-extern __inline__ tree *Rglazyp(struct Slazyp *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lazyp)
- fprintf(stderr,"glazyp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglazyp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rglazyp PROTO((struct Slazyp *));
-#endif /* ! __GNUC__ */
-
-#define glazyp(xyzxyz) (*Rglazyp((struct Slazyp *) (xyzxyz)))
-
-extern tree mkplusp PROTO((tree, literal));
-#ifdef __GNUC__
-
-tree *Rgplusp PROTO((struct Splusp *));
-
-extern __inline__ tree *Rgplusp(struct Splusp *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != plusp)
- fprintf(stderr,"gplusp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgplusp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgplusp PROTO((struct Splusp *));
-#endif /* ! __GNUC__ */
-
-#define gplusp(xyzxyz) (*Rgplusp((struct Splusp *) (xyzxyz)))
-#ifdef __GNUC__
-
-literal *Rgplusi PROTO((struct Splusp *));
-
-extern __inline__ literal *Rgplusi(struct Splusp *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != plusp)
- fprintf(stderr,"gplusi: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgplusi);
-}
-#else /* ! __GNUC__ */
-extern literal *Rgplusi PROTO((struct Splusp *));
-#endif /* ! __GNUC__ */
-
-#define gplusi(xyzxyz) (*Rgplusi((struct Splusp *) (xyzxyz)))
-
-extern tree mkwildp PROTO((void));
-
-extern tree mkrestr PROTO((tree, ttype));
-#ifdef __GNUC__
-
-tree *Rgrestre PROTO((struct Srestr *));
-
-extern __inline__ tree *Rgrestre(struct Srestr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != restr)
- fprintf(stderr,"grestre: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgrestre);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgrestre PROTO((struct Srestr *));
-#endif /* ! __GNUC__ */
-
-#define grestre(xyzxyz) (*Rgrestre((struct Srestr *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgrestrt PROTO((struct Srestr *));
-
-extern __inline__ ttype *Rgrestrt(struct Srestr *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != restr)
- fprintf(stderr,"grestrt: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgrestrt);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgrestrt PROTO((struct Srestr *));
-#endif /* ! __GNUC__ */
-
-#define grestrt(xyzxyz) (*Rgrestrt((struct Srestr *) (xyzxyz)))
-
-extern tree mkcomprh PROTO((tree, list));
-#ifdef __GNUC__
-
-tree *Rgcexp PROTO((struct Scomprh *));
-
-extern __inline__ tree *Rgcexp(struct Scomprh *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != comprh)
- fprintf(stderr,"gcexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcexp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgcexp PROTO((struct Scomprh *));
-#endif /* ! __GNUC__ */
-
-#define gcexp(xyzxyz) (*Rgcexp((struct Scomprh *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgcquals PROTO((struct Scomprh *));
-
-extern __inline__ list *Rgcquals(struct Scomprh *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != comprh)
- fprintf(stderr,"gcquals: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgcquals);
-}
-#else /* ! __GNUC__ */
-extern list *Rgcquals PROTO((struct Scomprh *));
-#endif /* ! __GNUC__ */
-
-#define gcquals(xyzxyz) (*Rgcquals((struct Scomprh *) (xyzxyz)))
-
-extern tree mkqual PROTO((tree, tree));
-#ifdef __GNUC__
-
-tree *Rgqpat PROTO((struct Squal *));
-
-extern __inline__ tree *Rgqpat(struct Squal *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != qual)
- fprintf(stderr,"gqpat: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgqpat);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgqpat PROTO((struct Squal *));
-#endif /* ! __GNUC__ */
-
-#define gqpat(xyzxyz) (*Rgqpat((struct Squal *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rgqexp PROTO((struct Squal *));
-
-extern __inline__ tree *Rgqexp(struct Squal *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != qual)
- fprintf(stderr,"gqexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgqexp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgqexp PROTO((struct Squal *));
-#endif /* ! __GNUC__ */
-
-#define gqexp(xyzxyz) (*Rgqexp((struct Squal *) (xyzxyz)))
-
-extern tree mkguard PROTO((tree));
-#ifdef __GNUC__
-
-tree *Rggexp PROTO((struct Sguard *));
-
-extern __inline__ tree *Rggexp(struct Sguard *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != guard)
- fprintf(stderr,"ggexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggexp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rggexp PROTO((struct Sguard *));
-#endif /* ! __GNUC__ */
-
-#define ggexp(xyzxyz) (*Rggexp((struct Sguard *) (xyzxyz)))
-
-extern tree mkdef PROTO((tree));
-#ifdef __GNUC__
-
-tree *Rggdef PROTO((struct Sdef *));
-
-extern __inline__ tree *Rggdef(struct Sdef *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != def)
- fprintf(stderr,"ggdef: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xggdef);
-}
-#else /* ! __GNUC__ */
-extern tree *Rggdef PROTO((struct Sdef *));
-#endif /* ! __GNUC__ */
-
-#define ggdef(xyzxyz) (*Rggdef((struct Sdef *) (xyzxyz)))
-
-extern tree mktinfixop PROTO((infixTree));
-#ifdef __GNUC__
-
-infixTree *Rgdummy PROTO((struct Stinfixop *));
-
-extern __inline__ infixTree *Rgdummy(struct Stinfixop *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tinfixop)
- fprintf(stderr,"gdummy: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgdummy);
-}
-#else /* ! __GNUC__ */
-extern infixTree *Rgdummy PROTO((struct Stinfixop *));
-#endif /* ! __GNUC__ */
-
-#define gdummy(xyzxyz) (*Rgdummy((struct Stinfixop *) (xyzxyz)))
-
-extern tree mklsection PROTO((tree, unkId));
-#ifdef __GNUC__
-
-tree *Rglsexp PROTO((struct Slsection *));
-
-extern __inline__ tree *Rglsexp(struct Slsection *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lsection)
- fprintf(stderr,"glsexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglsexp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rglsexp PROTO((struct Slsection *));
-#endif /* ! __GNUC__ */
-
-#define glsexp(xyzxyz) (*Rglsexp((struct Slsection *) (xyzxyz)))
-#ifdef __GNUC__
-
-unkId *Rglsop PROTO((struct Slsection *));
-
-extern __inline__ unkId *Rglsop(struct Slsection *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != lsection)
- fprintf(stderr,"glsop: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xglsop);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rglsop PROTO((struct Slsection *));
-#endif /* ! __GNUC__ */
-
-#define glsop(xyzxyz) (*Rglsop((struct Slsection *) (xyzxyz)))
-
-extern tree mkrsection PROTO((unkId, tree));
-#ifdef __GNUC__
-
-unkId *Rgrsop PROTO((struct Srsection *));
-
-extern __inline__ unkId *Rgrsop(struct Srsection *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != rsection)
- fprintf(stderr,"grsop: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgrsop);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgrsop PROTO((struct Srsection *));
-#endif /* ! __GNUC__ */
-
-#define grsop(xyzxyz) (*Rgrsop((struct Srsection *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rgrsexp PROTO((struct Srsection *));
-
-extern __inline__ tree *Rgrsexp(struct Srsection *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != rsection)
- fprintf(stderr,"grsexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgrsexp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgrsexp PROTO((struct Srsection *));
-#endif /* ! __GNUC__ */
-
-#define grsexp(xyzxyz) (*Rgrsexp((struct Srsection *) (xyzxyz)))
-
-extern tree mkeenum PROTO((tree, list, list));
-#ifdef __GNUC__
-
-tree *Rgefrom PROTO((struct Seenum *));
-
-extern __inline__ tree *Rgefrom(struct Seenum *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != eenum)
- fprintf(stderr,"gefrom: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgefrom);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgefrom PROTO((struct Seenum *));
-#endif /* ! __GNUC__ */
-
-#define gefrom(xyzxyz) (*Rgefrom((struct Seenum *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgestep PROTO((struct Seenum *));
-
-extern __inline__ list *Rgestep(struct Seenum *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != eenum)
- fprintf(stderr,"gestep: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgestep);
-}
-#else /* ! __GNUC__ */
-extern list *Rgestep PROTO((struct Seenum *));
-#endif /* ! __GNUC__ */
-
-#define gestep(xyzxyz) (*Rgestep((struct Seenum *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgeto PROTO((struct Seenum *));
-
-extern __inline__ list *Rgeto(struct Seenum *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != eenum)
- fprintf(stderr,"geto: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgeto);
-}
-#else /* ! __GNUC__ */
-extern list *Rgeto PROTO((struct Seenum *));
-#endif /* ! __GNUC__ */
-
-#define geto(xyzxyz) (*Rgeto((struct Seenum *) (xyzxyz)))
-
-extern tree mkllist PROTO((list));
-#ifdef __GNUC__
-
-list *Rgllist PROTO((struct Sllist *));
-
-extern __inline__ list *Rgllist(struct Sllist *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != llist)
- fprintf(stderr,"gllist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgllist);
-}
-#else /* ! __GNUC__ */
-extern list *Rgllist PROTO((struct Sllist *));
-#endif /* ! __GNUC__ */
-
-#define gllist(xyzxyz) (*Rgllist((struct Sllist *) (xyzxyz)))
-
-extern tree mkccall PROTO((stringId, stringId, list));
-#ifdef __GNUC__
-
-stringId *Rgccid PROTO((struct Sccall *));
-
-extern __inline__ stringId *Rgccid(struct Sccall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ccall)
- fprintf(stderr,"gccid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgccid);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgccid PROTO((struct Sccall *));
-#endif /* ! __GNUC__ */
-
-#define gccid(xyzxyz) (*Rgccid((struct Sccall *) (xyzxyz)))
-#ifdef __GNUC__
-
-stringId *Rgccinfo PROTO((struct Sccall *));
-
-extern __inline__ stringId *Rgccinfo(struct Sccall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ccall)
- fprintf(stderr,"gccinfo: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgccinfo);
-}
-#else /* ! __GNUC__ */
-extern stringId *Rgccinfo PROTO((struct Sccall *));
-#endif /* ! __GNUC__ */
-
-#define gccinfo(xyzxyz) (*Rgccinfo((struct Sccall *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgccargs PROTO((struct Sccall *));
-
-extern __inline__ list *Rgccargs(struct Sccall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ccall)
- fprintf(stderr,"gccargs: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgccargs);
-}
-#else /* ! __GNUC__ */
-extern list *Rgccargs PROTO((struct Sccall *));
-#endif /* ! __GNUC__ */
-
-#define gccargs(xyzxyz) (*Rgccargs((struct Sccall *) (xyzxyz)))
-
-extern tree mkscc PROTO((hstring, tree));
-#ifdef __GNUC__
-
-hstring *Rgsccid PROTO((struct Sscc *));
-
-extern __inline__ hstring *Rgsccid(struct Sscc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != scc)
- fprintf(stderr,"gsccid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsccid);
-}
-#else /* ! __GNUC__ */
-extern hstring *Rgsccid PROTO((struct Sscc *));
-#endif /* ! __GNUC__ */
-
-#define gsccid(xyzxyz) (*Rgsccid((struct Sscc *) (xyzxyz)))
-#ifdef __GNUC__
-
-tree *Rgsccexp PROTO((struct Sscc *));
-
-extern __inline__ tree *Rgsccexp(struct Sscc *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != scc)
- fprintf(stderr,"gsccexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgsccexp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgsccexp PROTO((struct Sscc *));
-#endif /* ! __GNUC__ */
-
-#define gsccexp(xyzxyz) (*Rgsccexp((struct Sscc *) (xyzxyz)))
-
-extern tree mknegate PROTO((tree));
-#ifdef __GNUC__
-
-tree *Rgnexp PROTO((struct Snegate *));
-
-extern __inline__ tree *Rgnexp(struct Snegate *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != negate)
- fprintf(stderr,"gnexp: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnexp);
-}
-#else /* ! __GNUC__ */
-extern tree *Rgnexp PROTO((struct Snegate *));
-#endif /* ! __GNUC__ */
-
-#define gnexp(xyzxyz) (*Rgnexp((struct Snegate *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_tree where
-import UgenUtil
-import Util
-
-import U_binding
-import U_coresyn ( U_coresyn ) -- interface only
-import U_hpragma ( U_hpragma ) -- interface only
-import U_list
-import U_literal
-import U_ttype
-
-type U_infixTree = (ProtoName, U_tree, U_tree)
-
-rdU_infixTree :: _Addr -> UgnM U_infixTree
-rdU_infixTree pt
- = ioToUgnM (_casm_ ``%r = gident(*Rginfun_hs((struct Sap *)%0));'' pt) `thenUgn` \ op_t ->
- ioToUgnM (_casm_ ``%r = (*Rginarg1_hs((struct Sap *)%0));'' pt) `thenUgn` \ arg1_t ->
- ioToUgnM (_casm_ ``%r = (*Rginarg2_hs((struct Sap *)%0));'' pt) `thenUgn` \ arg2_t ->
-
- rdU_unkId op_t `thenUgn` \ op ->
- rdU_tree arg1_t `thenUgn` \ arg1 ->
- rdU_tree arg2_t `thenUgn` \ arg2 ->
- returnUgn (op, arg1, arg2)
-%}}
-type tree;
- hmodule : < ghname : stringId;
- ghimplist : list;
- ghexplist : list;
- ghmodlist : binding;
- ghmodline : long; >;
- ident : < gident : unkId; >;
- lit : < glit : literal; >;
- tuple : < gtuplelist : list; >;
- ap : < gfun : tree;
- garg : tree; >;
- lambda : < glampats : list;
- glamexpr : tree;
- glamline : long; >;
- let : < gletvdeflist : binding;
- gletvexpr : tree; >;
- casee : < gcaseexpr : tree;
- gcasebody : list; >;
- ife : < gifpred : tree;
- gifthen : tree;
- gifelse : tree; >;
- par : < gpare : tree; >;
- as : < gasid : unkId;
- gase : tree; >;
- lazyp : < glazyp : tree; >;
- plusp : < gplusp : tree;
- gplusi : literal; >;
- wildp : < >;
- restr : < grestre : tree;
- grestrt : ttype; >;
- comprh : < gcexp : tree;
- gcquals : list; >;
- qual : < gqpat : tree;
- gqexp : tree; >;
- guard : < ggexp : tree; >;
- def : < ggdef : tree; >; /* unused, I believe WDP 95/08 */
-/* "tinfixop" is an odd bird:
- we clobber its tag into another "tree", thus marking
- that tree as infixery. We do not create tinfixops
- per se. (WDP 95/08)
-*/
- tinfixop: < gdummy : infixTree; >;
- lsection: < glsexp : tree;
- glsop : unkId; >;
- rsection: < grsop : unkId;
- grsexp : tree; >;
- eenum : < gefrom : tree;
- gestep : list;
- geto : list; >;
- llist : < gllist : list; >;
- ccall : < gccid : stringId;
- gccinfo : stringId;
- gccargs : list; >;
- scc : < gsccid : hstring;
- gsccexp : tree; >;
- negate : < gnexp : tree; >;
-end;
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_ttype where
-import UgenUtil
-import Util
-%}}
-type ttype;
- tname : < gtypeid : id;
- gtypel : list; >;
- namedtvar : < gnamedtvar : id; >;
- tllist : < gtlist : ttype; >;
- ttuple : < gttuple : list; >;
- tfun : < gtfun : ttype;
- gtarg : ttype; >;
- context : < gtcontextl : list;
- gtcontextt : ttype; >;
- tproc : < gtpid : list;
- gtdata : ttype; >;
- tpod : < gtpod : ttype; >;
-end;
-
+++ /dev/null
-
-
-#include "hspincl.h"
-#include "yaccParser/ttype.h"
-
-Tttype tttype(t)
- ttype t;
-{
- return(t -> tag);
-}
-
-
-/************** tname ******************/
-
-ttype mktname(PPgtypeid, PPgtypel)
- unkId PPgtypeid;
- list PPgtypel;
-{
- register struct Stname *pp =
- (struct Stname *) malloc(sizeof(struct Stname));
- pp -> tag = tname;
- pp -> Xgtypeid = PPgtypeid;
- pp -> Xgtypel = PPgtypel;
- return((ttype)pp);
-}
-
-unkId *Rgtypeid(t)
- struct Stname *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tname)
- fprintf(stderr,"gtypeid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtypeid);
-}
-
-list *Rgtypel(t)
- struct Stname *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tname)
- fprintf(stderr,"gtypel: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtypel);
-}
-
-/************** namedtvar ******************/
-
-ttype mknamedtvar(PPgnamedtvar)
- unkId PPgnamedtvar;
-{
- register struct Snamedtvar *pp =
- (struct Snamedtvar *) malloc(sizeof(struct Snamedtvar));
- pp -> tag = namedtvar;
- pp -> Xgnamedtvar = PPgnamedtvar;
- return((ttype)pp);
-}
-
-unkId *Rgnamedtvar(t)
- struct Snamedtvar *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != namedtvar)
- fprintf(stderr,"gnamedtvar: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnamedtvar);
-}
-
-/************** tllist ******************/
-
-ttype mktllist(PPgtlist)
- ttype PPgtlist;
-{
- register struct Stllist *pp =
- (struct Stllist *) malloc(sizeof(struct Stllist));
- pp -> tag = tllist;
- pp -> Xgtlist = PPgtlist;
- return((ttype)pp);
-}
-
-ttype *Rgtlist(t)
- struct Stllist *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tllist)
- fprintf(stderr,"gtlist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtlist);
-}
-
-/************** ttuple ******************/
-
-ttype mkttuple(PPgttuple)
- list PPgttuple;
-{
- register struct Sttuple *pp =
- (struct Sttuple *) malloc(sizeof(struct Sttuple));
- pp -> tag = ttuple;
- pp -> Xgttuple = PPgttuple;
- return((ttype)pp);
-}
-
-list *Rgttuple(t)
- struct Sttuple *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ttuple)
- fprintf(stderr,"gttuple: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgttuple);
-}
-
-/************** tfun ******************/
-
-ttype mktfun(PPgtfun, PPgtarg)
- ttype PPgtfun;
- ttype PPgtarg;
-{
- register struct Stfun *pp =
- (struct Stfun *) malloc(sizeof(struct Stfun));
- pp -> tag = tfun;
- pp -> Xgtfun = PPgtfun;
- pp -> Xgtarg = PPgtarg;
- return((ttype)pp);
-}
-
-ttype *Rgtfun(t)
- struct Stfun *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tfun)
- fprintf(stderr,"gtfun: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtfun);
-}
-
-ttype *Rgtarg(t)
- struct Stfun *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tfun)
- fprintf(stderr,"gtarg: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtarg);
-}
-
-/************** context ******************/
-
-ttype mkcontext(PPgtcontextl, PPgtcontextt)
- list PPgtcontextl;
- ttype PPgtcontextt;
-{
- register struct Scontext *pp =
- (struct Scontext *) malloc(sizeof(struct Scontext));
- pp -> tag = context;
- pp -> Xgtcontextl = PPgtcontextl;
- pp -> Xgtcontextt = PPgtcontextt;
- return((ttype)pp);
-}
-
-list *Rgtcontextl(t)
- struct Scontext *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != context)
- fprintf(stderr,"gtcontextl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtcontextl);
-}
-
-ttype *Rgtcontextt(t)
- struct Scontext *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != context)
- fprintf(stderr,"gtcontextt: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtcontextt);
-}
-
-/************** unidict ******************/
-
-ttype mkunidict(PPgunidict_clas, PPgunidict_ty)
- unkId PPgunidict_clas;
- ttype PPgunidict_ty;
-{
- register struct Sunidict *pp =
- (struct Sunidict *) malloc(sizeof(struct Sunidict));
- pp -> tag = unidict;
- pp -> Xgunidict_clas = PPgunidict_clas;
- pp -> Xgunidict_ty = PPgunidict_ty;
- return((ttype)pp);
-}
-
-unkId *Rgunidict_clas(t)
- struct Sunidict *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != unidict)
- fprintf(stderr,"gunidict_clas: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgunidict_clas);
-}
-
-ttype *Rgunidict_ty(t)
- struct Sunidict *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != unidict)
- fprintf(stderr,"gunidict_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgunidict_ty);
-}
-
-/************** unityvartemplate ******************/
-
-ttype mkunityvartemplate(PPgunityvartemplate)
- unkId PPgunityvartemplate;
-{
- register struct Sunityvartemplate *pp =
- (struct Sunityvartemplate *) malloc(sizeof(struct Sunityvartemplate));
- pp -> tag = unityvartemplate;
- pp -> Xgunityvartemplate = PPgunityvartemplate;
- return((ttype)pp);
-}
-
-unkId *Rgunityvartemplate(t)
- struct Sunityvartemplate *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != unityvartemplate)
- fprintf(stderr,"gunityvartemplate: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgunityvartemplate);
-}
-
-/************** uniforall ******************/
-
-ttype mkuniforall(PPguniforall_tv, PPguniforall_ty)
- list PPguniforall_tv;
- ttype PPguniforall_ty;
-{
- register struct Suniforall *pp =
- (struct Suniforall *) malloc(sizeof(struct Suniforall));
- pp -> tag = uniforall;
- pp -> Xguniforall_tv = PPguniforall_tv;
- pp -> Xguniforall_ty = PPguniforall_ty;
- return((ttype)pp);
-}
-
-list *Rguniforall_tv(t)
- struct Suniforall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != uniforall)
- fprintf(stderr,"guniforall_tv: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xguniforall_tv);
-}
-
-ttype *Rguniforall_ty(t)
- struct Suniforall *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != uniforall)
- fprintf(stderr,"guniforall_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xguniforall_ty);
-}
-
-/************** ty_maybe_nothing ******************/
-
-ttype mkty_maybe_nothing(void)
-{
- register struct Sty_maybe_nothing *pp =
- (struct Sty_maybe_nothing *) malloc(sizeof(struct Sty_maybe_nothing));
- pp -> tag = ty_maybe_nothing;
- return((ttype)pp);
-}
-
-/************** ty_maybe_just ******************/
-
-ttype mkty_maybe_just(PPgty_maybe)
- ttype PPgty_maybe;
-{
- register struct Sty_maybe_just *pp =
- (struct Sty_maybe_just *) malloc(sizeof(struct Sty_maybe_just));
- pp -> tag = ty_maybe_just;
- pp -> Xgty_maybe = PPgty_maybe;
- return((ttype)pp);
-}
-
-ttype *Rgty_maybe(t)
- struct Sty_maybe_just *t;
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ty_maybe_just)
- fprintf(stderr,"gty_maybe: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgty_maybe);
-}
+++ /dev/null
-#ifndef ttype_defined
-#define ttype_defined
-
-#include <stdio.h>
-
-#ifndef PROTO
-#ifdef __STDC__
-#define PROTO(x) x
-#else
-#define PROTO(x) /**/
-#endif
-#endif
-
-typedef enum {
- tname,
- namedtvar,
- tllist,
- ttuple,
- tfun,
- context,
- unidict,
- unityvartemplate,
- uniforall,
- ty_maybe_nothing,
- ty_maybe_just
-} Tttype;
-
-typedef struct { Tttype tag; } *ttype;
-
-#ifdef __GNUC__
-Tttype tttype(ttype t);
-extern __inline__ Tttype tttype(ttype t)
-{
- return(t -> tag);
-}
-#else /* ! __GNUC__ */
-extern Tttype tttype PROTO((ttype));
-#endif /* ! __GNUC__ */
-
-struct Stname {
- Tttype tag;
- unkId Xgtypeid;
- list Xgtypel;
-};
-
-struct Snamedtvar {
- Tttype tag;
- unkId Xgnamedtvar;
-};
-
-struct Stllist {
- Tttype tag;
- ttype Xgtlist;
-};
-
-struct Sttuple {
- Tttype tag;
- list Xgttuple;
-};
-
-struct Stfun {
- Tttype tag;
- ttype Xgtfun;
- ttype Xgtarg;
-};
-
-struct Scontext {
- Tttype tag;
- list Xgtcontextl;
- ttype Xgtcontextt;
-};
-
-struct Sunidict {
- Tttype tag;
- unkId Xgunidict_clas;
- ttype Xgunidict_ty;
-};
-
-struct Sunityvartemplate {
- Tttype tag;
- unkId Xgunityvartemplate;
-};
-
-struct Suniforall {
- Tttype tag;
- list Xguniforall_tv;
- ttype Xguniforall_ty;
-};
-
-struct Sty_maybe_nothing {
- Tttype tag;
-};
-
-struct Sty_maybe_just {
- Tttype tag;
- ttype Xgty_maybe;
-};
-
-extern ttype mktname PROTO((unkId, list));
-#ifdef __GNUC__
-
-unkId *Rgtypeid PROTO((struct Stname *));
-
-extern __inline__ unkId *Rgtypeid(struct Stname *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tname)
- fprintf(stderr,"gtypeid: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtypeid);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgtypeid PROTO((struct Stname *));
-#endif /* ! __GNUC__ */
-
-#define gtypeid(xyzxyz) (*Rgtypeid((struct Stname *) (xyzxyz)))
-#ifdef __GNUC__
-
-list *Rgtypel PROTO((struct Stname *));
-
-extern __inline__ list *Rgtypel(struct Stname *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tname)
- fprintf(stderr,"gtypel: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtypel);
-}
-#else /* ! __GNUC__ */
-extern list *Rgtypel PROTO((struct Stname *));
-#endif /* ! __GNUC__ */
-
-#define gtypel(xyzxyz) (*Rgtypel((struct Stname *) (xyzxyz)))
-
-extern ttype mknamedtvar PROTO((unkId));
-#ifdef __GNUC__
-
-unkId *Rgnamedtvar PROTO((struct Snamedtvar *));
-
-extern __inline__ unkId *Rgnamedtvar(struct Snamedtvar *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != namedtvar)
- fprintf(stderr,"gnamedtvar: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgnamedtvar);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgnamedtvar PROTO((struct Snamedtvar *));
-#endif /* ! __GNUC__ */
-
-#define gnamedtvar(xyzxyz) (*Rgnamedtvar((struct Snamedtvar *) (xyzxyz)))
-
-extern ttype mktllist PROTO((ttype));
-#ifdef __GNUC__
-
-ttype *Rgtlist PROTO((struct Stllist *));
-
-extern __inline__ ttype *Rgtlist(struct Stllist *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tllist)
- fprintf(stderr,"gtlist: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtlist);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgtlist PROTO((struct Stllist *));
-#endif /* ! __GNUC__ */
-
-#define gtlist(xyzxyz) (*Rgtlist((struct Stllist *) (xyzxyz)))
-
-extern ttype mkttuple PROTO((list));
-#ifdef __GNUC__
-
-list *Rgttuple PROTO((struct Sttuple *));
-
-extern __inline__ list *Rgttuple(struct Sttuple *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ttuple)
- fprintf(stderr,"gttuple: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgttuple);
-}
-#else /* ! __GNUC__ */
-extern list *Rgttuple PROTO((struct Sttuple *));
-#endif /* ! __GNUC__ */
-
-#define gttuple(xyzxyz) (*Rgttuple((struct Sttuple *) (xyzxyz)))
-
-extern ttype mktfun PROTO((ttype, ttype));
-#ifdef __GNUC__
-
-ttype *Rgtfun PROTO((struct Stfun *));
-
-extern __inline__ ttype *Rgtfun(struct Stfun *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tfun)
- fprintf(stderr,"gtfun: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtfun);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgtfun PROTO((struct Stfun *));
-#endif /* ! __GNUC__ */
-
-#define gtfun(xyzxyz) (*Rgtfun((struct Stfun *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgtarg PROTO((struct Stfun *));
-
-extern __inline__ ttype *Rgtarg(struct Stfun *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != tfun)
- fprintf(stderr,"gtarg: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtarg);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgtarg PROTO((struct Stfun *));
-#endif /* ! __GNUC__ */
-
-#define gtarg(xyzxyz) (*Rgtarg((struct Stfun *) (xyzxyz)))
-
-extern ttype mkcontext PROTO((list, ttype));
-#ifdef __GNUC__
-
-list *Rgtcontextl PROTO((struct Scontext *));
-
-extern __inline__ list *Rgtcontextl(struct Scontext *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != context)
- fprintf(stderr,"gtcontextl: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtcontextl);
-}
-#else /* ! __GNUC__ */
-extern list *Rgtcontextl PROTO((struct Scontext *));
-#endif /* ! __GNUC__ */
-
-#define gtcontextl(xyzxyz) (*Rgtcontextl((struct Scontext *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgtcontextt PROTO((struct Scontext *));
-
-extern __inline__ ttype *Rgtcontextt(struct Scontext *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != context)
- fprintf(stderr,"gtcontextt: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgtcontextt);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgtcontextt PROTO((struct Scontext *));
-#endif /* ! __GNUC__ */
-
-#define gtcontextt(xyzxyz) (*Rgtcontextt((struct Scontext *) (xyzxyz)))
-
-extern ttype mkunidict PROTO((unkId, ttype));
-#ifdef __GNUC__
-
-unkId *Rgunidict_clas PROTO((struct Sunidict *));
-
-extern __inline__ unkId *Rgunidict_clas(struct Sunidict *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != unidict)
- fprintf(stderr,"gunidict_clas: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgunidict_clas);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgunidict_clas PROTO((struct Sunidict *));
-#endif /* ! __GNUC__ */
-
-#define gunidict_clas(xyzxyz) (*Rgunidict_clas((struct Sunidict *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rgunidict_ty PROTO((struct Sunidict *));
-
-extern __inline__ ttype *Rgunidict_ty(struct Sunidict *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != unidict)
- fprintf(stderr,"gunidict_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgunidict_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgunidict_ty PROTO((struct Sunidict *));
-#endif /* ! __GNUC__ */
-
-#define gunidict_ty(xyzxyz) (*Rgunidict_ty((struct Sunidict *) (xyzxyz)))
-
-extern ttype mkunityvartemplate PROTO((unkId));
-#ifdef __GNUC__
-
-unkId *Rgunityvartemplate PROTO((struct Sunityvartemplate *));
-
-extern __inline__ unkId *Rgunityvartemplate(struct Sunityvartemplate *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != unityvartemplate)
- fprintf(stderr,"gunityvartemplate: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgunityvartemplate);
-}
-#else /* ! __GNUC__ */
-extern unkId *Rgunityvartemplate PROTO((struct Sunityvartemplate *));
-#endif /* ! __GNUC__ */
-
-#define gunityvartemplate(xyzxyz) (*Rgunityvartemplate((struct Sunityvartemplate *) (xyzxyz)))
-
-extern ttype mkuniforall PROTO((list, ttype));
-#ifdef __GNUC__
-
-list *Rguniforall_tv PROTO((struct Suniforall *));
-
-extern __inline__ list *Rguniforall_tv(struct Suniforall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != uniforall)
- fprintf(stderr,"guniforall_tv: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xguniforall_tv);
-}
-#else /* ! __GNUC__ */
-extern list *Rguniforall_tv PROTO((struct Suniforall *));
-#endif /* ! __GNUC__ */
-
-#define guniforall_tv(xyzxyz) (*Rguniforall_tv((struct Suniforall *) (xyzxyz)))
-#ifdef __GNUC__
-
-ttype *Rguniforall_ty PROTO((struct Suniforall *));
-
-extern __inline__ ttype *Rguniforall_ty(struct Suniforall *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != uniforall)
- fprintf(stderr,"guniforall_ty: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xguniforall_ty);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rguniforall_ty PROTO((struct Suniforall *));
-#endif /* ! __GNUC__ */
-
-#define guniforall_ty(xyzxyz) (*Rguniforall_ty((struct Suniforall *) (xyzxyz)))
-
-extern ttype mkty_maybe_nothing PROTO((void));
-
-extern ttype mkty_maybe_just PROTO((ttype));
-#ifdef __GNUC__
-
-ttype *Rgty_maybe PROTO((struct Sty_maybe_just *));
-
-extern __inline__ ttype *Rgty_maybe(struct Sty_maybe_just *t)
-{
-#ifdef UGEN_DEBUG
- if(t -> tag != ty_maybe_just)
- fprintf(stderr,"gty_maybe: illegal selection; was %d\n", t -> tag);
-#endif /* UGEN_DEBUG */
- return(& t -> Xgty_maybe);
-}
-#else /* ! __GNUC__ */
-extern ttype *Rgty_maybe PROTO((struct Sty_maybe_just *));
-#endif /* ! __GNUC__ */
-
-#define gty_maybe(xyzxyz) (*Rgty_maybe((struct Sty_maybe_just *) (xyzxyz)))
-
-#endif
+++ /dev/null
-%{
-#include "hspincl.h"
-%}
-%{{
-module U_ttype where
-import UgenUtil
-import Util
-
-import U_list
-%}}
-type ttype;
- tname : < gtypeid : unkId;
- gtypel : list; >;
- namedtvar : < gnamedtvar : unkId; >;
- tllist : < gtlist : ttype; >;
- ttuple : < gttuple : list; >;
- tfun : < gtfun : ttype;
- gtarg : ttype; >;
- context : < gtcontextl : list;
- gtcontextt : ttype; >;
-
- unidict : < gunidict_clas : unkId;
- gunidict_ty : ttype; >;
- unityvartemplate: <gunityvartemplate : unkId; >;
- uniforall : < guniforall_tv : list;
- guniforall_ty : ttype; >;
-
- ty_maybe_nothing : < >;
- ty_maybe_just : < gty_maybe : ttype; >;
-end;
-
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Convert Types to Contexts *
-* *
-* *
-**********************************************************************/
-
-
-#include <stdio.h>
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-/* Imported Values */
-extern list Lnil;
-
-static void is_context_format PROTO((ttype)); /* forward */
-
-/*
- partain: see also the comment by "decl" in hsparser.y.
-
- Here, we've been given a type that must be of the form
- "C a" or "(C1 a, C2 a, ...)" [otherwise an error]
-
- Convert it to a list.
-*/
-
-
-list
-type2context(t)
- ttype t;
-{
- char *tycon_name;
- list args, rest_args;
- ttype first_arg;
-
- switch (tttype(t)) {
- case ttuple:
- /* returning the list is OK, but ensure items are right format */
- args = gttuple(t);
-
- if (tlist(args) == lnil)
- hsperror ("type2context: () found instead of a context");
-
- while (tlist(args) != lnil)
- {
- is_context_format(lhd(args));
- args = ltl(args);
- }
-
- return(gttuple(t)); /* args */
-
-
- case tname :
- tycon_name = gtypeid(t);
-
- /* just a class name ":: C =>" */
- if (tlist(gtypel(t)) == lnil)
- return (mklcons(t, Lnil));
-
- /* should be just: ":: C a =>" */
- else
- {
- first_arg = (ttype) lhd(gtypel(t));
- rest_args = ltl(gtypel(t)); /* should be nil */
-
- if (tlist(rest_args) != lnil)
- hsperror ("type2context: too many variables after class name");
-
- switch (tttype(first_arg))
- {
- case namedtvar: /* ToDo: right? */
- return (mklcons(t, Lnil));
- break;
-
- default:
- hsperror ("type2context: something wrong with variable after class name");
- }
- }
- break;
-
- case namedtvar:
- hsperror ("type2context: unexpected namedtvar found in a context");
-
- case tllist:
- hsperror ("type2context: list constructor found in a context");
-
- case tfun:
- hsperror ("type2context: arrow (->) constructor found in a context");
-
- case context:
- hsperror ("type2context: unexpected context-thing found in a context");
-
- default :
- hsperror ("type2context: totally unexpected input");
- }
- abort(); /* should never get here! */
-}
-
-
-/* is_context_format is the same as "type2context" except that it just performs checking */
-/* ttype is either "tycon" [class] or "tycon (named)tvar" [class var] */
-
-static void
-is_context_format(t)
- ttype t;
-{
- char *tycon_name;
- list rest_args;
- ttype first_arg;
-
- switch (tttype(t))
- {
- case tname :
- tycon_name = gtypeid(t);
-
- /* just a class name ":: C =>" */
- if (tlist(gtypel(t)) == lnil)
- hsperror("is_context_format: variable missing after class name");
-
- /* should be just: ":: C a =>" */
- else
- {
- first_arg = (ttype) lhd(gtypel(t));
- rest_args = ltl(gtypel(t)); /* should be nil */
- if (tlist(rest_args) != lnil)
- hsperror ("is_context_format: too many variables after class name");
-
- switch (tttype(first_arg))
- {
- case namedtvar: /* ToDo: right? */
- /* everything is cool; will fall off the end */
- break;
- default:
- hsperror ("is_context_format: something wrong with variable after class name");
- }
- }
- break;
-
- case ttuple:
- hsperror ("is_context_format: tuple found in a context");
-
- case namedtvar:
- hsperror ("is_context_format: unexpected namedtvar found in a context");
-
- case tllist:
- hsperror ("is_context_format: list constructor found in a context");
-
- case tfun:
- hsperror ("is_context_format: arrow (->) constructor found in a context");
-
- case context:
- hsperror ("is_context_format: unexpected context-thing found in a context");
-
- default:
- hsperror ("is_context_format: totally unexpected input");
- }
-}
-
+++ /dev/null
-/**********************************************************************
-* *
-* *
-* Declarations *
-* *
-* *
-**********************************************************************/
-
-#include "hspincl.h"
-#include "constants.h"
-#include "utils.h"
-
-#define PARSER_VERSION "0.27"
-
-tree root; /* The root of the built syntax tree. */
-list Lnil;
-list all;
-
-BOOLEAN nonstandardFlag = FALSE; /* Set if non-std Haskell extensions to be used. */
-BOOLEAN acceptPrim = FALSE; /* Set if Int#, etc., may be used */
-BOOLEAN haskell1_3Flag = FALSE; /* Set if we are doing (proto?) Haskell 1.3 */
-BOOLEAN etags = FALSE; /* Set if we're parsing only to produce tags. */
-BOOLEAN hashIds = FALSE; /* Set if Identifiers should be hashed. */
-
-BOOLEAN ignoreSCC = TRUE; /* Set if we ignore/filter scc expressions. */
-BOOLEAN warnSCC = FALSE; /* Set if we warn about ignored scc expressions. */
-
-BOOLEAN implicitPrelude = TRUE; /* Set if we implicitly import the Prelude. */
-BOOLEAN ignorePragmas = FALSE; /* Set if we want to ignore pragmas */
-
-/* From time to time, the format of interface files may change.
-
- So that we don't get gratuitous syntax errors or silently slurp in
- junk info, two things: (a) the compiler injects a "this is a
- version N interface":
-
- {-# GHC_PRAGMA INTERFACE VERSION <n> #-}
-
- (b) this parser has a "minimum acceptable version", below which it
- refuses to parse the pragmas (it just considers them as comments).
- It also has a "maximum acceptable version", above which...
-
- The minimum is so a new parser won't try to grok overly-old
- interfaces; the maximum (usually the current version number when
- the parser was released) is so an old parser will not try to grok
- since-upgraded interfaces.
-
- If an interface has no INTERFACE VERSION line, it is taken to be
- version 0.
-*/
-int minAcceptablePragmaVersion = 5; /* 0.26 or greater ONLY */
-int maxAcceptablePragmaVersion = 6; /* 0.28+ */
-int thisIfacePragmaVersion = 0;
-
-static char *input_file_dir; /* The directory where the input file is. */
-
-char HiSuffix[64] = ".hi"; /* can be changed with -h flag */
-char PreludeHiSuffix[64] = ".hi"; /* can be changed with -g flag */
-
-/* OLD 95/08: BOOLEAN ExplicitHiSuffixGiven = 0; */
-static BOOLEAN verbose = FALSE; /* Set for verbose messages. */
-
-/* Forward decls */
-static void who_am_i PROTO((void));
-
-/**********************************************************************
-* *
-* *
-* Utility Functions *
-* *
-* *
-**********************************************************************/
-
-# include <stdio.h>
-# include "constants.h"
-# include "hspincl.h"
-# include "utils.h"
-
-void
-process_args(argc,argv)
- int argc;
- char **argv;
-{
- BOOLEAN keep_munging_option = FALSE;
-
-/*OLD: progname = argv[0]; */
- imports_dirlist = mklnil();
- sys_imports_dirlist = mklnil();
-
- argc--, argv++;
-
- while (argc && argv[0][0] == '-') {
-
- keep_munging_option = TRUE;
-
- while (keep_munging_option && *++*argv != '\0') {
- switch(**argv) {
-
- /* -I dir */
- case 'I':
- imports_dirlist = lapp(imports_dirlist,*argv+1);
- keep_munging_option = FALSE;
- break;
-
- /* -J dir (for system imports) */
- case 'J':
- sys_imports_dirlist = lapp(sys_imports_dirlist,*argv+1);
- keep_munging_option = FALSE;
- break;
-
- case 'g':
- strcpy(PreludeHiSuffix, *argv+1);
- keep_munging_option = FALSE;
- break;
-
- case 'h':
- strcpy(HiSuffix, *argv+1);
-/*OLD 95/08: ExplicitHiSuffixGiven = 1; */
- keep_munging_option = FALSE;
- break;
-
- case 'v':
- who_am_i(); /* identify myself */
- verbose = TRUE;
- break;
-
- case 'N':
- nonstandardFlag = TRUE;
- acceptPrim = TRUE;
- break;
-
- case '3':
- haskell1_3Flag = TRUE;
- break;
-
- case 'S':
- ignoreSCC = FALSE;
- break;
-
- case 'W':
- warnSCC = TRUE;
- break;
-
- case 'p':
- ignorePragmas = TRUE;
- break;
-
- case 'P':
- implicitPrelude = FALSE;
- break;
-
- case 'D':
-#ifdef HSP_DEBUG
- { extern int yydebug;
- yydebug = 1;
- }
-#endif
- break;
-
- /* -Hn -- Use Hash Table, Size n (if given) */
- case 'H':
- hashIds = TRUE;
- if(*(*argv+1)!= '\0')
- hash_table_size = atoi(*argv+1);
- break;
- case 'E':
- etags = TRUE;
- break;
- }
- }
- argc--, argv++;
- }
-
- if(argc >= 1 && freopen(argv[0], "r", stdin) == NULL) {
- fprintf(stderr, "Cannot open %s.\n", argv[0]);
- exit(1);
- }
-
- if(argc >= 2 && freopen(argv[1], "w", stdout) == NULL) {
- fprintf(stderr, "Cannot open %s.\n", argv[1]);
- exit(1);
- }
-
-
- /* By default, imports come from the directory of the source file */
- if ( argc >= 1 )
- {
- char *endchar;
-
- input_file_dir = xmalloc (strlen(argv[0]) + 1);
- strcpy(input_file_dir, argv[0]);
-#ifdef macintosh
- endchar = rindex(input_file_dir, (int) ':');
-#else
- endchar = rindex(input_file_dir, (int) '/');
-#endif /* ! macintosh */
-
- if ( endchar == NULL )
- {
- free(input_file_dir);
- input_file_dir = ".";
- }
- else
- *endchar = '\0';
- }
-
- /* No input file -- imports come from the current directory first */
- else
- input_file_dir = ".";
-
- imports_dirlist = mklcons( input_file_dir, imports_dirlist );
-
- if (verbose)
- {
- fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size);
- if(acceptPrim)
- fprintf(stderr,"Allowing special syntax for Unboxed Values\n");
- }
-}
-
-void
-error(s)
- char *s;
-{
-/*OLD: fprintf(stderr, "%s: Error %s\n", progname, s); */
- fprintf(stderr, "PARSER: Error %s\n", s);
- exit(1);
-}
-
-static void
-who_am_i(void)
-{
- fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION);
-}
-
-tree
-mkbinop(s, l, r)
- char *s;
- tree l, r;
-{
- return mkap(mkap(mkident(s), l), r);
-}
-
-list
-lconc(l1, l2)
- list l1;
- list l2;
-{
- list t;
-
- if (tlist(l1) == lnil)
- return(l2);
- for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
- ;
- ltl(t) = l2;
- return(l1);
-}
-
-list
-lapp(list l1, VOID_STAR l2)
-{
- list t;
-
- if (tlist(l1) == lnil)
- return(mklcons(l2, mklnil()));
- for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
- ;
- ltl(t) = mklcons(l2, mklnil());
- return(l1);
-}
-
-
-/************** Haskell Infix ops, built on mkap ******************/
-
-tree mkinfixop(s, l, r)
- char *s;
- tree l, r;
-{
- tree ap = mkap(mkap(mkident(s), l), r);
- ap -> tag = tinfixop;
- return ap;
-}
-
-tree *
-Rginfun(t)
- struct Sap *t;
-{
- if(t -> tag != tinfixop)
- fprintf(stderr, "ginfun: illegal selection; was %d\n", t -> tag);
- return(Rgfun((struct Sap *) (t -> Xgfun)));
-}
-
-tree *
-Rginarg1(t)
- struct Sap *t;
-{
- if(t -> tag != tinfixop)
- fprintf(stderr, "ginarg1: illegal selection; was %d\n", t -> tag);
- return(Rgarg((struct Sap *) (t -> Xgfun)));
-}
-
-tree *
-Rginarg2(t)
- struct Sap *t;
-{
- if(t -> tag != tinfixop)
- fprintf(stderr, "ginarg2: illegal selection; was %d\n", t -> tag);
- return(& t -> Xgarg);
-}
+++ /dev/null
-/*
- Utility Definitions.
-*/
-
-#ifndef __UTILS_H
-#define __UTILS_H
-
-/* stuff from util.c */
-extern tree root;
-extern list Lnil;
-extern list all;
-
-extern BOOLEAN nonstandardFlag;
-extern BOOLEAN hashIds;
-extern BOOLEAN acceptPrim;
-extern BOOLEAN etags;
-
-extern BOOLEAN ignoreSCC;
-extern BOOLEAN warnSCC;
-
-extern BOOLEAN implicitPrelude;
-extern BOOLEAN ignorePragmas;
-
-extern int minAcceptablePragmaVersion;
-extern int maxAcceptablePragmaVersion;
-extern int thisIfacePragmaVersion;
-
-extern unsigned hash_table_size;
-extern char *input_file_dir;
-
-extern list imports_dirlist;
-extern list sys_imports_dirlist;
-
-extern char HiSuffix[];
-extern char PreludeHiSuffix[];
-
-void process_args PROTO((int, char **));
-
-/* end of util.c stuff */
-
-list mklcons PROTO((void *h, list t)); /* if we have PROTO, we have "void *" */
-list lapp PROTO((list l1, void *l2));
-list lconc PROTO((list l1, list l2));
-list mktruecase PROTO((tree t));
-
-#define lsing(l) mklcons(l, Lnil) /* Singleton Lists */
-#define ldub(l1, l2) mklcons(l1, lsing(l2)) /* Two-element Lists */
-
-#define FN fns[icontexts]
-#define SAMEFN samefn[icontexts]
-#define PREVPATT prevpatt[icontexts]
-
-tree *Rginfun PROTO((struct Sap *));
-tree *Rginarg1 PROTO((struct Sap *));
-tree *Rginarg2 PROTO((struct Sap *));
-
-#define ginfun(xx) *Rginfun(xx)
-#define ginarg1(xx) *Rginarg1(xx)
-#define ginarg2(xx) *Rginarg2(xx)
-
-id installid PROTO((char *)); /* Create a new identifier */
-hstring installHstring PROTO((int, char *)); /* Create a new literal string */
-
-id install_literal PROTO((char *));
-char *id_to_string PROTO((id));
-
-struct infix *infixlookup PROTO((id));
-
-/* partain additions */
-
-char *xmalloc PROTO((unsigned)); /* just a GNU-style error-checking malloc */
-int printf PROTO((const char *, ...));
-int fprintf PROTO((FILE *, const char *, ...));
-/*varies (sun/alpha): int fputc PROTO((char, FILE *)); */
-int fputs PROTO((const char *, FILE *));
-int sscanf PROTO((const char *, const char *, ...));
-long strtol PROTO((const char *, char **, int));
-size_t fread PROTO((void *, size_t, size_t, FILE *));
-int fclose PROTO((FILE *));
-int isatty PROTO((int));
-/*extern ??? _filbuf */
-/*extern ??? _flsbuf */
-
-void format_string PROTO((FILE *, unsigned char *, int));
-tree mkbinop PROTO((char *, tree, tree));
-tree mkinfixop PROTO((char *, tree, tree));
-list type2context PROTO((ttype));
-pbinding createpat PROTO((list, binding));
-void process_args PROTO((int, char **));
-void hash_init PROTO((void));
-void print_hash_table PROTO((void));
-long int hash_index PROTO((id));
-void yyinit PROTO((void));
-int yyparse PROTO((void));
-int yylex PROTO((void));
-void setyyin PROTO((char *));
-void yyerror PROTO((char *));
-void error PROTO((char *));
-void hsperror PROTO((char *));
-void enteriscope PROTO((void));
-void exposeis PROTO((void));
-void makeinfix PROTO((id, int, int));
-int nfixes PROTO((void));
-long int precedence PROTO((int));
-int pprecedence PROTO((struct infix *));
-int pfixity PROTO((struct infix *));
-void pprogram PROTO((tree));
-void hsincindent PROTO((void));
-void hssetindent PROTO((void));
-void hsendindent PROTO((void));
-void hsindentoff PROTO((void));
-
-int checkfixity PROTO((char *));
-void checksamefn PROTO((char *));
-void checkinpat PROTO((void));
-
-void patternOrExpr PROTO((int,tree));
-/* the "int" arg says what we want; it is one of: */
-#define LEGIT_PATT 1
-#define LEGIT_EXPR 2
-
-BOOLEAN lhs_is_patt PROTO((tree));
-tree function PROTO((tree));
-void extendfn PROTO((binding, binding));
-void precparse PROTO((tree));
-void checkorder PROTO((binding));
-void checkprec PROTO((tree, id, BOOLEAN));
-BOOLEAN isconstr PROTO((char *));
-void setstartlineno PROTO((void));
-void find_module_on_imports_dirlist PROTO((char *, BOOLEAN, char *));
-char *fixop PROTO((int));
-char *fixtype PROTO((int));
-
-/* mattson additions */
-char *xstrdup PROTO((char *)); /* Duplicate a string */
-char *xstrndup PROTO((char *, unsigned)); /* Duplicate a substring */
-char *xrealloc PROTO((char *, unsigned)); /* Re-allocate a string */
-
-#endif /* __UTILS_H */
projects / ghc-hetmet.git / commitdiff