home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS - Coast to Coast
/
simteldosarchivecoasttocoast2.iso
/
calculat
/
pibcal11.zip
/
EXPRESSI.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-03-11
|
21KB
|
601 lines
(*--------------------------------------------------------------------------*)
(* Expression -- parse and execute expression *)
(*--------------------------------------------------------------------------*)
PROCEDURE Expression( VAR formal: formalty;
VAR Iline: AnyStr;
VAR Ipos: INTEGER;
VAR v: valuety);
(*--------------------------------------------------------------------------*)
(* *)
(* Procedure: Expression *)
(* *)
(* Purpose: Parse and execute expression *)
(* *)
(* Calling sequence: *)
(* *)
(* Expression( VAR formal: formalty; *)
(* VAR Iline: AnyStr; *)
(* VAR Ipos: INTEGER; *)
(* VAR v: valuety); *)
(* *)
(* formal -- formal parameter block *)
(* Iline -- input command line *)
(* Ipos -- current position in input command line *)
(* v -- value of variable *)
(* *)
(* Calls: Term *)
(* *)
(* Called By: DoExp *)
(* *)
(* Remarks: *)
(* *)
(* This is the heart of the PibCalc program. This procedure *)
(* controls parsing and execution of an expression in PibCalc *)
(* syntax. The method used is recursive descent. *)
(* *)
(* Expression syntax: *)
(* ----------------- *)
(* *)
(* Expressions are composed of constants, variables, function calls, *)
(* and the special element '.', using the operators +, -, *, /, **, *)
(* MOD, and DIV, acoording to the usual algorithmic programming *)
(* language syntax rules. Parentheses may be used for grouping. *)
(* The precise syntax is given below in a modified Backus-Naur form. *)
(* *)
(* Notation used: *)
(* *)
(* = is defined to be. *)
(* . end of definition. *)
(* '...' Literal. *)
(* [...] Optional. *)
(* <...> Repeat 0 or more times. *)
(* | Or. *)
(* (...) Grouping. *)
(* *)
(* EXP = [SIGN] TERM < ADOP TERM >. *)
(* TERM = FACTOR < MULOP FACTOR >. *)
(* FACTOR = ELEMENT < '**' ELEMENT >. *)
(* ELEMENT = CONST | VAR | '(' EXP ')' | '.' | FUNC. *)
(* SIGN = '+' | '-'. *)
(* ADOP = '+' | '-'. *)
(* MULOP = '*' | '/' | 'MOD' | 'DIV'. *)
(* CONST = INT | REAL. *)
(* INT = DECINT | OCTINT | HEXINT. *)
(* DECINT = DEC <DEC> ['D']. *)
(* OCTINT = OCT <OCT> ['B'|'O']. *)
(* HEXINT = HEX <HEX> ['X']. *)
(* REAL = DEC <DEC> '.' <DEC> [EXPON] | *)
(* <DEC> '.' DEC <DEC> [EXPON]. *)
(* EXPON = 'E' [SIGN] DEC <DEC>. *)
(* VAR = LET. *)
(* FUNC = FNAME [ '(' EXP < ',' EXP > ')' ]. *)
(* FNAME = LET < ALPHNUM >. *)
(* ALPHNUM = LET | DEC. *)
(* LET = 'A' | ... | 'Z'. *)
(* DEC = '0' | ... | '9'. *)
(* OCT = '0' | ... | '7'. *)
(* HEX = '0' | ... | '9' | 'A' | ... | 'F'. *)
(* *)
(* The routines here are a quite direct translation of this syntax *)
(* into Turbo. Hence, detailed descriptions of the routines are *)
(* not provided. *)
(* *)
(*--------------------------------------------------------------------------*)
LABEL
99 (* ERROR EXIT *);
VAR
negate: BOOLEAN;
op: Tokenty;
w: valuety;
(*--------------------------------------------------------------------------*)
(* NextTok -- Get next token *)
(*--------------------------------------------------------------------------*)
PROCEDURE NextTok;
BEGIN (* NextTok *)
GetTok( Iline , Ipos );
END (* NextTok *);
(*--------------------------------------------------------------------------*)
(* VarVal -- Get value of variable *)
(*--------------------------------------------------------------------------*)
PROCEDURE VarVal( varnam: varnamty; VAR v: valuety );
VAR
i: INTEGER;
found: BOOLEAN;
BEGIN (* VarVal *)
WITH formal DO
BEGIN
i := 0;
found := FALSE;
WHILE ( i < nump ) AND ( NOT found ) DO
BEGIN
i := i + 1;
found := ( varnam = parms[i].name );
END;
IF found THEN
v := parms[i].VAL
ELSE
IF NOT VarVals[varnam].def THEN Undef(varnam)
ELSE v := VarVals[varnam]
END;
END (* VarVal *);
(*--------------------------------------------------------------------------*)
(* StdFunc -- Get value of standard function *)
(*--------------------------------------------------------------------------*)
PROCEDURE StdFunc( index:INTEGER; VAR v:valuety );
LABEL
99 (* Error exit *);
VAR
a: valuety;
b: valuety;
k: INTEGER;
(*--------------------------------------------------------------------------*)
(* BadArg -- Report error in argument to function *)
(*--------------------------------------------------------------------------*)
PROCEDURE BadArg;
BEGIN (* BadArg *)
WRITELN('Bad argument to ',StdFuncs[index].name);
ErrorFlag := TRUE;
END (* BadArg *);
(*--------------------------------------------------------------------------*)
BEGIN (* StdFunc *)
WITH StdFuncs[index],v DO
BEGIN
def := TRUE;
typ := rea;
i := 0;
IF nparms <> 0 THEN
BEGIN
(* Evaluate 1st function argument *)
NextTok;
IF Token <> oparsy THEN
BEGIN
SynErr;
GOTO 99;
END;
NextTok;
Expression( formal, Iline, ipos, a );
IF ErrorFlag THEN GOTO 99;
IF nparms = 2 THEN (* Evaluate 2nd function argument *)
BEGIN
IF Token <> commasy THEN
BEGIN
SynErr;
GOTO 99;
END;
NextTok;
Expression( formal, Iline, ipos, b );
IF ErrorFlag THEN GOTO 99;
END;
END;
(* Convert angle in degrees to angle *)
(* in radians *)
IF ( angle = deg ) AND ( func IN [ sinf..cscf ] ) THEN
a.r := a.r * PI/180.0;
(* Check for valid argument values *)
CASE func OF
tanf, secf:
IF COS(a.r) = 0.0 THEN BadArg;
cotf, cscf:
IF SIN(a.r) = 0.0 THEN BadArg;
asinf, acosf:
IF abs(a.r) > 1.0 THEN BadArg;
asecf, acscf:
IF abs(a.r) < 1.0 THEN BadArg;
atan2f:
IF abs(a.r)=0.0 THEN IF abs(b.r)=0.0 THEN BadArg;
lnf, log10f:
IF a.r <= 0.0 THEN BadArg;
logf:
BEGIN
IF a.r <= 0.0 THEN BadArg;
IF b.r <= 0.0 THEN BadArg
END;
sqrtf:
IF a.r < 0.0 THEN BadArg;
ELSE;
END (* CASE *);
IF ErrorFlag THEN GOTO 99;
(* Evaluate the function *)
CASE func OF
absf:
BEGIN
typ := a.typ;
r := abs( a.r );
i := abs( a.i );
END;
minf, Maxf:
BEGIN
typ := a.typ;
r := a.r;
i := a.i;
WHILE Token = commasy DO
BEGIN
NextTok;
Expression( formal, Iline, ipos, a );
IF ErrorFlag THEN GOTO 99;
IF a.typ = rea THEN typ := rea;
IF ( ( func = minf ) AND ( a.r < r ) ) OR
( ( func = maxf ) AND ( a.r > r ) ) THEN
BEGIN
r := a.r;
i := a.i
END
END
END;
truncf:
BEGIN
i := TRUNC( a.r );
k := i;
r := k;
typ := INT;
END;
roundf:
BEGIN
i := ROUND( a.r );
k := i;
r := k;
typ := INT;
END;
sinf: r := SIN( a.r );
cosf: r := COS( a.r );
tanf: r := SIN( a.r ) / COS( a.r );
cotf: r := COS( a.r ) / SIN( a.r );
secf: r := 1.0 / COS( a.r );
cscf: r := 1.0 / SIN( a.r );
asinf: r := arcsin( a.r );
acosf: r := arccos( a.r );
atanf: r := ARCTAN( a.r );
acotf: r := PI / 2.0 - ARCTAN( a.r );
asecf: r := arccos( 1.0 / a.r );
acscf: r := arcsin( 1.0 / a.r );
atan2f: r := arctan2( a.r , b.r );
expf: r := EXP( a.r );
lnf: r := LN( a.r );
log10f: r := log10( a.r );
logf: r := log( a.r , b.r );
sqrtf: r := SQRT( a.r );
EEf: r := EE;
PIf: r := PI;
END (* CASE *);
IF ErrorFlag THEN GOTO 99;
(* Convert angles to degrees if needed *)
IF ( angle = deg ) AND ( func IN [asinf..atan2f] ) THEN
r := r * 180.0/PI;
(* Check if any garbage left over *)
IF (nparms <> 0) AND (Token <> cparsy) THEN SynErr
END (* WITH *);
99:
END;
(*--------------------------------------------------------------------------*)
(* UserFunc -- Evaluate user-defined function *)
(*--------------------------------------------------------------------------*)
PROCEDURE UserFunc (index: INTEGER; VAR v: valuety);
LABEL
99 (* ERROR EXIT *);
VAR
lformal: formalty;
i: INTEGER;
dpos: INTEGER;
BEGIN (* UserFunc *)
WITH UserFuncs[index],lformal DO
BEGIN
(* Pick up no. of params to function *)
nump := nparms;
IF nparms > 0 THEN (* If params, need to evaluate each one *)
BEGIN
NextTok; (* Look for open paren of arg list *)
IF Token <> oparsy THEN
BEGIN
SynErr;
GOTO 99;
END;
(* Loop over each param *)
FOR i := 1 TO nparms DO
BEGIN
(* Pick up formal param name *)
parms[i].name := pnames[i];
NextTok;
(* Evaluate its actual value *)
Expression( formal, Iline, ipos, parms[i].VAL );
IF ErrorFlag THEN GOTO 99;
(* Look for comma *)
IF i < nparms THEN
IF Token <> commasy THEN
BEGIN
SynErr;
GOTO 99;
END;
END;
(* Look for closing right paren *)
(* of argument list *)
IF Token <> cparsy THEN
BEGIN
SynErr;
GOTO 99;
END;
END;
(* Now scan definition of function, *)
(* inserting actual values in place *)
(* of formal parameters, and hence *)
(* evaluating function. *)
(* dpos = current position in *)
(* definition of function. *)
dpos := 1;
GetTok( defn , dpos );
Expression( lformal, defn, dpos, v );
IF ErrorFlag THEN GOTO 99;
(* Ensure all of function definition *)
(* used up. *)
IF Token <> eolsy THEN
BEGIN
SynErr;
GOTO 99;
END;
END;
99:
END (* UserFunc *);
(*--------------------------------------------------------------------------*)
(* Element -- pick up 'element' in expression *)
(*--------------------------------------------------------------------------*)
PROCEDURE Element( VAR v: valuety );
LABEL
99 (* ERROR EXIT *);
BEGIN (* Element *)
(*---------------------------------------------------*)
(* ELEMENT = CONST | VAR | '(' EXP ')' | '.' | FUNC. *)
(*---------------------------------------------------*)
CASE Token OF
constsy : v := constval;
varsy : VarVal( varnam , v );
oparsy : BEGIN
NextTok;
Expression( formal, Iline, ipos, v );
IF ErrorFlag THEN GOTO 99;
IF Token <> cparsy THEN SynErr;
END;
periodsy : v := curval;
StdFuncsy : StdFunc( iStdFunc , v );
UserFuncsy: UserFunc( iUserFunc , v );
ELSE
SynErr;
END (* Case *);
IF ( NOT ErrorFlag ) THEN NextTok;
99:
END (* Element *);
(*--------------------------------------------------------------------------*)
(* Factor -- pick up 'factor' in expression *)
(*--------------------------------------------------------------------------*)
PROCEDURE Factor( VAR v: valuety );
VAR
w: valuety;
LABEL 99;
BEGIN (* Factor *)
(*-------------------------------------*)
(* FACTOR = ELEMENT < '**' ELEMENT >. *)
(*-------------------------------------*)
Element( v );
IF ErrorFlag THEN GOTO 99;
WHILE Token = exponsy DO
BEGIN
NextTok;
Element( w );
IF ErrorFlag THEN GOTO 99;
Powvals( v , w );
END;
99:
END (* Factor *);
(*--------------------------------------------------------------------------*)
(* Term -- pick up 'term' in expression *)
(*--------------------------------------------------------------------------*)
PROCEDURE Term( VAR v: valuety );
VAR
op: Tokenty;
w: valuety;
LABEL 99;
BEGIN (* Term *)
(*---------------------------------*)
(* TERM = FACTOR < MULOP FACTOR >. *)
(*---------------------------------*)
Factor( v );
IF ErrorFlag THEN GOTO 99;
WHILE Token IN [starsy,slashsy,modsy,divsy] DO
BEGIN
op := Token;
NextTok;
Factor( w );
IF ErrorFlag THEN GOTO 99;
CASE op OF
starsy: MulVals ( v , w );
slashsy: RdivVals( v , w );
divsy: IdivVals( v , w );
modsy: ModVals ( v , w );
END;
END;
99:
END (* Term *);
(*--------------------------------------------------------------------------*)
BEGIN (* Expression *)
(* Any errors before getting here? *)
(* If so, do nothing. *)
IF ErrorFlag THEN GOTO 99;
(*-----------------------------------*)
(* EXP = [SIGN] TERM < ADOP TERM >. *)
(*-----------------------------------*)
(* Check for and remember leading *)
(* sign *)
negate := FALSE;
IF Token IN [plussy,minussy] THEN
BEGIN
negate := ( Token = minussy );
NextTok;
END;
(* Pick up leading expression value *)
Term( v );
IF ErrorFlag THEN GOTO 99;
(* Apply negative sign if leading '-' *)
IF negate THEN
WITH v DO
BEGIN
r := -r;
IF typ = INT THEN i := -i;
END;
(* Continue through rest of expression *)
WHILE Token IN [plussy,minussy] DO
BEGIN
op := Token;
NextTok;
Term( w );
IF ErrorFlag THEN GOTO 99;
CASE op OF
plussy: addvals( v , w );
minussy: subvals( v , w );
END;
END;
99:
END (* EXPRESSION *);
