/* Copyright (c) 1979 Regents of the University of California */
static char sccsid
[] = "@(#)pcproc.c 1.3 10/28/80";
* and to the end 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");
putleaf( P2ICON
, 0 , 0 , P2INT
, "_PFLUSH" );
putop( P2UNARY P2CALL
, P2INT
);
putdot( filename
, line
);
error("flush takes at most one argument");
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stklval(argv
[1], NOFLAGS
);
if (ap
->class != FILET
) {
error("flush's argument must be a file, not %s", nameof(ap
));
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( P2ICON
, 0 , 0 , P2INT
, "_PFLUSH" );
putop( P2UNARY P2CALL
, P2INT
);
putdot( filename
, line
);
putRV( 0 , cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putLV( "__err" , 0 , 0 , P2PTR
|P2STRTY
);
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
} 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
putRV( 0 , cbn
, CURFILEOFFSET
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
stklval(argv
[1], NOFLAGS
);
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
* Skip over the first argument
putRV( 0, cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putLV( "_output" , 0 , 0 , P2PTR
|P2STRTY
);
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
putRV( 0, cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putLV( "_output" , 0 , 0 , P2PTR
|P2STRTY
);
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
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 longs 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");
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.
ADDTYPE( p2type( filetype
)
, ADDTYPE( p2type( filetype
) , P2PTR
) );
putop( P2UNARY P2MUL
, p2type( filetype
) );
switch ( classify( filetype
) ) {
precheck( filetype
, "_RANG4" , "_RSGN4" );
ap
= rvalue( argv
[1] , filetype
, RREQ
);
ap
= rvalue( argv
[1] , filetype
, LREQ
);
if (incompat(ap
, filetype
, argv
[1])) {
cerror("Type mismatch in write to non-text file");
switch ( classify( filetype
) ) {
putop( P2ASSIGN
, p2type( filetype
) );
putdot( filename
, line
);
putdot( filename
, line
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
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 scalars to text files is non-standard");
fmtspec
= CONWIDTH
+ CONPREC
;
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
, ADDTYPE( P2FTN
|P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
stkrval( alv
, NIL
, RREQ
);
putop( P2LISTOP
, P2INT
);
, ADDTYPE( P2FTN
|P2INT
, P2PTR
)
stkrval( alv
, NIL
, RREQ
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0, cbn
, CURFILEOFFSET
putop( P2LISTOP
, P2INT
);
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
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
putop( P2LISTOP
, P2INT
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
putCONG( &format
[ fmtstart
]
, strlen( &format
[ fmtstart
] )
putop( P2LISTOP
, P2INT
);
if ( fmtspec
& VARWIDTH
) {
* ,(temp=width,MAX(temp,...)),
if ( ( typ
== TDOUBLE
&& al
[3] == NIL
)
sizes
[ cbn
].om_off
-= sizeof( int );
tempoff
= sizes
[ cbn
].om_off
;
putlbracket( ftnno
, -tempoff
);
if ( tempoff
< sizes
[ cbn
].om_max
) {
sizes
[ cbn
].om_max
= tempoff
;
putRV( 0 , cbn
, tempoff
, P2INT
);
ap
= stkrval( al
[2] , NIL
, RREQ
);
putop( P2ASSIGN
, P2INT
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, tempoff
, P2INT
);
|| typ
== TSTR
|| typ
== TDOUBLE
) {
,ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stkrval( al
[2] , NIL
, RREQ
);
error("First write width must be integer, not %s", nameof(ap
));
putleaf( P2ICON
, 1 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, 1 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putop( P2COMOP
, P2INT
);
putop( P2LISTOP
, P2INT
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, tempoff
, P2INT
);
sizes
[ cbn
].om_off
+= sizeof( int );
putleaf( P2ICON
, 8 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, 1 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, strnglen
, 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, 0 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putop( P2COMOP
, P2INT
);
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, 0 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, 0 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putop( P2LISTOP
, P2INT
);
* If there is a variable precision,
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stkrval( al
[3] , NIL
, RREQ
);
error("Second write width must be integer, not %s", nameof(ap
));
putleaf( P2ICON
, 0 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, 0 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putop( P2LISTOP
, P2INT
);
* evaluate the thing we want printed.
stkrval( alv
, NIL
, RREQ
);
putop( P2LISTOP
, P2INT
);
ap
= stkrval( alv
, NIL
, RREQ
);
if ( isnta( ap
, "d" ) ) {
putop( P2SCONV
, P2DOUBLE
);
putop( P2LISTOP
, P2INT
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stkrval( alv
, NIL
, RREQ
);
sprintf( format
, PREFIXFORMAT
, LABELPREFIX
putleaf( P2ICON
, 0 , 0 , P2PTR
| P2CHAR
putop( P2LISTOP
, P2INT
);
putop( P2LISTOP
, P2INT
);
putCONG( "" , 0 , LREQ
);
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
* Write the string after its blank padding
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
ap
= stkrval(alv
, NIL
, RREQ
);
putop( P2LISTOP
, P2INT
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stkrval(alv
, NIL
, RREQ
);
* min, inline expanded as
* temp < len ? temp : len
putRV( 0 , cbn
, tempoff
, P2INT
);
putleaf( P2ICON
, strnglen
, 0 , P2INT
, 0 );
putRV( 0 , cbn
, tempoff
, P2INT
);
putleaf( P2ICON
, strnglen
, 0 , P2INT
, 0 );
putop( P2COLON
, P2INT
);
putop( P2QUEST
, P2INT
);
&& ( strfmt
& CONWIDTH
) ) {
putleaf( P2ICON
, strnglen
, 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, 1 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0, cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putop( P2LISTOP
, P2INT
);
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");
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putleaf( P2ICON
, '\n' , 0 , P2CHAR
, 0 );
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
* 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
putRV( 0, cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
stklval(argv
[1], NOFLAGS
);
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
putRV( 0, cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putLV( "_input" , 0 , 0 , P2PTR
|P2STRTY
);
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
input
->nl_flags
|= NUSED
;
putRV( 0, cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putLV( "_input" , 0 , 0 , P2PTR
|P2STRTY
);
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
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");
ap
= lvalue( al
, MOD
| ASGN
| NOUSE
, RREQ
);
if ( isa( ap
, "bsci" ) ) {
precheck( ap
, "_RANG4" , "_RSNG4" );
p2type( filetype
) , P2PTR
)
switch ( classify( filetype
) ) {
switch ( classify( filetype
) ) {
putop( P2ASSIGN
, p2type( ap
) );
putdot( filename
, line
);
putdot( filename
, line
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
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" );
, ADDTYPE( P2FTN
| readtype
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
sprintf( format
, PREFIXFORMAT
, LABELPREFIX
putleaf( P2ICON
, 0 , 0 , P2PTR
| P2CHAR
putop( P2LISTOP
, P2INT
);
error("Reading scalars from text files is non-standard");
putop( P2CALL
, readtype
);
if ( isa( ap
, "bcsi" ) ) {
putop( P2ASSIGN
, 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");
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
error("read requires an argument");
error("%s expects one argument", p
->symbol
);
putRV( 0 , cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stklval(argv
[1], NOFLAGS
);
if (ap
->class != FILET
) {
error("Argument to %s must be a file, not %s", p
->symbol
, nameof(ap
));
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, op
== O_GET
? "_GET" : "_PUT" );
putRV( 0 , cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
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( P2ICON
, 0 , 0 , P2INT
, op
== O_RESET
? "_RESET" : "_REWRITE" );
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
));
* 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
));
putleaf( P2ICON
, 0 , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, strnglen
, 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, text(ap
) ? 0: width(ap
->type
) , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
error("%s expects at least one argument", p
->symbol
);
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, op
== O_DISPOSE
? "_DISPOSE" :
opt('t') ? "_NEWZ" : "_NEW" );
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");
putleaf( P2ICON
, width( ap
) , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
error("%s expects one argument", p
->symbol
);
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
, op
== O_DATE
? "_DATE" : "_TIME" );
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
));
putdot( filename
, line
);
error("halt takes no arguments");
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putop( P2UNARY P2CALL
, P2INT
);
putdot( filename
, line
);
error("argv takes two arguments");
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
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
));
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, width( ap
) , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
error("stlimit requires one argument");
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stkrval(argv
[1], NIL
, RREQ
);
error("stlimit's argument must be an integer, not %s", nameof(ap
));
putdot( filename
, line
);
error("remove expects one argument");
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stkrval(argv
[1], NOFLAGS
, RREQ
);
if (classify(ap
) != TSTR
) {
error("remove's argument must be a string, not %s", nameof(ap
));
putleaf( P2ICON
, width( ap
) , 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
error("linelimit expects two arguments");
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stklval(argv
[1], NOFLAGS
|NOUSE
);
error("linelimit's first argument must be a text file, not %s", nameof(ap
));
ap
= stkrval(al
[1], NIL
, RREQ
);
error("linelimit's second argument must be an integer, not %s", nameof(ap
));
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
error("page expects one argument");
putRV( 0 , cbn
, CURFILEOFFSET
, P2PTR
|P2STRTY
);
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stklval(argv
[1], NOFLAGS
);
error("Argument to page must be a text file, not %s", nameof(ap
));
putop( P2ASSIGN
, P2PTR
|P2STRTY
);
putdot( filename
, line
);
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putleaf( P2ICON
, '\f' , 0 , P2CHAR
, 0 );
, ADDTYPE( P2FTN
| P2INT
, P2PTR
)
putRV( 0 , cbn
, CURFILEOFFSET
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
error("pack expects three arguments");
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
error("unpack expects three arguments");
putleaf( P2ICON
, 0 , 0 , ADDTYPE( P2FTN
| P2INT
, P2PTR
)
ap
= stkrval((int *) pui
, NLNIL
, 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( P2LISTOP
, P2INT
);
al
= (struct nl
*) stklval(puz
, op
== O_UNPACK
? NOFLAGS
: 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
));
putop( P2LISTOP
, P2INT
);
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
putleaf( P2ICON
, itemwidth
, 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, j
, 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, i
, 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putleaf( P2ICON
, k
, 0 , P2INT
, 0 );
putop( P2LISTOP
, P2INT
);
putdot( filename
, line
);
error("%s is an unimplemented 6400 extension", p
->symbol
);