projects
/
unix-history
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
tags
|
clone url
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
new copyright; att/bsd/shared
[unix-history]
/
usr
/
src
/
usr.bin
/
pascal
/
src
/
func.c
diff --git
a/usr/src/usr.bin/pascal/src/func.c
b/usr/src/usr.bin/pascal/src/func.c
index
fdb6270
..
5d8db4b
100644
(file)
--- a/
usr/src/usr.bin/pascal/src/func.c
+++ b/
usr/src/usr.bin/pascal/src/func.c
@@
-1,6
+1,13
@@
-/* Copyright (c) 1979 Regents of the University of California */
+/*-
+ * Copyright (c) 1980 The Regents of the University of California.
+ * All rights reserved.
+ *
+ * %sccs.include.redist.c%
+ */
-static char sccsid[] = "@(#)func.c 1.4 %G%";
+#ifndef lint
+static char sccsid[] = "@(#)func.c 5.2 (Berkeley) %G%";
+#endif /* not lint */
#include "whoami.h"
#ifdef OBJ
#include "whoami.h"
#ifdef OBJ
@@
-10,6
+17,7
@@
static char sccsid[] = "@(#)func.c 1.4 %G%";
#include "0.h"
#include "tree.h"
#include "opcode.h"
#include "0.h"
#include "tree.h"
#include "opcode.h"
+#include "tree_ty.h"
/*
* Funccod generates code for
/*
* Funccod generates code for
@@
-17,32
+25,34
@@
static char sccsid[] = "@(#)func.c 1.4 %G%";
* call to generate calls to user
* defined functions and procedures.
*/
* call to generate calls to user
* defined functions and procedures.
*/
-funccod(r)
- int *r;
+struct nl
+*funccod(r)
+ struct tnode *r;
{
struct nl *p;
register struct nl *p1;
{
struct nl *p;
register struct nl *p1;
- register int *al;
+ struct nl *tempnlp;
+ register struct tnode *al;
register op;
register op;
- int argc
, *argv
;
-
int tr[2], tr2[4]
;
+ int argc;
+
struct tnode *argv, tr, tr2
;
/*
* Verify that the given name
* is defined and the name of
* a function.
*/
/*
* Verify that the given name
* is defined and the name of
* a function.
*/
- p = lookup(r
[2]
);
- if (p == NIL) {
- rvlist(r
[3]
);
- return (NIL);
+ p = lookup(r
->pcall_node.proc_id
);
+ if (p == N
LN
IL) {
+ rvlist(r
->pcall_node.arg
);
+ return (N
LN
IL);
}
if (p->class != FUNC && p->class != FFUNC) {
error("%s is not a function", p->symbol);
}
if (p->class != FUNC && p->class != FFUNC) {
error("%s is not a function", p->symbol);
- rvlist(r
[3]
);
- return (NIL);
+ rvlist(r
->pcall_node.arg
);
+ return (N
LN
IL);
}
}
- argv = r
[3]
;
+ argv = r
->pcall_node.arg
;
/*
* Call handles user defined
* procedures and functions
/*
* Call handles user defined
* procedures and functions
@@
-53,7
+63,7
@@
funccod(r)
* Count the arguments
*/
argc = 0;
* Count the arguments
*/
argc = 0;
- for (al = argv; al !=
NIL; al = al[2]
)
+ for (al = argv; al !=
TR_NIL; al = al->list_node.next
)
argc++;
/*
* Built-in functions have
argc++;
/*
* Built-in functions have
@@
-76,23
+86,24
@@
funccod(r)
if (argc != 0) {
error("%s takes no arguments", p->symbol);
rvlist(argv);
if (argc != 0) {
error("%s takes no arguments", p->symbol);
rvlist(argv);
- return (NIL);
+ return (N
LN
IL);
}
}
-
put1(
op);
+
(void) put(1,
op);
return (nl+T4INT);
case O_EOF:
case O_EOLN:
if (argc == 0) {
return (nl+T4INT);
case O_EOF:
case O_EOLN:
if (argc == 0) {
- argv = tr;
- tr[1] = tr2;
- tr2[0] = T_VAR;
- tr2[2] = input->symbol;
- tr2[1] = tr2[3] = NIL;
+ argv = (&tr);
+ tr.list_node.list = (&tr2);
+ tr2.tag = T_VAR;
+ tr2.var_node.cptr = input->symbol;
+ tr2.var_node.line_no = NIL;
+ tr2.var_node.qual = TR_NIL;
argc = 1;
} else if (argc != 1) {
error("%s takes either zero or one argument", p->symbol);
rvlist(argv);
argc = 1;
} else if (argc != 1) {
error("%s takes either zero or one argument", p->symbol);
rvlist(argv);
- return (NIL);
+ return (N
LN
IL);
}
}
/*
}
}
/*
@@
-102,18
+113,22
@@
funccod(r)
if (argc != 1) {
error("%s takes exactly one argument", p->symbol);
rvlist(argv);
if (argc != 1) {
error("%s takes exactly one argument", p->symbol);
rvlist(argv);
- return (NIL);
+ return (N
LN
IL);
}
/*
* Evaluate the argmument
*/
if (op == O_EOF || op == O_EOLN)
}
/*
* Evaluate the argmument
*/
if (op == O_EOF || op == O_EOLN)
- p1 = stklval(
(int *) argv[1], NLNIL , LREQ
);
+ p1 = stklval(
argv->list_node.list, NIL
);
else
else
- p1 = stkrval(
(int *) argv[1], NLNIL ,
RREQ );
- if (p1 == NIL)
- return (NIL);
+ p1 = stkrval(
argv->list_node.list, NLNIL , (long)
RREQ );
+ if (p1 == N
LN
IL)
+ return (N
LN
IL);
switch (op) {
switch (op) {
+ case 0:
+ error("%s is an unimplemented 6000-3.4 extension", p->symbol);
+ default:
+ panic("func1");
case O_EXP:
case O_SIN:
case O_COS:
case O_EXP:
case O_SIN:
case O_COS:
@@
-124,12
+139,12
@@
funccod(r)
case O_EXPO:
case O_UNDEF:
if (isa(p1, "i"))
case O_EXPO:
case O_UNDEF:
if (isa(p1, "i"))
- convert(
p1
, nl+TDOUBLE);
+ convert(
nl+T4INT
, nl+TDOUBLE);
else if (isnta(p1, "d")) {
error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
else if (isnta(p1, "d")) {
error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
- return (NIL);
+ return (N
LN
IL);
}
}
-
put1(
op);
+
(void) put(1,
op);
if (op == O_UNDEF)
return (nl+TBOOL);
else if (op == O_EXPO)
if (op == O_UNDEF)
return (nl+TBOOL);
else if (op == O_EXPO)
@@
-139,95
+154,105
@@
funccod(r)
case O_SEED:
if (isnta(p1, "i")) {
error("seed's argument must be an integer, not %s", nameof(p1));
case O_SEED:
if (isnta(p1, "i")) {
error("seed's argument must be an integer, not %s", nameof(p1));
- return (NIL);
+ return (N
LN
IL);
}
}
-
put1(
op);
+
(void) put(1,
op);
return (nl+T4INT);
case O_ROUND:
case O_TRUNC:
if (isnta(p1, "d")) {
error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
return (nl+T4INT);
case O_ROUND:
case O_TRUNC:
if (isnta(p1, "d")) {
error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
- return (NIL);
+ return (N
LN
IL);
}
}
-
put1(
op);
+
(void) put(1,
op);
return (nl+T4INT);
case O_ABS2:
case O_SQR2:
if (isa(p1, "d")) {
return (nl+T4INT);
case O_ABS2:
case O_SQR2:
if (isa(p1, "d")) {
-
put1(
op + O_ABS8-O_ABS2);
+
(void) put(1,
op + O_ABS8-O_ABS2);
return (nl+TDOUBLE);
}
if (isa(p1, "i")) {
return (nl+TDOUBLE);
}
if (isa(p1, "i")) {
-
put1(
op + (width(p1) >> 2));
+
(void) put(1,
op + (width(p1) >> 2));
return (nl+T4INT);
}
error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
return (nl+T4INT);
}
error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
- return (NIL);
+ return (N
LN
IL);
case O_ORD2:
case O_ORD2:
- if (isa(p1, "bcis")
|| classify(p1) == TPTR
) {
+ if (isa(p1, "bcis")) {
return (nl+T4INT);
}
return (nl+T4INT);
}
- error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1));
- return (NIL);
+ if (classify(p1) == TPTR) {
+ if (!opt('s')) {
+ return (nl+T4INT);
+ }
+ standard();
+ }
+ error("ord's argument must be of scalar type, not %s",
+ nameof(p1));
+ return (NLNIL);
case O_SUCC2:
case O_PRED2:
case O_SUCC2:
case O_PRED2:
- if (isa(p1, "
bcs
")) {
-
put1(op
);
- return (
p1
);
+ if (isa(p1, "
d
")) {
+
error("%s is forbidden for reals", p->symbol
);
+ return (
NLNIL
);
}
}
+ if ( isnta( p1 , "bcsi" ) ) {
+ error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
+ return NIL;
+ }
+ tempnlp = p1 -> class == TYPE ? p1 -> type : p1;
if (isa(p1, "i")) {
if (isa(p1, "i")) {
- if (width(p1) <= 2)
- op += O_PRED24-O_PRED2;
- else
+ if (width(p1) <= 2) {
+ op += O_PRED24 - O_PRED2;
+ (void) put(3, op, (int)tempnlp->range[0],
+ (int)tempnlp->range[1]);
+ } else {
op++;
op++;
- put1(op);
- return (nl+T4INT);
- }
- if (isa(p1, "id")) {
- error("%s is forbidden for reals", p->symbol);
- return (NIL);
+ (void) put(3, op, tempnlp->range[0],
+ tempnlp->range[1]);
+ }
+ return nl + T4INT;
+ } else {
+ (void) put(3, op, (int)tempnlp->range[0],
+ (int)tempnlp->range[1]);
+ return p1;
}
}
- error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
- return (NIL);
case O_ODD2:
if (isnta(p1, "i")) {
error("odd's argument must be an integer, not %s", nameof(p1));
case O_ODD2:
if (isnta(p1, "i")) {
error("odd's argument must be an integer, not %s", nameof(p1));
- return (NIL);
+ return (N
LN
IL);
}
}
-
put1(
op + (width(p1) >> 2));
+
(void) put(1,
op + (width(p1) >> 2));
return (nl+TBOOL);
case O_CHR2:
if (isnta(p1, "i")) {
error("chr's argument must be an integer, not %s", nameof(p1));
return (nl+TBOOL);
case O_CHR2:
if (isnta(p1, "i")) {
error("chr's argument must be an integer, not %s", nameof(p1));
- return (NIL);
+ return (N
LN
IL);
}
}
-
put1(
op + (width(p1) >> 2));
+
(void) put(1,
op + (width(p1) >> 2));
return (nl+TCHAR);
case O_CARD:
if (isnta(p1, "t")) {
error("Argument to card must be a set, not %s", nameof(p1));
return (nl+TCHAR);
case O_CARD:
if (isnta(p1, "t")) {
error("Argument to card must be a set, not %s", nameof(p1));
- return (NIL);
+ return (N
LN
IL);
}
}
-
put2(
O_CARD, width(p1));
+
(void) put(2,
O_CARD, width(p1));
return (nl+T2INT);
case O_EOLN:
if (!text(p1)) {
error("Argument to eoln must be a text file, not %s", nameof(p1));
return (nl+T2INT);
case O_EOLN:
if (!text(p1)) {
error("Argument to eoln must be a text file, not %s", nameof(p1));
- return (NIL);
+ return (N
LN
IL);
}
}
-
put1(
op);
+
(void) put(1,
op);
return (nl+TBOOL);
case O_EOF:
if (p1->class != FILET) {
error("Argument to eof must be file, not %s", nameof(p1));
return (nl+TBOOL);
case O_EOF:
if (p1->class != FILET) {
error("Argument to eof must be file, not %s", nameof(p1));
- return (NIL);
+ return (N
LN
IL);
}
}
-
put1(
op);
+
(void) put(1,
op);
return (nl+TBOOL);
return (nl+TBOOL);
- case 0:
- error("%s is an unimplemented 6000-3.4 extension", p->symbol);
- default:
- panic("func1");
}
}
#endif OBJ
}
}
#endif OBJ