hp@relay.EU.net@vmars.UUCP (03/11/90)
Posting-number: Volume 11, Issue 22
Submitted-by: hp@relay.EU.net@vmars.UUCP
Archive-name: rpl/part02
#! /bin/sh
# This is a shell archive. Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file". To overwrite existing
# files, type "sh file -c". You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: Makefile arithcmd.h benchmar bincmd.c bincmd.h branchcm.h
# cmplxcmd.c cmplxcmd.h debug.c debug.h errors.c errors.h filecmd.c
# filecmd.h globvar.c globvar.h intcmd.h logcmd.c logcmd.h matherr.c
# mem.h misccmd.c misccmd.h parser.h porting.tips problems realcmd.h
# relcmd.c relcmd.h rpl.c rpl.h rpl.prj stackcmd.c stackcmd.h
# storecmd.c storecmd.h trigcmd.h
# Wrapped by hp@gipsy on Thu Mar 8 17:56:17 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Makefile' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Makefile'\"
else
echo shar: Extracting \"'Makefile'\" \(2842 characters\)
sed "s/^X//" >'Makefile' <<'END_OF_FILE'
X# rpl Makefile
X#
X# This Makefile works with ULTRIX v2.1 and GCC v.1.36.
X# You may have to make changes for other systems or
X# compilers.
X
X# @(#) 1.0 90-03-07 hjp
X
X
X# port contains headerfiles I wrote as replacements
X# for some of Turbo-C's headerfiles during porting
X# the program to ULTRIX.
X
X# define -DTRACE for some tracing messages.
X# I added them because gcc and dbx won't work together.
X
X# define -DSTDARGBUG if stdarg.h doesn't work right
X# with your compiler, too.
X
CFLAGS = -Iport -DSTDARGBUG
CC = gcc
X
X# object files for rpl.
X
OBJS = arithcmd.o \
X bincmd.o \
X branchcm.o \
X cmplxcmd.o \
X errors.o \
X filecmd.o \
X globvar.o \
X rpl.o \
X intcmd.o \
X logcmd.o \
X matherr.o \
X misccmd.o \
X parser.o \
X realcmd.o \
X relcmd.o \
X stackcmd.o \
X storecmd.o \
X trigcmd.o
X
X# additional object files needed with gcc.
X# They may be in your C library or you may miss others ...
X
POBJS = cabs.o \
X itoa.o \
X strerror.o \
X strtoul.o
X
X# Libraries:
X# m is the math library
X# malloc contains faster memory allocation routines.
X
LIBS = -lm -lmalloc
X
rpl: $(OBJS) $(POBJS)
X gcc -o rpl $(OBJS) $(POBJS) $(LIBS)
X
arithcmd.o: arithcmd.c arithcmd.h debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h
bincmd.o: bincmd.c branchcm.h debug.h errors.h rpl.h intcmd.h misccmd.h stackcmd.h
branchcm.o: branchcm.c branchcm.h debug.h errors.h rpl.h intcmd.h misccmd.h stackcmd.h
cmplxcmd.o: cmplxcmd.c cmplxcmd.h errors.h globvar.h rpl.h intcmd.h stackcmd.h
debug.o: debug.c debug.h rpl.h errors.h
errors.o: errors.c errors.h debug.h
filecmd.o: filecmd.c errors.h filecmd.h globvar.h rpl.h intcmd.h
globvar.o: globvar.c arithcmd.h branchcm.h cmplxcmd.h debug.h filecmd.h globvar.h rpl.h logcmd.h misccmd.h relcmd.h stackcmd.h storecmd.h trigcmd.h
rpl.o: rpl.c debug.h globvar.h rpl.h intcmd.h parser.h
intcmd.o: intcmd.c debug.h errors.h rpl.h globvar.h intcmd.h misccmd.h
logcmd.o: logcmd.c errors.h globvar.h rpl.h intcmd.h logcmd.h stackcmd.h
matherr.o: matherr.c
misccmd.o: misccmd.c debug.h errors.h globvar.h rpl.h intcmd.h misccmd.h stackcmd.h
parser.o: parser.c debug.h errors.h globvar.h rpl.h misccmd.h parser.h
realcmd.o: realcmd.c arithcmd.h errors.h globvar.h intcmd.h realcmd.h rpl.h stackcmd.h
relcmd.o: relcmd.c relcmd.h debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h
stackcmd.o: stackcmd.c debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h
storecmd.o: storecmd.c debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h storecmd.h
trigcmd.o: trigcmd.c debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h trigcmd.h
X
cabs.o: port/cabs.c
X gcc -c -o cabs.o port/cabs.c
X
itoa.o: port/itoa.c
X gcc -c -o itoa.o port/itoa.c
X
strerror.o: port/strerror.c
X gcc -c -o strerror.o port/strerror.c
X
strtoul.o: port/strtoul.c
X gcc -c -o strtoul.o port/strtoul.c
X
X#
X# clean: remove all files created during making
X#
X
clean:
X rm $(OBJS) $(POBJS) rpl
X
END_OF_FILE
if test 2842 -ne `wc -c <'Makefile'`; then
echo shar: \"'Makefile'\" unpacked with wrong size!
fi
# end of 'Makefile'
fi
if test -f 'arithcmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'arithcmd.h'\"
else
echo shar: Extracting \"'arithcmd.h'\" \(812 characters\)
sed "s/^X//" >'arithcmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Functions used for implementing user arithmetic commands
X
X0.0 hjp 89-06-27
X
X initial version
X
X0.1 hjp 89-10-01
X
X EXP and LN added.
X
X0.2 hjp 89-11-08
X
X PI, e and i added.
X SIN, ASIN, COS, ACOS, TAN, ATAN added.
X
X0.3 hjp 89-11-15
X
X C->R, R->C, RE, IM added.
X
X0.4 hjp 89-12-02
X
X LN and EXP moved to LogCmd
X SIN, TAN, COS, ASIN, ATAN, ACOS moved to TrigCmd
X R->C, C->R, RE, IM moved to CmplxCmd.
X
X****************************************************************/
X
X#ifndef I_arithcmd
X
X #define I_arithcmd
X
X void c_add (void);
X void c_div (void);
X void c_e (void);
X void c_i (void);
X void c_inv (void);
X void c_mul (void);
X void c_neg (void);
X void c_pi (void);
X void c_pow (void);
X void c_sq (void);
X void c_sqrt (void);
X void c_sub (void);
X
X#endif
END_OF_FILE
if test 812 -ne `wc -c <'arithcmd.h'`; then
echo shar: \"'arithcmd.h'\" unpacked with wrong size!
fi
chmod +x 'arithcmd.h'
# end of 'arithcmd.h'
fi
if test -f 'benchmar' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'benchmar'\"
else
echo shar: Extracting \"'benchmar'\" \(1944 characters\)
sed "s/^X//" >'benchmar' <<'END_OF_FILE'
X BENCHMARKS
X ----------
X
X
X
X------------------------------------------------------------
X1. Empty Loop 1 .. 10000
X
RPL (Amstrad PC 1512): 12.25 sec.
RPL (DECstation 3100): 0.08 sec.
X
X<< TIME
X 1 10000 FOR i NEXT
X TIME - NEG
X>>
X
X
X
HP28C: 81.95 sec.
X
X<< # 123E SYSEVAL
X 1 10000 START NEXT
X # 123E SYSEVAL
X SWAP - B->R 8192 /
X>>
X
X
X
GWBASIC (Amstrad PC 1512): 5.35 sec.
X
X10 PRINT TIME$
X20 FOR i = 1 TO 10000
X30 NEXT i
X40 PRINT TIME$
X
X
X------------------------------------------------------------
X2. Fibonacci - Number
X
RPL (Amstrad PC 1512): 15.71 sec.
RPL (DECstation 3100): 0.40 sec.
X
X<<
X IF DUP 2 >
X THEN
X DUP 1 - FIB SW
X ELSE
X DROP 1
X ENDIF
X>> 'FIB' STO
X
X<< TIME
X 15 FIB DROP
X TIME - NEG
X>>
X
X
X
HP28C: 43.376 sec.
X
X<<
X IF DUP 2 >
X THEN
X DUP 1 - FIB SWAP 2 - FIB +
X ELSE
X DROP 1
X ENDIF
X>> 'FIB' STO
X
X << # 123E SYSEVAL
X 15 FIB DROP
X # 123E SYSEVAL
X SWAP - B->R 8192 /
X >>
X
X
X
GWBasic (Amstrad PC1512): 23.15 sec.
X
X10 PRINT TIME$
X20 DIM STACK (30)
X30 SP = 0
X40 STACK (SP) = 15: SP = SP + 1
X50 GOSUB 1000
X55 PRINT STACK (SP - 1)
X60 PRINT TIME$
X900 END
X1000 ' PRINT "fib("; STACK (SP - 1); ")", "[sp = "; SP; "]"
X1005 IF STACK (SP - 1) > 2 THEN 1010 ELSE 1060
X1010 STACK (SP) = STACK (SP - 1): SP = SP + 1
X1020 STACK (SP - 1) = STACK (SP - 1) - 1: GOSUB 1000
X1030 H = STACK (SP - 1): STACK (SP - 1) = STACK (SP - 2): STACK (SP - 2) = H
X1040 STACK (SP - 1) = STACK (SP - 1) - 2: GOSUB 1000
X1045 STACK (SP - 2) = STACK (SP - 2) + STACK (SP - 1): SP = SP - 1
X1050 GOTO 1080
X1060 'else
X1070 STACK (SP - 1) = 1
X1080 'endif
X1085 ' PRINT "="; STACK (SP - 1), "[sp = "; SP; "]"
X1090 RETURN
END_OF_FILE
if test 1944 -ne `wc -c <'benchmar'`; then
echo shar: \"'benchmar'\" unpacked with wrong size!
fi
chmod +x 'benchmar'
# end of 'benchmar'
fi
if test -f 'bincmd.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'bincmd.c'\"
else
echo shar: Extracting \"'bincmd.c'\" \(1126 characters\)
sed "s/^X//" >'bincmd.c' <<'END_OF_FILE'
X/****************************************************************
X
X BinCmd -- Commands for manipulating binary objects.
X (The BINARY menu on HP28)
X
X0.0 hjp 90-03-03
X
X initial version
X
X****************************************************************/
X
X#include "bincmd.h"
X#include "errors.h"
X#include "globvar.h"
X#include "intcmd.h"
X#include "rpl.h"
X#include "stackcmd.h"
X
X/*
X B->R convert binary to real
X
X BINARY -> REAL
X*/
X
void c_b_r (void)
X{
X realobj * a;
X binaryobj * c;
X
X if (! stack) {
X error ("B->R", ERR_2FEWARG);
X return;
X }
X
X if ((c = stack->obj)->id == BINARY) {
X
X if (!(a = mallocobj (REAL)))
X {
X error ("B->R", ERR_NOMEM);
X return;
X }
X a->val = c->val;
X c_drop ();
X push (a);
X } else {
X error ("B->R", ERR_WRTYPE);
X }
X}
X
X
X/*
X R->B convert real ro binary
X
X REAL -> BINARY
X*/
X
void c_r_b (void)
X{
X realobj * c;
X binaryobj * a;
X
X if (! stack) {
X error ("R->B", ERR_2FEWARG);
X return;
X }
X
X if ((c = stack->obj)->id == REAL) {
X
X if (!(a = mallocobj (BINARY)))
X {
X error ("R->B", ERR_NOMEM);
X return;
X }
X a->val = c->val;
X c_drop ();
X push (a);
X } else {
X error ("R->B", ERR_WRTYPE);
X }
X}
END_OF_FILE
if test 1126 -ne `wc -c <'bincmd.c'`; then
echo shar: \"'bincmd.c'\" unpacked with wrong size!
fi
chmod +x 'bincmd.c'
# end of 'bincmd.c'
fi
if test -f 'bincmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'bincmd.h'\"
else
echo shar: Extracting \"'bincmd.h'\" \(294 characters\)
sed "s/^X//" >'bincmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Commands related to binary objects.
X
X0.0 hjp 90-03-03
X
X initial version.
X
X****************************************************************/
X
X#ifndef I_bincmd
X
X #define I_bincmd
X
X void c_b_r (void);
X void c_r_b (void);
X
X#endif
END_OF_FILE
if test 294 -ne `wc -c <'bincmd.h'`; then
echo shar: \"'bincmd.h'\" unpacked with wrong size!
fi
chmod +x 'bincmd.h'
# end of 'bincmd.h'
fi
if test -f 'branchcm.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'branchcm.h'\"
else
echo shar: Extracting \"'branchcm.h'\" \(818 characters\)
sed "s/^X//" >'branchcm.h' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X BranchCmd
X
Description:
X Commands for flow control
X
X
Modification history:
X
X 0.0 hjp 89-07-14
X
X initial version
X
X 0.1 hjp 89-08-28
X
X if-then-else-endif and loops added.
X WARNING: Syntax differs from HP28
X END replaced by ENDIF, ENDDO, ENDWHILE !!!
X
X****************************************************************/
X
X#ifndef I_branchcm
X
X #define I_branchcm
X
X void c_ift (void);
X void c_ifte (void);
X void c_if (void);
X void c_then (void);
X void c_else (void);
X void c_endif (void);
X void c_start (void);
X void c_for (void);
X void c_next (void);
X void c_step (void);
X void c_while (void);
X void c_repeat(void);
X void c_endwhile (void);
X void c_do (void);
X void c_until (void);
X void c_enddo (void);
X
X extern
X loopobj * loopstack;
X
X#endif
END_OF_FILE
if test 818 -ne `wc -c <'branchcm.h'`; then
echo shar: \"'branchcm.h'\" unpacked with wrong size!
fi
chmod +x 'branchcm.h'
# end of 'branchcm.h'
fi
if test -f 'cmplxcmd.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'cmplxcmd.c'\"
else
echo shar: Extracting \"'cmplxcmd.c'\" \(2380 characters\)
sed "s/^X//" >'cmplxcmd.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X CmplxCmd
X
Description:
X Commands related to complex numbers (The CMPLX menu on HP28C)
X
Modification history:
X
X 0.0 hjp 89-12-03
X
X initial version
X R->C, C->R, RE, IM extracted from ArithCmd.
X
X****************************************************************/
X
X#include "cmplxcmd.h"
X#include "errors.h"
X#include "globvar.h"
X#include "rpl.h"
X#include "intcmd.h"
X#include "stackcmd.h"
X
X/*
X R->C convert two reals into a complex number
X
X x y -> (x, y)
X
X REAL REAL -> COMPLEX
X*/
X
void c_r_c (void)
X{
X realobj * a, * b;
X complexobj * c;
X
X if (! stack && ! stack->next) {
X error ("R->C", ERR_2FEWARG);
X return;
X }
X
X if ((a = stack->obj)->id == REAL && (b = stack->next->obj)->id == REAL) {
X if (!(c = mallocobj (COMPLEX)))
X {
X error ("R->C", ERR_NOMEM);
X return;
X }
X c->val.x = b->val; c->val.y = a->val;
X c_drop ();
X c_drop ();
X push (c);
X } else {
X error ("R->C", ERR_WRTYPE);
X }
X}
X
X
X/*
X C->R convert a complex to two reals
X
X (x, y) -> x y
X
X COMPLEX -> REAL REAL
X*/
X
void c_c_r (void)
X{
X realobj * a, * b;
X complexobj * c;
X
X if (! stack) {
X error ("C->R", ERR_2FEWARG);
X return;
X }
X
X if ((c = stack->obj)->id == COMPLEX) {
X
X if (!(a = mallocobj (REAL)))
X {
X error ("R->C", ERR_NOMEM);
X return;
X }
X a->val = c->val.x;
X if (!(b = mallocobj (REAL)))
X {
X a->link ++; /* set link to 1, so that destroy will really free a */
X destroy (a, 1);
X error ("R->C", ERR_NOMEM);
X return;
X }
X b->val = c->val.y;
X c_drop ();
X push (a);
X push (b);
X } else {
X error ("R->C", ERR_WRTYPE);
X }
X}
X
X
X/*
X RE real part of complex number
X
X (x, y) -> x
X
X COMPLEX -> REAL
X*/
X
void c_re (void)
X{
X realobj * a;
X complexobj * c;
X
X if (! stack) {
X error ("RE", ERR_2FEWARG);
X return;
X }
X
X if ((c = stack->obj)->id == COMPLEX) {
X
X if (!(a = mallocobj (REAL)))
X {
X error ("RE", ERR_NOMEM);
X return;
X }
X a->val = c->val.x;
X c_drop ();
X push (a);
X } else {
X error ("RE", ERR_WRTYPE);
X }
X}
X
X
X/*
X IM imaginary part of complex number
X
X (x, y) -> y
X
X COMPLEX -> REAL
X*/
X
void c_im (void)
X{
X realobj * a;
X complexobj * c;
X
X if (! stack) {
X error ("IM", ERR_2FEWARG);
X return;
X }
X
X if ((c = stack->obj)->id == COMPLEX) {
X
X if (!(a = mallocobj (REAL)))
X {
X error ("IM", ERR_NOMEM);
X return;
X }
X a->val = c->val.y;
X c_drop ();
X push (a);
X }
X else
X {
X error ("IM", ERR_WRTYPE);
X }
X}
END_OF_FILE
if test 2380 -ne `wc -c <'cmplxcmd.c'`; then
echo shar: \"'cmplxcmd.c'\" unpacked with wrong size!
fi
chmod +x 'cmplxcmd.c'
# end of 'cmplxcmd.c'
fi
if test -f 'cmplxcmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'cmplxcmd.h'\"
else
echo shar: Extracting \"'cmplxcmd.h'\" \(402 characters\)
sed "s/^X//" >'cmplxcmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Functions used for implementing user logarithmic commands
X
X0.0 hjp 89-12-03
X
X initial version
X R->C, C->R, RE, IM extracted from ArithCmd.
X
X****************************************************************/
X
X#ifndef I_cmplxcmd
X
X #define I_cmplxcmd
X
X void c_c_r (void);
X void c_im (void);
X void c_r_c (void);
X void c_re (void);
X
X#endif
END_OF_FILE
if test 402 -ne `wc -c <'cmplxcmd.h'`; then
echo shar: \"'cmplxcmd.h'\" unpacked with wrong size!
fi
chmod +x 'cmplxcmd.h'
# end of 'cmplxcmd.h'
fi
if test -f 'debug.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'debug.c'\"
else
echo shar: Extracting \"'debug.c'\" \(2002 characters\)
sed "s/^X//" >'debug.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X Debug
X
Description:
X Contains variables of all types to enable casts in the debugger.
X Contains functions used for debugging.
X
X WARNING! This module is very compiler-dependent. If you are not
X using Turbo C 2.0 on an IBM PC-compatible, you will have
X to change it or simply throw it out.
X
Modification history:
X
X 0.0 hjp 89-07-08
X
X initial version
X
X 0.1 hjp 89-07-25
X
X #include <stdio.h> added to supress warnings
X
X 0.2 hjp 89-08-28
X
X stringobjs added
X
X 0.3 hjp 89-08-28
X
X opobjs added
X
X 0.4 hjp 89-09-04
X
X memmap added.
X clearmem added.
X
X 0.5 clearmem improved.
X uses variable blocksize now.
X
X****************************************************************/
X
X#include <alloc.h>
X#include <mem.h>
X#include <stdio.h>
X
X#include "rpl.h"
X#include "errors.h"
X
nameobj no;
nameobj * nop;
stringobj so;
stringobj * sop;
opobj oo;
opobj * oop;
realobj ro;
realobj * rop;
X
void * debugmalloc (unsigned n)
X{
X void * p = malloc (n);
X
X printf ("allocated %u bytes at %p\n", n, p);
X return p;
X}
X
void debugfree (void * p)
X{
X printf ("freeing %lu bytes at %p\n", ((long *) p)[-2] - 1, p);
X
X free (p);
X}
X
void * debugrealloc (void * p, unsigned n)
X{
X void * p1;
X
X printf ("reallocating %lu bytes at %p ", ((long *) p)[-2] - 1, p);
X p1 = realloc (p, n);
X printf ("to %u bytes at %p\n", n, p1);
X return p1;
X}
X
void memmap (void)
X{
X uint seg;
X uint * p;
X char * s;
X
X for (seg = _SS + (_stklen >> 4); seg < 0xA000; seg ++) {
X
X p = (uint *) (((long) seg << 16) + 0x0008);
X if (s = id2str (* p)) {
X printf ("%x: %s (link = %u, size = %u)\n", seg, s, p [1], p [2]);
X }
X }
X}
X
X
X/*
X clearmem
X
X Allocate as much memory as possible, clear it, and release it again.
X*/
X
void clearmem (uint chunk)
X{
X void * p;
X
X if (chunk >= 16) {
X if (p = malloc (chunk - 8)) {
X printf ("clearmem: %d bytes at %p\n", chunk - 8, p);
X memset (p, 0, chunk - 8);
X clearmem (chunk);
X free (p);
X } else {
X chunk >>= 1;
X clearmem (chunk);
X }
X }
X}
END_OF_FILE
if test 2002 -ne `wc -c <'debug.c'`; then
echo shar: \"'debug.c'\" unpacked with wrong size!
fi
chmod +x 'debug.c'
# end of 'debug.c'
fi
if test -f 'debug.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'debug.h'\"
else
echo shar: Extracting \"'debug.h'\" \(762 characters\)
sed "s/^X//" >'debug.h' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X Debug
X
Description:
X Contains variables of all types to enable casts in the debugger.
X
X
Modification history:
X
X 0.0 hjp 89-07-08
X
X initial version
X
X 0.2 hjp 89-08-28
X
X opobjs added
X
X****************************************************************/
X
X#ifndef I_debug
X
X #include "rpl.h"
X
X extern nameobj no;
X extern nameobj * nop;
X extern stringobj so;
X extern stringobj * sop;
X extern opobj oo;
X extern opobj * oop;
X
X void * debugmalloc (unsigned);
X void debugfree (void *);
X void * debugrealloc (void *, unsigned);
X
X void memmap (void);
X void clearmem (uint);
X
X /*
X #define malloc(a) debugmalloc(a)
X #define free(a) debugfree(a)
X #define realloc(a, b) debugrealloc(a, b)
X */
X
X#endif
END_OF_FILE
if test 762 -ne `wc -c <'debug.h'`; then
echo shar: \"'debug.h'\" unpacked with wrong size!
fi
chmod +x 'debug.h'
# end of 'debug.h'
fi
if test -f 'errors.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'errors.c'\"
else
echo shar: Extracting \"'errors.c'\" \(2516 characters\)
sed "s/^X//" >'errors.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X Errors
X
Description:
X Error messages
X
X
Modification history:
X
X 0.0 hjp 89-06-26
X
X initial version
X
X 0.1 hjp 89-07-25
X
X ERR_NXVAR added
X
X 0.2 hjp 89-08-15
X
X parameter detail added to error
X ERR_DOS added.
X
X 0.3 hjp 89-08-29
X
X ERR_LOOP added.
X
X 0.4 hjp 89-10-05
X
X INT_BADLINK added.
X error has now variable parameter list.
X
X 0.5 hjp 89-11-15
X
X parameter to ERR_SYNTAX added.
X
X 0.6 hjp 89-12-11
X
X ERR_FPE added.
X
X 0.7 hjp 90-02-27
X
X START, FOR, DO, WHILE, COMMENT added to id2str.
X
X****************************************************************/
X
X#define ERRORS_C
X
X#include <port.h>
X#include <stdarg.h>
X#include <stdio.h>
X
X#include "errors.h"
X#include "debug.h"
X
char * errstr [] =
X{
X "No error\n",
X "Wrong argument type %s\n",
X "Stack empty\n",
X "Too few arguments\n",
X "Syntax error: %s\n",
X "Out of Memory\n",
X "No such variable: '%s'\n",
X "No user variables\n",
X "Error reported by DOS: %s\n",
X "Loop nesting error\n",
X "Floating Point Exception\n",
X
X "(INTERNAL) stack is not a list\n",
X "(INTERNAL) unknown object type %s\n",
X "(INTERNAL) impossible link count %s",
X
X "(PANIC) buffer overflow -- committing suicide ...\n",
X};
X
char * id2str (int id)
X{
X char * rc;
X
X switch (id) {
X case REAL:
X rc = "REAL";
X break;
X case COMPLEX:
X rc = "COMPLEX";
X break;
X case BINARY:
X rc = "BINARY";
X break;
X case PROGRAM:
X rc = "PROGRAM";
X break;
X case OP:
X rc = "OP";
X break;
X case UNAME:
X rc = "UNAME";
X break;
X case QNAME:
X rc = "QNAME";
X break;
X case STRING:
X rc = "STRING";
X break;
X case LIST:
X rc = "LIST";
X break;
X case VARIABLE:
X rc = "VARIABLE";
X break;
X case START:
X rc = "START";
X break;
X case DO:
X rc = "DO";
X break;
X case FOR:
X rc = "FOR";
X break;
X case WHILE:
X rc = "WHILE";
X break;
X case COMMENT:
X rc = "COMMENT";
X break;
X default:
X rc = NULL;
X }
X return rc;
X}
X
X
X#ifdef STDARGBUG
X
X void error (char * cmd, int errnum, long dummy )
X {
X va_list argptr;
X
X #ifdef TRACE
X printf ("error (%s, %d, ...) {\n", cmd, errnum);
X #endif
X va_start (argptr, errnum);
X printf ("%s: ", cmd);
X vprintf (errstr [errnum], argptr);
X va_end (argptr);
X #ifdef TRACE
X printf ("} error\n");
X #endif
X }
X#else
X
X void error (char * cmd, int errnum, ... )
X {
X va_list argptr;
X
X #ifdef TRACE
X printf ("error (%s, %d, ...) {\n", cmd, errnum);
X #endif
X va_start (argptr, errnum);
X printf ("%s: ", cmd);
X vprintf (errstr [errnum], argptr);
X va_end (argptr);
X #ifdef TRACE
X printf ("} error\n");
X #endif
X }
X#endif
END_OF_FILE
if test 2516 -ne `wc -c <'errors.c'`; then
echo shar: \"'errors.c'\" unpacked with wrong size!
fi
chmod +x 'errors.c'
# end of 'errors.c'
fi
if test -f 'errors.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'errors.h'\"
else
echo shar: Extracting \"'errors.h'\" \(970 characters\)
sed "s/^X//" >'errors.h' <<'END_OF_FILE'
X/****************************************************************
X
X Variables and constants used for error-messages
X
X0.0 hjp 89-06-14
X
X initial version
X
X0.1 hjp 89-07-25
X
X ERR_NXVAR added
X
X0.2 hjp 89-08-14
X
X ERR_NOVAR added
X
X0.3 hjp 89-08-15
X
X ERR_DOS added
X
X0.4 hjp 89-08-29
X
X ERR_LOOP added
X
X0.5 hjp 89-10-05
X
X INT_BADLINK added.
X error () changed to variable arguments.
X
X0.6 hjp 89-12-11
X
X ERR_FPE added.
X
X****************************************************************/
X
X#ifndef I_errors
X
X #define I_errors
X
X extern
X char * errstr [];
X
X enum {
X ERR_NOERR,
X ERR_WRTYPE,
X ERR_STKEMPTY,
X ERR_2FEWARG,
X ERR_SYNTAX,
X ERR_NOMEM,
X ERR_NXVAR,
X ERR_NOVAR,
X ERR_DOS,
X ERR_LOOP,
X ERR_FPE,
X
X INT_STKNOLIST, /* internal errors */
X INT_NXOBJ,
X INT_BADLINK,
X
X INT_BUFOVER, /* internal fatal errors */
X };
X
X char * id2str (int id);
X
X #if defined ERRORS_C && defined STDARGBUG
X void error ();
X #else
X void error (char * function, int errno, ...);
X #endif
X
X#endif
END_OF_FILE
if test 970 -ne `wc -c <'errors.h'`; then
echo shar: \"'errors.h'\" unpacked with wrong size!
fi
chmod +x 'errors.h'
# end of 'errors.h'
fi
if test -f 'filecmd.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'filecmd.c'\"
else
echo shar: Extracting \"'filecmd.c'\" \(2593 characters\)
sed "s/^X//" >'filecmd.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X FileCmd
X
Description:
X Commands for file I/O
X
X
Modification history:
X
X 0.0 hjp 89-08-14
X
X initial version.
X
X 0.1 hjp 89-08-15
X
X SAVE debugged
X LOAD added
X SYSTEM added.
X
X 0.2 hjp 89-11-23
X
X SAVE now _appends_ to file.
X
X 0.3 hjp 89-12-02
X
X PRINT added.
X
X 0.4 hjp 89-12-11
X
X minor bug fixing.
X
X****************************************************************/
X
X#include <stddef.h>
X#include <stdlib.h>
X#include <stdio.h>
X
X#include "rpl.h"
X#include "errors.h"
X#include "filecmd.h"
X#include "globvar.h"
X#include "intcmd.h"
X#include "stackcmd.h"
X
X/*
X SAVE: save object at level 2 to file at level 1
X
X 1: obj 2: string ->
X*/
X
void c_save (void)
X{
X listobj * a, * b;
X FILE * fp;
X
X if ((b = stack) && (a = stack->next)) {
X
X if (b->obj->id != STRING) {
X
X error ("SAVE", ERR_WRTYPE, id2str (b->obj->id));
X
X } else if (fp = fopen (((stringobj *) b->obj)->val, "a")) {
X
X c_drop (); /* drop name */
X
X iop = iobuffer;
X printobj (a->obj);
X fprintf (fp, "%s\n", iobuffer);
X if (fclose (fp)) {
X error ("SAVE", ERR_DOS, strerror (errno));
X }
X c_drop (); /* drop saved object */
X
X } else {
X error ("SAVE", ERR_DOS, strerror (errno));
X }
X } else {
X
X error ("SAVE", ERR_2FEWARG, NULL);
X }
X}
X
X
X/*
X LOAD: load file into command line
X
X 1: string -> ??
X*/
X
void c_load (void)
X{
X listobj * b;
X FILE * fp;
X int rdcnt;
X
X if ((b = stack)) {
X
X if (b->obj->id != STRING) {
X
X error ("LOAD", ERR_WRTYPE, id2str (b->obj->id));
X
X } else if (fp = fopen (((stringobj *) b->obj)->val, "r")) {
X
X c_drop (); /* drop name */
X
X rdcnt = fread (cmdline, 1, PROGMAXSIZE - 1, fp); /* try to read max. program size */
X cmdline [rdcnt] = 0; /* append EOS */
X rdptr = cmdline; empty = 0; /* simulate edit () */
X if (fclose (fp)) {
X error ("LOAD", ERR_DOS, strerror (errno));
X }
X
X } else {
X error ("LOAD", ERR_DOS, strerror (errno));
X }
X } else {
X
X error ("LOAD", ERR_2FEWARG, NULL);
X }
X}
X
void c_system (void)
X{
X listobj * b;
X
X if ((b = stack)) {
X
X if (b->obj->id != STRING) {
X
X error ("SYSTEM", ERR_WRTYPE, id2str (b->obj->id));
X
X } else if (system (((stringobj *) b->obj)->val)) {
X
X error ("SYSTEM", ERR_DOS, strerror (errno));
X
X }
X c_drop ();
X
X } else {
X
X error ("SYSTEM", ERR_2FEWARG, NULL);
X }
X}
X
X
X/*
X PRINT: write object at level 1 to stdout
X
X 1: obj ->
X*/
X
void c_print (void)
X{
X listobj * a;
X
X if (a = stack) {
X
X iop = iobuffer;
X printobj (a->obj);
X printf ("%s\n", iobuffer);
X c_drop (); /* drop printed object */
X
X } else {
X
X error ("PRINT", ERR_2FEWARG, NULL);
X }
X}
X
END_OF_FILE
if test 2593 -ne `wc -c <'filecmd.c'`; then
echo shar: \"'filecmd.c'\" unpacked with wrong size!
fi
chmod +x 'filecmd.c'
# end of 'filecmd.c'
fi
if test -f 'filecmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'filecmd.h'\"
else
echo shar: Extracting \"'filecmd.h'\" \(389 characters\)
sed "s/^X//" >'filecmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X File commands
X
X0.0 hjp 89-08-15
X
X initial version
X
X0.1 hjp 89-08-15
X
X SYSTEM added
X
X0.2 hjp 89-12-02
X
X PRINT added.
X
X****************************************************************/
X
X#ifndef I_filecmd
X
X #define I_filecmd
X
X void c_save (void);
X void c_load (void);
X void c_print (void);
X void c_system (void);
X
X#endif
END_OF_FILE
if test 389 -ne `wc -c <'filecmd.h'`; then
echo shar: \"'filecmd.h'\" unpacked with wrong size!
fi
chmod +x 'filecmd.h'
# end of 'filecmd.h'
fi
if test -f 'globvar.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'globvar.c'\"
else
echo shar: Extracting \"'globvar.c'\" \(5327 characters\)
sed "s/^X//" >'globvar.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X GlobVar
X
Description:
X global variables
X
X
Modification history:
X
X 0.0 hjp 89-06-26
X
X initial version
X
X 0.1 hjp 89-07-08
X
X vars added
X
X 0.2 hjp 89-08-28
X
X ip added
X
X 0.3 hjp 89-09-03
X
X localvars added
X
X 0.4 hjp 89-11-23
X
X radix added.
X
X 0.5 hjp 90-03-03
X
X bincmd added.
X constants added.
X
X 0.6 hjp 90-03-04
X
X realcmd added.
X
X 0.7 hjp 90-03-06
X
X opobj "MemMap" excluded for non Turbo-C environment.
X
X 0.8 hjp 90-03-07
X
X main_loop added.
X
X****************************************************************/
X
X#include <setjmp.h>
X#include <stddef.h>
X
X#include "rpl.h"
X#include "arithcmd.h"
X#include "bincmd.h"
X#include "branchcm.h"
X#include "cmplxcmd.h"
X#include "debug.h"
X#include "filecmd.h"
X#include "logcmd.h"
X#include "misccmd.h"
X#include "realcmd.h"
X#include "relcmd.h"
X#include "stackcmd.h"
X#include "storecmd.h"
X#include "trigcmd.h"
X
X
listobj * stack = NULL;
X
varobj * vars = NULL, /* user variables */
X * localvars = NULL; /* local variables: created by FOR and -> operators */
X
int radix = 16; /* radix for i/o of binaries (2, 8, 10 or 16) */
X
genobj ** ip;
X
opobj ops [] =
X{
X OP, 0, sizeof (opobj), c_add, "+",
X OP, 0, sizeof (opobj), c_sub, "-",
X OP, 0, sizeof (opobj), c_mul, "*",
X OP, 0, sizeof (opobj), c_div, "/",
X OP, 0, sizeof (opobj), c_drop, "DROP",
X OP, 0, sizeof (opobj), c_off, "OFF",
X OP, 0, sizeof (opobj), c_neg, "NEG",
X OP, 0, sizeof (opobj), c_swap, "SWAP",
X OP, 0, sizeof (opobj), c_sq, "SQ",
X OP, 0, sizeof (opobj), c_sqrt, "SQRT",
X OP, 0, sizeof (opobj), c_pow, "^",
X OP, 0, sizeof (opobj), c_inv, "INV",
X OP, 0, sizeof (opobj), c_clear, "CLEAR",
X OP, 0, sizeof (opobj), c_pbegin, "<<", /* \ these two tokens */
X OP, 0, sizeof (opobj), c_pend, ">>", /* / must stay together */
X OP, 0, sizeof (opobj), c_eval, "EVAL",
X OP, 0, sizeof (opobj), c_sto, "STO",
X OP, 0, sizeof (opobj), c_rcl, "RCL",
X OP, 0, sizeof (opobj), c_ift, "IFT",
X OP, 0, sizeof (opobj), c_ifte, "IFTE",
X OP, 0, sizeof (opobj), c_gt, ">",
X OP, 0, sizeof (opobj), c_ge, ">=",
X OP, 0, sizeof (opobj), c_eq, "==",
X OP, 0, sizeof (opobj), c_le, "<=",
X OP, 0, sizeof (opobj), c_lt, "<",
X OP, 0, sizeof (opobj), c_ne, "!=",
X OP, 0, sizeof (opobj), c_dup, "DUP",
X OP, 0, sizeof (opobj), c_tron, "TRON",
X OP, 0, sizeof (opobj), c_troff, "TROFF",
X OP, 0, sizeof (opobj), c_user, "USER",
X OP, 0, sizeof (opobj), c_purge, "PURGE",
X OP, 0, sizeof (opobj), c_save, "SAVE",
X OP, 0, sizeof (opobj), c_load, "LOAD",
X OP, 0, sizeof (opobj), c_system, "SYSTEM",
X OP, 0, sizeof (opobj), c_if, "IF",
X OP, 0, sizeof (opobj), c_then, "THEN",
X OP, 0, sizeof (opobj), c_else, "ELSE",
X OP, 0, sizeof (opobj), c_endif, "ENDIF",
X OP, 0, sizeof (opobj), c_start, "START",
X OP, 0, sizeof (opobj), c_for, "FOR",
X OP, 0, sizeof (opobj), c_next, "NEXT",
X OP, 0, sizeof (opobj), c_step, "STEP",
X OP, 0, sizeof (opobj), c_do, "DO",
X OP, 0, sizeof (opobj), c_until, "UNTIL",
X OP, 0, sizeof (opobj), c_enddo, "ENDDO",
X OP, 0, sizeof (opobj), c_while, "WHILE",
X OP, 0, sizeof (opobj), c_repeat, "REPEAT",
X OP, 0, sizeof (opobj), c_endwhile, "ENDWHILE",
X OP, 0, sizeof (opobj), c_time, "TIME",
X#ifdef __TURBOC__
X OP, 0, sizeof (opobj), memmap, "MemMap", /* for debugging only */
X#endif
X OP, 0, sizeof (opobj), c_ln, "LN",
X OP, 0, sizeof (opobj), c_exp, "EXP",
X OP, 0, sizeof (opobj), c_local, "->",
X OP, 0, sizeof (opobj), c_pi, "PI",
X OP, 0, sizeof (opobj), c_e, "e",
X OP, 0, sizeof (opobj), c_i, "i",
X OP, 0, sizeof (opobj), c_sin, "SIN",
X OP, 0, sizeof (opobj), c_cos, "COS",
X OP, 0, sizeof (opobj), c_tan, "TAN",
X OP, 0, sizeof (opobj), c_asin, "ASIN",
X OP, 0, sizeof (opobj), c_acos, "ACOS",
X OP, 0, sizeof (opobj), c_atan, "ATAN",
X OP, 0, sizeof (opobj), c_c_r, "C->R",
X OP, 0, sizeof (opobj), c_im, "IM",
X OP, 0, sizeof (opobj), c_re, "RE",
X OP, 0, sizeof (opobj), c_r_c, "R->C",
X OP, 0, sizeof (opobj), c_bin, "BIN",
X OP, 0, sizeof (opobj), c_oct, "OCT",
X OP, 0, sizeof (opobj), c_dec, "DEC",
X OP, 0, sizeof (opobj), c_hex, "HEX",
X OP, 0, sizeof (opobj), c_print, "PRINT",
X OP, 0, sizeof (opobj), c_listend, "}",
X OP, 0, sizeof (opobj), c_b_r, "B->R",
X OP, 0, sizeof (opobj), c_r_b, "R->B",
X OP, 0, sizeof (opobj), c_maxr, "MAXR",
X OP, 0, sizeof (opobj), c_minr, "MINR",
X OP, 0, sizeof (opobj), c_abs, "ABS",
X OP, 0, sizeof (opobj), c_sign, "SIGN",
X OP, 0, sizeof (opobj), c_ip, "IP",
X OP, 0, sizeof (opobj), c_fp, "FP",
X OP, 0, sizeof (opobj), c_floor, "FLOOR",
X OP, 0, sizeof (opobj), c_ceil, "CEIL",
X OP, 0, sizeof (opobj), c_max, "MAX",
X OP, 0, sizeof (opobj), c_min, "MIN",
X OP, 0, sizeof (opobj), c_mod, "MOD",
X};
X
X
const noops = sizeof (ops) / sizeof (opobj);
X
X
int traceflag = 0;
X
X/* constant objects */
X
complexobj complex_zero = {COMPLEX, 1, sizeof (complexobj), {0.0, 0.0}};
complexobj complex_one = {COMPLEX, 1, sizeof (complexobj), {1.0, 0.0}};
complexobj complex_i = {COMPLEX, 1, sizeof (complexobj), {0.0, 1.0}};
X
realobj real_zero = {REAL, 1, sizeof (realobj), 0.0};
realobj real_e = {REAL, 1, sizeof (realobj), M_E};
realobj real_pi = {REAL, 1, sizeof (realobj), M_PI};
realobj real_min = {REAL, 1, sizeof (realobj), TINY_VAL};
realobj real_max = {REAL, 1, sizeof (realobj), HUGE_VAL};
X
X/* stack backup for handling signals */
X
jmp_buf main_loop;
END_OF_FILE
if test 5327 -ne `wc -c <'globvar.c'`; then
echo shar: \"'globvar.c'\" unpacked with wrong size!
fi
chmod +x 'globvar.c'
# end of 'globvar.c'
fi
if test -f 'globvar.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'globvar.h'\"
else
echo shar: Extracting \"'globvar.h'\" \(1019 characters\)
sed "s/^X//" >'globvar.h' <<'END_OF_FILE'
X/****************************************************************
X
X Global variables
X
X----------------------------------------------------------------
X
X0.0 hjp 89-06-14
X
X initial version
X
X0.1 hjp 89-07-08
X
X vars added
X
X0.2 hjp 89-07-14
X
X traceflag added
X
X0.3 hjp 89-08-28
X
X ip added
X
X0.4 hjp 89-09-03
X
X localvars added
X
X0.5 hjp 89-11-23
X
X radix added
X
X0.6 hjp 90-03-03
X
X constants added.
X
X0.6 hjp 90-03-03
X
X main_loop added.
X
X****************************************************************/
X
X
X#ifndef I_globvar
X
X #define I_globvar
X
X #include <setjmp.h>
X #include "rpl.h"
X
X extern
X listobj * stack;
X
X extern
X varobj * vars,
X * localvars;
X
X extern
X genobj ** ip;
X
X extern
X char cmdline [],
X empty,
X * rdptr,
X
X pbuffer [];
X
X extern
X opobj ops [];
X
X extern
X const noops;
X
X #define NOOPS noops
X
X extern
X int traceflag;
X
X extern
X int radix;
X
X extern
X complexobj complex_zero, complex_one, complex_i;
X
X extern
X realobj real_zero, real_e, real_pi, real_max, real_min;
X
X extern
X jmp_buf main_loop;
X
X#endif
END_OF_FILE
if test 1019 -ne `wc -c <'globvar.h'`; then
echo shar: \"'globvar.h'\" unpacked with wrong size!
fi
chmod +x 'globvar.h'
# end of 'globvar.h'
fi
if test -f 'intcmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'intcmd.h'\"
else
echo shar: Extracting \"'intcmd.h'\" \(813 characters\)
sed "s/^X//" >'intcmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Internally used commands
X
X0.0 hjp 89-06-26
X
X initial version
X
X0.1 hjp 89-09-03
X
X findvar added
X
X0.2 hjp 89-12-02
X
X mallocobj added.
X
X0.3 hjp 89-12-11
X
X fpehandler added.
X
X0.4 hjp 90-03-07
X
X inthandler added.
X
X****************************************************************/
X
X#ifndef I_intcmnds
X
X #define I_intcmnds
X
X void push (genobj * p);
X void destroy (genobj * p, int level);
X genobj * duplicate (genobj * obj, int level);
X void fpehandler (int sig);
X void inthandler (int sig);
X genobj * mallocobj (int type);
X void printobj (genobj * obj);
X void psr (listobj * l, int n);
X void printstack (void);
X void interprete (genobj * obj, int level);
X varobj * findvar (char * name);
X
X extern
X char iobuffer [],
X * iop,
X * ioend;
X
X#endif
END_OF_FILE
if test 813 -ne `wc -c <'intcmd.h'`; then
echo shar: \"'intcmd.h'\" unpacked with wrong size!
fi
chmod +x 'intcmd.h'
# end of 'intcmd.h'
fi
if test -f 'logcmd.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'logcmd.c'\"
else
echo shar: Extracting \"'logcmd.c'\" \(2248 characters\)
sed "s/^X//" >'logcmd.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X LogCmd
X
Description:
X Commands related to logarithms (The LOGS menu on HP28C)
X
Modification history:
X
X 0.0 hjp 89-12-03
X
X initial version
X LN and EXP extracted from ArithCmd.
X
X****************************************************************/
X
X#include "errors.h"
X#include "globvar.h"
X#include "rpl.h"
X#include "intcmd.h"
X#include "logcmd.h"
X#include "stackcmd.h"
X
X/*
X ln -- compute natural logarithm of object in level 1
X
X x -> ln(x)
X
X REAL -> REAL
X REAL -> COMPLEX
X COMPLEX -> COMPLEX
X*/
X
void c_ln (void)
X{
X genobj * a;
X realobj * c;
X complexobj * b;
X
X if (! stack) {
X error ("ln", ERR_2FEWARG);
X return;
X }
X
X if ((a = stack->obj)->id == REAL) {
X if (((realobj *)a)->val >= 0.0) {
X if (!(c = mallocobj (REAL)))
X {
X error ("LN", ERR_NOMEM);
X return;
X }
X c->id = REAL;
X c->link = 0;
X c->size = sizeof (realobj);
X c->val = log (((realobj *) a)->val);
X c_drop ();
X push (c);
X } else {
X if (! (b = mallocobj (COMPLEX)))
X {
X error ("LN", ERR_NOMEM);
X return;
X }
X b->val.x = log (-((realobj *) a)->val);
X b->val.y = M_PI;
X c_drop ();
X push (b);
X }
X } else if (a->id == COMPLEX) {
X double x = ((complexobj *) a)->val.x,
X y = ((complexobj *) a)->val.y;
X
X if (! (b = mallocobj (COMPLEX)))
X {
X error ("LN", ERR_NOMEM);
X return;
X }
X b->val.x = log (sqrt (x * x + y * y));
X b->val.y = x || y ? atan2 (y, x) : 0.0;
X c_drop ();
X push (b);
X } else {
X error ("inv", ERR_WRTYPE);
X }
X}
X
X/*
X EXP compute e to the power of object in level 1
X
X x -> e ^ x
X
X real -> real
X complex -> complex
X*/
X
void c_exp (void)
X{
X genobj * a;
X realobj * c;
X complexobj * b;
X
X if (! stack) {
X error ("EXP", ERR_2FEWARG);
X return;
X }
X
X if ((a = stack->obj)->id == REAL) {
X if (!(c = mallocobj (REAL)))
X {
X error ("EXP", ERR_NOMEM);
X return;
X }
X c->val = exp (((realobj *) a)->val);
X c_drop ();
X push (c);
X } else if (a->id == COMPLEX) {
X double x = ((complexobj *) a)->val.x,
X y = ((complexobj *) a)->val.y;
X
X if (! (b = mallocobj (COMPLEX)))
X {
X error ("EXP", ERR_NOMEM);
X return;
X }
X b->val.x = exp (x) * cos (y);
X b->val.y = exp (x) * sin (y);
X c_drop ();
X push (b);
X } else {
X error ("EXP", ERR_WRTYPE);
X }
X}
END_OF_FILE
if test 2248 -ne `wc -c <'logcmd.c'`; then
echo shar: \"'logcmd.c'\" unpacked with wrong size!
fi
chmod +x 'logcmd.c'
# end of 'logcmd.c'
fi
if test -f 'logcmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'logcmd.h'\"
else
echo shar: Extracting \"'logcmd.h'\" \(350 characters\)
sed "s/^X//" >'logcmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Functions used for implementing user logarithmic commands
X
X0.0 hjp 89-12-03
X
X initial version
X LN and EXP extracted from ArithCmd.
X
X****************************************************************/
X
X#ifndef I_logcmd
X
X #define I_logcmd
X
X void c_exp (void);
X void c_ln (void);
X#endif
END_OF_FILE
if test 350 -ne `wc -c <'logcmd.h'`; then
echo shar: \"'logcmd.h'\" unpacked with wrong size!
fi
chmod +x 'logcmd.h'
# end of 'logcmd.h'
fi
if test -f 'matherr.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'matherr.c'\"
else
echo shar: Extracting \"'matherr.c'\" \(689 characters\)
sed "s/^X//" >'matherr.c' <<'END_OF_FILE'
X
X/****************************************************************
X
Module:
X matherr
X
Description:
X Error handler for exceptions in math functions.
X
X
Modification history:
X
X 0.0 hjp 89-12-17
X
X initial version.
X
X****************************************************************/
X
X#include <math.h>
X#include <port.h>
X
X
int matherr(struct exception *e)
X{
X if (e->type == UNDERFLOW)
X {
X /* flush underflow to 0 */
X e->retval = 0;
X return 1;
X }
X if (e->type == TLOSS)
X {
X /* total loss of precision, but ignore the problem */
X return 1;
X }
X if (e->type == OVERFLOW)
X {
X /* set overflow to HUGE_VAL */
X e->retval = HUGE_VAL;
X return 1;
X }
X /* all other errors are fatal */
X return 0;
X}
X
END_OF_FILE
if test 689 -ne `wc -c <'matherr.c'`; then
echo shar: \"'matherr.c'\" unpacked with wrong size!
fi
chmod +x 'matherr.c'
# end of 'matherr.c'
fi
if test -f 'mem.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'mem.h'\"
else
echo shar: Extracting \"'mem.h'\" \(67 characters\)
sed "s/^X//" >'mem.h' <<'END_OF_FILE'
X/*
X mem.h
X
X*/
X
X#define memmove(dst, src, cnt) bcopy(src, dst, cnt)
END_OF_FILE
if test 67 -ne `wc -c <'mem.h'`; then
echo shar: \"'mem.h'\" unpacked with wrong size!
fi
chmod +x 'mem.h'
# end of 'mem.h'
fi
if test -f 'misccmd.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'misccmd.c'\"
else
echo shar: Extracting \"'misccmd.c'\" \(3917 characters\)
sed "s/^X//" >'misccmd.c' <<'END_OF_FILE'
X/****************************************************************
X
X Miscellaneous user commands
X
X0.0 hjp 89-06-27
X
X initial version
X
X0.1 hjp 89-07-14
X
X TRON, TROFF added
X
X0.2 hjp 89-08-29
X
X TIME added
X
X0.3 hjp 89-09-03
X
X TIME changed: uses ftime now instead of time
X
X0.4 hjp 89-10-04
X
X -> added.
X
X0.5 hjp 89-11-23
X
X BIN, OCT, DEC, HEX added.
X
X0.6 hjp 90-02-27
X
X comment object added in local_var.
X
X0.7 hjp 90-03-02
X
X } added.
X
X0.8 hjp 90-03-03
X
X malloc replaced by mallocobj (at last!).
X
X0.9 hjp 90-03-06
X
X sys/types.h added for UNIX-compatibility.
X
X****************************************************************/
X
X
X#include <math.h>
X#include <process.h>
X#include <string.h>
X#include <sys/types.h>
X#include <sys/timeb.h>
X
X#include "errors.h"
X#include "globvar.h"
X#include "rpl.h"
X#include "intcmd.h"
X#include "misccmd.h"
X#include "debug.h"
X#include "stackcmd.h"
X
X/*
X exit from HP28-Emulator
X*/
X
void c_off (void)
X{
X exit (0);
X}
X
X
void c_pbegin (void)
X{
X /* dummy function -- does nothing */
X}
X
X
void c_pend (void)
X{
X /* dummy function -- does nothing */
X}
X
X
X/*
X evaluate object in level 1
X*/
X
void c_eval (void)
X{
X listobj * l;
X
X l = stack;
X
X if (l) {
X if (l->id == LIST) {
X stack = l->next;
X
X interprete (l->obj, 0);
X
X destroy ((genobj *)l, 0);
X } else {
X error ("eval", INT_STKNOLIST);
X }
X } else {
X error ("eval", ERR_STKEMPTY);
X }
X}
X
void c_tron (void)
X{
X traceflag = 1;
X}
X
void c_troff (void)
X{
X traceflag = 0;
X}
X
X
void c_time (void)
X{
X struct timeb tb;
X
X realobj * c;
X
X ftime (&tb);
X if (!(c = mallocobj (REAL))) {
X error ("TIME", ERR_NOMEM);
X return;
X }
X c->val = tb.time + tb.millitm * 0.001;
X push (c);
X
X}
X
X/*
X ->
X
X Syntax required:
X
X -> UNAME { UNAME } PROGRAM
X
X 1. create local variable for each uname assigning values from the stack.
X 2. execute program.
X 3. delete the local variables created in step 1.
X
X Example:
X
X -> a b c << some program >>
X
X Stack:
X 1
X 2
X 3
X 4
X
X before execution of << some program >>, the stack will contain
X the single value 1,
X the local variable a will contain the value 2,
X b will contain the value 3,
X c will contain the value 4.
X
X This twisted arrangement (the variable found last by the interpreter
X gets the value in level one) makes programs more readable,
X but complicates the assignment to local variables.
X*/
X
static
int local_var (void)
X{
X int n_var;
X varobj * v;
X nameobj * n;
X
X if ((* ++ ip)->id == UNAME) {
X
X n = * ip; /* remember name */
X
X /* create local variables following in the list first */
X
X n_var = local_var () + 1;
X
X /* is there a value on the stack ? */
X
X if (! stack) {
X error ("->", ERR_2FEWARG);
X return (n_var - 1);
X }
X
X /* create local variable */
X
X if (! (v = mallocobj (VARIABLE))) {
X error ("->", ERR_NOMEM);
X return (n_var - 1);
X }
X
X /* and move value from stack to new var. */
X
X v->id = VARIABLE;
X v->size = sizeof (varobj);
X v->link = 1;
X strcpy (v->name, n->name);
X v->val = stack->obj; stack->obj->link ++;
X v->next = localvars; localvars = v;
X c_drop ();
X return n_var;
X } else if ((* ip)->id == COMMENT) {
X /* skip it and try next */
X return local_var ();
X } else {
X return 0;
X }
X}
X
void c_local (void)
X{
X int n_var; /* number of local variables */
X
X n_var = local_var ();
X
X /* now * ip should point to a program */
X
X if ((* ip)->id != PROGRAM) {
X error ("->", ERR_WRTYPE, id2str ((* ip)->id));
X return;
X }
X
X interprete ((* ip), 0);
X
X /* remove all local variables created */
X
X while (-- n_var >= 0) {
X varobj * v = localvars->next;
X destroy (localvars, 0);
X localvars = v;
X }
X}
X
X
X/*
X BIN set radix for binaries to 2.
X*/
X
void c_bin (void)
X{
X radix = 2;
X}
X
X
X/*
X OCT set radix for binaries to 8.
X*/
X
void c_oct (void)
X{
X radix = 8;
X}
X
X
X/*
X DEC set radix for binaries to 10.
X*/
X
void c_dec (void)
X{
X radix = 10;
X}
X
X
X/*
X HEX set radix for binaries to 16.
X*/
X
void c_hex (void)
X{
X radix = 16;
X}
X
X
void c_listend (void)
X{
X /* dummy function -- does nothing */
X}
END_OF_FILE
if test 3917 -ne `wc -c <'misccmd.c'`; then
echo shar: \"'misccmd.c'\" unpacked with wrong size!
fi
chmod +x 'misccmd.c'
# end of 'misccmd.c'
fi
if test -f 'misccmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'misccmd.h'\"
else
echo shar: Extracting \"'misccmd.h'\" \(739 characters\)
sed "s/^X//" >'misccmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Miscellaneous user commands
X
X0.0 hjp 89-06-27
X
X initial version
X
X0.1 hjp 89-07-14
X
X TRON, TROFF added
X
X0.2 hjp 89-08-29
X
X TIME added
X
X0.3 hjp 89-10-04
X
X -> (c_local) added
X
X0.4 hjp 89-11-23
X
X BIN, OCT, DEC, HEX added.
X
X0.5 hjp 90-03-02
X
X } added.
X
X****************************************************************/
X
X#ifndef I_misc_cmd
X
X #define I_misc_cmd
X
X void c_bin (void);
X void c_dec (void);
X void c_hex (void);
X void c_listend (void); /* } */
X void c_oct (void);
X void c_off (void);
X void c_pbegin (void);
X void c_pend (void);
X void c_eval (void);
X void c_tron (void);
X void c_troff (void);
X void c_time (void);
X void c_local (void); /* -> */
X
X#endif
END_OF_FILE
if test 739 -ne `wc -c <'misccmd.h'`; then
echo shar: \"'misccmd.h'\" unpacked with wrong size!
fi
chmod +x 'misccmd.h'
# end of 'misccmd.h'
fi
if test -f 'parser.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'parser.h'\"
else
echo shar: Extracting \"'parser.h'\" \(518 characters\)
sed "s/^X//" >'parser.h' <<'END_OF_FILE'
X/****************************************************************
X
X Parser.h
X
X0.0 hjp 89-06-14
X
X initial version
X
X****************************************************************/
X
extern
char cmdline [], /* The command line */
X empty, /* is it empty */
X * rdptr, /* rdptr points to the first character not yet read by getobj */
X
X pbuffer []; /* buffer for building programs */
X
void findwhite (void);
void skipwhite (void);
genobj * getobj (void);
void edit (genobj * obj);
void * readvalue (void);
END_OF_FILE
if test 518 -ne `wc -c <'parser.h'`; then
echo shar: \"'parser.h'\" unpacked with wrong size!
fi
chmod +x 'parser.h'
# end of 'parser.h'
fi
if test -f 'porting.tips' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'porting.tips'\"
else
echo shar: Extracting \"'porting.tips'\" \(2995 characters\)
sed "s/^X//" >'porting.tips' <<'END_OF_FILE'
Tips for porting RPL to other systems:
X
X
I ported RPL to gcc (Version 1.36, MIPS) to find out how
portable the code is. I needed about two days and most of
the problems were with gcc's header files.
X
This sources are the result and compile both with Turbo-C
and gcc without errors (but a lot of warnings because of many
missing casts -- I had the warning 'suspicious pointer conversion'
turned off on Turbo-C).
X
Here is a list of the problems I had and how I solved them.
X
arithcmd.c:
X The function
X double cabs (struct complex z)
X and the
X struct complex {double x, y;}
X were not defined in math.h.
X
X I had to define them myself.
X cabs was, however, in cc's math library, but there
X seems to a difference in how cc and gcc handle structures
X as arguments. After finding sources for cabs and recompiling
X them it worked.
X
debug.c
X This file should be left out. It contains very compiler-dependent
X functions.
X
errors.c
X The function error uses a variable argument list. This did not work
X correctly, because the va_start macro was inside a #ifdef host_mips.
X Defining host_mips caused the program to compile without errors, but
X the optional arguments are not passed correctly.
X
X A (admittedly clumsy) workaround for this is to define error () with
X additional dummy arguments.
X
filecmd.c
X The function strerror () does not exist in gcc's library.
X I wrote a replacement.
X
globvar.c
X The line
X OP, 0, sizeof (opobj), memmap, "MemMap",
X should be deleted.
X
intcmd.c
X Printstack () uses coreleft () and _SP to find out how much memory and
X stack are left. Both are unique to Turbo-C, so change them or leave
X them out.
X
X Gcc's signal.h had a syntax error in it. It used #ifdef...#endif inside
X a comment! I split the comment.
X
X The functions itoa () and ultoa () do not exist in gcc's library.
X I wrote replacements.
X
misccmd.c
X c_time () uses ftime (), which may not be available on some systems.
X
parser.c
X Turbo-Cs sscanf has difficulties reading double values. To work around
X this bug I made real long double and checked the value read against
X HUGE_VAL. If your system does not know long doubles or the constant
X HUGE_VAL, you can change it back.
X
X The function strtoul () does not exist in gcc's library.
X I wrote a replacement.
X
rpl.c
X The line
X uint _stklen = 0x4000;
X can be left out. If stacks are limited in size on your system, use
X compiler or linker options (or somewhat else) to ensure that the stack
X is large enough. 16kB should suffice for everyday work.
X
X Start_prof () starts a profiling system published in comp.sources.misc
X last summer. It works with Microsoft C and Turbo C. Change it to your
X profiling system or leave it out.
X
X clearmem () should be left out.
X
storecmd.c
X The function strerror () does not exist in gcc's library.
X I wrote a replacement.
X
hjp.h
X some of the types defined in hjp.h are already defined on some systems.
X Remove these to prevent "duplicate typedef" errors.
X
X*.c
X #include <alloc.h> must be replaced by #include <malloc.h>.
END_OF_FILE
if test 2995 -ne `wc -c <'porting.tips'`; then
echo shar: \"'porting.tips'\" unpacked with wrong size!
fi
# end of 'porting.tips'
fi
if test -f 'problems' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'problems'\"
else
echo shar: Extracting \"'problems'\" \(1604 characters\)
sed "s/^X//" >'problems' <<'END_OF_FILE'
pending:
X
X89-11-30 Exception handling needed.
X
solved:
X
X89-08-15 89-08-15 LOAD missing
X89-08-15 89-08-22 Error in parsing strings: skips EOL
X89-08-15 89-08-22 Strings should be C-like
X89-08-15 89-08-22 cr/lf not recognized as white space
X89-08-23 89-10-05 loosing memory w/ calls
X89-09-03 89-10-05 loosing memory w/ relcmds -- push but no destroy
X89-09-03 89-10-05 loosing memory w/ arithcmds -- push but no destroy -- link count neccessary
X89-09-03 89-10-05 introducing link count: arithcmd <= c_sqrt
X intcmd
X rest is still unchanged ==> extremly unstable
X *link count should now be implemented everywhere.
X89-08-15 89-11-08 STO should globber existing variables.
X89-11-09 89-11-11 ACOS wrong results with complex
X89-11-09 89-11-11 ATAN wrong results with complex
X89-11-11 89-11-11 SQ changes argument
X89-11-11 89-11-15 TAN wrong w/ some complex args
X89-11-15 89-11-23 need function to append object to a file (modify SAVE ??)
X89-11-23 89-12-02 Ops for binary not implemented.
X89-10-05 89-12-11 Problems with local variables in recursive functions.
X (89-11-11: didn't occur since, the SQ bug could have been the reason)
X *considered fixed
X89-11-23 89-12-11 Find shorter algorithm to resolve overloading.
X *still not optimal, but a lot better than before.
X90-03-03 90-03-03 malloc still used in branchcmd.c, intcmd.c misccmd.c relcmd.c stocmd.c
END_OF_FILE
if test 1604 -ne `wc -c <'problems'`; then
echo shar: \"'problems'\" unpacked with wrong size!
fi
chmod +x 'problems'
# end of 'problems'
fi
if test -f 'realcmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'realcmd.h'\"
else
echo shar: Extracting \"'realcmd.h'\" \(478 characters\)
sed "s/^X//" >'realcmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Commands related to real objects.
X
X0.0 hjp 90-03-04
X
X initial version.
X
X****************************************************************/
X
X#ifndef I_realcmd
X
X #define I_realcmd
X
X void c_minr (void);
X void c_maxr (void);
X void c_abs (void);
X void c_sign (void);
X void c_mod (void);
X void c_max (void);
X void c_min (void);
X void c_floor (void);
X void c_ceil (void);
X void c_ip (void);
X void c_fp (void);
X
X#endif
END_OF_FILE
if test 478 -ne `wc -c <'realcmd.h'`; then
echo shar: \"'realcmd.h'\" unpacked with wrong size!
fi
chmod +x 'realcmd.h'
# end of 'realcmd.h'
fi
if test -f 'relcmd.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'relcmd.c'\"
else
echo shar: Extracting \"'relcmd.c'\" \(3675 characters\)
sed "s/^X//" >'relcmd.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X RelCmd
X
Description:
X Commands implementing relational operations
X
X
Modification history:
X
X0.0 hjp 89-07-14
X
X initial version
X
X0.1 hjp 89-09-04
X
X destroy added after push to prevent memory loss.
X
X0.2 hjp 89-10-01
X
X link count added. destroy now superfluos - removed.
X
X0.3 hjp 90-03-03
X
X malloc replaced by mallocobj (at last!).
X
X0.4 hjp 90-03-07
X
X argument checking fixed in all functions.
X
X****************************************************************/
X
X#include "rpl.h"
X#include "relcmd.h"
X#include "globvar.h"
X#include "errors.h"
X#include "intcmd.h"
X#include "stackcmd.h"
X
X#include "debug.h"
X
X/*
X Level 2 > Level 1 ?
X*/
X
void c_gt (void)
X{
X genobj * a, * b, * c;
X
X if (! stack || ! stack->next) {
X error (">", ERR_2FEWARG);
X return;
X }
X
X b = stack->obj; a = stack->next->obj;
X
X if (a->id == REAL && b->id == REAL) {
X c = mallocobj (REAL);
X ((realobj *)c)->val = ((realobj *) a)->val > ((realobj *) b)->val;
X c_drop ();
X c_drop ();
X push (c);
X } else {
X if (a->id != REAL) error (">", ERR_WRTYPE, id2str (a->id));
X if (b->id != REAL) error (">", ERR_WRTYPE, id2str (b->id));
X }
X}
X
X
X/*
X Level 2 >= Level 1 ?
X*/
X
void c_ge (void)
X{
X genobj * a, * b, * c;
X
X if (! stack || ! stack->next) {
X error (">=", ERR_2FEWARG);
X return;
X }
X
X b = stack->obj; a = stack->next->obj;
X
X if (a->id == REAL && b->id == REAL) {
X c = mallocobj (REAL);
X ((realobj *)c)->val = ((realobj *) a)->val >= ((realobj *) b)->val;
X c_drop ();
X c_drop ();
X push (c);
X } else {
X if (a->id != REAL) error (">=", ERR_WRTYPE, id2str (a->id));
X if (b->id != REAL) error (">=", ERR_WRTYPE, id2str (b->id));
X }
X}
X
X
X/*
X Level 2 == Level 1 ?
X*/
X
void c_eq (void)
X{
X genobj * a, * b, * c;
X
X if (! stack || ! stack->next) {
X error ("==", ERR_2FEWARG);
X return;
X }
X
X b = stack->obj; a = stack->next->obj;
X
X if (a->id == REAL && b->id == REAL) {
X c = mallocobj (REAL);
X ((realobj *)c)->val = ((realobj *) a)->val == ((realobj *) b)->val;
X c_drop ();
X c_drop ();
X push (c);
X } else {
X if (a->id != REAL) error ("==", ERR_WRTYPE, id2str (a->id));
X if (b->id != REAL) error ("==", ERR_WRTYPE, id2str (b->id));
X }
X}
X
X
X/*
X Level 2 <= Level 1 ?
X*/
X
void c_le (void)
X{
X genobj * a, * b, * c;
X
X if (! stack || ! stack->next) {
X error ("<=", ERR_2FEWARG);
X return;
X }
X
X b = stack->obj; a = stack->next->obj;
X
X if (a->id == REAL && b->id == REAL) {
X c = mallocobj (REAL);
X ((realobj *)c)->val = ((realobj *) a)->val <= ((realobj *) b)->val;
X c_drop ();
X c_drop ();
X push (c);
X } else {
X if (a->id != REAL) error ("<=", ERR_WRTYPE, id2str (a->id));
X if (b->id != REAL) error ("<=", ERR_WRTYPE, id2str (b->id));
X }
X}
X
X
X/*
X Level 2 < Level 1 ?
X*/
X
void c_lt (void)
X{
X genobj * a, * b, * c;
X
X if (! stack || ! stack->next) {
X error ("<", ERR_2FEWARG);
X return;
X }
X
X b = stack->obj; a = stack->next->obj;
X
X if (a->id == REAL && b->id == REAL) {
X c = mallocobj (REAL);
X ((realobj *)c)->val = ((realobj *) a)->val < ((realobj *) b)->val;
X c_drop ();
X c_drop ();
X push (c);
X } else {
X if (a->id != REAL) error ("<", ERR_WRTYPE, id2str (a->id));
X if (b->id != REAL) error ("<", ERR_WRTYPE, id2str (b->id));
X }
X}
X
X
X/*
X Level 2 != Level 1 ?
X*/
X
void c_ne (void)
X{
X genobj * a, * b, * c;
X
X if (! stack || ! stack->next) {
X error ("!=", ERR_2FEWARG);
X return;
X }
X
X b = stack->obj; a = stack->next->obj;
X
X if (a->id == REAL && b->id == REAL) {
X c = mallocobj (REAL);
X ((realobj *)c)->val = ((realobj *) a)->val != ((realobj *) b)->val;
X c_drop ();
X c_drop ();
X push (c);
X } else {
X if (a->id != REAL) error ("!=", ERR_WRTYPE, id2str (a->id));
X if (b->id != REAL) error ("!=", ERR_WRTYPE, id2str (b->id));
X }
X}
END_OF_FILE
if test 3675 -ne `wc -c <'relcmd.c'`; then
echo shar: \"'relcmd.c'\" unpacked with wrong size!
fi
chmod +x 'relcmd.c'
# end of 'relcmd.c'
fi
if test -f 'relcmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'relcmd.h'\"
else
echo shar: Extracting \"'relcmd.h'\" \(431 characters\)
sed "s/^X//" >'relcmd.h' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X RelCmd
X
Description:
X Commands implementing relational operations
X
X
Modification history:
X
X 0.0 hjp 89-07-14
X
X initial version
X
X****************************************************************/
X
X#ifndef I_relcmd
X
X #define I_relcmd
X
X void c_gt (void);
X void c_ge (void);
X void c_eq (void);
X void c_le (void);
X void c_lt (void);
X void c_ne (void);
X
X#endif
END_OF_FILE
if test 431 -ne `wc -c <'relcmd.h'`; then
echo shar: \"'relcmd.h'\" unpacked with wrong size!
fi
chmod +x 'relcmd.h'
# end of 'relcmd.h'
fi
if test -f 'rpl.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'rpl.c'\"
else
echo shar: Extracting \"'rpl.c'\" \(1311 characters\)
sed "s/^X//" >'rpl.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X HP main module
X
Description:
X interactive loop
X
X
Modification history:
X
X 0.0 hjp 89-06-26
X
X initial version
X
X 0.1 hjp 89-07-25
X
X main greatly simplified by replacement of switch (obj->id)
X through interprete (obj, 1);
X
X 0.2 hjp 89-12-11
X
X FPE handling added.
X
X 0.3 hjp 90-03-06
X
X Stack length, profiling and clearmem excluded for
X non-Turbo-C environment.
X
X****************************************************************/
X
X
X#include <signal.h>
X#include <stdio.h>
X#include <string.h>
X
X#include "rpl.h"
X#include "globvar.h"
X#include "intcmd.h"
X#include "parser.h"
X#include "debug.h"
X
X#ifdef __TURBOC__
uint _stklen = 0x4000; /* 16 k Bytes of stack */
X#endif
X
main (int argc, char ** argv)
X{
X genobj * obj;
X
X#ifdef __TURBOC__
X if (! strcmp (argv [1], "-p")) {
X prof_start (argv [0]);
X }
X#endif
X
X /* clear memory so that MemMap will work right */
X
X#ifdef __TURBOC__
X clearmem (0x8000);
X#endif
X
X /* set up floating point exception handler */
X
X signal (SIGFPE, fpehandler);
X signal (SIGINT, inthandler);
X
X for (;;) {
X setjmp (main_loop);
X obj = readvalue ();
X if (obj) {
X interprete (obj, 1);
X obj->link ++; /* destroy original instance of object */
X destroy (obj, 1);
X } else {
X empty = 1;
X printstack ();
X }
X }
X}
X
END_OF_FILE
if test 1311 -ne `wc -c <'rpl.c'`; then
echo shar: \"'rpl.c'\" unpacked with wrong size!
fi
chmod +x 'rpl.c'
# end of 'rpl.c'
fi
if test -f 'rpl.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'rpl.h'\"
else
echo shar: Extracting \"'rpl.h'\" \(2534 characters\)
sed "s/^X//" >'rpl.h' <<'END_OF_FILE'
X/****************************************************************
X
X Typedefs and constants
X
X0.0 hjp 89-06-14
X
X initial version
X
X0.1 hjp 89-07-08
X
X function prototypes moved to intcmds.h
X
X0.2 hjp 89-07-25
X
X stringobj added
X
X0.3 hjp 89-08-29
X
X loopobj added
X
X0.4 hjp 89-09-04
X
X link count added to all objects.
X
X0.5 hjp 89-11-23
X
X binary object added.
X
X0.6 hjp 89-12-02
X
X object types changed to be continuous.
X macro t22int (convert 2 types to int) added.
X
X0.7 hjp 89-12-02
X
X Comment object added.
X
X0.8 hjp 90-03-06
X
X port.h added.
X
X****************************************************************/
X
X
X#ifndef I_hp
X
X #define I_hp
X
X #include <hjp.h>
X #include <math.h>
X #include <port.h>
X
X #define PROGMAXSIZE 4096
X #define NAMELEN 32
X
X #define NOOBJ -1
X #define REAL 1
X #define COMPLEX 2
X #define STRING 3
X #define RVECT 4
X #define RMAT 5
X #define CVECT 6
X #define CMAT 7
X #define LIST 8
X #define QNAME 9
X #define UNAME 10
X #define OP 11
X #define PROGRAM 12
X #define BINARY 13
X
X #define VARIABLE 16 /* internal use only */
X #define START 17 /* internal use only */
X #define FOR 18 /* internal use only */
X #define DO 19 /* internal use only */
X #define WHILE 20 /* internal use only */
X #define COMMENT 21 /* internal use only */
X
X #define t22int(a, b) (((a)<<8)|(b))
X
X
X typedef struct complex
X complex;
X
X typedef struct genobj {
X int id;
X uint link;
X uint size;
X } genobj;
X
X typedef struct realobj {
X int id;
X uint link;
X uint size;
X double val;
X } realobj;
X
X typedef struct complexobj {
X int id;
X uint link;
X uint size;
X complex val;
X } complexobj;
X
X typedef struct opobj {
X int id;
X uint link;
X uint size;
X void (* fptr)(void);
X char name [32];
X } opobj;
X
X typedef struct listobj {
X int id;
X uint link;
X uint size;
X genobj * obj;
X struct listobj
X * next;
X } listobj;
X
X typedef struct nameobj {
X int id;
X uint link;
X uint size;
X char name [NAMELEN];
X } nameobj;
X
X typedef struct varobj {
X int id;
X uint link;
X uint size;
X char name [NAMELEN];
X genobj * val;
X struct varobj
X * next;
X } varobj;
X
X typedef struct stringobj {
X int id;
X uint link;
X uint size;
X char val [1]; /* dummy to calm the compiler. */
X /* The string can be up to 65521 chars long (including '\0') */
X } stringobj;
X
X typedef struct loopobj {
X int id;
X uint link;
X uint size;
X struct
X loopobj * next;
X genobj ** addr;
X double cnt;
X varobj * var;
X } loopobj;
X
X
X typedef struct binaryobj {
X int id;
X uint link;
X uint size;
X long val;
X } binaryobj;
X
X typedef stringobj commentobj;
X
X#endif
END_OF_FILE
if test 2534 -ne `wc -c <'rpl.h'`; then
echo shar: \"'rpl.h'\" unpacked with wrong size!
fi
chmod +x 'rpl.h'
# end of 'rpl.h'
fi
if test -f 'rpl.prj' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'rpl.prj'\"
else
echo shar: Extracting \"'rpl.prj'\" \(1223 characters\)
sed "s/^X//" >'rpl.prj' <<'END_OF_FILE'
arithcmd.c (arithcmd.h debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h)
bincmd.c (bincmd.h)
branchcm.c (branchcm.h debug.h errors.h rpl.h intcmd.h misccmd.h stackcmd.h)
cmplxcmd.c (cmplxcmd.h errors.h globvar.h rpl.h intcmd.h stackcmd.h)
debug.c (debug.h rpl.h errors.h)
errors.c (errors.h debug.h)
filecmd.c (errors.h filecmd.h globvar.h rpl.h intcmd.h)
globvar.c (arithcmd.h branchcm.h cmplxcmd.h debug.h filecmd.h globvar.h rpl.h logcmd.h misccmd.h relcmd.h stackcmd.h storecmd.h trigcmd.h)
rpl.c (debug.h globvar.h rpl.h intcmd.h parser.h)
intcmd.c (debug.h errors.h rpl.h globvar.h intcmd.h misccmd.h)
logcmd.c (errors.h globvar.h rpl.h intcmd.h logcmd.h stackcmd.h)
matherr.c
misccmd.c (debug.h errors.h globvar.h rpl.h intcmd.h misccmd.h stackcmd.h)
parser.c (debug.h errors.h globvar.h intcmd.h misccmd.h parser.h rpl.h)
realcmd.c (realcmd.h debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h)
relcmd.c (relcmd.h debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h)
stackcmd.c (debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h)
storecmd.c (debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h storecmd.h)
trigcmd.c (debug.h errors.h globvar.h rpl.h intcmd.h stackcmd.h trigcmd.h)
X
X/tc/cprof/lprof.obj
END_OF_FILE
if test 1223 -ne `wc -c <'rpl.prj'`; then
echo shar: \"'rpl.prj'\" unpacked with wrong size!
fi
chmod +x 'rpl.prj'
# end of 'rpl.prj'
fi
if test -f 'stackcmd.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'stackcmd.c'\"
else
echo shar: Extracting \"'stackcmd.c'\" \(1268 characters\)
sed "s/^X//" >'stackcmd.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X StackCmd
X
Description:
X Commands for manipulating the stack
X
X
Modification history:
X
X 0.0 hjp 89-06-26
X
X initial version: DROP, SWAP, CLEAR
X
X 0.1 hjp 89-06-26
X
X DUP added
X
X****************************************************************/
X
X#include <stddef.h>
X
X#include "errors.h"
X#include "globvar.h"
X#include "rpl.h"
X#include "intcmd.h"
X#include "stackcmd.h"
X#include "debug.h"
X
X/*
X drop the element at the top of the stack
X*/
X
void c_drop (void)
X{
X listobj * l;
X
X l = stack;
X
X if (l) {
X if (l->id == LIST) {
X stack = l->next;
X destroy ((genobj *)l, 0);
X } else {
X error ("drop", INT_STKNOLIST, NULL);
X }
X } else {
X error ("drop", ERR_STKEMPTY, NULL);
X }
X}
X
X
X/*
X swap two topmost arguments
X*/
X
void c_swap (void)
X{
X listobj * a, * b;
X
X if ((a = stack) && (b = stack->next)) {
X a->next = b->next;
X b->next = a;
X stack = b;
X } else {
X error ("swap", ERR_2FEWARG, NULL);
X }
X}
X
X
X/*
X clear stack
X*/
void c_clear (void)
X{
X while (stack) {
X c_drop ();
X }
X}
X
X/*
X duplicate topmost element
X*/
X
void c_dup (void)
X{
X#ifdef TRACE
X printf ("c_dup () {\n");
X#endif
X if (stack) {
X push (stack->obj);
X } else {
X error ("DUP", ERR_2FEWARG);
X }
X#ifdef TRACE
X printf ("} c_dup\n");
X#endif
X}
END_OF_FILE
if test 1268 -ne `wc -c <'stackcmd.c'`; then
echo shar: \"'stackcmd.c'\" unpacked with wrong size!
fi
chmod +x 'stackcmd.c'
# end of 'stackcmd.c'
fi
if test -f 'stackcmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'stackcmd.h'\"
else
echo shar: Extracting \"'stackcmd.h'\" \(369 characters\)
sed "s/^X//" >'stackcmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Stack commands
X
X0.0 hjp 89-06-14
X
X initial version: DROP, SWAP, CLEAR
X
X0.1 hjp 89-07-14
X
X DUP added
X
X****************************************************************/
X
X#ifndef I_stackcmd
X
X #define I_stackcmd
X
X void c_drop (void);
X void c_swap (void);
X void c_clear (void);
X void c_dup (void);
X
X#endif
END_OF_FILE
if test 369 -ne `wc -c <'stackcmd.h'`; then
echo shar: \"'stackcmd.h'\" unpacked with wrong size!
fi
chmod +x 'stackcmd.h'
# end of 'stackcmd.h'
fi
if test -f 'storecmd.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'storecmd.c'\"
else
echo shar: Extracting \"'storecmd.c'\" \(3166 characters\)
sed "s/^X//" >'storecmd.c' <<'END_OF_FILE'
X/****************************************************************
X
Module:
X StoreCmd
X
Description:
X Commands for manipulating variables
X
X
Modification history:
X
X0.0 hjp 89-07-08
X
X initial version.
X
X0.1 hjp: 89-07-25
X
X comments added.
X
X0.2 hjp: 89-08-14
X
X PURGE and USER added.
X
X0.3 hjp: 89-11-08
X
X STO now globbers existing variables.
X
X0.4 hjp: 89-11-23
X
X PURGE now can delete files.
X (This would belong into FileCmd, but I didn't want 2 purges.)
X
X0.5 hjp 90-03-03
X
X malloc replaced by mallocobj (at last!).
X
X****************************************************************/
X
X#include <stddef.h>
X#include <stdio.h>
X#include <string.h>
X
X#include "rpl.h"
X#include "errors.h"
X#include "intcmd.h"
X#include "stackcmd.h"
X#include "storecmd.h"
X#include "globvar.h"
X#include "debug.h"
X
X/*
X STO: store object in variable
X
X 2: obj 1: qname ->
X*/
X
void c_sto (void)
X{
X listobj * a, * b;
X varobj * p;
X
X if ((b = stack) && (a = stack->next)) {
X
X if (b->obj->id != QNAME) {
X
X error ("STO", ERR_WRTYPE, NULL);
X
X } else if (p = findvar (((nameobj *) b->obj)->name)) {
X
X destroy (p->val, 1); /* destroy old contents of variable */
X
X c_drop (); /* drop name */
X
X p->val = a->obj;
X
X stack = a->next; /* drop stored object w/o destroing it !! */
X a->obj = NULL;
X destroy (a, 0);
X
X } else if (p = mallocobj (VARIABLE)) {
X
X p->id = VARIABLE;
X p->link = 1;
X p->size = sizeof (varobj);
X strcpy (p->name, ((nameobj *) b->obj)->name);
X
X c_drop (); /* drop name */
X
X p->val = a->obj;
X
X stack = a->next; /* drop stored object w/o destroing it !! */
X a->obj = NULL;
X destroy (a, 0);
X
X p->next = vars; /* hook it into variable list */
X vars = p;
X
X }
X } else {
X
X error ("STO", ERR_2FEWARG, NULL);
X }
X}
X
X/*
X RCL: recall variable
X 1: qname -> 1: obj
X*/
X
void c_rcl (void)
X{
X nameobj * a;
X varobj * p;
X
X if (! stack) {
X error ("RCL", ERR_2FEWARG, NULL);
X return;
X }
X
X if ((a = stack->obj)->id != QNAME) {
X error ("RCL", ERR_WRTYPE, NULL);
X return;
X }
X
X for (p = vars; p && strcmp (a->name, p->name); p = p->next);
X
X c_drop ();
X
X if (p) {
X push (p->val);
X } else {
X error ("RCL", ERR_NXVAR, NULL);
X return;
X }
X}
X
X/*
X USER: show user variables
X*/
X
void c_user (void)
X{
X varobj * p;
X
X if (vars) {
X for (p = vars; p; p = p->next) {
X printf ("'%s'\n", p->name);
X }
X } else {
X error ("USER", ERR_NOVAR, NULL);
X return;
X }
X}
X
X/*
X PURGE: purge user variable(s) or file.
X
X 1:qname ->
X 1:v -> (the variable with name v is purged)
X
X 1:string ->
X 1:s -> (the file with name s is unlinked)
X*/
X
void c_purge (void)
X{
X nameobj * a;
X varobj * p, * pp;
X
X if (! stack) {
X error ("PURGE", ERR_2FEWARG, NULL);
X return;
X }
X
X if ((a = stack->obj)->id == QNAME) {
X
X for (pp = NULL, p = vars;
X p && strcmp (a->name, p->name);
X pp = p, p = p->next);
X
X c_drop ();
X
X if (p) {
X if (pp) {
X pp->next = p->next;
X } else {
X vars = p->next;
X }
X destroy (p, 1);
X } else {
X error ("PURGE", ERR_NXVAR, NULL);
X return;
X }
X } else if ((a = stack->obj)->id == STRING) {
X if (unlink (((stringobj *) a)->val) == -1) {
X error ("PURGE", ERR_DOS, strerror (errno));
X }
X c_drop ();
X } else {
X error ("PURGE", ERR_WRTYPE, NULL);
X return;
X }
X}
END_OF_FILE
if test 3166 -ne `wc -c <'storecmd.c'`; then
echo shar: \"'storecmd.c'\" unpacked with wrong size!
fi
chmod +x 'storecmd.c'
# end of 'storecmd.c'
fi
if test -f 'storecmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'storecmd.h'\"
else
echo shar: Extracting \"'storecmd.h'\" \(360 characters\)
sed "s/^X//" >'storecmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Store commands
X
X0.0 hjp 89-07-08
X
X initial version
X
X0.1 hjp 89-08-14
X
X PURGE and USER added
X
X****************************************************************/
X
X#ifndef I_storecmd
X
X #define I_storecmd
X
X void c_sto (void);
X void c_rcl (void);
X void c_purge (void);
X void c_user (void);
X
X#endif
END_OF_FILE
if test 360 -ne `wc -c <'storecmd.h'`; then
echo shar: \"'storecmd.h'\" unpacked with wrong size!
fi
chmod +x 'storecmd.h'
# end of 'storecmd.h'
fi
if test -f 'trigcmd.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'trigcmd.h'\"
else
echo shar: Extracting \"'trigcmd.h'\" \(460 characters\)
sed "s/^X//" >'trigcmd.h' <<'END_OF_FILE'
X/****************************************************************
X
X Functions used for implementing user trigonometric commands
X
X0.0 hjp 89-12-03
X
X initial version
X SIN, COS, TAN, ASIN, ACOS, ATAN extracted from ArithCmd.
X
X****************************************************************/
X
X#ifndef I_trigcmd
X
X #define I_trigcmd
X
X void c_acos (void);
X void c_asin (void);
X void c_atan (void);
X void c_cos (void);
X void c_sin (void);
X void c_tan (void);
X
X#endif
END_OF_FILE
if test 460 -ne `wc -c <'trigcmd.h'`; then
echo shar: \"'trigcmd.h'\" unpacked with wrong size!
fi
chmod +x 'trigcmd.h'
# end of 'trigcmd.h'
fi
echo shar: End of shell archive.
exit 0