/* Copyright (c) 1979 Regents of the University of California */
* pi - Pascal interpreter code translator
* Charles Haley, Bill Joy UCB
* Version 1.2 January 1979
* The following arrays are used to determine which classes may be
* read and written to/from text files.
* They are indexed by the return types from classify.
#define rdops(x) rdxxxx[(x)-(TFIRST)]
#define wrops(x) wrxxxx[(x)-(TFIRST)]
0, /* -3 pointer types */
0, /* 0 nil - i.e. no type */
O_READC
, /* 2 character */
0, /* -3 pointer types */
O_WRITG
, /* -1 string types */
0, /* 0 nil - i.e. no type */
O_WRITB
, /* 1 booleans */
O_WRITC
, /* 2 character */
* Proc handles procedure calls.
* Non-builtin procedures are "buck-passed" to func (with a flag
* indicating that they are actually procedures.
* builtin procedures are handled here.
struct nl
*filetype
, *ap
;
int argc
, *argv
, c
, two
, oct
, hex
, *file
;
* Verify that the name is
* defined and is that of a
error("Can't call %s, its %s not a procedure", p
->symbol
, classes
[p
->class]);
* Call handles user defined
* procedures and functions.
* Call to built-in procedure.
for (al
= argv
; al
!= NIL
; al
= al
[2])
* associated with the built-in
* procedure in the namelist
op
= p
->value
[0] &~ NSTAND
;
if (opt('s') && (p
->value
[0] & NSTAND
)) {
error("%s is a nonstandard procedure", p
->symbol
);
error("null takes no arguments");
error("flush takes at most one argument");
ap
= rvalue(argv
[1], NIL
);
error("flush's argument must be a file, not %s", nameof(ap
));
* Set up default file "output"'s type
* Determine the file implied
* for the write and generate
* code to make it the active file.
* For message, all that matters
* is that the filetype is
* Thus "output" will suit us fine.
} else if (argv
!= NIL
&& (al
= argv
[1])[0] != T_WEXP
) {
* If there is a first argument which has
* no write widths, then it is potentially
ap
= rvalue(argv
[1], NIL
);
if (ap
!= NIL
&& ap
->class == FILE) {
* Got "write(f, ...", make
* f the active file, and save
* it and its type for use in
* processing the rest of the
* Skip over the first argument
for (; argv
!= NIL
; argv
= argv
[2]) {
* accumulate width information,
* and two records the fact
* that we saw two write widths
if (filetype
!= nl
+T1CHAR
) {
error("Write widths allowed only with text files");
* Handle width expressions.
* The basic game here is that width
* expressions get evaluated and left
* on the stack and their width's get
* packed into the high byte of the
* affected opcode (subop).
* opcode that takes two widths
error("Second write width must be integer, not %s", nameof(ap
));
op
=| even(width(ap
)) << 11;
error("First write width must be integer, not %s", nameof(ap
));
op
=| even(width(ap
)) << 8;
if (filetype
!= nl
+T1CHAR
) {
error("Oct/hex allowed only on text files");
error("Write widths allowed only on text files");
* Generalized write, i.e.
ap
= rvalue(argv
[1], NIL
);
if (incompat(ap
, filetype
, argv
[1])) {
cerror("Type mismatch in write to non-text file");
put2(O_AS
, width(filetype
));
* Evaluate the expression
if (two
&& c
!= TDOUBLE
) {
error("Only reals can have two write widths");
error("Oct and hex are non-standard");
error("Can't write %ss with oct/hex", clnames
[c
]);
put1(op
| (oct
? O_WROCT2
: O_WRHEX2
) | (width(ap
) >> 2));
error("Can't write %ss to a text file", clnames
[c
]);
if (c
== TINT
&& width(ap
) != 4)
* insufficent number of args.
switch (p
->value
[0] &~ NSTAND
) {
error("Write requires an argument");
error("Message requires an argument");
if (filetype
!= nl
+T1CHAR
)
error("Can't 'writeln' a non text file");
* Determine the file implied
* for the read and generate
* code to make it the active file.
ap
= rvalue(argv
[1], NIL
);
if (ap
!= NIL
&& ap
->class == FILE) {
* Got "read(f, ...", make
* f the active file, and save
* it and its type for use in
* processing the rest of the
input
->nl_flags
=| NUSED
;
input
->nl_flags
=| NUSED
;
for (; argv
!= NIL
; argv
= argv
[2]) {
* Get the address of the target
error("Arguments to %s must be variables, not expressions", p
->symbol
);
ap
= lvalue(al
, MOD
|ASGN
|NOUSE
);
if (filetype
!= nl
+T1CHAR
) {
if (incompat(filetype
, ap
, NIL
)) {
error("Type mismatch in read from non-text file");
put2(O_RV2
, input
->value
[0]);
put2(O_IND
, width(filetype
));
error("Can't read %ss from a text file", clnames
[c
]);
* Data read is on the stack.
rangechk(ap
, op
== O_READC
? ap
: nl
+T4INT
);
gen(O_AS2
, O_AS2
, width(ap
),
op
== O_READ8
? 8 : op
== O_READ4
? 4 : 2);
* insufficient number of args.
if (p
->value
[0] == O_READLN
) {
if (filetype
!= nl
+T1CHAR
)
error("Can't 'readln' a non text file");
error("read requires an argument");
error("%s expects one argument", p
->symbol
);
ap
= rvalue(argv
[1], NIL
);
error("Argument to %s must be a file, not %s", p
->symbol
, nameof(ap
));
if (argc
== 0 || argc
> 2) {
error("%s expects one or two arguments", p
->symbol
);
if (opt('s') && argc
== 2) {
error("Two argument forms of reset and rewrite are non-standard");
ap
= lvalue(argv
[1], MOD
|NOUSE
);
error("First argument to %s must be a file, not %s", p
->symbol
, nameof(ap
));
* Optional second argument
* UNIX (R) file to be associated.
if (classify(al
) != TSTR
) {
error("Second argument to %s must be a string, not %s", p
->symbol
, nameof(al
));
error("File name too long");
put2(op
| c
<< 8, text(ap
) ? 0: width(ap
->type
));
error("%s expects at least one argument", p
->symbol
);
ap
= lvalue(argv
[1], MOD
|NOUSE
);
error("(First) argument to %s must be a pointer, not %s", p
->symbol
, nameof(ap
));
if (ap
->class != RECORD
) {
error("Record required when specifying variant tags");
for (; argv
!= NIL
; argv
= argv
[2]) {
if (ap
->value
[NL_VARNT
] == NIL
) {
error("Too many tag fields");
error("Second and successive arguments to %s must be constants", p
->symbol
);
if (incompat(con
.ctype
, ap
->value
[NL_TAG
]->type
)) {
cerror("Specified tag constant type clashed with variant case selector type");
for (ap
= ap
->value
[NL_VARNT
]; ap
!= NIL
; ap
= ap
->chain
)
if (ap
->range
[0] == con
.crval
)
error("No variant case label value equals specified constant value");
ap
= ap
->value
[NL_VTOREC
];
error("%s expects one argument", p
->symbol
);
ap
= lvalue(argv
[1], MOD
|NOUSE
);
if (classify(ap
) != TSTR
|| width(ap
) != 10) {
error("Argument to %s must be a alfa, not %s", p
->symbol
, nameof(ap
));
error("halt takes no arguments");
error("argv takes two arguments");
ap
= rvalue(argv
[1], NIL
);
error("argv's first argument must be an integer, not %s", nameof(ap
));
ap
= lvalue(al
[1], MOD
|NOUSE
);
if (classify(ap
) != TSTR
) {
error("argv's second argument must be a string, not %s", nameof(ap
));
error("stlimit requires one argument");
ap
= rvalue(argv
[1], NIL
);
error("stlimit's argument must be an integer, not %s", nameof(ap
));
error("remove expects one argument");
ap
= rvalue(argv
[1], NIL
);
if (classify(ap
) != TSTR
) {
error("remove's argument must be a string, not %s", nameof(ap
));
error("linelimit expects two arguments");
ap
= lvalue(argv
[1], NOMOD
|NOUSE
);
error("linelimit's first argument must be a text file, not %s", nameof(ap
));
error("linelimit's second argument must be an integer, not %s", nameof(ap
));
error("page expects one argument");
ap
= rvalue(argv
[1], NIL
);
error("Argument to page must be a text file, not %s", nameof(ap
));
error("pack expects three arguments");
error("unpack expects three arguments");
ap
= lvalue(pua
, op
== O_PACK
? NOMOD
: MOD
|NOUSE
);
if (ap
->class != ARRAY
) {
error("%s requires a to be an unpacked array, not %s", pu
, nameof(ap
));
al
= lvalue(puz
, op
== O_UNPACK
? NOMOD
: MOD
|NOUSE
);
if (al
->class != ARRAY
) {
error("%s requires z to be a packed array, not %s", pu
, nameof(ap
));
if (al
->type
== NIL
|| ap
->type
== NIL
)
if (al
->type
!= ap
->type
) {
error("%s requires a and z to be arrays of the same type", pu
, nameof(ap
));
if (ap
->chain
!= NIL
|| al
->chain
!= NIL
) {
error("%s requires a and z to be single dimension arrays", pu
);
if (ap
== NIL
|| al
== NIL
)
* al is the range for z i.e. u..v
* ap is the range for a i.e. m..n
i
= ap
->range
[1] - ap
->range
[0] + 1;
j
= al
->range
[1] - al
->range
[0] + 1;
error("%s cannot have more elements in a (%d) than in z (%d)", pu
, j
, i
);
* get n-m-(v-u) and m for the interpreter
put(5, op
, width(ap
), j
, i
, k
);
error("%s is an unimplemented 6400 extension", p
->symbol
);