projects / unix-history / blob
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
BSD 4_3_Net_2 release
[unix-history] / usr / src / usr.bin / pascal / src / pclval.c
/*-
* Copyright (c) 1980 The Regents of the University of California.
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*/
#ifndef lint
static char sccsid[] = "@(#)pclval.c 5.2 (Berkeley) 4/16/91";
#endif /* not lint */
#include "whoami.h"
#include "0.h"
#include "tree.h"
#include "opcode.h"
#include "objfmt.h"
#include "tree_ty.h"
#ifdef PC
/*
* and the rest of the file
*/
# include "pc.h"
# include <pcc.h>
extern int flagwas;
/*
* pclvalue computes the address
* of a qualified name and
* leaves it on the stack.
* for pc, it can be asked for either an lvalue or an rvalue.
* the semantics are the same, only the code is different.
* for putting out calls to check for nil and fnil,
* we have to traverse the list of qualifications twice:
* once to put out the calls and once to put out the address to be checked.
*/
struct nl *
pclvalue( var , modflag , required )
struct tnode *var;
int modflag;
int required;
{
register struct nl *p;
register struct tnode *c, *co;
int f, o;
struct tnode l_node, tr;
VAR_NODE *v_node;
LIST_NODE *tr_ptr;
struct nl *firstp, *lastp;
char *firstsymbol;
char firstextra_flags;
int firstbn;
int s;
if ( var == TR_NIL ) {
return NLNIL;
}
if ( nowexp( var ) ) {
return NLNIL;
}
if ( var->tag != T_VAR ) {
error("Variable required"); /* Pass mesgs down from pt of call ? */
return NLNIL;
}
v_node = &(var->var_node);
firstp = p = lookup( v_node->cptr );
if ( p == NLNIL ) {
return NLNIL;
}
firstsymbol = p -> symbol;
firstbn = bn;
firstextra_flags = p -> extra_flags;
c = v_node->qual;
if ( ( modflag & NOUSE ) && ! lptr( c ) ) {
p -> nl_flags = flagwas;
}
if ( modflag & MOD ) {
p -> nl_flags |= NMOD;
}
/*
* Only possibilities for p -> class here
* are the named classes, i.e. CONST, TYPE
* VAR, PROC, FUNC, REF, or a WITHPTR.
*/
tr_ptr = &(l_node.list_node);
if ( p -> class == WITHPTR ) {
/*
* Construct the tree implied by
* the with statement
*/
l_node.tag = T_LISTPP;
tr_ptr->list = &(tr);
tr_ptr->next = v_node->qual;
tr.tag = T_FIELD;
tr.field_node.id_ptr = v_node->cptr;
c = &(l_node);
}
/*
* this not only puts out the names of functions to call
* but also does all the semantic checking of the qualifications.
*/
if ( ! nilfnil( p , c , modflag , firstp , v_node->cptr ) ) {
return NLNIL;
}
switch (p -> class) {
case WITHPTR:
case REF:
/*
* Obtain the indirect word
* of the WITHPTR or REF
* as the base of our lvalue
*/
putRV( firstsymbol , firstbn , p -> value[ 0 ] ,
firstextra_flags , p2type( p ) );
firstsymbol = 0;
f = 0; /* have an lv on stack */
o = 0;
break;
case VAR:
if (p->type->class != CRANGE) {
f = 1; /* no lv on stack yet */
o = p -> value[0];
} else {
error("Conformant array bound %s found where variable required", p->symbol);
return(NIL);
}
break;
default:
error("%s %s found where variable required", classes[p -> class], p -> symbol);
return (NLNIL);
}
/*
* Loop and handle each
* qualification on the name
*/
if ( c == NIL &&
( modflag & ASGN ) &&
( p -> value[ NL_FORV ] & FORVAR ) ) {
error("Can't modify the for variable %s in the range of the loop", p -> symbol);
return (NLNIL);
}
s = 0;
for ( ; c != TR_NIL ; c = c->list_node.next ) {
co = c->list_node.list;
if ( co == TR_NIL ) {
return NLNIL;
}
lastp = p;
p = p -> type;
if ( p == NLNIL ) {
return NLNIL;
}
/*
* If we haven't seen enough subscripts, and the next
* qualification isn't array reference, then it's an error.
*/
if (s && co->tag != T_ARY) {
error("Too few subscripts (%d given, %d required)",
s, p->value[0]);
}
switch ( co->tag ) {
case T_PTR:
/*
* Pointer qualification.
*/
if ( f ) {
putLV( firstsymbol , firstbn , o ,
firstextra_flags , p2type( p ) );
firstsymbol = 0;
} else {
if (o) {
putleaf( PCC_ICON , o , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_PLUS , PCCTM_PTR | PCCT_CHAR );
}
}
/*
* Pointer cannot be
* nil and file cannot
* be at end-of-file.
* the appropriate function name is
* already out there from nilfnil.
*/
if ( p -> class == PTR ) {
/*
* this is the indirection from
* the address of the pointer
* to the pointer itself.
* kirk sez:
* fnil doesn't want this.
* and does it itself for files
* since only it knows where the
* actual window is.
* but i have to do this for
* regular pointers.
*/
putop( PCCOM_UNARY PCC_MUL , p2type( p ) );
if ( opt( 't' ) ) {
putop( PCC_CALL , PCCT_INT );
}
} else {
putop( PCC_CALL , PCCT_INT );
}
f = o = 0;
continue;
case T_ARGL:
case T_ARY:
if ( f ) {
putLV( firstsymbol , firstbn , o ,
firstextra_flags , p2type( p ) );
firstsymbol = 0;
} else {
if (o) {
putleaf( PCC_ICON , o , 0 , PCCT_INT
, (char *) 0 );
putop( PCC_PLUS , PCCT_INT );
}
}
s = arycod( p , co->ary_node.expr_list, s);
if (s == p->value[0]) {
s = 0;
} else {
p = lastp;
}
f = o = 0;
continue;
case T_FIELD:
/*
* Field names are just
* an offset with some
* semantic checking.
*/
p = reclook(p, co->field_node.id_ptr);
o += p -> value[0];
continue;
default:
panic("lval2");
}
}
if (s) {
error("Too few subscripts (%d given, %d required)",
s, p->type->value[0]);
return NLNIL;
}
if (f) {
if ( required == LREQ ) {
putLV( firstsymbol , firstbn , o ,
firstextra_flags , p2type( p -> type ) );
} else {
putRV( firstsymbol , firstbn , o ,
firstextra_flags , p2type( p -> type ) );
}
} else {
if (o) {
putleaf( PCC_ICON , o , 0 , PCCT_INT , (char *) 0 );
putop( PCC_PLUS , PCCT_INT );
}
if ( required == RREQ ) {
putop( PCCOM_UNARY PCC_MUL , p2type( p -> type ) );
}
}
return ( p -> type );
}
/*
* this recursively follows done a list of qualifications
* and puts out the beginnings of calls to fnil for files
* or nil for pointers (if checking is on) on the way back.
* this returns true or false.
*/
bool
nilfnil( p , c , modflag , firstp , r2 )
struct nl *p;
struct tnode *c;
int modflag;
struct nl *firstp;
char *r2; /* no, not r2-d2 */
{
struct tnode *co;
struct nl *lastp;
int t;
static int s = 0;
if ( c == TR_NIL ) {
return TRUE;
}
co = ( c->list_node.list );
if ( co == TR_NIL ) {
return FALSE;
}
lastp = p;
p = p -> type;
if ( p == NLNIL ) {
return FALSE;
}
switch ( co->tag ) {
case T_PTR:
/*
* Pointer qualification.
*/
lastp -> nl_flags |= NUSED;
if ( p -> class != PTR && p -> class != FILET) {
error("^ allowed only on files and pointers, not on %ss", nameof(p));
goto bad;
}
break;
case T_ARGL:
if ( p -> class != ARRAY ) {
if ( lastp == firstp ) {
error("%s is a %s, not a function", r2, classes[firstp -> class]);
} else {
error("Illegal function qualificiation");
}
return FALSE;
}
recovered();
error("Pascal uses [] for subscripting, not ()");
/* and fall through */
case T_ARY:
if ( p -> class != ARRAY ) {
error("Subscripting allowed only on arrays, not on %ss", nameof(p));
goto bad;
}
codeoff();
s = arycod( p , co->ary_node.expr_list , s );
codeon();
switch ( s ) {
case 0:
return FALSE;
case -1:
goto bad;
}
if (s == p->value[0]) {
s = 0;
} else {
p = lastp;
}
break;
case T_FIELD:
/*
* Field names are just
* an offset with some
* semantic checking.
*/
if ( p -> class != RECORD ) {
error(". allowed only on records, not on %ss", nameof(p));
goto bad;
}
if ( co->field_node.id_ptr == NIL ) {
return FALSE;
}
p = reclook( p , co->field_node.id_ptr );
if ( p == NIL ) {
error("%s is not a field in this record", co->field_node.id_ptr);
goto bad;
}
if ( modflag & MOD ) {
p -> nl_flags |= NMOD;
}
if ((modflag & NOUSE) == 0 || lptr(c->field_node.other )) {
p -> nl_flags |= NUSED;
}
break;
default:
panic("nilfnil");
}
/*
* recursive call, check the rest of the qualifications.
*/
if ( ! nilfnil( p , c->list_node.next , modflag , firstp , r2 ) ) {
return FALSE;
}
/*
* the point of all this.
*/
if ( co->tag == T_PTR ) {
if ( p -> class == PTR ) {
if ( opt( 't' ) ) {
putleaf( PCC_ICON , 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
, "_NIL" );
}
} else {
putleaf( PCC_ICON , 0 , 0
, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
, "_FNIL" );
}
}
return TRUE;
bad:
cerror("Error occurred on qualification of %s", r2);
return FALSE;
}
#endif PC
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.