/* Copyright (c) 1979 Regents of the University of California */
static char sccsid
[] = "@(#)proc.c 1.11 %G%";
* and the rest of the file
* The following array is used to determine which classes may be read
* from textfiles. It is indexed by the return value from classify.
#define rdops(x) rdxxxx[(x)-(TFIRST)]
O_READE
, /* -4 scalar types */
0, /* -3 pointer types */
O_READC
, /* 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.
register int *alv
, *al
, op
;
struct nl
*filetype
, *ap
;
int argc
, *argv
, typ
, fmtspec
, strfmt
, stkcnt
, *file
;
char fmt
, format
[20], *strptr
;
int prec
, field
, strnglen
, fmtlen
, fmtstart
, pu
;
* Verify that the name is
* defined and is that of a
if (p
->class != PROC
&& p
->class != FPROC
) {
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
= stklval(argv
[1], NIL
, LREQ
);
if (ap
->class != FILET
) {
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
= stkrval(argv
[1], NIL
, RREQ
);
if (ap
!= NIL
&& ap
->class == FILET
) {
* Got "write(f, ...", make
* f the active file, and save
* it and its type for use in
* processing the rest of the
stklval(argv
[1], NIL
, LREQ
);
* Skip over the first argument
for (; argv
!= NIL
; argv
= argv
[2]) {
* fmtspec indicates the type (CONstant or VARiable)
* and number (none, WIDTH, and/or PRECision)
* of the fields in the printf format for this
* stkcnt is the number of bytes pushed on the stack
* fmt is the format output indicator (D, E, F, O, X, S)
* fmtstart = 0 for leading blank; = 1 for no blank
ap
= stkrval(alv
, NIL
, RREQ
);
* Handle width expressions.
* The basic game here is that width
* expressions get evaluated. If they
* are constant, the value is placed
* directly in the format string.
* Otherwise the value is pushed onto
* the stack and an indirection is
* put into the format string.
* Evaluate second format spec
&& isa( con
.ctype
, "i" ) ) {
error("Writing %ss with two write widths is non-standard", clnames
[typ
]);
error("Cannot write %ss with two write widths", clnames
[typ
]);
* Evaluate first format spec
&& isa( con
.ctype
, "i" ) ) {
if ((fmtspec
& CONPREC
) && prec
< 0 ||
(fmtspec
& CONWIDTH
) && field
< 0) {
error("Negative widths are not allowed");
((fmtspec
& CONPREC
) && prec
== 0 ||
(fmtspec
& CONWIDTH
) && field
== 0)) {
error("Zero widths are non-standard");
if (filetype
!= nl
+T1CHAR
) {
if (fmt
== 'O' || fmt
== 'X') {
error("Oct/hex allowed only on text files");
error("Write widths allowed only on text files");
* Generalized write, i.e.
stklval(file
, NIL
, LREQ
);
ap
= rvalue(argv
[1], NIL
);
if (incompat(ap
, filetype
, argv
[1])) {
cerror("Type mismatch in write to non-text file");
put(2, O_AS
, width(filetype
));
* Evaluate the expression
if (fmt
== 'O' || fmt
== 'X') {
error("Oct and hex are non-standard");
if (typ
== TSTR
|| typ
== TDOUBLE
) {
error("Can't write %ss with oct/hex", clnames
[typ
]);
if (typ
== TCHAR
|| typ
== TBOOL
)
* Place the arguement on the stack. If there is
* no format specified by the programmer, implement
error("Writing %ss to text files is non-standard",
ap
= stkrval(alv
, NIL
, RREQ
);
ap
= stkrval(alv
, NIL
, RREQ
);
stkcnt
+= sizeof(double);
ap
= stkrval(alv
, NIL
, RREQ
);
convert(nl
+ T4INT
, INT_TYP
);
sizeof(char *) + sizeof(int));
ap
= stkrval(alv
, NIL
, RREQ
);
convert(nl
+ T4INT
, INT_TYP
);
error("Writing %ss to text files is non-standard",
stkrval(alv
, NIL
, RREQ
);
put(2, O_NAM
, (long)listnames(ap
));
stkcnt
+= sizeof(char *);
ap
= stkrval(alv
, TDOUBLE
, RREQ
);
stkcnt
+= sizeof(double);
fmtspec
= CONWIDTH
+ CONPREC
;
switch ( classify( con
.ctype
) ) {
for (strnglen
= 0; *strptr
++; strnglen
++) /* void */;
if (fmtspec
& CONWIDTH
) {
* push string to implement leading blank padding
stkcnt
+= sizeof(char *);
error("Can't write %ss to a text file", clnames
[typ
]);
* If there is a variable precision, evaluate it onto
ap
= stkrval(al
[3], NIL
, RREQ
);
error("Second write width must be integer, not %s", nameof(ap
));
convert(nl
+T4INT
, INT_TYP
);
* If there is a variable width, evaluate it onto
if (fmtspec
& VARWIDTH
) {
if ( ( typ
== TDOUBLE
&& fmtspec
== VARWIDTH
)
soffset
= sizes
[cbn
].curtmps
;
tempnlp
= tmpalloc(sizeof(long),
put(2, O_LV
| cbn
<< 8 + INDX
,
tempnlp
-> value
[ NL_OFFS
] );
ap
= stkrval(al
[2], NIL
, RREQ
);
error("First write width must be integer, not %s", nameof(ap
));
* Perform special processing on widths based
if (fmtspec
== VARWIDTH
) {
put(2, O_RV4
| cbn
<< 8 + INDX
,
tempnlp
-> value
[NL_OFFS
] );
convert(nl
+T4INT
, INT_TYP
);
put(2, O_RV4
| cbn
<< 8 + INDX
,
tempnlp
->value
[NL_OFFS
] );
put(2, O_RV4
| cbn
<< 8 + INDX
,
tempnlp
-> value
[ NL_OFFS
] );
put(3, O_MAX
, strnglen
, 0);
convert(nl
+T4INT
, INT_TYP
);
* Generate the format string
sprintf(&format
[1], "%%%c", fmt
);
sprintf(&format
[1], "%%%d%c", field
, fmt
);
sprintf(&format
[1], "%%*%c", fmt
);
sprintf(&format
[1], "%%%d.%d%c", field
, prec
, fmt
);
sprintf(&format
[1], "%%%d.*%c", field
, fmt
);
sprintf(&format
[1], "%%*.%d%c", prec
, fmt
);
sprintf(&format
[1], "%%*.*%c", fmt
);
fmtlen
= lenstr(&format
[fmtstart
], 0);
putstr(&format
[fmtstart
], 0);
stkcnt
+= 2 * sizeof(char *);
put(2, O_WRITEF
, stkcnt
);
* Write the string after its blank padding
put(2, O_RV4
| cbn
<< 8 + INDX
,
tempnlp
-> value
[ NL_OFFS
] );
convert(nl
+T4INT
, INT_TYP
);
put(2, CON_INT
, strnglen
);
ap
= stkrval(alv
, NIL
, RREQ
);
2 * sizeof(char *) + 2 * sizeof(int));
* 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
= stkrval(argv
[1], NIL
, RREQ
);
if (ap
!= NIL
&& ap
->class == FILET
) {
* Got "read(f, ...", make
* f the active file, and save
* it and its type for use in
* processing the rest of the
stklval(argv
[1], NIL
, LREQ
);
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
= stklval(al
, MOD
|ASGN
|NOUSE
);
if (filetype
!= nl
+T1CHAR
) {
if (incompat(filetype
, ap
, argv
[1] )) {
error("Type mismatch in read from non-text file");
stklval(file
, NIL
, LREQ
);
put(2, PTR_RV
, (int)input
->value
[0]);
put(2, O_IND
, width(filetype
));
error("Can't read %ss from a text file", clnames
[typ
]);
put(2, op
, (long)listnames(ap
));
error("Reading scalars from text files is non-standard");
* Data read is on the stack.
if (op
!= O_READ8
&& op
!= O_READE
)
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
= stklval(argv
[1], NIL
, LREQ
);
if (ap
->class != FILET
) {
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
= stklval(argv
[1], MOD
|NOUSE
);
if (ap
->class != FILET
) {
error("First argument to %s must be a file, not %s", p
->symbol
, nameof(ap
));
put(2, O_CON24
, text(ap
) ? 0: width(ap
->type
));
* Optional second argument
* UNIX (R) file to be associated.
al
= stkrval(al
[1], NOFLAGS
, RREQ
);
if (classify(al
) != TSTR
) {
error("Second argument to %s must be a string, not %s", p
->symbol
, nameof(al
));
put(2, O_CON24
, width(al
));
al
= stkrval(al
[1], NOFLAGS
, RREQ
);
ap
= stklval(argv
[1], MOD
|NOUSE
);
error("%s expects at least one argument", p
->symbol
);
ap
= stklval(argv
[1], op
== O_NEW
? ( MOD
| NOUSE
) : MOD
);
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
->ptr
[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
->ptr
[NL_TAG
])->type
, NIL
)) {
cerror("Specified tag constant type clashed with variant case selector type");
for (ap
= ap
->ptr
[NL_VARNT
]; ap
!= NIL
; ap
= ap
->chain
)
if (ap
->range
[0] == con
.crval
)
error("No variant case label value equals specified constant value");
error("%s expects one argument", p
->symbol
);
ap
= stklval(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
= stkrval(argv
[1], NIL
, RREQ
);
error("argv's first argument must be an integer, not %s", nameof(ap
));
ap
= stklval(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
= stkrval(argv
[1], NIL
, RREQ
);
error("stlimit's argument must be an integer, not %s", nameof(ap
));
error("remove expects one argument");
ap
= stkrval(argv
[1], NOFLAGS
, RREQ
);
if (classify(ap
) != TSTR
) {
error("remove's argument must be a string, not %s", nameof(ap
));
put(2, O_CON24
, width(ap
));
ap
= stkrval(argv
[1], NOFLAGS
, RREQ
);
error("linelimit expects two arguments");
ap
= stkrval(al
[1], NIL
, RREQ
);
error("linelimit's second argument must be an integer, not %s", nameof(ap
));
ap
= stklval(argv
[1], NOFLAGS
|NOUSE
);
error("linelimit's first argument must be a text file, not %s", nameof(ap
));
error("page expects one argument");
ap
= stklval(argv
[1], NIL
, LREQ
);
error("Argument to page must be a text file, not %s", nameof(ap
));
if (argc
== 0 || argc
> 2) {
error("Assert expects one or two arguments");
* Optional second argument is a string specifying
* why the assertion failed.
al
= stkrval(al
[1], NIL
, RREQ
);
if (classify(al
) != TSTR
) {
error("Second argument to assert must be a string, not %s", nameof(al
));
ap
= stkrval(argv
[1], NIL
, RREQ
);
error("Assert expression must be Boolean, not %ss", nameof(ap
));
error("pack expects three arguments");
error("unpack expects three arguments");
ap
= stklval(pua
, op
== O_PACK
? NOFLAGS
: MOD
|NOUSE
);
al
= (struct nl
*) stklval(puz
, op
== O_UNPACK
? NOFLAGS
: MOD
|NOUSE
);
if (ap
->class != ARRAY
) {
error("%s requires a to be an unpacked array, not %s", pu
, nameof(ap
));
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
));
itemwidth
= width(ap
->type
);
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(2, O_CON24
, itemwidth
);
al
= (struct nl
*) stklval(puz
, op
== O_UNPACK
? NOFLAGS
: MOD
|NOUSE
);
ap
= stklval(pua
, op
== O_PACK
? NOFLAGS
: MOD
|NOUSE
);
ap
= stkrval((int *) pui
, NLNIL
, RREQ
);
error("%s is an unimplemented extension", p
->symbol
);