2 * Copyright (c) 2009, Vincent Berthoux
4 * This source code is released for free distribution under the terms of the
5 * GNU General Public License.
7 * This module contains functions for generating tags for Objective Caml
13 #include "general.h" /* must always come first */
24 /* To get rid of unused parameter warning in
27 #elif defined(__GNUC__)
28 # define UNUSED(x) UNUSED_ ## x __attribute__((unused))
29 #elif defined(__LCLINT__)
30 # define UNUSED(x) /*@unused@*/ x
34 #define OCAML_MAX_STACK_SIZE 256
37 K_CLASS
, /* Ocaml class, relatively rare */
38 K_METHOD
, /* class method */
39 K_MODULE
, /* Ocaml module OR functor */
41 K_TYPE
, /* name of an OCaml type */
43 K_CONSTRUCTOR
, /* Constructor of a sum type */
48 static kindOption OcamlKinds
[] = {
49 {TRUE
, 'c', "class", "classes"},
50 {TRUE
, 'm', "method", "Object's method"},
51 {TRUE
, 'M', "module", "Module or functor"},
52 {TRUE
, 'v', "var", "Global variable"},
53 {TRUE
, 't', "type", "Type name"},
54 {TRUE
, 'f', "function", "A function"},
55 {TRUE
, 'C', "Constructor", "A constructor"},
56 {TRUE
, 'r', "Record field", "A 'structure' field"},
57 {TRUE
, 'e', "Exception", "An exception"}
102 Tok_Val
, /* string/number/poo */
103 Tok_Op
, /* any operator recognized by the language */
108 Tok_Backslash
, /* '\\' */
110 Tok_EOF
/* END of file */
113 typedef struct sOcaKeywordDesc
{
118 typedef ocamlKeyword ocaToken
;
120 static const ocaKeywordDesc OcamlKeywordTable
[] = {
121 { "and" , OcaKEYWORD_and
},
122 { "begin" , OcaKEYWORD_begin
},
123 { "class" , OcaKEYWORD_class
},
124 { "do" , OcaKEYWORD_do
},
125 { "done" , OcaKEYWORD_done
},
126 { "else" , OcaKEYWORD_else
},
127 { "end" , OcaKEYWORD_end
},
128 { "exception" , OcaKEYWORD_exception
},
129 { "for" , OcaKEYWORD_for
},
130 { "fun" , OcaKEYWORD_fun
},
131 { "function" , OcaKEYWORD_fun
},
132 { "functor" , OcaKEYWORD_functor
},
133 { "in" , OcaKEYWORD_in
},
134 { "let" , OcaKEYWORD_let
},
135 { "match" , OcaKEYWORD_match
},
136 { "method" , OcaKEYWORD_method
},
137 { "module" , OcaKEYWORD_module
},
138 { "mutable" , OcaKEYWORD_mutable
},
139 { "object" , OcaKEYWORD_object
},
140 { "of" , OcaKEYWORD_of
},
141 { "rec" , OcaKEYWORD_rec
},
142 { "sig" , OcaKEYWORD_sig
},
143 { "struct" , OcaKEYWORD_struct
},
144 { "then" , OcaKEYWORD_then
},
145 { "try" , OcaKEYWORD_try
},
146 { "type" , OcaKEYWORD_type
},
147 { "val" , OcaKEYWORD_val
},
148 { "value" , OcaKEYWORD_let
}, /* just to handle revised syntax */
149 { "virtual" , OcaKEYWORD_virtual
},
150 { "while" , OcaKEYWORD_while
},
151 { "with" , OcaKEYWORD_with
},
155 { "land " , Tok_Op
},
157 { "lxor " , Tok_Op
},
162 { "true" , Tok_Val
},
163 { "false" , Tok_Val
}
166 static langType Lang_Ocaml
;
168 boolean exportLocalInfo
= FALSE
;
170 /*//////////////////////////////////////////////////////////////////
172 typedef struct _lexingState
{
173 vString
*name
; /* current parsed identifier/operator */
174 const unsigned char *cp
; /* position in stream */
177 /* array of the size of all possible value for a char */
178 boolean isOperator
[1 << (8 * sizeof (char))] = { FALSE
};
180 static void initKeywordHash ( void )
182 const size_t count
= sizeof (OcamlKeywordTable
) / sizeof (ocaKeywordDesc
);
185 for (i
= 0; i
< count
; ++i
)
187 addKeyword (OcamlKeywordTable
[i
].name
, Lang_Ocaml
,
188 (int) OcamlKeywordTable
[i
].id
);
192 /* definition of all the operator in OCaml,
193 * /!\ certain operator get special treatment
194 * in regards of their role in OCaml grammar :
195 * '|' ':' '=' '~' and '?' */
196 static void initOperatorTable ( void )
198 isOperator
['!'] = TRUE
;
199 isOperator
['$'] = TRUE
;
200 isOperator
['%'] = TRUE
;
201 isOperator
['&'] = TRUE
;
202 isOperator
['*'] = TRUE
;
203 isOperator
['+'] = TRUE
;
204 isOperator
['-'] = TRUE
;
205 isOperator
['.'] = TRUE
;
206 isOperator
['/'] = TRUE
;
207 isOperator
[':'] = TRUE
;
208 isOperator
['<'] = TRUE
;
209 isOperator
['='] = TRUE
;
210 isOperator
['>'] = TRUE
;
211 isOperator
['?'] = TRUE
;
212 isOperator
['@'] = TRUE
;
213 isOperator
['^'] = TRUE
;
214 isOperator
['~'] = TRUE
;
215 isOperator
['|'] = TRUE
;
218 /*//////////////////////////////////////////////////////////////////////
220 static boolean
isNum (char c
)
222 return c
>= '0' && c
<= '9';
224 static boolean
isLowerAlpha (char c
)
226 return c
>= 'a' && c
<= 'z';
229 static boolean
isUpperAlpha (char c
)
231 return c
>= 'A' && c
<= 'Z';
234 static boolean
isAlpha (char c
)
236 return isLowerAlpha (c
) || isUpperAlpha (c
);
239 static boolean
isIdent (char c
)
241 return isNum (c
) || isAlpha (c
) || c
== '_' || c
== '\'';
244 static boolean
isSpace (char c
)
246 return c
== ' ' || c
== '\t' || c
== '\r' || c
== '\n';
249 static void eatWhiteSpace (lexingState
* st
)
251 const unsigned char *cp
= st
->cp
;
252 while (isSpace (*cp
))
258 static void eatString (lexingState
* st
)
260 boolean lastIsBackSlash
= FALSE
;
261 boolean unfinished
= TRUE
;
262 const unsigned char *c
= st
->cp
+ 1;
266 /* end of line should never happen.
268 if (c
== NULL
|| c
[0] == '\0')
270 else if (*c
== '"' && !lastIsBackSlash
)
273 lastIsBackSlash
= *c
== '\\';
281 static void eatComment (lexingState
* st
)
283 boolean unfinished
= TRUE
;
284 boolean lastIsStar
= FALSE
;
285 const unsigned char *c
= st
->cp
+ 2;
289 /* we've reached the end of the line..
290 * so we have to reload a line... */
291 if (c
== NULL
|| *c
== '\0')
293 st
->cp
= fileReadLine ();
294 /* WOOPS... no more input...
295 * we return, next lexing read
296 * will be null and ok */
302 /* we've reached the end of the comment */
303 else if (*c
== ')' && lastIsStar
)
305 /* here we deal with imbricated comment, which
306 * are allowed in OCaml */
307 else if (c
[0] == '(' && c
[1] == '*')
315 lastIsStar
= '*' == *c
;
323 static void readIdentifier (lexingState
* st
)
325 const unsigned char *p
;
326 vStringClear (st
->name
);
328 /* first char is a simple letter */
329 if (isAlpha (*st
->cp
) || *st
->cp
== '_')
330 vStringPut (st
->name
, (int) *st
->cp
);
332 /* Go till you get identifier chars */
333 for (p
= st
->cp
+ 1; isIdent (*p
); p
++)
334 vStringPut (st
->name
, (int) *p
);
338 vStringTerminate (st
->name
);
341 static ocamlKeyword
eatNumber (lexingState
* st
)
343 while (isNum (*st
->cp
))
348 /* Operator can be defined in OCaml as a function
349 * so we must be ample enough to parse them normally */
350 static ocamlKeyword
eatOperator (lexingState
* st
)
353 const unsigned char *root
= st
->cp
;
355 vStringClear (st
->name
);
357 while (isOperator
[st
->cp
[count
]])
359 vStringPut (st
->name
, st
->cp
[count
]);
363 vStringTerminate (st
->name
);
378 else if (count
== 2 && root
[0] == '-' && root
[1] == '>')
384 /* The lexer is in charge of reading the file.
385 * Some of sub-lexer (like eatComment) also read file.
386 * lexing is finished when the lexer return Tok_EOF */
387 static ocamlKeyword
lex (lexingState
* st
)
390 /* handling data input here */
391 while (st
->cp
== NULL
|| st
->cp
[0] == '\0')
393 st
->cp
= fileReadLine ();
398 if (isAlpha (*st
->cp
))
401 retType
= lookupKeyword (vStringValue (st
->name
), Lang_Ocaml
);
403 if (retType
== -1) /* If it's not a keyword */
405 return OcaIDENTIFIER
;
412 else if (isNum (*st
->cp
))
413 return eatNumber (st
);
414 else if (isSpace (*st
->cp
))
419 /* OCaml permit the definition of our own operators
420 * so here we check all the consecuting chars which
421 * are operators to discard them. */
422 else if (isOperator
[*st
->cp
])
423 return eatOperator (st
);
428 if (st
->cp
[1] == '*') /* ergl, a comment */
477 return Tok_Backslash
;
484 /* default return if nothing is recognized,
485 * shouldn't happen, but at least, it will
486 * be handled without destroying the parsing. */
490 /*//////////////////////////////////////////////////////////////////////
492 typedef void (*parseNext
) (vString
* const ident
, ocaToken what
);
494 /********** Helpers */
495 /* This variable hold the 'parser' which is going to
496 * handle the next token */
499 /* Special variable used by parser eater to
500 * determine which action to put after their
501 * job is finished. */
504 /* If a token put an end to current delcaration/
506 ocaToken terminatingToken
;
508 /* Token to be searched by the different
510 ocaToken waitedToken
;
512 /* name of the last class, used for
513 * context stacking. */
518 typedef enum _sContextKind
{
523 typedef enum _sContextType
{
533 typedef struct _sOcamlContext
{
534 contextKind kind
; /* well if the context is strong or not */
536 parseNext callback
; /* what to do when a context is pop'd */
537 vString
*contextName
; /* name, if any, of the surrounding context */
540 /* context stack, can be used to output scope information
541 * into the tag file. */
542 ocamlContext stack
[OCAML_MAX_STACK_SIZE
];
543 /* current position in the tag */
546 /* special function, often recalled, so putting it here */
547 static void globalScope (vString
* const ident
, ocaToken what
);
549 /* Return : index of the last named context if one
550 * is found, -1 otherwise */
551 static int getLastNamedIndex ( void )
555 for (i
= stackIndex
- 1; i
>= 0; --i
)
557 if (stack
[i
].contextName
->buffer
&&
558 strlen (stack
[i
].contextName
->buffer
) > 0)
567 static const char *contextDescription (contextType t
)
571 case ContextFunction
:
590 static char contextTypeSuffix (contextType t
)
594 case ContextFunction
:
610 /* Push a new context, handle null string */
611 static void pushContext (contextKind kind
, contextType type
, parseNext after
,
612 vString
const *contextName
)
616 if (stackIndex
>= OCAML_MAX_STACK_SIZE
)
618 verbose ("OCaml Maximum depth reached");
623 stack
[stackIndex
].kind
= kind
;
624 stack
[stackIndex
].type
= type
;
625 stack
[stackIndex
].callback
= after
;
627 parentIndex
= getLastNamedIndex ();
628 if (contextName
== NULL
)
630 vStringClear (stack
[stackIndex
++].contextName
);
634 if (parentIndex
>= 0)
636 vStringCopy (stack
[stackIndex
].contextName
,
637 stack
[parentIndex
].contextName
);
638 vStringPut (stack
[stackIndex
].contextName
,
639 contextTypeSuffix (stack
[parentIndex
].type
));
641 vStringCat (stack
[stackIndex
].contextName
, contextName
);
644 vStringCopy (stack
[stackIndex
].contextName
, contextName
);
649 static void pushStrongContext (vString
* name
, contextType type
)
651 pushContext (ContextStrong
, type
, &globalScope
, name
);
654 static void pushSoftContext (parseNext continuation
,
655 vString
* name
, contextType type
)
657 pushContext (ContextSoft
, type
, continuation
, name
);
660 static void pushEmptyContext (parseNext continuation
)
662 pushContext (ContextSoft
, ContextValue
, continuation
, NULL
);
665 /* unroll the stack until the last named context.
666 * then discard it. Used to handle the :
669 * where the context is reseted after the in. Context may have
670 * been really nested before that. */
671 static void popLastNamed ( void )
673 int i
= getLastNamedIndex ();
678 toDoNext
= stack
[i
].callback
;
679 vStringClear (stack
[i
].contextName
);
683 /* ok, no named context found...
684 * (should not happen). */
686 toDoNext
= &globalScope
;
690 /* pop a context without regarding it's content
691 * (beside handling empty stack case) */
692 static void popSoftContext ( void )
696 toDoNext
= &globalScope
;
701 toDoNext
= stack
[stackIndex
].callback
;
702 vStringClear (stack
[stackIndex
].contextName
);
706 /* Reset everything until the last global space.
707 * a strong context can be :
710 * - the initial global space
711 * - a _global_ delcaration (let at global scope or in a module).
712 * Created to exit quickly deeply nested context */
713 static contextType
popStrongContext ( void )
717 for (i
= stackIndex
- 1; i
>= 0; --i
)
719 if (stack
[i
].kind
== ContextStrong
)
722 toDoNext
= stack
[i
].callback
;
723 vStringClear (stack
[i
].contextName
);
724 return stack
[i
].type
;
727 /* ok, no strong context found... */
729 toDoNext
= &globalScope
;
733 /* Ignore everything till waitedToken and jump to comeAfter.
734 * If the "end" keyword is encountered break, doesn't remember
736 static void tillToken (vString
* const UNUSED (ident
), ocaToken what
)
738 if (what
== waitedToken
)
739 toDoNext
= comeAfter
;
740 else if (what
== OcaKEYWORD_end
)
743 toDoNext
= &globalScope
;
747 /* Ignore everything till a waitedToken is seen, but
748 * take care of balanced parentheses/bracket use */
749 static void contextualTillToken (vString
* const UNUSED (ident
), ocaToken what
)
751 static int parentheses
= 0;
752 static int bracket
= 0;
753 static int curly
= 0;
776 default: /* other token are ignored */
780 if (what
== waitedToken
&& parentheses
== 0 && bracket
== 0 && curly
== 0)
781 toDoNext
= comeAfter
;
783 else if (what
== OcaKEYWORD_end
)
786 toDoNext
= &globalScope
;
790 /* Wait for waitedToken and jump to comeAfter or let
791 * the globalScope handle declarations */
792 static void tillTokenOrFallback (vString
* const ident
, ocaToken what
)
794 if (what
== waitedToken
)
795 toDoNext
= comeAfter
;
797 globalScope (ident
, what
);
800 /* ignore token till waitedToken, or give up if find
801 * terminatingToken. Use globalScope to handle new
803 static void tillTokenOrTerminatingOrFallback (vString
* const ident
,
806 if (what
== waitedToken
)
807 toDoNext
= comeAfter
;
808 else if (what
== terminatingToken
)
809 toDoNext
= globalScope
;
811 globalScope (ident
, what
);
814 /* ignore the next token in the stream and jump to the
815 * given comeAfter state */
816 static void ignoreToken (vString
* const UNUSED (ident
), ocaToken
UNUSED (what
))
818 toDoNext
= comeAfter
;
821 /********** Grammar */
822 /* the purpose of each function is detailled near their
825 static void killCurrentState ( void )
828 /* Tracking the kind of previous strong
829 * context, if it doesn't match with a
830 * really strong entity, repop */
831 switch (popStrongContext ())
837 case ContextFunction
:
859 /* used to prepare tag for OCaml, just in case their is a need to
860 * add additional information to the tag. */
861 static void prepareTag (tagEntryInfo
* tag
, vString
const *name
, ocamlKind kind
)
865 initTagEntry (tag
, vStringValue (name
));
866 tag
->kindName
= OcamlKinds
[kind
].name
;
867 tag
->kind
= OcamlKinds
[kind
].letter
;
869 parentIndex
= getLastNamedIndex ();
870 if (parentIndex
>= 0)
872 tag
->extensionFields
.scope
[0] =
873 contextDescription (stack
[parentIndex
].type
);
874 tag
->extensionFields
.scope
[1] =
875 vStringValue (stack
[parentIndex
].contextName
);
879 /* Used to centralise tag creation, and be able to add
880 * more information to it in the future */
881 static void addTag (vString
* const ident
, int kind
)
883 tagEntryInfo toCreate
;
884 prepareTag (&toCreate
, ident
, kind
);
885 makeTagEntry (&toCreate
);
888 boolean needStrongPoping
= FALSE
;
889 static void requestStrongPoping ( void )
891 needStrongPoping
= TRUE
;
894 static void cleanupPreviousParser ( void )
896 if (needStrongPoping
)
898 needStrongPoping
= FALSE
;
903 /* Due to some circular dependencies, the following functions
904 * must be forward-declared. */
905 static void letParam (vString
* const ident
, ocaToken what
);
906 static void localScope (vString
* const ident
, ocaToken what
);
907 static void mayRedeclare (vString
* const ident
, ocaToken what
);
908 static void typeSpecification (vString
* const ident
, ocaToken what
);
911 * Parse a record type
912 * type ident = // parsed previously
918 static void typeRecord (vString
* const ident
, ocaToken what
)
923 addTag (ident
, K_RECORDFIELD
);
924 terminatingToken
= Tok_CurlR
;
925 waitedToken
= Tok_semi
;
926 comeAfter
= &typeRecord
;
927 toDoNext
= &tillTokenOrTerminatingOrFallback
;
930 case OcaKEYWORD_mutable
:
936 toDoNext
= &globalScope
;
939 default: /* don't care */
945 * exception ExceptionName ... */
946 static void exceptionDecl (vString
* const ident
, ocaToken what
)
948 if (what
== OcaIDENTIFIER
)
950 addTag (ident
, K_EXCEPTION
);
952 /* don't know what to do on else... */
954 toDoNext
= &globalScope
;
957 tagEntryInfo tempTag
;
960 /* Ensure a constructor is not a type path beginning
962 static void constructorValidation (vString
* const ident
, ocaToken what
)
966 case Tok_Op
: /* if we got a '.' which is an operator */
967 toDoNext
= &globalScope
;
969 needStrongPoping
= FALSE
;
972 case OcaKEYWORD_of
: /* OK, it must be a constructor :) */
973 makeTagEntry (&tempTag
);
974 vStringClear (tempIdent
);
975 toDoNext
= &tillTokenOrFallback
;
976 comeAfter
= &typeSpecification
;
977 waitedToken
= Tok_Pipe
;
980 case Tok_Pipe
: /* OK, it was a constructor :) */
981 makeTagEntry (&tempTag
);
982 vStringClear (tempIdent
);
983 toDoNext
= &typeSpecification
;
986 default: /* and mean that we're not facing a module name */
987 makeTagEntry (&tempTag
);
988 vStringClear (tempIdent
);
989 toDoNext
= &tillTokenOrFallback
;
990 comeAfter
= &typeSpecification
;
991 waitedToken
= Tok_Pipe
;
993 /* nothing in the context, discard it */
996 /* to be sure we use this token */
997 globalScope (ident
, what
);
1002 /* Parse beginning of type definition
1003 * type 'avar ident =
1005 * type ('var1, 'var2) ident =
1007 static void typeDecl (vString
* const ident
, ocaToken what
)
1014 comeAfter
= &typeDecl
;
1015 toDoNext
= &ignoreToken
;
1017 /* LOTS of parameters */
1019 comeAfter
= &typeDecl
;
1020 waitedToken
= Tok_PARR
;
1021 toDoNext
= &tillToken
;
1025 addTag (ident
, K_TYPE
);
1026 pushStrongContext (ident
, ContextType
);
1027 requestStrongPoping ();
1028 waitedToken
= Tok_EQ
;
1029 comeAfter
= &typeSpecification
;
1030 toDoNext
= &tillTokenOrFallback
;
1034 globalScope (ident
, what
);
1038 /* Parse type of kind
1039 * type bidule = Ctor1 of ...
1043 * type bidule = | Ctor1 of ... | Ctor2
1045 * when type bidule = { ... } is detected,
1046 * let typeRecord handle it. */
1047 static void typeSpecification (vString
* const ident
, ocaToken what
)
1053 if (isUpperAlpha (ident
->buffer
[0]))
1055 /* here we handle type aliases of type
1056 * type foo = AnotherModule.bar
1057 * AnotherModule can mistakenly be took
1058 * for a constructor. */
1059 vStringCopy (tempIdent
, ident
);
1060 prepareTag (&tempTag
, tempIdent
, K_CONSTRUCTOR
);
1061 toDoNext
= &constructorValidation
;
1065 toDoNext
= &tillTokenOrFallback
;
1066 comeAfter
= &typeSpecification
;
1067 waitedToken
= Tok_Pipe
;
1071 case OcaKEYWORD_and
:
1072 toDoNext
= &typeDecl
;
1075 case Tok_BRL
: /* the '[' & ']' are ignored to accommodate */
1076 case Tok_BRR
: /* with the revised syntax */
1078 /* just ignore it */
1082 toDoNext
= &typeRecord
;
1085 default: /* don't care */
1091 static boolean dirtySpecialParam
= FALSE
;
1094 /* parse the ~label and ~label:type parameter */
1095 static void parseLabel (vString
* const ident
, ocaToken what
)
1097 static int parCount
= 0;
1102 if (!dirtySpecialParam
)
1105 if (exportLocalInfo
)
1106 addTag (ident
, K_VAR
);
1108 dirtySpecialParam
= TRUE
;
1119 toDoNext
= &letParam
;
1123 if (ident
->buffer
[0] == ':')
1125 toDoNext
= &ignoreToken
;
1126 comeAfter
= &letParam
;
1128 else if (parCount
== 0 && dirtySpecialParam
)
1130 toDoNext
= &letParam
;
1131 letParam (ident
, what
);
1136 if (parCount
== 0 && dirtySpecialParam
)
1138 toDoNext
= &letParam
;
1139 letParam (ident
, what
);
1146 /* Optional argument with syntax like this :
1148 static void parseOptionnal (vString
* const ident
, ocaToken what
)
1150 static int parCount
= 0;
1156 if (!dirtySpecialParam
)
1158 if (exportLocalInfo
)
1159 addTag (ident
, K_VAR
);
1161 dirtySpecialParam
= TRUE
;
1164 toDoNext
= &letParam
;
1175 toDoNext
= &letParam
;
1178 default: /* don't care */
1184 /** handle let inside functions (so like it's name
1185 * say : local let */
1186 static void localLet (vString
* const ident
, ocaToken what
)
1191 /* We ignore this token to be able to parse such
1193 * let (ident : type) = ...
1197 case OcaKEYWORD_rec
:
1198 /* just ignore to be able to parse such declarations:
1199 * let rec ident = ... */
1203 /* we are defining a new operator, it's a
1204 * function definition */
1205 if (exportLocalInfo
)
1206 addTag (ident
, K_FUNCTION
);
1208 pushSoftContext (mayRedeclare
, ident
, ContextFunction
);
1209 toDoNext
= &letParam
;
1212 /* Can be a weiiird binding, or an '_' */
1214 if (exportLocalInfo
)
1215 addTag (ident
, K_VAR
);
1216 pushSoftContext (mayRedeclare
, ident
, ContextValue
);
1217 toDoNext
= &letParam
;
1221 if (exportLocalInfo
)
1222 addTag (ident
, K_VAR
);
1223 pushSoftContext (mayRedeclare
, ident
, ContextValue
);
1224 toDoNext
= &letParam
;
1227 case OcaKEYWORD_end
:
1228 popStrongContext ();
1232 toDoNext
= &localScope
;
1238 * | pattern pattern -> ...
1240 * pattern apttern apttern -> ...
1241 * we ignore all identifiers declared in the pattern,
1242 * because their scope is likely to be even more limited
1243 * than the let definitions.
1244 * Used after a match ... with, or a function ... or fun ...
1245 * because their syntax is similar. */
1246 static void matchPattern (vString
* const UNUSED (ident
), ocaToken what
)
1251 pushEmptyContext (&matchPattern
);
1252 toDoNext
= &mayRedeclare
;
1265 /* Used at the beginning of a new scope (begin of a
1266 * definition, parenthesis...) to catch inner let
1267 * definition that may be in. */
1268 static void mayRedeclare (vString
* const ident
, ocaToken what
)
1272 case OcaKEYWORD_let
:
1273 case OcaKEYWORD_val
:
1274 toDoNext
= localLet
;
1277 case OcaKEYWORD_object
:
1278 vStringClear (lastClass
);
1279 pushContext (ContextStrong
, ContextClass
,
1280 &localScope
, NULL
/*voidName */ );
1281 needStrongPoping
= FALSE
;
1282 toDoNext
= &globalScope
;
1285 case OcaKEYWORD_for
:
1286 case OcaKEYWORD_while
:
1287 toDoNext
= &tillToken
;
1288 waitedToken
= OcaKEYWORD_do
;
1289 comeAfter
= &mayRedeclare
;
1292 case OcaKEYWORD_try
:
1293 toDoNext
= &mayRedeclare
;
1294 pushSoftContext (matchPattern
, ident
, ContextFunction
);
1297 case OcaKEYWORD_fun
:
1298 toDoNext
= &matchPattern
;
1301 /* Handle the special ;; from the OCaml
1305 toDoNext
= &localScope
;
1306 localScope (ident
, what
);
1311 * p1 p2 ... pn = ...
1313 * ?(p1=v) p2 ~p3 ~pn:ja ... = ... */
1314 static void letParam (vString
* const ident
, ocaToken what
)
1319 toDoNext
= &mayRedeclare
;
1323 if (exportLocalInfo
)
1324 addTag (ident
, K_VAR
);
1328 switch (ident
->buffer
[0])
1331 /*popSoftContext(); */
1332 /* we got a type signature */
1333 comeAfter
= &mayRedeclare
;
1334 toDoNext
= &tillTokenOrFallback
;
1335 waitedToken
= Tok_EQ
;
1338 /* parse something like
1343 * ~(varname: long type) */
1345 toDoNext
= &parseLabel
;
1346 dirtySpecialParam
= FALSE
;
1349 /* Optional argument with syntax like this :
1354 toDoNext
= &parseOptionnal
;
1355 dirtySpecialParam
= FALSE
;
1363 default: /* don't care */
1370 * used to be sure the class definition is not a type
1372 static void classSpecif (vString
* const UNUSED (ident
), ocaToken what
)
1376 case OcaKEYWORD_object
:
1377 pushStrongContext (lastClass
, ContextClass
);
1378 toDoNext
= &globalScope
;
1382 vStringClear (lastClass
);
1383 toDoNext
= &globalScope
;
1387 /* Handle a method ... class declaration.
1388 * nearly a copy/paste of globalLet. */
1389 static void methodDecl (vString
* const ident
, ocaToken what
)
1394 /* We ignore this token to be able to parse such
1396 * let (ident : type) = ... */
1399 case OcaKEYWORD_mutable
:
1400 case OcaKEYWORD_virtual
:
1401 case OcaKEYWORD_rec
:
1402 /* just ignore to be able to parse such declarations:
1403 * let rec ident = ... */
1407 addTag (ident
, K_METHOD
);
1408 /* Normal pushing to get good subs */
1409 pushStrongContext (ident
, ContextMethod
);
1410 /*pushSoftContext( globalScope, ident, ContextMethod ); */
1411 toDoNext
= &letParam
;
1414 case OcaKEYWORD_end
:
1415 popStrongContext ();
1419 toDoNext
= &globalScope
;
1424 /* name of the last module, used for
1425 * context stacking. */
1426 vString
*lastModule
;
1430 * ... struct (* new global scope *) end
1432 * ... sig (* new global scope *) end
1434 * functor ... -> moduleSpecif
1436 static void moduleSpecif (vString
* const ident
, ocaToken what
)
1440 case OcaKEYWORD_functor
:
1441 toDoNext
= &contextualTillToken
;
1442 waitedToken
= Tok_To
;
1443 comeAfter
= &moduleSpecif
;
1446 case OcaKEYWORD_struct
:
1447 case OcaKEYWORD_sig
:
1448 pushStrongContext (lastModule
, ContextModule
);
1449 toDoNext
= &globalScope
;
1452 case Tok_PARL
: /* ( */
1453 toDoNext
= &contextualTillToken
;
1454 comeAfter
= &globalScope
;
1455 waitedToken
= Tok_PARR
;
1456 contextualTillToken (ident
, what
);
1460 vStringClear (lastModule
);
1461 toDoNext
= &globalScope
;
1467 * then pass the token stream to moduleSpecif */
1468 static void moduleDecl (vString
* const ident
, ocaToken what
)
1472 case OcaKEYWORD_type
:
1473 /* just ignore it, name come after */
1477 addTag (ident
, K_MODULE
);
1478 vStringCopy (lastModule
, ident
);
1479 waitedToken
= Tok_EQ
;
1480 comeAfter
= &moduleSpecif
;
1481 toDoNext
= &contextualTillToken
;
1484 default: /* don't care */
1492 * class virtual ['a,'b] classname = ... */
1493 static void classDecl (vString
* const ident
, ocaToken what
)
1498 addTag (ident
, K_CLASS
);
1499 vStringCopy (lastClass
, ident
);
1500 toDoNext
= &contextualTillToken
;
1501 waitedToken
= Tok_EQ
;
1502 comeAfter
= &classSpecif
;
1506 toDoNext
= &tillToken
;
1507 waitedToken
= Tok_BRR
;
1508 comeAfter
= &classDecl
;
1519 * let rec ident ... */
1520 static void globalLet (vString
* const ident
, ocaToken what
)
1525 /* We ignore this token to be able to parse such
1527 * let (ident : type) = ...
1531 case OcaKEYWORD_mutable
:
1532 case OcaKEYWORD_virtual
:
1533 case OcaKEYWORD_rec
:
1534 /* just ignore to be able to parse such declarations:
1535 * let rec ident = ... */
1539 /* we are defining a new operator, it's a
1540 * function definition */
1541 addTag (ident
, K_FUNCTION
);
1542 pushStrongContext (ident
, ContextFunction
);
1543 toDoNext
= &letParam
;
1547 addTag (ident
, K_VAR
);
1548 pushStrongContext (ident
, ContextValue
);
1549 requestStrongPoping ();
1550 toDoNext
= &letParam
;
1553 case OcaKEYWORD_end
:
1554 popStrongContext ();
1558 toDoNext
= &globalScope
;
1563 /* Handle the "strong" top levels, all 'big' declarations
1565 static void globalScope (vString
* const UNUSED (ident
), ocaToken what
)
1567 /* Do not touch, this is used only by the global scope
1568 * to handle an 'and' */
1569 static parseNext previousParser
= NULL
;
1573 case OcaKEYWORD_and
:
1574 cleanupPreviousParser ();
1575 toDoNext
= previousParser
;
1578 case OcaKEYWORD_type
:
1579 cleanupPreviousParser ();
1580 toDoNext
= &typeDecl
;
1581 previousParser
= &typeDecl
;
1584 case OcaKEYWORD_class
:
1585 cleanupPreviousParser ();
1586 toDoNext
= &classDecl
;
1587 previousParser
= &classDecl
;
1590 case OcaKEYWORD_module
:
1591 cleanupPreviousParser ();
1592 toDoNext
= &moduleDecl
;
1593 previousParser
= &moduleDecl
;
1596 case OcaKEYWORD_end
:
1597 needStrongPoping
= FALSE
;
1598 killCurrentState ();
1599 /*popStrongContext(); */
1602 case OcaKEYWORD_method
:
1603 cleanupPreviousParser ();
1604 toDoNext
= &methodDecl
;
1605 /* and is not allowed in methods */
1608 /* val is mixed with let as global
1609 * to be able to handle mli & new syntax */
1610 case OcaKEYWORD_val
:
1611 case OcaKEYWORD_let
:
1612 cleanupPreviousParser ();
1613 toDoNext
= &globalLet
;
1614 previousParser
= &globalLet
;
1617 case OcaKEYWORD_exception
:
1618 cleanupPreviousParser ();
1619 toDoNext
= &exceptionDecl
;
1620 previousParser
= NULL
;
1623 /* must be a #line directive, discard the
1635 /* Parse expression. Well ignore it is more the case,
1636 * ignore all tokens except "shocking" keywords */
1637 static void localScope (vString
* const ident
, ocaToken what
)
1648 /* Everything that `begin` has an `end`
1649 * as end is overloaded and signal many end
1650 * of things, we add an empty strong context to
1651 * avoid problem with the end.
1653 case OcaKEYWORD_begin
:
1654 pushContext (ContextStrong
, ContextBlock
, &mayRedeclare
, NULL
);
1655 toDoNext
= &mayRedeclare
;
1662 /* Ok, we got a '{', which is much likely to create
1663 * a record. We cannot treat it like other [ && (,
1664 * because it may contain the 'with' keyword and screw
1665 * everything else. */
1667 toDoNext
= &contextualTillToken
;
1668 waitedToken
= Tok_CurlR
;
1669 comeAfter
= &localScope
;
1670 contextualTillToken (ident
, what
);
1673 /* Yeah imperative feature of OCaml,
1674 * a ';' like in C */
1676 toDoNext
= &mayRedeclare
;
1681 pushEmptyContext (&localScope
);
1682 toDoNext
= &mayRedeclare
;
1685 case OcaKEYWORD_and
:
1687 toDoNext
= &localLet
;
1690 case OcaKEYWORD_else
:
1691 case OcaKEYWORD_then
:
1693 pushEmptyContext (&localScope
);
1694 toDoNext
= &mayRedeclare
;
1698 pushEmptyContext (&localScope
);
1699 toDoNext
= &mayRedeclare
;
1702 case OcaKEYWORD_match
:
1703 pushEmptyContext (&localScope
);
1704 toDoNext
= &mayRedeclare
;
1707 case OcaKEYWORD_with
:
1709 toDoNext
= &matchPattern
;
1710 pushEmptyContext (&matchPattern
);
1713 case OcaKEYWORD_end
:
1714 killCurrentState ();
1718 case OcaKEYWORD_fun
:
1719 comeAfter
= &mayRedeclare
;
1720 toDoNext
= &tillToken
;
1721 waitedToken
= Tok_To
;
1724 case OcaKEYWORD_done
:
1725 case OcaKEYWORD_val
:
1730 requestStrongPoping ();
1731 globalScope (ident
, what
);
1736 /*////////////////////////////////////////////////////////////////
1737 //// Deal with the system */
1738 /* in OCaml the file name is the module name used in the language
1739 * with it first letter put in upper case */
1740 static void computeModuleName ( void )
1742 /* in Ocaml the file name define a module.
1743 * so we define a module =)
1745 const char *filename
= getSourceFileName ();
1747 int endIndex
= strlen (filename
) - 1;
1748 vString
*moduleName
= vStringNew ();
1750 while (filename
[endIndex
] != '.' && endIndex
> 0)
1753 /* avoid problem with path in front of filename */
1754 beginIndex
= endIndex
;
1755 while (beginIndex
> 0)
1757 if (filename
[beginIndex
] == '\\' || filename
[beginIndex
] == '/')
1766 vStringNCopyS (moduleName
, &filename
[beginIndex
], endIndex
- beginIndex
);
1767 vStringTerminate (moduleName
);
1769 if (isLowerAlpha (moduleName
->buffer
[0]))
1770 moduleName
->buffer
[0] += ('A' - 'a');
1772 makeSimpleTag (moduleName
, OcamlKinds
, K_MODULE
);
1773 vStringDelete (moduleName
);
1776 /* Allocate all string of the context stack */
1777 static void initStack ( void )
1780 for (i
= 0; i
< OCAML_MAX_STACK_SIZE
; ++i
)
1781 stack
[i
].contextName
= vStringNew ();
1784 static void clearStack ( void )
1787 for (i
= 0; i
< OCAML_MAX_STACK_SIZE
; ++i
)
1788 vStringDelete (stack
[i
].contextName
);
1791 static void findOcamlTags (void)
1793 vString
*name
= vStringNew ();
1797 computeModuleName ();
1799 tempIdent
= vStringNew ();
1800 lastModule
= vStringNew ();
1801 lastClass
= vStringNew ();
1802 voidName
= vStringNew ();
1803 vStringCopyS (voidName
, "_");
1805 st
.name
= vStringNew ();
1806 st
.cp
= fileReadLine ();
1807 toDoNext
= &globalScope
;
1809 while (tok
!= Tok_EOF
)
1811 (*toDoNext
) (st
.name
, tok
);
1815 vStringDelete (name
);
1816 vStringDelete (voidName
);
1817 vStringDelete (tempIdent
);
1818 vStringDelete (lastModule
);
1819 vStringDelete (lastClass
);
1823 static void ocamlInitialize (const langType language
)
1825 Lang_Ocaml
= language
;
1827 initOperatorTable ();
1831 extern parserDefinition
*OcamlParser (void)
1833 static const char *const extensions
[] = { "ml", "mli", NULL
};
1834 parserDefinition
*def
= parserNew ("OCaml");
1835 def
->kinds
= OcamlKinds
;
1836 def
->kindCount
= KIND_COUNT (OcamlKinds
);
1837 def
->extensions
= extensions
;
1838 def
->parser
= findOcamlTags
;
1839 def
->initialize
= ocamlInitialize
;