1 //////////////////////////////////////////////////////////////////////////////
2 // This file is part of Teyjus. //
3 // //
4 // Teyjus is free software: you can redistribute it and/or modify //
5 // it under the terms of the GNU General Public License as published by //
6 // the Free Software Foundation, either version 3 of the License, or //
7 // (at your option) any later version. //
8 // //
9 // Teyjus is distributed in the hope that it will be useful, //
10 // but WITHOUT ANY WARRANTY; without even the implied warranty of //
11 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the //
12 // GNU General Public License for more details. //
13 // //
14 // You should have received a copy of the GNU General Public License //
15 // along with Teyjus. If not, see <http://www.gnu.org/licenses/>. //
16 //////////////////////////////////////////////////////////////////////////////
17 /***************************************************************************/
18 /* ocamlcode.c. */
19 /* This file defines auxiliary functions in making pervasive.mli and */
20 /* pervasive.ml. */
21 /* Since space and time efficiency is not an important concern in the */
22 /* system source code generation phase, the code here is structured in the */
23 /* way for the convenience of making changes on pervasive.mli{ml}. */
24 /***************************************************************************/
25 #include <stdio.h>
26 #include <stdlib.h>
27 #include <string.h>
28
29 #include "ocamlcode.h"
30
31 /***************************************************************************/
32 /* Functions for making various language constructs */
33 /***************************************************************************/
34 /* Make a string of form <first>.<second> */
OC_mkDotStr(char * first,char * second)35 static char* OC_mkDotStr(char* first, char* second)
36 {
37 size_t length = strlen(first) + strlen(second) + 1;
38 char* ptr = UTIL_mallocStr(length+1);
39
40 strcpy(ptr, first);
41 strcat(ptr, ".");
42 strcat(ptr, second);
43
44 return ptr;
45 }
46
47 /*
48 (Some <info>)
49 */
OC_mkSome(char * info)50 char* OC_mkSome(char* info)
51 {
52 size_t length = strlen(info) + 10;
53 char* rtptr = UTIL_mallocStr(length + 1);
54
55 strcpy(rtptr, "(Some ");
56 strcat(rtptr, info);
57 strcat(rtptr, ")");
58
59 return rtptr;
60 }
61
62 /*
63 (ref <info>)
64 */
OC_mkRef(char * info)65 char* OC_mkRef(char* info)
66 {
67 size_t length = strlen(info) + 10;
68 char* rtptr = UTIL_mallocStr(length + 1);
69
70 strcpy(rtptr, "(ref ");
71 strcat(rtptr, info);
72 strcat(rtptr, ")");
73
74 return rtptr;
75 }
76
77
78 /* Make a variable definition:
79 let <varName> = <defs>
80 */
OC_mkVarDef(char * varName,char * defs)81 static char* OC_mkVarDef(char* varName, char* defs)
82 {
83 size_t length = strlen(varName) + strlen(defs) + 10;
84 char* vardef = UTIL_mallocStr(length + 1);
85
86 strcpy(vardef, "let ");
87 strcat(vardef, varName);
88 strcat(vardef, " = ");
89 strcat(vardef, defs);
90
91 return vardef;
92 }
93
94 /* Make a variable declaration:
95 val <varName> : <varType>"\n"
96 */
OC_mkVarDec(char * varName,char * varType)97 static char* OC_mkVarDec(char* varName, char* varType)
98 {
99 size_t length = strlen(varName) + strlen(varType) + 10;
100 char* vardec = UTIL_mallocStr(length + 1);
101
102 strcpy(vardec, "val ");
103 strcat(vardec, varName);
104 strcat(vardec, " : ");
105 strcat(vardec, varType);
106 strcat(vardec, "\n");
107
108 return vardec;
109 }
110
111 /* Make arrow type:
112 <type1> -> <type2>
113 */
OC_mkArrowType(char * ty1,char * ty2)114 static char* OC_mkArrowType(char* ty1, char* ty2)
115 {
116 size_t length = strlen(ty1) + strlen(ty2) + 5;
117 char* arrowType = UTIL_mallocStr(length);
118
119 strcpy(arrowType, ty1);
120 strcat(arrowType, " -> ");
121 strcat(arrowType, ty2);
122 return arrowType;
123 }
124
125
126 /**************************************************************************/
127 /* Names from other modules */
128 /**************************************************************************/
129 /********************************************************/
130 /* Fixities */
131 /********************************************************/
132 #define INFIX "Absyn.Infix"
133 #define INFIXL "Absyn.Infixl"
134 #define INFIXR "Absyn.Infixr"
135 #define PREFIX "Absyn.Prefix"
136 #define PREFIXR "Absyn.Prefixr"
137 #define POSTFIX "Absyn.Postfix"
138 #define POSTFIXL "Absyn.Postfixl"
139 #define NOFIXITY "Absyn.NoFixity"
140
141 #define MAXPREC "maxPrec + 1"
142
143 /********************************************************/
144 /* module names */
145 /********************************************************/
146 #define ABSYN "Absyn"
147 #define SYMBOL "Symbol"
148 #define ERRORMSG "Errormsg"
149 #define TABLE "Table"
150
151 /********************************************************/
152 /* types */
153 /********************************************************/
154 //absyn
155 #define TY_KIND "akind"
156 #define TY_CONST "aconstant"
157 #define TY_TERM "aterm"
158 #define TY_TYABBREV "atypeabbrev"
159 //table
160 #define TY_SYMTAB "SymbolTable.t"
161
162 /********************************************************/
163 /* value constructors */
164 /********************************************************/
165 //absyn
166 #define VCTR_KIND "Kind"
167 #define VCTR_KINDTYPE "PervasiveKind"
168 #define VCTR_CONSTANT "Constant"
169 #define VCTR_PERVCONST "PervasiveConstant"
170 #define VCTR_TYSKEL "Skeleton"
171 #define VCTR_APPTYPE "ApplicationType"
172 #define VCTR_ARROWTYPE "ArrowType"
173 #define VCTR_SKELVARTYPE "SkeletonVarType"
174 #define VCTR_BUILTIN "Builtin"
175
176 //errormsg
177 #define VCTR_NULLPOS "none"
178
179 //symbol
180 #define VCTR_SYMBOL "symbol"
181 #define VCTR_SYMBOL_ALIAS "symbolAlias"
182
183 //table
184 #define VCTR_EMPTYTAB "SymbolTable.empty"
185
186 /********************************************************/
187 /* functions */
188 /********************************************************/
189 //table
190 #define FUNC_ADD "add"
191 //absyn
192 #define FUNC_MAKETYSETVAR "makeTypeSetVariable"
193
194 /***************************************************************************/
195 /* Local names */
196 /***************************************************************************/
197 #define BUILDPERVKIND "buildPervasiveKinds"
198 #define BUILDPERVCONST "buildPervasiveConstants"
199
200 #define PERVKIND "pervasiveKinds"
201 #define PERVCONST "pervasiveConstants"
202 #define PERVTYABBR "pervasiveTypeAbbrevs"
203
204 #define KVAR_PREFIX "k"
205 #define CVAR_POSTFIX "Constant"
206 #define TSKVAR_PREFIX "tyskel"
207 #define TAB "t"
208
209 #define IS "is"
210 #define SETVARIR "tysetvarIR"
211 #define SETVARIRS "tysetvarIRS"
212 #define OVERLOADTYSKEL1 "overloadTySkel1"
213 #define OVERLOADTYSKEL2 "overloadTySkel2"
214 #define OVERLOADTYSKEL3 "overloadTySkel3"
215
216 /***************************************************************************/
217 /* Functions for making program components */
218 /***************************************************************************/
219 /*
220 (Symbol.symbol "<name>")
221 */
OC_mkSymbol(char * name)222 static char* OC_mkSymbol(char* name)
223 {
224 char* symbolCtr = OC_mkDotStr(SYMBOL, VCTR_SYMBOL);
225 size_t length = strlen(symbolCtr) + strlen(name) + 10;
226 char* rtptr= UTIL_mallocStr(length + 1);
227
228 strcpy(rtptr, "(");
229 strcat(rtptr, symbolCtr); free(symbolCtr);
230 strcat(rtptr, " \"");
231 strcat(rtptr, name);
232 strcat(rtptr, "\")");
233 return rtptr;
234 }
235
236 /*
237 (Symbol.symbolAlias "<name>" "<printName>")
238 */
OC_mkSymbolAlias(char * name,char * printName)239 static char* OC_mkSymbolAlias(char *name, char *printName)
240 {
241 char* symbolCtr = OC_mkDotStr(SYMBOL, VCTR_SYMBOL_ALIAS);
242 size_t length = strlen(symbolCtr) + strlen(name) + strlen(printName) + 10;
243 char* rtptr= UTIL_mallocStr(length + 1);
244
245 strcpy(rtptr, "(");
246 strcat(rtptr, symbolCtr); free(symbolCtr);
247 strcat(rtptr, " \"");
248 strcat(rtptr, name);
249 strcat(rtptr, "\" \"");
250 strcat(rtptr, printName);
251 strcat(rtptr, "\")");
252 return rtptr;
253 }
254
255 /* let t = Table.add (Symbol.symbol "<name>") <varName> t in\n
256 */
OC_mkTabEntry(char * name,char * varName)257 char* OC_mkTabEntry(char* name, char* varName)
258 {
259 char* entry;
260 char* tableAdd = OC_mkDotStr(TABLE, FUNC_ADD);
261 char* symbol = OC_mkSymbol(name);
262 size_t length = strlen(tableAdd) + strlen(symbol) + strlen(varName) +
263 strlen(TAB) + 15;
264 char* def = UTIL_mallocStr(length + 1);
265
266 strcpy(def, tableAdd); free(tableAdd);
267 strcat(def, " ");
268 strcat(def, symbol); free(symbol);
269 strcat(def, " ");
270 strcat(def, varName);
271 strcat(def, " ");
272 strcat(def, TAB);
273 strcat(def, " in\n ");
274
275 entry = OC_mkVarDef(TAB, def); free(def);
276 return entry;
277 }
278
279 /* let t = Table.SymbolTable.empty in \n*/
OC_mkTabInit()280 static char* OC_mkTabInit()
281 {
282 char* init;
283 char* emptyTab = OC_mkDotStr(TABLE, VCTR_EMPTYTAB);
284 size_t length = strlen(emptyTab) + 10;
285 char* def = UTIL_mallocStr(length + 1);
286
287 strcpy(def, emptyTab); free(emptyTab);
288 strcat(def, " in\n ");
289
290 init = OC_mkVarDef(TAB, def); free(def);
291
292 return init;
293 }
294
295 /* let <funcName> = function () ->\n
296 let t = Table.SymbolTable.empty in <entries> t\n\n */
OC_mkBuildTabFunc(char * funcName,char * entries)297 static char* OC_mkBuildTabFunc(char* funcName, char* entries)
298 {
299 char* func;
300 char* inits = OC_mkTabInit();
301 size_t length = strlen(entries) + strlen(TAB) + strlen(inits) + 30;
302 char* def = UTIL_mallocStr(length + 1);
303
304 strcpy(def, "function () ->\n ");
305 strcat(def, inits); free(inits);
306 strcat(def, entries);
307 strcat(def, TAB);
308 strcat(def, "\n\n");
309
310 func = OC_mkVarDef(funcName, def); free(def);
311
312 return func;
313 }
314
315 /* let <tabName> = <buildFunc> ()\n\n */
OC_mkTab(char * tabName,char * buildFuncName)316 static char* OC_mkTab(char* tabName, char* buildFuncName)
317 {
318 char* tab;
319 size_t length = strlen(buildFuncName) + 10;
320 char* def = UTIL_mallocStr(length + 1);
321
322 strcpy(def, buildFuncName);
323 strcat(def, " ()\n\n");
324
325 tab = OC_mkVarDef(tabName, def); free(def);
326
327 return tab;
328 }
329
330 /* val <tabName> = Absyn.<typeName> Table.SymbolTable.t\n */
OC_mkTabDec(char * tabName,char * typeName)331 static char* OC_mkTabDec(char* tabName, char* typeName)
332 {
333 char* dec;
334 char* symbolTab = OC_mkDotStr(TABLE, TY_SYMTAB);
335 char* myType = OC_mkDotStr(ABSYN, typeName);
336 size_t length = strlen(symbolTab) + strlen(myType) + 5;
337 char* typedec = UTIL_mallocStr(length + 1);
338
339 strcpy(typedec, myType); free(myType);
340 strcat(typedec, " ");
341 strcat(typedec, symbolTab); free(symbolTab);
342 strcat(typedec, "\n");
343
344 dec = OC_mkVarDec(tabName, typedec); free(typedec);
345
346 return dec;
347 }
348
349 /****************************************************************************/
350 /* functions for making pervasive kind relevant components */
351 /****************************************************************************/
352 /* k<name> */
OC_mkKVarName(char * name)353 char* OC_mkKVarName(char* name)
354 {
355 return UTIL_appendStr(KVAR_PREFIX, name);
356 }
357
358 /* is<name> */
OC_mkIsKindFuncName(char * name)359 char* OC_mkIsKindFuncName(char* name)
360 {
361 return UTIL_appendStr(IS, name);
362 }
363
364 /* val <kindVarName> : Absyn.akind \n*/
OC_mkKindVarDec(char * kindVarName)365 char* OC_mkKindVarDec(char* kindVarName)
366 {
367 char* kindType = OC_mkDotStr(ABSYN, TY_KIND);
368 char* dec = OC_mkVarDec(kindVarName, kindType);
369 free(kindType);
370 return dec;
371 }
372
373 /* val <funcName> : Absyn.akind -> bool */
OC_mkIsKindFuncDec(char * funcName)374 char* OC_mkIsKindFuncDec(char* funcName)
375 {
376 char* kindType = OC_mkDotStr(ABSYN, TY_KIND);
377 char* arrowType = OC_mkArrowType(kindType, "bool");
378 char* dec = OC_mkVarDec(funcName, arrowType);
379 free(kindType); free(arrowType);
380 return dec;
381 }
382
383 /* let <funcName> tm = tm == <kindVarName> */
OC_mkIsKindFuncDef(char * funcName,char * kindVarName)384 char* OC_mkIsKindFuncDef(char* funcName, char* kindVarName)
385 {
386 char* funchead = UTIL_mallocStr(strlen(funcName) + 3);
387 char* defbody = UTIL_mallocStr(strlen(kindVarName) + 10);
388 char* def;
389
390 strcpy(funchead, funcName);
391 strcat(funchead, " tm");
392
393 strcpy(defbody, "(tm == ");
394 strcat(defbody, kindVarName);
395 strcat(defbody, ")");
396
397 def = OC_mkVarDef(funchead, defbody); free(funchead); free(defbody);
398 return def;
399 }
400
401 /*Kind variable definition:
402 let <varName> = Absyn.PervasiveKind(Symbol.symbol "<kindName>",
403 (Some <arity>), ref offset, Errormsg.none)
404 */
OC_mkKindVar(char * varName,char * kindName,char * arity,char * offset)405 char* OC_mkKindVar(char* varName, char* kindName, char* arity, char* offset)
406 {
407 char* kindvar;
408 char* ctr = OC_mkDotStr(ABSYN, VCTR_KIND);
409 char* symbol = OC_mkSymbol(kindName);
410 char* nargs = OC_mkSome(arity);
411 char* index = OC_mkRef(offset);
412 char* ktype = OC_mkDotStr(ABSYN, VCTR_KINDTYPE);
413 char* pos = OC_mkDotStr(ERRORMSG, VCTR_NULLPOS);
414 size_t length = strlen(ctr) + strlen(symbol) + strlen(nargs) +
415 strlen(index) + strlen(ktype) + strlen(pos) + 10;
416
417 char* def = UTIL_mallocStr(length + 1);
418
419 strcpy(def, ctr); free(ctr);
420 strcat(def, "(");
421 strcat(def, symbol); free(symbol);
422 strcat(def, ", ");
423 strcat(def, nargs); free(nargs);
424 strcat(def, ", ");
425 strcat(def, index); free(index);
426 strcat(def, ", ");
427 strcat(def, ktype); free(ktype);
428 strcat(def, ", ");
429 strcat(def, pos); free(pos);
430 strcat(def, ")");
431
432 kindvar = OC_mkVarDef(varName, def); free(def);
433 return kindvar;
434 }
435
436 /* let buildPervasiveKinds =
437 function () ->\n <inits> <entries>\n <tabName>\n\n */
OC_mkBuildKTabFunc(char * entries)438 char* OC_mkBuildKTabFunc(char* entries)
439 {
440 return OC_mkBuildTabFunc(BUILDPERVKIND, entries);
441 }
442
443 /****************************************************************************/
444 /* functions for making pervasive type skeleton components */
445 /****************************************************************************/
446 /* Absyn.SkeletonVarType(ref <ind>)
447 */
genTySkelVar(char * ind)448 static char* genTySkelVar(char* ind)
449 {
450 char* ctr = OC_mkDotStr(ABSYN, VCTR_SKELVARTYPE);
451 char* ref = OC_mkRef(ind);
452 size_t length = strlen(ctr) + strlen(ref) + 5;
453 char* skelVar = UTIL_mallocStr(length + 1);
454
455 strcpy(skelVar, ctr); free(ctr);
456 strcat(skelVar, "(");
457 strcat(skelVar, ref); free(ref);
458 strcat(skelVar, ")");
459
460 return skelVar;
461 }
462
463 /* Absyn.ArrowType(<type1>, <type2>)
464 */
genTySkelArrow(char * type1,char * type2)465 static char* genTySkelArrow(char* type1, char* type2)
466 {
467 char* ctr = OC_mkDotStr(ABSYN, VCTR_ARROWTYPE);
468 size_t length = strlen(ctr) + strlen(type1) + strlen(type2) + 5;
469 char* arrowtype = UTIL_mallocStr(length + 1);
470
471 strcpy(arrowtype, ctr); free(ctr);
472 strcat(arrowtype, "(");
473 strcat(arrowtype, type1);
474 strcat(arrowtype, ", ");
475 strcat(arrowtype, type2);
476 strcat(arrowtype, ")");
477
478 return arrowtype;
479 }
480
481 /* Absyn.AppType(k<sortName>, <args>)
482 */
genTySkelApp(char * sortName,char * args)483 static char* genTySkelApp(char* sortName, char* args)
484 {
485 char* ctr = OC_mkDotStr(ABSYN, VCTR_APPTYPE);
486 char* sortVar = OC_mkKVarName(sortName);
487 size_t length = strlen(ctr) + strlen(sortVar) + strlen(args) + 5;
488 char* apptype = UTIL_mallocStr(length + 1);
489
490 strcpy(apptype, ctr); free(ctr);
491 strcat(apptype, "(");
492 strcat(apptype, sortVar); free(sortVar);
493 strcat(apptype, ", ");
494 strcat(apptype, args);
495 strcat(apptype, ")");
496
497 return apptype;
498 }
499
500 /* Absyn.AppType(k<sortName>, [])
501 */
genTySkelSort(char * sortName)502 static char* genTySkelSort(char* sortName)
503 {
504 return genTySkelApp(sortName, "[]");
505 }
506
507 //forward declaration
508 char* OC_genTySkel(Type args);
509
OC_genTySkelArgs(TypeList args)510 static char* OC_genTySkelArgs(TypeList args)
511 {
512 size_t length;
513 char* mytext1 = NULL;
514 char* mytext = NULL;
515 char* oneTypeText = NULL;
516 Type oneType = args -> oneType;
517
518 args = args -> next;
519 mytext1 = OC_genTySkel(oneType);
520
521 while (args) {
522 oneType = args -> oneType;
523 args = args -> next;
524 oneTypeText = OC_genTySkel(oneType);
525
526 length = strlen(mytext1) + strlen(oneTypeText) + 5;
527 mytext = UTIL_mallocStr(length + 1);
528 strcpy(mytext, mytext1); free(mytext1);
529 strcat(mytext, " :: ");
530 strcat(mytext, oneTypeText); free(oneTypeText);
531 mytext1 = mytext;
532 }
533 length = strlen(mytext1) + 10;
534 mytext = UTIL_mallocStr(length + 1);
535 strcpy(mytext, "(");
536 strcat(mytext, mytext1); free(mytext1);
537 strcat(mytext, " :: [])");
538
539 return mytext;
540 }
541
OC_genTySkel(Type tyskel)542 char* OC_genTySkel(Type tyskel)
543 {
544 char* mytext1;
545 char* mytext2;
546 char* mytext3;
547
548 switch(tyskel -> tag) {
549 case SORT:
550 {
551 mytext1 = genTySkelSort(tyskel -> data.sort);
552 return mytext1;
553 }
554 case SKVAR:
555 {
556 mytext1 = genTySkelVar(tyskel -> data.skvar);
557 return mytext1;
558 }
559 case STR:
560 {
561 mytext1 = OC_genTySkelArgs(tyskel -> data.str.args);
562 mytext2 = genTySkelApp((tyskel -> data.str.functor)->data.func.name,
563 mytext1);
564 free(mytext1);
565 return mytext2;
566 }
567 case ARROW:
568 {
569 mytext1 = OC_genTySkel(tyskel -> data.arrow.lop);
570 mytext2 = OC_genTySkel(tyskel -> data.arrow.rop);
571 mytext3 = genTySkelArrow(mytext1, mytext2);
572 free(mytext1); free(mytext2);
573 return mytext3;
574 }
575 default:
576 return strdup("");
577 }
578 }
579
580 /* tyskel<number> */
OC_mkTySkelVarName(char * number)581 char* OC_mkTySkelVarName(char* number)
582 {
583 return UTIL_appendStr(TSKVAR_PREFIX, number);
584 }
585
586 /* Type Skeleton variable definition:
587 let <varName> = Some(Absyn.Skeleton(<tySkel>, ref None, ref false))
588 */
OC_mkTYSkelVar(char * varName,char * tySkel)589 char* OC_mkTYSkelVar(char* varName, char* tySkel)
590 {
591 char* tyskelvar;
592 char* ctr = OC_mkDotStr(ABSYN, VCTR_TYSKEL);
593 char* index = OC_mkRef("None");
594 char* adjust = OC_mkRef("false");
595 size_t length = strlen(ctr) + strlen(index) + strlen(adjust) +
596 strlen(tySkel) + 15;
597 char* def = UTIL_mallocStr(length + 1);
598 char* somedef;
599
600 strcpy(def, "(");
601 strcat(def, ctr); free(ctr);
602 strcat(def, "(");
603 strcat(def, tySkel);
604 strcat(def, ", ");
605 strcat(def, index); free(index);
606 strcat(def, ", ");
607 strcat(def, adjust); free(adjust);
608 strcat(def, "))");
609
610 somedef = OC_mkSome(def); free(def);
611 tyskelvar = OC_mkVarDef(varName, somedef); free(somedef);
612
613 return tyskelvar;
614 }
615
616
OC_mkTypeSetVar(char * defaultty,char * arglist,char * tyName)617 static char* OC_mkTypeSetVar(char* defaultty, char* arglist, char* tyName)
618 {
619 char* setVar;
620 char* func = OC_mkDotStr(ABSYN, FUNC_MAKETYSETVAR);
621 char* def = UTIL_mallocStr(strlen(func) + strlen(arglist) + strlen(defaultty) + 2);
622 strcpy(def, func); free(func);
623 strcat(def, " ");
624 strcat(def, defaultty);
625 strcat(def, " ");
626 strcat(def, arglist);
627
628 setVar = OC_mkVarDef(tyName, def); free(def);
629 return setVar;
630 }
631
632 /*********************************************/
633 /* generate tyskels for overloaded constants */
634 /*********************************************/
OC_mkTySkelRef(char * tySkel)635 static char* OC_mkTySkelRef(char* tySkel)
636 {
637 char* ctr = OC_mkDotStr(ABSYN, VCTR_TYSKEL);
638 char* index = OC_mkRef("None");
639 char* adjust = OC_mkRef("false");
640 size_t length = strlen(ctr) + strlen(index) + strlen(adjust) +
641 strlen(tySkel) + 15;
642 char* def = UTIL_mallocStr(length + 1);
643 char* somedef;
644 char* ref;
645
646 strcpy(def, "(");
647 strcat(def, ctr); free(ctr);
648 strcat(def, "(");
649 strcat(def, tySkel);
650 strcat(def, ", ");
651 strcat(def, index); free(index);
652 strcat(def, ", ");
653 strcat(def, adjust); free(adjust);
654 strcat(def, "))");
655
656 somedef = OC_mkSome(def); free(def);
657 ref = OC_mkRef(somedef); free(somedef);
658 return ref;
659 }
660
OC_mkFixedTySkels(char * tySkels)661 char* OC_mkFixedTySkels(char* tySkels)
662 {
663 char *text;
664 char* setvarIntReal =
665 OC_mkTypeSetVar("(Absyn.ApplicationType(kint,[]))",
666 "(Absyn.ApplicationType(kint,[]) :: Absyn.ApplicationType(kreal,[]) :: [])", SETVARIR);
667 char* setvarIntRealStr =
668 OC_mkTypeSetVar("(Absyn.ApplicationType(kint,[]))",
669 "(Absyn.ApplicationType(kint,[]) :: Absyn.ApplicationType(kreal,[]) :: Absyn.ApplicationType(kstring, []) :: [])", SETVARIRS);
670 char *tyskelBody, *tyskelBody2;
671 char *tyskel, *tyskelText;
672
673 text = UTIL_appendStr(tySkels, setvarIntReal); free(setvarIntReal);
674 tySkels = UTIL_appendStr(text, "\n"); free(text);
675
676 tyskelBody = genTySkelArrow(SETVARIR, SETVARIR);
677 tyskelText = OC_mkTySkelRef(tyskelBody);
678 tyskel = OC_mkVarDef(OVERLOADTYSKEL1, tyskelText); free(tyskelText);
679 text = UTIL_appendStr(tySkels, tyskel); free(tyskel);
680 tySkels = UTIL_appendStr(text, "\n"); free(text);
681
682 tyskelBody2 = genTySkelArrow(SETVARIR, tyskelBody); free(tyskelBody);
683 tyskelText = OC_mkTySkelRef(tyskelBody2); free(tyskelBody2);
684 tyskel = OC_mkVarDef(OVERLOADTYSKEL2, tyskelText); free(tyskelText);
685 text = UTIL_appendStr(tySkels, tyskel); free(tyskel);
686 tySkels = UTIL_appendStr(text, "\n\n"); free(text);
687
688 text = UTIL_appendStr(tySkels, setvarIntRealStr); free(setvarIntRealStr);
689 tySkels = UTIL_appendStr(text, "\n"); free(text);
690
691 tyskelBody = genTySkelArrow(SETVARIRS, "Absyn.ApplicationType(kbool, [])");
692 tyskelBody2 = genTySkelArrow(SETVARIRS, tyskelBody); free(tyskelBody);
693 tyskelText = OC_mkTySkelRef(tyskelBody2); free(tyskelBody2);
694 tyskel = OC_mkVarDef(OVERLOADTYSKEL3, tyskelText); free(tyskelText);
695 text = UTIL_appendStr(tySkels, tyskel); free(tyskel);
696 tySkels = UTIL_appendStr(text, "\n\n"); free(text);
697
698 return tySkels;
699 }
700
701 /****************************************************************************/
702 /* functions for making pervasive constants components */
703 /****************************************************************************/
704 /* <name>Constant */
OC_mkCVarName(char * name)705 char* OC_mkCVarName(char* name)
706 {
707 return UTIL_appendStr(name, CVAR_POSTFIX);
708 }
709 /* is<name>Constant */
OC_mkIsConstFuncName(char * name)710 char* OC_mkIsConstFuncName(char* name)
711 {
712 return UTIL_appendStr(IS, name);
713 }
714
715 /* val <constVarName> : Absyn.aconstant \n*/
OC_mkConstVarDec(char * constVarName)716 char* OC_mkConstVarDec(char* constVarName)
717 {
718 char* constType = OC_mkDotStr(ABSYN, TY_CONST);
719 char* dec = OC_mkVarDec(constVarName, constType);
720 free(constType);
721 return dec;
722 }
723
724 /* val <funcName> : Absyn.aconstant -> bool */
OC_mkIsConstFuncDec(char * funcName)725 char* OC_mkIsConstFuncDec(char* funcName)
726 {
727 char* constType = OC_mkDotStr(ABSYN, TY_CONST);
728 char* arrowType = OC_mkArrowType(constType, "bool");
729 char* dec = OC_mkVarDec(funcName, arrowType);
730 free(constType); free(arrowType);
731 return dec;
732 }
733
734
735 /* let <funcName> tm = tm == <constVarName> */
OC_mkIsConstFuncDef(char * funcName,char * constVarName)736 char* OC_mkIsConstFuncDef(char* funcName, char* constVarName)
737 {
738 char* funchead = UTIL_mallocStr(strlen(funcName) + 3);
739 char* defbody = UTIL_mallocStr(strlen(constVarName) + 10);
740 char* def;
741
742 strcpy(funchead, funcName);
743 strcat(funchead, " tm");
744
745 strcpy(defbody, "(tm == ");
746 strcat(defbody, constVarName);
747 strcat(defbody, ")");
748
749 def = OC_mkVarDef(funchead, defbody); free(funchead); free(defbody);
750 return def;
751 }
752
753 /* (ref fixity) */
OC_mkFixity(OP_Fixity fixity)754 static char* OC_mkFixity(OP_Fixity fixity)
755 {
756 switch (fixity){
757 case OP_INFIX : return OC_mkRef(strdup(INFIX));
758 case OP_INFIXL : return OC_mkRef(strdup(INFIXL));
759 case OP_INFIXR : return OC_mkRef(strdup(INFIXR));
760 case OP_PREFIX : return OC_mkRef(strdup(PREFIX));
761 case OP_PREFIXR : return OC_mkRef(strdup(PREFIXR));
762 case OP_POSTFIX : return OC_mkRef(strdup(POSTFIX));
763 case OP_POSTFIXL : return OC_mkRef(strdup(POSTFIXL));
764 case OP_NONE : return OC_mkRef(strdup(NOFIXITY));
765 default : return OC_mkRef(strdup(NOFIXITY));
766 }
767 }
768
769 /* (ref prec) */
OC_mkPrec(OP_Prec prec)770 static char* OC_mkPrec(OP_Prec prec)
771 {
772 char* precNum;
773 char* precText;
774 if (OP_precIsMax(prec)) {
775 char* temp = OC_mkDotStr(ABSYN, MAXPREC);
776 precNum = UTIL_mallocStr(strlen(temp) + 2);
777 strcpy(precNum, "(");
778 strcat(precNum, temp);
779 strcat(precNum, ")");
780 } else precNum = UTIL_itoa(prec.data.prec);
781 precText = OC_mkRef(precNum); free(precNum);
782 return precText;
783 }
784
785 /* (ref true/false ) */
OC_mkRefBool(UTIL_Bool value)786 static char* OC_mkRefBool(UTIL_Bool value)
787 {
788 if (value) return OC_mkRef("true");
789 else return OC_mkRef("false");
790 }
791
OC_mkRefInt(int value)792 static char* OC_mkRefInt(int value)
793 {
794 char* valueText = UTIL_itoa(value);
795 char* text = OC_mkRef(valueText);
796 free(valueText);
797 return text;
798 }
799
OC_mkCodeInfo(OP_Code codeInfo)800 static char* OC_mkCodeInfo(OP_Code codeInfo)
801 {
802 char* code;
803 char* ref;
804 if (OP_codeInfoIsNone(codeInfo)) {
805 code = strdup("None");
806 } else {
807 char* codeInd = UTIL_itoa(codeInfo);
808 char* ctr = OC_mkDotStr(ABSYN, VCTR_BUILTIN);
809 char* codeText = UTIL_mallocStr(strlen(codeInd) + strlen(ctr) + 10);
810 strcpy(codeText, "(");
811 strcat(codeText, ctr); free(ctr);
812 strcat(codeText, "(");
813 strcat(codeText, codeInd); free(codeInd);
814 strcat(codeText, "))");
815 code = OC_mkSome(codeText); free(codeText);
816 }
817 ref = OC_mkRef(code); free(code);
818 return ref;
819 }
820
OC_mkConstCat(UTIL_Bool redef)821 static char* OC_mkConstCat(UTIL_Bool redef)
822 {
823 char* ctr = OC_mkDotStr(ABSYN,VCTR_PERVCONST);
824 char* boolValue;
825 char* cat;
826 char* ref;
827
828 if (redef) boolValue = strdup("true");
829 else boolValue = strdup("false");
830
831 cat = UTIL_mallocStr(strlen(ctr) + strlen(boolValue) + 10);
832 strcpy(cat, "(");
833 strcat(cat, ctr); free(ctr);
834 strcat(cat, "(");
835 strcat(cat, boolValue); free(boolValue);
836 strcat(cat, "))");
837
838 ref = OC_mkRef(cat); free(cat);
839 return ref;
840 }
841
OC_mkSkelNeededness(int tyenvsize)842 static char* OC_mkSkelNeededness(int tyenvsize)
843 {
844 char* length = UTIL_itoa(tyenvsize);
845 char* some;
846 char* ref;
847 char* init = UTIL_mallocStr(strlen(length) + 20);
848 strcpy(init, "(Array.make ");
849 strcat(init, length); free(length);
850 strcat(init, " true)");
851
852 some = OC_mkSome(init); free(init);
853 ref = OC_mkRef(some); free(some);
854 return ref;
855 }
856
OC_mkNeededness(int neededness,int tyenvsize)857 static char* OC_mkNeededness(int neededness, int tyenvsize)
858 {
859 char* length = UTIL_itoa(tyenvsize);
860 char* init;
861 char* some;
862 char* ref;
863
864 if (neededness == tyenvsize) {
865 init = UTIL_mallocStr(strlen(length) + 20);
866 strcpy(init, "(Array.make ");
867 strcat(init, length); free(length);
868 strcat(init, " true)");
869 } else {
870 char* num = UTIL_itoa(neededness);
871 init = UTIL_mallocStr(strlen(length) + strlen(num) + 60);
872 strcpy(init, "(Array.init ");
873 strcat(init, length); free(length);
874 strcat(init, " (fun x -> if x >= ");
875 strcat(init, num); free(num);
876 strcat(init, " then false else true))");
877 }
878 some = OC_mkSome(init); free(init);
879 ref = OC_mkRef(some); free(some);
880 return ref;
881 }
882
883
OC_mkConstVarText(char * constName,char * fixity,char * prec,char * typrev,char * tyskel,char * tyenvsize,char * skelneededness,char * neededness,char * codeinfo,char * constcat,char * varname,char * offset,char * printName)884 static char* OC_mkConstVarText(char* constName, char* fixity, char* prec,
885 char* typrev, char* tyskel, char* tyenvsize,
886 char* skelneededness, char* neededness, char* codeinfo,
887 char* constcat, char* varname, char* offset,
888 char* printName)
889 {
890 char* constVar;
891 char* ctr = OC_mkDotStr(ABSYN, VCTR_CONSTANT);
892 char* symbol = OC_mkSymbolAlias(constName, printName);
893 char* refFalse = OC_mkRef("false");
894 char* refTrue = OC_mkRef("true");
895 char* index = OC_mkRef(offset);
896 char* pos = OC_mkDotStr(ERRORMSG, VCTR_NULLPOS);
897
898 size_t length = strlen(ctr) + strlen(symbol) + strlen(fixity) +
899 strlen(prec) + strlen(typrev) + strlen(tyskel) + strlen(tyenvsize) +
900 strlen(skelneededness) + strlen(neededness) + strlen(codeinfo) +
901 strlen(constcat) + strlen(index) + strlen(pos) + strlen(refFalse) * 6 + 35;
902 char* def = UTIL_mallocStr(length);
903
904 strcpy(def, ctr); free(ctr);
905 strcat(def, "(");
906 strcat(def, symbol); free(symbol);
907 strcat(def, ", ");
908 strcat(def, fixity);
909 strcat(def, ", ");
910 strcat(def, prec);
911 strcat(def, ", ");
912 strcat(def, refFalse);
913 strcat(def, ", ");
914 strcat(def, refFalse);
915 strcat(def, ", ");
916 strcat(def, refTrue); free(refTrue); /* no defs */
917 strcat(def, ", ");
918 strcat(def, refFalse);
919 strcat(def, ", ");
920 strcat(def, typrev);
921 strcat(def, ", ");
922 strcat(def, refFalse); free(refFalse);
923 strcat(def, ", ");
924 strcat(def, tyskel);
925 strcat(def, ", ");
926 strcat(def, tyenvsize);
927 strcat(def, ", ");
928 strcat(def, skelneededness);
929 strcat(def, ", ");
930 strcat(def, neededness);
931 strcat(def, ", ");
932 strcat(def, codeinfo);
933 strcat(def, ", ");
934 strcat(def, constcat);
935 strcat(def, ", ");
936 strcat(def, index); free(index);
937 strcat(def, ", ");
938 strcat(def, pos); free(pos);
939 strcat(def, ")");
940
941 constVar = OC_mkVarDef(varname, def); free(def);
942 return constVar;
943 }
944
945 /* Constant variable definition :
946 let <varName> = Absyn.Constant(Symbol.symbolAlias "<constName>" "<printName>",
947 ref <fixity>, ref <prec>, ref false, ref false, ref false, ref false,
948 ref false, ref <typrev>, ref false, ref <tySkel>,
949 ref <tyenvsize>, ref (Some <skelneededness>),
950 ref (Some <neededness>), ref <codeInfo>,
951 ref <constantCat>, ref 0, Errormsg.none)
952 */
OC_mkConstVar(char * constName,OP_Fixity fixity,OP_Prec prec,UTIL_Bool typrev,char * tySkel,int tyenvsize,int neededness,OP_Code codeInfo,UTIL_Bool reDef,char * varName,char * offset,char * printName)953 char* OC_mkConstVar(char* constName, OP_Fixity fixity, OP_Prec prec,
954 UTIL_Bool typrev, char* tySkel, int tyenvsize,
955 int neededness, OP_Code codeInfo, UTIL_Bool reDef,
956 char* varName, char* offset, char* printName)
957 {
958 char* constVar;
959 char* fixityText = OC_mkFixity(fixity);
960 char* precText = OC_mkPrec(prec);
961 char* typrevText = OC_mkRefBool(typrev);
962 char* tySkelText = OC_mkRef(tySkel);
963 char* tyenvsizeText = OC_mkRefInt(tyenvsize);
964 char* skelneedednessText = OC_mkSkelNeededness(tyenvsize);
965 char* needednessText = OC_mkNeededness(neededness, tyenvsize);
966 char* codeInfoText = OC_mkCodeInfo(codeInfo);
967 char* constCatText = OC_mkConstCat(reDef);
968
969 constVar = OC_mkConstVarText(constName, fixityText, precText,
970 typrevText, tySkelText, tyenvsizeText,
971 skelneedednessText, needednessText, codeInfoText,
972 constCatText, varName, offset, printName);
973
974 free(fixityText); free(precText); free(typrevText); free(tySkelText);
975 free(tyenvsizeText); free(skelneedednessText); free(needednessText);
976 free(codeInfoText); free(constCatText);
977
978 return constVar;
979 }
980
981 #define GENERICAPPLY "genericApplyConstant"
982 #define OVERLOADUMINUS "overloadUMinusConstant"
983 #define OVERLOADABS "overloadAbsConstant"
984 #define OVERLOADPLUS "overloadPlusConstant"
985 #define OVERLOADMINUS "overloadMinusConstant"
986 #define OVERLOADTIME "overloadTimeConstant"
987 #define OVERLOADLT "overloadLTConstant"
988 #define OVERLOADGT "overloadGTConstant"
989 #define OVERLOADLE "overloadLEConstant"
990 #define OVERLOADGE "overloadGEConstant"
991
OC_mkOverLoadConstVar(char * name,char * fixity,char * prec,char * tyskel,char * varName)992 static char* OC_mkOverLoadConstVar(char* name, char* fixity, char* prec,
993 char* tyskel, char* varName)
994 {
995 char* constVar;
996 constVar = OC_mkConstVarText(name, fixity, prec, "ref true", tyskel,
997 "ref 0", "ref(Some(Array.make 0 true))", "ref None", "ref None",
998 "ref(Absyn.PervasiveConstant(false))",
999 varName, "0", name);
1000 return constVar;
1001 }
1002
1003 /* generate fixed constants */
OC_mkGenericConstVar(char * varList)1004 char* OC_mkGenericConstVar(char* varList)
1005 {
1006 char* text;
1007 char* constVar;
1008
1009 constVar = OC_mkConstVarText(" apply", "ref Absyn.Infixl",
1010 "ref (Absyn.maxPrec + 2)", "ref false",
1011 "ref(Some(Absyn.Skeleton(Absyn.ErrorType, ref None, ref false)))",
1012 "ref 0", "ref(Some(Array.make 0 true))", "ref None", "ref None",
1013 "ref(Absyn.PervasiveConstant(false))", GENERICAPPLY, "0",
1014 " apply");
1015 text = UTIL_appendStr(varList, constVar); free(constVar);
1016 varList = UTIL_appendStr(text, "\n\n"); free(text);
1017
1018 constVar = OC_mkOverLoadConstVar("~", "ref Absyn.Prefix",
1019 "ref (Absyn.maxPrec + 1)", OVERLOADTYSKEL1,
1020 OVERLOADUMINUS);
1021 text = UTIL_appendStr(varList, constVar); free(constVar);
1022 varList = UTIL_appendStr(text, "\n\n"); free(text);
1023
1024
1025 constVar = OC_mkConstVarText("abs", "ref Absyn.NoFixity",
1026 "ref 0", "ref true",
1027 OVERLOADTYSKEL1,
1028 "ref 0", "ref(Some(Array.make 0 true))",
1029 "ref None", "ref None",
1030 "ref(Absyn.PervasiveConstant(true))",
1031 OVERLOADABS, "0", "abs");
1032
1033 text = UTIL_appendStr(varList, constVar); free(constVar);
1034 varList = UTIL_appendStr(text, "\n\n"); free(text);
1035
1036
1037 constVar = OC_mkOverLoadConstVar("+", "ref Absyn.Infixl", "ref 150",
1038 OVERLOADTYSKEL2, OVERLOADPLUS);
1039 text = UTIL_appendStr(varList, constVar); free(constVar);
1040 varList = UTIL_appendStr(text, "\n\n"); free(text);
1041
1042 constVar = OC_mkOverLoadConstVar("-", "ref Absyn.Infixl", "ref 150",
1043 OVERLOADTYSKEL2, OVERLOADMINUS);
1044 text = UTIL_appendStr(varList, constVar); free(constVar);
1045 varList = UTIL_appendStr(text, "\n\n"); free(text);
1046
1047 constVar = OC_mkOverLoadConstVar("*", "ref Absyn.Infixl", "ref 160",
1048 OVERLOADTYSKEL2, OVERLOADTIME);
1049 text = UTIL_appendStr(varList, constVar); free(constVar);
1050 varList = UTIL_appendStr(text, "\n\n"); free(text);
1051
1052 constVar = OC_mkOverLoadConstVar("<", "ref Absyn.Infix", "ref 130",
1053 OVERLOADTYSKEL3, OVERLOADLT);
1054 text = UTIL_appendStr(varList, constVar); free(constVar);
1055 varList = UTIL_appendStr(text, "\n\n"); free(text);
1056
1057 constVar = OC_mkOverLoadConstVar(">", "ref Absyn.Infix", "ref 130",
1058 OVERLOADTYSKEL3, OVERLOADGT);
1059 text = UTIL_appendStr(varList, constVar); free(constVar);
1060 varList = UTIL_appendStr(text, "\n\n"); free(text);
1061
1062 constVar = OC_mkOverLoadConstVar("<", "ref Absyn.Infix", "ref 130",
1063 OVERLOADTYSKEL3, OVERLOADLE);
1064 text = UTIL_appendStr(varList, constVar); free(constVar);
1065 varList = UTIL_appendStr(text, "\n\n"); free(text);
1066
1067 constVar = OC_mkOverLoadConstVar(">=", "ref Absyn.Infix", "ref 130",
1068 OVERLOADTYSKEL3, OVERLOADGE);
1069 text = UTIL_appendStr(varList, constVar); free(constVar);
1070 varList = UTIL_appendStr(text, "\n\n"); free(text);
1071 return varList;
1072 }
1073
1074 /* generate fixed constants decs */
OC_mkGenericConstVarDec(char * decList)1075 char* OC_mkGenericConstVarDec(char* decList)
1076 {
1077 char* text;
1078 char* dec;
1079
1080 dec = OC_mkConstVarDec(GENERICAPPLY);
1081 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1082 decList = text;
1083
1084 dec = OC_mkConstVarDec(OVERLOADUMINUS);
1085 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1086 decList = text;
1087
1088
1089 dec = OC_mkConstVarDec(OVERLOADABS);
1090 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1091 decList = text;
1092
1093
1094 dec = OC_mkConstVarDec(OVERLOADPLUS);
1095 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1096 decList = text;
1097
1098 dec = OC_mkConstVarDec(OVERLOADMINUS);
1099 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1100 decList = text;
1101
1102 dec = OC_mkConstVarDec(OVERLOADTIME);
1103 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1104 decList = text;
1105
1106 dec = OC_mkConstVarDec(OVERLOADLT);
1107 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1108 decList = text;
1109
1110 dec = OC_mkConstVarDec(OVERLOADGT);
1111 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1112 decList = text;
1113
1114 dec = OC_mkConstVarDec(OVERLOADLE);
1115 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1116 decList = text;
1117
1118 dec = OC_mkConstVarDec(OVERLOADGE);
1119 text = UTIL_appendStr(decList, dec); free(decList); free(dec);
1120 decList = text;
1121
1122 return decList;
1123 }
1124
1125
1126 /* generate fixed constants entry in buildConstant function */
OC_mkGenericConstTabEntry(char * entries)1127 char* OC_mkGenericConstTabEntry(char* entries)
1128 {
1129 char* text;
1130 char* tabEntry;
1131
1132 tabEntry = OC_mkTabEntry("~", OVERLOADUMINUS);
1133 text = UTIL_appendStr(entries, tabEntry);
1134 free(tabEntry); free(entries);
1135 entries = text;
1136
1137
1138 tabEntry = OC_mkTabEntry("abs", OVERLOADABS);
1139 text = UTIL_appendStr(entries, tabEntry);
1140 free(tabEntry); free(entries);
1141 entries = text;
1142
1143
1144 tabEntry = OC_mkTabEntry("+", OVERLOADPLUS);
1145 text = UTIL_appendStr(entries, tabEntry);
1146 free(tabEntry); free(entries);
1147 entries = text;
1148
1149 tabEntry = OC_mkTabEntry("-", OVERLOADMINUS);
1150 text = UTIL_appendStr(entries, tabEntry);
1151 free(tabEntry); free(entries);
1152 entries = text;
1153
1154 tabEntry = OC_mkTabEntry("*", OVERLOADTIME);
1155 text = UTIL_appendStr(entries, tabEntry);
1156 free(tabEntry); free(entries);
1157 entries = text;
1158
1159 tabEntry = OC_mkTabEntry("<", OVERLOADLT);
1160 text = UTIL_appendStr(entries, tabEntry);
1161 free(tabEntry); free(entries);
1162 entries = text;
1163
1164 tabEntry = OC_mkTabEntry(">", OVERLOADGT);
1165 text = UTIL_appendStr(entries, tabEntry);
1166 free(tabEntry); free(entries);
1167 entries = text;
1168
1169 tabEntry = OC_mkTabEntry("<=", OVERLOADLE);
1170 text = UTIL_appendStr(entries, tabEntry);
1171 free(tabEntry); free(entries);
1172 entries = text;
1173
1174 tabEntry = OC_mkTabEntry(">=", OVERLOADGE);
1175 text = UTIL_appendStr(entries, tabEntry);
1176 free(tabEntry); free(entries);
1177 entries = text;
1178
1179 return entries;
1180 }
1181
1182 /* let buildPervasiveKinds =
1183 function () ->\n <inits> <entries>\n <tabName>\n\n */
OC_mkBuildCTabFunc(char * entries)1184 char* OC_mkBuildCTabFunc(char* entries)
1185 {
1186 return OC_mkBuildTabFunc(BUILDPERVCONST, entries);
1187 }
1188
1189 /* make generaic const is function decs */
OC_mkGenericConstFuncDecs(char * funcDefs)1190 char* OC_mkGenericConstFuncDecs(char* funcDefs)
1191 {
1192 char* funcName;
1193 char* def;
1194 char* text;
1195
1196 funcName = OC_mkIsConstFuncName(GENERICAPPLY);
1197 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1198 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1199 funcDefs = text;
1200
1201 funcName = OC_mkIsConstFuncName(OVERLOADUMINUS);
1202 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1203 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1204 funcDefs = text;
1205
1206
1207 funcName = OC_mkIsConstFuncName(OVERLOADABS);
1208 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1209 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1210 funcDefs = text;
1211
1212
1213 funcName = OC_mkIsConstFuncName(OVERLOADPLUS);
1214 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1215 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1216 funcDefs = text;
1217
1218 funcName = OC_mkIsConstFuncName(OVERLOADMINUS);
1219 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1220 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1221 funcDefs = text;
1222
1223 funcName = OC_mkIsConstFuncName(OVERLOADTIME);
1224 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1225 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1226 funcDefs = text;
1227
1228 funcName = OC_mkIsConstFuncName(OVERLOADLT);
1229 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1230 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1231 funcDefs = text;
1232
1233 funcName = OC_mkIsConstFuncName(OVERLOADGT);
1234 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1235 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1236 funcDefs = text;
1237
1238 funcName = OC_mkIsConstFuncName(OVERLOADLE);
1239 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1240 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1241 funcDefs = text;
1242
1243 funcName = OC_mkIsConstFuncName(OVERLOADGE);
1244 def = OC_mkIsConstFuncDec(funcName); free(funcName);
1245 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1246 funcDefs = text;
1247
1248 return funcDefs;
1249 }
1250
1251
1252 /* make generaic const is function defs */
OC_mkGenericConstFuncDefs(char * funcDefs)1253 char* OC_mkGenericConstFuncDefs(char* funcDefs)
1254 {
1255 char* funcName;
1256 char* def;
1257 char* text;
1258
1259 funcName = OC_mkIsConstFuncName(GENERICAPPLY);
1260 def = OC_mkIsConstFuncDef(funcName, GENERICAPPLY); free(funcName);
1261 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1262 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1263
1264
1265 funcName = OC_mkIsConstFuncName(OVERLOADUMINUS);
1266 def = OC_mkIsConstFuncDef(funcName, OVERLOADUMINUS); free(funcName);
1267 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1268 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1269
1270
1271 funcName = OC_mkIsConstFuncName(OVERLOADABS);
1272 def = OC_mkIsConstFuncDef(funcName, OVERLOADABS); free(funcName);
1273 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1274 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1275
1276
1277 funcName = OC_mkIsConstFuncName(OVERLOADPLUS);
1278 def = OC_mkIsConstFuncDef(funcName, OVERLOADPLUS); free(funcName);
1279 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1280 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1281
1282 funcName = OC_mkIsConstFuncName(OVERLOADMINUS);
1283 def = OC_mkIsConstFuncDef(funcName, OVERLOADMINUS); free(funcName);
1284 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1285 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1286
1287 funcName = OC_mkIsConstFuncName(OVERLOADTIME);
1288 def = OC_mkIsConstFuncDef(funcName, OVERLOADTIME); free(funcName);
1289 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1290 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1291
1292 funcName = OC_mkIsConstFuncName(OVERLOADLT);
1293 def = OC_mkIsConstFuncDef(funcName, OVERLOADLT); free(funcName);
1294 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1295 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1296
1297 funcName = OC_mkIsConstFuncName(OVERLOADGT);
1298 def = OC_mkIsConstFuncDef(funcName, OVERLOADGT); free(funcName);
1299 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1300 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1301
1302 funcName = OC_mkIsConstFuncName(OVERLOADLE);
1303 def = OC_mkIsConstFuncDef(funcName, OVERLOADLE); free(funcName);
1304 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1305 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1306
1307 funcName = OC_mkIsConstFuncName(OVERLOADGE);
1308 def = OC_mkIsConstFuncDef(funcName, OVERLOADGE); free(funcName);
1309 text = UTIL_appendStr(funcDefs, def); free(def); free(funcDefs);
1310 funcDefs = UTIL_appendStr(text, "\n\n"); free(text);
1311
1312 return funcDefs;
1313 }
1314
OC_mkCompare(char * name)1315 char* OC_mkCompare(char* name)
1316 {
1317 char* text = UTIL_mallocStr(strlen(name) + 15);
1318 strcpy(text, "(const == ");
1319 strcat(text, name);
1320 strcat(text, ")");
1321 return text;
1322 }
1323
1324
OC_mkOr(char * operandl,char * operandr)1325 char* OC_mkOr(char* operandl, char* operandr)
1326 {
1327 char* text = UTIL_mallocStr(strlen(operandl) + strlen(operandr) + 5);
1328 strcpy(text, operandl);
1329 strcat(text, " || ");
1330 strcat(text, operandr);
1331
1332 return text;
1333 }
1334
1335
1336 #define PERV_REGCLOB_DEF_BEG "let regClobberingPerv const = \n if ("
1337 #define PERV_REGCLOB_DEF_END ") then true else false \n\n"
OC_mkRegClobFunc(char * body)1338 char* OC_mkRegClobFunc(char* body)
1339 {
1340 char* text = UTIL_mallocStr(strlen(PERV_REGCLOB_DEF_BEG) + strlen(body) +
1341 strlen(PERV_REGCLOB_DEF_END));
1342 strcpy(text, PERV_REGCLOB_DEF_BEG);
1343 strcat(text, body);
1344 strcat(text, PERV_REGCLOB_DEF_END);
1345
1346 return text;
1347 }
1348
1349 #define PERV_BCK_DEF_BEG "let backtrackablePerv const = \n if ("
1350 #define PERV_BCK_DEF_END ") then true else false \n\n"
OC_mkBackTrackFunc(char * body)1351 char* OC_mkBackTrackFunc(char* body)
1352 {
1353 char* text = UTIL_mallocStr(strlen(PERV_BCK_DEF_BEG) + strlen(body) +
1354 strlen(PERV_BCK_DEF_END));
1355 strcpy(text, PERV_BCK_DEF_BEG);
1356 strcat(text, body);
1357 strcat(text, PERV_BCK_DEF_END);
1358
1359 return text;
1360 }
1361
1362
1363
1364 /*****************************************************************************/
1365 /* functions for making the fixed part of pervasive.mli */
1366 /*****************************************************************************/
1367 #define TERM_DECS \
1368 "val implicationTerm : Absyn.aterm\nval andTerm : Absyn.aterm\n"
1369
1370 #define PERV_FUNC_DECS \
1371 "val isPerv : Absyn.aconstant -> bool \nval regClobberingPerv : Absyn.aconstant -> bool \nval backtrackablePerv : Absyn.aconstant -> bool\n"
1372
1373 /*
1374 val pervasiveKinds : Absyn.akind Table.SymbolTable.t
1375 val pervasiveConstants : Absyn.aconstant Table.SymbolTable.t
1376 val pervasiveTypeAbbrevs : Absyn.atypeabbrev Table.SymbolTable.t
1377 */
OC_mkFixedMLI()1378 char* OC_mkFixedMLI()
1379 {
1380 char* kindDec = OC_mkTabDec(PERVKIND, TY_KIND);
1381 char* constDec = OC_mkTabDec(PERVCONST, TY_CONST);
1382 char* tyabbrDec = OC_mkTabDec(PERVTYABBR, TY_TYABBREV);
1383 size_t length = strlen(kindDec) + strlen(constDec) + strlen(tyabbrDec) +
1384 strlen(TERM_DECS) + strlen(PERV_FUNC_DECS) + 10;
1385 char* decs = UTIL_mallocStr(length + 1);
1386
1387 strcpy(decs, kindDec); free(kindDec);
1388 strcat(decs, constDec); free(constDec);
1389 strcat(decs, tyabbrDec); free(tyabbrDec);
1390 strcat(decs, "\n");
1391 strcat(decs, TERM_DECS);
1392 strcat(decs, "\n");
1393 strcat(decs, PERV_FUNC_DECS);
1394 strcat(decs, "\n");
1395
1396 return decs;
1397 }
1398
1399 /*****************************************************************************/
1400 /* functions for making the fixed part of pervasive.ml */
1401 /*****************************************************************************/
1402 #define TERM_DEFS \
1403 "let andTerm = Absyn.ConstantTerm(andConstant, [], Errormsg.none) \nlet implicationTerm = Absyn.ConstantTerm(implConstant, [], Errormsg.none)\n"
1404
1405 #define PERV_ISPERV_DEF \
1406 "let isPerv const = \n let constCat = Absyn.getConstantType(const) in \n match constCat with \n Absyn.PervasiveConstant(_) -> true \n | _ -> false \n"
1407
1408 /*
1409 let pervasiveKinds = buildPervasiveKinds ()
1410 let pervasiveConstants = buildPervasiveConstants ()
1411 let pervasiveTypeAbbrevs = Table.SymbolTable.empty
1412 */
OC_mkFixedML()1413 char* OC_mkFixedML()
1414 {
1415 char* kindDef = OC_mkTab(PERVKIND, BUILDPERVKIND);
1416 char* constDef = OC_mkTab(PERVCONST, BUILDPERVCONST);
1417 char* emptyTab = OC_mkDotStr(TABLE, VCTR_EMPTYTAB);
1418 char* tyabbrDef = OC_mkVarDef(PERVTYABBR, emptyTab);
1419 size_t length = strlen(kindDef) + strlen(constDef) + strlen(tyabbrDef) +
1420 strlen(TERM_DEFS) + strlen(PERV_ISPERV_DEF) + 10;
1421 char* defs = UTIL_mallocStr(length + 1);
1422
1423 free(emptyTab);
1424 strcpy(defs, kindDef); free(kindDef);
1425 strcat(defs, constDef); free(constDef);
1426 strcat(defs, tyabbrDef); free(tyabbrDef);
1427 strcat(defs, "\n\n");
1428 strcat(defs, TERM_DEFS);
1429 strcat(defs, "\n");
1430 strcat(defs, PERV_ISPERV_DEF);
1431 strcat(defs, "\n");
1432
1433 return defs;
1434 }
1435