![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to clas.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / pi|
Return to clas.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / pi |
1.1 root 1: /* Copyright (c) 1979 Regents of the University of California */
2: #
3: /*
4: * pi - Pascal interpreter code translator
5: *
6: * Charles Haley, Bill Joy UCB
7: * Version 1.2 November 1978
8: */
9:
10: #include "whoami"
11: #include "0.h"
12: #include "tree.h"
13:
14: /*
15: * This is the array of class
16: * names for the classes returned
17: * by classify. The order of the
18: * classes is the same as the base
19: * of the namelist, with special
20: * negative index entries for structures,
21: * scalars, pointers, sets and strings
22: * to be collapsed into.
23: */
24: char *clnxxxx[] =
25: {
26: "file", /* -7 TFILE */
27: "record", /* -6 TREC */
28: "array", /* -5 TARY */
29: "scalar", /* -4 TSCAL */
30: "pointer", /* -3 TPTR */
31: "set", /* -2 TSET */
32: "string", /* -1 TSTR */
33: "SNARK", /* 0 NIL */
34: "Boolean", /* 1 TBOOL */
35: "char", /* 2 TCHAR */
36: "integer", /* 3 TINT */
37: "real", /* 4 TREAL */
38: "\"nil\"", /* 5 TNIL */
39: };
40:
41: char **clnames = &clnxxxx[-(TFIRST)];
42:
43: /*
44: * Classify takes a pointer
45: * to a type and returns one
46: * of several interesting group
47: * classifications for easy use.
48: */
49: classify(p1)
50: struct nl *p1;
51: {
52: register struct nl *p;
53:
54: p = p1;
55: swit:
56: if (p == NIL) {
57: nocascade();
58: return (NIL);
59: }
60: if (p == &nl[TSTR])
61: return (TSTR);
62: switch (p->class) {
63: case PTR:
64: return (TPTR);
65: case ARRAY:
66: if (p->type == nl+T1CHAR)
67: return (TSTR);
68: return (TARY);
69: case STR:
70: return (TSTR);
71: case SET:
72: return (TSET);
73: case RANGE:
74: p = p->type;
75: goto swit;
76: case TYPE:
77: if (p <= nl+TLAST)
78: return (p - nl);
79: panic("clas2");
80: case FILET:
81: return (TFILE);
82: case RECORD:
83: return (TREC);
84: case SCAL:
85: return (TSCAL);
86: default:
87: panic("clas");
88: }
89: }
90:
91: #ifndef PI0
92: /*
93: * Is p a text file?
94: */
95: text(p)
96: struct nl *p;
97: {
98:
99: return (p != NIL && p->class == FILET && p->type == nl+T1CHAR);
100: }
101: #endif
102:
103: /*
104: * Scalar returns a pointer to
105: * the the base scalar type of
106: * its argument if its argument
107: * is a SCALar else NIL.
108: */
109: scalar(p1)
110: struct nl *p1;
111: {
112: register struct nl *p;
113:
114: p = p1;
115: if (p == NIL)
116: return (NIL);
117: if (p->class == RANGE)
118: p = p->type;
119: if (p == NIL)
120: return (NIL);
121: return (p->class == SCAL ? p : NIL);
122: }
123:
124: /*
125: * Isa tells whether p
126: * is one of a group of
127: * namelist classes. The
128: * classes wanted are specified
129: * by the characters in s.
130: * (Note that s would more efficiently,
131: * if less clearly, be given by a mask.)
132: */
133: isa(p, s)
134: register struct nl *p;
135: char *s;
136: {
137: register i;
138: register char *cp;
139:
140: if (p == NIL)
141: return (NIL);
142: /*
143: * map ranges down to
144: * the base type
145: */
146: if (p->class == RANGE)
147: p = p->type;
148: /*
149: * the following character/class
150: * associations are made:
151: *
152: * s scalar
153: * b Boolean
154: * c character
155: * i integer
156: * d double (real)
157: * t set
158: */
159: switch (p->class) {
160: case SET:
161: i = TDOUBLE+1;
162: break;
163: case SCAL:
164: i = 0;
165: break;
166: default:
167: i = p - nl;
168: }
169: if (i >= 0 && i <= TDOUBLE+1) {
170: i = "sbcidt"[i];
171: cp = s;
172: while (*cp)
173: if (*cp++ == i)
174: return (1);
175: }
176: return (NIL);
177: }
178:
179: /*
180: * Isnta is !isa
181: */
182: isnta(p, s)
183: {
184:
185: return (!isa(p, s));
186: }
187:
188: /*
189: * "shorthand"
190: */
191: nameof(p)
192: {
193:
194: return (clnames[classify(p)]);
195: }
196:
197: #ifndef PI0
198: nowexp(r)
199: int *r;
200: {
201: if (r[0] == T_WEXP) {
202: if (r[2] == NIL)
203: error("Oct/hex allowed only on writeln/write calls");
204: else
205: error("Width expressions allowed only in writeln/write calls");
206: return (1);
207: }
208: return (NIL);
209: }
210: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.