* Copyright (c) 1980 The Regents of the University of California.
* %sccs.include.redist.c%
static char sccsid
[] = "@(#)pcproc.c 5.2 (Berkeley) %G%";
* and to the end 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.
struct tnode
*r
; /* T_PCALL */
register struct tnode
*alv
, *al
;
struct nl
*filetype
, *ap
;
int argc
, typ
, fmtspec
, strfmt
;
struct tnode
*argv
, *file
;
char fmt
, format
[20], *strptr
, *cmd
;
int prec
, field
, strnglen
, fmtstart
;
struct tnode
*pua
, *pui
, *puz
;
* 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");
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, "_PFLUSH" );
putop( PCCOM_UNARY PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("flush takes at most one argument");
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stklval(argv
->list_node
.list
, NOFLAGS
);
if (ap
->class != FILET
) {
error("flush's argument must be a file, not %s", nameof(ap
));
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
* 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.
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, "_PFLUSH" );
putop( PCCOM_UNARY PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
putRV( (char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
,
putLV( "__err" , 0 , 0 , NGLOBAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
} 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
!= 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
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
,
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
file
= argv
->list_node
.list
;
(void) stklval(argv
->list_node
.list
, NOFLAGS
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
* Skip over the first argument
argv
= argv
->list_node
.next
;
putRV((char *) 0, cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putLV( "_output" , 0 , 0 , NGLOBAL
,
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
output
->nl_flags
|= NUSED
;
putRV((char *) 0, cbn
, CURFILEOFFSET
, NLOCAL
,
putLV( "_output" , 0 , 0 , NGLOBAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
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
* 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.
putleaf( PCC_ICON
, 0 , 0
PCCM_ADDTYPE( p2type( filetype
)
(void) stklval(file
, NOFLAGS
);
, PCCM_ADDTYPE( p2type( filetype
) , PCCTM_PTR
) );
putop( PCCOM_UNARY PCC_MUL
, p2type( filetype
) );
switch ( classify( filetype
) ) {
precheck( filetype
, "_RANG4" , "_RSNG4" );
ap
= rvalue( argv
->list_node
.list
, filetype
, RREQ
);
ap
= rvalue( argv
->list_node
.list
, filetype
, LREQ
);
if (incompat(ap
, filetype
, argv
->list_node
.list
)) {
cerror("Type mismatch in write to non-text file");
switch ( classify( filetype
) ) {
sconv(p2type(ap
), p2type(filetype
));
putop( PCC_ASSIGN
, p2type( filetype
) );
putdot( filename
, line
);
PCCM_ADDTYPE(p2type(filetype
),
putdot( filename
, line
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
,
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
* 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
)
* If there is no format specified by the programmer,
error("Writing %ss to text files is non-standard",
error("Writing %ss to text files is non-standard",
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
) {
error("Can't write %ss to a text file", clnames
[typ
]);
* Generate the format string
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
|PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
(void) stkrval( alv
, NLNIL
, (long) RREQ
);
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
|PCCT_INT
, PCCTM_PTR
)
(void) stkrval( alv
, NLNIL
,
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0, cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
sprintf(&format
[1], "%%%c", fmt
);
sprintf(&format
[1], "%%%1D%c", field
, fmt
);
sprintf(&format
[1], "%%*%c", fmt
);
sprintf(&format
[1], "%%%1D.%1D%c", field
, prec
, fmt
);
sprintf(&format
[1], "%%%1D.*%c", field
, fmt
);
sprintf(&format
[1], "%%*.%1D%c", prec
, fmt
);
sprintf(&format
[1], "%%*.*%c", fmt
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_CALL
, PCCT_INT
);
putCONG( &format
[ fmtstart
]
, strlen( &format
[ fmtstart
] )
putop( PCC_CM
, PCCT_INT
);
if ( fmtspec
& VARWIDTH
) {
* ,(temp=width,MAX(temp,...)),
al
->wexpr_node
.expr3
== TR_NIL
)
soffset
= sizes
[cbn
].curtmps
;
tempnlp
= tmpalloc((long) (sizeof(long)),
tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, PCCT_INT
);
ap
= stkrval( al
->wexpr_node
.expr2
,
putop( PCC_ASSIGN
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, PCCT_INT
);
|| typ
== TSTR
|| typ
== TDOUBLE
) {
putleaf( PCC_ICON
, 0 , 0
,PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stkrval( al
->wexpr_node
.expr2
,
error("First write width must be integer, not %s", nameof(ap
));
putleaf( PCC_ICON
, REALSPC
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 1 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
if ( al
->wexpr_node
.expr3
== TR_NIL
) {
putop( PCC_COMOP
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
tempnlp
-> value
[ NL_OFFS
] ,
0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 1 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, strnglen
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_COMOP
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
* If there is a variable precision,
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stkrval( al
->wexpr_node
.expr3
,
error("Second write width must be integer, not %s", nameof(ap
));
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
* evaluate the thing we want printed.
(void) stkrval( alv
, NLNIL
, (long) RREQ
);
putop( PCC_CM
, PCCT_INT
);
ap
= stkrval( alv
, NLNIL
, (long) RREQ
);
sconv(p2type(ap
), PCCT_DOUBLE
);
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stkrval( alv
, NLNIL
, (long) RREQ
);
sprintf( format
, PREFIXFORMAT
, LABELPREFIX
putleaf( PCC_ICON
, 0 , 0 ,
(int) (PCCTM_PTR
| PCCT_CHAR
), format
);
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putCONG( "" , 0 , LREQ
);
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
* Write the string after its blank padding
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
ap
= stkrval(alv
, NLNIL
, (long) RREQ
);
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stkrval(alv
, NLNIL
, (long) RREQ
);
* min, inline expanded as
* temp < len ? temp : len
tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, PCCT_INT
);
putleaf( PCC_ICON
, strnglen
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_LT
, PCCT_INT
);
tempnlp
-> value
[ NL_OFFS
] ,
tempnlp
-> extra_flags
, PCCT_INT
);
putleaf( PCC_ICON
, strnglen
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_COLON
, PCCT_INT
);
putop( PCC_QUEST
, PCCT_INT
);
&& ( strfmt
& CONWIDTH
) ) {
putleaf( PCC_ICON
, strnglen
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 1 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0, cbn
, CURFILEOFFSET
, NLOCAL
,
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
* 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");
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putleaf( PCC_ICON
, '\n' , 0 , (int) PCCT_CHAR
, (char *) 0 );
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
,
NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
* 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
;
putRV((char *) 0, cbn
, CURFILEOFFSET
, NLOCAL
,
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
(void) stklval(argv
->list_node
.list
, NOFLAGS
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
argv
= argv
->list_node
.next
;
putRV((char *) 0, cbn
, CURFILEOFFSET
, NLOCAL
,
putLV( "_input" , 0 , 0 , NGLOBAL
,
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
input
->nl_flags
|= NUSED
;
putRV((char *) 0, cbn
, CURFILEOFFSET
, NLOCAL
,
putLV( "_input" , 0 , 0 , NGLOBAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
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");
ap
= lvalue( al
, MOD
| ASGN
| NOUSE
, RREQ
);
if ( isa( ap
, "bsci" ) ) {
precheck( ap
, "_RANG4" , "_RSNG4" );
putleaf( PCC_ICON
, 0 , 0
p2type( filetype
) , PCCTM_PTR
)
(void) stklval(file
, NOFLAGS
);
putRV( "_input" , 0 , 0 , NGLOBAL
,
PCCTM_PTR
| PCCT_STRTY
);
putop(PCC_CALL
, PCCM_ADDTYPE(p2type(filetype
), PCCTM_PTR
));
switch ( classify( filetype
) ) {
putop( PCCOM_UNARY PCC_MUL
switch ( classify( filetype
) ) {
sconv(p2type(filetype
), p2type(ap
));
putop( PCC_ASSIGN
, p2type( ap
) );
putdot( filename
, line
);
PCCM_ADDTYPE(p2type(ap
), PCCTM_PTR
),
putdot( filename
, line
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
,
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
* if you get to here, you are reading from
* a text file. only possiblities are:
* character, integer, real, or scalar.
* read( f , foo , ... ) is done as
* foo := read( f ) with rangechecking
error("Can't read %ss from a text file", clnames
[typ
]);
* left hand side of foo := read( f )
ap
= lvalue( al
, MOD
|ASGN
|NOUSE
, RREQ
);
if ( isa( ap
, "bsci" ) ) {
precheck( ap
, "_RANG4" , "_RSNG4" );
putleaf( PCC_ICON
, 0 , 0
, (int) PCCM_ADDTYPE( PCCTM_FTN
| readtype
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
,
sprintf( format
, PREFIXFORMAT
, LABELPREFIX
putleaf( PCC_ICON
, 0, 0, (int) (PCCTM_PTR
| PCCT_CHAR
),
putop( PCC_CM
, PCCT_INT
);
error("Reading scalars from text files is non-standard");
putop( PCC_CALL
, (int) readtype
);
if ( isa( ap
, "bcsi" ) ) {
postcheck(ap
, readtype
==PCCT_INT
?nl
+T4INT
:nl
+TDOUBLE
);
sconv((int) readtype
, p2type(ap
));
putop( PCC_ASSIGN
, p2type( ap
) );
putdot( filename
, line
);
* insufficient number of args.
if (p
->value
[0] == O_READLN
) {
if (filetype
!= nl
+T1CHAR
)
error("Can't 'readln' a non text file");
putleaf( PCC_ICON
, 0 , 0
, (int) PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
,
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("read requires an argument");
error("%s expects one argument", p
->symbol
);
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stklval(argv
->list_node
.list
, NOFLAGS
);
if (ap
->class != FILET
) {
error("Argument to %s must be a file, not %s", p
->symbol
, nameof(ap
));
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
, op
== O_GET
? "_GET" : "_PUT" );
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
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");
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, op
== O_RESET
? "_RESET" : "_REWRITE" );
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
));
* Optional second argument
* UNIX (R) file to be associated.
al
= argv
->list_node
.next
;
al
= (struct tnode
*) stkrval(al
->list_node
.list
,
if (classify((struct nl
*) al
) != TSTR
) {
error("Second argument to %s must be a string, not %s", p
->symbol
, nameof((struct nl
*) al
));
strnglen
= width((struct nl
*) al
);
putleaf( PCC_ICON
, 0 , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, strnglen
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, text(ap
) ? 0: width(ap
->type
) , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("%s expects at least one argument", p
->symbol
);
alv
= argv
->list_node
.list
;
ap
= stklval(alv
, op
== O_NEW
? ( MOD
| NOUSE
) : MOD
);
error("(First) argument to %s must be a pointer, not %s", p
->symbol
, nameof(ap
));
else /* op == O_DISPOSE */
if ((ap
->nl_flags
& NFILES
) != 0)
putleaf( PCC_ICON
, 0, 0, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
), cmd
);
(void) stklval(alv
, op
== O_NEW
? ( MOD
| NOUSE
) : MOD
);
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");
putleaf( PCC_ICON
, width( ap
) , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
if (opt('t') && op
== O_NEW
) {
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
(void) stkrval(alv
, NLNIL
, (long) RREQ
);
putleaf( PCC_ICON
, width( ap
) , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("%s expects one argument", p
->symbol
);
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
, op
== O_DATE
? "_DATE" : "_TIME" );
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
));
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("halt takes no arguments");
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putop( PCCOM_UNARY PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("argv takes two arguments");
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
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
));
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, width( ap
) , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("stlimit requires one argument");
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stkrval(argv
->list_node
.list
, NLNIL
, (long) RREQ
);
error("stlimit's argument must be an integer, not %s", nameof(ap
));
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("remove expects one argument");
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stkrval(argv
->list_node
.list
, NLNIL
, (long) RREQ
);
if (classify(ap
) != TSTR
) {
error("remove's argument must be a string, not %s", nameof(ap
));
putleaf( PCC_ICON
, width( ap
) , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("linelimit expects two arguments");
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stklval(argv
->list_node
.list
, NOFLAGS
|NOUSE
);
error("linelimit's first argument must be a text file, not %s", nameof(ap
));
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
));
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("page expects one argument");
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
ap
= stklval(argv
->list_node
.list
, NOFLAGS
);
error("Argument to page must be a text file, not %s", nameof(ap
));
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_ASSIGN
, PCCTM_PTR
|PCCT_STRTY
);
putdot( filename
, line
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putleaf( PCC_ICON
, '\f' , 0 , (int) PCCT_CHAR
, (char *) 0 );
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
putRV((char *) 0 , cbn
, CURFILEOFFSET
, NLOCAL
, PCCTM_PTR
|PCCT_STRTY
);
putop( PCC_CALL
, PCCT_INT
);
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
if (argc
== 0 || argc
> 2) {
error("Assert expects one or two arguments");
putleaf( PCC_ICON
, 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
) , cmd
);
ap
= stkrval(argv
->list_node
.list
, NLNIL
, (long) RREQ
);
error("Assert expression must be Boolean, not %ss", nameof(ap
));
* Optional second argument is a string specifying
* why the assertion failed.
al
= argv
->list_node
.next
;
al
= (struct tnode
*) stkrval(al
->list_node
.list
, NLNIL
, (long) RREQ
);
if (classify((struct nl
*) al
) != TSTR
) {
error("Second argument to assert must be a string, not %s", nameof((struct nl
*) al
));
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("pack expects three arguments");
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
pua
= (al
= argv
)->list_node
.list
;
pui
= (al
= al
->list_node
.next
)->list_node
.list
;
puz
= (al
= al
->list_node
.next
)->list_node
.list
;
error("unpack expects three arguments");
putleaf( PCC_ICON
, 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN
| PCCT_INT
, PCCTM_PTR
)
puz
= (al
= argv
)->list_node
.list
;
pua
= (al
= al
->list_node
.next
)->list_node
.list
;
pui
= (al
= al
->list_node
.next
)->list_node
.list
;
ap
= stkrval(pui
, NLNIL
, (long) RREQ
);
ap
= stklval(pua
, op
== O_PACK
? NOFLAGS
: MOD
|NOUSE
);
if (ap
->class != ARRAY
) {
error("%s requires a to be an unpacked array, not %s", pu
, nameof(ap
));
putop( PCC_CM
, PCCT_INT
);
al
= (struct tnode
*) stklval(puz
, op
== O_UNPACK
? NOFLAGS
: MOD
|NOUSE
);
if (((struct nl
*) al
)->class != ARRAY
) {
error("%s requires z to be a packed array, not %s", pu
, nameof(ap
));
if (((struct nl
*) al
)->type
== NIL
||
((struct nl
*) ap
)->type
== NIL
)
if (((struct nl
*) al
)->type
!= ((struct nl
*) ap
)->type
) {
error("%s requires a and z to be arrays of the same type", pu
, nameof(ap
));
putop( PCC_CM
, PCCT_INT
);
k
= width((struct nl
*) al
);
itemwidth
= width(ap
->type
);
al
= ((struct tnode
*) ((struct nl
*) al
)->chain
);
if (ap
->chain
!= NIL
|| ((struct nl
*) 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
= ((struct nl
*) al
)->range
[1] -
((struct nl
*) al
)->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
putleaf( PCC_ICON
, itemwidth
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, j
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, i
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putleaf( PCC_ICON
, k
, 0 , PCCT_INT
, (char *) 0 );
putop( PCC_CM
, PCCT_INT
);
putop( PCC_CALL
, PCCT_INT
);
putdot( filename
, line
);
error("%s is an unimplemented extension", p
->symbol
);