From f6ca98ca45e8cdbae153a23077cccb5dd71e4e7b Mon Sep 17 00:00:00 2001 From: partain Date: Fri, 22 Mar 1996 09:31:46 +0000 Subject: [PATCH] [project @ 1996-03-22 09:28:55 by partain] Removing more junk files --- ghc/compiler/abstractSyn/AbsSyn.lhs | 301 -- ghc/compiler/abstractSyn/AbsSynFuns.lhs | 530 ---- ghc/compiler/abstractSyn/HsBinds.lhs | 329 --- ghc/compiler/abstractSyn/HsCore.lhs | 353 --- ghc/compiler/abstractSyn/HsDecls.lhs | 299 -- ghc/compiler/abstractSyn/HsExpr.lhs | 506 ---- ghc/compiler/abstractSyn/HsImpExp.lhs | 226 -- ghc/compiler/abstractSyn/HsLit.lhs | 76 - ghc/compiler/abstractSyn/HsMatches.lhs | 215 -- ghc/compiler/abstractSyn/HsPat.lhs | 352 --- ghc/compiler/abstractSyn/HsPragmas.lhs | 200 -- ghc/compiler/abstractSyn/HsTypes.lhs | 273 -- ghc/compiler/abstractSyn/Name.lhs | 322 -- ghc/compiler/uniType/AbsUniType.lhs | 223 -- ghc/compiler/uniType/Class.lhs | 386 --- ghc/compiler/uniType/TyCon.lhs | 590 ---- ghc/compiler/uniType/TyVar.lhs | 344 --- ghc/compiler/uniType/UniTyFuns.lhs | 1940 ------------ ghc/compiler/uniType/UniType.lhs | 370 --- ghc/compiler/yaccParser/Jmakefile | 112 - ghc/compiler/yaccParser/MAIL.byacc | 146 - ghc/compiler/yaccParser/README-DPH | 241 -- ghc/compiler/yaccParser/README.debug | 12 - ghc/compiler/yaccParser/U_atype.hs | 22 - ghc/compiler/yaccParser/U_binding.hs | 200 -- ghc/compiler/yaccParser/U_coresyn.hs | 278 -- ghc/compiler/yaccParser/U_entidt.hs | 42 - ghc/compiler/yaccParser/U_finfot.hs | 18 - ghc/compiler/yaccParser/U_hpragma.hs | 121 - ghc/compiler/yaccParser/U_list.hs | 20 - ghc/compiler/yaccParser/U_literal.hs | 68 - ghc/compiler/yaccParser/U_pbinding.hs | 32 - ghc/compiler/yaccParser/U_tree.hs | 184 -- ghc/compiler/yaccParser/U_treeHACK.hs | 185 -- ghc/compiler/yaccParser/U_ttype.hs | 66 - ghc/compiler/yaccParser/UgenAll.lhs | 48 - ghc/compiler/yaccParser/UgenUtil.lhs | 98 - ghc/compiler/yaccParser/atype.c | 57 - ghc/compiler/yaccParser/atype.h | 90 - ghc/compiler/yaccParser/atype.ugn | 15 - ghc/compiler/yaccParser/binding.c | 1061 ------- ghc/compiler/yaccParser/binding.h | 1436 --------- ghc/compiler/yaccParser/binding.ugn | 115 - ghc/compiler/yaccParser/constants.h | 52 - ghc/compiler/yaccParser/coresyn.c | 1495 ---------- ghc/compiler/yaccParser/coresyn.h | 1903 ------------ ghc/compiler/yaccParser/coresyn.ugn | 120 - ghc/compiler/yaccParser/entidt.c | 167 -- ghc/compiler/yaccParser/entidt.h | 215 -- ghc/compiler/yaccParser/entidt.ugn | 20 - ghc/compiler/yaccParser/finfot.c | 45 - ghc/compiler/yaccParser/finfot.h | 72 - ghc/compiler/yaccParser/finfot.ugn | 12 - ghc/compiler/yaccParser/hpragma.c | 597 ---- ghc/compiler/yaccParser/hpragma.h | 756 ----- ghc/compiler/yaccParser/hpragma.ugn | 65 - ghc/compiler/yaccParser/hschooks.c | 66 - ghc/compiler/yaccParser/hsclink.c | 63 - ghc/compiler/yaccParser/hslexer-DPH.lex | 1397 --------- ghc/compiler/yaccParser/hslexer.c | 4351 --------------------------- ghc/compiler/yaccParser/hslexer.flex | 1365 --------- ghc/compiler/yaccParser/hsparser-DPH.y | 1555 ---------- ghc/compiler/yaccParser/hsparser.tab.c | 4711 ------------------------------ ghc/compiler/yaccParser/hsparser.tab.h | 138 - ghc/compiler/yaccParser/hsparser.y | 2102 ------------- ghc/compiler/yaccParser/hspincl.h | 74 - ghc/compiler/yaccParser/id.c | 286 -- ghc/compiler/yaccParser/id.h | 15 - ghc/compiler/yaccParser/impidt.c | 320 -- ghc/compiler/yaccParser/impidt.h | 143 - ghc/compiler/yaccParser/import_dirlist.c | 223 -- ghc/compiler/yaccParser/infix.c | 261 -- ghc/compiler/yaccParser/list.c | 55 - ghc/compiler/yaccParser/list.h | 79 - ghc/compiler/yaccParser/list.ugn | 13 - ghc/compiler/yaccParser/listcomp.c | 67 - ghc/compiler/yaccParser/literal.c | 321 -- ghc/compiler/yaccParser/literal.h | 390 --- ghc/compiler/yaccParser/literal.ugn | 25 - ghc/compiler/yaccParser/main.c | 55 - ghc/compiler/yaccParser/pbinding.c | 81 - ghc/compiler/yaccParser/pbinding.h | 126 - ghc/compiler/yaccParser/pbinding.ugn | 23 - ghc/compiler/yaccParser/printtree.c | 984 ------- ghc/compiler/yaccParser/syntax.c | 781 ----- ghc/compiler/yaccParser/tree-DPH.ugn | 80 - ghc/compiler/yaccParser/tree.c | 869 ------ ghc/compiler/yaccParser/tree.h | 1100 ------- ghc/compiler/yaccParser/tree.ugn | 85 - ghc/compiler/yaccParser/ttype-DPH.ugn | 23 - ghc/compiler/yaccParser/ttype.c | 301 -- ghc/compiler/yaccParser/ttype.h | 376 --- ghc/compiler/yaccParser/ttype.ugn | 31 - ghc/compiler/yaccParser/type2context.c | 160 - ghc/compiler/yaccParser/util.c | 309 -- ghc/compiler/yaccParser/utils.h | 139 - 96 files changed, 41564 deletions(-) delete mode 100644 ghc/compiler/abstractSyn/AbsSyn.lhs delete mode 100644 ghc/compiler/abstractSyn/AbsSynFuns.lhs delete mode 100644 ghc/compiler/abstractSyn/HsBinds.lhs delete mode 100644 ghc/compiler/abstractSyn/HsCore.lhs delete mode 100644 ghc/compiler/abstractSyn/HsDecls.lhs delete mode 100644 ghc/compiler/abstractSyn/HsExpr.lhs delete mode 100644 ghc/compiler/abstractSyn/HsImpExp.lhs delete mode 100644 ghc/compiler/abstractSyn/HsLit.lhs delete mode 100644 ghc/compiler/abstractSyn/HsMatches.lhs delete mode 100644 ghc/compiler/abstractSyn/HsPat.lhs delete mode 100644 ghc/compiler/abstractSyn/HsPragmas.lhs delete mode 100644 ghc/compiler/abstractSyn/HsTypes.lhs delete mode 100644 ghc/compiler/abstractSyn/Name.lhs delete mode 100644 ghc/compiler/uniType/AbsUniType.lhs delete mode 100644 ghc/compiler/uniType/Class.lhs delete mode 100644 ghc/compiler/uniType/TyCon.lhs delete mode 100644 ghc/compiler/uniType/TyVar.lhs delete mode 100644 ghc/compiler/uniType/UniTyFuns.lhs delete mode 100644 ghc/compiler/uniType/UniType.lhs delete mode 100644 ghc/compiler/yaccParser/Jmakefile delete mode 100644 ghc/compiler/yaccParser/MAIL.byacc delete mode 100644 ghc/compiler/yaccParser/README-DPH delete mode 100644 ghc/compiler/yaccParser/README.debug delete mode 100644 ghc/compiler/yaccParser/U_atype.hs delete mode 100644 ghc/compiler/yaccParser/U_binding.hs delete mode 100644 ghc/compiler/yaccParser/U_coresyn.hs delete mode 100644 ghc/compiler/yaccParser/U_entidt.hs delete mode 100644 ghc/compiler/yaccParser/U_finfot.hs delete mode 100644 ghc/compiler/yaccParser/U_hpragma.hs delete mode 100644 ghc/compiler/yaccParser/U_list.hs delete mode 100644 ghc/compiler/yaccParser/U_literal.hs delete mode 100644 ghc/compiler/yaccParser/U_pbinding.hs delete mode 100644 ghc/compiler/yaccParser/U_tree.hs delete mode 100644 ghc/compiler/yaccParser/U_treeHACK.hs delete mode 100644 ghc/compiler/yaccParser/U_ttype.hs delete mode 100644 ghc/compiler/yaccParser/UgenAll.lhs delete mode 100644 ghc/compiler/yaccParser/UgenUtil.lhs delete mode 100644 ghc/compiler/yaccParser/atype.c delete mode 100644 ghc/compiler/yaccParser/atype.h delete mode 100644 ghc/compiler/yaccParser/atype.ugn delete mode 100644 ghc/compiler/yaccParser/binding.c delete mode 100644 ghc/compiler/yaccParser/binding.h delete mode 100644 ghc/compiler/yaccParser/binding.ugn delete mode 100644 ghc/compiler/yaccParser/constants.h delete mode 100644 ghc/compiler/yaccParser/coresyn.c delete mode 100644 ghc/compiler/yaccParser/coresyn.h delete mode 100644 ghc/compiler/yaccParser/coresyn.ugn delete mode 100644 ghc/compiler/yaccParser/entidt.c delete mode 100644 ghc/compiler/yaccParser/entidt.h delete mode 100644 ghc/compiler/yaccParser/entidt.ugn delete mode 100644 ghc/compiler/yaccParser/finfot.c delete mode 100644 ghc/compiler/yaccParser/finfot.h delete mode 100644 ghc/compiler/yaccParser/finfot.ugn delete mode 100644 ghc/compiler/yaccParser/hpragma.c delete mode 100644 ghc/compiler/yaccParser/hpragma.h delete mode 100644 ghc/compiler/yaccParser/hpragma.ugn delete mode 100644 ghc/compiler/yaccParser/hschooks.c delete mode 100644 ghc/compiler/yaccParser/hsclink.c delete mode 100644 ghc/compiler/yaccParser/hslexer-DPH.lex delete mode 100644 ghc/compiler/yaccParser/hslexer.c delete mode 100644 ghc/compiler/yaccParser/hslexer.flex delete mode 100644 ghc/compiler/yaccParser/hsparser-DPH.y delete mode 100644 ghc/compiler/yaccParser/hsparser.tab.c delete mode 100644 ghc/compiler/yaccParser/hsparser.tab.h delete mode 100644 ghc/compiler/yaccParser/hsparser.y delete mode 100644 ghc/compiler/yaccParser/hspincl.h delete mode 100644 ghc/compiler/yaccParser/id.c delete mode 100644 ghc/compiler/yaccParser/id.h delete mode 100644 ghc/compiler/yaccParser/impidt.c delete mode 100644 ghc/compiler/yaccParser/impidt.h delete mode 100644 ghc/compiler/yaccParser/import_dirlist.c delete mode 100644 ghc/compiler/yaccParser/infix.c delete mode 100644 ghc/compiler/yaccParser/list.c delete mode 100644 ghc/compiler/yaccParser/list.h delete mode 100644 ghc/compiler/yaccParser/list.ugn delete mode 100644 ghc/compiler/yaccParser/listcomp.c delete mode 100644 ghc/compiler/yaccParser/literal.c delete mode 100644 ghc/compiler/yaccParser/literal.h delete mode 100644 ghc/compiler/yaccParser/literal.ugn delete mode 100644 ghc/compiler/yaccParser/main.c delete mode 100644 ghc/compiler/yaccParser/pbinding.c delete mode 100644 ghc/compiler/yaccParser/pbinding.h delete mode 100644 ghc/compiler/yaccParser/pbinding.ugn delete mode 100644 ghc/compiler/yaccParser/printtree.c delete mode 100644 ghc/compiler/yaccParser/syntax.c delete mode 100644 ghc/compiler/yaccParser/tests/Jmakefile delete mode 100644 ghc/compiler/yaccParser/tree-DPH.ugn delete mode 100644 ghc/compiler/yaccParser/tree.c delete mode 100644 ghc/compiler/yaccParser/tree.h delete mode 100644 ghc/compiler/yaccParser/tree.ugn delete mode 100644 ghc/compiler/yaccParser/ttype-DPH.ugn delete mode 100644 ghc/compiler/yaccParser/ttype.c delete mode 100644 ghc/compiler/yaccParser/ttype.h delete mode 100644 ghc/compiler/yaccParser/ttype.ugn delete mode 100644 ghc/compiler/yaccParser/type2context.c delete mode 100644 ghc/compiler/yaccParser/util.c delete mode 100644 ghc/compiler/yaccParser/utils.h diff --git a/ghc/compiler/abstractSyn/AbsSyn.lhs b/ghc/compiler/abstractSyn/AbsSyn.lhs deleted file mode 100644 index b7f494a..0000000 --- a/ghc/compiler/abstractSyn/AbsSyn.lhs +++ /dev/null @@ -1,301 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/AbsSynFuns.lhs b/ghc/compiler/abstractSyn/AbsSynFuns.lhs deleted file mode 100644 index c342cc0..0000000 --- a/ghc/compiler/abstractSyn/AbsSynFuns.lhs +++ /dev/null @@ -1,530 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/HsBinds.lhs b/ghc/compiler/abstractSyn/HsBinds.lhs deleted file mode 100644 index c0716d2..0000000 --- a/ghc/compiler/abstractSyn/HsBinds.lhs +++ /dev/null @@ -1,329 +0,0 @@ -% -% (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(""), 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} diff --git a/ghc/compiler/abstractSyn/HsCore.lhs b/ghc/compiler/abstractSyn/HsCore.lhs deleted file mode 100644 index 1481007..0000000 --- a/ghc/compiler/abstractSyn/HsCore.lhs +++ /dev/null @@ -1,353 +0,0 @@ -% -% (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_ ", 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} diff --git a/ghc/compiler/abstractSyn/HsDecls.lhs b/ghc/compiler/abstractSyn/HsDecls.lhs deleted file mode 100644 index 8063775..0000000 --- a/ghc/compiler/abstractSyn/HsDecls.lhs +++ /dev/null @@ -1,299 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/HsExpr.lhs b/ghc/compiler/abstractSyn/HsExpr.lhs deleted file mode 100644 index 131958c..0000000 --- a/ghc/compiler/abstractSyn/HsExpr.lhs +++ /dev/null @@ -1,506 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/HsImpExp.lhs b/ghc/compiler/abstractSyn/HsImpExp.lhs deleted file mode 100644 index 3db0fda..0000000 --- a/ghc/compiler/abstractSyn/HsImpExp.lhs +++ /dev/null @@ -1,226 +0,0 @@ -% -% (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} - - diff --git a/ghc/compiler/abstractSyn/HsLit.lhs b/ghc/compiler/abstractSyn/HsLit.lhs deleted file mode 100644 index bf5ae19..0000000 --- a/ghc/compiler/abstractSyn/HsLit.lhs +++ /dev/null @@ -1,76 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/HsMatches.lhs b/ghc/compiler/abstractSyn/HsMatches.lhs deleted file mode 100644 index 15620ed..0000000 --- a/ghc/compiler/abstractSyn/HsMatches.lhs +++ /dev/null @@ -1,215 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/HsPat.lhs b/ghc/compiler/abstractSyn/HsPat.lhs deleted file mode 100644 index 35b54e4..0000000 --- a/ghc/compiler/abstractSyn/HsPat.lhs +++ /dev/null @@ -1,352 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/HsPragmas.lhs b/ghc/compiler/abstractSyn/HsPragmas.lhs deleted file mode 100644 index 6e9ec4e..0000000 --- a/ghc/compiler/abstractSyn/HsPragmas.lhs +++ /dev/null @@ -1,200 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/HsTypes.lhs b/ghc/compiler/abstractSyn/HsTypes.lhs deleted file mode 100644 index 8ea7821..0000000 --- a/ghc/compiler/abstractSyn/HsTypes.lhs +++ /dev/null @@ -1,273 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/abstractSyn/Name.lhs b/ghc/compiler/abstractSyn/Name.lhs deleted file mode 100644 index e4c717a..0000000 --- a/ghc/compiler/abstractSyn/Name.lhs +++ /dev/null @@ -1,322 +0,0 @@ -% -% (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("") - 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} diff --git a/ghc/compiler/uniType/AbsUniType.lhs b/ghc/compiler/uniType/AbsUniType.lhs deleted file mode 100644 index 2bfdb2f..0000000 --- a/ghc/compiler/uniType/AbsUniType.lhs +++ /dev/null @@ -1,223 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/uniType/Class.lhs b/ghc/compiler/uniType/Class.lhs deleted file mode 100644 index 4d61be9..0000000 --- a/ghc/compiler/uniType/Class.lhs +++ /dev/null @@ -1,386 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/uniType/TyCon.lhs b/ghc/compiler/uniType/TyCon.lhs deleted file mode 100644 index 814108e..0000000 --- a/ghc/compiler/uniType/TyCon.lhs +++ /dev/null @@ -1,590 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/uniType/TyVar.lhs b/ghc/compiler/uniType/TyVar.lhs deleted file mode 100644 index 4723b8c..0000000 --- a/ghc/compiler/uniType/TyVar.lhs +++ /dev/null @@ -1,344 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/uniType/UniTyFuns.lhs b/ghc/compiler/uniType/UniTyFuns.lhs deleted file mode 100644 index 4a2bf43..0000000 --- a/ghc/compiler/uniType/UniTyFuns.lhs +++ /dev/null @@ -1,1940 +0,0 @@ -% -% (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 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} diff --git a/ghc/compiler/uniType/UniType.lhs b/ghc/compiler/uniType/UniType.lhs deleted file mode 100644 index 7cbbe44..0000000 --- a/ghc/compiler/uniType/UniType.lhs +++ /dev/null @@ -1,370 +0,0 @@ -% -% (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} diff --git a/ghc/compiler/yaccParser/Jmakefile b/ghc/compiler/yaccParser/Jmakefile deleted file mode 100644 index 15b12ea..0000000 --- a/ghc/compiler/yaccParser/Jmakefile +++ /dev/null @@ -1,112 +0,0 @@ -#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) ) - - - - - - - - - - diff --git a/ghc/compiler/yaccParser/MAIL.byacc b/ghc/compiler/yaccParser/MAIL.byacc deleted file mode 100644 index 7c25fab..0000000 --- a/ghc/compiler/yaccParser/MAIL.byacc +++ /dev/null @@ -1,146 +0,0 @@ -Return-Path: mattson@dcs.gla.ac.uk -Return-Path: -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 - -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 - -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 - --------- diff --git a/ghc/compiler/yaccParser/README-DPH b/ghc/compiler/yaccParser/README-DPH deleted file mode 100644 index 8b9647f..0000000 --- a/ghc/compiler/yaccParser/README-DPH +++ /dev/null @@ -1,241 +0,0 @@ -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); } - - ("-")?{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 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(); } -+ ; - - diff --git a/ghc/compiler/yaccParser/README.debug b/ghc/compiler/yaccParser/README.debug deleted file mode 100644 index 17503dd..0000000 --- a/ghc/compiler/yaccParser/README.debug +++ /dev/null @@ -1,12 +0,0 @@ -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. diff --git a/ghc/compiler/yaccParser/U_atype.hs b/ghc/compiler/yaccParser/U_atype.hs deleted file mode 100644 index 79ac302..0000000 --- a/ghc/compiler/yaccParser/U_atype.hs +++ /dev/null @@ -1,22 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_binding.hs b/ghc/compiler/yaccParser/U_binding.hs deleted file mode 100644 index 6ab8211..0000000 --- a/ghc/compiler/yaccParser/U_binding.hs +++ /dev/null @@ -1,200 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_coresyn.hs b/ghc/compiler/yaccParser/U_coresyn.hs deleted file mode 100644 index d3570df..0000000 --- a/ghc/compiler/yaccParser/U_coresyn.hs +++ /dev/null @@ -1,278 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_entidt.hs b/ghc/compiler/yaccParser/U_entidt.hs deleted file mode 100644 index 5face2b..0000000 --- a/ghc/compiler/yaccParser/U_entidt.hs +++ /dev/null @@ -1,42 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_finfot.hs b/ghc/compiler/yaccParser/U_finfot.hs deleted file mode 100644 index 15055df..0000000 --- a/ghc/compiler/yaccParser/U_finfot.hs +++ /dev/null @@ -1,18 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_hpragma.hs b/ghc/compiler/yaccParser/U_hpragma.hs deleted file mode 100644 index e344a5e..0000000 --- a/ghc/compiler/yaccParser/U_hpragma.hs +++ /dev/null @@ -1,121 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_list.hs b/ghc/compiler/yaccParser/U_list.hs deleted file mode 100644 index 7e73e77..0000000 --- a/ghc/compiler/yaccParser/U_list.hs +++ /dev/null @@ -1,20 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_literal.hs b/ghc/compiler/yaccParser/U_literal.hs deleted file mode 100644 index 97fb6ea..0000000 --- a/ghc/compiler/yaccParser/U_literal.hs +++ /dev/null @@ -1,68 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_pbinding.hs b/ghc/compiler/yaccParser/U_pbinding.hs deleted file mode 100644 index 282fbaf..0000000 --- a/ghc/compiler/yaccParser/U_pbinding.hs +++ /dev/null @@ -1,32 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_tree.hs b/ghc/compiler/yaccParser/U_tree.hs deleted file mode 100644 index 52ae1e6..0000000 --- a/ghc/compiler/yaccParser/U_tree.hs +++ /dev/null @@ -1,184 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_treeHACK.hs b/ghc/compiler/yaccParser/U_treeHACK.hs deleted file mode 100644 index c80d2f6..0000000 --- a/ghc/compiler/yaccParser/U_treeHACK.hs +++ /dev/null @@ -1,185 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/U_ttype.hs b/ghc/compiler/yaccParser/U_ttype.hs deleted file mode 100644 index 23b455a..0000000 --- a/ghc/compiler/yaccParser/U_ttype.hs +++ /dev/null @@ -1,66 +0,0 @@ - - -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") diff --git a/ghc/compiler/yaccParser/UgenAll.lhs b/ghc/compiler/yaccParser/UgenAll.lhs deleted file mode 100644 index 7ca0508..0000000 --- a/ghc/compiler/yaccParser/UgenAll.lhs +++ /dev/null @@ -1,48 +0,0 @@ -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} diff --git a/ghc/compiler/yaccParser/UgenUtil.lhs b/ghc/compiler/yaccParser/UgenUtil.lhs deleted file mode 100644 index 80587f1..0000000 --- a/ghc/compiler/yaccParser/UgenUtil.lhs +++ /dev/null @@ -1,98 +0,0 @@ -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} diff --git a/ghc/compiler/yaccParser/atype.c b/ghc/compiler/yaccParser/atype.c deleted file mode 100644 index b1cbfe3..0000000 --- a/ghc/compiler/yaccParser/atype.c +++ /dev/null @@ -1,57 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/atype.h b/ghc/compiler/yaccParser/atype.h deleted file mode 100644 index 0651a70..0000000 --- a/ghc/compiler/yaccParser/atype.h +++ /dev/null @@ -1,90 +0,0 @@ -#ifndef atype_defined -#define atype_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/atype.ugn b/ghc/compiler/yaccParser/atype.ugn deleted file mode 100644 index c51e5b2..0000000 --- a/ghc/compiler/yaccParser/atype.ugn +++ /dev/null @@ -1,15 +0,0 @@ -%{ -#include "hspincl.h" -%} -%{{ -module U_atype where -import UgenUtil -import Util - -import U_list -%}} -type atype; - atc : < gatcid : unkId; - gatctypel : list; - gatcline : long; >; -end; diff --git a/ghc/compiler/yaccParser/binding.c b/ghc/compiler/yaccParser/binding.c deleted file mode 100644 index 6aa24ec..0000000 --- a/ghc/compiler/yaccParser/binding.c +++ /dev/null @@ -1,1061 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/binding.h b/ghc/compiler/yaccParser/binding.h deleted file mode 100644 index 7342d01..0000000 --- a/ghc/compiler/yaccParser/binding.h +++ /dev/null @@ -1,1436 +0,0 @@ -#ifndef binding_defined -#define binding_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/binding.ugn b/ghc/compiler/yaccParser/binding.ugn deleted file mode 100644 index 680a0b1..0000000 --- a/ghc/compiler/yaccParser/binding.ugn +++ /dev/null @@ -1,115 +0,0 @@ -%{ -#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:; - - dspec_uprag : < gdspec_id : unkId; - gdspec_tys : list; - gdspec_line : long; >; - -end; diff --git a/ghc/compiler/yaccParser/constants.h b/ghc/compiler/yaccParser/constants.h deleted file mode 100644 index 9e168c7..0000000 --- a/ghc/compiler/yaccParser/constants.h +++ /dev/null @@ -1,52 +0,0 @@ -/* - 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 */ diff --git a/ghc/compiler/yaccParser/coresyn.c b/ghc/compiler/yaccParser/coresyn.c deleted file mode 100644 index 2f17580..0000000 --- a/ghc/compiler/yaccParser/coresyn.c +++ /dev/null @@ -1,1495 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/coresyn.h b/ghc/compiler/yaccParser/coresyn.h deleted file mode 100644 index 37ef02c..0000000 --- a/ghc/compiler/yaccParser/coresyn.h +++ /dev/null @@ -1,1903 +0,0 @@ -#ifndef coresyn_defined -#define coresyn_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/coresyn.ugn b/ghc/compiler/yaccParser/coresyn.ugn deleted file mode 100644 index 5d65c84..0000000 --- a/ghc/compiler/yaccParser/coresyn.ugn +++ /dev/null @@ -1,120 +0,0 @@ -%{ -#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 : ; - corec : ; - corec_pair: ; - - 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; diff --git a/ghc/compiler/yaccParser/entidt.c b/ghc/compiler/yaccParser/entidt.c deleted file mode 100644 index 3e6c951..0000000 --- a/ghc/compiler/yaccParser/entidt.c +++ /dev/null @@ -1,167 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/entidt.h b/ghc/compiler/yaccParser/entidt.h deleted file mode 100644 index d2c356c..0000000 --- a/ghc/compiler/yaccParser/entidt.h +++ /dev/null @@ -1,215 +0,0 @@ -#ifndef entidt_defined -#define entidt_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/entidt.ugn b/ghc/compiler/yaccParser/entidt.ugn deleted file mode 100644 index 3b3c8f1..0000000 --- a/ghc/compiler/yaccParser/entidt.ugn +++ /dev/null @@ -1,20 +0,0 @@ -%{ -#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; diff --git a/ghc/compiler/yaccParser/finfot.c b/ghc/compiler/yaccParser/finfot.c deleted file mode 100644 index 504d5c9..0000000 --- a/ghc/compiler/yaccParser/finfot.c +++ /dev/null @@ -1,45 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/finfot.h b/ghc/compiler/yaccParser/finfot.h deleted file mode 100644 index 98c7d31..0000000 --- a/ghc/compiler/yaccParser/finfot.h +++ /dev/null @@ -1,72 +0,0 @@ -#ifndef finfot_defined -#define finfot_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/finfot.ugn b/ghc/compiler/yaccParser/finfot.ugn deleted file mode 100644 index 1ac6899..0000000 --- a/ghc/compiler/yaccParser/finfot.ugn +++ /dev/null @@ -1,12 +0,0 @@ -%{ -#include "hspincl.h" -%} -%{{ -module U_finfot where -import UgenUtil -import Util -%}} -type finfot; -/*OLD:95/08: nofinfo : < >; */ - finfo : < fi1: stringId; fi2: stringId; >; -end; diff --git a/ghc/compiler/yaccParser/hpragma.c b/ghc/compiler/yaccParser/hpragma.c deleted file mode 100644 index 46a6f10..0000000 --- a/ghc/compiler/yaccParser/hpragma.c +++ /dev/null @@ -1,597 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/hpragma.h b/ghc/compiler/yaccParser/hpragma.h deleted file mode 100644 index 80b811d..0000000 --- a/ghc/compiler/yaccParser/hpragma.h +++ /dev/null @@ -1,756 +0,0 @@ -#ifndef hpragma_defined -#define hpragma_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/hpragma.ugn b/ghc/compiler/yaccParser/hpragma.ugn deleted file mode 100644 index 81ba61e..0000000 --- a/ghc/compiler/yaccParser/hpragma.ugn +++ /dev/null @@ -1,65 +0,0 @@ -%{ -#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; diff --git a/ghc/compiler/yaccParser/hschooks.c b/ghc/compiler/yaccParser/hschooks.c deleted file mode 100644 index 2700839..0000000 --- a/ghc/compiler/yaccParser/hschooks.c +++ /dev/null @@ -1,66 +0,0 @@ -/* -These routines customise the error messages -for various bits of the RTS. They are linked -in instead of the defaults. -*/ -#include - -#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' 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' 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" */ -} diff --git a/ghc/compiler/yaccParser/hsclink.c b/ghc/compiler/yaccParser/hsclink.c deleted file mode 100644 index c95e22f..0000000 --- a/ghc/compiler/yaccParser/hsclink.c +++ /dev/null @@ -1,63 +0,0 @@ -/* This is the "top-level" file for the *linked-into-the-compiler* parser. - See also main.c. (WDP 94/10) -*/ - -#include - -#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); -} diff --git a/ghc/compiler/yaccParser/hslexer-DPH.lex b/ghc/compiler/yaccParser/hslexer-DPH.lex deleted file mode 100644 index 6f6946f..0000000 --- a/ghc/compiler/yaccParser/hslexer-DPH.lex +++ /dev/null @@ -1,1397 +0,0 @@ -%{ -/********************************************************************** -* * -* * -* 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 -#include -#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); } - -"void#" { RETURN(VOIDPRIM); } -{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); } - -("-")?{N}"#" { - yytext[yyleng-1] = '\0'; /* clobber the # first */ - yylval.uid = xstrdup(yytext); - RETURN(INTPRIM); - } -{N} { - yylval.uid = xstrdup(yytext); - RETURN(INTEGER); - } - -{N}"."{N}(("e"|"E")("+"|"-")?{N})?"##" { - yytext[yyleng-2] = '\0'; /* clobber the # first */ - yylval.uid = xstrdup(yytext); - RETURN(DOUBLEPRIM); - } - -{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); - } - - -"``"[^']+"''" { 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); - } - -"`"{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 "". - This allows unnamed sources to be piped into the parser. -*/ - -yyinit() -{ - extern BOOLEAN acceptPrim; - - input_filename = xstrdup(""); - - 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 %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 */ diff --git a/ghc/compiler/yaccParser/hslexer.c b/ghc/compiler/yaccParser/hslexer.c deleted file mode 100644 index add30be..0000000 --- a/ghc/compiler/yaccParser/hslexer.c +++ /dev/null @@ -1,4351 +0,0 @@ -/* 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 - - -/* cfront 1.2 defines "c_plusplus" instead of "__cplusplus" */ -#ifdef c_plusplus -#ifndef __cplusplus -#define __cplusplus -#endif -#endif - - -#ifdef __cplusplus - -#include -#include - -/* 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 -#include -#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 - -#if defined(STDC_HEADERS) || defined(HAVE_STRING_H) -#include -/* An ANSI string.h and pre-ANSI memory.h might conflict. */ -#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H) -#include -#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 -/* 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 */ - -#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 -#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 . - */ - -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 state, where - * a backslash is legal. Then, we match the backslash and move into the - * state. When we drop out of , 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 state, where - * a backslash is legal. Then, we match the backslash and move into the - * state. When we drop out of , we collect more normal - * characters, moving back and forth between and as more - * backslashes are encountered. (We may even digress into 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 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 - * and 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 <> 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 "". - This allows unnamed sources to be piped into the parser. -*/ - -extern BOOLEAN acceptPrim; - -void -yyinit(void) -{ - input_filename = xstrdup(""); - - /* 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); -} diff --git a/ghc/compiler/yaccParser/hslexer.flex b/ghc/compiler/yaccParser/hslexer.flex deleted file mode 100644 index 3c2ab36..0000000 --- a/ghc/compiler/yaccParser/hslexer.flex +++ /dev/null @@ -1,1365 +0,0 @@ -%{ -/********************************************************************** -* * -* * -* 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 - -#if defined(STDC_HEADERS) || defined(HAVE_STRING_H) -#include -/* An ANSI string.h and pre-ANSI memory.h might conflict. */ -#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H) -#include -#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 -/* 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 */ - -#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 - */ -%} - -^"# ".*{NL} { - char tempf[FILENAME_SIZE]; - sscanf(yytext+1, "%d \"%[^\"]", &hslineno, tempf); - new_filename(tempf); - hsplineno = hslineno; hscolno = 0; hspcolno = 0; - } - -^"#line ".*{NL} { - char tempf[FILENAME_SIZE]; - sscanf(yytext+5, "%d \"%[^\"]", &hslineno, tempf); - new_filename(tempf); - hsplineno = hslineno; hscolno = 0; hspcolno = 0; - } - -"{-# 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; - } -"{-# GHC_PRAGMA INTERFACE VERSION "{D}+" #-}" { - sscanf(yytext+33,"%d ",&thisIfacePragmaVersion); - } -"{-# GHC_PRAGMA " { - if ( ignorePragmas || - thisIfacePragmaVersion < minAcceptablePragmaVersion || - thisIfacePragmaVersion > maxAcceptablePragmaVersion) { - nested_comments = 1; - PUSH_STATE(Comment); - } else { - PUSH_STATE(GhcPragma); - RETURN(GHC_PRAGMA); - } - } -"_N_" { RETURN(NO_PRAGMA); } -"_NI_" { RETURN(NOINFO_PRAGMA); } -"_ABSTRACT_" { RETURN(ABSTRACT_PRAGMA); } -"_DEFOREST_" { RETURN(DEFOREST_PRAGMA); } -"_SPECIALISE_" { RETURN(SPECIALISE_PRAGMA); } -"_M_" { RETURN(MODNAME_PRAGMA); } -"_A_" { RETURN(ARITY_PRAGMA); } -"_U_" { RETURN(UPDATE_PRAGMA); } -"_S_" { RETURN(STRICTNESS_PRAGMA); } -"_K_" { RETURN(KIND_PRAGMA); } -"_MF_" { RETURN(MAGIC_UNFOLDING_PRAGMA); } -"_F_" { RETURN(UNFOLDING_PRAGMA); } - -"_!_" { RETURN(COCON); } -"_#_" { RETURN(COPRIM); } -"_APP_" { RETURN(COAPP); } -"_TYAPP_" { RETURN(COTYAPP); } -"_ALG_" { RETURN(CO_ALG_ALTS); } -"_PRIM_" { RETURN(CO_PRIM_ALTS); } -"_NO_DEFLT_" { RETURN(CO_NO_DEFAULT); } -"_LETREC_" { RETURN(CO_LETREC); } - -"_PRELUDE_DICTS_CC_" { RETURN(CO_PRELUDE_DICTS_CC); } -"_ALL_DICTS_CC_" { RETURN(CO_ALL_DICTS_CC); } -"_USER_CC_" { RETURN(CO_USER_CC); } -"_AUTO_CC_" { RETURN(CO_AUTO_CC); } -"_DICT_CC_" { RETURN(CO_DICT_CC); } - -"_DUPD_CC_" { RETURN(CO_DUPD_CC); } -"_CAF_CC_" { RETURN(CO_CAF_CC); } - -"_SDSEL_" { RETURN(CO_SDSEL_ID); } -"_METH_" { RETURN(CO_METH_ID); } -"_DEFM_" { RETURN(CO_DEFM_ID); } -"_DFUN_" { RETURN(CO_DFUN_ID); } -"_CONSTM_" { RETURN(CO_CONSTM_ID); } -"_SPEC_" { RETURN(CO_SPEC_ID); } -"_WRKR_" { RETURN(CO_WRKR_ID); } -"_ORIG_" { RETURN(CO_ORIG_NM); /* fully-qualified original name*/ } - -"_ALWAYS_" { RETURN(UNFOLD_ALWAYS); } -"_IF_ARGS_" { RETURN(UNFOLD_IF_ARGS); } - -"_NOREP_I_" { RETURN(NOREP_INTEGER); } -"_NOREP_R_" { RETURN(NOREP_RATIONAL); } -"_NOREP_S_" { RETURN(NOREP_STRING); } - -" #-}" { POP_STATE; RETURN(END_PRAGMA); } - -"{-#"{WS}*"SPECIALI"[SZ]E { - PUSH_STATE(UserPragma); - RETURN(SPECIALISE_UPRAGMA); - } -"{-#"{WS}*"INLINE" { - PUSH_STATE(UserPragma); - RETURN(INLINE_UPRAGMA); - } -"{-#"{WS}*"MAGIC_UNFOLDING" { - PUSH_STATE(UserPragma); - RETURN(MAGIC_UNFOLDING_UPRAGMA); - } -"{-#"{WS}*"DEFOREST" { - PUSH_STATE(UserPragma); - RETURN(DEFOREST_UPRAGMA); - } -"{-#"{WS}*"ABSTRACT" { - PUSH_STATE(UserPragma); - RETURN(ABSTRACT_UPRAGMA); - } -"{-#"{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); - } -"#-}" { POP_STATE; RETURN(END_UPRAGMA); } - -%{ - /* - * Haskell keywords. `scc' is actually a Glasgow extension, but it is - * intentionally accepted as a keyword even for normal . - */ -%} - -"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); } -"_ccall_GC_" { RETURN(CCALL_GC); } -"_casm_" { RETURN(CASM); } -"_casm_GC_" { RETURN(CASM_GC); } -"_scc_" { RETURN(SCC); } -"_forall_" { RETURN(FORALL); } - -%{ - /* - * Haskell operators. Nothing special about these. - */ -%} - -".." { 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(TYLAMBDA); } -"_" { RETURN(WILDCARD); } -"`" { RETURN(BQUOTE); } -"~" { RETURN(LAZY); } -"-" { 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. - */ -%} - -("-")?"0o"{O}+"#" { /* octal */ - yylval.uid = xstrndup(yytext, yyleng - 1); - RETURN(INTPRIM); - } -"0o"{O}+ { /* octal */ - yylval.uid = xstrndup(yytext, yyleng); - RETURN(INTEGER); - } -("-")?"0x"{H}+"#" { /* hexadecimal */ - yylval.uid = xstrndup(yytext, yyleng - 1); - RETURN(INTPRIM); - } -"0x"{H}+ { /* hexadecimal */ - yylval.uid = xstrndup(yytext, yyleng); - RETURN(INTEGER); - } -("-")?{N}"#" { - yylval.uid = xstrndup(yytext, yyleng - 1); - RETURN(INTPRIM); - } -{N} { - yylval.uid = xstrndup(yytext, yyleng); - RETURN(INTEGER); - } - -%{ - /* - * Floats and (for Glasgow extensions) primitive floats/doubles. - */ -%} - -("-")?{F}"##" { - yylval.uid = xstrndup(yytext, yyleng - 2); - RETURN(DOUBLEPRIM); - } -("-")?{F}"#" { - yylval.uid = xstrndup(yytext, yyleng - 1); - RETURN(FLOATPRIM); - } -{F} { - yylval.uid = xstrndup(yytext, yyleng); - RETURN(FLOAT); - } - -%{ - /* - * Funky ``foo'' style C literals for Glasgow extensions - */ -%} - -"``"[^']+"''" { - hsnewid(yytext + 2, yyleng - 4); - RETURN(CLITLIT); - } - -%{ - /* - * Identifiers, both variables and operators. The trailing hash is allowed - * for Glasgow extensions. - */ -%} - -"_NIL_" { hsnewid(yytext, yyleng); RETURN(CONID); } -"_TUP_"{D}+ { hsnewid(yytext, yyleng); RETURN(CONID); } -[a-z]{i}*"$"[a-z]{i}* { hsnewid(yytext, yyleng); RETURN(TYVAR_TEMPLATE_ID); } - -%{ -/* These SHOULDNAE work in "Code" (sigh) */ -%} -{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); - } -_+{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! */ - } -{Id} { - hsnewid(yytext, yyleng); - RETURN(_isconstr(yytext) ? CONID : VARID); - } -{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) - */ -%} - -"`"{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 state, where - * a backslash is legal. Then, we match the backslash and move into the - * state. When we drop out of , 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. - */ -%} - -'({CHAR}|"\"")"'#" { - yylval.uhstring = installHstring(1, yytext+1); - RETURN(CHARPRIM); - } -'({CHAR}|"\"")' { - yylval.uhstring = installHstring(1, yytext+1); - RETURN(CHAR); - } -'' {char errbuf[ERR_BUF_SIZE]; - sprintf(errbuf, "'' is not a valid character (or string) literal\n"); - hsperror(errbuf); - } -'({CHAR}|"\"")* { - hsmlcolno = hspcolno; - cleartext(); - addtext(yytext+1, yyleng-1); - PUSH_STATE(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}|"\"")*' { - 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}|"\"")+ { 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 state, where - * a backslash is legal. Then, we match the backslash and move into the - * state. When we drop out of , we collect more normal - * characters, moving back and forth between and as more - * backslashes are encountered. (We may even digress into mode if we - * find a comment in a gap between backslashes.) Finally, we read the last chunk - * of normal characters and the close ". - */ -%} - -"\""({CHAR}|"'")*"\""# { - yylval.uhstring = installHstring(yyleng-3, yytext+1); - /* the -3 accounts for the " on front, "# on the end */ - RETURN(STRINGPRIM); - } -"\""({CHAR}|"'")*"\"" { - yylval.uhstring = installHstring(yyleng-2, yytext+1); - RETURN(STRING); - } -"\""({CHAR}|"'")* { - hsmlcolno = hspcolno; - cleartext(); - addtext(yytext+1, yyleng-1); - PUSH_STATE(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); - } -({CHAR}|"'")*"\"" { - unsigned length; - char *text; - - addtext(yytext, yyleng-1); - text = fetchtext(&length); - - yylval.uhstring = installHstring(length, text); - hspcolno = hsmlcolno; - POP_STATE; - RETURN(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 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. - */ -%} - -\\ { PUSH_STATE(CharEsc); } -\\& /* Ignore */ ; -\\ { PUSH_STATE(StringEsc); noGap = TRUE; } - -\\ { addchar(*yytext); POP_STATE; } -\\ { if (noGap) { addchar(*yytext); } POP_STATE; } - -["'] { addchar(*yytext); POP_STATE; } -NUL { addchar('\000'); POP_STATE; } -SOH { addchar('\001'); POP_STATE; } -STX { addchar('\002'); POP_STATE; } -ETX { addchar('\003'); POP_STATE; } -EOT { addchar('\004'); POP_STATE; } -ENQ { addchar('\005'); POP_STATE; } -ACK { addchar('\006'); POP_STATE; } -BEL | -a { addchar('\007'); POP_STATE; } -BS | -b { addchar('\010'); POP_STATE; } -HT | -t { addchar('\011'); POP_STATE; } -LF | -n { addchar('\012'); POP_STATE; } -VT | -v { addchar('\013'); POP_STATE; } -FF | -f { addchar('\014'); POP_STATE; } -CR | -r { addchar('\015'); POP_STATE; } -SO { addchar('\016'); POP_STATE; } -SI { addchar('\017'); POP_STATE; } -DLE { addchar('\020'); POP_STATE; } -DC1 { addchar('\021'); POP_STATE; } -DC2 { addchar('\022'); POP_STATE; } -DC3 { addchar('\023'); POP_STATE; } -DC4 { addchar('\024'); POP_STATE; } -NAK { addchar('\025'); POP_STATE; } -SYN { addchar('\026'); POP_STATE; } -ETB { addchar('\027'); POP_STATE; } -CAN { addchar('\030'); POP_STATE; } -EM { addchar('\031'); POP_STATE; } -SUB { addchar('\032'); POP_STATE; } -ESC { addchar('\033'); POP_STATE; } -FS { addchar('\034'); POP_STATE; } -GS { addchar('\035'); POP_STATE; } -RS { addchar('\036'); POP_STATE; } -US { addchar('\037'); POP_STATE; } -SP { addchar('\040'); POP_STATE; } -DEL { addchar('\177'); POP_STATE; } -"^"{CNTRL} { char c = yytext[1] - '@'; addchar(c); POP_STATE; } -{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; - } -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; - } -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) - */ -%} - -"--".*{NL}?{WS}* | -{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. - */ -%} - -"{-" { - noGap = FALSE; nested_comments = 1; PUSH_STATE(Comment); - } - -[^-{]* | -"-"+[^-{}]+ | -"{"+[^-{}]+ ; -"{-" { nested_comments++; } -"-}" { if (--nested_comments == 0) POP_STATE; } -(.|\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. - */ -%} - -(.|\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(""); - } -(.|\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(""); - } -(.|\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(""); - } -(.|\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(""); - } - } -(.|\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 - * and 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 <> rules. Hence the - * line/column advancement has to be done by hand. - */ -%} - -<> { - hsplineno = hslineno; hspcolno = hscolno; - hsperror("unterminated character literal"); - } -<> { - hsplineno = hslineno; hspcolno = hscolno; - hsperror("unterminated comment"); - } -<> { - hsplineno = hslineno; hspcolno = hscolno; - hsperror("unterminated string literal"); - } -<> { - hsplineno = hslineno; hspcolno = hscolno; - hsperror("unterminated interface pragma"); - } -<> { - hsplineno = hslineno; hspcolno = hscolno; - hsperror("unterminated user-specified pragma"); - } -<> { hsplineno = hslineno; hspcolno = hscolno; return(EOF); } - -%% - -/********************************************************************** -* * -* * -* YACC/LEX Initialisation etc. * -* * -* * -**********************************************************************/ - -/* - We initialise input_filename to "". - This allows unnamed sources to be piped into the parser. -*/ - -extern BOOLEAN acceptPrim; - -void -yyinit(void) -{ - input_filename = xstrdup(""); - - /* 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); -} diff --git a/ghc/compiler/yaccParser/hsparser-DPH.y b/ghc/compiler/yaccParser/hsparser-DPH.y deleted file mode 100644 index 55749cd..0000000 --- a/ghc/compiler/yaccParser/hsparser-DPH.y +++ /dev/null @@ -1,1555 +0,0 @@ -/************************************************************************** -* 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 -#include -#include -#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 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 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 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 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 simple simple_long type atype btype ttype ntatype inst class - tyvar - -%type constr - -%type STRING FLOAT INTEGER CHARPRIM INTPRIM FLOATPRIM DOUBLEPRIM CLITLIT VOIDPRIM -%type CHAR -%type export import -%type 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 */ - $$ = hsplineno; /* remember current line number */ - } - lampats - { hsendindent(); /* added by partain */ - /* exitiscope(); /? Also not understood */ - } - RARROW exp /* lambda abstraction */ - { - $$ = mklambda($3, $6, $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(); - } - ; - -%% diff --git a/ghc/compiler/yaccParser/hsparser.tab.c b/ghc/compiler/yaccParser/hsparser.tab.c deleted file mode 100644 index 64e3327..0000000 --- a/ghc/compiler/yaccParser/hsparser.tab.c +++ /dev/null @@ -1,4711 +0,0 @@ - -/* 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 -#include -#include -#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 - -#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 -#else /* not sparc */ -#if defined (MSDOS) && !defined (__TURBOC__) -#include -#else /* not MSDOS, or __TURBOC__ */ -#if defined(_AIX) -#include - #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 - -#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 - -#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" - - 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, ""); - - 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++; - } -} diff --git a/ghc/compiler/yaccParser/hsparser.tab.h b/ghc/compiler/yaccParser/hsparser.tab.h deleted file mode 100644 index 15ec07b..0000000 --- a/ghc/compiler/yaccParser/hsparser.tab.h +++ /dev/null @@ -1,138 +0,0 @@ -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; diff --git a/ghc/compiler/yaccParser/hsparser.y b/ghc/compiler/yaccParser/hsparser.y deleted file mode 100644 index 46ae1ac..0000000 --- a/ghc/compiler/yaccParser/hsparser.y +++ /dev/null @@ -1,2102 +0,0 @@ -/************************************************************************** -* 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 -#include -#include -#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 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 lit_constant - -%type 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 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 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 simple type atype btype ttype ntatype - class restrict_inst general_inst tyvar type_maybe - core_type core_type_maybe - -%type constr - -%type FLOAT INTEGER INTPRIM - FLOATPRIM DOUBLEPRIM CLITLIT -%type STRING STRINGPRIM CHAR CHARPRIM -%type export import - -%type 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 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 */ - $$ = hsplineno; /* remember current line number */ - } - lampats - { hsendindent(); /* added by partain */ - /* exitiscope(); /? Also not understood */ - } - RARROW exp /* lambda abstraction */ - { - $$ = mklambda($3, $6, $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, ""); - - 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++; - } -} diff --git a/ghc/compiler/yaccParser/hspincl.h b/ghc/compiler/yaccParser/hspincl.h deleted file mode 100644 index b273957..0000000 --- a/ghc/compiler/yaccParser/hspincl.h +++ /dev/null @@ -1,74 +0,0 @@ -#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 -/* An ANSI string.h and pre-ANSI memory.h might conflict. */ -#if !defined(STDC_HEADERS) && defined(HAVE_MEMORY_H) -#include -#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 -/* memory.h and strings.h conflict on some systems. */ -#endif /* not STDC_HEADERS and not HAVE_STRING_H */ - -#ifdef HAVE_MALLOC_H -#include -#endif -#ifdef HAVE_STDLIB_H -#include -#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 */ diff --git a/ghc/compiler/yaccParser/id.c b/ghc/compiler/yaccParser/id.c deleted file mode 100644 index 72e2fca..0000000 --- a/ghc/compiler/yaccParser/id.c +++ /dev/null @@ -1,286 +0,0 @@ -/********************************************************************** -* * -* * -* Identifier Processing * -* * -* * -**********************************************************************/ - -#include - -#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= 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); -} diff --git a/ghc/compiler/yaccParser/id.h b/ghc/compiler/yaccParser/id.h deleted file mode 100644 index b0fd009..0000000 --- a/ghc/compiler/yaccParser/id.h +++ /dev/null @@ -1,15 +0,0 @@ -#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 diff --git a/ghc/compiler/yaccParser/impidt.c b/ghc/compiler/yaccParser/impidt.c deleted file mode 100644 index 08b55fa..0000000 --- a/ghc/compiler/yaccParser/impidt.c +++ /dev/null @@ -1,320 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/impidt.h b/ghc/compiler/yaccParser/impidt.h deleted file mode 100644 index 0c27c78..0000000 --- a/ghc/compiler/yaccParser/impidt.h +++ /dev/null @@ -1,143 +0,0 @@ -#ifndef impidt_defined -#define impidt_defined - -#include - -#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))) - diff --git a/ghc/compiler/yaccParser/import_dirlist.c b/ghc/compiler/yaccParser/import_dirlist.c deleted file mode 100644 index d81de59..0000000 --- a/ghc/compiler/yaccParser/import_dirlist.c +++ /dev/null @@ -1,223 +0,0 @@ -/********************************************************************** -* * -* * -* Import Directory List Handling * -* * -* * -**********************************************************************/ - -#include - -#include "hspincl.h" -#include "constants.h" -#include "utils.h" - -#ifdef HAVE_UNISTD_H -#include -#endif - -#ifdef HAVE_SYS_TYPES_H -#include -#else -#ifdef HAVE_TYPES_H -#include -#endif -#endif - -#ifdef HAVE_SYS_STAT_H -#include -#endif - -#ifdef HAVE_SYS_FILE_H -#include -#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; - } -} diff --git a/ghc/compiler/yaccParser/infix.c b/ghc/compiler/yaccParser/infix.c deleted file mode 100644 index 9e17a1e..0000000 --- a/ghc/compiler/yaccParser/infix.c +++ /dev/null @@ -1,261 +0,0 @@ -/* - * Infix operator stuff -- modified from LML - */ - -#include - -#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++; -} diff --git a/ghc/compiler/yaccParser/list.c b/ghc/compiler/yaccParser/list.c deleted file mode 100644 index 9a3c8cb..0000000 --- a/ghc/compiler/yaccParser/list.c +++ /dev/null @@ -1,55 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/list.h b/ghc/compiler/yaccParser/list.h deleted file mode 100644 index cbd9014..0000000 --- a/ghc/compiler/yaccParser/list.h +++ /dev/null @@ -1,79 +0,0 @@ -#ifndef list_defined -#define list_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/list.ugn b/ghc/compiler/yaccParser/list.ugn deleted file mode 100644 index 3606f20..0000000 --- a/ghc/compiler/yaccParser/list.ugn +++ /dev/null @@ -1,13 +0,0 @@ -%{ -#include "hspincl.h" -%} -%{{ -module U_list where -import UgenUtil -import Util -%}} -type list; - lcons : < lhd : VOID_STAR; - ltl : list; >; - lnil : <>; -end; diff --git a/ghc/compiler/yaccParser/listcomp.c b/ghc/compiler/yaccParser/listcomp.c deleted file mode 100644 index 6258869..0000000 --- a/ghc/compiler/yaccParser/listcomp.c +++ /dev/null @@ -1,67 +0,0 @@ -/* - 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)))); - } -} diff --git a/ghc/compiler/yaccParser/literal.c b/ghc/compiler/yaccParser/literal.c deleted file mode 100644 index 509db3a..0000000 --- a/ghc/compiler/yaccParser/literal.c +++ /dev/null @@ -1,321 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/literal.h b/ghc/compiler/yaccParser/literal.h deleted file mode 100644 index bf3599f..0000000 --- a/ghc/compiler/yaccParser/literal.h +++ /dev/null @@ -1,390 +0,0 @@ -#ifndef literal_defined -#define literal_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/literal.ugn b/ghc/compiler/yaccParser/literal.ugn deleted file mode 100644 index f35f54f..0000000 --- a/ghc/compiler/yaccParser/literal.ugn +++ /dev/null @@ -1,25 +0,0 @@ -%{ -#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; diff --git a/ghc/compiler/yaccParser/main.c b/ghc/compiler/yaccParser/main.c deleted file mode 100644 index ea1accd..0000000 --- a/ghc/compiler/yaccParser/main.c +++ /dev/null @@ -1,55 +0,0 @@ -/* This is the "top-level" file for the *standalone* hsp parser. - See also hsclink.c. (WDP 94/10) -*/ - -#include - -#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); - } -} diff --git a/ghc/compiler/yaccParser/pbinding.c b/ghc/compiler/yaccParser/pbinding.c deleted file mode 100644 index 4ea35b6..0000000 --- a/ghc/compiler/yaccParser/pbinding.c +++ /dev/null @@ -1,81 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/pbinding.h b/ghc/compiler/yaccParser/pbinding.h deleted file mode 100644 index 204979c..0000000 --- a/ghc/compiler/yaccParser/pbinding.h +++ /dev/null @@ -1,126 +0,0 @@ -#ifndef pbinding_defined -#define pbinding_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/pbinding.ugn b/ghc/compiler/yaccParser/pbinding.ugn deleted file mode 100644 index b7386f4..0000000 --- a/ghc/compiler/yaccParser/pbinding.ugn +++ /dev/null @@ -1,23 +0,0 @@ -%{ -#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; diff --git a/ghc/compiler/yaccParser/printtree.c b/ghc/compiler/yaccParser/printtree.c deleted file mode 100644 index d276110..0000000 --- a/ghc/compiler/yaccParser/printtree.c +++ /dev/null @@ -1,984 +0,0 @@ -/********************************************************************** -* * -* * -* Syntax Tree Printing Routines * -* * -* * -**********************************************************************/ - - -#define COMPACT TRUE /* No spaces in output -- #undef this for debugging */ - - -#include - -#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"); - } -} diff --git a/ghc/compiler/yaccParser/syntax.c b/ghc/compiler/yaccParser/syntax.c deleted file mode 100644 index e64f978..0000000 --- a/ghc/compiler/yaccParser/syntax.c +++ /dev/null @@ -1,781 +0,0 @@ -/********************************************************************** -* * -* * -* Syntax-related Utility Functions * -* * -* * -**********************************************************************/ - -#include -#include - -#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); - } - } -} - diff --git a/ghc/compiler/yaccParser/tests/Jmakefile b/ghc/compiler/yaccParser/tests/Jmakefile deleted file mode 100644 index e69de29..0000000 diff --git a/ghc/compiler/yaccParser/tree-DPH.ugn b/ghc/compiler/yaccParser/tree-DPH.ugn deleted file mode 100644 index 1b68dcd..0000000 --- a/ghc/compiler/yaccParser/tree-DPH.ugn +++ /dev/null @@ -1,80 +0,0 @@ -%{ -#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; diff --git a/ghc/compiler/yaccParser/tree.c b/ghc/compiler/yaccParser/tree.c deleted file mode 100644 index 43d0167..0000000 --- a/ghc/compiler/yaccParser/tree.c +++ /dev/null @@ -1,869 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/tree.h b/ghc/compiler/yaccParser/tree.h deleted file mode 100644 index 0f715d7..0000000 --- a/ghc/compiler/yaccParser/tree.h +++ /dev/null @@ -1,1100 +0,0 @@ -#ifndef tree_defined -#define tree_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/tree.ugn b/ghc/compiler/yaccParser/tree.ugn deleted file mode 100644 index decf7e3..0000000 --- a/ghc/compiler/yaccParser/tree.ugn +++ /dev/null @@ -1,85 +0,0 @@ -%{ -#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; diff --git a/ghc/compiler/yaccParser/ttype-DPH.ugn b/ghc/compiler/yaccParser/ttype-DPH.ugn deleted file mode 100644 index dd0209b..0000000 --- a/ghc/compiler/yaccParser/ttype-DPH.ugn +++ /dev/null @@ -1,23 +0,0 @@ -%{ -#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; - diff --git a/ghc/compiler/yaccParser/ttype.c b/ghc/compiler/yaccParser/ttype.c deleted file mode 100644 index e31a744..0000000 --- a/ghc/compiler/yaccParser/ttype.c +++ /dev/null @@ -1,301 +0,0 @@ - - -#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); -} diff --git a/ghc/compiler/yaccParser/ttype.h b/ghc/compiler/yaccParser/ttype.h deleted file mode 100644 index 900c23e..0000000 --- a/ghc/compiler/yaccParser/ttype.h +++ /dev/null @@ -1,376 +0,0 @@ -#ifndef ttype_defined -#define ttype_defined - -#include - -#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 diff --git a/ghc/compiler/yaccParser/ttype.ugn b/ghc/compiler/yaccParser/ttype.ugn deleted file mode 100644 index 63ed306..0000000 --- a/ghc/compiler/yaccParser/ttype.ugn +++ /dev/null @@ -1,31 +0,0 @@ -%{ -#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: ; - uniforall : < guniforall_tv : list; - guniforall_ty : ttype; >; - - ty_maybe_nothing : < >; - ty_maybe_just : < gty_maybe : ttype; >; -end; - diff --git a/ghc/compiler/yaccParser/type2context.c b/ghc/compiler/yaccParser/type2context.c deleted file mode 100644 index 1be4394..0000000 --- a/ghc/compiler/yaccParser/type2context.c +++ /dev/null @@ -1,160 +0,0 @@ -/********************************************************************** -* * -* * -* Convert Types to Contexts * -* * -* * -**********************************************************************/ - - -#include -#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"); - } -} - diff --git a/ghc/compiler/yaccParser/util.c b/ghc/compiler/yaccParser/util.c deleted file mode 100644 index 12aa070..0000000 --- a/ghc/compiler/yaccParser/util.c +++ /dev/null @@ -1,309 +0,0 @@ -/********************************************************************** -* * -* * -* 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 #-} - - (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 -# 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); -} diff --git a/ghc/compiler/yaccParser/utils.h b/ghc/compiler/yaccParser/utils.h deleted file mode 100644 index 3b5b2ed..0000000 --- a/ghc/compiler/yaccParser/utils.h +++ /dev/null @@ -1,139 +0,0 @@ -/* - 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 */ -- 1.7.10.4