* Copyright (c) 1980 The Regents of the University of California.
* %sccs.include.redist.c%
static char sccsid
[] = "@(#)proc.c 5.2 (Berkeley) %G%";
* and the rest of the file
* The constant EXPOSIZE specifies the number of digits in the exponent
* The constant REALSPC defines the amount of forced padding preceeding
* real numbers when they are printed. If REALSPC == 0, then no padding
* is added, REALSPC == 1 adds one extra blank irregardless of the width
* N.B. - Values greater than one require program mods.
* 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 struct tnode
*alv
, *al
;
struct nl
*filetype
, *ap
, *al1
;
int argc
, typ
, fmtspec
, strfmt
, stkcnt
;
char fmt
, format
[20], *strptr
, *pu
;
int prec
, field
, strnglen
, fmtlen
, fmtstart
;
struct tnode
*pua
, *pui
, *puz
, *file
;
* Verify that the name is
* defined and is that of a
p
= lookup(r
->pcall_node
.proc_id
);
rvlist(r
->pcall_node
.arg
);
if (p
->class != PROC
&& p
->class != FPROC
) {
error("Can't call %s, its %s not a procedure", p
->symbol
, classes
[p
->class]);
rvlist(r
->pcall_node
.arg
);
argv
= r
->pcall_node
.arg
;
* Call handles user defined
* procedures and functions.
(void) call(p
, argv
, PROC
, bn
);
* Call to built-in procedure.
for (al
= argv
; al
!= TR_NIL
; al
= al
->list_node
.next
)
* 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");
(void) put(1, O_MESSAGE
);
error("flush takes at most one argument");
ap
= stklval(argv
->list_node
.list
, NIL
);
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.
(void) put(1, O_MESSAGE
);
} else if (argv
!= TR_NIL
&& (al
= argv
->list_node
.list
)->tag
!=
* If there is a first argument which has
* no write widths, then it is potentially
ap
= stkrval(argv
->list_node
.list
, NLNIL
, (long) RREQ
);
argv
= argv
->list_node
.next
;
if (ap
!= NLNIL
&& 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
file
= argv
->list_node
.list
;
(void) stklval(argv
->list_node
.list
, NIL
);
* Skip over the first argument
argv
= argv
->list_node
.next
;
(void) put(1, O_UNITOUT
);
output
->nl_flags
|= NUSED
;
(void) put(1, O_UNITOUT
);
output
->nl_flags
|= NUSED
;
for (; argv
!= TR_NIL
; argv
= argv
->list_node
.next
) {
* 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
al
= argv
->list_node
.list
;
alv
= al
->wexpr_node
.expr1
;
ap
= stkrval(alv
, NLNIL
, (long) 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.
if (al
->wexpr_node
.expr3
==
else if (al
->wexpr_node
.expr3
==
else if (al
->wexpr_node
.expr3
!= TR_NIL
) {
* Evaluate second format spec
if ( constval(al
->wexpr_node
.expr3
)
&& 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
if (al
->wexpr_node
.expr2
!= TR_NIL
) {
if ( constval(al
->wexpr_node
.expr2
)
&& 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.
(void) stklval(file
, NIL
);
ap
= rvalue(argv
->list_node
.list
, NLNIL
, LREQ
);
if (incompat(ap
, filetype
,
cerror("Type mismatch in write to non-text file");
(void) 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
, NLNIL
, (long) RREQ
);
ap
= stkrval(alv
, NLNIL
, (long) RREQ
);
stkcnt
+= sizeof(double);
ap
= stkrval(alv
, NLNIL
, (long) RREQ
);
convert(nl
+ T4INT
, INT_TYP
);
sizeof(char *) + sizeof(int));
ap
= stkrval(alv
, NLNIL
, (long) RREQ
);
convert(nl
+ T4INT
, INT_TYP
);
error("Writing %ss to text files is non-standard",
(void) stkrval(alv
, NLNIL
, (long) RREQ
);
(void) put(2, O_NAM
, (long)listnames(ap
));
stkcnt
+= sizeof(char *);
ap
= stkrval(alv
, (struct nl
*) TDOUBLE
, (long) RREQ
);
stkcnt
+= sizeof(double);
field
= 14 + (5 + EXPOSIZE
);
prec
= field
- (5 + EXPOSIZE
);
fmtspec
= CONWIDTH
+ CONPREC
;
prec
= field
- (5 + EXPOSIZE
);
switch ( classify( con
.ctype
) ) {
for (strnglen
= 0; *strptr
++; strnglen
++) /* void */;
if (fmtspec
& CONWIDTH
) {
* push string to implement leading blank padding
(void) put(2, O_LVCON
, 2);
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
->wexpr_node
.expr3
, NLNIL
,
error("Second write width must be integer, not %s", nameof(ap
));
(void) put(3, O_MAX
, 0, 0);
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((long) (sizeof(long)),
(void) put(2, O_LV
| cbn
<< 8 + INDX
,
tempnlp
-> value
[ NL_OFFS
] );
ap
= stkrval(al
->wexpr_node
.expr2
, NLNIL
, (long) RREQ
);
error("First write width must be integer, not %s", nameof(ap
));
* Perform special processing on widths based
if (fmtspec
== VARWIDTH
) {
(void) put(2, O_RV4
| cbn
<< 8 + INDX
,
tempnlp
-> value
[NL_OFFS
] );
5 + EXPOSIZE
+ REALSPC
, 1);
convert(nl
+T4INT
, INT_TYP
);
(void) put(2, O_RV4
| cbn
<< 8 + INDX
,
tempnlp
->value
[NL_OFFS
] );
(void) put(3, O_MAX
, REALSPC
, 1);
(void) put(2, O_RV4
| cbn
<< 8 + INDX
,
tempnlp
-> value
[ NL_OFFS
] );
(void) put(3, O_MAX
, strnglen
, 0);
(void) put(3, O_MAX
, 0, 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);
(void) put(2, O_LVCON
, fmtlen
);
putstr(&format
[fmtstart
], 0);
stkcnt
+= 2 * sizeof(char *);
(void) put(2, O_WRITEF
, stkcnt
);
* Write the string after its blank padding
(void) put(2, CON_INT
, 1);
(void) put(2, O_RV4
| cbn
<< 8 + INDX
,
tempnlp
-> value
[ NL_OFFS
] );
(void) put(2, O_MIN
, strnglen
);
convert(nl
+T4INT
, INT_TYP
);
(void) put(2, CON_INT
, strnglen
);
ap
= stkrval(alv
, NLNIL
, (long) 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
->list_node
.list
, NLNIL
, (long) RREQ
);
argv
= argv
->list_node
.next
;
if (ap
!= NLNIL
&& 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
file
= argv
->list_node
.list
;
(void) stklval(argv
->list_node
.list
, NIL
);
argv
= argv
->list_node
.next
;
(void) put(1, O_UNITINP
);
input
->nl_flags
|= NUSED
;
(void) put(1, O_UNITINP
);
input
->nl_flags
|= NUSED
;
for (; argv
!= TR_NIL
; argv
= argv
->list_node
.next
) {
* Get the address of the target
al
= argv
->list_node
.list
;
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
->list_node
.list
)) {
error("Type mismatch in read from non-text file");
(void) stklval(file
, NIL
);
(void) put(2, PTR_RV
, (int)input
->value
[0]);
if (isa(filetype
, "bcsi")) {
int filewidth
= width(filetype
);
(void) put(2, O_IND
, filewidth
);
(void) put(2, O_IND
, width(filetype
));
(void) put(2, O_AS
, width(ap
));
error("Can't read %ss from a text file", clnames
[typ
]);
(void) 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
);
(void) 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
->list_node
.list
, NIL
);
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
->list_node
.list
, MOD
|NOUSE
);
if (ap
->class != FILET
) {
error("First argument to %s must be a file, not %s", p
->symbol
, nameof(ap
));
(void) put(2, O_CON24
, text(ap
) ? 0: width(ap
->type
));
* Optional second argument
* UNIX (R) file to be associated.
al
= argv
->list_node
.next
;
al
= (struct tnode
*) stkrval(al
->list_node
.list
,
(struct nl
*) NOFLAGS
, (long) RREQ
);
if (classify((struct nl
*) al
) != TSTR
) {
error("Second argument to %s must be a string, not %s", p
->symbol
, nameof((struct nl
*) al
));
(void) put(2, O_CON24
, width((struct nl
*) al
));
al
= argv
->list_node
.next
;
al
= (struct tnode
*) stkrval(al
->list_node
.list
,
(struct nl
*) NOFLAGS
, (long) RREQ
);
(void) put(2, O_CON24
, 0);
(void) put(2, PTR_CON
, NIL
);
ap
= stklval(argv
->list_node
.list
, MOD
|NOUSE
);
error("%s expects at least one argument", p
->symbol
);
ap
= stklval(argv
->list_node
.list
,
op
== O_NEW
? ( MOD
| NOUSE
) : MOD
);
error("(First) argument to %s must be a pointer, not %s", p
->symbol
, nameof(ap
));
if ((ap
->nl_flags
& NFILES
) && op
== O_DISPOSE
)
argv
= argv
->list_node
.next
;
if (ap
->class != RECORD
) {
error("Record required when specifying variant tags");
for (; argv
!= TR_NIL
; argv
= argv
->list_node
.next
) {
if (ap
->ptr
[NL_VARNT
] == NIL
) {
error("Too many tag fields");
if (!isconst(argv
->list_node
.list
)) {
error("Second and successive arguments to %s must be constants", p
->symbol
);
gconst(argv
->list_node
.list
);
if (incompat(con
.ctype
, (
ap
->ptr
[NL_TAG
])->type
, TR_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");
(void) put(2, op
, width(ap
));
error("%s expects one argument", p
->symbol
);
ap
= stklval(argv
->list_node
.list
, 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");
noreach
= TRUE
; /* used to be 1 */
error("argv takes two arguments");
ap
= stkrval(argv
->list_node
.list
, NLNIL
, (long) RREQ
);
error("argv's first argument must be an integer, not %s", nameof(ap
));
al
= argv
->list_node
.next
;
ap
= stklval(al
->list_node
.list
, MOD
|NOUSE
);
if (classify(ap
) != TSTR
) {
error("argv's second argument must be a string, not %s", nameof(ap
));
(void) put(2, op
, width(ap
));
error("stlimit requires one argument");
ap
= stkrval(argv
->list_node
.list
, NLNIL
, (long) RREQ
);
error("stlimit's argument must be an integer, not %s", nameof(ap
));
error("remove expects one argument");
ap
= stkrval(argv
->list_node
.list
, (struct nl
*) NOFLAGS
,
if (classify(ap
) != TSTR
) {
error("remove's argument must be a string, not %s", nameof(ap
));
(void) put(2, O_CON24
, width(ap
));
ap
= stkrval(argv
->list_node
.list
, (struct nl
*) NOFLAGS
,
error("linelimit expects two arguments");
al
= argv
->list_node
.next
;
ap
= stkrval(al
->list_node
.list
, NLNIL
, (long) RREQ
);
error("linelimit's second argument must be an integer, not %s", nameof(ap
));
ap
= stklval(argv
->list_node
.list
, NOFLAGS
|NOUSE
);
error("linelimit's first argument must be a text file, not %s", nameof(ap
));
error("page expects one argument");
ap
= stklval(argv
->list_node
.list
, NIL
);
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
= argv
->list_node
.next
;
al1
= stkrval(al
->list_node
.list
, NLNIL
, (long) RREQ
);
if (classify(al1
) != TSTR
) {
error("Second argument to assert must be a string, not %s", nameof(al1
));
(void) put(2, PTR_CON
, NIL
);
ap
= stkrval(argv
->list_node
.list
, NLNIL
, (long) RREQ
);
error("Assert expression must be Boolean, not %ss", nameof(ap
));
error("pack expects three arguments");
pua
= argv
->list_node
.list
;
al
= argv
->list_node
.next
;
pui
= al
->list_node
.list
;
alv
= al
->list_node
.next
;
puz
= alv
->list_node
.list
;
error("unpack expects three arguments");
puz
= argv
->list_node
.list
;
al
= argv
->list_node
.next
;
pua
= al
->list_node
.list
;
alv
= al
->list_node
.next
;
pui
= alv
->list_node
.list
;
ap
= stklval(pua
, op
== O_PACK
? NOFLAGS
: MOD
|NOUSE
);
al1
= 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 (al1
->class != ARRAY
) {
error("%s requires z to be a packed array, not %s", pu
, nameof(ap
));
if (al1
->type
== NIL
|| ap
->type
== NIL
)
if (al1
->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
|| al1
->chain
!= NIL
) {
error("%s requires a and z to be single dimension arrays", pu
);
if (ap
== NIL
|| al1
== NIL
)
* al1 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
= al1
->range
[1] - al1
->range
[0] + 1;
error("%s cannot have more elements in a (%d) than in z (%d)", pu
, (char *) j
, (char *) i
);
* get n-m-(v-u) and m for the interpreter
(void) put(2, O_CON24
, k
);
(void) put(2, O_CON24
, i
);
(void) put(2, O_CON24
, j
);
(void) put(2, O_CON24
, itemwidth
);
al1
= stklval(puz
, op
== O_UNPACK
? NOFLAGS
: MOD
|NOUSE
);
ap
= stklval(pua
, op
== O_PACK
? NOFLAGS
: MOD
|NOUSE
);
ap
= stkrval(pui
, NLNIL
, (long) RREQ
);
error("%s is an unimplemented extension", p
->symbol
);