v11i022: RPL Part 2 of 3

hp at relay.EU.net hp at relay.EU.net
Sun Mar 11 05:57:34 AEST 1990


Posting-number: Volume 11, Issue 22
Submitted-by: hp at 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 at 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



More information about the Comp.sources.misc mailing list