xref: /csrg-svn/old/dbx/pascal.c (revision 9689)
19675Slinton /* Copyright (c) 1982 Regents of the University of California */
29675Slinton 
3*9689Slinton static char sccsid[] = "@(#)pascal.c 1.2 12/15/82";
49675Slinton 
59675Slinton /*
69675Slinton  * Pascal-dependent symbol routines.
79675Slinton  */
89675Slinton 
99675Slinton #include "defs.h"
109675Slinton #include "symbols.h"
119675Slinton #include "pascal.h"
129675Slinton #include "languages.h"
139675Slinton #include "tree.h"
149675Slinton #include "eval.h"
159675Slinton #include "mappings.h"
169675Slinton #include "process.h"
179675Slinton #include "runtime.h"
189675Slinton #include "machine.h"
199675Slinton 
209675Slinton #ifndef public
219675Slinton #endif
229675Slinton 
239675Slinton /*
249675Slinton  * Initialize Pascal information.
259675Slinton  */
269675Slinton 
279675Slinton public pascal_init()
289675Slinton {
299675Slinton     Language lang;
309675Slinton 
319675Slinton     lang = language_define("pascal", ".p");
329675Slinton     language_setop(lang, L_PRINTDECL, pascal_printdecl);
339675Slinton     language_setop(lang, L_PRINTVAL, pascal_printval);
349675Slinton     language_setop(lang, L_TYPEMATCH, pascal_typematch);
359675Slinton }
369675Slinton 
379675Slinton /*
389675Slinton  * Compatible tests if two types are compatible.  The issue
399675Slinton  * is complicated a bit by ranges.
409675Slinton  *
419675Slinton  * Integers and reals are not compatible since they cannot always be mixed.
429675Slinton  */
439675Slinton 
449675Slinton public Boolean pascal_typematch(type1, type2)
459675Slinton Symbol type1, type2;
469675Slinton {
479675Slinton     Boolean b;
489675Slinton     register Symbol t1, t2;
499675Slinton 
509675Slinton     t1 = rtype(t1);
519675Slinton     t2 = rtype(t2);
529675Slinton     b = (Boolean)
539675Slinton 	(t1->type == t2->type and (
549675Slinton 	    (t1->class == RANGE and t2->class == RANGE) or
559675Slinton 	    (t1->class == SCAL and t2->class == CONST) or
569675Slinton 	    (t1->class == CONST and t2->class == SCAL) or
579675Slinton 	    (t1->type == t_char and t1->class == ARRAY and t2->class == ARRAY)
589675Slinton 	) or
599675Slinton 	(t1 == t_nil and t2->class == PTR) or
609675Slinton 	(t1->class == PTR and t2 == t_nil)
619675Slinton     );
629675Slinton     return b;
639675Slinton }
649675Slinton 
659675Slinton public pascal_printdecl(s)
669675Slinton Symbol s;
679675Slinton {
689675Slinton     register Symbol t;
699675Slinton     Boolean semicolon;
709675Slinton 
719675Slinton     semicolon = true;
729675Slinton     switch (s->class) {
739675Slinton 	case CONST:
749675Slinton 	    if (s->type->class == SCAL) {
759675Slinton 		printf("(enumeration constant, ord %ld)",
769675Slinton 		    s->symvalue.iconval);
779675Slinton 	    } else {
789675Slinton 		printf("const %s = ", symname(s));
799675Slinton 		printval(s);
809675Slinton 	    }
819675Slinton 	    break;
829675Slinton 
839675Slinton 	case TYPE:
849675Slinton 	    printf("type %s = ", symname(s));
859675Slinton 	    printtype(s, s->type);
869675Slinton 	    break;
879675Slinton 
889675Slinton 	case VAR:
899675Slinton 	    if (isparam(s)) {
909675Slinton 		printf("(parameter) %s : ", symname(s));
919675Slinton 	    } else {
929675Slinton 		printf("var %s : ", symname(s));
939675Slinton 	    }
949675Slinton 	    printtype(s, s->type);
959675Slinton 	    break;
969675Slinton 
979675Slinton 	case REF:
989675Slinton 	    printf("(var parameter) %s : ", symname(s));
999675Slinton 	    printtype(s, s->type);
1009675Slinton 	    break;
1019675Slinton 
1029675Slinton 	case RANGE:
1039675Slinton 	case ARRAY:
1049675Slinton 	case RECORD:
1059675Slinton 	case VARNT:
1069675Slinton 	case PTR:
1079675Slinton 	    printtype(s, s);
1089675Slinton 	    semicolon = false;
1099675Slinton 	    break;
1109675Slinton 
1119675Slinton 	case FVAR:
1129675Slinton 	    printf("(function variable) %s : ", symname(s));
1139675Slinton 	    printtype(s, s->type);
1149675Slinton 	    break;
1159675Slinton 
1169675Slinton 	case FIELD:
1179675Slinton 	    printf("(field) %s : ", symname(s));
1189675Slinton 	    printtype(s, s->type);
1199675Slinton 	    break;
1209675Slinton 
1219675Slinton 	case PROC:
1229675Slinton 	    printf("procedure %s", symname(s));
1239675Slinton 	    listparams(s);
1249675Slinton 	    break;
1259675Slinton 
1269675Slinton 	case PROG:
1279675Slinton 	    printf("program %s", symname(s));
1289675Slinton 	    t = s->chain;
1299675Slinton 	    if (t != nil) {
1309675Slinton 		printf("(%s", symname(t));
1319675Slinton 		for (t = t->chain; t != nil; t = t->chain) {
1329675Slinton 		    printf(", %s", symname(t));
1339675Slinton 		}
1349675Slinton 		printf(")");
1359675Slinton 	    }
1369675Slinton 	    break;
1379675Slinton 
1389675Slinton 	case FUNC:
1399675Slinton 	    printf("function %s", symname(s));
1409675Slinton 	    listparams(s);
1419675Slinton 	    printf(" : ");
1429675Slinton 	    printtype(s, s->type);
1439675Slinton 	    break;
1449675Slinton 
1459675Slinton 	default:
1469675Slinton 	    error("class %s in printdecl", classname(s));
1479675Slinton     }
1489675Slinton     if (semicolon) {
1499675Slinton 	putchar(';');
1509675Slinton     }
1519675Slinton     putchar('\n');
1529675Slinton }
1539675Slinton 
1549675Slinton /*
1559675Slinton  * Recursive whiz-bang procedure to print the type portion
1569675Slinton  * of a declaration.  Doesn't work quite right for variant records.
1579675Slinton  *
1589675Slinton  * The symbol associated with the type is passed to allow
1599675Slinton  * searching for type names without getting "type blah = blah".
1609675Slinton  */
1619675Slinton 
1629675Slinton private printtype(s, t)
1639675Slinton Symbol s;
1649675Slinton Symbol t;
1659675Slinton {
1669675Slinton     register Symbol tmp;
1679675Slinton 
1689675Slinton     switch (t->class) {
1699675Slinton 	case VAR:
1709675Slinton 	case CONST:
1719675Slinton 	case FUNC:
1729675Slinton 	case PROC:
1739675Slinton 	    panic("printtype: class %s", classname(t));
1749675Slinton 	    break;
1759675Slinton 
1769675Slinton 	case ARRAY:
1779675Slinton 	    printf("array[");
1789675Slinton 	    tmp = t->chain;
1799675Slinton 	    if (tmp != nil) {
1809675Slinton 		for (;;) {
1819675Slinton 		    printtype(tmp, tmp);
1829675Slinton 		    tmp = tmp->chain;
1839675Slinton 		    if (tmp == nil) {
1849675Slinton 			break;
1859675Slinton 		    }
1869675Slinton 		    printf(", ");
1879675Slinton 		}
1889675Slinton 	    }
1899675Slinton 	    printf("] of ");
1909675Slinton 	    printtype(t, t->type);
1919675Slinton 	    break;
1929675Slinton 
1939675Slinton 	case RECORD:
1949675Slinton 	    printf("record\n");
1959675Slinton 	    if (t->chain != nil) {
1969675Slinton 		printtype(t->chain, t->chain);
1979675Slinton 	    }
1989675Slinton 	    printf("end");
1999675Slinton 	    break;
2009675Slinton 
2019675Slinton 	case FIELD:
2029675Slinton 	    if (t->chain != nil) {
2039675Slinton 		printtype(t->chain, t->chain);
2049675Slinton 	    }
2059675Slinton 	    printf("\t%s : ", symname(t));
2069675Slinton 	    printtype(t, t->type);
2079675Slinton 	    printf(";\n");
2089675Slinton 	    break;
2099675Slinton 
2109675Slinton 	case RANGE: {
2119675Slinton 	    long r0, r1;
2129675Slinton 
2139675Slinton 	    r0 = t->symvalue.rangev.lower;
2149675Slinton 	    r1 = t->symvalue.rangev.upper;
2159675Slinton 	    if (t == t_char) {
2169675Slinton 		if (r0 < 0x20 or r0 > 0x7e) {
2179675Slinton 		    printf("%ld..", r0);
2189675Slinton 		} else {
2199675Slinton 		    printf("'%c'..", (char) r0);
2209675Slinton 		}
2219675Slinton 		if (r1 < 0x20 or r1 > 0x7e) {
2229675Slinton 		    printf("\\%lo", r1);
2239675Slinton 		} else {
2249675Slinton 		    printf("'%c'", (char) r1);
2259675Slinton 		}
2269675Slinton 	    } else if (r0 > 0 and r1 == 0) {
2279675Slinton 		printf("%ld byte real", r0);
2289675Slinton 	    } else if (r0 >= 0) {
2299675Slinton 		printf("%lu..%lu", r0, r1);
2309675Slinton 	    } else {
2319675Slinton 		printf("%ld..%ld", r0, r1);
2329675Slinton 	    }
2339675Slinton 	    break;
2349675Slinton 	}
2359675Slinton 
2369675Slinton 	case PTR:
2379675Slinton 	    putchar('*');
2389675Slinton 	    printtype(t, t->type);
2399675Slinton 	    break;
2409675Slinton 
2419675Slinton 	case TYPE:
2429675Slinton 	    if (symname(t) != nil) {
2439675Slinton 		printf("%s", symname(t));
2449675Slinton 	    } else {
2459675Slinton 		printtype(t, t->type);
2469675Slinton 	    }
2479675Slinton 	    break;
2489675Slinton 
2499675Slinton 	case SCAL:
2509675Slinton 	    printf("(");
2519675Slinton 	    t = t->type->chain;
2529675Slinton 	    if (t != nil) {
2539675Slinton 		printf("%s", symname(t));
2549675Slinton 		t = t->chain;
2559675Slinton 		while (t != nil) {
2569675Slinton 		    printf(", %s", symname(t));
2579675Slinton 		    t = t->chain;
2589675Slinton 		}
2599675Slinton 	    } else {
2609675Slinton 		panic("empty enumeration");
2619675Slinton 	    }
2629675Slinton 	    printf(")");
2639675Slinton 	    break;
2649675Slinton 
2659675Slinton 	default:
2669675Slinton 	    printf("(class %d)", t->class);
2679675Slinton 	    break;
2689675Slinton     }
2699675Slinton }
2709675Slinton 
2719675Slinton /*
2729675Slinton  * List the parameters of a procedure or function.
2739675Slinton  * No attempt is made to combine like types.
2749675Slinton  */
2759675Slinton 
2769675Slinton private listparams(s)
2779675Slinton Symbol s;
2789675Slinton {
2799675Slinton     Symbol t;
2809675Slinton 
2819675Slinton     if (s->chain != nil) {
2829675Slinton 	putchar('(');
2839675Slinton 	for (t = s->chain; t != nil; t = t->chain) {
2849675Slinton 	    switch (t->class) {
2859675Slinton 		case REF:
2869675Slinton 		    printf("var ");
2879675Slinton 		    break;
2889675Slinton 
2899675Slinton 		case FPROC:
2909675Slinton 		    printf("procedure ");
2919675Slinton 		    break;
2929675Slinton 
2939675Slinton 		case FFUNC:
2949675Slinton 		    printf("function ");
2959675Slinton 		    break;
2969675Slinton 
2979675Slinton 		case VAR:
2989675Slinton 		    break;
2999675Slinton 
3009675Slinton 		default:
3019675Slinton 		    panic("unexpected class %d for parameter", t->class);
3029675Slinton 	    }
3039675Slinton 	    printf("%s : ", symname(t));
3049675Slinton 	    printtype(t, t->type);
3059675Slinton 	    if (t->chain != nil) {
3069675Slinton 		printf("; ");
3079675Slinton 	    }
3089675Slinton 	}
3099675Slinton 	putchar(')');
3109675Slinton     }
3119675Slinton }
3129675Slinton 
3139675Slinton /*
3149675Slinton  * Print out the value on the top of the expression stack
3159675Slinton  * in the format for the type of the given symbol.
3169675Slinton  */
3179675Slinton 
3189675Slinton public pascal_printval(s)
3199675Slinton Symbol s;
3209675Slinton {
3219675Slinton     Symbol t;
3229675Slinton     Address a;
3239675Slinton     int len;
3249675Slinton     double r;
3259675Slinton 
3269675Slinton     if (s->class == REF) {
3279675Slinton 	s = s->type;
3289675Slinton     }
3299675Slinton     switch (s->class) {
3309675Slinton 	case TYPE:
3319675Slinton 	    pascal_printval(s->type);
3329675Slinton 	    break;
3339675Slinton 
3349675Slinton 	case ARRAY:
3359675Slinton 	    t = rtype(s->type);
3369675Slinton 	    if (t==t_char or (t->class==RANGE and t->type==t_char)) {
3379675Slinton 		len = size(s);
3389675Slinton 		sp -= len;
3399675Slinton 		printf("'%.*s'", len, sp);
3409675Slinton 		break;
3419675Slinton 	    } else {
3429675Slinton 		printarray(s);
3439675Slinton 	    }
3449675Slinton 	    break;
3459675Slinton 
3469675Slinton 	case RECORD:
3479675Slinton 	    printrecord(s);
3489675Slinton 	    break;
3499675Slinton 
3509675Slinton 	case VARNT:
3519675Slinton 	    error("can't print out variant records");
3529675Slinton 	    break;
3539675Slinton 
3549675Slinton 
3559675Slinton 	case RANGE:
3569675Slinton 	    if (s == t_boolean) {
3579675Slinton 		printf(((Boolean) popsmall(s)) == true ? "true" : "false");
3589675Slinton 	    } else if (s == t_char) {
3599675Slinton 		printf("'%c'", pop(char));
3609675Slinton 	    } else if (s->symvalue.rangev.upper == 0 and
3619675Slinton 			s->symvalue.rangev.lower > 0) {
3629675Slinton 		switch (s->symvalue.rangev.lower) {
3639675Slinton 		    case sizeof(float):
3649675Slinton 			prtreal(pop(float));
3659675Slinton 			break;
3669675Slinton 
3679675Slinton 		    case sizeof(double):
3689675Slinton 			prtreal(pop(double));
3699675Slinton 			break;
3709675Slinton 
3719675Slinton 		    default:
3729675Slinton 			panic("bad real size %d", s->symvalue.rangev.lower);
3739675Slinton 			break;
3749675Slinton 		}
3759675Slinton 	    } else if (s->symvalue.rangev.lower >= 0) {
3769675Slinton 		printf("%lu", popsmall(s));
3779675Slinton 	    } else {
3789675Slinton 		printf("%ld", popsmall(s));
3799675Slinton 	    }
3809675Slinton 	    break;
3819675Slinton 
3829675Slinton 	case FILET:
3839675Slinton 	case PTR: {
3849675Slinton 	    Address addr;
3859675Slinton 
3869675Slinton 	    addr = pop(Address);
3879675Slinton 	    if (addr == 0) {
3889675Slinton 		printf("0, (nil)");
3899675Slinton 	    } else {
3909675Slinton 		printf("0x%x, 0%o", addr, addr);
3919675Slinton 	    }
3929675Slinton 	    break;
3939675Slinton 	}
3949675Slinton 
3959675Slinton 	case FIELD:
3969675Slinton 	    error("missing record specification");
3979675Slinton 	    break;
3989675Slinton 
3999675Slinton 	case SCAL: {
4009675Slinton 	    int scalar;
4019675Slinton 	    Boolean found;
4029675Slinton 
4039675Slinton 	    scalar = popsmall(s);
4049675Slinton 	    found = false;
4059675Slinton 	    for (t = s->chain; t != nil; t = t->chain) {
4069675Slinton 		if (t->symvalue.iconval == scalar) {
4079675Slinton 		    printf("%s", symname(t));
4089675Slinton 		    found = true;
4099675Slinton 		    break;
4109675Slinton 		}
4119675Slinton 	    }
4129675Slinton 	    if (not found) {
4139675Slinton 		printf("(scalar = %d)", scalar);
4149675Slinton 	    }
4159675Slinton 	    break;
4169675Slinton 	}
4179675Slinton 
4189675Slinton 	case FPROC:
4199675Slinton 	case FFUNC:
4209675Slinton 	{
4219675Slinton 	    Address a;
4229675Slinton 
4239675Slinton 	    a = fparamaddr(pop(long));
4249675Slinton 	    t = whatblock(a);
4259675Slinton 	    if (t == nil) {
4269675Slinton 		printf("(proc %d)", a);
4279675Slinton 	    } else {
4289675Slinton 		printf("%s", symname(t));
4299675Slinton 	    }
4309675Slinton 	    break;
4319675Slinton 	}
4329675Slinton 
4339675Slinton 	default:
4349675Slinton 	    if (ord(s->class) < ord(BADUSE) or ord(s->class) > ord(TYPEREF)) {
4359675Slinton 		panic("printval: bad class %d", ord(s->class));
4369675Slinton 	    }
4379675Slinton 	    error("don't know how to print a %s", classname(s));
4389675Slinton 	    /* NOTREACHED */
4399675Slinton     }
4409675Slinton }
441