Commit 3160f854 authored by sof's avatar sof

[project @ 1999-01-14 17:58:41 by sof]

Assorted minor Haskell 98 changes:

  * Maximal munch rule for "--" comments
  * _ as lower-case letter, "_" is a reserved id. Prefixing unused
    variable names in patterns with '_' causes the renamer not to
    report such names as being unused.
  * allow empty decls
  * comprehensions are now list comprehensions, not monadic.
  * use Monad.fail to signal pattern matching errors within
    do expressions.
  * remove record punning.
  * empty contexts are now legal  (go wild!)
  * allow records with no fields
  * allow newtypes with a labelled field
  * default default is now (Integer, Double)
  * turn off defaulting mechanism for args & res to a _ccall_.
  * allow LHSs of the form  (a -.- b) x = ...
  * Main.main can now have type (IO a)
  * nuked Void (and its use in the compiler sources.)
  * deriving machinery for Enum now also generate 'succ' and 'pred'
    method bindings.
parent 882e459f
......@@ -20,6 +20,7 @@ module MkId (
mkDataConId,
mkRecordSelId,
mkNewTySelId,
mkPrimitiveId
) where
......@@ -240,6 +241,40 @@ mkRecordSelId field_label selector_ty
\end{code}
%************************************************************************
%* *
\subsection{Newtype field selectors}
%* *
%************************************************************************
Possibly overkill to do it this way:
\begin{code}
mkNewTySelId field_label selector_ty = sel_id
where
sel_id = mkId (fieldLabelName field_label) selector_ty
(RecordSelId field_label) info
info = exactArity 1 `setArityInfo` (
unfolding `setUnfoldingInfo`
noIdInfo)
-- ToDo: consider adding further IdInfo
unfolding = mkUnfolding sel_rhs
(tyvars, theta, tau) = splitSigmaTy selector_ty
(data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
-- tau is of form (T a b c -> field-type)
(tycon, _, data_cons) = splitAlgTyConApp data_ty
tyvar_tys = mkTyVarTys tyvars
[data_id] = mkTemplateLocals [data_ty]
sel_rhs = mkLams tyvars $ Lam data_id $
Note (Coerce rhs_ty data_ty) (Var data_id)
\end{code}
%************************************************************************
%* *
\subsection{Dictionary selectors}
......
......@@ -3,3 +3,4 @@ _exports_
Name Name;
_declarations_
1 data Name;
......@@ -20,6 +20,7 @@ module OccName (
mkClassTyConOcc, mkClassDataConOcc,
isTvOcc, isTCOcc, isVarOcc, isConSymOcc, isConOcc, isSymOcc,
isWildCardOcc, isAnonOcc,
pprOccName, occNameString, occNameFlavour,
-- The basic form of names
......@@ -390,7 +391,7 @@ occNameFlavour (OccName TvOcc _ _ _) = "Type variable"
occNameFlavour (OccName TCOcc s _ _) = "Type constructor or class"
isVarOcc, isTCOcc, isTvOcc,
isConSymOcc, isSymOcc :: OccName -> Bool
isConSymOcc, isSymOcc, isWildCardOcc :: OccName -> Bool
isVarOcc (OccName VarOcc _ _ _) = True
isVarOcc other = False
......@@ -406,6 +407,10 @@ isConSymOcc (OccName _ s _ _) = isLexConSym s
isSymOcc (OccName _ s _ _) = isLexSym s
isConOcc (OccName _ s _ _) = isLexCon s
isWildCardOcc (OccName _ s _ _) = (_HEAD_ s) == '_' && _LENGTH_ s == 1
isAnonOcc (OccName _ s _ _) = (_HEAD_ s) == '_'
\end{code}
......
......@@ -49,11 +49,13 @@ module Unique (
arrayPrimTyConKey,
assertIdKey,
augmentIdKey,
bindIOIdKey,
boolTyConKey,
boundedClassKey,
boxedConKey,
buildIdKey,
byteArrayPrimTyConKey,
byteArrayTyConKey,
cCallableClassKey,
cReturnableClassKey,
charDataConKey,
......@@ -61,6 +63,7 @@ module Unique (
charTyConKey,
concatIdKey,
consDataConKey,
deRefStablePtrIdKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
......@@ -73,6 +76,7 @@ module Unique (
eqClassOpKey,
errorIdKey,
falseDataConKey,
failMClassOpKey,
filterIdKey,
floatDataConKey,
floatPrimTyConKey,
......@@ -83,7 +87,6 @@ module Unique (
foreignObjDataConKey,
foreignObjPrimTyConKey,
foreignObjTyConKey,
weakPrimTyConKey,
fractionalClassKey,
fromEnumClassOpKey,
fromIntClassOpKey,
......@@ -117,13 +120,14 @@ module Unique (
ixClassKey,
listTyConKey,
mainKey,
makeStablePtrIdKey,
mapIdKey,
minusClassOpKey,
monadClassKey,
monadPlusClassKey,
monadZeroClassKey,
mutableArrayPrimTyConKey,
mutableByteArrayPrimTyConKey,
mutableByteArrayTyConKey,
mutVarPrimTyConKey,
nilDataConKey,
noMethodBindingErrorIdKey,
......@@ -169,6 +173,7 @@ module Unique (
toEnumClassOpKey,
traceIdKey,
trueDataConKey,
unboundKey,
unboxedConKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
......@@ -176,8 +181,7 @@ module Unique (
unpackCStringIdKey,
unsafeCoerceIdKey,
ushowListIdKey,
voidIdKey,
voidTyConKey,
weakPrimTyConKey,
wordDataConKey,
wordPrimTyConKey,
wordTyConKey,
......@@ -190,14 +194,7 @@ module Unique (
word64DataConKey,
word64PrimTyConKey,
word64TyConKey,
zeroClassOpKey,
zipIdKey,
bindIOIdKey,
deRefStablePtrIdKey,
makeStablePtrIdKey,
unboundKey,
byteArrayTyConKey,
mutableByteArrayTyConKey
zipIdKey
) where
#include "HsVersions.h"
......@@ -464,21 +461,20 @@ floatingClassKey = mkPreludeClassUnique 5
fractionalClassKey = mkPreludeClassUnique 6
integralClassKey = mkPreludeClassUnique 7
monadClassKey = mkPreludeClassUnique 8
monadZeroClassKey = mkPreludeClassUnique 9
monadPlusClassKey = mkPreludeClassUnique 10
functorClassKey = mkPreludeClassUnique 11
numClassKey = mkPreludeClassUnique 12
ordClassKey = mkPreludeClassUnique 13
readClassKey = mkPreludeClassUnique 14
realClassKey = mkPreludeClassUnique 15
realFloatClassKey = mkPreludeClassUnique 16
realFracClassKey = mkPreludeClassUnique 17
showClassKey = mkPreludeClassUnique 18
monadPlusClassKey = mkPreludeClassUnique 9
functorClassKey = mkPreludeClassUnique 10
numClassKey = mkPreludeClassUnique 11
ordClassKey = mkPreludeClassUnique 12
readClassKey = mkPreludeClassUnique 13
realClassKey = mkPreludeClassUnique 14
realFloatClassKey = mkPreludeClassUnique 15
realFracClassKey = mkPreludeClassUnique 16
showClassKey = mkPreludeClassUnique 17
cCallableClassKey = mkPreludeClassUnique 19
cReturnableClassKey = mkPreludeClassUnique 20
cCallableClassKey = mkPreludeClassUnique 18
cReturnableClassKey = mkPreludeClassUnique 19
ixClassKey = mkPreludeClassUnique 21
ixClassKey = mkPreludeClassUnique 20
\end{code}
%************************************************************************
......@@ -534,14 +530,13 @@ word16TyConKey = mkPreludeTyConUnique 60
word32TyConKey = mkPreludeTyConUnique 61
word64PrimTyConKey = mkPreludeTyConUnique 62
word64TyConKey = mkPreludeTyConUnique 63
voidTyConKey = mkPreludeTyConUnique 64
boxedConKey = mkPreludeTyConUnique 65
unboxedConKey = mkPreludeTyConUnique 66
anyBoxConKey = mkPreludeTyConUnique 67
kindConKey = mkPreludeTyConUnique 68
boxityConKey = mkPreludeTyConUnique 69
typeConKey = mkPreludeTyConUnique 70
threadIdPrimTyConKey = mkPreludeTyConUnique 71
boxedConKey = mkPreludeTyConUnique 64
unboxedConKey = mkPreludeTyConUnique 65
anyBoxConKey = mkPreludeTyConUnique 66
kindConKey = mkPreludeTyConUnique 67
boxityConKey = mkPreludeTyConUnique 68
typeConKey = mkPreludeTyConUnique 69
threadIdPrimTyConKey = mkPreludeTyConUnique 70
\end{code}
%************************************************************************
......@@ -615,15 +610,14 @@ unpackCString2IdKey = mkPreludeMiscIdUnique 27
unpackCStringAppendIdKey = mkPreludeMiscIdUnique 28
unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 29
unpackCStringIdKey = mkPreludeMiscIdUnique 30
voidIdKey = mkPreludeMiscIdUnique 31
ushowListIdKey = mkPreludeMiscIdUnique 32
unsafeCoerceIdKey = mkPreludeMiscIdUnique 33
concatIdKey = mkPreludeMiscIdUnique 34
filterIdKey = mkPreludeMiscIdUnique 35
zipIdKey = mkPreludeMiscIdUnique 36
bindIOIdKey = mkPreludeMiscIdUnique 37
deRefStablePtrIdKey = mkPreludeMiscIdUnique 38
makeStablePtrIdKey = mkPreludeMiscIdUnique 39
ushowListIdKey = mkPreludeMiscIdUnique 31
unsafeCoerceIdKey = mkPreludeMiscIdUnique 32
concatIdKey = mkPreludeMiscIdUnique 33
filterIdKey = mkPreludeMiscIdUnique 34
zipIdKey = mkPreludeMiscIdUnique 35
bindIOIdKey = mkPreludeMiscIdUnique 36
deRefStablePtrIdKey = mkPreludeMiscIdUnique 37
makeStablePtrIdKey = mkPreludeMiscIdUnique 38
\end{code}
Certain class operations from Prelude classes. They get their own
......@@ -641,7 +635,7 @@ enumFromToClassOpKey = mkPreludeMiscIdUnique 107
enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108
eqClassOpKey = mkPreludeMiscIdUnique 109
geClassOpKey = mkPreludeMiscIdUnique 110
zeroClassOpKey = mkPreludeMiscIdUnique 112
failMClassOpKey = mkPreludeMiscIdUnique 112
thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
-- Just a place holder for unbound variables produced by the renamer:
unboundKey = mkPreludeMiscIdUnique 114
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.18 1998/12/22 12:55:55 simonm Exp $
% $Id: CgExpr.lhs,v 1.19 1999/01/14 17:58:46 sof Exp $
%
%********************************************************
%* *
......@@ -18,6 +18,7 @@ import Constants ( mAX_SPEC_SELECTEE_SIZE, mAX_SPEC_AP_SIZE )
import StgSyn
import CgMonad
import AbsCSyn
import AbsCUtils ( mkAbstractCs )
import CLabel ( mkClosureTblLabel )
import SMRep ( fixedHdrSize )
......@@ -423,15 +424,29 @@ Little helper for primitives that return unboxed tuples.
\begin{code}
primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
primRetUnboxedTuple op args res_ty
= let (tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of
Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
Just pr -> pr
prim_reps = map typePrimRep ty_args
temp_uniqs = map mkBuiltinUnique [0..length ty_args]
temp_amodes = zipWith CTemp temp_uniqs prim_reps
= getArgAmodes args `thenFC` \ arg_amodes ->
{-
put all the arguments in temporaries so they don't get stomped when
we push the return address.
-}
let
n_args = length args
arg_uniqs = map mkBuiltinUnique [0 .. n_args-1]
arg_reps = map getArgPrimRep args
arg_temps = zipWith CTemp arg_uniqs arg_reps
in
absC (mkAbstractCs (zipWith CAssign arg_temps arg_amodes)) `thenC`
{-
allocate some temporaries for the return values.
-}
let
(tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of
Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
Just pr -> pr
prim_reps = map typePrimRep ty_args
temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
returnUnboxedTuple temp_amodes
(getArgAmodes args `thenFC` \ arg_amodes ->
absC (COpStmt temp_amodes op arg_amodes []))
returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
\end{code}
......@@ -4,3 +4,4 @@ DsExpr dsExpr dsLet;
_declarations_
1 dsExpr _:_ TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
1 dsLet _:_ TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;;
......@@ -35,7 +35,7 @@ import FieldLabel ( FieldLabel )
import Id ( Id, idType, recordSelectorFieldLabel )
import Const ( Con(..) )
import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels )
import Const ( mkMachInt, Literal(..) )
import Const ( mkMachInt, Literal(..), mkStrLit )
import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
......@@ -328,7 +328,7 @@ dsExpr (HsLet binds body)
= dsExpr body `thenDs` \ body' ->
dsLet binds body'
dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc)
dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc)
| maybeToBool maybe_list_comp
= -- Special case for list comprehensions
putSrcLocDs src_loc $
......@@ -336,7 +336,7 @@ dsExpr (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty src_loc)
| otherwise
= putSrcLocDs src_loc $
dsDo do_or_lc stmts return_id then_id zero_id result_ty
dsDo do_or_lc stmts return_id then_id fail_id result_ty
where
maybe_list_comp
= case (do_or_lc, splitTyConApp_maybe result_ty) of
......@@ -563,7 +563,6 @@ dsExpr (DictApp expr dicts) -- becomes a curried application
\begin{code}
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
dsExpr (HsDo _ _ _) = panic "dsExpr:HsDo"
......@@ -585,11 +584,11 @@ dsDo :: StmtCtxt
-> [TypecheckedStmt]
-> Id -- id for: return m
-> Id -- id for: (>>=) m
-> Id -- id for: zero m
-> Id -- id for: fail m
-> Type -- Element type; the whole expression has type (m t)
-> DsM CoreExpr
dsDo do_or_lc stmts return_id then_id zero_id result_ty
dsDo do_or_lc stmts return_id then_id fail_id result_ty
= let
(_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b)
......@@ -600,7 +599,12 @@ dsDo do_or_lc stmts return_id then_id zero_id result_ty
go (GuardStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
returnDs (mkIfThenElse expr2 rest (App (Var zero_id) (Type b_ty)))
let msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
returnDs (mkIfThenElse expr2
rest
(App (App (Var fail_id)
(Type b_ty))
(mkLit (mkStrLit msg stringTy))))
go (ExprStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
......@@ -624,13 +628,17 @@ dsDo do_or_lc stmts return_id then_id zero_id result_ty
dsExpr expr `thenDs` \ expr2 ->
let
(_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
zero_expr = TyApp (HsVar zero_id) [b_ty]
main_match = mkSimpleMatch [pat] (HsDoOut do_or_lc stmts return_id then_id zero_id result_ty locn)
fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLitOut (HsString (_PK_ msg)) stringTy)
msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
(HsDoOut do_or_lc stmts return_id then_id fail_id result_ty locn)
(Just result_ty) locn
the_matches
= if failureFreePat pat
then [main_match]
else [main_match, mkSimpleMatch [WildPat a_ty] zero_expr (Just result_ty) locn]
| failureFreePat pat = [main_match]
| otherwise =
[ main_match
, mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn
]
in
matchWrapper DoBindMatch the_matches match_msg
`thenDs` \ (binders, matching_code) ->
......
......@@ -276,8 +276,9 @@ data ConDetails name
| RecCon -- record-style con decl
[([name], BangType name)] -- list of "fields"
| NewCon -- newtype con decl
| NewCon -- newtype con decl, possibly with a labelled field.
(HsType name)
(Maybe name) -- Just x => labelled field 'x'
data BangType name
= Banged (HsType name) -- HsType: to allow Haskell extensions
......@@ -295,9 +296,14 @@ ppr_con_details con (InfixCon ty1 ty2)
ppr_con_details con (VanillaCon tys)
= ppr con <+> hsep (map (ppr_bang) tys)
ppr_con_details con (NewCon ty)
ppr_con_details con (NewCon ty Nothing)
= ppr con <+> pprParendHsType ty
ppr_con_details con (NewCon ty (Just x))
= ppr con <+> braces pp_field
where
pp_field = ppr x <+> dcolon <+> pprParendHsType ty
ppr_con_details con (RecCon fields)
= ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
where
......
......@@ -4,3 +4,4 @@ HsExpr HsExpr pprExpr;
_declarations_
1 data HsExpr i p;
1 pprExpr _:_ _forall_ [i p] {Name.NamedThing i, Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;;
......@@ -34,6 +34,7 @@ type constr;
/* constr in simple "newtype" form: */
constrnew : < gconnid : qid;
gconnty : ttype;
gconnla : maybe; /* Maybe qvar */
gconnline : long; >;
/* constr with a existential prefixed context C => ... */
......
......@@ -137,6 +137,8 @@ static void new_filename PROTO((char *));
static int Return PROTO((int));
static void hsentercontext PROTO((int));
static BOOLEAN is_commment PROTO((char*, int));
/* Special file handling for IMPORTS */
/* Note: imports only ever go *one deep* (hence no need for a stack) WDP 94/09 */
......@@ -242,7 +244,7 @@ F {N}"."{N}(("e"|"E")("+"|"-")?{N})?
S [!#$%&*+./<=>?@\\^|\-~:\xa1-\xbf\xd7\xf7]
SId {S}{S}*
L [A-Z\xc0-\xd6\xd8-\xde]
l [a-z\xdf-\xf6\xf8-\xff]
l [a-z_\xdf-\xf6\xf8-\xff]
I {L}|{l}
i {L}|{l}|[0-9'_]
Id {I}{i}*
......@@ -268,7 +270,6 @@ NL [\n\r]
*/
%}
<Code,GlaExt,StringEsc>"--"[^\n\r]*{NL}?{WS}* |
<Code,GlaExt,UserPragma,StringEsc>{WS}+ { noGap = FALSE; }
%{
......@@ -430,7 +431,6 @@ NL [\n\r]
<Code,GlaExt,UserPragma>"," { RETURN(COMMA); }
<Code,GlaExt>";" { RETURN(SEMI); }
<Code,GlaExt>"`" { RETURN(BQUOTE); }
<Code,GlaExt>"_" { RETURN(WILDCARD); }
<Code,GlaExt>"." { RETURN(DOT); }
<Code,GlaExt>".." { RETURN(DOTDOT); }
......@@ -536,8 +536,16 @@ NL [\n\r]
RETURN(isconstr(yytext) ? CONID : VARID);
}
<Code,GlaExt,UserPragma>{SId} {
hsnewid(yytext, yyleng);
RETURN(isconstr(yytext) ? CONSYM : VARSYM);
if (is_commment(yytext,yyleng)) {
int c;
while ((c = input()) != '\n' && c != '\r' && c!= EOF )
;
if (c != EOF)
unput(c);
} else {
hsnewid(yytext, yyleng);
RETURN(isconstr(yytext) ? CONSYM : VARSYM);
}
}
<Code,GlaExt,UserPragma>{Mod}"."{Id}"#" {
BOOLEAN is_constr;
......@@ -737,6 +745,19 @@ NL [\n\r]
<CharEsc>\\ { addchar(*yytext); POP_STATE; }
<StringEsc>\\ { if (noGap) { addchar(*yytext); } POP_STATE; }
%{
/*
Not 100% correct, tokenizes "foo \ --<>--
\ bar"
as "foo bar", but this is not correct as per Haskell 98 report and its
maximal munch rule for "--"-style comments.
For the moment, not deemed worthy to fix.
*/
%}
<StringEsc>"--"[^\n\r]*{NL}?{WS}* { noGap=FALSE; }
<CharEsc,StringEsc>["'] { addchar(*yytext); POP_STATE; }
<CharEsc,StringEsc>NUL { addchar('\000'); POP_STATE; }
<CharEsc,StringEsc>SOH { addchar('\001'); POP_STATE; }
......@@ -837,6 +858,7 @@ NL [\n\r]
<Comment>"-}" { if (--nested_comments == 0) POP_STATE; }
<Comment>(.|\n) ;
%{
/*
* Illegal characters. This used to be a single rule, but we might as well
......@@ -974,6 +996,11 @@ new_filename(char *f) /* This looks pretty dodgy to me (WDP) */
forcing insertion of ; or } as appropriate
*/
#ifdef HSP_DEBUG
#define LAYOUT_DEBUG
#endif
static BOOLEAN
hsshouldindent(void)
{
......@@ -985,7 +1012,7 @@ hsshouldindent(void)
void
hssetindent(void)
{
#ifdef HSP_DEBUG
#ifdef LAYOUT_DEBUG
fprintf(stderr, "hssetindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
#endif
......@@ -1014,7 +1041,7 @@ hssetindent(void)
void
hsincindent(void)
{
#ifdef HSP_DEBUG
#ifdef LAYOUT_DEBUG
fprintf(stderr, "hsincindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
#endif
hsentercontext(indenttab[icontexts] & ~1);
......@@ -1042,7 +1069,7 @@ hsentercontext(int indent)
}
forgetindent = FALSE;
indenttab[icontexts] = indent;
#ifdef HSP_DEBUG
#ifdef LAYOUT_DEBUG
fprintf(stderr, "hsentercontext:indent=%d,hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", indent, hscolno, hspcolno, icontexts, INDENTPT);
#endif
}
......@@ -1053,7 +1080,7 @@ void
hsendindent(void)
{
--icontexts;
#ifdef HSP_DEBUG
#ifdef LAYOUT_DEBUG
fprintf(stderr, "hsendindent:hscolno=%d,hspcolno=%d,INDENTPT[%d]=%d\n", hscolno, hspcolno, icontexts, INDENTPT);
#endif
}
......@@ -1061,14 +1088,12 @@ hsendindent(void)
/*
* 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
......@@ -1084,6 +1109,7 @@ Return(int tok)
return (SEMI);
}
}
hssttok = -1;
#ifdef HSP_DEBUG
fprintf(stderr, "returning %d (%d:%d)\n", tok, hspcolno, INDENTPT);
......@@ -1344,3 +1370,21 @@ hsnewqid(char *name, int length)
return isconstr(dot+1);
}
static
BOOLEAN
is_commment(char* lexeme, int len)
{
char* ptr;
int i;
if (len < 2) {
return FALSE;
}
for(i=0;i<len;i++) {
if (lexeme[i] != '-') return FALSE;
}
return TRUE;
}
......@@ -128,7 +128,7 @@ BOOLEAN pat_check=TRUE;
%token OCURLY CCURLY VCCURLY
%token COMMA SEMI OBRACK CBRACK
%token WILDCARD BQUOTE OPAREN CPAREN
%token BQUOTE OPAREN CPAREN
%token OUNBOXPAREN CUNBOXPAREN
......@@ -232,10 +232,10 @@ BOOLEAN pat_check=TRUE;
dorest stmts stmt
rbinds rbinds1 rpats rpats1 list_exps list_rest
qvarsk qvars_list
constrs constr1 fields conargatypes
constrs fields conargatypes
tautypes atypes
types_and_maybe_ids
pats simple_context simple_context_list
pats simple_context simple_context_list
export_list enames
import_list inames
impdecls maybeimpdecls impdecl
......@@ -274,10 +274,10 @@ BOOLEAN pat_check=TRUE;
gcon gconk gtycon itycon qop1 qvarop1
ename iname
%type <ubinding> topdecl topdecls letdecls
%type <ubinding> topdecl topdecls topdecls1 letdecls
typed datad newtd classd instd defaultd foreignd
decl decls fixdecl fix_op fix_ops valdef
maybe_where cbody rinst type_and_maybe_id
decl decls decls1 fixdecl fix_op fix_ops valdef
maybe_where type_and_maybe_id