/* Copyright (c) 1979 Regents of the University of California */
* pi - Pascal interpreter code translator
* Charles Haley, Bill Joy UCB
* Version 1.2 January 1979
* Array of information about pre-defined, block 0 symbols.
TINT
, 0177777, 0177600, 0, 0177,
TINT
, 0177777, 0100000, 0, 077777,
TINT
, 0100000, 0, 077777, 0177777,
TDOUBLE
, 0, 0, 0, 0, /* fake for reals */
* Built-in composite types
"maxchar", T1CHAR
, 0177, 0,
"minint", T4INT
, 0100000, 0, /* Must be last 2! */
"maxint", T4INT
, 077777, 0177777,
"undefined", O_UNDEF
|NSTAND
,
"random", O_RANDOM
|NSTAND
,
"wallclock", O_WCLCK
|NSTAND
,
"sysclock", O_SCLCK
|NSTAND
,
"linelimit", O_LLIMIT
|NSTAND
,
"message", O_MESSAGE
|NSTAND
,
"remove", O_REMOVE
|NSTAND
,
"stlimit", O_STLIM
|NSTAND
,
* NAMELIST SEGMENT DEFINITIONS
* Initnl initializes the first namelist segment and then
* uses the array biltins to initialize the name list for
ntab
[0].nls_high
= &nl
[INL
];
for (q
= biltins
; *q
!= 0; q
++)
hdefnl(*q
, TYPE
, nlp
, 0);
p
= defnl(0, RANGE
, nl
+*q
, 0);
nl
[T4INT
].range
[0] = MININT
;
nl
[T4INT
].range
[1] = MAXINT
;
* Pre-defined composite types
hdefnl(*q
++, TYPE
, nl
+T1BOOL
, 0);
enter(defnl((intset
= *q
++), TYPE
, nlp
+1, 0));
defnl(0, RANGE
, nl
+TINT
, 0)->value
[3] = 127;
p
= defnl(0, RANGE
, nl
+TINT
, 0);
defnl(0, ARRAY
, nl
+T1CHAR
, 1)->chain
= p
;
hdefnl(*q
++, TYPE
, nlp
-1, 0); /* "alfa" */
hdefnl(*q
++, TYPE
, nlp
+1, 0); /* "text" */
p
= defnl(0, FILE, nl
+T1CHAR
, 0);
input
= hdefnl(*q
++, VAR
, p
, -2); /* "input" */
output
= hdefnl(*q
++, VAR
, p
, -4); /* "output" */
input
= hdefnl(*q
++, VAR
, p
, 0); /* "input" */
output
= hdefnl(*q
++, VAR
, p
, 0); /* "output" */
hdefnl(q
[0], CONST
, nl
+q
[1], q
[2])->value
[1] = q
[3];
nlp
[-2].range
[0] = MININT
;
nlp
[-1].range
[0] = MAXINT
;
* Built-in procedures and functions
hdefnl(q
[0], FUNC
, 0, q
[1]);
hdefnl(q
[0], PROC
, 0, q
[1]);
hdefnl(*q
++, FUNC
, 0, 0);
hdefnl(*q
++, PROC
, 0, 0);
hdefnl(sym
, cls
, typ
, val
)
p
= defnl(sym
, cls
, typ
, val
);
* Free up the name list segments
* at the end of a statement/proc/func
* All segments are freed down to the one in which
while (nlact
->nls_low
> nlp
|| nlact
->nls_high
< nlp
) {
char VARIABLE
[] "variable";
* Dump the namelist from the
* current nlp down to 'to'.
* All the namelist is dumped if
printf("\n\"%s\" Block=%d\n", rout
, cbn
);
for (p
= nlp
; p
!= to
;) {
if (p
== nlsp
->nls_low
) {
printf("\tName\tClass Bn+Flags\tType\tVal\tChn\n");
printf("%3d:", nloff(p
));
printf("\t%.7s", p
->symbol
);
printf("\t%s", ctext
[p
->class]);
printf("%d ", p
->nl_flags
& 037);
if (p
->nl_flags
& NFILES
)
printf("\t[%d]", nloff(p
->type
));
switch (nloff(p
->type
)) {
printf("\t%ld", p
->range
[0]);
printf("\t%d,%d", cbn
, v
);
printf("\t%ld..%ld", p
->range
[0], p
->range
[1]);
printf("\t%d(%d)", v
, p
->value
[NL_FLDSZ
]);
printf("\t\"%s\"", p
->value
[1]);
printf("\t<%o>", p
->value
[0] & 0377);
if (p
->value
[0] & NSTAND
)
printf("\t[%d]", nloff(p
->chain
));
printf("\tVARNT=[%d]", nloff(p
->value
[NL_VARNT
]));
printf(" TAG=[%d]", nloff(p
->value
[NL_TAG
]));
printf("\tVTOREC=[%d]", nloff(p
->value
[NL_VTOREC
]));
printf("\tNo entries\n");
* Define a new name list entry
* with initial symbol, class, type
* and value[0] as given. A new name
* list segment is allocated to hold
* the next name list slot if necessary.
defnl(sym
, cls
, typ
, val
)
* Insure that the next namelist
* entry actually exists. This is
* really not needed here, it would
* suffice to do it at entry if we
* need the slot. It is done this
* way because, historically, nlp
* always pointed at the next namelist
if (nlp
>= nlact
->nls_high
) {
cp
= alloc(NLINC
* sizeof *nlp
);
cp
= alloc((NLINC
/ 2) * sizeof *nlp
);
error("Ran out of memory (defnl)");
if (nlact
>= &ntab
[MAXNL
]) {
error("Ran out of name list tables");
nlact
->nls_high
= nlact
->nls_low
+ i
;
* Make a duplicate of the argument
* namelist entry for, e.g., type
* declarations of the form 'type a = b'
register int *p1
, *p2
, i
;
p
= p2
= defnl(0, 0, 0, 0);
* Compute a namelist offset
* Enter a symbol into the block
* symbol table. Symbols are hashed
* 64 ways based on low 6 bits of the
* character pointer into the string
register struct nl
*rp
, *hp
;
if (rp
->symbol
== input
->symbol
|| rp
->symbol
== output
->symbol
)
error("Pre-defined files input and output must not be redefined");
if (rp
->class != BADUSE
&& rp
->class != FIELD
)
for (p
= hp
; p
!= NIL
&& (p
->nl_block
& 037) == cbn
; p
= p
->nl_next
)
if (p
->symbol
== rp
->symbol
&& p
->class != BADUSE
&& p
->class != FIELD
) {
error("%s is already defined in this block", rp
->symbol
);
double MININT
-2147483648.;
double MAXINT
2147483647.;