--- /dev/null
+
+SUBDIRS = \
+ float \
+ fphook \
+ i386 \
+ libm2 \
+ libp \
+ liby \
+ math \
+ rts \
+
+include ../Makefile.inc
--- /dev/null
+
+all:
+ cd float && make
+ cd fphook && make
+ cd `arch` && make
+ cd libm2 && make
+ cd libp && make
+ cd liby && make
+ cd math && make
+ cd rts && make
+
--- /dev/null
+#!/bin/sh
+# Author: Kees J. Bot
+# Compile one soft FP source file.
+# (These files shouldn't be optimized normally, but the 16-bit C compiler
+# only optimizes scratch register allocation a bit with -O. To the 32-bit
+# compiler -O is a no-op.)
+
+case $#:$1 in
+1:*.fc) ;;
+*) echo "$0: $1: not a FC file" >&2; exit 1
+esac
+
+base="`basename "$1" .fc`"
+trap 'rm -f tmp.c tmp.s"; exit 1' 2
+
+cp "$1" tmp.c &&
+cc -O -I. -D_MINIX -D_POSIX_SOURCE -S tmp.c &&
+sed -f FP.script tmp.s > "$base.s" &&
+rm tmp.c tmp.s
--- /dev/null
+s/_adf4/.adf4/
+s/_adf8/.adf8/
+s/_cff4/.cff4/
+s/_cff8/.cff8/
+s/_cfi/.cfi/
+s/_cfu/.cfu/
+s/_cif4/.cif4/
+s/_cif8/.cif8/
+s/_cmf4/.cmf4/
+s/_cmf8/.cmf8/
+s/_cuf4/.cuf4/
+s/_cuf8/.cuf8/
+s/_dvf4/.dvf4/
+s/_dvf8/.dvf8/
+s/_fef4/.fef4/
+s/_fef8/.fef8/
+s/_fif4/.fif4/
+s/_fif8/.fif8/
+s/_mlf4/.mlf4/
+s/_mlf8/.mlf8/
+s/_ngf4/.ngf4/
+s/_ngf8/.ngf8/
+s/_sbf4/.sbf4/
+s/_sbf8/.sbf8/
+s/_zrf4/.zrf4/
+s/_zrf8/.zrf8/
+s/_add_ext/.add_ext/
+s/_div_ext/.div_ext/
+s/_mul_ext/.mul_ext/
+s/_nrm_ext/.nrm_ext/
+s/_sft_ext/.sft_ext/
+s/_sub_ext/.sub_ext/
+s/_zrf_ext/.zrf_ext/
+s/_compact/.compact/
+s/_extend/.extend/
+s/_b64_add/.b64_add/
+s/_b64_sft/.b64_sft/
+s/_b64_rsft/.b64_rsft/
+s/_b64_lsft/.b64_lsft/
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ include file for floating point package
+*/
+
+ /* FLOAT FORMAT EXPONENT BIAS */
+
+#define SGL_BIAS 127 /* excess 128 notation used */
+#define DBL_BIAS 1023 /* excess 1024 notation used */
+#define EXT_BIAS 0 /* 2s-complement notation used */
+ /* this is possible because the */
+ /* sign is in a seperate word */
+
+ /* VARIOUS MAX AND MIN VALUES */
+ /* 1) FOR THE DIFFERENT FORMATS */
+
+#define SGL_MAX 254 /* standard definition */
+#define SGL_MIN 1 /* standard definition */
+#define DBL_MAX 2046 /* standard definition */
+#define DBL_MIN 1 /* standard definition */
+#define EXT_MAX 16383 /* standard minimum */
+#define EXT_MIN -16382 /* standard minimum */
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ include file for floating point package
+*/
+
+# define CARRYBIT 0x80000000L
+# define NORMBIT 0x80000000L
+# define EXP_STORE 16
+
+
+ /* parameters for Single Precision */
+#define SGL_EXPSHIFT 7
+#define SGL_M1LEFT 8
+#define SGL_ZERO 0xffffff80L
+#define SGL_EXACT 0xff
+#define SGL_RUNPACK SGL_M1LEFT
+
+#define SGL_ROUNDUP 0x80
+#define SGL_CARRYOUT 0x01000000L
+#define SGL_MASK 0x007fffffL
+
+ /* parameters for Double Precision */
+ /* used in extend.c */
+
+#define DBL_EXPSHIFT 4
+
+#define DBL_M1LEFT 11
+
+#define DBL_RPACK (32-DBL_M1LEFT)
+#define DBL_LPACK DBL_M1LEFT
+
+ /* used in compact.c */
+
+#define DBL_ZERO 0xfffffd00L
+
+#define DBL_EXACT 0x7ff
+
+#define DBL_RUNPACK DBL_M1LEFT
+#define DBL_LUNPACK (32-DBL_RUNPACK)
+
+#define DBL_ROUNDUP 0x400
+#define DBL_CARRYOUT 0x00200000L
+#define DBL_MASK 0x000fffffL
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ include file for floating point package
+*/
+
+ /* EM TRAPS */
+
+#define EIOVFL 3 /* Integer Overflow */
+#define EFOVFL 4 /* Floating Overflow */
+#define EFUNFL 5 /* Floating Underflow */
+#define EIDIVZ 6 /* Integer Divide by 0 */
+#define EFDIVZ 7 /* Floating Divide by 0.0 */
+#define EIUND 8 /* Integer Undefined Number */
+#define EFUND 9 /* Floating Undefined Number */
+#define ECONV 10 /* Conversion Error */
+# define trap(x) _fptrp(x)
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/********************************************************/
+/*
+ Type definitions for C Floating Point Package
+ include file for floating point package
+*/
+/********************************************************/
+/*
+ THESE STRUCTURES ARE USED TO ADDRESS THE INDIVIDUAL
+ PARTS OF THE FLOATING POINT NUMBER REPRESENTATIONS.
+
+ THREE STRUCTURES ARE DEFINED:
+ SINGLE: single precision floating format
+ DOUBLE: double precision floating format
+ EXTEND: double precision extended format
+*/
+/********************************************************/
+
+#ifndef __FPTYPES
+#define __FPTYPES
+
+typedef struct {
+ unsigned long h_32; /* higher 32 bits of 64 */
+ unsigned long l_32; /* lower 32 bits of 64 */
+} B64;
+
+typedef unsigned long SINGLE;
+
+typedef struct {
+ unsigned long d[2];
+} DOUBLE;
+
+typedef struct { /* expanded float format */
+ short sign;
+ short exp;
+ B64 mantissa;
+#define m1 mantissa.h_32
+#define m2 mantissa.l_32
+} EXTEND;
+
+struct fef4_returns {
+ int e;
+ SINGLE f;
+};
+
+struct fef8_returns {
+ int e;
+ DOUBLE f;
+};
+
+struct fif4_returns {
+ SINGLE ipart;
+ SINGLE fpart;
+};
+
+struct fif8_returns {
+ DOUBLE ipart;
+ DOUBLE fpart;
+};
+
+#if __STDC__
+#define _PROTOTYPE(function, params) function params
+#else
+#define _PROTOTYPE(function, params) function()
+#endif
+_PROTOTYPE( void add_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void mul_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void div_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void sub_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void sft_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void nrm_ext, (EXTEND *e1));
+_PROTOTYPE( void zrf_ext, (EXTEND *e1));
+_PROTOTYPE( void extend, (unsigned long *from, EXTEND *to, int size));
+_PROTOTYPE( void compact, (EXTEND *from, unsigned long *to, int size));
+_PROTOTYPE( void _fptrp, (int));
+_PROTOTYPE( void adf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( void adf8, (DOUBLE s2, DOUBLE s1));
+_PROTOTYPE( void sbf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( void sbf8, (DOUBLE s2, DOUBLE s1));
+_PROTOTYPE( void dvf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( void dvf8, (DOUBLE s2, DOUBLE s1));
+_PROTOTYPE( void mlf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( void mlf8, (DOUBLE s2, DOUBLE s1));
+_PROTOTYPE( void ngf4, (SINGLE f));
+_PROTOTYPE( void ngf8, (DOUBLE f));
+_PROTOTYPE( void zrf4, (SINGLE *l));
+_PROTOTYPE( void zrf8, (DOUBLE *z));
+_PROTOTYPE( void cff4, (DOUBLE src));
+_PROTOTYPE( void cff8, (SINGLE src));
+_PROTOTYPE( void cif4, (int ss, long src));
+_PROTOTYPE( void cif8, (int ss, long src));
+_PROTOTYPE( void cuf4, (int ss, long src));
+_PROTOTYPE( void cuf8, (int ss, long src));
+_PROTOTYPE( long cfu, (int ds, int ss, DOUBLE src));
+_PROTOTYPE( long cfi, (int ds, int ss, DOUBLE src));
+_PROTOTYPE( int cmf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( int cmf8, (DOUBLE d1, DOUBLE d2));
+_PROTOTYPE( void fef4, (struct fef4_returns *r, SINGLE s1));
+_PROTOTYPE( void fef8, (struct fef8_returns *r, DOUBLE s1));
+_PROTOTYPE( void fif4, (struct fif4_returns *p, SINGLE x, SINGLE y));
+_PROTOTYPE( void fif8, (struct fif8_returns *p, DOUBLE x, DOUBLE y));
+
+_PROTOTYPE( void b64_sft, (B64 *, int));
+_PROTOTYPE( void b64_lsft, (B64 *));
+_PROTOTYPE( void b64_rsft, (B64 *));
+_PROTOTYPE( int b64_add, (B64 *, B64 *));
+#endif
--- /dev/null
+# Makefile for lib/float.
+
+CC1 = /bin/sh ./FP.compile
+
+LIBRARIES = libfp
+
+libfp_OBJECTS = \
+ add_ext.o \
+ adder.o \
+ adf4.o \
+ adf8.o \
+ cff4.o \
+ cff8.o \
+ cfi.o \
+ cfu.o \
+ cif4.o \
+ cif8.o \
+ cmf4.o \
+ cmf8.o \
+ compact.o \
+ cuf4.o \
+ cuf8.o \
+ div_ext.o \
+ dvf4.o \
+ dvf8.o \
+ extend.o \
+ fef4.o \
+ fef8.o \
+ fif4.o \
+ fif8.o \
+ fptrp.o \
+ mlf4.o \
+ mlf8.o \
+ mul_ext.o \
+ ngf4.o \
+ ngf8.o \
+ nrm_ext.o \
+ sbf4.o \
+ sbf8.o \
+ sft_ext.o \
+ shifter.o \
+ sub_ext.o \
+ zrf4.o \
+ zrf8.o \
+ zrf_ext.o \
+
+include ../../Makefile.ack.inc
+
+#extra commands to convert the c files to the correct assembler files
+
+%.s: %.fc
+ /bin/sh ./FP.compile $<
+
+#1. make a assembler file of the c file
+#%.fs: %.fc
+# -cp $< $(<:.fc=.c) && cc -O -I. -D_MINIX -D_POSIX_SOURCE -S $(<:.fc=.c) && cp $(<:.fc=.s) $(<:.fc=.fs)
+# @rm $(<:.fc=.c) $(<:.fc=.s)
+
+#2. modify the assembler file
+#%.s: %.fs
+# sed -f FP.script $< > $@
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ADD TWO EXTENDED FORMAT NUMBERS
+*/
+
+#include "FP_types.h"
+
+void
+add_ext(e1,e2)
+register EXTEND *e1,*e2;
+{
+ if ((e2->m1 | e2->m2) == 0L) {
+ return;
+ }
+ if ((e1->m1 | e1->m2) == 0L) {
+ *e1 = *e2;
+ return;
+ }
+ sft_ext(e1, e2); /* adjust mantissas to equal powers */
+ if (e1->sign != e2->sign) {
+ /* e1 + e2 = e1 - (-e2) */
+ if (e2->m1 > e1->m1 ||
+ (e2->m1 == e1->m1 && e2->m2 > e1->m2)) {
+ /* abs(e2) > abs(e1) */
+ EXTEND x;
+
+ x = *e1;
+ *e1 = *e2;
+ if (x.m2 > e1->m2) {
+ e1->m1 -= 1; /* carry in */
+ }
+ e1->m1 -= x.m1;
+ e1->m2 -= x.m2;
+ }
+ else {
+ if (e2->m2 > e1->m2)
+ e1->m1 -= 1; /* carry in */
+ e1->m1 -= e2->m1;
+ e1->m2 -= e2->m2;
+ }
+ }
+ else {
+ if (b64_add(&e1->mantissa,&e2->mantissa)) { /* addition carry */
+ b64_rsft(&e1->mantissa); /* shift mantissa one bit RIGHT */
+ e1->m1 |= 0x80000000L; /* set max bit */
+ e1->exp++; /* increase the exponent */
+ }
+ }
+ nrm_ext(e1);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ * these are the routines the routines to do 32 and 64-bit addition
+ */
+
+# ifdef EXT_DEBUG
+# include <stdio.h>
+# endif
+
+# include "FP_types.h"
+# define UNKNOWN -1
+# define TRUE 1
+# define FALSE 0
+# define MAXBIT 0x80000000L
+
+ /*
+ * add 64 bits
+ */
+int
+b64_add(e1,e2)
+ /*
+ * pointers to 64 bit 'registers'
+ */
+register B64 *e1,*e2;
+{
+ register int overflow;
+ int carry;
+
+ /* add higher pair of 32 bits */
+ overflow = ((unsigned long) 0xFFFFFFFF - e1->h_32 < e2->h_32);
+ e1->h_32 += e2->h_32;
+
+ /* add lower pair of 32 bits */
+ carry = ((unsigned long) 0xFFFFFFFF - e1->l_32 < e2->l_32);
+ e1->l_32 += e2->l_32;
+# ifdef EXT_DEBUG
+ printf("\t\t\t\t\tb64_add: overflow (%d); internal carry(%d)\n",
+ overflow,carry);
+ fflush(stdout);
+# endif
+ if ((carry) && (++e1->h_32 == 0))
+ return(TRUE); /* had a 64 bit overflow */
+ return(overflow); /* return status from higher add */
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ * include file for 32 & 64 bit addition
+ */
+
+typedef struct B64 {
+ unsigned long h_32; /* higher 32 bits of 64 */
+ unsigned long l_32; /* lower 32 bits of 64 */
+} B64;
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ADD TWO FLOATS - SINGLE (ADF 4)
+*/
+
+#include "FP_types.h"
+
+void
+adf4(s2,s1)
+SINGLE s1,s2;
+{
+ EXTEND e1,e2;
+ int swap = 0;
+
+ if (s1 == (SINGLE) 0) {
+ s1 = s2;
+ return;
+ }
+ if (s2 == (SINGLE) 0) {
+ return;
+ }
+ extend(&s1,&e1,sizeof(SINGLE));
+ extend(&s2,&e2,sizeof(SINGLE));
+ add_ext(&e1,&e2);
+ compact(&e1,&s1,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ADD TWO FLOATS - DOUBLE (ADF 8)
+*/
+
+#include "FP_types.h"
+
+void
+adf8(s2,s1)
+DOUBLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ if (s1.d[0] == 0 && s1.d[1] == 0) {
+ s1 = s2;
+ return;
+ }
+ if (s2.d[0] == 0 && s2.d[1] == 0) {
+ return;
+ }
+
+ extend(&s1.d[0],&e1,sizeof(DOUBLE));
+ extend(&s2.d[0],&e2,sizeof(DOUBLE));
+ add_ext(&e1,&e2);
+ compact(&e1,&s1.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+#define CHAR_UNSIGNED 0
+#define MSB_AT_LOW_ADDRESS 0
+#define MSW_AT_LOW_ADDRESS 0
+#define FL_MSB_AT_LOW_ADDRESS 0
+#define FL_MSW_AT_LOW_ADDRESS 0
+#define FL_MSL_AT_LOW_ADDRESS 0
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT DOUBLE TO SINGLE (CFF 8 4)
+
+ This routine works quite simply. A floating point
+ of size 08 is converted to extended format.
+ This extended variable is converted back to
+ a floating point of size 04.
+
+*/
+
+#include "FP_types.h"
+
+void
+cff4(src)
+DOUBLE src; /* the source itself - THIS TIME it's DOUBLE */
+{
+ EXTEND buf;
+
+ extend(&src.d[0],&buf,sizeof(DOUBLE)); /* no matter what */
+ compact(&buf,&(src.d[1]),sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT SINGLE TO DOUBLE (CFF 4 8)
+
+ This routine works quite simply. A floating point
+ of size 04 is converted to extended format.
+ This extended variable is converted back to
+ a floating point of size 08.
+
+*/
+
+#include "FP_types.h"
+
+void
+cff8(src)
+SINGLE src;
+{
+ EXTEND buf;
+
+ extend(&src,&buf,sizeof(SINGLE)); /* no matter what */
+ compact(&buf, &src,sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT FLOAT TO SIGNED (CFI m n)
+
+ N.B. The caller must know what it is getting.
+ A LONG is always returned. If it is an
+ integer the high byte is cleared first.
+*/
+
+#include "FP_trap.h"
+#include "FP_types.h"
+#include "FP_shift.h"
+
+long
+cfi(ds,ss,src)
+int ds; /* destination size (2 or 4) */
+int ss; /* source size (4 or 8) */
+DOUBLE src; /* assume worst case */
+{
+ EXTEND buf;
+ long new;
+ short max_exp;
+
+ extend(&src.d[0],&buf,ss); /* get extended format */
+ if (buf.exp < 0) { /* no conversion needed */
+ src.d[ss == 8] = 0L;
+ return(0L);
+ }
+ max_exp = (ds << 3) - 2; /* signed numbers */
+ /* have more limited max_exp */
+ if (buf.exp > max_exp) {
+ if (buf.exp == max_exp+1 && buf.sign && buf.m1 == NORMBIT &&
+ buf.m2 == 0L) {
+ }
+ else {
+ trap(EIOVFL); /* integer overflow */
+ buf.exp %= max_exp; /* truncate */
+ }
+ }
+ new = buf.m1 >> (31-buf.exp);
+ if (buf.sign)
+ new = -new;
+done:
+ src.d[ss == 8] = new;
+ return(new);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT FLOAT TO UNSIGNED (CFU m n)
+
+ N.B. The caller must know what it is getting.
+ A LONG is always returned. If it is an
+ integer the high byte is cleared first.
+*/
+
+#include "FP_trap.h"
+#include "FP_types.h"
+
+long
+cfu(ds,ss,src)
+int ds; /* destination size (2 or 4) */
+int ss; /* source size (4 or 8) */
+DOUBLE src; /* assume worst case */
+{
+ EXTEND buf;
+ long new;
+ short newint, max_exp;
+
+ extend(&src.d[0],&buf,ss); /* get extended format */
+ if (buf.exp < 0) { /* no conversion needed */
+ src.d[ss == 8] = 0L;
+ return(0L);
+ }
+ max_exp = (ds << 3) - 1;
+ if (buf.exp > max_exp) {
+ trap(EIOVFL); /* integer overflow */
+ buf.exp %= max_exp;
+ }
+ new = buf.m1 >> (31-buf.exp);
+done:
+ src.d[ss == 8] = new;
+ return(new);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT INTEGER TO SINGLE (CIF n 4)
+
+ THIS ROUTINE WORKS BY FILLING AN EXTENDED
+ WITH THE INTEGER VALUE IN EXTENDED FORMAT
+ AND USES COMPACT() TO PUT IT INTO THE PROPER
+ FLOATING POINT PRECISION.
+*/
+
+#include "FP_types.h"
+
+void
+cif4(ss,src)
+int ss; /* source size */
+long src; /* largest possible integer to convert */
+{
+ EXTEND buf;
+ short *ipt;
+ long i_src;
+ SINGLE *result;
+
+ zrf_ext(&buf);
+ if (ss == sizeof(long)) {
+ buf.exp = 31;
+ i_src = src;
+ result = (SINGLE *) &src;
+ }
+ else {
+ ipt = (short *) &src;
+ i_src = (long) *ipt;
+ buf.exp = 15;
+ result = (SINGLE *) &ss;
+ }
+ if (i_src == 0) {
+ *result = (SINGLE) 0L;
+ return;
+ }
+ /* ESTABLISHED THAT src != 0 */
+ /* adjust exponent field */
+ buf.sign = (i_src < 0) ? 0x8000 : 0;
+ /* clear sign bit of integer */
+ /* move to mantissa field */
+ buf.m1 = (i_src < 0) ? -i_src : i_src;
+ /* adjust mantissa field */
+ if (ss != sizeof(long))
+ buf.m1 <<= 16;
+ nrm_ext(&buf); /* adjust mantissa field */
+ compact(&buf, result,sizeof(SINGLE)); /* put on stack */
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT INTEGER TO FLOAT (CIF n 8)
+
+ THIS ROUTINE WORKS BY FILLING AN EXTENDED
+ WITH THE INTEGER VALUE IN EXTENDED FORMAT
+ AND USES COMPACT() TO PUT IT INTO THE PROPER
+ FLOATING POINT PRECISION.
+*/
+
+#include "FP_types.h"
+
+void
+cif8(ss,src)
+int ss; /* source size */
+long src; /* largest possible integer to convert */
+{
+ EXTEND buf;
+ DOUBLE *result; /* for return value */
+ short *ipt;
+ long i_src;
+
+ result = (DOUBLE *) ((void *) &ss); /* always */
+ zrf_ext(&buf);
+ if (ss == sizeof(long)) {
+ buf.exp = 31;
+ i_src = src;
+ }
+ else {
+ ipt = (short *) &src;
+ i_src = (long) *ipt;
+ buf.exp = 15;
+ }
+ if (i_src == 0) {
+ zrf8(result);
+ return;
+ }
+ /* ESTABLISHED THAT src != 0 */
+ /* adjust exponent field */
+ buf.sign = (i_src < 0) ? 0x8000 : 0;
+ /* clear sign bit of integer */
+ /* move to mantissa field */
+ buf.m1 = (i_src < 0) ? -i_src : i_src;
+ /* adjust mantissa field */
+ if (ss != sizeof(long))
+ buf.m1 <<= 16;
+ nrm_ext(&buf);
+ compact(&buf,&result->d[0],8);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ COMPARE SINGLES (CMF 4)
+*/
+
+#include "FP_types.h"
+#include "get_put.h"
+
+int
+cmf4(f1,f2)
+SINGLE f1,f2;
+{
+ /*
+ * return ((f1 < f2) ? 1 : (f1 - f2))
+ */
+#define SIGN(x) (((x) < 0) ? -1 : 1)
+ int sign1,sign2;
+ long l1,l2;
+
+ l1 = get4((char *) &f1);
+ l2 = get4((char *) &f2);
+
+ if (l1 == l2) return 0;
+
+ sign1 = SIGN(l1);
+ sign2 = SIGN(l2);
+ if (sign1 != sign2) {
+ if ((l1 & 0x7fffffff) == 0 &&
+ (l2 & 0x7fffffff) == 0) return 0;
+ return ((sign1 > 0) ? -1 : 1);
+ }
+
+ return (sign1 * ((l1 < l2) ? 1 : -1));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ COMPARE DOUBLES (CMF 8)
+*/
+
+#include "FP_types.h"
+#include "get_put.h"
+
+int
+cmf8(d1,d2)
+DOUBLE d1,d2;
+{
+#define SIGN(x) (((x) < 0) ? -1 : 1)
+ /*
+ * return ((d1 < d2) ? 1 : (d1 > d2) ? -1 : 0))
+ */
+ long l1,l2;
+ int sign1,sign2;
+ int rv;
+
+#if FL_MSL_AT_LOW_ADDRESS
+ l1 = get4((char *)&d1);
+ l2 = get4((char *)&d2);
+#else
+ l1 = get4(((char *)&d1+4));
+ l2 = get4(((char *)&d2+4));
+#endif
+ sign1 = SIGN(l1);
+ sign2 = SIGN(l2);
+ if (sign1 != sign2) {
+ l1 &= 0x7fffffff;
+ l2 &= 0x7fffffff;
+ if (l1 != 0 || l2 != 0) {
+ return ((sign1 > 0) ? -1 : 1);
+ }
+ }
+ if (l1 != l2) { /* we can decide here */
+ rv = l1 < l2 ? 1 : -1;
+ }
+ else { /* decide in 2nd half */
+ unsigned long u1, u2;
+#if FL_MSL_AT_LOW_ADDRESS
+ u1 = get4(((char *)&d1 + 4));
+ u2 = get4(((char *)&d2 + 4));
+#else
+ u1 = get4((char *)&d1);
+ u2 = get4((char *)&d2);
+#endif
+ if (u1 == u2)
+ return(0);
+ if (u1 < u2) rv = 1;
+ else rv = -1;
+ }
+ return sign1 * rv;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ COMPACT EXTEND FORMAT INTO FLOAT OF PROPER SIZE
+*/
+
+# include "FP_bias.h"
+# include "FP_shift.h"
+# include "FP_trap.h"
+# include "FP_types.h"
+# include "get_put.h"
+
+void
+compact(f,to,size)
+EXTEND *f;
+unsigned long *to;
+int size;
+{
+ int error = 0;
+
+ if (size == sizeof(DOUBLE)) {
+ /*
+ * COMPACT EXTENDED INTO DOUBLE
+ */
+ DOUBLE *DBL = (DOUBLE *) (void *) to;
+
+ if ((f->m1|(f->m2 & DBL_ZERO)) == 0L) {
+ zrf8(DBL);
+ return;
+ }
+ f->exp += DBL_BIAS; /* restore proper bias */
+ if (f->exp > DBL_MAX) {
+dbl_over: trap(EFOVFL);
+ f->exp = DBL_MAX+1;
+ f->m1 = 0;
+ f->m2 = 0;
+ if (error++)
+ return;
+ }
+ else if (f->exp < DBL_MIN) {
+ b64_rsft(&(f->mantissa));
+ if (f->exp < 0) {
+ b64_sft(&(f->mantissa), -f->exp);
+ f->exp = 0;
+ }
+ /* underflow ??? */
+ }
+
+ /* local CAST conversion */
+
+ /* because of special format shift only 10 bits */
+ /* bit shift mantissa 10 bits */
+
+ /* first align within words, then do store operation */
+
+ DBL->d[0] = f->m1 >> DBL_RUNPACK; /* plus 22 == 32 */
+ DBL->d[1] = f->m2 >> DBL_RUNPACK; /* plus 22 == 32 */
+ DBL->d[1] |= (f->m1 << DBL_LUNPACK); /* plus 10 == 32 */
+
+ /* if not exact then round to nearest */
+ /* on a tie, round to even */
+
+#ifdef EXCEPTION_INEXACT
+ if ((f->m2 & DBL_EXACT) != 0) {
+ INEXACT();
+#endif
+ if (((f->m2 & DBL_EXACT) > DBL_ROUNDUP)
+ || ((f->m2 & DBL_EXACT) == DBL_ROUNDUP
+ && (f->m2 & (DBL_ROUNDUP << 1)))) {
+ DBL->d[1]++; /* rounding up */
+ if (DBL->d[1] == 0L) { /* carry out */
+ DBL->d[0]++;
+
+ if (f->exp == 0 && (DBL->d[0] & ~DBL_MASK)) {
+ f->exp++;
+ }
+ if (DBL->d[0] & DBL_CARRYOUT) { /* carry out */
+ if (DBL->d[0] & 01)
+ DBL->d[1] = CARRYBIT;
+ DBL->d[0] >>= 1;
+ f->exp++;
+ }
+ }
+ /* check for overflow */
+ if (f->exp > DBL_MAX)
+ goto dbl_over;
+ }
+#ifdef EXCEPTION_INEXACT
+ }
+#endif
+
+ /*
+ * STORE EXPONENT AND SIGN:
+ *
+ * 1) clear leading bits (B4-B15)
+ * 2) shift and store exponent
+ */
+
+ DBL->d[0] &= DBL_MASK;
+ DBL->d[0] |=
+ ((long) (f->exp << DBL_EXPSHIFT) << EXP_STORE);
+ if (f->sign)
+ DBL->d[0] |= CARRYBIT;
+
+ /*
+ * STORE MANTISSA
+ */
+
+#if FL_MSL_AT_LOW_ADDRESS
+ put4(DBL->d[0], (char *) &DBL->d[0]);
+ put4(DBL->d[1], (char *) &DBL->d[1]);
+#else
+ { unsigned long l;
+ put4(DBL->d[1], (char *) &l);
+ put4(DBL->d[0], (char *) &DBL->d[1]);
+ DBL->d[0] = l;
+ }
+#endif
+ }
+ else {
+ /*
+ * COMPACT EXTENDED INTO FLOAT
+ */
+ SINGLE *SGL;
+
+ /* local CAST conversion */
+ SGL = (SINGLE *) (void *) to;
+ if ((f->m1 & SGL_ZERO) == 0L) {
+ *SGL = 0L;
+ return;
+ }
+ f->exp += SGL_BIAS; /* restore bias */
+ if (f->exp > SGL_MAX) {
+sgl_over: trap(EFOVFL);
+ f->exp = SGL_MAX+1;
+ f->m1 = 0L;
+ f->m2 = 0L;
+ if (error++)
+ return;
+ }
+ else if (f->exp < SGL_MIN) {
+ b64_rsft(&(f->mantissa));
+ if (f->exp < 0) {
+ b64_sft(&(f->mantissa), -f->exp);
+ f->exp = 0;
+ }
+ /* underflow ??? */
+ }
+
+ /* shift mantissa and store */
+ *SGL = (f->m1 >> SGL_RUNPACK);
+
+ /* check for rounding to nearest */
+ /* on a tie, round to even */
+#ifdef EXCEPTION_INEXACT
+ if (f->m2 != 0 ||
+ (f->m1 & SGL_EXACT) != 0L) {
+ INEXACT();
+#endif
+ if (((f->m1 & SGL_EXACT) > SGL_ROUNDUP)
+ || ((f->m1 & SGL_EXACT) == SGL_ROUNDUP
+ && (f->m1 & (SGL_ROUNDUP << 1)))) {
+ (*SGL)++;
+ if (f->exp == 0 && (*SGL & ~SGL_MASK)) {
+ f->exp++;
+ }
+ /* check normal */
+ if (*SGL & SGL_CARRYOUT) {
+ *SGL >>= 1;
+ f->exp++;
+ }
+ if (f->exp > SGL_MAX)
+ goto sgl_over;
+ }
+#ifdef EXCEPTION_INEXACT
+ }
+#endif
+
+ /*
+ * STORE EXPONENT AND SIGN:
+ *
+ * 1) clear leading bit of fraction
+ * 2) shift and store exponent
+ */
+
+ *SGL &= SGL_MASK; /* B23-B31 are 0 */
+ *SGL |= ((long) (f->exp << SGL_EXPSHIFT) << EXP_STORE);
+ if (f->sign)
+ *SGL |= CARRYBIT;
+
+ /*
+ * STORE MANTISSA
+ */
+
+ put4(*SGL, (char *) &SGL);
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT INTEGER TO SINGLE (CUF n 4)
+
+ THIS ROUTINE WORKS BY FILLING AN EXTENDED
+ WITH THE INTEGER VALUE IN EXTENDED FORMAT
+ AND USES COMPACT() TO PUT IT INTO THE PROPER
+ FLOATING POINT PRECISION.
+*/
+
+#include "FP_types.h"
+
+void
+cuf4(ss,src)
+int ss; /* source size */
+long src; /* largest possible integer to convert */
+{
+ EXTEND buf;
+ short *ipt;
+ SINGLE *result;
+ long i_src;
+
+ zrf_ext(&buf);
+ if (ss == sizeof(long)) {
+ buf.exp = 31;
+ i_src = src;
+ result = (SINGLE *) &src;
+ }
+ else {
+ ipt = (short *) &src;
+ i_src = (long) *ipt;
+ buf.exp = 15;
+ result = (SINGLE *) ((void *) &ss);
+ }
+ if (i_src == 0) {
+ *result = (SINGLE) 0L;
+ return;
+ }
+ /* ESTABLISHED THAT src != 0 */
+
+ /* adjust exponent field */
+ if (ss != sizeof(long))
+ i_src <<= 16;
+
+ /* move to mantissa field */
+ buf.m1 = i_src;
+
+ /* adjust mantissa field */
+ nrm_ext(&buf);
+ compact(&buf,result,4);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT INTEGER TO FLOAT (CUF n 8)
+
+ THIS ROUTINE WORKS BY FILLING AN EXTENDED
+ WITH THE INTEGER VALUE IN EXTENDED FORMAT
+ AND USES COMPACT() TO PUT IT INTO THE PROPER
+ FLOATING POINT PRECISION.
+*/
+
+#include "FP_types.h"
+
+void
+cuf8(ss,src)
+int ss; /* source size */
+long src; /* largest possible integer to convert */
+{
+ EXTEND buf;
+ short *ipt;
+ long i_src;
+
+ zrf_ext(&buf);
+ if (ss == sizeof(long)) {
+ buf.exp = 31;
+ i_src = src;
+ }
+ else {
+ ipt = (short *) &src;
+ i_src = (long) *ipt;
+ buf.exp = 15;
+ }
+ if (i_src == 0) {
+ zrf8((DOUBLE *)((void *)&ss));
+ return;
+ }
+ /* ESTABLISHED THAT src != 0 */
+
+ /* adjust exponent field */
+ if (ss != sizeof(long))
+ i_src <<= 16;
+
+ /* move to mantissa field */
+ buf.m1 = i_src;
+
+ /* adjust mantissa field */
+ nrm_ext(&buf);
+ compact(&buf,(unsigned long *) (void *)&ss,8);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ DIVIDE EXTENDED FORMAT
+*/
+
+#include "FP_bias.h"
+#include "FP_trap.h"
+#include "FP_types.h"
+
+/*
+ November 15, 1984
+
+ This is a routine to do the work.
+ There are two versions:
+ One is based on the partial products method
+ and makes no use possible machine instructions
+ to divide (hardware dividers).
+ The other is used when USE_DIVIDE is defined. It is much faster on
+ machines with fast 4 byte operations.
+*/
+/********************************************************/
+
+void
+div_ext(e1,e2)
+EXTEND *e1,*e2;
+{
+ short error = 0;
+ B64 result;
+ register unsigned long *lp;
+#ifndef USE_DIVIDE
+ short count;
+#else
+ unsigned short u[9], v[5];
+ register int j;
+ register unsigned short *u_p = u;
+ int maxv = 4;
+#endif
+
+ if ((e2->m1 | e2->m2) == 0) {
+ /*
+ * Exception 8.2 - Divide by zero
+ */
+ trap(EFDIVZ);
+ e1->m1 = e1->m2 = 0L;
+ e1->exp = EXT_MAX;
+ return;
+ }
+ if ((e1->m1 | e1->m2) == 0) { /* 0 / anything == 0 */
+ e1->exp = 0; /* make sure */
+ return;
+ }
+#ifndef USE_DIVIDE
+ /*
+ * numbers are right shifted one bit to make sure
+ * that m1 is quaranteed to be larger if its
+ * maximum bit is set
+ */
+ b64_rsft(&e1->mantissa); /* 64 bit shift right */
+ b64_rsft(&e2->mantissa); /* 64 bit shift right */
+ e1->exp++;
+ e2->exp++;
+#endif
+ /* check for underflow, divide by zero, etc */
+ e1->sign ^= e2->sign;
+ e1->exp -= e2->exp;
+
+#ifndef USE_DIVIDE
+ /* do division of mantissas */
+ /* uses partial product method */
+ /* init control variables */
+
+ count = 64;
+ result.h_32 = 0L;
+ result.l_32 = 0L;
+
+ /* partial product division loop */
+
+ while (count--) {
+ /* first left shift result 1 bit */
+ /* this is ALWAYS done */
+
+ b64_lsft(&result);
+
+ /* compare dividend and divisor */
+ /* if dividend >= divisor add a bit */
+ /* and subtract divisior from dividend */
+
+ if ( (e1->m1 < e2->m1) ||
+ ((e1->m1 == e2->m1) && (e1->m2 < e2->m2) ))
+ ; /* null statement */
+ /* i.e., don't add or subtract */
+ else {
+ result.l_32++; /* ADD */
+ if (e2->m2 > e1->m2)
+ e1->m1 -= 1; /* carry in */
+ e1->m1 -= e2->m1; /* do SUBTRACTION */
+ e1->m2 -= e2->m2; /* SUBTRACTION */
+ }
+
+ /* shift dividend left one bit OR */
+ /* IF it equals ZERO we can break out */
+ /* of the loop, but still must shift */
+ /* the quotient the remaining count bits */
+ /* NB save the results of this test in error */
+ /* if not zero, then the result is inexact. */
+ /* this would be reported in IEEE standard */
+
+ /* lp points to dividend */
+ lp = &e1->m1;
+
+ error = ((*lp | *(lp+1)) != 0L) ? 1 : 0;
+ if (error) { /* more work */
+ /* assume max bit == 0 (see above) */
+ b64_lsft(&e1->mantissa);
+ continue;
+ }
+ else
+ break; /* leave loop */
+ } /* end of divide by subtraction loop */
+
+ if (count > 0) {
+ lp = &result.h_32;
+ if (count > 31) { /* move to higher word */
+ *lp = *(lp+1);
+ count -= 32;
+ *(lp+1) = 0L; /* clear low word */
+ }
+ if (*lp)
+ *lp <<= count; /* shift rest of way */
+ lp++; /* == &result.l_32 */
+ if (*lp) {
+ result.h_32 |= (*lp >> 32-count);
+ *lp <<= count;
+ }
+ }
+#else /* USE_DIVIDE */
+
+ u[4] = (e1->m2 & 1) << 15;
+ b64_rsft(&(e1->mantissa));
+ u[0] = e1->m1 >> 16;
+ u[1] = e1->m1;
+ u[2] = e1->m2 >> 16;
+ u[3] = e1->m2;
+ u[5] = 0; u[6] = 0; u[7] = 0;
+ v[1] = e2->m1 >> 16;
+ v[2] = e2->m1;
+ v[3] = e2->m2 >> 16;
+ v[4] = e2->m2;
+ while (! v[maxv]) maxv--;
+ result.h_32 = 0;
+ result.l_32 = 0;
+ lp = &result.h_32;
+
+ /*
+ * Use an algorithm of Knuth (The art of programming, Seminumerical
+ * algorithms), to divide u by v. u and v are both seen as numbers
+ * with base 65536.
+ */
+ for (j = 0; j <= 3; j++, u_p++) {
+ unsigned long q_est, temp;
+
+ if (j == 2) lp++;
+ if (u_p[0] == 0 && u_p[1] < v[1]) continue;
+ temp = ((unsigned long)u_p[0] << 16) + u_p[1];
+ if (u_p[0] >= v[1]) {
+ q_est = 0x0000FFFFL;
+ }
+ else {
+ q_est = temp / v[1];
+ }
+ temp -= q_est * v[1];
+ while (temp < 0x10000 && v[2]*q_est > ((temp<<16)+u_p[2])) {
+ q_est--;
+ temp += v[1];
+ }
+ /* Now, according to Knuth, we have an estimate of the
+ quotient, that is either correct or one too big, but
+ almost always correct.
+ */
+ if (q_est != 0) {
+ int i;
+ unsigned long k = 0;
+ int borrow = 0;
+
+ for (i = maxv; i > 0; i--) {
+ unsigned long tmp = q_est * v[i] + k + borrow;
+ unsigned short md = tmp;
+
+ borrow = (md > u_p[i]);
+ u_p[i] -= md;
+ k = tmp >> 16;
+ }
+ k += borrow;
+ borrow = u_p[0] < k;
+ u_p[0] -= k;
+
+ if (borrow) {
+ /* So, this does not happen often; the estimate
+ was one too big; correct this
+ */
+ *lp |= (j & 1) ? (q_est - 1) : ((q_est-1)<<16);
+ borrow = 0;
+ for (i = maxv; i > 0; i--) {
+ unsigned long tmp
+ = v[i]+(unsigned long)u_p[i]+borrow;
+
+ u_p[i] = tmp;
+ borrow = tmp >> 16;
+ }
+ u_p[0] += borrow;
+ }
+ else *lp |= (j & 1) ? q_est : (q_est<<16);
+ }
+ }
+#ifdef EXCEPTION_INEXACT
+ u_p = &u[0];
+ for (j = 7; j >= 0; j--) {
+ if (*u_p++) {
+ error = 1;
+ break;
+ }
+ }
+#endif
+#endif
+
+#ifdef EXCEPTION_INEXACT
+ if (error) {
+ /*
+ * report here exception 8.5 - Inexact
+ * from Draft 8.0 of IEEE P754:
+ * In the absence of an invalid operation exception,
+ * if the rounded result of an operation is not exact or if
+ * it overflows without a trap, then the inexact exception
+ * shall be assigned. The rounded or overflowed result
+ * shall be delivered to the destination.
+ */
+ INEXACT();
+#endif
+ e1->mantissa = result;
+
+ nrm_ext(e1);
+ if (e1->exp < EXT_MIN) {
+ /*
+ * Exception 8.4 - Underflow
+ */
+ trap(EFUNFL); /* underflow */
+ e1->exp = EXT_MIN;
+ e1->m1 = e1->m2 = 0L;
+ return;
+ }
+ if (e1->exp >= EXT_MAX) {
+ /*
+ * Exception 8.3 - Overflow
+ */
+ trap(EFOVFL); /* overflow */
+ e1->exp = EXT_MAX;
+ e1->m1 = e1->m2 = 0L;
+ return;
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ DIVIDE TWO SINGLES - SINGLE Precision (dvf 4)
+*/
+
+#include "FP_types.h"
+
+void
+dvf4(s2,s1)
+SINGLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ extend(&s1,&e1,sizeof(SINGLE));
+ extend(&s2,&e2,sizeof(SINGLE));
+
+ /* do a divide */
+ div_ext(&e1,&e2);
+ compact(&e1,&s1,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ DIVIDE TWO FLOATS - DOUBLE Precision (DVF 8)
+*/
+
+#include "FP_types.h"
+
+void
+dvf8(s2,s1)
+DOUBLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ extend(&s1.d[0],&e1,sizeof(DOUBLE));
+ extend(&s2.d[0],&e2,sizeof(DOUBLE));
+
+ /* do a divide */
+ div_ext(&e1,&e2);
+ compact(&e1,&s1.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERTS FLOATING POINT TO EXTENDED FORMAT
+
+ Two sizes of FLOATING Point are known:
+ SINGLE and DOUBLE
+*/
+/********************************************************/
+/*
+ It is not required to normalize in extended
+ format, but it has been chosen to do so.
+ Extended Format is as follows (at exit):
+
+->sign S000 0000 | 0000 0000 <SIGN>
+->exp 0EEE EEEE | EEEE EEEE <EXPONENT>
+->m1 LFFF FFFF | FFFF FFFF <L.Fraction>
+ FFFF FFFF | FFFF FFFF <Fraction>
+->m2 FFFF FFFF | FFFF FFFF <Fraction>
+ FFFF F000 | 0000 0000 <Fraction>
+*/
+/********************************************************/
+
+#include "FP_bias.h"
+#include "FP_shift.h"
+#include "FP_types.h"
+#include "get_put.h"
+/********************************************************/
+
+void
+extend(from,to,size)
+unsigned long *from;
+EXTEND *to;
+int size;
+{
+ register char *cpt1;
+ unsigned long tmp;
+ int leadbit = 0;
+
+ cpt1 = (char *) from;
+
+#if FL_MSL_AT_LOW_ADDRESS
+#if FL_MSW_AT_LOW_ADDRESS
+ to->exp = uget2(cpt1);
+#else
+ to->exp = uget2(cpt1+2);
+#endif
+#else
+#if FL_MSW_AT_LOW_ADDRESS
+ to->exp = uget2(cpt1+(size == sizeof(DOUBLE) ? 4 : 0));
+#else
+ to->exp = uget2(cpt1+(size == sizeof(DOUBLE) ? 6 : 2));
+#endif
+#endif
+ to->sign = (to->exp & 0x8000); /* set sign bit */
+ to->exp ^= to->sign;
+ if (size == sizeof(DOUBLE))
+ to->exp >>= DBL_EXPSHIFT;
+ else
+ to->exp >>= SGL_EXPSHIFT;
+ if (to->exp > 0)
+ leadbit++; /* will set Lead bit later */
+ else to->exp++;
+
+ if (size == sizeof(DOUBLE)) {
+#if FL_MSL_AT_LOW_ADDRESS
+ to->m1 = get4(cpt1);
+ cpt1 += 4;
+ tmp = get4(cpt1);
+#else
+ tmp = get4(cpt1);
+ cpt1 += 4;
+ to->m1 = get4(cpt1);
+#endif
+ if (to->exp == 1 && to->m1 == 0 && tmp == 0) {
+ to->exp = 0;
+ to->sign = 0;
+ to->m1 = 0;
+ to->m2 = 0;
+ return;
+ }
+ to->m1 <<= DBL_M1LEFT; /* shift */
+ to->exp -= DBL_BIAS; /* remove bias */
+ to->m1 |= (tmp>>DBL_RPACK); /* plus 10 == 32 */
+ to->m2 = (tmp<<DBL_LPACK); /* plus 22 == 32 */
+ }
+ else { /* size == sizeof(SINGLE) */
+ to->m1 = get4(cpt1);
+ to->m1 <<= SGL_M1LEFT; /* shift */
+ if (to->exp == 1 && to->m1 == 0) {
+ to->exp = 0;
+ to->sign = 0;
+ to->m1 = 0;
+ to->m2 = 0;
+ return;
+ }
+ to->exp -= SGL_BIAS; /* remove bias */
+ to->m2 = 0L;
+ }
+
+ to->m1 |= NORMBIT; /* set bit L */
+ if (leadbit == 0) { /* set or clear Leading Bit */
+ to->m1 &= ~NORMBIT; /* clear bit L */
+ nrm_ext(to); /* and normalize */
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SEPERATE INTO EXPONENT AND FRACTION (FEF 4)
+*/
+
+#include "FP_types.h"
+
+void
+fef4(r,s1)
+SINGLE s1;
+struct fef4_returns *r;
+{
+ EXTEND buf;
+ register struct fef4_returns *p = r; /* make copy; r might refer
+ to itself (see table)
+ */
+
+ extend(&s1,&buf,sizeof(SINGLE));
+ if (buf.exp == 0 && buf.m1 == 0 && buf.m2 == 0) {
+ p->e = 0;
+ }
+ else {
+ p->e = buf.exp+1;
+ buf.exp = -1;
+ }
+ compact(&buf,&p->f,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SEPERATE DOUBLE INTO EXPONENT AND FRACTION (FEF 8)
+*/
+
+#include "FP_types.h"
+
+void
+fef8(r, s1)
+DOUBLE s1;
+struct fef8_returns *r;
+{
+ EXTEND buf;
+ register struct fef8_returns *p = r; /* make copy, r might refer
+ to itself (see table)
+ */
+
+ extend(&s1.d[0],&buf,sizeof(DOUBLE));
+ if (buf.exp == 0 && buf.m1 == 0 && buf.m2 == 0) {
+ p->e = 0;
+ }
+ else {
+ p->e = buf.exp + 1;
+ buf.exp = -1;
+ }
+ compact(&buf,&p->f.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ MULTIPLY AND DISMEMBER PARTS (FIF 4)
+*/
+
+#include "FP_types.h"
+#include "FP_shift.h"
+
+void
+fif4(p,x,y)
+SINGLE x,y;
+struct fif4_returns *p;
+{
+
+ EXTEND e1,e2;
+
+ extend(&y,&e1,sizeof(SINGLE));
+ extend(&x,&e2,sizeof(SINGLE));
+ /* do a multiply */
+ mul_ext(&e1,&e2);
+ e2 = e1;
+ compact(&e2,&y,sizeof(SINGLE));
+ if (e1.exp < 0) {
+ p->ipart = 0;
+ p->fpart = y;
+ return;
+ }
+ if (e1.exp > 30 - SGL_M1LEFT) {
+ p->ipart = y;
+ p->fpart = 0;
+ return;
+ }
+ b64_sft(&e1.mantissa, 63 - e1.exp);
+ b64_sft(&e1.mantissa, e1.exp - 63); /* "loose" low order bits */
+ compact(&e1,&(p->ipart),sizeof(SINGLE));
+ extend(&(p->ipart), &e2, sizeof(SINGLE));
+ extend(&y, &e1, sizeof(SINGLE));
+ sub_ext(&e1, &e2);
+ compact(&e1, &(p->fpart), sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ MULTIPLY AND DISMEMBER PARTS (FIF 8)
+*/
+
+#include "FP_types.h"
+#include "FP_shift.h"
+
+void
+fif8(p,x,y)
+DOUBLE x,y;
+struct fif8_returns *p;
+{
+
+ EXTEND e1,e2;
+
+ extend(&y.d[0],&e1,sizeof(DOUBLE));
+ extend(&x.d[0],&e2,sizeof(DOUBLE));
+ /* do a multiply */
+ mul_ext(&e1,&e2);
+ e2 = e1;
+ compact(&e2, &y.d[0], sizeof(DOUBLE));
+ if (e1.exp < 0) {
+ p->ipart.d[0] = 0;
+ p->ipart.d[1] = 0;
+ p->fpart = y;
+ return;
+ }
+ if (e1.exp > 62 - DBL_M1LEFT) {
+ p->ipart = y;
+ p->fpart.d[0] = 0;
+ p->fpart.d[1] = 0;
+ return;
+ }
+ b64_sft(&e1.mantissa, 63 - e1.exp);
+ b64_sft(&e1.mantissa, e1.exp - 63); /* "loose" low order bits */
+ compact(&e1, &(p->ipart.d[0]), sizeof(DOUBLE));
+ extend(&(p->ipart.d[0]), &e2, sizeof(DOUBLE));
+ extend(&y.d[0], &e1, sizeof(DOUBLE));
+ sub_ext(&e1, &e2);
+ compact(&e1, &(p->fpart.d[0]), sizeof(DOUBLE));
+}
--- /dev/null
+#
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define __fptrp
+.sect .text
+__fptrp:
+#if __i386
+ push ebp
+ mov ebp, esp
+ mov eax, 8(bp)
+ call .Xtrp
+ leave
+ ret
+#else /* i86 */
+ push bp
+ mov bp, sp
+ mov ax, 4(bp)
+ call .Xtrp
+ jmp .cret
+#endif
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+#include <byte_order.h>
+
+#if CHAR_UNSIGNED
+#define Xchar(ch) (ch)
+#else
+#define Xchar(ch) ((ch) & 0377)
+#endif
+
+#define BYTES_REVERSED (MSB_AT_LOW_ADDRESS != FL_MSB_AT_LOW_ADDRESS)
+#define WORDS_REVERSED (MSW_AT_LOW_ADDRESS != FL_MSW_AT_LOW_ADDRESS)
+#define LONGS_REVERSED (FL_MSL_AT_LOW_ADDRESS)
+
+#if BYTES_REVERSED
+#define uget2(c) (Xchar((c)[1]) | ((unsigned) Xchar((c)[0]) << 8))
+#define Xput2(i, c) (((c)[1] = (i)), ((c)[0] = (i) >> 8))
+#define put2(i, c) { register int j = (i); Xput2(j, c); }
+#else
+#define uget2(c) (* ((unsigned short *) (c)))
+#define Xput2(i, c) (* ((short *) (c)) = (i))
+#define put2(i, c) Xput2(i, c)
+#endif
+
+#define get2(c) ((short) uget2(c))
+
+#if WORDS_REVERSED || BYTES_REVERSED
+#define get4(c) (uget2((c)+2) | ((long) uget2(c) << 16))
+#define put4(l, c) { register long x=(l); \
+ Xput2((int)x,(c)+2); \
+ Xput2((int)(x>>16),(c)); \
+ }
+#else
+#define get4(c) (* ((long *) (c)))
+#define put4(l, c) (* ((long *) (c)) = (l))
+#endif
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ * Multiply Single Precesion Float (MLF 4)
+ */
+
+#include "FP_types.h"
+
+void
+mlf4(s2,s1)
+SINGLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ extend(&s1,&e1,sizeof(SINGLE));
+ extend(&s2,&e2,sizeof(SINGLE));
+ /* do a multiply */
+ mul_ext(&e1,&e2);
+ compact(&e1,&s1,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ * Multiply Double Precision Float (MLF 8)
+ */
+
+#include "FP_types.h"
+
+void
+mlf8(s2,s1)
+DOUBLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ extend(&s1.d[0],&e1,sizeof(DOUBLE));
+ extend(&s2.d[0],&e2,sizeof(DOUBLE));
+ /* do a multiply */
+ mul_ext(&e1,&e2);
+ compact(&e1,&s1.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ROUTINE TO MULTIPLY TWO EXTENDED FORMAT NUMBERS
+*/
+
+# include "FP_bias.h"
+# include "FP_trap.h"
+# include "FP_types.h"
+# include "FP_shift.h"
+
+void
+mul_ext(e1,e2)
+EXTEND *e1,*e2;
+{
+ register int i,j; /* loop control */
+ unsigned short mp[4]; /* multiplier */
+ unsigned short mc[4]; /* multipcand */
+ unsigned short result[8]; /* result */
+ register unsigned short *pres;
+
+ /* first save the sign (XOR) */
+ e1->sign ^= e2->sign;
+
+ /* compute new exponent */
+ e1->exp += e2->exp + 1;
+ /* 128 bit multiply of mantissas */
+
+ /* assign unknown long formats */
+ /* to known unsigned word formats */
+ mp[0] = e1->m1 >> 16;
+ mp[1] = (unsigned short) e1->m1;
+ mp[2] = e1->m2 >> 16;
+ mp[3] = (unsigned short) e1->m2;
+ mc[0] = e2->m1 >> 16;
+ mc[1] = (unsigned short) e2->m1;
+ mc[2] = e2->m2 >> 16;
+ mc[3] = (unsigned short) e2->m2;
+ for (i = 8; i--;) {
+ result[i] = 0;
+ }
+ /*
+ * fill registers with their components
+ */
+ for(i=4, pres = &result[4];i--;pres--) if (mp[i]) {
+ unsigned short k = 0;
+ unsigned long mpi = mp[i];
+ for(j=4;j--;) {
+ unsigned long tmp = (unsigned long)pres[j] + k;
+ if (mc[j]) tmp += mpi * mc[j];
+ pres[j] = tmp;
+ k = tmp >> 16;
+ }
+ pres[-1] = k;
+ }
+ if (! (result[0] & 0x8000)) {
+ e1->exp--;
+ for (i = 0; i <= 3; i++) {
+ result[i] <<= 1;
+ if (result[i+1]&0x8000) result[i] |= 1;
+ }
+ result[4] <<= 1;
+ }
+
+ /*
+ * combine the registers to a total
+ */
+ e1->m1 = ((unsigned long)(result[0]) << 16) + result[1];
+ e1->m2 = ((unsigned long)(result[2]) << 16) + result[3];
+ if (result[4] & 0x8000) {
+ if (++e1->m2 == 0)
+ if (++e1->m1 == 0) {
+ e1->m1 = NORMBIT;
+ e1->exp++;
+ }
+ }
+
+ /* check for overflow */
+ if (e1->exp >= EXT_MAX) {
+ trap(EFOVFL);
+ /* if caught */
+ /* return signed infinity */
+ e1->exp = EXT_MAX;
+infinity: e1->m1 = e1->m2 =0L;
+ return;
+ }
+ /* check for underflow */
+ if (e1->exp < EXT_MIN) {
+ trap(EFUNFL);
+ e1->exp = EXT_MIN;
+ goto infinity;
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ NEGATE A FLOATING POINT (NGF 4)
+*/
+/********************************************************/
+
+#include "FP_types.h"
+#include "get_put.h"
+
+#define OFF ((FL_MSW_AT_LOW_ADDRESS ? 0 : 2) + (FL_MSB_AT_LOW_ADDRESS ? 0 : 1))
+void
+ngf4(f)
+SINGLE f;
+{
+ unsigned char *p;
+
+ if (f != (SINGLE) 0) {
+ p = (unsigned char *) &f + OFF;
+ *p ^= 0x80;
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ NEGATE A FLOATING POINT (NGF 8)
+*/
+/********************************************************/
+
+#include "FP_types.h"
+#include "get_put.h"
+
+#define OFF ((FL_MSL_AT_LOW_ADDRESS ? 0 : 4) + (FL_MSW_AT_LOW_ADDRESS ? 0 : 2) + (FL_MSB_AT_LOW_ADDRESS ? 0 : 1))
+
+void
+ngf8(f)
+DOUBLE f;
+{
+ unsigned char *p;
+
+ if (f.d[0] != 0 || f.d[1] != 0) {
+ p = (unsigned char *) &f + OFF;
+ *p ^= 0x80;
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/********************************************************/
+/*
+ NORMALIZE an EXTENDED FORMAT NUMBER
+*/
+/********************************************************/
+
+#include "FP_shift.h"
+#include "FP_types.h"
+
+void
+nrm_ext(e1)
+EXTEND *e1;
+{
+ /* we assume that the mantissa != 0 */
+ /* if it is then just return */
+ /* to let it be a problem elsewhere */
+ /* THAT IS, The exponent is not set to */
+ /* zero. If we don't test here an */
+ /* infinite loop is generated when */
+ /* mantissa is zero */
+
+ if ((e1->m1 | e1->m2) == 0L)
+ return;
+
+ /* if top word is zero mov low word */
+ /* to top word, adjust exponent value */
+ if (e1->m1 == 0L) {
+ e1->m1 = e1->m2;
+ e1->m2 = 0L;
+ e1->exp -= 32;
+ }
+ if ((e1->m1 & NORMBIT) == 0) {
+ unsigned long l = ((unsigned long)NORMBIT >> 1);
+ int cnt = -1;
+
+ while (! (l & e1->m1)) {
+ l >>= 1;
+ cnt--;
+ }
+ e1->exp += cnt;
+ b64_sft(&(e1->mantissa), cnt);
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SUBTRACT TWO FLOATS - SINGLE Precision (SBF 4)
+*/
+
+#include "FP_types.h"
+
+void
+sbf4(s2,s1)
+SINGLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ if (s2 == (SINGLE) 0) {
+ return;
+ }
+ extend(&s1,&e1,sizeof(SINGLE));
+ extend(&s2,&e2,sizeof(SINGLE));
+ sub_ext(&e1,&e2);
+ compact(&e1,&s1,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SUBTRACT TWO FLOATS - DOUBLE Precision (SBF 8)
+*/
+
+#include "FP_types.h"
+
+void
+sbf8(s2,s1)
+DOUBLE s1,s2;
+{
+ EXTEND e1, e2;
+
+ if (s2.d[0] == 0 && s2.d[1] == 0) {
+ return;
+ }
+ extend(&s1.d[0],&e1,sizeof(DOUBLE));
+ extend(&s2.d[0],&e2,sizeof(DOUBLE));
+ sub_ext(&e1,&e2);
+ compact(&e1,&s1.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SHIFT TWO EXTENDED NUMBERS INTO PROPER
+ ALIGNMENT FOR ADDITION (exponents are equal)
+ Numbers should not be zero on entry.
+*/
+
+#include "FP_types.h"
+
+void
+sft_ext(e1,e2)
+EXTEND *e1,*e2;
+{
+ register EXTEND *s;
+ register int diff;
+
+ diff = e1->exp - e2->exp;
+
+ if (!diff)
+ return; /* exponents are equal */
+
+ if (diff < 0) { /* e2 is larger */
+ /* shift e1 */
+ diff = -diff;
+ s = e1;
+ }
+ else /* e1 is larger */
+ /* shift e2 */
+ s = e2;
+
+ s->exp += diff;
+ b64_sft(&(s->mantissa), diff);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+# include "FP_types.h"
+
+void
+b64_sft(e1,n)
+B64 *e1;
+int n;
+{
+ if (n > 0) {
+ if (n > 63) {
+ e1->l_32 = 0;
+ e1->h_32 = 0;
+ return;
+ }
+ if (n >= 32) {
+ e1->l_32 = e1->h_32;
+ e1->h_32 = 0;
+ n -= 32;
+ }
+ if (n > 0) {
+ e1->l_32 >>= n;
+ if (e1->h_32 != 0) {
+ e1->l_32 |= (e1->h_32 << (32 - n));
+ e1->h_32 >>= n;
+ }
+ }
+ return;
+ }
+ n = -n;
+ if (n > 0) {
+ if (n > 63) {
+ e1->l_32 = 0;
+ e1->h_32 = 0;
+ return;
+ }
+ if (n >= 32) {
+ e1->h_32 = e1->l_32;
+ e1->l_32 = 0;
+ n -= 32;
+ }
+ if (n > 0) {
+ e1->h_32 <<= n;
+ if (e1->l_32 != 0) {
+ e1->h_32 |= (e1->l_32 >> (32 - n));
+ e1->l_32 <<= n;
+ }
+ }
+ }
+}
+
+void
+b64_lsft(e1)
+B64 *e1;
+{
+ /* shift left 1 bit */
+ e1->h_32 <<= 1;
+ if (e1->l_32 & 0x80000000L) e1->h_32 |= 1;
+ e1->l_32 <<= 1;
+}
+
+void
+b64_rsft(e1)
+B64 *e1;
+{
+ /* shift right 1 bit */
+ e1->l_32 >>= 1;
+ if (e1->h_32 & 1) e1->l_32 |= 0x80000000L;
+ e1->h_32 >>= 1;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SUBTRACT 2 EXTENDED FORMAT NUMBERS
+*/
+
+#include "FP_types.h"
+
+void
+sub_ext(e1,e2)
+EXTEND *e1,*e2;
+{
+ if ((e2->m1 | e2->m2) == 0L) {
+ return;
+ }
+ if ((e1->m1 | e1->m2) == 0L) {
+ *e1 = *e2;
+ e1->sign = e2->sign ? 0 : 1;
+ return;
+ }
+ sft_ext(e1, e2);
+ if (e1->sign != e2->sign) {
+ /* e1 - e2 = e1 + (-e2) */
+ if (b64_add(&e1->mantissa,&e2->mantissa)) { /* addition carry */
+ b64_rsft(&e1->mantissa); /* shift mantissa one bit RIGHT */
+ e1->m1 |= 0x80000000L; /* set max bit */
+ e1->exp++; /* increase the exponent */
+ }
+ }
+ else if (e2->m1 > e1->m1 ||
+ (e2->m1 == e1->m1 && e2->m2 > e1->m2)) {
+ /* abs(e2) > abs(e1) */
+ if (e1->m2 > e2->m2) {
+ e2->m1 -= 1; /* carry in */
+ }
+ e2->m1 -= e1->m1;
+ e2->m2 -= e1->m2;
+ *e1 = *e2;
+ e1->sign = e2->sign ? 0 : 1;
+ }
+ else {
+ if (e2->m2 > e1->m2)
+ e1->m1 -= 1; /* carry in */
+ e1->m1 -= e2->m1;
+ e1->m2 -= e2->m2;
+ }
+ nrm_ext(e1);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ return a zero float (ZRF 4)
+*/
+
+#include "FP_types.h"
+
+void
+zrf4(l)
+SINGLE *l;
+{
+ *l = 0L;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ return a zero double (ZRF 8)
+*/
+
+#include "FP_types.h"
+
+void
+zrf8(z)
+DOUBLE *z;
+{
+
+ z->d[0] = 0L;
+ z->d[1] = 0L;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ZERO and return EXTEND FORMAT FLOAT
+*/
+
+#include "FP_types.h"
+
+void
+zrf_ext(e)
+EXTEND *e;
+{
+ e->m1 = 0;
+ e->m2 = 0;
+ e->exp = 0;
+ e->sign = 0;
+}
--- /dev/null
+#!/bin/sh
+# Author: Kees J. Bot
+# Compile one soft FP source file.
+# (These files shouldn't be optimized normally, but the 16-bit C compiler
+# only optimizes scratch register allocation a bit with -O. To the 32-bit
+# compiler -O is a no-op.)
+
+case $#:$1 in
+1:*.fc) ;;
+*) echo "$0: $1: not a FC file" >&2; exit 1
+esac
+
+base="`basename "$1" .fc`"
+trap 'rm -f tmp.c tmp.s"; exit 1' 2
+
+cp "$1" tmp.c &&
+cc -O -I. -D_MINIX -D_POSIX_SOURCE -S tmp.c &&
+sed -f FP.script tmp.s > "$base.s" &&
+rm tmp.c tmp.s
--- /dev/null
+s/_adf4/.adf4/
+s/_adf8/.adf8/
+s/_cff4/.cff4/
+s/_cff8/.cff8/
+s/_cfi/.cfi/
+s/_cfu/.cfu/
+s/_cif4/.cif4/
+s/_cif8/.cif8/
+s/_cmf4/.cmf4/
+s/_cmf8/.cmf8/
+s/_cuf4/.cuf4/
+s/_cuf8/.cuf8/
+s/_dvf4/.dvf4/
+s/_dvf8/.dvf8/
+s/_fef4/.fef4/
+s/_fef8/.fef8/
+s/_fif4/.fif4/
+s/_fif8/.fif8/
+s/_mlf4/.mlf4/
+s/_mlf8/.mlf8/
+s/_ngf4/.ngf4/
+s/_ngf8/.ngf8/
+s/_sbf4/.sbf4/
+s/_sbf8/.sbf8/
+s/_zrf4/.zrf4/
+s/_zrf8/.zrf8/
+s/_add_ext/.add_ext/
+s/_div_ext/.div_ext/
+s/_mul_ext/.mul_ext/
+s/_nrm_ext/.nrm_ext/
+s/_sft_ext/.sft_ext/
+s/_sub_ext/.sub_ext/
+s/_zrf_ext/.zrf_ext/
+s/_compact/.compact/
+s/_extend/.extend/
+s/_b64_add/.b64_add/
+s/_b64_sft/.b64_sft/
+s/_b64_rsft/.b64_rsft/
+s/_b64_lsft/.b64_lsft/
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ include file for floating point package
+*/
+
+ /* FLOAT FORMAT EXPONENT BIAS */
+
+#define SGL_BIAS 127 /* excess 128 notation used */
+#define DBL_BIAS 1023 /* excess 1024 notation used */
+#define EXT_BIAS 0 /* 2s-complement notation used */
+ /* this is possible because the */
+ /* sign is in a seperate word */
+
+ /* VARIOUS MAX AND MIN VALUES */
+ /* 1) FOR THE DIFFERENT FORMATS */
+
+#define SGL_MAX 254 /* standard definition */
+#define SGL_MIN 1 /* standard definition */
+#define DBL_MAX 2046 /* standard definition */
+#define DBL_MIN 1 /* standard definition */
+#define EXT_MAX 16383 /* standard minimum */
+#define EXT_MIN -16382 /* standard minimum */
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ include file for floating point package
+*/
+
+# define CARRYBIT 0x80000000L
+# define NORMBIT 0x80000000L
+# define EXP_STORE 16
+
+
+ /* parameters for Single Precision */
+#define SGL_EXPSHIFT 7
+#define SGL_M1LEFT 8
+#define SGL_ZERO 0xffffff80L
+#define SGL_EXACT 0xff
+#define SGL_RUNPACK SGL_M1LEFT
+
+#define SGL_ROUNDUP 0x80
+#define SGL_CARRYOUT 0x01000000L
+#define SGL_MASK 0x007fffffL
+
+ /* parameters for Double Precision */
+ /* used in extend.c */
+
+#define DBL_EXPSHIFT 4
+
+#define DBL_M1LEFT 11
+
+#define DBL_RPACK (32-DBL_M1LEFT)
+#define DBL_LPACK DBL_M1LEFT
+
+ /* used in compact.c */
+
+#define DBL_ZERO 0xfffffd00L
+
+#define DBL_EXACT 0x7ff
+
+#define DBL_RUNPACK DBL_M1LEFT
+#define DBL_LUNPACK (32-DBL_RUNPACK)
+
+#define DBL_ROUNDUP 0x400
+#define DBL_CARRYOUT 0x00200000L
+#define DBL_MASK 0x000fffffL
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ include file for floating point package
+*/
+
+ /* EM TRAPS */
+
+#define EIOVFL 3 /* Integer Overflow */
+#define EFOVFL 4 /* Floating Overflow */
+#define EFUNFL 5 /* Floating Underflow */
+#define EIDIVZ 6 /* Integer Divide by 0 */
+#define EFDIVZ 7 /* Floating Divide by 0.0 */
+#define EIUND 8 /* Integer Undefined Number */
+#define EFUND 9 /* Floating Undefined Number */
+#define ECONV 10 /* Conversion Error */
+# define trap(x) _fptrp(x)
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/********************************************************/
+/*
+ Type definitions for C Floating Point Package
+ include file for floating point package
+*/
+/********************************************************/
+/*
+ THESE STRUCTURES ARE USED TO ADDRESS THE INDIVIDUAL
+ PARTS OF THE FLOATING POINT NUMBER REPRESENTATIONS.
+
+ THREE STRUCTURES ARE DEFINED:
+ SINGLE: single precision floating format
+ DOUBLE: double precision floating format
+ EXTEND: double precision extended format
+*/
+/********************************************************/
+
+#ifndef __FPTYPES
+#define __FPTYPES
+
+typedef struct {
+ unsigned long h_32; /* higher 32 bits of 64 */
+ unsigned long l_32; /* lower 32 bits of 64 */
+} B64;
+
+typedef unsigned long SINGLE;
+
+typedef struct {
+ unsigned long d[2];
+} DOUBLE;
+
+typedef struct { /* expanded float format */
+ short sign;
+ short exp;
+ B64 mantissa;
+#define m1 mantissa.h_32
+#define m2 mantissa.l_32
+} EXTEND;
+
+struct fef4_returns {
+ int e;
+ SINGLE f;
+};
+
+struct fef8_returns {
+ int e;
+ DOUBLE f;
+};
+
+struct fif4_returns {
+ SINGLE ipart;
+ SINGLE fpart;
+};
+
+struct fif8_returns {
+ DOUBLE ipart;
+ DOUBLE fpart;
+};
+
+#if __STDC__
+#define _PROTOTYPE(function, params) function params
+#else
+#define _PROTOTYPE(function, params) function()
+#endif
+_PROTOTYPE( void add_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void mul_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void div_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void sub_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void sft_ext, (EXTEND *e1, EXTEND *e2));
+_PROTOTYPE( void nrm_ext, (EXTEND *e1));
+_PROTOTYPE( void zrf_ext, (EXTEND *e1));
+_PROTOTYPE( void extend, (unsigned long *from, EXTEND *to, int size));
+_PROTOTYPE( void compact, (EXTEND *from, unsigned long *to, int size));
+_PROTOTYPE( void _fptrp, (int));
+_PROTOTYPE( void adf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( void adf8, (DOUBLE s2, DOUBLE s1));
+_PROTOTYPE( void sbf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( void sbf8, (DOUBLE s2, DOUBLE s1));
+_PROTOTYPE( void dvf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( void dvf8, (DOUBLE s2, DOUBLE s1));
+_PROTOTYPE( void mlf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( void mlf8, (DOUBLE s2, DOUBLE s1));
+_PROTOTYPE( void ngf4, (SINGLE f));
+_PROTOTYPE( void ngf8, (DOUBLE f));
+_PROTOTYPE( void zrf4, (SINGLE *l));
+_PROTOTYPE( void zrf8, (DOUBLE *z));
+_PROTOTYPE( void cff4, (DOUBLE src));
+_PROTOTYPE( void cff8, (SINGLE src));
+_PROTOTYPE( void cif4, (int ss, long src));
+_PROTOTYPE( void cif8, (int ss, long src));
+_PROTOTYPE( void cuf4, (int ss, long src));
+_PROTOTYPE( void cuf8, (int ss, long src));
+_PROTOTYPE( long cfu, (int ds, int ss, DOUBLE src));
+_PROTOTYPE( long cfi, (int ds, int ss, DOUBLE src));
+_PROTOTYPE( int cmf4, (SINGLE s2, SINGLE s1));
+_PROTOTYPE( int cmf8, (DOUBLE d1, DOUBLE d2));
+_PROTOTYPE( void fef4, (struct fef4_returns *r, SINGLE s1));
+_PROTOTYPE( void fef8, (struct fef8_returns *r, DOUBLE s1));
+_PROTOTYPE( void fif4, (struct fif4_returns *p, SINGLE x, SINGLE y));
+_PROTOTYPE( void fif8, (struct fif8_returns *p, DOUBLE x, DOUBLE y));
+
+_PROTOTYPE( void b64_sft, (B64 *, int));
+_PROTOTYPE( void b64_lsft, (B64 *));
+_PROTOTYPE( void b64_rsft, (B64 *));
+_PROTOTYPE( int b64_add, (B64 *, B64 *));
+#endif
--- /dev/null
+# Makefile for lib/ack/fphook.
+
+# The ACK ANSI C compiler has an nice trick to reduce the size of programs
+# that do not use floating point. If a program uses floating point then the
+# compiler generates an external reference to the label '_fp_hook'. This makes
+# the loader bring in the floating point printing and conversion routines
+# '_f_print' and 'strtod' from the library libd.a. Otherwise two dummy
+# routines are found in libc.a. (The printf and scanf need floating point
+# for the %f formats, whether you use them or not.)
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE -I..
+
+LIBRARIES = libd libc
+
+libd_OBJECTS = fphook.o
+
+libc_OBJECTS = fltpr.o strtod.o
+
+include ../../Makefile.ack.inc
--- /dev/null
+# Makefile for lib/i86/fphook.
+
+# The ACK ANSI C compiler has an nice trick to reduce the size of programs
+# that do not use floating point. If a program uses floating point then the
+# compiler generates an external reference to the label '_fp_hook'. This makes
+# the loader bring in the floating point printing and conversion routines
+# '_f_print' and 'strtod' from the library libd.a. Otherwise two dummy
+# routines are found in libc.a. (The printf and scanf need floating point
+# for the %f formats, whether you use them or not.)
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE
+CC1 = $(CC) $(CFLAGS) -c -I$(SRCDIR)/ack
+
+LIBD = ../../libd.a
+LIBC = ../../libc.a
+
+all: $(LIBD) $(LIBC)
+
+$(LIBD): fphook.c
+ $(CC1) fphook.c
+ aal cr $@ fphook.o
+ rm fphook.o
+
+$(LIBC): $(LIBC)(fltpr.o) $(LIBC)(strtod.o)
+ aal cr $@ *.o
+ rm *.o
+
+$(LIBC)(fltpr.o): fltpr.c
+ $(CC1) fltpr.c
+
+$(LIBC)(strtod.o): strtod.c
+ $(CC1) strtod.c
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ADD TWO EXTENDED FORMAT NUMBERS
+*/
+
+#include "FP_types.h"
+
+void
+add_ext(e1,e2)
+register EXTEND *e1,*e2;
+{
+ if ((e2->m1 | e2->m2) == 0L) {
+ return;
+ }
+ if ((e1->m1 | e1->m2) == 0L) {
+ *e1 = *e2;
+ return;
+ }
+ sft_ext(e1, e2); /* adjust mantissas to equal powers */
+ if (e1->sign != e2->sign) {
+ /* e1 + e2 = e1 - (-e2) */
+ if (e2->m1 > e1->m1 ||
+ (e2->m1 == e1->m1 && e2->m2 > e1->m2)) {
+ /* abs(e2) > abs(e1) */
+ EXTEND x;
+
+ x = *e1;
+ *e1 = *e2;
+ if (x.m2 > e1->m2) {
+ e1->m1 -= 1; /* carry in */
+ }
+ e1->m1 -= x.m1;
+ e1->m2 -= x.m2;
+ }
+ else {
+ if (e2->m2 > e1->m2)
+ e1->m1 -= 1; /* carry in */
+ e1->m1 -= e2->m1;
+ e1->m2 -= e2->m2;
+ }
+ }
+ else {
+ if (b64_add(&e1->mantissa,&e2->mantissa)) { /* addition carry */
+ b64_rsft(&e1->mantissa); /* shift mantissa one bit RIGHT */
+ e1->m1 |= 0x80000000L; /* set max bit */
+ e1->exp++; /* increase the exponent */
+ }
+ }
+ nrm_ext(e1);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ * these are the routines the routines to do 32 and 64-bit addition
+ */
+
+# ifdef EXT_DEBUG
+# include <stdio.h>
+# endif
+
+# include "FP_types.h"
+# define UNKNOWN -1
+# define TRUE 1
+# define FALSE 0
+# define MAXBIT 0x80000000L
+
+ /*
+ * add 64 bits
+ */
+int
+b64_add(e1,e2)
+ /*
+ * pointers to 64 bit 'registers'
+ */
+register B64 *e1,*e2;
+{
+ register int overflow;
+ int carry;
+
+ /* add higher pair of 32 bits */
+ overflow = ((unsigned long) 0xFFFFFFFF - e1->h_32 < e2->h_32);
+ e1->h_32 += e2->h_32;
+
+ /* add lower pair of 32 bits */
+ carry = ((unsigned long) 0xFFFFFFFF - e1->l_32 < e2->l_32);
+ e1->l_32 += e2->l_32;
+# ifdef EXT_DEBUG
+ printf("\t\t\t\t\tb64_add: overflow (%d); internal carry(%d)\n",
+ overflow,carry);
+ fflush(stdout);
+# endif
+ if ((carry) && (++e1->h_32 == 0))
+ return(TRUE); /* had a 64 bit overflow */
+ return(overflow); /* return status from higher add */
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ * include file for 32 & 64 bit addition
+ */
+
+typedef struct B64 {
+ unsigned long h_32; /* higher 32 bits of 64 */
+ unsigned long l_32; /* lower 32 bits of 64 */
+} B64;
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ADD TWO FLOATS - SINGLE (ADF 4)
+*/
+
+#include "FP_types.h"
+
+void
+adf4(s2,s1)
+SINGLE s1,s2;
+{
+ EXTEND e1,e2;
+ int swap = 0;
+
+ if (s1 == (SINGLE) 0) {
+ s1 = s2;
+ return;
+ }
+ if (s2 == (SINGLE) 0) {
+ return;
+ }
+ extend(&s1,&e1,sizeof(SINGLE));
+ extend(&s2,&e2,sizeof(SINGLE));
+ add_ext(&e1,&e2);
+ compact(&e1,&s1,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ADD TWO FLOATS - DOUBLE (ADF 8)
+*/
+
+#include "FP_types.h"
+
+void
+adf8(s2,s1)
+DOUBLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ if (s1.d[0] == 0 && s1.d[1] == 0) {
+ s1 = s2;
+ return;
+ }
+ if (s2.d[0] == 0 && s2.d[1] == 0) {
+ return;
+ }
+
+ extend(&s1.d[0],&e1,sizeof(DOUBLE));
+ extend(&s2.d[0],&e2,sizeof(DOUBLE));
+ add_ext(&e1,&e2);
+ compact(&e1,&s1.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+#define CHAR_UNSIGNED 0
+#define MSB_AT_LOW_ADDRESS 0
+#define MSW_AT_LOW_ADDRESS 0
+#define FL_MSB_AT_LOW_ADDRESS 0
+#define FL_MSW_AT_LOW_ADDRESS 0
+#define FL_MSL_AT_LOW_ADDRESS 0
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT DOUBLE TO SINGLE (CFF 8 4)
+
+ This routine works quite simply. A floating point
+ of size 08 is converted to extended format.
+ This extended variable is converted back to
+ a floating point of size 04.
+
+*/
+
+#include "FP_types.h"
+
+void
+cff4(src)
+DOUBLE src; /* the source itself - THIS TIME it's DOUBLE */
+{
+ EXTEND buf;
+
+ extend(&src.d[0],&buf,sizeof(DOUBLE)); /* no matter what */
+ compact(&buf,&(src.d[1]),sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT SINGLE TO DOUBLE (CFF 4 8)
+
+ This routine works quite simply. A floating point
+ of size 04 is converted to extended format.
+ This extended variable is converted back to
+ a floating point of size 08.
+
+*/
+
+#include "FP_types.h"
+
+void
+cff8(src)
+SINGLE src;
+{
+ EXTEND buf;
+
+ extend(&src,&buf,sizeof(SINGLE)); /* no matter what */
+ compact(&buf, &src,sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT FLOAT TO SIGNED (CFI m n)
+
+ N.B. The caller must know what it is getting.
+ A LONG is always returned. If it is an
+ integer the high byte is cleared first.
+*/
+
+#include "FP_trap.h"
+#include "FP_types.h"
+#include "FP_shift.h"
+
+long
+cfi(ds,ss,src)
+int ds; /* destination size (2 or 4) */
+int ss; /* source size (4 or 8) */
+DOUBLE src; /* assume worst case */
+{
+ EXTEND buf;
+ long new;
+ short max_exp;
+
+ extend(&src.d[0],&buf,ss); /* get extended format */
+ if (buf.exp < 0) { /* no conversion needed */
+ src.d[ss == 8] = 0L;
+ return(0L);
+ }
+ max_exp = (ds << 3) - 2; /* signed numbers */
+ /* have more limited max_exp */
+ if (buf.exp > max_exp) {
+ if (buf.exp == max_exp+1 && buf.sign && buf.m1 == NORMBIT &&
+ buf.m2 == 0L) {
+ }
+ else {
+ trap(EIOVFL); /* integer overflow */
+ buf.exp %= max_exp; /* truncate */
+ }
+ }
+ new = buf.m1 >> (31-buf.exp);
+ if (buf.sign)
+ new = -new;
+done:
+ src.d[ss == 8] = new;
+ return(new);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT FLOAT TO UNSIGNED (CFU m n)
+
+ N.B. The caller must know what it is getting.
+ A LONG is always returned. If it is an
+ integer the high byte is cleared first.
+*/
+
+#include "FP_trap.h"
+#include "FP_types.h"
+
+long
+cfu(ds,ss,src)
+int ds; /* destination size (2 or 4) */
+int ss; /* source size (4 or 8) */
+DOUBLE src; /* assume worst case */
+{
+ EXTEND buf;
+ long new;
+ short newint, max_exp;
+
+ extend(&src.d[0],&buf,ss); /* get extended format */
+ if (buf.exp < 0) { /* no conversion needed */
+ src.d[ss == 8] = 0L;
+ return(0L);
+ }
+ max_exp = (ds << 3) - 1;
+ if (buf.exp > max_exp) {
+ trap(EIOVFL); /* integer overflow */
+ buf.exp %= max_exp;
+ }
+ new = buf.m1 >> (31-buf.exp);
+done:
+ src.d[ss == 8] = new;
+ return(new);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT INTEGER TO SINGLE (CIF n 4)
+
+ THIS ROUTINE WORKS BY FILLING AN EXTENDED
+ WITH THE INTEGER VALUE IN EXTENDED FORMAT
+ AND USES COMPACT() TO PUT IT INTO THE PROPER
+ FLOATING POINT PRECISION.
+*/
+
+#include "FP_types.h"
+
+void
+cif4(ss,src)
+int ss; /* source size */
+long src; /* largest possible integer to convert */
+{
+ EXTEND buf;
+ short *ipt;
+ long i_src;
+ SINGLE *result;
+
+ zrf_ext(&buf);
+ if (ss == sizeof(long)) {
+ buf.exp = 31;
+ i_src = src;
+ result = (SINGLE *) &src;
+ }
+ else {
+ ipt = (short *) &src;
+ i_src = (long) *ipt;
+ buf.exp = 15;
+ result = (SINGLE *) &ss;
+ }
+ if (i_src == 0) {
+ *result = (SINGLE) 0L;
+ return;
+ }
+ /* ESTABLISHED THAT src != 0 */
+ /* adjust exponent field */
+ buf.sign = (i_src < 0) ? 0x8000 : 0;
+ /* clear sign bit of integer */
+ /* move to mantissa field */
+ buf.m1 = (i_src < 0) ? -i_src : i_src;
+ /* adjust mantissa field */
+ if (ss != sizeof(long))
+ buf.m1 <<= 16;
+ nrm_ext(&buf); /* adjust mantissa field */
+ compact(&buf, result,sizeof(SINGLE)); /* put on stack */
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT INTEGER TO FLOAT (CIF n 8)
+
+ THIS ROUTINE WORKS BY FILLING AN EXTENDED
+ WITH THE INTEGER VALUE IN EXTENDED FORMAT
+ AND USES COMPACT() TO PUT IT INTO THE PROPER
+ FLOATING POINT PRECISION.
+*/
+
+#include "FP_types.h"
+
+void
+cif8(ss,src)
+int ss; /* source size */
+long src; /* largest possible integer to convert */
+{
+ EXTEND buf;
+ DOUBLE *result; /* for return value */
+ short *ipt;
+ long i_src;
+
+ result = (DOUBLE *) ((void *) &ss); /* always */
+ zrf_ext(&buf);
+ if (ss == sizeof(long)) {
+ buf.exp = 31;
+ i_src = src;
+ }
+ else {
+ ipt = (short *) &src;
+ i_src = (long) *ipt;
+ buf.exp = 15;
+ }
+ if (i_src == 0) {
+ zrf8(result);
+ return;
+ }
+ /* ESTABLISHED THAT src != 0 */
+ /* adjust exponent field */
+ buf.sign = (i_src < 0) ? 0x8000 : 0;
+ /* clear sign bit of integer */
+ /* move to mantissa field */
+ buf.m1 = (i_src < 0) ? -i_src : i_src;
+ /* adjust mantissa field */
+ if (ss != sizeof(long))
+ buf.m1 <<= 16;
+ nrm_ext(&buf);
+ compact(&buf,&result->d[0],8);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ COMPARE SINGLES (CMF 4)
+*/
+
+#include "FP_types.h"
+#include "get_put.h"
+
+int
+cmf4(f1,f2)
+SINGLE f1,f2;
+{
+ /*
+ * return ((f1 < f2) ? 1 : (f1 - f2))
+ */
+#define SIGN(x) (((x) < 0) ? -1 : 1)
+ int sign1,sign2;
+ long l1,l2;
+
+ l1 = get4((char *) &f1);
+ l2 = get4((char *) &f2);
+
+ if (l1 == l2) return 0;
+
+ sign1 = SIGN(l1);
+ sign2 = SIGN(l2);
+ if (sign1 != sign2) {
+ if ((l1 & 0x7fffffff) == 0 &&
+ (l2 & 0x7fffffff) == 0) return 0;
+ return ((sign1 > 0) ? -1 : 1);
+ }
+
+ return (sign1 * ((l1 < l2) ? 1 : -1));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ COMPARE DOUBLES (CMF 8)
+*/
+
+#include "FP_types.h"
+#include "get_put.h"
+
+int
+cmf8(d1,d2)
+DOUBLE d1,d2;
+{
+#define SIGN(x) (((x) < 0) ? -1 : 1)
+ /*
+ * return ((d1 < d2) ? 1 : (d1 > d2) ? -1 : 0))
+ */
+ long l1,l2;
+ int sign1,sign2;
+ int rv;
+
+#if FL_MSL_AT_LOW_ADDRESS
+ l1 = get4((char *)&d1);
+ l2 = get4((char *)&d2);
+#else
+ l1 = get4(((char *)&d1+4));
+ l2 = get4(((char *)&d2+4));
+#endif
+ sign1 = SIGN(l1);
+ sign2 = SIGN(l2);
+ if (sign1 != sign2) {
+ l1 &= 0x7fffffff;
+ l2 &= 0x7fffffff;
+ if (l1 != 0 || l2 != 0) {
+ return ((sign1 > 0) ? -1 : 1);
+ }
+ }
+ if (l1 != l2) { /* we can decide here */
+ rv = l1 < l2 ? 1 : -1;
+ }
+ else { /* decide in 2nd half */
+ unsigned long u1, u2;
+#if FL_MSL_AT_LOW_ADDRESS
+ u1 = get4(((char *)&d1 + 4));
+ u2 = get4(((char *)&d2 + 4));
+#else
+ u1 = get4((char *)&d1);
+ u2 = get4((char *)&d2);
+#endif
+ if (u1 == u2)
+ return(0);
+ if (u1 < u2) rv = 1;
+ else rv = -1;
+ }
+ return sign1 * rv;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ COMPACT EXTEND FORMAT INTO FLOAT OF PROPER SIZE
+*/
+
+# include "FP_bias.h"
+# include "FP_shift.h"
+# include "FP_trap.h"
+# include "FP_types.h"
+# include "get_put.h"
+
+void
+compact(f,to,size)
+EXTEND *f;
+unsigned long *to;
+int size;
+{
+ int error = 0;
+
+ if (size == sizeof(DOUBLE)) {
+ /*
+ * COMPACT EXTENDED INTO DOUBLE
+ */
+ DOUBLE *DBL = (DOUBLE *) (void *) to;
+
+ if ((f->m1|(f->m2 & DBL_ZERO)) == 0L) {
+ zrf8(DBL);
+ return;
+ }
+ f->exp += DBL_BIAS; /* restore proper bias */
+ if (f->exp > DBL_MAX) {
+dbl_over: trap(EFOVFL);
+ f->exp = DBL_MAX+1;
+ f->m1 = 0;
+ f->m2 = 0;
+ if (error++)
+ return;
+ }
+ else if (f->exp < DBL_MIN) {
+ b64_rsft(&(f->mantissa));
+ if (f->exp < 0) {
+ b64_sft(&(f->mantissa), -f->exp);
+ f->exp = 0;
+ }
+ /* underflow ??? */
+ }
+
+ /* local CAST conversion */
+
+ /* because of special format shift only 10 bits */
+ /* bit shift mantissa 10 bits */
+
+ /* first align within words, then do store operation */
+
+ DBL->d[0] = f->m1 >> DBL_RUNPACK; /* plus 22 == 32 */
+ DBL->d[1] = f->m2 >> DBL_RUNPACK; /* plus 22 == 32 */
+ DBL->d[1] |= (f->m1 << DBL_LUNPACK); /* plus 10 == 32 */
+
+ /* if not exact then round to nearest */
+ /* on a tie, round to even */
+
+#ifdef EXCEPTION_INEXACT
+ if ((f->m2 & DBL_EXACT) != 0) {
+ INEXACT();
+#endif
+ if (((f->m2 & DBL_EXACT) > DBL_ROUNDUP)
+ || ((f->m2 & DBL_EXACT) == DBL_ROUNDUP
+ && (f->m2 & (DBL_ROUNDUP << 1)))) {
+ DBL->d[1]++; /* rounding up */
+ if (DBL->d[1] == 0L) { /* carry out */
+ DBL->d[0]++;
+
+ if (f->exp == 0 && (DBL->d[0] & ~DBL_MASK)) {
+ f->exp++;
+ }
+ if (DBL->d[0] & DBL_CARRYOUT) { /* carry out */
+ if (DBL->d[0] & 01)
+ DBL->d[1] = CARRYBIT;
+ DBL->d[0] >>= 1;
+ f->exp++;
+ }
+ }
+ /* check for overflow */
+ if (f->exp > DBL_MAX)
+ goto dbl_over;
+ }
+#ifdef EXCEPTION_INEXACT
+ }
+#endif
+
+ /*
+ * STORE EXPONENT AND SIGN:
+ *
+ * 1) clear leading bits (B4-B15)
+ * 2) shift and store exponent
+ */
+
+ DBL->d[0] &= DBL_MASK;
+ DBL->d[0] |=
+ ((long) (f->exp << DBL_EXPSHIFT) << EXP_STORE);
+ if (f->sign)
+ DBL->d[0] |= CARRYBIT;
+
+ /*
+ * STORE MANTISSA
+ */
+
+#if FL_MSL_AT_LOW_ADDRESS
+ put4(DBL->d[0], (char *) &DBL->d[0]);
+ put4(DBL->d[1], (char *) &DBL->d[1]);
+#else
+ { unsigned long l;
+ put4(DBL->d[1], (char *) &l);
+ put4(DBL->d[0], (char *) &DBL->d[1]);
+ DBL->d[0] = l;
+ }
+#endif
+ }
+ else {
+ /*
+ * COMPACT EXTENDED INTO FLOAT
+ */
+ SINGLE *SGL;
+
+ /* local CAST conversion */
+ SGL = (SINGLE *) (void *) to;
+ if ((f->m1 & SGL_ZERO) == 0L) {
+ *SGL = 0L;
+ return;
+ }
+ f->exp += SGL_BIAS; /* restore bias */
+ if (f->exp > SGL_MAX) {
+sgl_over: trap(EFOVFL);
+ f->exp = SGL_MAX+1;
+ f->m1 = 0L;
+ f->m2 = 0L;
+ if (error++)
+ return;
+ }
+ else if (f->exp < SGL_MIN) {
+ b64_rsft(&(f->mantissa));
+ if (f->exp < 0) {
+ b64_sft(&(f->mantissa), -f->exp);
+ f->exp = 0;
+ }
+ /* underflow ??? */
+ }
+
+ /* shift mantissa and store */
+ *SGL = (f->m1 >> SGL_RUNPACK);
+
+ /* check for rounding to nearest */
+ /* on a tie, round to even */
+#ifdef EXCEPTION_INEXACT
+ if (f->m2 != 0 ||
+ (f->m1 & SGL_EXACT) != 0L) {
+ INEXACT();
+#endif
+ if (((f->m1 & SGL_EXACT) > SGL_ROUNDUP)
+ || ((f->m1 & SGL_EXACT) == SGL_ROUNDUP
+ && (f->m1 & (SGL_ROUNDUP << 1)))) {
+ (*SGL)++;
+ if (f->exp == 0 && (*SGL & ~SGL_MASK)) {
+ f->exp++;
+ }
+ /* check normal */
+ if (*SGL & SGL_CARRYOUT) {
+ *SGL >>= 1;
+ f->exp++;
+ }
+ if (f->exp > SGL_MAX)
+ goto sgl_over;
+ }
+#ifdef EXCEPTION_INEXACT
+ }
+#endif
+
+ /*
+ * STORE EXPONENT AND SIGN:
+ *
+ * 1) clear leading bit of fraction
+ * 2) shift and store exponent
+ */
+
+ *SGL &= SGL_MASK; /* B23-B31 are 0 */
+ *SGL |= ((long) (f->exp << SGL_EXPSHIFT) << EXP_STORE);
+ if (f->sign)
+ *SGL |= CARRYBIT;
+
+ /*
+ * STORE MANTISSA
+ */
+
+ put4(*SGL, (char *) &SGL);
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT INTEGER TO SINGLE (CUF n 4)
+
+ THIS ROUTINE WORKS BY FILLING AN EXTENDED
+ WITH THE INTEGER VALUE IN EXTENDED FORMAT
+ AND USES COMPACT() TO PUT IT INTO THE PROPER
+ FLOATING POINT PRECISION.
+*/
+
+#include "FP_types.h"
+
+void
+cuf4(ss,src)
+int ss; /* source size */
+long src; /* largest possible integer to convert */
+{
+ EXTEND buf;
+ short *ipt;
+ SINGLE *result;
+ long i_src;
+
+ zrf_ext(&buf);
+ if (ss == sizeof(long)) {
+ buf.exp = 31;
+ i_src = src;
+ result = (SINGLE *) &src;
+ }
+ else {
+ ipt = (short *) &src;
+ i_src = (long) *ipt;
+ buf.exp = 15;
+ result = (SINGLE *) ((void *) &ss);
+ }
+ if (i_src == 0) {
+ *result = (SINGLE) 0L;
+ return;
+ }
+ /* ESTABLISHED THAT src != 0 */
+
+ /* adjust exponent field */
+ if (ss != sizeof(long))
+ i_src <<= 16;
+
+ /* move to mantissa field */
+ buf.m1 = i_src;
+
+ /* adjust mantissa field */
+ nrm_ext(&buf);
+ compact(&buf,result,4);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERT INTEGER TO FLOAT (CUF n 8)
+
+ THIS ROUTINE WORKS BY FILLING AN EXTENDED
+ WITH THE INTEGER VALUE IN EXTENDED FORMAT
+ AND USES COMPACT() TO PUT IT INTO THE PROPER
+ FLOATING POINT PRECISION.
+*/
+
+#include "FP_types.h"
+
+void
+cuf8(ss,src)
+int ss; /* source size */
+long src; /* largest possible integer to convert */
+{
+ EXTEND buf;
+ short *ipt;
+ long i_src;
+
+ zrf_ext(&buf);
+ if (ss == sizeof(long)) {
+ buf.exp = 31;
+ i_src = src;
+ }
+ else {
+ ipt = (short *) &src;
+ i_src = (long) *ipt;
+ buf.exp = 15;
+ }
+ if (i_src == 0) {
+ zrf8((DOUBLE *)((void *)&ss));
+ return;
+ }
+ /* ESTABLISHED THAT src != 0 */
+
+ /* adjust exponent field */
+ if (ss != sizeof(long))
+ i_src <<= 16;
+
+ /* move to mantissa field */
+ buf.m1 = i_src;
+
+ /* adjust mantissa field */
+ nrm_ext(&buf);
+ compact(&buf,(unsigned long *) (void *)&ss,8);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ DIVIDE EXTENDED FORMAT
+*/
+
+#include "FP_bias.h"
+#include "FP_trap.h"
+#include "FP_types.h"
+
+/*
+ November 15, 1984
+
+ This is a routine to do the work.
+ There are two versions:
+ One is based on the partial products method
+ and makes no use possible machine instructions
+ to divide (hardware dividers).
+ The other is used when USE_DIVIDE is defined. It is much faster on
+ machines with fast 4 byte operations.
+*/
+/********************************************************/
+
+void
+div_ext(e1,e2)
+EXTEND *e1,*e2;
+{
+ short error = 0;
+ B64 result;
+ register unsigned long *lp;
+#ifndef USE_DIVIDE
+ short count;
+#else
+ unsigned short u[9], v[5];
+ register int j;
+ register unsigned short *u_p = u;
+ int maxv = 4;
+#endif
+
+ if ((e2->m1 | e2->m2) == 0) {
+ /*
+ * Exception 8.2 - Divide by zero
+ */
+ trap(EFDIVZ);
+ e1->m1 = e1->m2 = 0L;
+ e1->exp = EXT_MAX;
+ return;
+ }
+ if ((e1->m1 | e1->m2) == 0) { /* 0 / anything == 0 */
+ e1->exp = 0; /* make sure */
+ return;
+ }
+#ifndef USE_DIVIDE
+ /*
+ * numbers are right shifted one bit to make sure
+ * that m1 is quaranteed to be larger if its
+ * maximum bit is set
+ */
+ b64_rsft(&e1->mantissa); /* 64 bit shift right */
+ b64_rsft(&e2->mantissa); /* 64 bit shift right */
+ e1->exp++;
+ e2->exp++;
+#endif
+ /* check for underflow, divide by zero, etc */
+ e1->sign ^= e2->sign;
+ e1->exp -= e2->exp;
+
+#ifndef USE_DIVIDE
+ /* do division of mantissas */
+ /* uses partial product method */
+ /* init control variables */
+
+ count = 64;
+ result.h_32 = 0L;
+ result.l_32 = 0L;
+
+ /* partial product division loop */
+
+ while (count--) {
+ /* first left shift result 1 bit */
+ /* this is ALWAYS done */
+
+ b64_lsft(&result);
+
+ /* compare dividend and divisor */
+ /* if dividend >= divisor add a bit */
+ /* and subtract divisior from dividend */
+
+ if ( (e1->m1 < e2->m1) ||
+ ((e1->m1 == e2->m1) && (e1->m2 < e2->m2) ))
+ ; /* null statement */
+ /* i.e., don't add or subtract */
+ else {
+ result.l_32++; /* ADD */
+ if (e2->m2 > e1->m2)
+ e1->m1 -= 1; /* carry in */
+ e1->m1 -= e2->m1; /* do SUBTRACTION */
+ e1->m2 -= e2->m2; /* SUBTRACTION */
+ }
+
+ /* shift dividend left one bit OR */
+ /* IF it equals ZERO we can break out */
+ /* of the loop, but still must shift */
+ /* the quotient the remaining count bits */
+ /* NB save the results of this test in error */
+ /* if not zero, then the result is inexact. */
+ /* this would be reported in IEEE standard */
+
+ /* lp points to dividend */
+ lp = &e1->m1;
+
+ error = ((*lp | *(lp+1)) != 0L) ? 1 : 0;
+ if (error) { /* more work */
+ /* assume max bit == 0 (see above) */
+ b64_lsft(&e1->mantissa);
+ continue;
+ }
+ else
+ break; /* leave loop */
+ } /* end of divide by subtraction loop */
+
+ if (count > 0) {
+ lp = &result.h_32;
+ if (count > 31) { /* move to higher word */
+ *lp = *(lp+1);
+ count -= 32;
+ *(lp+1) = 0L; /* clear low word */
+ }
+ if (*lp)
+ *lp <<= count; /* shift rest of way */
+ lp++; /* == &result.l_32 */
+ if (*lp) {
+ result.h_32 |= (*lp >> 32-count);
+ *lp <<= count;
+ }
+ }
+#else /* USE_DIVIDE */
+
+ u[4] = (e1->m2 & 1) << 15;
+ b64_rsft(&(e1->mantissa));
+ u[0] = e1->m1 >> 16;
+ u[1] = e1->m1;
+ u[2] = e1->m2 >> 16;
+ u[3] = e1->m2;
+ u[5] = 0; u[6] = 0; u[7] = 0;
+ v[1] = e2->m1 >> 16;
+ v[2] = e2->m1;
+ v[3] = e2->m2 >> 16;
+ v[4] = e2->m2;
+ while (! v[maxv]) maxv--;
+ result.h_32 = 0;
+ result.l_32 = 0;
+ lp = &result.h_32;
+
+ /*
+ * Use an algorithm of Knuth (The art of programming, Seminumerical
+ * algorithms), to divide u by v. u and v are both seen as numbers
+ * with base 65536.
+ */
+ for (j = 0; j <= 3; j++, u_p++) {
+ unsigned long q_est, temp;
+
+ if (j == 2) lp++;
+ if (u_p[0] == 0 && u_p[1] < v[1]) continue;
+ temp = ((unsigned long)u_p[0] << 16) + u_p[1];
+ if (u_p[0] >= v[1]) {
+ q_est = 0x0000FFFFL;
+ }
+ else {
+ q_est = temp / v[1];
+ }
+ temp -= q_est * v[1];
+ while (temp < 0x10000 && v[2]*q_est > ((temp<<16)+u_p[2])) {
+ q_est--;
+ temp += v[1];
+ }
+ /* Now, according to Knuth, we have an estimate of the
+ quotient, that is either correct or one too big, but
+ almost always correct.
+ */
+ if (q_est != 0) {
+ int i;
+ unsigned long k = 0;
+ int borrow = 0;
+
+ for (i = maxv; i > 0; i--) {
+ unsigned long tmp = q_est * v[i] + k + borrow;
+ unsigned short md = tmp;
+
+ borrow = (md > u_p[i]);
+ u_p[i] -= md;
+ k = tmp >> 16;
+ }
+ k += borrow;
+ borrow = u_p[0] < k;
+ u_p[0] -= k;
+
+ if (borrow) {
+ /* So, this does not happen often; the estimate
+ was one too big; correct this
+ */
+ *lp |= (j & 1) ? (q_est - 1) : ((q_est-1)<<16);
+ borrow = 0;
+ for (i = maxv; i > 0; i--) {
+ unsigned long tmp
+ = v[i]+(unsigned long)u_p[i]+borrow;
+
+ u_p[i] = tmp;
+ borrow = tmp >> 16;
+ }
+ u_p[0] += borrow;
+ }
+ else *lp |= (j & 1) ? q_est : (q_est<<16);
+ }
+ }
+#ifdef EXCEPTION_INEXACT
+ u_p = &u[0];
+ for (j = 7; j >= 0; j--) {
+ if (*u_p++) {
+ error = 1;
+ break;
+ }
+ }
+#endif
+#endif
+
+#ifdef EXCEPTION_INEXACT
+ if (error) {
+ /*
+ * report here exception 8.5 - Inexact
+ * from Draft 8.0 of IEEE P754:
+ * In the absence of an invalid operation exception,
+ * if the rounded result of an operation is not exact or if
+ * it overflows without a trap, then the inexact exception
+ * shall be assigned. The rounded or overflowed result
+ * shall be delivered to the destination.
+ */
+ INEXACT();
+#endif
+ e1->mantissa = result;
+
+ nrm_ext(e1);
+ if (e1->exp < EXT_MIN) {
+ /*
+ * Exception 8.4 - Underflow
+ */
+ trap(EFUNFL); /* underflow */
+ e1->exp = EXT_MIN;
+ e1->m1 = e1->m2 = 0L;
+ return;
+ }
+ if (e1->exp >= EXT_MAX) {
+ /*
+ * Exception 8.3 - Overflow
+ */
+ trap(EFOVFL); /* overflow */
+ e1->exp = EXT_MAX;
+ e1->m1 = e1->m2 = 0L;
+ return;
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ DIVIDE TWO SINGLES - SINGLE Precision (dvf 4)
+*/
+
+#include "FP_types.h"
+
+void
+dvf4(s2,s1)
+SINGLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ extend(&s1,&e1,sizeof(SINGLE));
+ extend(&s2,&e2,sizeof(SINGLE));
+
+ /* do a divide */
+ div_ext(&e1,&e2);
+ compact(&e1,&s1,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ DIVIDE TWO FLOATS - DOUBLE Precision (DVF 8)
+*/
+
+#include "FP_types.h"
+
+void
+dvf8(s2,s1)
+DOUBLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ extend(&s1.d[0],&e1,sizeof(DOUBLE));
+ extend(&s2.d[0],&e2,sizeof(DOUBLE));
+
+ /* do a divide */
+ div_ext(&e1,&e2);
+ compact(&e1,&s1.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ CONVERTS FLOATING POINT TO EXTENDED FORMAT
+
+ Two sizes of FLOATING Point are known:
+ SINGLE and DOUBLE
+*/
+/********************************************************/
+/*
+ It is not required to normalize in extended
+ format, but it has been chosen to do so.
+ Extended Format is as follows (at exit):
+
+->sign S000 0000 | 0000 0000 <SIGN>
+->exp 0EEE EEEE | EEEE EEEE <EXPONENT>
+->m1 LFFF FFFF | FFFF FFFF <L.Fraction>
+ FFFF FFFF | FFFF FFFF <Fraction>
+->m2 FFFF FFFF | FFFF FFFF <Fraction>
+ FFFF F000 | 0000 0000 <Fraction>
+*/
+/********************************************************/
+
+#include "FP_bias.h"
+#include "FP_shift.h"
+#include "FP_types.h"
+#include "get_put.h"
+/********************************************************/
+
+void
+extend(from,to,size)
+unsigned long *from;
+EXTEND *to;
+int size;
+{
+ register char *cpt1;
+ unsigned long tmp;
+ int leadbit = 0;
+
+ cpt1 = (char *) from;
+
+#if FL_MSL_AT_LOW_ADDRESS
+#if FL_MSW_AT_LOW_ADDRESS
+ to->exp = uget2(cpt1);
+#else
+ to->exp = uget2(cpt1+2);
+#endif
+#else
+#if FL_MSW_AT_LOW_ADDRESS
+ to->exp = uget2(cpt1+(size == sizeof(DOUBLE) ? 4 : 0));
+#else
+ to->exp = uget2(cpt1+(size == sizeof(DOUBLE) ? 6 : 2));
+#endif
+#endif
+ to->sign = (to->exp & 0x8000); /* set sign bit */
+ to->exp ^= to->sign;
+ if (size == sizeof(DOUBLE))
+ to->exp >>= DBL_EXPSHIFT;
+ else
+ to->exp >>= SGL_EXPSHIFT;
+ if (to->exp > 0)
+ leadbit++; /* will set Lead bit later */
+ else to->exp++;
+
+ if (size == sizeof(DOUBLE)) {
+#if FL_MSL_AT_LOW_ADDRESS
+ to->m1 = get4(cpt1);
+ cpt1 += 4;
+ tmp = get4(cpt1);
+#else
+ tmp = get4(cpt1);
+ cpt1 += 4;
+ to->m1 = get4(cpt1);
+#endif
+ if (to->exp == 1 && to->m1 == 0 && tmp == 0) {
+ to->exp = 0;
+ to->sign = 0;
+ to->m1 = 0;
+ to->m2 = 0;
+ return;
+ }
+ to->m1 <<= DBL_M1LEFT; /* shift */
+ to->exp -= DBL_BIAS; /* remove bias */
+ to->m1 |= (tmp>>DBL_RPACK); /* plus 10 == 32 */
+ to->m2 = (tmp<<DBL_LPACK); /* plus 22 == 32 */
+ }
+ else { /* size == sizeof(SINGLE) */
+ to->m1 = get4(cpt1);
+ to->m1 <<= SGL_M1LEFT; /* shift */
+ if (to->exp == 1 && to->m1 == 0) {
+ to->exp = 0;
+ to->sign = 0;
+ to->m1 = 0;
+ to->m2 = 0;
+ return;
+ }
+ to->exp -= SGL_BIAS; /* remove bias */
+ to->m2 = 0L;
+ }
+
+ to->m1 |= NORMBIT; /* set bit L */
+ if (leadbit == 0) { /* set or clear Leading Bit */
+ to->m1 &= ~NORMBIT; /* clear bit L */
+ nrm_ext(to); /* and normalize */
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SEPERATE INTO EXPONENT AND FRACTION (FEF 4)
+*/
+
+#include "FP_types.h"
+
+void
+fef4(r,s1)
+SINGLE s1;
+struct fef4_returns *r;
+{
+ EXTEND buf;
+ register struct fef4_returns *p = r; /* make copy; r might refer
+ to itself (see table)
+ */
+
+ extend(&s1,&buf,sizeof(SINGLE));
+ if (buf.exp == 0 && buf.m1 == 0 && buf.m2 == 0) {
+ p->e = 0;
+ }
+ else {
+ p->e = buf.exp+1;
+ buf.exp = -1;
+ }
+ compact(&buf,&p->f,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SEPERATE DOUBLE INTO EXPONENT AND FRACTION (FEF 8)
+*/
+
+#include "FP_types.h"
+
+void
+fef8(r, s1)
+DOUBLE s1;
+struct fef8_returns *r;
+{
+ EXTEND buf;
+ register struct fef8_returns *p = r; /* make copy, r might refer
+ to itself (see table)
+ */
+
+ extend(&s1.d[0],&buf,sizeof(DOUBLE));
+ if (buf.exp == 0 && buf.m1 == 0 && buf.m2 == 0) {
+ p->e = 0;
+ }
+ else {
+ p->e = buf.exp + 1;
+ buf.exp = -1;
+ }
+ compact(&buf,&p->f.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ MULTIPLY AND DISMEMBER PARTS (FIF 4)
+*/
+
+#include "FP_types.h"
+#include "FP_shift.h"
+
+void
+fif4(p,x,y)
+SINGLE x,y;
+struct fif4_returns *p;
+{
+
+ EXTEND e1,e2;
+
+ extend(&y,&e1,sizeof(SINGLE));
+ extend(&x,&e2,sizeof(SINGLE));
+ /* do a multiply */
+ mul_ext(&e1,&e2);
+ e2 = e1;
+ compact(&e2,&y,sizeof(SINGLE));
+ if (e1.exp < 0) {
+ p->ipart = 0;
+ p->fpart = y;
+ return;
+ }
+ if (e1.exp > 30 - SGL_M1LEFT) {
+ p->ipart = y;
+ p->fpart = 0;
+ return;
+ }
+ b64_sft(&e1.mantissa, 63 - e1.exp);
+ b64_sft(&e1.mantissa, e1.exp - 63); /* "loose" low order bits */
+ compact(&e1,&(p->ipart),sizeof(SINGLE));
+ extend(&(p->ipart), &e2, sizeof(SINGLE));
+ extend(&y, &e1, sizeof(SINGLE));
+ sub_ext(&e1, &e2);
+ compact(&e1, &(p->fpart), sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ MULTIPLY AND DISMEMBER PARTS (FIF 8)
+*/
+
+#include "FP_types.h"
+#include "FP_shift.h"
+
+void
+fif8(p,x,y)
+DOUBLE x,y;
+struct fif8_returns *p;
+{
+
+ EXTEND e1,e2;
+
+ extend(&y.d[0],&e1,sizeof(DOUBLE));
+ extend(&x.d[0],&e2,sizeof(DOUBLE));
+ /* do a multiply */
+ mul_ext(&e1,&e2);
+ e2 = e1;
+ compact(&e2, &y.d[0], sizeof(DOUBLE));
+ if (e1.exp < 0) {
+ p->ipart.d[0] = 0;
+ p->ipart.d[1] = 0;
+ p->fpart = y;
+ return;
+ }
+ if (e1.exp > 62 - DBL_M1LEFT) {
+ p->ipart = y;
+ p->fpart.d[0] = 0;
+ p->fpart.d[1] = 0;
+ return;
+ }
+ b64_sft(&e1.mantissa, 63 - e1.exp);
+ b64_sft(&e1.mantissa, e1.exp - 63); /* "loose" low order bits */
+ compact(&e1, &(p->ipart.d[0]), sizeof(DOUBLE));
+ extend(&(p->ipart.d[0]), &e2, sizeof(DOUBLE));
+ extend(&y.d[0], &e1, sizeof(DOUBLE));
+ sub_ext(&e1, &e2);
+ compact(&e1, &(p->fpart.d[0]), sizeof(DOUBLE));
+}
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+#include "../stdio/loc_incl.h"
+
+int _fp_hook = 1;
+
+char *
+_f_print(va_list *ap, int flags, char *s, char c, int precision)
+{
+ fprintf(stderr,"cannot print floating point\n");
+ exit(EXIT_FAILURE);
+}
--- /dev/null
+/*
+ * fltpr.c - print floating point numbers
+ */
+/* $Header$ */
+
+#ifndef NOFLOAT
+#include <string.h>
+#include <stdarg.h>
+#include "../stdio/loc_incl.h"
+int _fp_hook = 1;
+
+static char *
+_pfloat(long double r, register char *s, int n, int flags)
+{
+ register char *s1;
+ int sign, dp;
+ register int i;
+
+ s1 = _fcvt(r, n, &dp, &sign);
+ if (sign)
+ *s++ = '-';
+ else if (flags & FL_SIGN)
+ *s++ = '+';
+ else if (flags & FL_SPACE)
+ *s++ = ' ';
+
+ if (dp<=0)
+ *s++ = '0';
+ for (i=dp; i>0; i--)
+ if (*s1) *s++ = *s1++;
+ else *s++ = '0';
+ if (((i=n) > 0) || (flags & FL_ALT))
+ *s++ = '.';
+ while (++dp <= 0) {
+ if (--i<0)
+ break;
+ *s++ = '0';
+ }
+ while (--i >= 0)
+ if (*s1) *s++ = *s1++;
+ else *s++ = '0';
+ return s;
+}
+
+static char *
+_pscien(long double r, register char *s, int n, int flags)
+{
+ int sign, dp;
+ register char *s1;
+
+ s1 = _ecvt(r, n + 1, &dp, &sign);
+ if (sign)
+ *s++ = '-';
+ else if (flags & FL_SIGN)
+ *s++ = '+';
+ else if (flags & FL_SPACE)
+ *s++ = ' ';
+
+ *s++ = *s1++;
+ if ((n > 0) || (flags & FL_ALT))
+ *s++ = '.';
+ while (--n >= 0)
+ if (*s1) *s++ = *s1++;
+ else *s++ = '0';
+ *s++ = 'e';
+ if ( r != 0 ) --dp ;
+ if ( dp<0 ) {
+ *s++ = '-' ; dp= -dp ;
+ } else {
+ *s++ = '+' ;
+ }
+ if (dp >= 100) {
+ *s++ = '0' + (dp / 100);
+ dp %= 100;
+ }
+ *s++ = '0' + (dp/10);
+ *s++ = '0' + (dp%10);
+ return s;
+}
+
+#define NDIGINEXP(exp) (((exp) >= 100 || (exp) <= -100) ? 3 : 2)
+#define LOW_EXP -4
+#define USE_EXP(exp, ndigits) (((exp) < LOW_EXP + 1) || (exp >= ndigits + 1))
+
+static char *
+_gcvt(long double value, int ndigit, char *s, int flags)
+{
+ int sign, dp;
+ register char *s1, *s2;
+ register int i;
+ register int nndigit = ndigit;
+
+ s1 = _ecvt(value, ndigit, &dp, &sign);
+ s2 = s;
+ if (sign) *s2++ = '-';
+ else if (flags & FL_SIGN)
+ *s2++ = '+';
+ else if (flags & FL_SPACE)
+ *s2++ = ' ';
+
+ if (!(flags & FL_ALT))
+ for (i = nndigit - 1; i > 0 && s1[i] == '0'; i--)
+ nndigit--;
+
+ if (USE_EXP(dp,ndigit)) {
+ /* Use E format */
+ dp--;
+ *s2++ = *s1++;
+ if ((nndigit > 1) || (flags & FL_ALT)) *s2++ = '.';
+ while (--nndigit > 0) *s2++ = *s1++;
+ *s2++ = 'e';
+ if (dp < 0) {
+ *s2++ = '-';
+ dp = -dp;
+ }
+ else *s2++ = '+';
+ s2 += NDIGINEXP(dp);
+ *s2 = 0;
+ for (i = NDIGINEXP(dp); i > 0; i--) {
+ *--s2 = dp % 10 + '0';
+ dp /= 10;
+ }
+ return s;
+ }
+ /* Use f format */
+ if (dp <= 0) {
+ if (*s1 != '0') {
+ /* otherwise the whole number is 0 */
+ *s2++ = '0';
+ *s2++ = '.';
+ }
+ while (dp < 0) {
+ dp++;
+ *s2++ = '0';
+ }
+ }
+ for (i = 1; i <= nndigit; i++) {
+ *s2++ = *s1++;
+ if (i == dp) *s2++ = '.';
+ }
+ if (i <= dp) {
+ while (i++ <= dp) *s2++ = '0';
+ *s2++ = '.';
+ }
+ if ((s2[-1]=='.') && !(flags & FL_ALT)) s2--;
+ *s2 = '\0';
+ return s;
+}
+
+char *
+_f_print(va_list *ap, int flags, char *s, char c, int precision)
+{
+ register char *old_s = s;
+ long double ld_val;
+
+ if (flags & FL_LONGDOUBLE) ld_val = va_arg(*ap, long double);
+ else ld_val = (long double) va_arg(*ap, double);
+
+ switch(c) {
+ case 'f':
+ s = _pfloat(ld_val, s, precision, flags);
+ break;
+ case 'e':
+ case 'E':
+ s = _pscien(ld_val, s, precision , flags);
+ break;
+ case 'g':
+ case 'G':
+ s = _gcvt(ld_val, precision, s, flags);
+ s += strlen(s);
+ break;
+ }
+ if ( c == 'E' || c == 'G') {
+ while (*old_s && *old_s != 'e') old_s++;
+ if (*old_s == 'e') *old_s = 'E';
+ }
+ return s;
+}
+#endif /* NOFLOAT */
+/* $Header$ */
+
+#include <stdlib.h>
+#include "../ansi/ext_fmt.h"
+
+void _str_ext_cvt(const char *s, char **ss, struct EXTEND *e);
+double _ext_dbl_cvt(struct EXTEND *e);
+
+double
+strtod(const char *p, char **pp)
+{
+ struct EXTEND e;
+
+ _str_ext_cvt(p, pp, &e);
+ return _ext_dbl_cvt(&e);
+}
--- /dev/null
+#
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define __fptrp
+.sect .text
+__fptrp:
+#if __i386
+ push ebp
+ mov ebp, esp
+ mov eax, 8(bp)
+ call .Xtrp
+ leave
+ ret
+#else /* i86 */
+ push bp
+ mov bp, sp
+ mov ax, 4(bp)
+ call .Xtrp
+ jmp .cret
+#endif
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+#include <byte_order.h>
+
+#if CHAR_UNSIGNED
+#define Xchar(ch) (ch)
+#else
+#define Xchar(ch) ((ch) & 0377)
+#endif
+
+#define BYTES_REVERSED (MSB_AT_LOW_ADDRESS != FL_MSB_AT_LOW_ADDRESS)
+#define WORDS_REVERSED (MSW_AT_LOW_ADDRESS != FL_MSW_AT_LOW_ADDRESS)
+#define LONGS_REVERSED (FL_MSL_AT_LOW_ADDRESS)
+
+#if BYTES_REVERSED
+#define uget2(c) (Xchar((c)[1]) | ((unsigned) Xchar((c)[0]) << 8))
+#define Xput2(i, c) (((c)[1] = (i)), ((c)[0] = (i) >> 8))
+#define put2(i, c) { register int j = (i); Xput2(j, c); }
+#else
+#define uget2(c) (* ((unsigned short *) (c)))
+#define Xput2(i, c) (* ((short *) (c)) = (i))
+#define put2(i, c) Xput2(i, c)
+#endif
+
+#define get2(c) ((short) uget2(c))
+
+#if WORDS_REVERSED || BYTES_REVERSED
+#define get4(c) (uget2((c)+2) | ((long) uget2(c) << 16))
+#define put4(l, c) { register long x=(l); \
+ Xput2((int)x,(c)+2); \
+ Xput2((int)(x>>16),(c)); \
+ }
+#else
+#define get4(c) (* ((long *) (c)))
+#define put4(l, c) (* ((long *) (c)) = (l))
+#endif
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ * Multiply Single Precesion Float (MLF 4)
+ */
+
+#include "FP_types.h"
+
+void
+mlf4(s2,s1)
+SINGLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ extend(&s1,&e1,sizeof(SINGLE));
+ extend(&s2,&e2,sizeof(SINGLE));
+ /* do a multiply */
+ mul_ext(&e1,&e2);
+ compact(&e1,&s1,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ * Multiply Double Precision Float (MLF 8)
+ */
+
+#include "FP_types.h"
+
+void
+mlf8(s2,s1)
+DOUBLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ extend(&s1.d[0],&e1,sizeof(DOUBLE));
+ extend(&s2.d[0],&e2,sizeof(DOUBLE));
+ /* do a multiply */
+ mul_ext(&e1,&e2);
+ compact(&e1,&s1.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ROUTINE TO MULTIPLY TWO EXTENDED FORMAT NUMBERS
+*/
+
+# include "FP_bias.h"
+# include "FP_trap.h"
+# include "FP_types.h"
+# include "FP_shift.h"
+
+void
+mul_ext(e1,e2)
+EXTEND *e1,*e2;
+{
+ register int i,j; /* loop control */
+ unsigned short mp[4]; /* multiplier */
+ unsigned short mc[4]; /* multipcand */
+ unsigned short result[8]; /* result */
+ register unsigned short *pres;
+
+ /* first save the sign (XOR) */
+ e1->sign ^= e2->sign;
+
+ /* compute new exponent */
+ e1->exp += e2->exp + 1;
+ /* 128 bit multiply of mantissas */
+
+ /* assign unknown long formats */
+ /* to known unsigned word formats */
+ mp[0] = e1->m1 >> 16;
+ mp[1] = (unsigned short) e1->m1;
+ mp[2] = e1->m2 >> 16;
+ mp[3] = (unsigned short) e1->m2;
+ mc[0] = e2->m1 >> 16;
+ mc[1] = (unsigned short) e2->m1;
+ mc[2] = e2->m2 >> 16;
+ mc[3] = (unsigned short) e2->m2;
+ for (i = 8; i--;) {
+ result[i] = 0;
+ }
+ /*
+ * fill registers with their components
+ */
+ for(i=4, pres = &result[4];i--;pres--) if (mp[i]) {
+ unsigned short k = 0;
+ unsigned long mpi = mp[i];
+ for(j=4;j--;) {
+ unsigned long tmp = (unsigned long)pres[j] + k;
+ if (mc[j]) tmp += mpi * mc[j];
+ pres[j] = tmp;
+ k = tmp >> 16;
+ }
+ pres[-1] = k;
+ }
+ if (! (result[0] & 0x8000)) {
+ e1->exp--;
+ for (i = 0; i <= 3; i++) {
+ result[i] <<= 1;
+ if (result[i+1]&0x8000) result[i] |= 1;
+ }
+ result[4] <<= 1;
+ }
+
+ /*
+ * combine the registers to a total
+ */
+ e1->m1 = ((unsigned long)(result[0]) << 16) + result[1];
+ e1->m2 = ((unsigned long)(result[2]) << 16) + result[3];
+ if (result[4] & 0x8000) {
+ if (++e1->m2 == 0)
+ if (++e1->m1 == 0) {
+ e1->m1 = NORMBIT;
+ e1->exp++;
+ }
+ }
+
+ /* check for overflow */
+ if (e1->exp >= EXT_MAX) {
+ trap(EFOVFL);
+ /* if caught */
+ /* return signed infinity */
+ e1->exp = EXT_MAX;
+infinity: e1->m1 = e1->m2 =0L;
+ return;
+ }
+ /* check for underflow */
+ if (e1->exp < EXT_MIN) {
+ trap(EFUNFL);
+ e1->exp = EXT_MIN;
+ goto infinity;
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ NEGATE A FLOATING POINT (NGF 4)
+*/
+/********************************************************/
+
+#include "FP_types.h"
+#include "get_put.h"
+
+#define OFF ((FL_MSW_AT_LOW_ADDRESS ? 0 : 2) + (FL_MSB_AT_LOW_ADDRESS ? 0 : 1))
+void
+ngf4(f)
+SINGLE f;
+{
+ unsigned char *p;
+
+ if (f != (SINGLE) 0) {
+ p = (unsigned char *) &f + OFF;
+ *p ^= 0x80;
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ NEGATE A FLOATING POINT (NGF 8)
+*/
+/********************************************************/
+
+#include "FP_types.h"
+#include "get_put.h"
+
+#define OFF ((FL_MSL_AT_LOW_ADDRESS ? 0 : 4) + (FL_MSW_AT_LOW_ADDRESS ? 0 : 2) + (FL_MSB_AT_LOW_ADDRESS ? 0 : 1))
+
+void
+ngf8(f)
+DOUBLE f;
+{
+ unsigned char *p;
+
+ if (f.d[0] != 0 || f.d[1] != 0) {
+ p = (unsigned char *) &f + OFF;
+ *p ^= 0x80;
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/********************************************************/
+/*
+ NORMALIZE an EXTENDED FORMAT NUMBER
+*/
+/********************************************************/
+
+#include "FP_shift.h"
+#include "FP_types.h"
+
+void
+nrm_ext(e1)
+EXTEND *e1;
+{
+ /* we assume that the mantissa != 0 */
+ /* if it is then just return */
+ /* to let it be a problem elsewhere */
+ /* THAT IS, The exponent is not set to */
+ /* zero. If we don't test here an */
+ /* infinite loop is generated when */
+ /* mantissa is zero */
+
+ if ((e1->m1 | e1->m2) == 0L)
+ return;
+
+ /* if top word is zero mov low word */
+ /* to top word, adjust exponent value */
+ if (e1->m1 == 0L) {
+ e1->m1 = e1->m2;
+ e1->m2 = 0L;
+ e1->exp -= 32;
+ }
+ if ((e1->m1 & NORMBIT) == 0) {
+ unsigned long l = ((unsigned long)NORMBIT >> 1);
+ int cnt = -1;
+
+ while (! (l & e1->m1)) {
+ l >>= 1;
+ cnt--;
+ }
+ e1->exp += cnt;
+ b64_sft(&(e1->mantissa), cnt);
+ }
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SUBTRACT TWO FLOATS - SINGLE Precision (SBF 4)
+*/
+
+#include "FP_types.h"
+
+void
+sbf4(s2,s1)
+SINGLE s1,s2;
+{
+ EXTEND e1,e2;
+
+ if (s2 == (SINGLE) 0) {
+ return;
+ }
+ extend(&s1,&e1,sizeof(SINGLE));
+ extend(&s2,&e2,sizeof(SINGLE));
+ sub_ext(&e1,&e2);
+ compact(&e1,&s1,sizeof(SINGLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SUBTRACT TWO FLOATS - DOUBLE Precision (SBF 8)
+*/
+
+#include "FP_types.h"
+
+void
+sbf8(s2,s1)
+DOUBLE s1,s2;
+{
+ EXTEND e1, e2;
+
+ if (s2.d[0] == 0 && s2.d[1] == 0) {
+ return;
+ }
+ extend(&s1.d[0],&e1,sizeof(DOUBLE));
+ extend(&s2.d[0],&e2,sizeof(DOUBLE));
+ sub_ext(&e1,&e2);
+ compact(&e1,&s1.d[0],sizeof(DOUBLE));
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SHIFT TWO EXTENDED NUMBERS INTO PROPER
+ ALIGNMENT FOR ADDITION (exponents are equal)
+ Numbers should not be zero on entry.
+*/
+
+#include "FP_types.h"
+
+void
+sft_ext(e1,e2)
+EXTEND *e1,*e2;
+{
+ register EXTEND *s;
+ register int diff;
+
+ diff = e1->exp - e2->exp;
+
+ if (!diff)
+ return; /* exponents are equal */
+
+ if (diff < 0) { /* e2 is larger */
+ /* shift e1 */
+ diff = -diff;
+ s = e1;
+ }
+ else /* e1 is larger */
+ /* shift e2 */
+ s = e2;
+
+ s->exp += diff;
+ b64_sft(&(s->mantissa), diff);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+# include "FP_types.h"
+
+void
+b64_sft(e1,n)
+B64 *e1;
+int n;
+{
+ if (n > 0) {
+ if (n > 63) {
+ e1->l_32 = 0;
+ e1->h_32 = 0;
+ return;
+ }
+ if (n >= 32) {
+ e1->l_32 = e1->h_32;
+ e1->h_32 = 0;
+ n -= 32;
+ }
+ if (n > 0) {
+ e1->l_32 >>= n;
+ if (e1->h_32 != 0) {
+ e1->l_32 |= (e1->h_32 << (32 - n));
+ e1->h_32 >>= n;
+ }
+ }
+ return;
+ }
+ n = -n;
+ if (n > 0) {
+ if (n > 63) {
+ e1->l_32 = 0;
+ e1->h_32 = 0;
+ return;
+ }
+ if (n >= 32) {
+ e1->h_32 = e1->l_32;
+ e1->l_32 = 0;
+ n -= 32;
+ }
+ if (n > 0) {
+ e1->h_32 <<= n;
+ if (e1->l_32 != 0) {
+ e1->h_32 |= (e1->l_32 >> (32 - n));
+ e1->l_32 <<= n;
+ }
+ }
+ }
+}
+
+void
+b64_lsft(e1)
+B64 *e1;
+{
+ /* shift left 1 bit */
+ e1->h_32 <<= 1;
+ if (e1->l_32 & 0x80000000L) e1->h_32 |= 1;
+ e1->l_32 <<= 1;
+}
+
+void
+b64_rsft(e1)
+B64 *e1;
+{
+ /* shift right 1 bit */
+ e1->l_32 >>= 1;
+ if (e1->h_32 & 1) e1->l_32 |= 0x80000000L;
+ e1->h_32 >>= 1;
+}
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+
+double
+strtod(const char *p, char **pp)
+{
+ fprintf(stderr,"cannot print floating point\n");
+ exit(EXIT_FAILURE);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ SUBTRACT 2 EXTENDED FORMAT NUMBERS
+*/
+
+#include "FP_types.h"
+
+void
+sub_ext(e1,e2)
+EXTEND *e1,*e2;
+{
+ if ((e2->m1 | e2->m2) == 0L) {
+ return;
+ }
+ if ((e1->m1 | e1->m2) == 0L) {
+ *e1 = *e2;
+ e1->sign = e2->sign ? 0 : 1;
+ return;
+ }
+ sft_ext(e1, e2);
+ if (e1->sign != e2->sign) {
+ /* e1 - e2 = e1 + (-e2) */
+ if (b64_add(&e1->mantissa,&e2->mantissa)) { /* addition carry */
+ b64_rsft(&e1->mantissa); /* shift mantissa one bit RIGHT */
+ e1->m1 |= 0x80000000L; /* set max bit */
+ e1->exp++; /* increase the exponent */
+ }
+ }
+ else if (e2->m1 > e1->m1 ||
+ (e2->m1 == e1->m1 && e2->m2 > e1->m2)) {
+ /* abs(e2) > abs(e1) */
+ if (e1->m2 > e2->m2) {
+ e2->m1 -= 1; /* carry in */
+ }
+ e2->m1 -= e1->m1;
+ e2->m2 -= e1->m2;
+ *e1 = *e2;
+ e1->sign = e2->sign ? 0 : 1;
+ }
+ else {
+ if (e2->m2 > e1->m2)
+ e1->m1 -= 1; /* carry in */
+ e1->m1 -= e2->m1;
+ e1->m2 -= e2->m2;
+ }
+ nrm_ext(e1);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ return a zero float (ZRF 4)
+*/
+
+#include "FP_types.h"
+
+void
+zrf4(l)
+SINGLE *l;
+{
+ *l = 0L;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ return a zero double (ZRF 8)
+*/
+
+#include "FP_types.h"
+
+void
+zrf8(z)
+DOUBLE *z;
+{
+
+ z->d[0] = 0L;
+ z->d[1] = 0L;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/* $Header$ */
+
+/*
+ ZERO and return EXTEND FORMAT FLOAT
+*/
+
+#include "FP_types.h"
+
+void
+zrf_ext(e)
+EXTEND *e;
+{
+ e->m1 = 0;
+ e->m2 = 0;
+ e->exp = 0;
+ e->sign = 0;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+#define LINO_AD 0
+#define FILN_AD 4
+
+#define LINO (*(int *)(_hol0()+LINO_AD))
+#define FILN (*(char **)(_hol0()+FILN_AD))
+
+#define EARRAY 0
+#define ERANGE 1
+#define ESET 2
+#define EIOVFL 3
+#define EFOVFL 4
+#define EFUNFL 5
+#define EIDIVZ 6
+#define EFDIVZ 7
+#define EIUND 8
+#define EFUND 9
+#define ECONV 10
+
+#define ESTACK 16
+#define EHEAP 17
+#define EILLINS 18
+#define EODDZ 19
+#define ECASE 20
+#define EMEMFLT 21
+#define EBADPTR 22
+#define EBADPC 23
+#define EBADLAE 24
+#define EBADMON 25
+#define EBADLIN 26
+#define EBADGTO 27
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1990 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+
+/* Modula-2 runtime errors */
+
+#define M2_TOOLARGE 64 /* stack of process too large */
+#define M2_TOOMANY 65 /* too many nested traps & handlers */
+#define M2_NORESULT 66 /* no RETURN from procedure function */
+#define M2_UOVFL 67 /* cardinal overflow */
+#define M2_FORCH 68 /* FOR-loop control variable changed */
+#define M2_UUVFL 69 /* cardinal underflow */
+#define M2_INTERNAL 70 /* internal error, should not happen */
+#define M2_UNIXSIG 71 /* unix signal */
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+#define EARGC 64
+#define EEXP 65
+#define ELOG 66
+#define ESQT 67
+#define EASS 68
+#define EPACK 69
+#define EUNPACK 70
+#define EMOD 71
+#define EBADF 72
+#define EFREE 73
+#define EFUNASS 74
+#define EWIDTH 75
+
+#define EWRITEF 96
+#define EREADF 97
+#define EEOF 98
+#define EFTRUNC 99
+#define ERESET 100
+#define EREWR 101
+#define ECLOSE 102
+#define EREAD 103
+#define EWRITE 104
+#define EDIGIT 105
+#define EASCII 106
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+#define WRBIT 0100000
+#define TXTBIT 040000
+#define EOFBIT 020000
+#define ELNBIT 010000
+#define WINDOW 04000
+#define MAGIC 0252
+
+#define PC_BUFLEN 1024
+
+struct file {
+ char *ptr;
+ unsigned flags;
+ char *fname;
+ int ufd;
+ int size;
+ int count;
+ int buflen;
+ char bufadr[PC_BUFLEN];
+};
--- /dev/null
+/*
+ * localmath.h - This header is used by the mathematical library.
+ */
+/* $Header$ */
+
+/* some constants (Hart & Cheney) */
+#define M_PI 3.14159265358979323846264338327950288
+#define M_2PI 6.28318530717958647692528676655900576
+#define M_3PI_4 2.35619449019234492884698253745962716
+#define M_PI_2 1.57079632679489661923132169163975144
+#define M_3PI_8 1.17809724509617246442349126872981358
+#define M_PI_4 0.78539816339744830961566084581987572
+#define M_PI_8 0.39269908169872415480783042290993786
+#define M_1_PI 0.31830988618379067153776752674502872
+#define M_2_PI 0.63661977236758134307553505349005744
+#define M_4_PI 1.27323954473516268615107010698011488
+#define M_E 2.71828182845904523536028747135266250
+#define M_LOG2E 1.44269504088896340735992468100189213
+#define M_LOG10E 0.43429448190325182765112891891660508
+#define M_LN2 0.69314718055994530941723212145817657
+#define M_LN10 2.30258509299404568401799145468436421
+#define M_SQRT2 1.41421356237309504880168872420969808
+#define M_1_SQRT2 0.70710678118654752440084436210484904
+#define M_EULER 0.57721566490153286060651209008240243
+
+/* macros for constructing polynomials */
+#define POLYNOM1(x, a) ((a)[1]*(x)+(a)[0])
+#define POLYNOM2(x, a) (POLYNOM1((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM3(x, a) (POLYNOM2((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM4(x, a) (POLYNOM3((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM5(x, a) (POLYNOM4((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM6(x, a) (POLYNOM5((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM7(x, a) (POLYNOM6((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM8(x, a) (POLYNOM7((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM9(x, a) (POLYNOM8((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM10(x, a) (POLYNOM9((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM11(x, a) (POLYNOM10((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM12(x, a) (POLYNOM11((x),(a)+1)*(x)+(a)[0])
+#define POLYNOM13(x, a) (POLYNOM12((x),(a)+1)*(x)+(a)[0])
+
+#define M_LN_MAX_D (M_LN2 * DBL_MAX_EXP)
+#define M_LN_MIN_D (M_LN2 * (DBL_MIN_EXP - 1))
--- /dev/null
+
+SUBDIRS = em head
+
+include ../../Makefile.ack.inc
--- /dev/null
+
+all:
+ cd em && make
+ cd head && make
+
--- /dev/null
+# Makefile for lib/ack/i386/em.
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE -Was-ack
+
+LIBRARIES = libe
+
+libe_OBJECTS = \
+ em_adf4.o \
+ em_adf8.o \
+ em_adi.o \
+ em_and.o \
+ em_blm.o \
+ em_cff4.o \
+ em_cff8.o \
+ em_cfi.o \
+ em_cfu.o \
+ em_cif4.o \
+ em_cif8.o \
+ em_cii.o \
+ em_cmf4.o \
+ em_cmf8.o \
+ em_cms.o \
+ em_com.o \
+ em_csa4.o \
+ em_csb4.o \
+ em_cuf4.o \
+ em_cuf8.o \
+ em_cuu.o \
+ em_dup.o \
+ em_dvf4.o \
+ em_dvf8.o \
+ em_dvi.o \
+ em_dvu.o \
+ em_error.o \
+ em_exg.o \
+ em_fat.o \
+ em_fef4.o \
+ em_fef8.o \
+ em_fif4.o \
+ em_fif8.o \
+ em_fp8087.o \
+ em_gto.o \
+ em_hol0.o \
+ em_iaar.o \
+ em_ilar.o \
+ em_inn.o \
+ em_ior.o \
+ em_isar.o \
+ em_lar4.o \
+ em_loi.o \
+ em_mlf4.o \
+ em_mlf8.o \
+ em_mli.o \
+ em_mon.o \
+ em_ngf4.o \
+ em_ngf8.o \
+ em_ngi.o \
+ em_nop.o \
+ em_print.o \
+ em_rck.o \
+ em_rmi.o \
+ em_rmu.o \
+ em_rol.o \
+ em_ror.o \
+ em_sar4.o \
+ em_sbf4.o \
+ em_sbf8.o \
+ em_sbi.o \
+ em_set.o \
+ em_sli.o \
+ em_sri.o \
+ em_sti.o \
+ em_stop.o \
+ em_trp.o \
+ em_unknown.o \
+ em_xor.o \
+
+include ../../../Makefile.ack.inc
--- /dev/null
+# Makefile for lib/i386/em.
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE -Was-ack
+CC1 = $(CC) $(CFLAGS) -c
+
+LIBRARY = ../../../libe.a
+all: $(LIBRARY)
+
+OBJECTS = \
+ $(LIBRARY)(em_adf4.o) \
+ $(LIBRARY)(em_adf8.o) \
+ $(LIBRARY)(em_adi.o) \
+ $(LIBRARY)(em_and.o) \
+ $(LIBRARY)(em_blm.o) \
+ $(LIBRARY)(em_cff4.o) \
+ $(LIBRARY)(em_cff8.o) \
+ $(LIBRARY)(em_cfi.o) \
+ $(LIBRARY)(em_cfu.o) \
+ $(LIBRARY)(em_cif4.o) \
+ $(LIBRARY)(em_cif8.o) \
+ $(LIBRARY)(em_cii.o) \
+ $(LIBRARY)(em_cmf4.o) \
+ $(LIBRARY)(em_cmf8.o) \
+ $(LIBRARY)(em_cms.o) \
+ $(LIBRARY)(em_com.o) \
+ $(LIBRARY)(em_csa4.o) \
+ $(LIBRARY)(em_csb4.o) \
+ $(LIBRARY)(em_cuf4.o) \
+ $(LIBRARY)(em_cuf8.o) \
+ $(LIBRARY)(em_cuu.o) \
+ $(LIBRARY)(em_dup.o) \
+ $(LIBRARY)(em_dvf4.o) \
+ $(LIBRARY)(em_dvf8.o) \
+ $(LIBRARY)(em_dvi.o) \
+ $(LIBRARY)(em_dvu.o) \
+ $(LIBRARY)(em_error.o) \
+ $(LIBRARY)(em_exg.o) \
+ $(LIBRARY)(em_fat.o) \
+ $(LIBRARY)(em_fef4.o) \
+ $(LIBRARY)(em_fef8.o) \
+ $(LIBRARY)(em_fif4.o) \
+ $(LIBRARY)(em_fif8.o) \
+ $(LIBRARY)(em_fp8087.o) \
+ $(LIBRARY)(em_gto.o) \
+ $(LIBRARY)(em_hol0.o) \
+ $(LIBRARY)(em_iaar.o) \
+ $(LIBRARY)(em_ilar.o) \
+ $(LIBRARY)(em_inn.o) \
+ $(LIBRARY)(em_ior.o) \
+ $(LIBRARY)(em_isar.o) \
+ $(LIBRARY)(em_lar4.o) \
+ $(LIBRARY)(em_loi.o) \
+ $(LIBRARY)(em_mlf4.o) \
+ $(LIBRARY)(em_mlf8.o) \
+ $(LIBRARY)(em_mli.o) \
+ $(LIBRARY)(em_mon.o) \
+ $(LIBRARY)(em_ngf4.o) \
+ $(LIBRARY)(em_ngf8.o) \
+ $(LIBRARY)(em_ngi.o) \
+ $(LIBRARY)(em_nop.o) \
+ $(LIBRARY)(em_print.o) \
+ $(LIBRARY)(em_rck.o) \
+ $(LIBRARY)(em_rmi.o) \
+ $(LIBRARY)(em_rmu.o) \
+ $(LIBRARY)(em_rol.o) \
+ $(LIBRARY)(em_ror.o) \
+ $(LIBRARY)(em_sar4.o) \
+ $(LIBRARY)(em_sbf4.o) \
+ $(LIBRARY)(em_sbf8.o) \
+ $(LIBRARY)(em_sbi.o) \
+ $(LIBRARY)(em_set.o) \
+ $(LIBRARY)(em_sli.o) \
+ $(LIBRARY)(em_sri.o) \
+ $(LIBRARY)(em_sti.o) \
+ $(LIBRARY)(em_stop.o) \
+ $(LIBRARY)(em_trp.o) \
+ $(LIBRARY)(em_unknown.o) \
+ $(LIBRARY)(em_xor.o) \
+
+$(LIBRARY): $(OBJECTS)
+ aal cr $@ *.o
+ rm *.o
+
+$(LIBRARY)(em_adf4.o): em_adf4.s
+ $(CC1) em_adf4.s
+
+$(LIBRARY)(em_adf8.o): em_adf8.s
+ $(CC1) em_adf8.s
+
+$(LIBRARY)(em_adi.o): em_adi.s
+ $(CC1) em_adi.s
+
+$(LIBRARY)(em_and.o): em_and.s
+ $(CC1) em_and.s
+
+$(LIBRARY)(em_blm.o): em_blm.s
+ $(CC1) em_blm.s
+
+$(LIBRARY)(em_cff4.o): em_cff4.s
+ $(CC1) em_cff4.s
+
+$(LIBRARY)(em_cff8.o): em_cff8.s
+ $(CC1) em_cff8.s
+
+$(LIBRARY)(em_cfi.o): em_cfi.s
+ $(CC1) em_cfi.s
+
+$(LIBRARY)(em_cfu.o): em_cfu.s
+ $(CC1) em_cfu.s
+
+$(LIBRARY)(em_cif4.o): em_cif4.s
+ $(CC1) em_cif4.s
+
+$(LIBRARY)(em_cif8.o): em_cif8.s
+ $(CC1) em_cif8.s
+
+$(LIBRARY)(em_cii.o): em_cii.s
+ $(CC1) em_cii.s
+
+$(LIBRARY)(em_cmf4.o): em_cmf4.s
+ $(CC1) em_cmf4.s
+
+$(LIBRARY)(em_cmf8.o): em_cmf8.s
+ $(CC1) em_cmf8.s
+
+$(LIBRARY)(em_cms.o): em_cms.s
+ $(CC1) em_cms.s
+
+$(LIBRARY)(em_com.o): em_com.s
+ $(CC1) em_com.s
+
+$(LIBRARY)(em_csa4.o): em_csa4.s
+ $(CC1) em_csa4.s
+
+$(LIBRARY)(em_csb4.o): em_csb4.s
+ $(CC1) em_csb4.s
+
+$(LIBRARY)(em_cuf4.o): em_cuf4.s
+ $(CC1) em_cuf4.s
+
+$(LIBRARY)(em_cuf8.o): em_cuf8.s
+ $(CC1) em_cuf8.s
+
+$(LIBRARY)(em_cuu.o): em_cuu.s
+ $(CC1) em_cuu.s
+
+$(LIBRARY)(em_dup.o): em_dup.s
+ $(CC1) em_dup.s
+
+$(LIBRARY)(em_dvf4.o): em_dvf4.s
+ $(CC1) em_dvf4.s
+
+$(LIBRARY)(em_dvf8.o): em_dvf8.s
+ $(CC1) em_dvf8.s
+
+$(LIBRARY)(em_dvi.o): em_dvi.s
+ $(CC1) em_dvi.s
+
+$(LIBRARY)(em_dvu.o): em_dvu.s
+ $(CC1) em_dvu.s
+
+$(LIBRARY)(em_error.o): em_error.s
+ $(CC1) em_error.s
+
+$(LIBRARY)(em_exg.o): em_exg.s
+ $(CC1) em_exg.s
+
+$(LIBRARY)(em_fat.o): em_fat.s
+ $(CC1) em_fat.s
+
+$(LIBRARY)(em_fef4.o): em_fef4.s
+ $(CC1) em_fef4.s
+
+$(LIBRARY)(em_fef8.o): em_fef8.s
+ $(CC1) em_fef8.s
+
+$(LIBRARY)(em_fif4.o): em_fif4.s
+ $(CC1) em_fif4.s
+
+$(LIBRARY)(em_fif8.o): em_fif8.s
+ $(CC1) em_fif8.s
+
+$(LIBRARY)(em_fp8087.o): em_fp8087.s
+ $(CC1) em_fp8087.s
+
+$(LIBRARY)(em_gto.o): em_gto.s
+ $(CC1) em_gto.s
+
+$(LIBRARY)(em_hol0.o): em_hol0.s
+ $(CC1) em_hol0.s
+
+$(LIBRARY)(em_iaar.o): em_iaar.s
+ $(CC1) em_iaar.s
+
+$(LIBRARY)(em_ilar.o): em_ilar.s
+ $(CC1) em_ilar.s
+
+$(LIBRARY)(em_inn.o): em_inn.s
+ $(CC1) em_inn.s
+
+$(LIBRARY)(em_ior.o): em_ior.s
+ $(CC1) em_ior.s
+
+$(LIBRARY)(em_isar.o): em_isar.s
+ $(CC1) em_isar.s
+
+$(LIBRARY)(em_lar4.o): em_lar4.s
+ $(CC1) em_lar4.s
+
+$(LIBRARY)(em_loi.o): em_loi.s
+ $(CC1) em_loi.s
+
+$(LIBRARY)(em_mlf4.o): em_mlf4.s
+ $(CC1) em_mlf4.s
+
+$(LIBRARY)(em_mlf8.o): em_mlf8.s
+ $(CC1) em_mlf8.s
+
+$(LIBRARY)(em_mli.o): em_mli.s
+ $(CC1) em_mli.s
+
+$(LIBRARY)(em_mon.o): em_mon.s
+ $(CC1) em_mon.s
+
+$(LIBRARY)(em_ngf4.o): em_ngf4.s
+ $(CC1) em_ngf4.s
+
+$(LIBRARY)(em_ngf8.o): em_ngf8.s
+ $(CC1) em_ngf8.s
+
+$(LIBRARY)(em_ngi.o): em_ngi.s
+ $(CC1) em_ngi.s
+
+$(LIBRARY)(em_nop.o): em_nop.s
+ $(CC1) em_nop.s
+
+$(LIBRARY)(em_print.o): em_print.s
+ $(CC1) em_print.s
+
+$(LIBRARY)(em_rck.o): em_rck.s
+ $(CC1) em_rck.s
+
+$(LIBRARY)(em_rmi.o): em_rmi.s
+ $(CC1) em_rmi.s
+
+$(LIBRARY)(em_rmu.o): em_rmu.s
+ $(CC1) em_rmu.s
+
+$(LIBRARY)(em_rol.o): em_rol.s
+ $(CC1) em_rol.s
+
+$(LIBRARY)(em_ror.o): em_ror.s
+ $(CC1) em_ror.s
+
+$(LIBRARY)(em_sar4.o): em_sar4.s
+ $(CC1) em_sar4.s
+
+$(LIBRARY)(em_sbf4.o): em_sbf4.s
+ $(CC1) em_sbf4.s
+
+$(LIBRARY)(em_sbf8.o): em_sbf8.s
+ $(CC1) em_sbf8.s
+
+$(LIBRARY)(em_sbi.o): em_sbi.s
+ $(CC1) em_sbi.s
+
+$(LIBRARY)(em_set.o): em_set.s
+ $(CC1) em_set.s
+
+$(LIBRARY)(em_sli.o): em_sli.s
+ $(CC1) em_sli.s
+
+$(LIBRARY)(em_sri.o): em_sri.s
+ $(CC1) em_sri.s
+
+$(LIBRARY)(em_sti.o): em_sti.s
+ $(CC1) em_sti.s
+
+$(LIBRARY)(em_stop.o): em_stop.s
+ $(CC1) em_stop.s
+
+$(LIBRARY)(em_trp.o): em_trp.s
+ $(CC1) em_trp.s
+
+$(LIBRARY)(em_unknown.o): em_unknown.s
+ $(CC1) em_unknown.s
+
+$(LIBRARY)(em_xor.o): em_xor.s
+ $(CC1) em_xor.s
--- /dev/null
+#define CHAR_UNSIGNED 0
+#define MSB_AT_LOW_ADDRESS 0
+#define MSW_AT_LOW_ADDRESS 0
+#define FL_MSB_AT_LOW_ADDRESS 0
+#define FL_MSW_AT_LOW_ADDRESS 0
+#define FL_MSL_AT_LOW_ADDRESS 0
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .adf4
+
+ .sect .text
+.adf4:
+ mov bx,sp
+ flds 4(bx)
+ fadds 8(bx)
+ fstps 8(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .adf8
+
+ .sect .text
+.adf8:
+ mov bx,sp
+ fldd 4(bx)
+ faddd 12(bx)
+ fstpd 12(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .adi
+
+ ! #bytes in ecx , top of stack in eax
+ .sect .text
+.adi:
+ pop ebx ! return address
+ cmp ecx,4
+ jne 9f
+ pop ecx
+ add eax,ecx
+ jmp ebx
+9:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push ebx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .and
+
+ ! #bytes in ecx
+ ! save edi; it might be a register variable
+
+ .sect .text
+.and:
+ pop ebx ! return address
+ mov edx,edi
+ mov edi,esp
+ add edi,ecx
+ sar ecx,2
+1:
+ pop eax
+ and eax,(edi)
+ stos
+ loop 1b
+ mov edi,edx
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .blm
+
+ ! ecx: count in words
+.blm:
+ mov ebx,esp
+ mov eax,esi
+ mov edx,edi
+ mov edi,4(ebx)
+ mov esi,8(ebx)
+ rep movs
+ mov esi,eax
+ mov edi,edx
+ ret 8
+
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cff4
+
+ .sect .text
+.cff4:
+ mov bx,sp
+ fldd 4(bx)
+ fstcw 4(bx)
+ wait
+ mov dx,4(bx)
+ and 4(bx),0xf3ff ! set to rounding mode
+ wait
+ fldcw 4(bx)
+ fstps 8(bx)
+ mov 4(bx),dx
+ wait
+ fldcw 4(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cff8
+
+ .sect .text
+.cff8:
+ mov bx,sp
+ flds 4(bx)
+ fstpd 4(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cfi
+
+ .sect .text
+.cfi:
+ mov bx,sp
+ fstcw 4(bx)
+ wait
+ mov dx,4(bx)
+ or 4(bx),0xc00 ! truncating mode
+ wait
+ fldcw 4(bx)
+ cmp 8(bx),4
+ jne 2f
+ ! loc 4 loc ? cfi
+ flds 12(bx)
+ fistpl 12(bx)
+1:
+ mov 4(bx),dx
+ wait
+ fldcw 4(bx)
+ ret
+2:
+ ! loc 8 loc ? cfi
+ fldd 12(bx)
+ fistpl 16(bx)
+ jmp 1b
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cfu
+
+ .sect .text
+.cfu:
+ mov bx,sp
+ fstcw 4(bx)
+ wait
+ mov dx,4(bx)
+ or 4(bx),0xc00 ! truncating mode
+ wait
+ fldcw 4(bx)
+ cmp 8(bx),4
+ jne 2f
+ ! loc 4 loc ? cfu
+ flds 12(bx)
+ fabs ! ???
+ fiaddl (bigmin)
+ fistpl 12(bx)
+ wait
+ mov ax,12(bx)
+ sub ax,(bigmin)
+ mov 12(bx),ax
+1:
+ mov 4(bx),dx
+ wait
+ fldcw 4(bx)
+ ret
+2:
+ ! loc 8 loc ? cfu
+ fldd 12(bx)
+ fabs ! ???
+ fiaddl (bigmin)
+ fistpl 16(bx)
+ mov ax,16(bx)
+ sub ax,(bigmin)
+ mov 16(bx),ax
+ jmp 1b
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cif4
+
+ .sect .text
+.cif4:
+ mov bx,sp
+ fildl 8(bx)
+ fstps 8(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cif8
+
+ .sect .text
+.cif8:
+ mov bx,sp
+ fildl 8(bx)
+ fstpd 4(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cii
+
+.sect .text
+.cii:
+ pop ebx ! return address
+ ! pop ecx, dest. size
+ ! pop edx, src. size
+ ! eax is source
+ cmp edx,1
+ jne 2f
+ movsxb eax,al
+ mov edx,4
+ jmp 1f
+2:
+ cmp edx,2
+ jne 1f
+ cwde ! convert from 2 to 4 bytes
+ mov edx,4
+1:
+ cmp edx,ecx
+ jne 9f
+ cmp edx,4
+ jne 9f
+ jmp ebx
+9:
+.extern EILLINS
+.extern .fat
+ mov eax,EILLINS
+ push eax
+ jmp .fat
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cmf4
+
+ .sect .text
+.cmf4:
+ mov bx,sp
+ xor cx,cx
+ flds 8(bx)
+ flds 4(bx)
+ fcompp ! compare and pop operands
+ fstsw ax
+ wait
+ sahf
+ je 1f
+ jb 2f
+ dec cx
+ jmp 1f
+2:
+ inc cx
+1:
+ mov ax,cx
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cmf8
+
+ .sect .text
+.cmf8:
+ mov bx,sp
+ xor cx,cx
+ fldd 12(bx)
+ fldd 4(bx)
+ fcompp ! compare and pop operands
+ fstsw ax
+ wait
+ sahf
+ je 1f
+ jb 2f
+ dec cx
+ jmp 1f
+2:
+ inc cx
+1:
+ mov ax,cx
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cms
+
+ ! #bytes in ecx
+ .sect .text
+.cms:
+ pop ebx ! return address
+ mov edx,esp
+ push esi
+ push edi
+ mov esi,edx
+ add edx,ecx
+ mov edi,edx
+ add edx,ecx
+ sar ecx,2
+ repe cmps
+ je 1f
+ inc ecx
+1:
+ pop edi
+ pop esi
+ mov esp,edx
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .com
+
+ ! #bytes in ecx
+ .sect .text
+.com:
+ mov ebx,esp
+ add ebx,4
+ sar ecx,2
+1:
+ not (ebx)
+ add ebx,4
+ loop 1b
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .csa4
+
+.sect .text
+.csa4:
+ ! ebx, descriptor address
+ ! eax, index
+ mov edx,(ebx) ! default
+ sub eax,4(ebx)
+ cmp eax,8(ebx)
+ ja 1f
+ sal eax,2
+ add ebx,eax
+ mov ebx,12(ebx)
+ test ebx,ebx
+ jnz 2f
+1:
+ mov ebx,edx
+ test ebx,ebx
+ jnz 2f
+.extern ECASE
+.extern .fat
+ mov eax,ECASE
+ push eax
+ jmp .fat
+2:
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .csb4
+
+.sect .text
+.csb4:
+ !ebx, descriptor address
+ !eax, index
+ mov edx,(ebx)
+ mov ecx,4(ebx)
+1:
+ add ebx,8
+ dec ecx
+ jl 4f
+ cmp eax,(ebx)
+ jne 1b
+ mov ebx,4(ebx)
+2:
+ test ebx,ebx
+ jnz 3f
+.extern ECASE
+.extern .fat
+ mov eax,ECASE
+ push eax
+ jmp .fat
+3:
+ jmp ebx
+4:
+ mov ebx,edx
+ jmp 2b
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cuf4
+
+ .sect .text
+.cuf4:
+ mov bx,sp
+ fildl 8(bx)
+ cmp 8(bx),0
+ jge 1f
+ fisubl (bigmin)
+ fisubl (bigmin)
+1:
+ fstps 8(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .cuf8
+
+ .sect .text
+.cuf8:
+ mov bx,sp
+ fildl 8(bx)
+ cmp 8(bx),0
+ jge 1f
+ fisubl (bigmin)
+ fisubl (bigmin)
+1:
+ fstpd 4(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .ciu
+.define .cui
+.define .cuu
+
+.sect .text
+.ciu:
+.cui:
+.cuu:
+ pop ebx ! return address
+ ! pop ecx, dest. size
+ ! pop edx, source size
+ ! eax is source
+ cmp edx,ecx
+ jne 8f
+ jmp ebx
+8:
+.extern EILLINS
+.extern .fat
+ mov eax,EILLINS
+ push eax
+ jmp .fat
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .dup
+
+ ! #bytes in ecx
+ .sect .text
+.dup:
+ pop ebx ! return address
+ mov eax,esi
+ mov edx,edi
+ mov esi,esp
+ sub esp,ecx
+ mov edi,esp
+ sar ecx,2
+ rep movs
+ mov esi,eax
+ mov edi,edx
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .dvf4
+
+ .sect .text
+.dvf4:
+ mov bx,sp
+ flds 8(bx)
+ fdivs 4(bx)
+ fstps 8(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .dvf8
+
+ .sect .text
+.dvf8:
+ mov bx,sp
+ fldd 12(bx)
+ fdivd 4(bx)
+ fstpd 12(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .dvi
+
+ ! #bytes in eax
+ .sect .text
+.dvi:
+ pop ebx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ cwd
+ pop ecx
+ idiv ecx
+ push eax
+ jmp ebx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push ebx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .dvu
+
+ ! #bytes in eax
+ .sect .text
+.dvu:
+ pop ebx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ xor edx,edx
+ pop ecx
+ div ecx
+ push eax
+ jmp ebx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push ebx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .error
+.define .Xtrp
+
+ ! eax is trap number
+ ! all registers must be saved
+ ! because return is possible
+ ! May only be called with error no's <16
+.sect .text
+.error:
+ mov ecx,eax
+ mov ebx,1
+ sal ebx,cl
+.extern .ignmask
+.extern .trp
+ test ebx,(.ignmask)
+ jne 2f
+ call .trp
+2:
+ ret
+
+.Xtrp:
+ pusha
+ cmp eax,16
+ jge 1f
+ call .error
+ popa
+ ret
+1:
+ call .trp
+ popa
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .exg
+
+ ! #bytes in ecx
+.sect .text
+.exg:
+ push edi
+ mov edi,esp
+ add edi,8
+ mov ebx,edi
+ add ebx,ecx
+ sar ecx,2
+1:
+ mov eax,(ebx)
+ xchg eax,(edi)
+ mov (ebx),eax
+ add edi,4
+ add ebx,4
+ loop 1b
+2:
+ pop edi
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .fat
+
+.fat:
+.extern .trp
+.extern .stop
+ call .trp
+ call .stop
+ ! no return
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .fef4
+
+ .sect .text
+.fef4:
+ ! this could be simpler, if only the
+ ! fxtract instruction was emulated properly
+ mov bx,sp
+ mov ax,8(bx)
+ and ax,0x7f800000
+ je 1f ! zero exponent
+ shr ax,23
+ sub ax,126
+ mov cx,ax ! exponent in cx
+ mov ax,8(bx)
+ and ax,0x807fffff
+ or ax,0x3f000000 ! load -1 exponent
+ mov bx,4(bx)
+ mov 4(bx),ax
+ mov (bx),cx
+ ret
+1: ! we get here on zero exp
+ mov ax,8(bx)
+ and ax,0x007fffff
+ jne 1f ! zero result
+ mov bx,4(bx)
+ mov (bx),ax
+ mov 4(bx),ax
+ ret
+1: ! otherwise unnormalized number
+ mov cx,8(bx)
+ and cx,0x807fffff
+ mov dx,cx
+ and cx,0x80000000
+ mov ax,-125
+2:
+ test dx,0x800000
+ jne 1f
+ dec ax
+ shl dx,1
+ or dx,cx
+ jmp 2b
+1:
+ mov bx,4(bx)
+ mov (bx),ax
+ and dx,0x807fffff
+ or dx,0x3f000000 ! load -1 exponent
+ mov 4(bx),dx
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .fef8
+
+ .sect .text
+.fef8:
+ ! this could be simpler, if only the
+ ! fxtract instruction was emulated properly
+ mov bx,sp
+ mov ax,12(bx)
+ and ax,0x7ff00000
+ je 1f ! zero exponent
+ shr ax,20
+ sub ax,1022
+ mov cx,ax ! exponent in cx
+ mov ax,12(bx)
+ and ax,0x800fffff
+ or ax,0x3fe00000 ! load -1 exponent
+ mov dx,8(bx)
+ mov bx,4(bx)
+ mov 4(bx),dx
+ mov 8(bx),ax
+ mov (bx),cx
+ ret
+1: ! we get here on zero exp
+ mov ax,12(bx)
+ and ax,0xfffff
+ or ax,8(bx)
+ jne 1f ! zero result
+ mov bx,4(bx)
+ mov (bx),ax
+ mov 4(bx),ax
+ mov 8(bx),ax
+ ret
+1: ! otherwise unnormalized number
+ mov cx,12(bx)
+ and cx,0x800fffff
+ mov dx,cx
+ and cx,0x80000000
+ mov ax,-1021
+2:
+ test dx,0x100000
+ jne 1f
+ dec ax
+ shl 8(bx),1
+ rcl dx,1
+ or dx,cx
+ jmp 2b
+1:
+ and dx,0x800fffff
+ or dx,0x3fe00000 ! load -1 exponent
+ mov cx,8(bx)
+ mov bx,4(bx)
+ mov (bx),ax
+ mov 8(bx),dx
+ mov 4(bx),cx
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .fif4
+
+ .sect .text
+.fif4:
+ mov bx,sp
+ flds 8(bx)
+ fmuls 12(bx) ! multiply
+ fld st ! copy result
+ ftst ! test sign; handle negative separately
+ fstsw ax
+ wait
+ sahf ! result of test in condition codes
+ jb 1f
+ frndint ! this one rounds (?)
+ fcom st(1) ! compare with original; if <=, then OK
+ fstsw ax
+ wait
+ sahf
+ jbe 2f
+ fisubs (one) ! else subtract 1
+ jmp 2f
+1: ! here, negative case
+ frndint ! this one rounds (?)
+ fcom st(1) ! compare with original; if >=, then OK
+ fstsw ax
+ wait
+ sahf
+ jae 2f
+ fiadds (one) ! else add 1
+2:
+ fsub st(1),st ! subtract integer part
+ mov bx,4(bx)
+ fstps (bx)
+ fstps 4(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .fif8
+
+ .sect .text
+.fif8:
+ mov bx,sp
+ fldd 8(bx)
+ fmuld 16(bx) ! multiply
+ fld st ! and copy result
+ ftst ! test sign; handle negative separately
+ fstsw ax
+ wait
+ sahf ! result of test in condition codes
+ jb 1f
+ frndint ! this one rounds (?)
+ fcom st(1) ! compare with original; if <=, then OK
+ fstsw ax
+ wait
+ sahf
+ jbe 2f
+ fisubs (one) ! else subtract 1
+ jmp 2f
+1: ! here, negative case
+ frndint ! this one rounds (?)
+ fcom st(1) ! compare with original; if >=, then OK
+ fstsw ax
+ wait
+ sahf
+ jae 2f
+ fiadds (one) ! else add 1
+2:
+ fsub st(1),st ! subtract integer part
+ mov bx,4(bx)
+ fstpd (bx)
+ fstpd 8(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define one, bigmin
+
+ .sect .rom
+one:
+ .data2 1
+two:
+ .data2 2
+bigmin:
+ .data4 -2147483648
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .gto
+
+.gto:
+ mov ebp,8(ebx)
+ mov esp,4(ebx)
+ jmp (ebx)
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+
+.define hol0
+.sect .data
+hol0:
+ .data4 0, 0
+ .data4 0, 0
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .iaar
+
+.iaar:
+ pop ecx
+ pop edx
+ cmp edx,4
+.extern .unknown
+ jne .unknown
+ pop ebx ! descriptor address
+ pop eax ! index
+ sub eax,(ebx)
+ mul 8(ebx)
+ pop ebx ! array base
+ add ebx,eax
+ push ecx
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .ilar
+
+.ilar:
+ pop ecx
+ pop edx
+.extern .unknown
+ cmp edx,4
+ jne .unknown
+ pop ebx ! descriptor address
+ pop eax ! index
+ push ecx
+.extern .lar4
+ jmp .lar4
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .inn
+
+ ! #bytes in ecx
+ ! bit # in eax
+.inn:
+ xor edx,edx
+ mov ebx,8
+ div ebx
+ mov ebx,esp
+ add ebx,4
+ add ebx,eax
+ cmp eax,ecx
+ jae 1f
+ movb al,(ebx)
+ mov ebx,edx
+ testb al,bits(ebx)
+ jz 1f
+ mov eax,1
+ jmp 2f
+1:
+ xor eax,eax
+2:
+ pop ebx
+ add esp,ecx
+ ! eax is result
+ jmp ebx
+
+ .sect .rom
+bits:
+ .data1 1,2,4,8,16,32,64,128
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .ior
+
+ ! #bytes in ecx
+.ior:
+ pop ebx ! return address
+ mov edx,edi
+ mov edi,esp
+ add edi,ecx
+ sar ecx,2
+1:
+ pop eax
+ or eax,(edi)
+ stos
+ loop 1b
+ mov edi,edx
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .isar
+
+.isar:
+ pop ecx
+ pop eax
+ cmp eax,4
+.extern .unknown
+ jne .unknown
+ pop ebx ! descriptor address
+ pop eax ! index
+ push ecx
+.extern .sar4
+ jmp .sar4
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .lar4
+
+.lar4:
+ ! ebx, descriptor address
+ ! eax, index
+ sub eax,(ebx)
+ mov ecx,8(ebx)
+ imul ecx
+ pop ebx
+ pop edx ! base address
+ add edx,eax
+ sar ecx,1
+ jnb 1f
+ xor eax,eax
+ movb al,(edx)
+ push eax
+ jmp ebx
+1:
+ sar ecx,1
+ jnb 1f
+ xor eax,eax
+ o16 mov ax,(edx)
+ push eax
+ jmp ebx
+1:
+ xchg edx,esi ! saved esi
+ mov eax,ecx
+ sal eax,2
+ sub esp,eax
+ mov eax,edi ! save edi
+ mov edi,esp
+ rep movs
+ mov edi,eax
+ mov esi,edx
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .loi
+.define .los
+
+ ! #bytes in ecx
+ ! address in ebx
+ ! save esi/edi. they might be register variables
+.los:
+ pop edx
+ mov eax,ecx
+ sar ecx,1
+ jnb 1f
+ movsxb eax,(ebx)
+ push eax
+ jmp edx
+1:
+ sar ecx,1
+ jnb 1f
+ movsx eax,(ebx)
+ push eax
+ jmp edx
+1:
+ push edx
+ mov edx,esi
+ mov esi,ebx
+ pop ebx
+ sub esp,eax
+ jmp 1f
+
+.loi:
+ ! only called with size >= 4
+ mov edx,esi
+ mov esi,ebx
+ pop ebx
+ sub esp,ecx
+ sar ecx,2
+1:
+ mov eax,edi
+ mov edi,esp
+ rep movs
+ mov esi,edx
+ mov edi,eax
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .mlf4
+
+ .sect .text
+.mlf4:
+ mov bx,sp
+ flds 4(bx)
+ fmuls 8(bx)
+ fstps 8(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .mlf8
+
+ .sect .text
+.mlf8:
+ mov bx,sp
+ fldd 4(bx)
+ fmuld 12(bx)
+ fstpd 12(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .mli
+
+ ! #bytes in eax
+.mli:
+ pop ebx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ pop ecx
+ mul ecx
+ push eax
+ jmp ebx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push ebx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .mon
+
+.mon:
+.extern .stop
+ call .stop
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .ngf4
+
+ .sect .text
+.ngf4:
+ mov bx,sp
+ flds 4(bx)
+ fchs
+ fstps 4(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .ngf8
+
+ .sect .text
+.ngf8:
+ mov bx,sp
+ fldd 4(bx)
+ fchs
+ fstpd 4(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .ngi
+
+ ! #bytes in eax
+.ngi:
+ pop ebx ! return address
+ cmp eax,4
+ jne 1f
+ pop ecx
+ neg ecx
+ push ecx
+ jmp ebx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push ebx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .nop
+.extern printd, printc, hol0
+
+.nop:
+ mov eax,(hol0)
+ call printd
+ movb al,'\n'
+ jmp printc
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define printc,printd,prints
+
+ ! argument in eax
+ ! uses ebx
+prints:
+ xchg eax,ebx
+1:
+ movb al,(ebx)
+ inc ebx
+ testb al,al
+ jz 2f
+ call printc
+ jmp 1b
+2:
+ ret
+
+ ! argument in eax
+ ! uses ecx and edx
+printd:
+ xor edx,edx
+ mov ecx,10
+ div ecx
+ test eax,eax
+ jz 1f
+ push edx
+ call printd
+ pop edx
+1:
+ xchg eax,edx
+ addb al,'0'
+
+ ! argument in eax
+printc:
+ push eax
+ mov ebx,esp
+ mov eax,1
+ push eax
+ push ebx
+ push eax
+ call __write
+ pop ebx
+ pop ebx
+ pop ebx
+ pop ebx
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .rck
+
+ ! descriptor address in ebx
+ ! value in eax, must be left there
+.rck:
+ cmp eax,(ebx)
+ jl 2f
+ cmp eax,4(ebx)
+ jg 2f
+ ret
+2:
+ push eax
+.extern ERANGE
+.extern .error
+ mov eax,ERANGE
+ call .error
+ pop eax
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .rmi
+
+ ! #bytes in eax
+.rmi:
+ pop ebx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ cwd
+ pop ecx
+ idiv ecx
+ push edx
+ jmp ebx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push ebx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .rmu
+
+ ! #bytes in eax
+.rmu:
+ pop ebx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ xor edx,edx
+ pop ecx
+ idiv ecx
+ push edx
+ jmp ebx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push ebx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .rol
+
+ ! #bytes in eax
+.rol:
+ pop edx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ pop ecx
+ rol eax,cl
+ push eax
+ jmp edx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push edx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .ror
+
+ ! #bytes in eax
+.ror:
+ pop edx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ pop ecx
+ ror eax,cl
+ push eax
+ jmp edx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push edx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .sar4
+
+.sar4:
+ ! ebx, descriptor address
+ ! eax, index
+ sub eax,(ebx)
+ mov ecx,8(ebx)
+ imul ecx
+ pop ebx
+ pop edx ! base address
+ add edx,eax
+ sar ecx,1
+ jnb 1f
+ pop eax
+ movb (edx),al
+ jmp ebx
+1:
+ sar ecx,1
+ jnb 1f
+ pop eax
+ o16 mov (edx),ax
+ jmp ebx
+1:
+ xchg edi,edx ! edi = base address, edx is saved edi
+ mov eax,esi
+ mov esi,esp
+ rep movs
+ mov esp,esi
+ mov esi,eax
+ mov edi,edx
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .sbf4
+
+ .sect .text
+.sbf4:
+ mov bx,sp
+ flds 8(bx)
+ fsubs 4(bx)
+ fstps 8(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define .sbf8
+
+ .sect .text
+.sbf8:
+ mov bx,sp
+ fldd 12(bx)
+ fsubd 4(bx)
+ fstpd 12(bx)
+ wait
+ ret
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .sbi
+
+ ! #bytes in ecx , top of stack in eax
+.sbi:
+ pop ebx ! return subress
+ cmp ecx,4
+ jne 1f
+ pop ecx
+ sub eax,ecx
+ neg eax
+ jmp ebx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push ebx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .set
+
+ ! #bytes in ecx
+ ! bit # in eax
+.set:
+ pop ebx ! return address
+ xor edx,edx
+!ifdef create set
+ sub esp,ecx
+ push ebx
+ push edi
+ mov ebx,esp
+ xor edi,edi
+ sar ecx,2
+1:
+ mov 8(ebx)(edi),edx
+ add edi,4
+ loop 1b
+!endif
+ mov ebx,8
+ div ebx
+ cmp eax,edi
+ jae 2f
+ mov edi,edx
+ movb dl,bits(edi)
+ mov edi,esp
+ add edi,eax
+ orb 8(edi),dl
+ pop edi
+ ret
+2:
+.extern ESET
+.extern .trp
+ pop edi
+ mov eax,ESET
+ jmp .trp
+
+ .sect .rom
+bits:
+ .data1 1,2,4,8,16,32,64,128
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .sli
+
+ ! #bytes in eax
+.sli:
+ pop edx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ pop ecx
+ sal eax,cl
+ push eax
+ jmp edx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push edx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .sri
+
+ ! #bytes in eax
+.sri:
+ pop edx ! return address
+ cmp eax,4
+ jne 1f
+ pop eax
+ pop ecx
+ sar eax,cl
+ push eax
+ jmp edx
+1:
+.extern EODDZ
+.extern .trp
+ mov eax,EODDZ
+ push edx
+ jmp .trp
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .sti
+.define .sts
+
+ ! #bytes in ecx
+ ! address in ebx
+ ! save edi/esi. they might be register variables
+.sts:
+ pop edx
+ sar ecx,1
+ jnb 1f
+ pop eax
+ movb (ebx),al
+ jmp edx
+1:
+ sar ecx,1
+ jnb 1f
+ pop eax
+ o16 mov (ebx),ax
+ jmp edx
+1:
+ push edx
+ mov edx,edi
+ mov edi,ebx
+ pop ebx
+ jmp 1f
+.sti:
+ ! only called with count >> 4
+ mov edx,edi
+ mov edi,ebx
+ pop ebx
+ sar ecx,2
+1:
+ mov eax,esi
+ mov esi,esp
+ rep movs
+ mov esp,esi
+ mov edi,edx
+ mov esi,eax
+ jmp ebx
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .stop
+.stop:
+ jmp ___exit
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .trp
+.extern .trppc, .stop
+
+ ! eax is trap number
+.trp:
+ xor ebx,ebx
+ xchg ebx,(.trppc)
+ test ebx,ebx
+ jz 2f
+ push eax
+ call ebx
+ pop eax
+ ret
+2:
+ push eax
+ call .stop
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .unknown
+.extern EILLINS, .fat
+
+.unknown:
+ mov eax,EILLINS
+ push eax
+ jmp .fat
--- /dev/null
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.sect .text
+.define .xor
+
+ ! #bytes in ecx
+.xor:
+ pop ebx ! return address
+ mov edx,edi
+ mov edi,esp
+ add edi,ecx
+ sar ecx,2
+1:
+ pop eax
+ xor eax,(edi)
+ stos
+ loop 1b
+ mov edi,edx
+ jmp ebx
--- /dev/null
+# Makefile for lib/ack/i386/head.
+
+ASFLAGS = -I.
+
+LIBRARIES = libe
+
+libe_OBJECTS = em_head.o
+
+include ../../../Makefile.ack.inc
--- /dev/null
+# Makefile for lib/i386/head.
+
+CC1 = $(CC) -Was-ack -c -I$(SRCDIR)/$(SUBDIR)
+
+LIBRARY = ../../../libe.a
+all: $(LIBRARY)
+
+$(LIBRARY): $(LIBRARY)(em_head.o)
+ aal cr $@ *.o
+ rm *.o
+
+$(LIBRARY)(em_head.o): em_head.s
+ $(CC1) -I. em_head.s
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+#define LINO_AD 0
+#define FILN_AD 4
+
+#define LINO (*(int *)(_hol0()+LINO_AD))
+#define FILN (*(char **)(_hol0()+FILN_AD))
+
+#define EARRAY 0
+#define ERANGE 1
+#define ESET 2
+#define EIOVFL 3
+#define EFOVFL 4
+#define EFUNFL 5
+#define EIDIVZ 6
+#define EFDIVZ 7
+#define EIUND 8
+#define EFUND 9
+#define ECONV 10
+
+#define ESTACK 16
+#define EHEAP 17
+#define EILLINS 18
+#define EODDZ 19
+#define ECASE 20
+#define EMEMFLT 21
+#define EBADPTR 22
+#define EBADPC 23
+#define EBADLAE 24
+#define EBADMON 25
+#define EBADLIN 26
+#define EBADGTO 27
--- /dev/null
+#
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.define ERANGE,ESET,EHEAP,ECASE,EILLINS,EIDIVZ,EODDZ
+.define .trppc, .ignmask
+
+ERANGE = 1
+ESET = 2
+EIDIVZ = 6
+EHEAP = 17
+EILLINS = 18
+EODDZ = 19
+ECASE = 20
+
+#include <em_abs.h>
+
+.sect .data
+.trppc:
+ .data4 0
+.ignmask:
+ .data4 EIOVFL | EIUND | ECONV | EFOVFL | EFUNFL
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: Access to program arguments and environment
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+extern char **argv, ***_penviron;
+extern int argc;
+unsigned int _Arguments__Argc;
+
+static char *
+findname(s1, s2)
+register char *s1, *s2;
+{
+
+ while (*s1 == *s2++) s1++;
+ if (*s1 == '\0' && *(s2-1) == '=') return s2;
+ return 0;
+}
+
+static unsigned int
+scopy(src, dst, max)
+ register char *src, *dst;
+ unsigned int max;
+{
+ register unsigned int i = 0;
+
+ while (*src && i <= max) {
+ i++;
+ *dst++ = *src++;
+ }
+ if (i <= max) {
+ *dst = '\0';
+ return i+1;
+ }
+ while (*src++) i++;
+ return i + 1;
+}
+
+_Arguments_()
+{
+ _Arguments__Argc = argc;
+}
+
+unsigned
+_Arguments__Argv(n, argument, l, u, s)
+ unsigned int u;
+ char *argument;
+{
+
+ if (n >= argc) return 0;
+ return scopy(argv[n], argument, u);
+}
+
+unsigned
+_Arguments__GetEnv(name, nn, nu, ns, value, l, u, s)
+ char *name, *value;
+ unsigned int nu, u;
+{
+ register char **p = *_penviron;
+ register char *v = 0;
+
+ while (*p && !(v = findname(name, *p++))) {
+ /* nothing */
+ }
+ if (!v) return 0;
+ return scopy(v, value, u);
+}
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE ArraySort;
+(*
+ Module: Array sorting module.
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+ FROM SYSTEM IMPORT ADDRESS, BYTE; (* no generics in Modula-2, sorry *)
+
+ TYPE BytePtr = POINTER TO BYTE;
+
+ VAR compareproc: CompareProc;
+
+ PROCEDURE Sort(base: ADDRESS; (* address of array *)
+ nel: CARDINAL; (* number of elements in array *)
+ size: CARDINAL; (* size of each element *)
+ compar: CompareProc); (* the comparison procedure *)
+ BEGIN
+ compareproc := compar;
+ qsort(base, base+(nel-1)*size, size);
+ END Sort;
+
+ PROCEDURE qsort(a1, a2: ADDRESS; size: CARDINAL);
+ (* Implemented with quick-sort, with some extra's *)
+ VAR left, right, lefteq, righteq: ADDRESS;
+ cmp: CompareResult;
+ mainloop: BOOLEAN;
+ BEGIN
+ WHILE a2 > a1 DO
+ left := a1;
+ right := a2;
+ lefteq := a1 + size * (((a2 - a1) + size) DIV (2 * size));
+ righteq := lefteq;
+ (*
+ Pick an element in the middle of the array.
+ We will collect the equals around it.
+ "lefteq" and "righteq" indicate the left and right
+ bounds of the equals respectively.
+ Smaller elements end up left of it, larger elements end
+ up right of it.
+ *)
+ LOOP
+ LOOP
+ IF left >= lefteq THEN EXIT END;
+ cmp := compareproc(left, lefteq);
+ IF cmp = greater THEN EXIT END;
+ IF cmp = less THEN
+ left := left + size;
+ ELSE
+ (* equal, so exchange with the element
+ to the left of the "equal"-interval.
+ *)
+ lefteq := lefteq - size;
+ exchange(left, lefteq, size);
+ END;
+ END;
+ mainloop := FALSE;
+ LOOP
+ IF right <= righteq THEN EXIT END;
+ cmp := compareproc(right, righteq);
+ IF cmp = less THEN
+ IF left < lefteq THEN
+ (* larger one at the left,
+ so exchange
+ *)
+ exchange(left,right,size);
+ left := left + size;
+ right := right - size;
+ mainloop := TRUE;
+ EXIT;
+ END;
+ (*
+ no more room at the left part, so we
+ move the "equal-interval" one place to the
+ right, and the smaller element to the
+ left of it.
+ This is best expressed as a three-way
+ exchange.
+ *)
+ righteq := righteq + size;
+ threewayexchange(left, righteq, right,
+ size);
+ lefteq := lefteq + size;
+ left := lefteq;
+ ELSIF cmp = equal THEN
+ (* equal, zo exchange with the element
+ to the right of the "equal"
+ interval
+ *)
+ righteq := righteq + size;
+ exchange(right, righteq, size);
+ ELSE
+ (* leave it where it is *)
+ right := right - size;
+ END;
+ END;
+ IF (NOT mainloop) THEN
+ IF left >= lefteq THEN
+ (* sort "smaller" part *)
+ qsort(a1, lefteq - size, size);
+ (* and now the "larger" part, saving a
+ procedure call, because of this big
+ WHILE loop
+ *)
+ a1 := righteq + size;
+ EXIT; (* from the LOOP *)
+ END;
+ (* larger element to the left, but no more room,
+ so move the "equal-interval" one place to the
+ left, and the larger element to the right
+ of it.
+ *)
+ lefteq := lefteq - size;
+ threewayexchange(right, lefteq, left, size);
+ righteq := righteq - size;
+ right := righteq;
+ END;
+ END;
+ END;
+ END qsort;
+
+ PROCEDURE exchange(a,b: BytePtr; size : CARDINAL);
+ VAR c: BYTE;
+ BEGIN
+ WHILE size > 0 DO
+ DEC(size);
+ c := a^;
+ a^ := b^;
+ a := ADDRESS(a) + 1;
+ b^ := c;
+ b := ADDRESS(b) + 1;
+ END;
+ END exchange;
+
+ PROCEDURE threewayexchange(p,q,r: BytePtr; size: CARDINAL);
+ VAR c: BYTE;
+ BEGIN
+ WHILE size > 0 DO
+ DEC(size);
+ c := p^;
+ p^ := r^;
+ p := ADDRESS(p) + 1;
+ r^ := q^;
+ r := ADDRESS(r) + 1;
+ q^ := c;
+ q := ADDRESS(q) + 1;
+ END;
+ END threewayexchange;
+
+END ArraySort.
--- /dev/null
+(*$R-*)
+IMPLEMENTATION MODULE CSP;
+(*
+ Module: Communicating Sequential Processes
+ From: "A Modula-2 Implementation of CSP",
+ M. Collado, R. Morales, J.J. Moreno,
+ SIGPlan Notices, Volume 22, Number 6, June 1987.
+ Some modifications by Ceriel J.H. Jacobs
+ Version: $Header$
+
+ See this article for an explanation of the use of this module.
+*)
+
+ FROM random IMPORT Uniform;
+ FROM SYSTEM IMPORT BYTE, ADDRESS, NEWPROCESS, TRANSFER;
+ FROM Storage IMPORT Allocate, Deallocate;
+ FROM Traps IMPORT Message;
+
+ CONST WorkSpaceSize = 2000;
+
+ TYPE ByteAddress = POINTER TO BYTE;
+ Channel = POINTER TO ChannelDescriptor;
+ ProcessType = POINTER TO ProcessDescriptor;
+ ProcessDescriptor = RECORD
+ next: ProcessType;
+ father: ProcessType;
+ cor: ADDRESS;
+ wsp: ADDRESS;
+ guardindex: INTEGER;
+ guardno: CARDINAL;
+ guardcount: CARDINAL;
+ opened: Channel;
+ sons: CARDINAL;
+ msgadr: ADDRESS;
+ msglen: CARDINAL;
+ END;
+
+ Queue = RECORD
+ head, tail: ProcessType;
+ END;
+
+ ChannelDescriptor = RECORD
+ senders: Queue;
+ owner: ProcessType;
+ guardindex: INTEGER;
+ next: Channel;
+ END;
+
+ VAR cp: ProcessType;
+ free, ready: Queue;
+
+(* ------------ Private modules and procedures ------------- *)
+
+ MODULE ProcessQueue;
+
+ IMPORT ProcessType, Queue;
+ EXPORT Push, Pop, InitQueue, IsEmpty;
+
+ PROCEDURE InitQueue(VAR q: Queue);
+ BEGIN
+ WITH q DO
+ head := NIL;
+ tail := NIL
+ END
+ END InitQueue;
+
+ PROCEDURE Push(p: ProcessType; VAR q: Queue);
+ BEGIN
+ p^.next := NIL;
+ WITH q DO
+ IF head = NIL THEN
+ tail := p
+ ELSE
+ head^.next := p
+ END;
+ head := p
+ END
+ END Push;
+
+ PROCEDURE Pop(VAR q: Queue; VAR p: ProcessType);
+ BEGIN
+ WITH q DO
+ p := tail;
+ IF p # NIL THEN
+ tail := tail^.next;
+ IF head = p THEN
+ head := NIL
+ END
+ END
+ END
+ END Pop;
+
+ PROCEDURE IsEmpty(q: Queue): BOOLEAN;
+ BEGIN
+ RETURN q.head = NIL
+ END IsEmpty;
+
+ END ProcessQueue;
+
+
+ PROCEDURE DoTransfer;
+ VAR aux: ProcessType;
+ BEGIN
+ aux := cp;
+ Pop(ready, cp);
+ IF cp = NIL THEN
+ HALT
+ ELSE
+ TRANSFER(aux^.cor, cp^.cor)
+ END
+ END DoTransfer;
+
+ PROCEDURE OpenChannel(ch: Channel; n: INTEGER);
+ BEGIN
+ WITH ch^ DO
+ IF guardindex = 0 THEN
+ guardindex := n;
+ next := cp^.opened;
+ cp^.opened := ch
+ END
+ END
+ END OpenChannel;
+
+ PROCEDURE CloseChannels(p: ProcessType);
+ BEGIN
+ WITH p^ DO
+ WHILE opened # NIL DO
+ opened^.guardindex := 0;
+ opened := opened^.next
+ END
+ END
+ END CloseChannels;
+
+ PROCEDURE ThereAreOpenChannels(): BOOLEAN;
+ BEGIN
+ RETURN cp^.opened # NIL;
+ END ThereAreOpenChannels;
+
+ PROCEDURE Sending(ch: Channel): BOOLEAN;
+ BEGIN
+ RETURN NOT IsEmpty(ch^.senders)
+ END Sending;
+
+(* -------------- Public Procedures ----------------- *)
+
+ PROCEDURE COBEGIN;
+ (* Beginning of a COBEGIN .. COEND structure *)
+ BEGIN
+ END COBEGIN;
+
+ PROCEDURE COEND;
+ (* End of a COBEGIN .. COEND structure *)
+ (* VAR aux: ProcessType; *)
+ BEGIN
+ IF cp^.sons > 0 THEN
+ DoTransfer
+ END
+ END COEND;
+
+ PROCEDURE StartProcess(P: PROC);
+ (* Start an anonimous process that executes the procedure P *)
+ VAR newprocess: ProcessType;
+ BEGIN
+ Pop(free, newprocess);
+ IF newprocess = NIL THEN
+ Allocate(newprocess,SIZE(ProcessDescriptor));
+ Allocate(newprocess^.wsp, WorkSpaceSize)
+ END;
+ WITH newprocess^ DO
+ father := cp;
+ sons := 0;
+ msglen := 0;
+ NEWPROCESS(P, wsp, WorkSpaceSize, cor)
+ END;
+ cp^.sons := cp^.sons + 1;
+ Push(newprocess, ready)
+ END StartProcess;
+
+ PROCEDURE StopProcess;
+ (* Terminate a Process (itself) *)
+ VAR aux: ProcessType;
+ BEGIN
+ aux := cp^.father;
+ aux^.sons := aux^.sons - 1;
+ IF aux^.sons = 0 THEN
+ Push(aux, ready)
+ END;
+ aux := cp;
+ Push(aux, free);
+ Pop(ready, cp);
+ IF cp = NIL THEN
+ HALT
+ ELSE
+ TRANSFER(aux^.cor, cp^.cor)
+ END
+ END StopProcess;
+
+ PROCEDURE InitChannel(VAR ch: Channel);
+ (* Initialize the channel ch *)
+ BEGIN
+ Allocate(ch, SIZE(ChannelDescriptor));
+ WITH ch^ DO
+ InitQueue(senders);
+ owner := NIL;
+ next := NIL;
+ guardindex := 0
+ END
+ END InitChannel;
+
+ PROCEDURE GetChannel(ch: Channel);
+ (* Assign the channel ch to the process that gets it *)
+ BEGIN
+ WITH ch^ DO
+ IF owner # NIL THEN
+ Message("Channel already has an owner");
+ HALT
+ END;
+ owner := cp
+ END
+ END GetChannel;
+
+ PROCEDURE Send(data: ARRAY OF BYTE; VAR ch: Channel);
+ (* Send a message with the data to the cvhannel ch *)
+ VAR m: ByteAddress;
+ (* aux: ProcessType; *)
+ i: CARDINAL;
+ BEGIN
+ WITH ch^ DO
+ Push(cp, senders);
+ Allocate(cp^.msgadr, SIZE(data));
+ m := cp^.msgadr;
+ cp^.msglen := HIGH(data);
+ FOR i := 0 TO HIGH(data) DO
+ m^ := data[i];
+ m := ADDRESS(m) + 1
+ END;
+ IF guardindex # 0 THEN
+ owner^.guardindex := guardindex;
+ CloseChannels(owner);
+ Push(owner, ready)
+ END
+ END;
+ DoTransfer
+ END Send;
+
+ PROCEDURE Receive(VAR ch: Channel; VAR dest: ARRAY OF BYTE);
+ (* Receive a message from the channel ch into the dest variable *)
+ VAR aux: ProcessType;
+ m: ByteAddress;
+ i: CARDINAL;
+ BEGIN
+ WITH ch^ DO
+ IF cp # owner THEN
+ Message("Only owner of channel can receive from it");
+ HALT
+ END;
+ IF Sending(ch) THEN
+ Pop(senders, aux);
+ m := aux^.msgadr;
+ FOR i := 0 TO aux^.msglen DO
+ dest[i] := m^;
+ m := ADDRESS(m) + 1
+ END;
+ Push(aux, ready);
+ Push(cp, ready);
+ CloseChannels(cp)
+ ELSE
+ OpenChannel(ch, -1);
+ DoTransfer;
+ Pop(senders, aux);
+ m := aux^.msgadr;
+ FOR i := 0 TO aux^.msglen DO
+ dest[i] := m^;
+ m := ADDRESS(m) + 1
+ END;
+ Push(cp, ready);
+ Push(aux, ready)
+ END;
+ Deallocate(aux^.msgadr, aux^.msglen+1);
+ DoTransfer
+ END
+ END Receive;
+
+ PROCEDURE SELECT(n: CARDINAL);
+ (* Beginning of a SELECT structure with n guards *)
+ BEGIN
+ cp^.guardindex := Uniform(1,n);
+ cp^.guardno := n;
+ cp^.guardcount := n
+ END SELECT;
+
+ PROCEDURE NEXTGUARD(): CARDINAL;
+ (* Returns an index to the next guard to be evaluated in a SELECT *)
+ BEGIN
+ RETURN cp^.guardindex
+ END NEXTGUARD;
+
+ PROCEDURE GUARD(cond: BOOLEAN; ch: Channel;
+ VAR dest: ARRAY OF BYTE): BOOLEAN;
+ (* Evaluates a guard, including reception management *)
+ (* VAR aux: ProcessType; *)
+ BEGIN
+ IF NOT cond THEN
+ RETURN FALSE
+ ELSIF ch = NIL THEN
+ CloseChannels(cp);
+ cp^.guardindex := 0;
+ RETURN TRUE
+ ELSIF Sending(ch) THEN
+ Receive(ch, dest);
+ cp^.guardindex := 0;
+ RETURN TRUE
+ ELSE
+ OpenChannel(ch, cp^.guardindex);
+ RETURN FALSE
+ END
+ END GUARD;
+
+ PROCEDURE ENDSELECT(): BOOLEAN;
+ (* End of a SELECT structure *)
+ BEGIN
+ WITH cp^ DO
+ IF guardindex <= 0 THEN
+ RETURN TRUE
+ END;
+ guardcount := guardcount - 1;
+ IF guardcount # 0 THEN
+ guardindex := (guardindex MOD INTEGER(guardno)) + 1
+ ELSIF ThereAreOpenChannels() THEN
+ DoTransfer
+ ELSE
+ guardindex := 0
+ END
+ END;
+ RETURN FALSE
+ END ENDSELECT;
+
+BEGIN
+ InitQueue(free);
+ InitQueue(ready);
+ Allocate(cp,SIZE(ProcessDescriptor));
+ WITH cp^ DO
+ sons := 0;
+ father := NIL
+ END
+END CSP.
+
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Conversions;
+(*
+ Module: numeric-to-string conversions
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ PROCEDURE ConvertNum(num, len, base: CARDINAL;
+ neg: BOOLEAN;
+ VAR str: ARRAY OF CHAR);
+ VAR i: CARDINAL;
+ r: CARDINAL;
+ tmp: ARRAY [0..20] OF CHAR;
+ BEGIN
+ i := 0;
+ REPEAT
+ r := num MOD base;
+ num := num DIV base;
+ IF r <= 9 THEN
+ tmp[i] := CHR(r + ORD('0'));
+ ELSE
+ tmp[i] := CHR(r - 10 + ORD('A'));
+ END;
+ INC(i);
+ UNTIL num = 0;
+ IF neg THEN
+ tmp[i] := '-';
+ INC(i)
+ END;
+ IF len > HIGH(str) + 1 THEN len := HIGH(str) + 1; END;
+ IF i > HIGH(str) + 1 THEN i := HIGH(str) + 1; END;
+ r := 0;
+ WHILE len > i DO str[r] := ' '; INC(r); DEC(len); END;
+ WHILE i > 0 DO str[r] := tmp[i-1]; DEC(i); INC(r); END;
+ WHILE r <= HIGH(str) DO
+ str[r] := 0C;
+ INC(r);
+ END;
+ END ConvertNum;
+
+ PROCEDURE ConvertOctal(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
+ BEGIN
+ ConvertNum(num, len, 8, FALSE, str);
+ END ConvertOctal;
+
+ PROCEDURE ConvertHex(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
+ BEGIN
+ ConvertNum(num, len, 16, FALSE, str);
+ END ConvertHex;
+
+ PROCEDURE ConvertCardinal(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
+ BEGIN
+ ConvertNum(num, len, 10, FALSE, str);
+ END ConvertCardinal;
+
+ PROCEDURE ConvertInteger(num: INTEGER;
+ len: CARDINAL;
+ VAR str: ARRAY OF CHAR);
+ BEGIN
+ IF (num < 0) AND (num >= -MAX(INTEGER)) THEN
+ ConvertNum(-num, len, 10, TRUE, str);
+ ELSE
+ ConvertNum(CARDINAL(num), len, 10, num < 0, str);
+ END;
+ END ConvertInteger;
+
+END Conversions.
--- /dev/null
+#
+;
+; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+; See the copyright notice in the ACK home directory, in the file "Copyright".
+;
+;
+; Module: Interface to some EM instructions and data
+; Author: Ceriel J.H. Jacobs
+; Version: $Header$
+;
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+#define ARG1 0
+#define ARG2 _EM_DSIZE
+#define IRES 2*_EM_DSIZE
+
+; FIF is called with three parameters:
+; - address of integer part result (IRES)
+; - float two (ARG2)
+; - float one (ARG1)
+; and returns an _EM_DSIZE-byte floating point number
+; Definition:
+; PROCEDURE FIF(ARG1, ARG2: LONGREAL; VAR IRES: LONGREAL) : LONGREAL;
+
+ exp $FIF
+ pro $FIF,0
+ lal 0
+ loi 2*_EM_DSIZE
+ fif _EM_DSIZE
+ lal IRES
+ loi _EM_PSIZE
+ sti _EM_DSIZE
+ ret _EM_DSIZE
+ end ?
+
+#define FARG 0
+#define ERES _EM_DSIZE
+
+; FEF is called with two parameters:
+; - address of base 2 exponent result (ERES)
+; - floating point number to be split (FARG)
+; and returns an _EM_DSIZE-byte floating point number (the mantissa)
+; Definition:
+; PROCEDURE FEF(FARG: LONGREAL; VAR ERES: integer): LONGREAL;
+
+ exp $FEF
+ pro $FEF,0
+ lal FARG
+ loi _EM_DSIZE
+ fef _EM_DSIZE
+ lal ERES
+ loi _EM_PSIZE
+ sti _EM_WSIZE
+ ret _EM_DSIZE
+ end ?
+
+#define TRAP 0
+
+; TRP is called with one parameter:
+; - trap number (TRAP)
+; Definition:
+; PROCEDURE TRP(trapno: INTEGER);
+
+ exp $TRP
+ pro $TRP, 0
+ lol TRAP
+ trp
+ ret 0
+ end ?
+
+#define PROC 0
+
+; SIG is called with one parameter:
+; - procedure instance identifier (PROC)
+; and returns the old traphandler.
+
+ exa handler
+ exp $SIG
+ pro $SIG, 0
+ lae handler
+ loi _EM_PSIZE
+ lal PROC
+ loi _EM_PSIZE
+ lae handler
+ sti _EM_PSIZE
+ ret _EM_PSIZE
+ end ?
+
+ exp $LINO
+ pro $LINO,0
+ loe 0
+ ret _EM_WSIZE
+ end ?
+
+ exp $FILN
+ pro $FILN,0
+ lae 4
+ loi _EM_PSIZE
+ ret _EM_PSIZE
+ end ?
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE InOut ;
+(*
+ Module: Wirth's Input/Output module
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ IMPORT Streams;
+ FROM Conversions IMPORT
+ ConvertCardinal, ConvertInteger,
+ ConvertOctal, ConvertHex;
+ FROM Traps IMPORT Message;
+
+ CONST TAB = 11C;
+
+ TYPE numbuf = ARRAY[0..255] OF CHAR;
+
+ VAR unread: BOOLEAN;
+ unreadch: CHAR;
+ CurrIn, CurrOut: Streams.Stream;
+ result: Streams.StreamResult;
+
+ PROCEDURE Read(VAR c : CHAR);
+
+ BEGIN
+ IF unread THEN
+ unread := FALSE;
+ c := unreadch;
+ Done := TRUE;
+ ELSE
+ Streams.Read(CurrIn, c, result);
+ Done := result = Streams.succeeded;
+ END;
+ END Read;
+
+ PROCEDURE UnRead(ch: CHAR);
+ BEGIN
+ unread := TRUE;
+ unreadch := ch;
+ END UnRead;
+
+ PROCEDURE Write(c: CHAR);
+ BEGIN
+ Streams.Write(CurrOut, c, result);
+ END Write;
+
+ PROCEDURE OpenInput(defext: ARRAY OF CHAR);
+ VAR namebuf : ARRAY [1..128] OF CHAR;
+ BEGIN
+ IF CurrIn # Streams.InputStream THEN
+ Streams.CloseStream(CurrIn, result);
+ END;
+ MakeFileName("Name of input file: ", defext, namebuf);
+ IF NOT Done THEN RETURN; END;
+ openinput(namebuf);
+ END OpenInput;
+
+ PROCEDURE OpenInputFile(filename: ARRAY OF CHAR);
+ BEGIN
+ IF CurrIn # Streams.InputStream THEN
+ Streams.CloseStream(CurrIn, result);
+ END;
+ openinput(filename);
+ END OpenInputFile;
+
+ PROCEDURE openinput(namebuf: ARRAY OF CHAR);
+ BEGIN
+ IF (namebuf[0] = '-') AND (namebuf[1] = 0C) THEN
+ CurrIn := Streams.InputStream;
+ Done := TRUE;
+ ELSE
+ Streams.OpenStream(CurrIn, namebuf, Streams.text,
+ Streams.reading, result);
+ Done := result = Streams.succeeded;
+ END;
+ END openinput;
+
+ PROCEDURE CloseInput;
+ BEGIN
+ IF CurrIn # Streams.InputStream THEN
+ Streams.CloseStream(CurrIn, result);
+ END;
+ CurrIn := Streams.InputStream;
+ END CloseInput;
+
+ PROCEDURE OpenOutput(defext: ARRAY OF CHAR);
+ VAR namebuf : ARRAY [1..128] OF CHAR;
+ BEGIN
+ IF CurrOut # Streams.OutputStream THEN
+ Streams.CloseStream(CurrOut, result);
+ END;
+ MakeFileName("Name of output file: ", defext, namebuf);
+ IF NOT Done THEN RETURN; END;
+ openoutput(namebuf);
+ END OpenOutput;
+
+ PROCEDURE OpenOutputFile(filename: ARRAY OF CHAR);
+ BEGIN
+ IF CurrOut # Streams.OutputStream THEN
+ Streams.CloseStream(CurrOut, result);
+ END;
+ openoutput(filename);
+ END OpenOutputFile;
+
+ PROCEDURE openoutput(namebuf: ARRAY OF CHAR);
+ BEGIN
+ IF (namebuf[1] = '-') AND (namebuf[2] = 0C) THEN
+ CurrOut := Streams.OutputStream;
+ Done := TRUE;
+ ELSE
+ Streams.OpenStream(CurrOut, namebuf, Streams.text,
+ Streams.writing, result);
+ Done := result = Streams.succeeded;
+ END;
+ END openoutput;
+
+ PROCEDURE CloseOutput;
+ BEGIN
+ IF CurrOut # Streams.OutputStream THEN
+ Streams.CloseStream(CurrOut, result);
+ END;
+ CurrOut := Streams.OutputStream;
+ END CloseOutput;
+
+ PROCEDURE MakeFileName(prompt, defext : ARRAY OF CHAR;
+ VAR buf : ARRAY OF CHAR);
+ VAR i : INTEGER;
+ j : CARDINAL;
+ BEGIN
+ Done := TRUE;
+ IF Streams.isatty(Streams.InputStream, result) THEN
+ XWriteString(prompt);
+ END;
+ XReadString(buf);
+ i := 0;
+ WHILE buf[i] # 0C DO i := i + 1 END;
+ IF i # 0 THEN
+ i := i - 1;
+ IF buf[i] = '.' THEN
+ FOR j := 0 TO HIGH(defext) DO
+ i := i + 1;
+ buf[i] := defext[j];
+ END;
+ buf[i+1] := 0C;
+ END;
+ RETURN;
+ END;
+ Done := FALSE;
+ END MakeFileName;
+
+ PROCEDURE ReadInt(VAR integ : INTEGER);
+ CONST
+ SAFELIMITDIV10 = MAX(INTEGER) DIV 10;
+ SAFELIMITREM10 = MAX(INTEGER) MOD 10;
+ TYPE
+ itype = [0..31];
+ ibuf = ARRAY itype OF CHAR;
+ VAR
+ int : INTEGER;
+ neg : BOOLEAN;
+ safedigit: [0 .. 9];
+ chvalue: CARDINAL;
+ buf : ibuf;
+ index : itype;
+ BEGIN
+ ReadString(buf);
+ IF NOT Done THEN
+ RETURN
+ END;
+ index := 0;
+ IF buf[index] = '-' THEN
+ neg := TRUE;
+ INC(index);
+ ELSIF buf[index] = '+' THEN
+ neg := FALSE;
+ INC(index);
+ ELSE
+ neg := FALSE
+ END;
+
+ safedigit := SAFELIMITREM10;
+ IF neg THEN safedigit := safedigit + 1 END;
+ int := 0;
+ WHILE (buf[index] >= '0') & (buf[index] <= '9') DO
+ chvalue := ORD(buf[index]) - ORD('0');
+ IF (int > SAFELIMITDIV10) OR
+ ( (int = SAFELIMITDIV10) AND
+ (chvalue > safedigit)) THEN
+ Message("integer too large");
+ HALT;
+ ELSE
+ int := 10*int + VAL(INTEGER, chvalue);
+ INC(index)
+ END;
+ END;
+ IF neg THEN
+ integ := -int
+ ELSE
+ integ := int
+ END;
+ IF buf[index] > " " THEN
+ Message("illegal integer");
+ HALT;
+ END;
+ Done := TRUE;
+ END ReadInt;
+
+ PROCEDURE ReadCard(VAR card : CARDINAL);
+ CONST
+ SAFELIMITDIV10 = MAX(CARDINAL) DIV 10;
+ SAFELIMITREM10 = MAX(CARDINAL) MOD 10;
+
+ TYPE
+ itype = [0..31];
+ ibuf = ARRAY itype OF CHAR;
+
+ VAR
+ int : CARDINAL;
+ index : itype;
+ buf : ibuf;
+ safedigit: [0 .. 9];
+ chvalue: CARDINAL;
+ BEGIN
+ ReadString(buf);
+ IF NOT Done THEN RETURN; END;
+ index := 0;
+ safedigit := SAFELIMITREM10;
+ int := 0;
+ WHILE (buf[index] >= '0') & (buf[index] <= '9') DO
+ chvalue := ORD(buf[index]) - ORD('0');
+ IF (int > SAFELIMITDIV10) OR
+ ( (int = SAFELIMITDIV10) AND
+ (chvalue > safedigit)) THEN
+ Message("cardinal too large");
+ HALT;
+ ELSE
+ int := 10*int + chvalue;
+ INC(index);
+ END;
+ END;
+ IF buf[index] > " " THEN
+ Message("illegal cardinal");
+ HALT;
+ END;
+ card := int;
+ Done := TRUE;
+ END ReadCard;
+
+ PROCEDURE ReadString(VAR s : ARRAY OF CHAR);
+ TYPE charset = SET OF CHAR;
+ VAR i : CARDINAL;
+ ch : CHAR;
+
+ BEGIN
+ i := 0;
+ REPEAT
+ Read(ch);
+ UNTIL NOT (ch IN charset{' ', TAB, 12C, 15C});
+ IF NOT Done THEN
+ RETURN;
+ END;
+ UnRead(ch);
+ REPEAT
+ Read(ch);
+ termCH := ch;
+ IF i <= HIGH(s) THEN
+ s[i] := ch;
+ IF (NOT Done) OR (ch <= " ") THEN
+ s[i] := 0C;
+ END;
+ END;
+ INC(i);
+ UNTIL (NOT Done) OR (ch <= " ");
+ IF Done THEN UnRead(ch); END;
+ END ReadString;
+
+ PROCEDURE XReadString(VAR s : ARRAY OF CHAR);
+ VAR j : CARDINAL;
+ ch : CHAR;
+
+ BEGIN
+ j := 0;
+ LOOP
+ Streams.Read(Streams.InputStream, ch, result);
+ IF result # Streams.succeeded THEN
+ EXIT;
+ END;
+ IF ch <= " " THEN
+ s[j] := 0C;
+ EXIT;
+ END;
+ IF j < HIGH(s) THEN
+ s[j] := ch;
+ INC(j);
+ END;
+ END;
+ END XReadString;
+
+ PROCEDURE XWriteString(s: ARRAY OF CHAR);
+ VAR i: CARDINAL;
+ BEGIN
+ i := 0;
+ LOOP
+ IF (i <= HIGH(s)) AND (s[i] # 0C) THEN
+ Streams.Write(Streams.OutputStream, s[i], result);
+ INC(i);
+ ELSE
+ EXIT;
+ END;
+ END;
+ END XWriteString;
+
+ PROCEDURE WriteCard(card, width : CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ ConvertCardinal(card, width, buf);
+ WriteString(buf);
+ END WriteCard;
+
+ PROCEDURE WriteInt(int : INTEGER; width : CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ ConvertInteger(int, width, buf);
+ WriteString(buf);
+ END WriteInt;
+
+ PROCEDURE WriteHex(card, width : CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ ConvertHex(card, width, buf);
+ WriteString(buf);
+ END WriteHex;
+
+ PROCEDURE WriteLn;
+ BEGIN
+ Write(EOL)
+ END WriteLn;
+
+ PROCEDURE WriteOct(card, width : CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ ConvertOctal(card, width, buf);
+ WriteString(buf);
+ END WriteOct;
+
+ PROCEDURE WriteString(str : ARRAY OF CHAR);
+ VAR
+ nbytes : CARDINAL;
+ BEGIN
+ nbytes := 0;
+ WHILE (nbytes <= HIGH(str)) AND (str[nbytes] # 0C) DO
+ Write(str[nbytes]);
+ INC(nbytes)
+ END;
+ END WriteString;
+
+BEGIN (* InOut initialization *)
+ CurrIn := Streams.InputStream;
+ CurrOut := Streams.OutputStream;
+ unread := FALSE;
+END InOut.
--- /dev/null
+#
+;
+; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+; See the copyright notice in the ACK home directory, in the file "Copyright".
+;
+;
+; Module: Compute non-constant set displays
+; Author: Ceriel J.H. Jacobs
+; Version: $Header$
+;
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+ ; LtoUset is called for set displays containing { expr1 .. expr2 }.
+ ; It has six parameters, of which the caller must pop five:
+ ; - The set in which bits must be set.
+ ; - the lower bound of the set type.
+ ; - The set size in bytes.
+ ; - The upper bound of set elements, specified by the set-type.
+ ; - "expr2", the upper bound
+ ; - "expr1", the lower bound
+
+#define SETBASE 5*_EM_WSIZE
+#define SETLOW 4*_EM_WSIZE
+#define SETSIZE 3*_EM_WSIZE
+#define USETSIZ 2*_EM_WSIZE
+#define LWB _EM_WSIZE
+#define UPB 0
+ exp $LtoUset
+ pro $LtoUset,0
+ lal SETBASE ; address of initial set
+ lol SETSIZE
+ los _EM_WSIZE ; load initial set
+ lol LWB ; low bound
+ lol SETLOW
+ sbu _EM_WSIZE
+ stl LWB
+ lol UPB ; high bound
+ lol SETLOW
+ sbu _EM_WSIZE
+ stl UPB
+1
+ lol LWB
+ lol UPB
+ cmu _EM_WSIZE
+ zgt *2 ; while low <= high
+ lol LWB
+ lol SETSIZE
+ set ? ; create [low]
+ lol SETSIZE
+ ior ? ; merge with initial set
+ lol LWB
+ loc 1
+ adu _EM_WSIZE
+ stl LWB
+ bra *1 ; loop back
+2
+ lal SETBASE
+ lol SETSIZE
+ sts _EM_WSIZE ; store result over initial set
+ ret 0
+ end 0
--- /dev/null
+# Makefile for lib/ack/libm2.
+
+CFLAGS = -O -I../h -wo
+M2FLAGS = -O -ws -n
+
+LIBRARIES = libm2
+
+libm2_OBJECTS = \
+ Arguments.o \
+ ArraySort.o \
+ CSP.o \
+ Conversion.o \
+ EM.o \
+ InOut.o \
+ LtoUset.o \
+ MathLib0.o \
+ Mathlib.o \
+ PascalIO.o \
+ Processes.o \
+ RealConver.o \
+ RealInOut.o \
+ SYSTEM.o \
+ Semaphores.o \
+ Storage.o \
+ StrAss.o \
+ Streams.o \
+ Strings.o \
+ Termcap.o \
+ Terminal.o \
+ Traps.o \
+ XXTermcap.o \
+ absd.o \
+ absf.o \
+ absi.o \
+ absl.o \
+ blockmove.o \
+ cap.o \
+ catch.o \
+ confarray.o \
+ dvi.o \
+ halt.o \
+ head_m2.o \
+ init.o \
+ load.o \
+ par_misc.o \
+ random.o \
+ rcka.o \
+ rcki.o \
+ rckil.o \
+ rcku.o \
+ rckul.o \
+ sigtrp.o \
+ stackprio.o \
+ store.o \
+ ucheck.o \
+
+include ../../Makefile.ack.inc
--- /dev/null
+# Makefile for lib/ack/libm2.
+
+M2 = m2
+CFLAGS = -O -I$(SRCDIR)/ack/h -wo
+CC1 = $(CC) $(CFLAGS) -c
+M2FLAGS = -O -ws -n
+M21 = $(M2) $(M2FLAGS) -c
+
+LIBRARY = ../../libm2.a
+all: $(LIBRARY)
+
+OBJECTS = \
+ $(LIBRARY)(Arguments.o) \
+ $(LIBRARY)(ArraySort.o) \
+ $(LIBRARY)(CSP.o) \
+ $(LIBRARY)(Conversion.o) \
+ $(LIBRARY)(EM.o) \
+ $(LIBRARY)(InOut.o) \
+ $(LIBRARY)(LtoUset.o) \
+ $(LIBRARY)(MathLib0.o) \
+ $(LIBRARY)(Mathlib.o) \
+ $(LIBRARY)(PascalIO.o) \
+ $(LIBRARY)(Processes.o) \
+ $(LIBRARY)(RealConver.o) \
+ $(LIBRARY)(RealInOut.o) \
+ $(LIBRARY)(SYSTEM.o) \
+ $(LIBRARY)(Semaphores.o) \
+ $(LIBRARY)(Storage.o) \
+ $(LIBRARY)(StrAss.o) \
+ $(LIBRARY)(Streams.o) \
+ $(LIBRARY)(Strings.o) \
+ $(LIBRARY)(Termcap.o) \
+ $(LIBRARY)(Terminal.o) \
+ $(LIBRARY)(Traps.o) \
+ $(LIBRARY)(XXTermcap.o) \
+ $(LIBRARY)(absd.o) \
+ $(LIBRARY)(absf.o) \
+ $(LIBRARY)(absi.o) \
+ $(LIBRARY)(absl.o) \
+ $(LIBRARY)(blockmove.o) \
+ $(LIBRARY)(cap.o) \
+ $(LIBRARY)(catch.o) \
+ $(LIBRARY)(confarray.o) \
+ $(LIBRARY)(dvi.o) \
+ $(LIBRARY)(halt.o) \
+ $(LIBRARY)(head_m2.o) \
+ $(LIBRARY)(init.o) \
+ $(LIBRARY)(load.o) \
+ $(LIBRARY)(par_misc.o) \
+ $(LIBRARY)(random.o) \
+ $(LIBRARY)(rcka.o) \
+ $(LIBRARY)(rcki.o) \
+ $(LIBRARY)(rckil.o) \
+ $(LIBRARY)(rcku.o) \
+ $(LIBRARY)(rckul.o) \
+ $(LIBRARY)(sigtrp.o) \
+ $(LIBRARY)(stackprio.o) \
+ $(LIBRARY)(store.o) \
+ $(LIBRARY)(ucheck.o) \
+
+$(LIBRARY): $(OBJECTS)
+ aal cr $@ *.o
+ rm *.o
+
+$(LIBRARY)(Arguments.o): Arguments.c
+ $(CC1) Arguments.c
+
+$(LIBRARY)(ArraySort.o): ArraySort.mod
+ $(M21) ArraySort.mod
+
+$(LIBRARY)(CSP.o): CSP.mod
+ $(M21) CSP.mod
+
+$(LIBRARY)(Conversion.o): Conversion.mod
+ $(M21) Conversion.mod
+
+$(LIBRARY)(EM.o): EM.e
+ $(CC1) EM.e
+
+$(LIBRARY)(InOut.o): InOut.mod
+ $(M21) InOut.mod
+
+$(LIBRARY)(LtoUset.o): LtoUset.e
+ $(CC1) LtoUset.e
+
+$(LIBRARY)(MathLib0.o): MathLib0.mod
+ $(M21) MathLib0.mod
+
+$(LIBRARY)(Mathlib.o): Mathlib.mod
+ $(M21) Mathlib.mod
+
+$(LIBRARY)(PascalIO.o): PascalIO.mod
+ $(M21) PascalIO.mod
+
+$(LIBRARY)(Processes.o): Processes.mod
+ $(M21) Processes.mod
+
+$(LIBRARY)(RealConver.o): RealConver.mod
+ $(M21) RealConver.mod
+
+$(LIBRARY)(RealInOut.o): RealInOut.mod
+ $(M21) RealInOut.mod
+
+$(LIBRARY)(SYSTEM.o): SYSTEM.c
+ $(CC1) SYSTEM.c
+
+$(LIBRARY)(Semaphores.o): Semaphores.mod
+ $(M21) Semaphores.mod
+
+$(LIBRARY)(Storage.o): Storage.mod
+ $(M21) Storage.mod
+
+$(LIBRARY)(StrAss.o): StrAss.c
+ $(CC1) StrAss.c
+
+$(LIBRARY)(Streams.o): Streams.mod
+ $(M21) Streams.mod
+
+$(LIBRARY)(Strings.o): Strings.mod
+ $(M21) Strings.mod
+
+$(LIBRARY)(Termcap.o): Termcap.mod
+ $(M21) Termcap.mod
+
+$(LIBRARY)(Terminal.o): Terminal.mod
+ $(M21) -D__USG Terminal.mod
+
+$(LIBRARY)(Traps.o): Traps.mod
+ $(M21) Traps.mod
+
+$(LIBRARY)(XXTermcap.o): XXTermcap.c
+ $(CC1) XXTermcap.c
+
+$(LIBRARY)(absd.o): absd.c
+ $(CC1) absd.c
+
+$(LIBRARY)(absf.o): absf.e
+ $(CC1) absf.e
+
+$(LIBRARY)(absi.o): absi.c
+ $(CC1) absi.c
+
+$(LIBRARY)(absl.o): absl.c
+ $(CC1) absl.c
+
+$(LIBRARY)(blockmove.o): blockmove.c
+ $(CC1) blockmove.c
+
+$(LIBRARY)(cap.o): cap.c
+ $(CC1) cap.c
+
+$(LIBRARY)(catch.o): catch.c
+ $(CC1) catch.c
+
+$(LIBRARY)(confarray.o): confarray.c
+ $(CC1) confarray.c
+
+$(LIBRARY)(dvi.o): dvi.c
+ $(CC1) dvi.c
+
+$(LIBRARY)(halt.o): halt.c
+ $(CC1) halt.c
+
+$(LIBRARY)(head_m2.o): head_m2.e
+ $(CC1) head_m2.e
+
+$(LIBRARY)(init.o): init.c
+ $(CC1) init.c
+
+$(LIBRARY)(load.o): load.c
+ $(CC1) load.c
+
+$(LIBRARY)(par_misc.o): par_misc.e
+ $(CC1) par_misc.e
+
+$(LIBRARY)(random.o): random.mod
+ $(M21) random.mod
+
+$(LIBRARY)(rcka.o): rcka.c
+ $(CC1) rcka.c
+
+$(LIBRARY)(rcki.o): rcki.c
+ $(CC1) rcki.c
+
+$(LIBRARY)(rckil.o): rckil.c
+ $(CC1) rckil.c
+
+$(LIBRARY)(rcku.o): rcku.c
+ $(CC1) rcku.c
+
+$(LIBRARY)(rckul.o): rckul.c
+ $(CC1) rckul.c
+
+$(LIBRARY)(sigtrp.o): sigtrp.c
+ $(CC1) sigtrp.c
+
+$(LIBRARY)(stackprio.o): stackprio.c
+ $(CC1) stackprio.c
+
+$(LIBRARY)(store.o): store.c
+ $(CC1) store.c
+
+$(LIBRARY)(ucheck.o): ucheck.c
+ $(CC1) ucheck.c
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE MathLib0;
+(*
+ Module: Some mathematical functions
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ IMPORT Mathlib;
+
+ PROCEDURE cos(arg: REAL): REAL;
+ BEGIN
+ RETURN Mathlib.cos(arg);
+ END cos;
+
+ PROCEDURE sin(arg: REAL): REAL;
+ BEGIN
+ RETURN Mathlib.sin(arg);
+ END sin;
+
+ PROCEDURE arctan(arg: REAL): REAL;
+ BEGIN
+ RETURN Mathlib.arctan(arg);
+ END arctan;
+
+ PROCEDURE sqrt(arg: REAL): REAL;
+ BEGIN
+ RETURN Mathlib.sqrt(arg);
+ END sqrt;
+
+ PROCEDURE ln(arg: REAL): REAL;
+ BEGIN
+ RETURN Mathlib.ln(arg);
+ END ln;
+
+ PROCEDURE exp(arg: REAL): REAL;
+ BEGIN
+ RETURN Mathlib.exp(arg);
+ END exp;
+
+ PROCEDURE entier(x: REAL): INTEGER;
+ VAR i: INTEGER;
+ BEGIN
+ IF x < 0.0 THEN
+ i := TRUNC(-x);
+ IF FLOAT(i) = -x THEN
+ RETURN -i;
+ ELSE
+ RETURN -i -1;
+ END;
+ END;
+ RETURN TRUNC(x);
+ END entier;
+
+ PROCEDURE real(x: INTEGER): REAL;
+ BEGIN
+ IF x < 0 THEN
+ RETURN - FLOAT(-x);
+ END;
+ RETURN FLOAT(x);
+ END real;
+
+BEGIN
+END MathLib0.
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Mathlib;
+(*
+ Module: Mathematical functions
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ FROM EM IMPORT FIF, FEF;
+ FROM Traps IMPORT Message;
+
+ CONST
+ OneRadianInDegrees = 57.295779513082320876798155D;
+ OneDegreeInRadians = 0.017453292519943295769237D;
+ OneOverSqrt2 = 0.70710678118654752440084436210484904D;
+
+ (* basic functions *)
+
+ PROCEDURE pow(x: REAL; i: INTEGER): REAL;
+ BEGIN
+ RETURN SHORT(longpow(LONG(x), i));
+ END pow;
+
+ PROCEDURE longpow(x: LONGREAL; i: INTEGER): LONGREAL;
+ VAR val: LONGREAL;
+ ri: LONGREAL;
+ BEGIN
+ ri := FLOATD(i);
+ IF x < 0.0D THEN
+ val := longexp(longln(-x) * ri);
+ IF ODD(i) THEN RETURN -val;
+ ELSE RETURN val;
+ END;
+ ELSIF x = 0.0D THEN
+ RETURN 0.0D;
+ ELSE
+ RETURN longexp(longln(x) * ri);
+ END;
+ END longpow;
+
+ PROCEDURE sqrt(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longsqrt(LONG(x)));
+ END sqrt;
+
+ PROCEDURE longsqrt(x: LONGREAL): LONGREAL;
+ VAR
+ temp: LONGREAL;
+ exp, i: INTEGER;
+ BEGIN
+ IF x <= 0.0D THEN
+ IF x < 0.0D THEN
+ Message("sqrt: negative argument");
+ HALT
+ END;
+ RETURN 0.0D;
+ END;
+ temp := FEF(x,exp);
+ (*
+ * NOTE
+ * this wont work on 1's comp
+ *)
+ IF ODD(exp) THEN
+ temp := 2.0D * temp;
+ DEC(exp);
+ END;
+ temp := 0.5D*(1.0D + temp);
+
+ WHILE exp > 28 DO
+ temp := temp * 16384.0D;
+ exp := exp - 28;
+ END;
+ WHILE exp < -28 DO
+ temp := temp / 16384.0D;
+ exp := exp + 28;
+ END;
+ WHILE exp >= 2 DO
+ temp := temp * 2.0D;
+ exp := exp - 2;
+ END;
+ WHILE exp <= -2 DO
+ temp := temp / 2.0D;
+ exp := exp + 2;
+ END;
+ FOR i := 0 TO 5 DO
+ temp := 0.5D*(temp + x/temp);
+ END;
+ RETURN temp;
+ END longsqrt;
+
+ PROCEDURE ldexp(x:LONGREAL; n: INTEGER): LONGREAL;
+ BEGIN
+ WHILE n >= 16 DO
+ x := x * 65536.0D;
+ n := n - 16;
+ END;
+ WHILE n > 0 DO
+ x := x * 2.0D;
+ DEC(n);
+ END;
+ WHILE n <= -16 DO
+ x := x / 65536.0D;
+ n := n + 16;
+ END;
+ WHILE n < 0 DO
+ x := x / 2.0D;
+ INC(n);
+ END;
+ RETURN x;
+ END ldexp;
+
+ PROCEDURE exp(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longexp(LONG(x)));
+ END exp;
+
+ PROCEDURE longexp(x: LONGREAL): LONGREAL;
+ (* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ *)
+ CONST
+ p0 = 0.25000000000000000000D+00;
+ p1 = 0.75753180159422776666D-02;
+ p2 = 0.31555192765684646356D-04;
+ q0 = 0.50000000000000000000D+00;
+ q1 = 0.56817302698551221787D-01;
+ q2 = 0.63121894374398503557D-03;
+ q3 = 0.75104028399870046114D-06;
+
+ VAR
+ neg: BOOLEAN;
+ n: INTEGER;
+ xn, g, x1, x2: LONGREAL;
+ BEGIN
+ neg := x < 0.0D;
+ IF neg THEN
+ x := -x;
+ END;
+ n := TRUNC(x/longln2 + 0.5D);
+ xn := FLOATD(n);
+ x1 := FLOATD(TRUNCD(x));
+ x2 := x - x1;
+ g := ((x1 - xn * 0.693359375D)+x2) - xn * (-2.1219444005469058277D-4);
+ IF neg THEN
+ g := -g;
+ n := -n;
+ END;
+ xn := g*g;
+ x := g*((p2*xn+p1)*xn+p0);
+ INC(n);
+ RETURN ldexp(0.5D + x/((((q3*xn+q2)*xn+q1)*xn+q0) - x), n);
+ END longexp;
+
+ PROCEDURE ln(x: REAL): REAL; (* natural log *)
+ BEGIN
+ RETURN SHORT(longln(LONG(x)));
+ END ln;
+
+ PROCEDURE longln(x: LONGREAL): LONGREAL; (* natural log *)
+ (* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ *)
+ CONST
+ p0 = -0.64124943423745581147D+02;
+ p1 = 0.16383943563021534222D+02;
+ p2 = -0.78956112887491257267D+00;
+ q0 = -0.76949932108494879777D+03;
+ q1 = 0.31203222091924532844D+03;
+ q2 = -0.35667977739034646171D+02;
+ q3 = 1.0D;
+ VAR
+ exp: INTEGER;
+ z, znum, zden, w: LONGREAL;
+
+ BEGIN
+ IF x <= 0.0D THEN
+ Message("ln: argument <= 0");
+ HALT
+ END;
+ x := FEF(x, exp);
+ IF x > OneOverSqrt2 THEN
+ znum := (x - 0.5D) - 0.5D;
+ zden := x * 0.5D + 0.5D;
+ ELSE
+ znum := x - 0.5D;
+ zden := znum * 0.5D + 0.5D;
+ DEC(exp);
+ END;
+ z := znum / zden;
+ w := z * z;
+ x := z + z * w * (((p2*w+p1)*w+p0)/(((q3*w+q2)*w+q1)*w+q0));
+ z := FLOATD(exp);
+ x := x + z * (-2.121944400546905827679D-4);
+ RETURN x + z * 0.693359375D;
+ END longln;
+
+ PROCEDURE log(x: REAL): REAL; (* log with base 10 *)
+ BEGIN
+ RETURN SHORT(longlog(LONG(x)));
+ END log;
+
+ PROCEDURE longlog(x: LONGREAL): LONGREAL; (* log with base 10 *)
+ BEGIN
+ RETURN longln(x)/longln10;
+ END longlog;
+
+ (* trigonometric functions; arguments in radians *)
+
+ PROCEDURE sin(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longsin(LONG(x)));
+ END sin;
+
+ PROCEDURE sinus(x: LONGREAL; cosflag: BOOLEAN) : LONGREAL;
+ (* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ *)
+ CONST
+ r0 = -0.16666666666666665052D+00;
+ r1 = 0.83333333333331650314D-02;
+ r2 = -0.19841269841201840457D-03;
+ r3 = 0.27557319210152756119D-05;
+ r4 = -0.25052106798274584544D-07;
+ r5 = 0.16058936490371589114D-09;
+ r6 = -0.76429178068910467734D-12;
+ r7 = 0.27204790957888846175D-14;
+ A1 = 3.1416015625D;
+ A2 = -8.908910206761537356617D-6;
+ VAR
+ x1, x2, y : LONGREAL;
+ neg : BOOLEAN;
+ BEGIN
+ IF x < 0.0D THEN
+ neg := TRUE;
+ x := -x
+ ELSE neg := FALSE
+ END;
+ IF cosflag THEN
+ neg := FALSE;
+ y := longhalfpi + x
+ ELSE
+ y := x
+ END;
+ y := y / longpi + 0.5D;
+
+ IF FIF(y, 1.0D, y) < 0.0D THEN ; END;
+ IF FIF(y, 0.5D, x1) # 0.0D THEN neg := NOT neg END;
+ IF cosflag THEN y := y - 0.5D END;
+ x2 := FIF(x, 1.0, x1);
+ x := x1 - y * A1;
+ x := x + x2;
+ x := x - y * A2;
+
+ IF x < 0.0D THEN
+ neg := NOT neg;
+ x := -x
+ END;
+ y := x * x;
+ x := x + x * y * (((((((r7*y+r6)*y+r5)*y+r4)*y+r3)*y+r2)*y+r1)*y+r0);
+ IF neg THEN RETURN -x END;
+ RETURN x;
+ END sinus;
+
+ PROCEDURE longsin(x: LONGREAL): LONGREAL;
+ BEGIN
+ RETURN sinus(x, FALSE);
+ END longsin;
+
+ PROCEDURE cos(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longcos(LONG(x)));
+ END cos;
+
+ PROCEDURE longcos(x: LONGREAL): LONGREAL;
+ BEGIN
+ IF x < 0.0D THEN x := -x; END;
+ RETURN sinus(x, TRUE);
+ END longcos;
+
+ PROCEDURE tan(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longtan(LONG(x)));
+ END tan;
+
+ PROCEDURE longtan(x: LONGREAL): LONGREAL;
+ (* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ *)
+
+ CONST
+ p1 = -0.13338350006421960681D+00;
+ p2 = 0.34248878235890589960D-02;
+ p3 = -0.17861707342254426711D-04;
+
+ q0 = 1.0D;
+ q1 = -0.46671683339755294240D+00;
+ q2 = 0.25663832289440112864D-01;
+ q3 = -0.31181531907010027307D-03;
+ q4 = 0.49819433993786512270D-06;
+
+ A1 = 1.57080078125D;
+ A2 = -4.454455103380768678308D-06;
+
+ VAR y, x1, x2: LONGREAL;
+ negative: BOOLEAN;
+ invert: BOOLEAN;
+ BEGIN
+ negative := x < 0.0D;
+ y := x / longhalfpi + 0.5D;
+
+ (* Use extended precision to calculate reduced argument.
+ Here we used 12 bits of the mantissa for a1.
+ Also split x in integer part x1 and fraction part x2.
+ *)
+ IF FIF(y, 1.0D, y) < 0.0D THEN ; END;
+ invert := FIF(y, 0.5D, x1) # 0.0D;
+ x2 := FIF(x, 1.0D, x1);
+ x := x1 - y * A1;
+ x := x + x2;
+ x := x - y * A2;
+
+ y := x * x;
+ x := x + x * y * ((p3*y+p2)*y+p1);
+ y := (((q4*y+q3)*y+q2)*y+q1)*y+q0;
+ IF negative THEN x := -x END;
+ IF invert THEN RETURN -y/x END;
+ RETURN x/y;
+ END longtan;
+
+ PROCEDURE arcsin(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longarcsin(LONG(x)));
+ END arcsin;
+
+ PROCEDURE arcsincos(x: LONGREAL; cosfl: BOOLEAN): LONGREAL;
+ CONST
+ p0 = -0.27368494524164255994D+02;
+ p1 = 0.57208227877891731407D+02;
+ p2 = -0.39688862997540877339D+02;
+ p3 = 0.10152522233806463645D+02;
+ p4 = -0.69674573447350646411D+00;
+
+ q0 = -0.16421096714498560795D+03;
+ q1 = 0.41714430248260412556D+03;
+ q2 = -0.38186303361750149284D+03;
+ q3 = 0.15095270841030604719D+03;
+ q4 = -0.23823859153670238830D+02;
+ q5 = 1.0D;
+ VAR
+ negative : BOOLEAN;
+ big: BOOLEAN;
+ g: LONGREAL;
+ BEGIN
+ negative := x < 0.0D;
+ IF negative THEN x := -x; END;
+ IF x > 0.5D THEN
+ big := TRUE;
+ IF x > 1.0D THEN
+ Message("arcsin or arccos: argument > 1");
+ HALT
+ END;
+ g := 0.5D - 0.5D * x;
+ x := -longsqrt(g);
+ x := x + x;
+ ELSE
+ big := FALSE;
+ g := x * x;
+ END;
+ x := x + x * g *
+ ((((p4*g+p3)*g+p2)*g+p1)*g+p0)/(((((q5*g+q4)*g+q3)*g+q2)*g+q1)*g+q0);
+ IF cosfl AND NOT negative THEN x := -x END;
+ IF cosfl = NOT big THEN
+ x := (x + longquartpi) + longquartpi;
+ ELSIF cosfl AND negative AND big THEN
+ x := (x + longhalfpi) + longhalfpi;
+ END;
+ IF negative AND NOT cosfl THEN x := -x END;
+ RETURN x;
+ END arcsincos;
+
+ PROCEDURE longarcsin(x: LONGREAL): LONGREAL;
+ BEGIN
+ RETURN arcsincos(x, FALSE);
+ END longarcsin;
+
+ PROCEDURE arccos(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longarccos(LONG(x)));
+ END arccos;
+
+ PROCEDURE longarccos(x: LONGREAL): LONGREAL;
+ BEGIN
+ RETURN arcsincos(x, TRUE);
+ END longarccos;
+
+ PROCEDURE arctan(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longarctan(LONG(x)));
+ END arctan;
+
+ VAR A: ARRAY[0..3] OF LONGREAL;
+ arctaninit: BOOLEAN;
+
+ PROCEDURE longarctan(x: LONGREAL): LONGREAL;
+ (* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ *)
+ CONST
+ p0 = -0.13688768894191926929D+02;
+ p1 = -0.20505855195861651981D+02;
+ p2 = -0.84946240351320683534D+01;
+ p3 = -0.83758299368150059274D+00;
+ q0 = 0.41066306682575781263D+02;
+ q1 = 0.86157349597130242515D+02;
+ q2 = 0.59578436142597344465D+02;
+ q3 = 0.15024001160028576121D+02;
+ q4 = 1.0D;
+ VAR
+ g: LONGREAL;
+ neg: BOOLEAN;
+ n: INTEGER;
+ BEGIN
+ IF NOT arctaninit THEN
+ arctaninit := TRUE;
+ A[0] := 0.0D;
+ A[1] := 0.52359877559829887307710723554658381D; (* p1/6 *)
+ A[2] := longhalfpi;
+ A[3] := 1.04719755119659774615421446109316763D; (* pi/3 *)
+ END;
+ neg := FALSE;
+ IF x < 0.0D THEN
+ neg := TRUE;
+ x := -x;
+ END;
+ IF x > 1.0D THEN
+ x := 1.0D/x;
+ n := 2
+ ELSE
+ n := 0
+ END;
+ IF x > 0.26794919243112270647D (* 2-sqrt(3) *) THEN
+ INC(n);
+ x := (((0.73205080756887729353D*x-0.5D)-0.5D)+x)/
+ (1.73205080756887729353D + x);
+ END;
+ g := x*x;
+ x := x + x * g * (((p3*g+p2)*g+p1)*g+p0) / ((((q4*g+q3)*g+q2)*g+q1)*g+q0);
+ IF n > 1 THEN x := -x END;
+ x := x + A[n];
+ IF neg THEN RETURN -x; END;
+ RETURN x;
+ END longarctan;
+
+ (* hyperbolic functions *)
+ (* The C math library has better implementations for some of these, but
+ they depend on some properties of the floating point implementation,
+ and, for now, we don't want that in the Modula-2 system.
+ *)
+
+ PROCEDURE sinh(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longsinh(LONG(x)));
+ END sinh;
+
+ PROCEDURE longsinh(x: LONGREAL): LONGREAL;
+ VAR expx: LONGREAL;
+ BEGIN
+ expx := longexp(x);
+ RETURN (expx - 1.0D/expx)/2.0D;
+ END longsinh;
+
+ PROCEDURE cosh(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longcosh(LONG(x)));
+ END cosh;
+
+ PROCEDURE longcosh(x: LONGREAL): LONGREAL;
+ VAR expx: LONGREAL;
+ BEGIN
+ expx := longexp(x);
+ RETURN (expx + 1.0D/expx)/2.0D;
+ END longcosh;
+
+ PROCEDURE tanh(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longtanh(LONG(x)));
+ END tanh;
+
+ PROCEDURE longtanh(x: LONGREAL): LONGREAL;
+ VAR expx: LONGREAL;
+ BEGIN
+ expx := longexp(x);
+ RETURN (expx - 1.0D/expx) / (expx + 1.0D/expx);
+ END longtanh;
+
+ PROCEDURE arcsinh(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longarcsinh(LONG(x)));
+ END arcsinh;
+
+ PROCEDURE longarcsinh(x: LONGREAL): LONGREAL;
+ VAR neg: BOOLEAN;
+ BEGIN
+ neg := FALSE;
+ IF x < 0.0D THEN
+ neg := TRUE;
+ x := -x;
+ END;
+ x := longln(x + longsqrt(x*x+1.0D));
+ IF neg THEN RETURN -x; END;
+ RETURN x;
+ END longarcsinh;
+
+ PROCEDURE arccosh(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longarccosh(LONG(x)));
+ END arccosh;
+
+ PROCEDURE longarccosh(x: LONGREAL): LONGREAL;
+ BEGIN
+ IF x < 1.0D THEN
+ Message("arccosh: argument < 1");
+ HALT
+ END;
+ RETURN longln(x + longsqrt(x*x - 1.0D));
+ END longarccosh;
+
+ PROCEDURE arctanh(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longarctanh(LONG(x)));
+ END arctanh;
+
+ PROCEDURE longarctanh(x: LONGREAL): LONGREAL;
+ BEGIN
+ IF (x <= -1.0D) OR (x >= 1.0D) THEN
+ Message("arctanh: ABS(argument) >= 1");
+ HALT
+ END;
+ RETURN longln((1.0D + x)/(1.0D - x)) / 2.0D;
+ END longarctanh;
+
+ (* conversions *)
+
+ PROCEDURE RadianToDegree(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longRadianToDegree(LONG(x)));
+ END RadianToDegree;
+
+ PROCEDURE longRadianToDegree(x: LONGREAL): LONGREAL;
+ BEGIN
+ RETURN x * OneRadianInDegrees;
+ END longRadianToDegree;
+
+ PROCEDURE DegreeToRadian(x: REAL): REAL;
+ BEGIN
+ RETURN SHORT(longDegreeToRadian(LONG(x)));
+ END DegreeToRadian;
+
+ PROCEDURE longDegreeToRadian(x: LONGREAL): LONGREAL;
+ BEGIN
+ RETURN x * OneDegreeInRadians;
+ END longDegreeToRadian;
+
+BEGIN
+ arctaninit := FALSE;
+END Mathlib.
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE PascalIO;
+(*
+ Module: Pascal-like Input/Output
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ FROM Conversions IMPORT
+ ConvertInteger, ConvertCardinal;
+ FROM RealConversions IMPORT
+ LongRealToString, StringToLongReal;
+ FROM Traps IMPORT Message;
+ FROM Streams IMPORT Stream, StreamKind, StreamMode, StreamResult,
+ InputStream, OutputStream, OpenStream, CloseStream,
+ EndOfStream, Read, Write, StreamBuffering;
+ FROM Storage IMPORT Allocate;
+ FROM SYSTEM IMPORT ADR;
+
+ TYPE charset = SET OF CHAR;
+ btype = (Preading, Pwriting, free);
+
+ CONST spaces = charset{11C, 12C, 13C, 14C, 15C, ' '};
+
+ TYPE IOstream = RECORD
+ type: btype;
+ done, eof : BOOLEAN;
+ ch: CHAR;
+ next: Text;
+ stream: Stream;
+ END;
+ Text = POINTER TO IOstream;
+ numbuf = ARRAY[0..255] OF CHAR;
+
+ VAR ibuf, obuf: IOstream;
+ head: Text;
+ result: StreamResult;
+
+ PROCEDURE Reset(VAR InputText: Text; Filename: ARRAY OF CHAR);
+ BEGIN
+ doclose(InputText);
+ getstruct(InputText);
+ WITH InputText^ DO
+ OpenStream(stream, Filename, text, reading, result);
+ IF result # succeeded THEN
+ Message("could not open input file");
+ HALT;
+ END;
+ type := Preading;
+ done := FALSE;
+ eof := FALSE;
+ END;
+ END Reset;
+
+ PROCEDURE Rewrite(VAR OutputText: Text; Filename: ARRAY OF CHAR);
+ BEGIN
+ doclose(OutputText);
+ getstruct(OutputText);
+ WITH OutputText^ DO
+ OpenStream(stream, Filename, text, writing, result);
+ IF result # succeeded THEN
+ Message("could not open output file");
+ HALT;
+ END;
+ type := Pwriting;
+ END;
+ END Rewrite;
+
+ PROCEDURE CloseOutput();
+ VAR p: Text;
+ BEGIN
+ p := head;
+ WHILE p # NIL DO
+ doclose(p);
+ p := p^.next;
+ END;
+ END CloseOutput;
+
+ PROCEDURE doclose(Xtext: Text);
+ BEGIN
+ IF Xtext # Notext THEN
+ WITH Xtext^ DO
+ IF type # free THEN
+ CloseStream(stream, result);
+ type := free;
+ END;
+ END;
+ END;
+ END doclose;
+
+ PROCEDURE getstruct(VAR Xtext: Text);
+ BEGIN
+ Xtext := head;
+ WHILE (Xtext # NIL) AND (Xtext^.type # free) DO
+ Xtext := Xtext^.next;
+ END;
+ IF Xtext = NIL THEN
+ Allocate(Xtext,SIZE(IOstream));
+ Xtext^.next := head;
+ head := Xtext;
+ END;
+ END getstruct;
+
+ PROCEDURE Error(tp: btype);
+ BEGIN
+ IF tp = Preading THEN
+ Message("input text expected");
+ ELSE
+ Message("output text expected");
+ END;
+ HALT;
+ END Error;
+
+ PROCEDURE ReadChar(InputText: Text; VAR ch : CHAR);
+ BEGIN
+ ch := NextChar(InputText);
+ IF InputText^.eof THEN
+ Message("unexpected EOF");
+ HALT;
+ END;
+ InputText^.done := FALSE;
+ END ReadChar;
+
+ PROCEDURE NextChar(InputText: Text): CHAR;
+ BEGIN
+ WITH InputText^ DO
+ IF type # Preading THEN Error(Preading); END;
+ IF NOT done THEN
+ IF EndOfStream(stream, result) THEN
+ eof := TRUE;
+ ch := 0C;
+ ELSE
+ Read(stream, ch, result);
+ done := TRUE;
+ END;
+ END;
+ RETURN ch;
+ END;
+ END NextChar;
+
+ PROCEDURE Get(InputText: Text);
+ VAR dummy: CHAR;
+ BEGIN
+ ReadChar(InputText, dummy);
+ END Get;
+
+ PROCEDURE Eoln(InputText: Text): BOOLEAN;
+ BEGIN
+ RETURN NextChar(InputText) = 12C;
+ END Eoln;
+
+ PROCEDURE Eof(InputText: Text): BOOLEAN;
+ BEGIN
+ RETURN (NextChar(InputText) = 0C) AND InputText^.eof;
+ END Eof;
+
+ PROCEDURE ReadLn(InputText: Text);
+ VAR ch: CHAR;
+ BEGIN
+ REPEAT
+ ReadChar(InputText, ch)
+ UNTIL ch = 12C;
+ END ReadLn;
+
+ PROCEDURE WriteChar(OutputText: Text; char: CHAR);
+ BEGIN
+ WITH OutputText^ DO
+ IF type # Pwriting THEN Error(Pwriting); END;
+ Write(stream, char, result);
+ END;
+ END WriteChar;
+
+ PROCEDURE WriteLn(OutputText: Text);
+ BEGIN
+ WriteChar(OutputText, 12C);
+ END WriteLn;
+
+ PROCEDURE Page(OutputText: Text);
+ BEGIN
+ WriteChar(OutputText, 14C);
+ END Page;
+
+ PROCEDURE ReadInteger(InputText: Text; VAR int : INTEGER);
+ CONST
+ SAFELIMITDIV10 = MAX(INTEGER) DIV 10;
+ SAFELIMITREM10 = MAX(INTEGER) MOD 10;
+ VAR
+ neg : BOOLEAN;
+ safedigit: CARDINAL;
+ ch: CHAR;
+ chvalue: CARDINAL;
+ BEGIN
+ WHILE NextChar(InputText) IN spaces DO
+ Get(InputText);
+ END;
+ ch := NextChar(InputText);
+ IF ch = '-' THEN
+ Get(InputText);
+ ch := NextChar(InputText);
+ neg := TRUE;
+ ELSIF ch = '+' THEN
+ Get(InputText);
+ ch := NextChar(InputText);
+ neg := FALSE;
+ ELSE
+ neg := FALSE
+ END;
+
+ safedigit := SAFELIMITREM10;
+ IF neg THEN safedigit := safedigit + 1 END;
+ int := 0;
+ IF (ch >= '0') AND (ch <= '9') THEN
+ WHILE (ch >= '0') & (ch <= '9') DO
+ chvalue := ORD(ch) - ORD('0');
+ IF (int < -SAFELIMITDIV10) OR
+ ( (int = -SAFELIMITDIV10) AND
+ (chvalue > safedigit)) THEN
+ Message("integer too large");
+ HALT;
+ ELSE
+ int := 10*int - VAL(INTEGER, chvalue);
+ Get(InputText);
+ ch := NextChar(InputText);
+ END;
+ END;
+ IF NOT neg THEN
+ int := -int
+ END;
+ ELSE
+ Message("integer expected");
+ HALT;
+ END;
+ END ReadInteger;
+
+ PROCEDURE ReadCardinal(InputText: Text; VAR card : CARDINAL);
+ CONST
+ SAFELIMITDIV10 = MAX(CARDINAL) DIV 10;
+ SAFELIMITREM10 = MAX(CARDINAL) MOD 10;
+
+ VAR
+ ch : CHAR;
+ safedigit: CARDINAL;
+ chvalue: CARDINAL;
+ BEGIN
+ WHILE NextChar(InputText) IN spaces DO
+ Get(InputText);
+ END;
+ ch := NextChar(InputText);
+ safedigit := SAFELIMITREM10;
+ card := 0;
+ IF (ch >= '0') AND (ch <= '9') THEN
+ WHILE (ch >= '0') & (ch <= '9') DO
+ chvalue := ORD(ch) - ORD('0');
+ IF (card > SAFELIMITDIV10) OR
+ ( (card = SAFELIMITDIV10) AND
+ (chvalue > safedigit)) THEN
+ Message("cardinal too large");
+ HALT;
+ ELSE
+ card := 10*card + chvalue;
+ Get(InputText);
+ ch := NextChar(InputText);
+ END;
+ END;
+ ELSE
+ Message("cardinal expected");
+ HALT;
+ END;
+ END ReadCardinal;
+
+ PROCEDURE ReadReal(InputText: Text; VAR real: REAL);
+ VAR x1: LONGREAL;
+ BEGIN
+ ReadLongReal(InputText, x1);
+ real := x1
+ END ReadReal;
+
+ PROCEDURE ReadLongReal(InputText: Text; VAR real: LONGREAL);
+ VAR
+ buf: numbuf;
+ ch: CHAR;
+ ok: BOOLEAN;
+ index: INTEGER;
+
+ PROCEDURE inch(): CHAR;
+ BEGIN
+ buf[index] := ch;
+ INC(index);
+ Get(InputText);
+ RETURN NextChar(InputText);
+ END inch;
+
+ BEGIN
+ index := 0;
+ ok := TRUE;
+ WHILE NextChar(InputText) IN spaces DO
+ Get(InputText);
+ END;
+ ch := NextChar(InputText);
+ IF (ch ='+') OR (ch = '-') THEN
+ ch := inch();
+ END;
+ IF (ch >= '0') AND (ch <= '9') THEN
+ WHILE (ch >= '0') AND (ch <= '9') DO
+ ch := inch();
+ END;
+ IF (ch = '.') THEN
+ ch := inch();
+ IF (ch >= '0') AND (ch <= '9') THEN
+ WHILE (ch >= '0') AND (ch <= '9') DO
+ ch := inch();
+ END;
+ ELSE
+ ok := FALSE;
+ END;
+ END;
+ IF ok AND (ch = 'E') THEN
+ ch := inch();
+ IF (ch ='+') OR (ch = '-') THEN
+ ch := inch();
+ END;
+ IF (ch >= '0') AND (ch <= '9') THEN
+ WHILE (ch >= '0') AND (ch <= '9') DO
+ ch := inch();
+ END;
+ ELSE
+ ok := FALSE;
+ END;
+ END;
+ ELSE
+ ok := FALSE;
+ END;
+ IF ok THEN
+ buf[index] := 0C;
+ StringToLongReal(buf, real, ok);
+ END;
+ IF NOT ok THEN
+ Message("Illegal real");
+ HALT;
+ END;
+ END ReadLongReal;
+
+ PROCEDURE WriteCardinal(OutputText: Text; card: CARDINAL; width: CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ ConvertCardinal(card, 1, buf);
+ WriteString(OutputText, buf, width);
+ END WriteCardinal;
+
+ PROCEDURE WriteInteger(OutputText: Text; int: INTEGER; width: CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ ConvertInteger(int, 1, buf);
+ WriteString(OutputText, buf, width);
+ END WriteInteger;
+
+ PROCEDURE WriteBoolean(OutputText: Text; bool: BOOLEAN; width: CARDINAL);
+ BEGIN
+ IF bool THEN
+ WriteString(OutputText, " TRUE", width);
+ ELSE
+ WriteString(OutputText, "FALSE", width);
+ END;
+ END WriteBoolean;
+
+ PROCEDURE WriteReal(OutputText: Text; real: REAL; width, nfrac: CARDINAL);
+ BEGIN
+ WriteLongReal(OutputText, LONG(real), width, nfrac)
+ END WriteReal;
+
+ PROCEDURE WriteLongReal(OutputText: Text; real: LONGREAL; width, nfrac: CARDINAL);
+ VAR
+ buf: numbuf;
+ ok: BOOLEAN;
+ digits: INTEGER;
+ BEGIN
+ IF width > SIZE(buf) THEN
+ width := SIZE(buf);
+ END;
+ IF nfrac > 0 THEN
+ LongRealToString(real, width, nfrac, buf, ok);
+ ELSE
+ IF width < 9 THEN width := 9; END;
+ IF real < 0.0D THEN
+ digits := 7 - INTEGER(width);
+ ELSE
+ digits := 6 - INTEGER(width);
+ END;
+ LongRealToString(real, width, digits, buf, ok);
+ END;
+ WriteString(OutputText, buf, 0);
+ END WriteLongReal;
+
+ PROCEDURE WriteString(OutputText: Text; str: ARRAY OF CHAR; width: CARDINAL);
+ VAR index: CARDINAL;
+ BEGIN
+ index := 0;
+ WHILE (index <= HIGH(str)) AND (str[index] # Eos) DO
+ INC(index);
+ END;
+ WHILE index < width DO
+ WriteChar(OutputText, " ");
+ INC(index);
+ END;
+ index := 0;
+ WHILE (index <= HIGH(str)) AND (str[index] # Eos) DO
+ WriteChar(OutputText, str[index]);
+ INC(index);
+ END;
+ END WriteString;
+
+BEGIN (* PascalIO initialization *)
+ WITH ibuf DO
+ stream := InputStream;
+ eof := FALSE;
+ type := Preading;
+ done := FALSE;
+ END;
+ WITH obuf DO
+ stream := OutputStream;
+ eof := FALSE;
+ type := Pwriting;
+ END;
+ Notext := NIL;
+ Input := ADR(ibuf);
+ Output := ADR(obuf);
+ Input^.next := Output;
+ Output^.next := NIL;
+ head := Input;
+END PascalIO.
--- /dev/null
+(*$R-*)
+IMPLEMENTATION MODULE Processes [1];
+(*
+ Module: Processes
+ From: "Programming in Modula-2", 3rd, corrected edition, by N. Wirth
+ Version: $Header$
+*)
+
+ FROM SYSTEM IMPORT ADDRESS, TSIZE, NEWPROCESS, TRANSFER;
+ FROM Storage IMPORT Allocate;
+ FROM Traps IMPORT Message;
+
+ TYPE SIGNAL = POINTER TO ProcessDescriptor;
+
+ ProcessDescriptor =
+ RECORD next: SIGNAL; (* ring *)
+ queue: SIGNAL; (* queue of waiting processes *)
+ cor: ADDRESS;
+ ready: BOOLEAN;
+ END;
+
+ VAR cp: SIGNAL; (* current process *)
+
+ PROCEDURE StartProcess(P: PROC; n: CARDINAL);
+ VAR s0: SIGNAL;
+ wsp: ADDRESS;
+ BEGIN
+ s0 := cp;
+ Allocate(wsp, n);
+ Allocate(cp, TSIZE(ProcessDescriptor));
+ WITH cp^ DO
+ next := s0^.next;
+ s0^.next := cp;
+ ready := TRUE;
+ queue := NIL
+ END;
+ NEWPROCESS(P, wsp, n, cp^.cor);
+ TRANSFER(s0^.cor, cp^.cor);
+ END StartProcess;
+
+ PROCEDURE SEND(VAR s: SIGNAL);
+ VAR s0: SIGNAL;
+ BEGIN
+ IF s # NIL THEN
+ s0 := cp;
+ cp := s;
+ WITH cp^ DO
+ s := queue;
+ ready := TRUE;
+ queue := NIL
+ END;
+ TRANSFER(s0^.cor, cp^.cor);
+ END
+ END SEND;
+
+ PROCEDURE WAIT(VAR s: SIGNAL);
+ VAR s0, s1: SIGNAL;
+ BEGIN
+ (* insert cp in queue s *)
+ IF s = NIL THEN
+ s := cp
+ ELSE
+ s0 := s;
+ s1 := s0^.queue;
+ WHILE s1 # NIL DO
+ s0 := s1;
+ s1 := s0^.queue
+ END;
+ s0^.queue := cp
+ END;
+ s0 := cp;
+ REPEAT
+ cp := cp^.next
+ UNTIL cp^.ready;
+ IF cp = s0 THEN
+ (* deadlock *)
+ Message("deadlock");
+ HALT
+ END;
+ s0^.ready := FALSE;
+ TRANSFER(s0^.cor, cp^.cor)
+ END WAIT;
+
+ PROCEDURE Awaited(s: SIGNAL): BOOLEAN;
+ BEGIN
+ RETURN s # NIL
+ END Awaited;
+
+ PROCEDURE Init(VAR s: SIGNAL);
+ BEGIN
+ s := NIL
+ END Init;
+
+BEGIN
+ Allocate(cp, TSIZE(ProcessDescriptor));
+ WITH cp^ DO
+ next := cp;
+ ready := TRUE;
+ queue := NIL
+ END
+END Processes.
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE RealConversions;
+(*
+ Module: string-to-real and real-to-string conversions
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+
+ PROCEDURE RealToString(arg: REAL;
+ width, digits: INTEGER;
+ VAR str: ARRAY OF CHAR;
+ VAR ok: BOOLEAN);
+ BEGIN
+ LongRealToString(LONG(arg), width, digits, str, ok);
+ END RealToString;
+
+ TYPE
+ Powers = RECORD
+ pval: LONGREAL;
+ rpval: LONGREAL;
+ exp: INTEGER
+ END;
+
+ VAR Powers10: ARRAY[1..6] OF Powers;
+
+ PROCEDURE LongRealToString(arg: LONGREAL;
+ width, digits: INTEGER;
+ VAR str: ARRAY OF CHAR;
+ VAR ok: BOOLEAN);
+ VAR pointpos: INTEGER;
+ i: CARDINAL;
+ ecvtflag: BOOLEAN;
+ r: LONGREAL;
+ ind1, ind2 : CARDINAL;
+ sign: BOOLEAN;
+ ndigits: CARDINAL;
+
+ BEGIN
+ r := arg;
+ IF digits < 0 THEN
+ ecvtflag := TRUE;
+ ndigits := -digits;
+ ELSE
+ ecvtflag := FALSE;
+ ndigits := digits;
+ END;
+ IF (HIGH(str) < ndigits + 3) THEN
+ str[0] := 0C; ok := FALSE; RETURN
+ END;
+ pointpos := 0;
+ sign := r < 0.0D;
+ IF sign THEN r := -r END;
+ ok := TRUE;
+ IF NOT (r / 10.0D < r) THEN
+ (* assume Nan or Infinity *)
+ r := 0.0D;
+ ok := FALSE;
+ END;
+ IF r # 0.0D THEN
+ IF r >= 10.0D THEN
+ FOR i := 1 TO 6 DO
+ WITH Powers10[i] DO
+ WHILE r >= pval DO
+ r := r * rpval;
+ INC(pointpos, exp)
+ END;
+ END;
+ END;
+ END;
+ IF r < 1.0D THEN
+ FOR i := 1 TO 6 DO
+ WITH Powers10[i] DO
+ WHILE r*pval < 10.0D DO
+ r := r * pval;
+ DEC(pointpos, exp)
+ END;
+ END;
+ END;
+ END;
+ (* Now, we have r in [1.0, 10.0) *)
+ INC(pointpos);
+ END;
+ ind1 := 0;
+ ind2 := ndigits+1;
+
+ IF NOT ecvtflag THEN
+ IF INTEGER(ind2) + pointpos <= 0 THEN
+ ind2 := 1;
+ ELSE
+ ind2 := INTEGER(ind2) + pointpos
+ END;
+ END;
+ IF ind2 > HIGH(str) THEN
+ ok := FALSE;
+ str[0] := 0C;
+ RETURN;
+ END;
+ WHILE ind1 < ind2 DO
+ str[ind1] := CHR(TRUNC(r)+ORD('0'));
+ r := 10.0D * (r - FLOATD(TRUNC(r)));
+ INC(ind1);
+ END;
+ IF ind2 > 0 THEN
+ DEC(ind2);
+ ind1 := ind2;
+ str[ind2] := CHR(ORD(str[ind2])+5);
+ WHILE str[ind2] > '9' DO
+ str[ind2] := '0';
+ IF ind2 > 0 THEN
+ DEC(ind2);
+ str[ind2] := CHR(ORD(str[ind2])+1);
+ ELSE
+ str[ind2] := '1';
+ INC(pointpos);
+ IF NOT ecvtflag THEN
+ IF ind1 > 0 THEN str[ind1] := '0'; END;
+ INC(ind1);
+ END;
+ END;
+ END;
+ IF (NOT ecvtflag) AND (ind1 = 0) THEN
+ str[0] := CHR(ORD(str[0])-5);
+ INC(ind1);
+ END;
+ END;
+ IF ecvtflag THEN
+ FOR i := ind1 TO 2 BY -1 DO
+ str[i] := str[i-1];
+ END;
+ str[1] := '.';
+ INC(ind1);
+ IF sign THEN
+ FOR i := ind1 TO 1 BY -1 DO
+ str[i] := str[i-1];
+ END;
+ INC(ind1);
+ str[0] := '-';
+ END;
+ IF (ind1 + 4) > HIGH(str) THEN
+ str[0] := 0C;
+ ok := FALSE;
+ RETURN;
+ END;
+ str[ind1] := 'E'; INC(ind1);
+ IF arg # 0.0D THEN DEC(pointpos); END;
+ IF pointpos < 0 THEN
+ pointpos := -pointpos;
+ str[ind1] := '-';
+ ELSE
+ str[ind1] := '+';
+ END;
+ INC(ind1);
+ str[ind1] := CHR(ORD('0') + CARDINAL(pointpos DIV 100));
+ pointpos := pointpos MOD 100;
+ INC(ind1);
+ str[ind1] := CHR(ORD('0') + CARDINAL(pointpos DIV 10));
+ INC(ind1);
+ str[ind1] := CHR(ORD('0') + CARDINAL(pointpos MOD 10));
+ ELSE
+ IF pointpos <= 0 THEN
+ FOR i := ind1 TO 1 BY -1 DO
+ str[i+CARDINAL(-pointpos)] := str[i-1];
+ END;
+ FOR i := 0 TO CARDINAL(-pointpos) DO
+ str[i] := '0';
+ END;
+ ind1 := ind1 + CARDINAL(1 - pointpos);
+ pointpos := 1;
+ END;
+ FOR i := ind1 TO CARDINAL(pointpos+1) BY -1 DO
+ str[i] := str[i-1];
+ END;
+ IF ndigits = 0 THEN
+ str[pointpos] := 0C;
+ ind1 := pointpos - 1;
+ ELSE
+ str[pointpos] := '.';
+ IF INTEGER(ind1) > pointpos+INTEGER(ndigits) THEN
+ ind1 := pointpos+INTEGER(ndigits);
+ END;
+ str[pointpos+INTEGER(ndigits)+1] := 0C;
+ END;
+ IF sign THEN
+ FOR i := ind1 TO 0 BY -1 DO
+ str[i+1] := str[i];
+ END;
+ str[0] := '-';
+ INC(ind1);
+ END;
+ END;
+ IF (ind1+1) <= HIGH(str) THEN str[ind1+1] := 0C; END;
+ IF ind1 >= CARDINAL(width) THEN
+ ok := FALSE;
+ RETURN;
+ END;
+ IF width > 0 THEN
+ DEC(width);
+ END;
+ IF (width > 0) AND (ind1 < CARDINAL(width)) THEN
+ FOR i := ind1 TO 0 BY -1 DO
+ str[i + CARDINAL(width) - ind1] := str[i];
+ END;
+ FOR i := 0 TO CARDINAL(width)-(ind1+1) DO
+ str[i] := ' ';
+ END;
+ ind1 := CARDINAL(width);
+ IF (ind1+1) <= HIGH(str) THEN
+ FOR ind1 := ind1+1 TO HIGH(str) DO
+ str[ind1] := 0C;
+ END;
+ END;
+ END;
+
+ END LongRealToString;
+
+
+ PROCEDURE StringToReal(str: ARRAY OF CHAR;
+ VAR r: REAL; VAR ok: BOOLEAN);
+ VAR x: LONGREAL;
+ BEGIN
+ StringToLongReal(str, x, ok);
+ IF ok THEN
+ r := x;
+ END;
+ END StringToReal;
+
+ PROCEDURE StringToLongReal(str: ARRAY OF CHAR;
+ VAR r: LONGREAL; VAR ok: BOOLEAN);
+ CONST BIG = 1.0D17;
+ TYPE SETOFCHAR = SET OF CHAR;
+ VAR pow10 : INTEGER;
+ i : INTEGER;
+ e : LONGREAL;
+ ch : CHAR;
+ signed: BOOLEAN;
+ signedexp: BOOLEAN;
+ iB: CARDINAL;
+
+ BEGIN
+ r := 0.0D;
+ pow10 := 0;
+ iB := 0;
+ ok := TRUE;
+ signed := FALSE;
+ WHILE (str[iB] = ' ') OR (str[iB] = CHR(9)) DO
+ INC(iB);
+ IF iB > HIGH(str) THEN
+ ok := FALSE;
+ RETURN;
+ END;
+ END;
+ IF str[iB] = '-' THEN signed := TRUE; INC(iB)
+ ELSIF str[iB] = '+' THEN INC(iB)
+ END;
+ ch := str[iB]; INC(iB);
+ IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
+ REPEAT
+ IF r>BIG THEN INC(pow10) ELSE r:= 10.0D*r+FLOATD(ORD(ch)-ORD('0')) END;
+ IF iB <= HIGH(str) THEN
+ ch := str[iB]; INC(iB);
+ END;
+ UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
+ IF (ch = '.') AND (iB <= HIGH(str)) THEN
+ ch := str[iB]; INC(iB);
+ IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
+ REPEAT
+ IF r < BIG THEN
+ r := 10.0D * r + FLOATD(ORD(ch)-ORD('0'));
+ DEC(pow10);
+ END;
+ IF iB <= HIGH(str) THEN
+ ch := str[iB]; INC(iB);
+ END;
+ UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
+ END;
+ IF (ch = 'E') THEN
+ IF iB > HIGH(str) THEN
+ ok := FALSE;
+ RETURN;
+ ELSE
+ ch := str[iB]; INC(iB);
+ END;
+ i := 0;
+ signedexp := FALSE;
+ IF (ch = '-') OR (ch = '+') THEN
+ signedexp := ch = '-';
+ IF iB > HIGH(str) THEN
+ ok := FALSE;
+ RETURN;
+ ELSE
+ ch := str[iB]; INC(iB);
+ END;
+ END;
+ IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
+ REPEAT
+ i := i*10 + INTEGER(ORD(ch) - ORD('0'));
+ IF iB <= HIGH(str) THEN
+ ch := str[iB]; INC(iB);
+ END;
+ UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
+ IF signedexp THEN i := -i END;
+ pow10 := pow10 + i;
+ END;
+ IF pow10 < 0 THEN i := -pow10; ELSE i := pow10; END;
+ e := 1.0D;
+ DEC(i);
+ WHILE i >= 10 DO
+ e := e * 10000000000.0D;
+ DEC(i,10);
+ END;
+ WHILE i >= 0 DO
+ e := e * 10.0D;
+ DEC(i)
+ END;
+ IF pow10<0 THEN
+ r := r / e;
+ ELSE
+ r := r * e;
+ END;
+ IF signed THEN r := -r; END;
+ IF (iB <= HIGH(str)) AND (ORD(ch) > ORD(' ')) THEN ok := FALSE; END
+ END StringToLongReal;
+
+BEGIN
+ WITH Powers10[1] DO pval := 1.0D32; rpval := 1.0D-32; exp := 32 END;
+ WITH Powers10[2] DO pval := 1.0D16; rpval := 1.0D-16; exp := 16 END;
+ WITH Powers10[3] DO pval := 1.0D8; rpval := 1.0D-8; exp := 8 END;
+ WITH Powers10[4] DO pval := 1.0D4; rpval := 1.0D-4; exp := 4 END;
+ WITH Powers10[5] DO pval := 1.0D2; rpval := 1.0D-2; exp := 2 END;
+ WITH Powers10[6] DO pval := 1.0D1; rpval := 1.0D-1; exp := 1 END;
+END RealConversions.
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE RealInOut;
+(*
+ Module: InOut for REAL numbers
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ FROM InOut IMPORT ReadString, WriteString, WriteOct;
+ FROM Traps IMPORT Message;
+ FROM SYSTEM IMPORT WORD;
+ FROM RealConversions IMPORT
+ LongRealToString, StringToLongReal;
+
+ CONST MAXNDIG = 32;
+ MAXWIDTH = MAXNDIG+7;
+ TYPE RBUF = ARRAY [0..MAXWIDTH+1] OF CHAR;
+
+ PROCEDURE WriteReal(arg: REAL; ndigits: CARDINAL);
+ BEGIN
+ WriteLongReal(LONG(arg), ndigits)
+ END WriteReal;
+
+ PROCEDURE WriteLongReal(arg: LONGREAL; ndigits: CARDINAL);
+ VAR buf : RBUF;
+ ok : BOOLEAN;
+
+ BEGIN
+ IF ndigits > MAXWIDTH THEN ndigits := MAXWIDTH; END;
+ IF ndigits < 10 THEN ndigits := 10; END;
+ LongRealToString(arg, ndigits, -INTEGER(ndigits - 7), buf, ok);
+ WriteString(buf);
+ END WriteLongReal;
+
+ PROCEDURE WriteFixPt(arg: REAL; n, k: CARDINAL);
+ BEGIN
+ WriteLongFixPt(LONG(arg), n, k)
+ END WriteFixPt;
+
+ PROCEDURE WriteLongFixPt(arg: LONGREAL; n, k: CARDINAL);
+ VAR buf: RBUF;
+ ok : BOOLEAN;
+
+ BEGIN
+ IF n > MAXWIDTH THEN n := MAXWIDTH END;
+ LongRealToString(arg, n, k, buf, ok);
+ WriteString(buf);
+ END WriteLongFixPt;
+
+ PROCEDURE ReadReal(VAR x: REAL);
+ VAR x1: LONGREAL;
+ BEGIN
+ ReadLongReal(x1);
+ x := x1
+ END ReadReal;
+
+ PROCEDURE ReadLongReal(VAR x: LONGREAL);
+ VAR Buf: ARRAY[0..512] OF CHAR;
+ ok: BOOLEAN;
+
+ BEGIN
+ ReadString(Buf);
+ StringToLongReal(Buf, x, ok);
+ IF NOT ok THEN
+ Message("real expected");
+ HALT;
+ END;
+ Done := TRUE;
+ END ReadLongReal;
+
+ PROCEDURE wroct(x: ARRAY OF WORD);
+ VAR i: CARDINAL;
+ BEGIN
+ FOR i := 0 TO HIGH(x) DO
+ WriteOct(CARDINAL(x[i]), 0);
+ WriteString(" ");
+ END;
+ END wroct;
+
+ PROCEDURE WriteRealOct(x: REAL);
+ BEGIN
+ wroct(x);
+ END WriteRealOct;
+
+ PROCEDURE WriteLongRealOct(x: LONGREAL);
+ BEGIN
+ wroct(x);
+ END WriteLongRealOct;
+
+BEGIN
+ Done := FALSE;
+END RealInOut.
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: SYSTEM
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+/*
+ An implementation of the Modula-2 NEWPROCESS and TRANSFER facilities
+ using the topsize, topsave, and topload facilities.
+ For each coroutine, a proc structure is built. For the main routine,
+ a static space is declared to save its stack. For the other coroutines,
+ the user specifies this space.
+*/
+
+#include <m2_traps.h>
+
+#define MAXMAIN 2048
+
+struct proc {
+ unsigned size; /* size of saved stackframe(s) */
+ int (*proc)(); /* address of coroutine procedure */
+ char *brk; /* stack break of this coroutine */
+};
+
+extern unsigned topsize();
+
+static struct proc mainproc[MAXMAIN/sizeof(struct proc) + 1];
+
+static struct proc *curproc = 0;/* current coroutine */
+extern char *MainLB; /* stack break of main routine */
+
+_SYSTEM__NEWPROCESS(p, a, n, p1)
+ int (*p)(); /* coroutine procedure */
+ struct proc *a; /* pointer to area for saved stack-frame */
+ unsigned n; /* size of this area */
+ struct proc **p1; /* where to leave coroutine descriptor,
+ in this implementation the address of
+ the area for saved stack-frame(s) */
+{
+ /* This procedure creates a new coroutine, but does not
+ transfer control to it. The routine "topsize" will compute the
+ stack break, which will be the local base of this routine.
+ Notice that we can do this because we do not need the stack
+ above this point for this coroutine. In Modula-2, coroutines
+ must be level 0 procedures without parameters.
+ */
+ char *brk = 0;
+ unsigned sz = topsize(&brk);
+
+ if (sz + sizeof(struct proc) > n) {
+ /* not enough space */
+ TRP(M2_TOOLARGE);
+ }
+ a->size = n;
+ a->proc = p;
+ a->brk = brk;
+ *p1 = a;
+ if (topsave(brk, a+1))
+ /* stack frame saved; now just return */
+ ;
+ else {
+ /* We get here through the first transfer to the coroutine
+ created above.
+ This also means that curproc is now set to this coroutine.
+ We cannot trust the parameters anymore.
+ Just call the coroutine procedure.
+ */
+ (*(curproc->proc))();
+ _cleanup();
+ _exit(0);
+ }
+}
+
+_SYSTEM__TRANSFER(a, b)
+ struct proc **a, **b;
+{
+ /* transfer from one coroutine to another, saving the current
+ descriptor in the space indicated by "a", and transfering to
+ the coroutine in descriptor "b".
+ */
+ unsigned size;
+
+ if (! curproc) {
+ /* the current coroutine is the main process;
+ initialize a coroutine descriptor for it ...
+ */
+ mainproc[0].brk = MainLB;
+ mainproc[0].size = sizeof(mainproc);
+ curproc = &mainproc[0];
+ }
+ *a = curproc; /* save current descriptor in "a" */
+ if (*b == curproc) {
+ /* transfer to itself is a no-op */
+ return;
+ }
+ size = topsize(&(curproc->brk));
+ if (size + sizeof(struct proc) > curproc->size) {
+ TRP(M2_TOOLARGE);
+ }
+ if (topsave(curproc->brk, curproc+1)) {
+ /* stack top saved. Now restore context of target
+ coroutine
+ */
+ curproc = *b;
+ topload(curproc+1);
+ /* we never get here ... */
+ }
+ /* but we do get here, when a transfer is done to the coroutine in "a".
+ */
+}
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Semaphores [1];
+(*
+ Module: Processes with semaphores
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+
+ Quasi-concurrency implementation
+*)
+
+ FROM SYSTEM IMPORT ADDRESS, NEWPROCESS, TRANSFER;
+ FROM Storage IMPORT Allocate;
+ FROM random IMPORT Uniform;
+ FROM Traps IMPORT Message;
+
+ TYPE Sema = POINTER TO Semaphore;
+ Processes = POINTER TO Process;
+ Semaphore =
+ RECORD
+ level: CARDINAL;
+ END;
+ Process =
+ RECORD next: Processes;
+ proc: ADDRESS;
+ waiting: Sema;
+ END;
+
+ VAR cp: Processes; (* current process *)
+
+ PROCEDURE StartProcess(P: PROC; n: CARDINAL);
+ VAR s0: Processes;
+ wsp: ADDRESS;
+ BEGIN
+ s0 := cp;
+ Allocate(wsp, n);
+ Allocate(cp, SIZE(Process));
+ WITH cp^ DO
+ next := s0^.next;
+ s0^.next := cp;
+ waiting := NIL;
+ END;
+ NEWPROCESS(P, wsp, n, cp^.proc);
+ TRANSFER(s0^.proc, cp^.proc);
+ END StartProcess;
+
+ PROCEDURE Up(VAR s: Sema);
+ BEGIN
+ s^.level := s^.level + 1;
+ ReSchedule;
+ END Up;
+
+ PROCEDURE Down(VAR s: Sema);
+ BEGIN
+ IF s^.level = 0 THEN
+ cp^.waiting := s;
+ ELSE
+ s^.level := s^.level - 1;
+ END;
+ ReSchedule;
+ END Down;
+
+ PROCEDURE NewSema(n: CARDINAL): Sema;
+ VAR s: Sema;
+ BEGIN
+ Allocate(s, SIZE(Semaphore));
+ s^.level := n;
+ RETURN s;
+ END NewSema;
+
+ PROCEDURE Level(s: Sema): CARDINAL;
+ BEGIN
+ RETURN s^.level;
+ END Level;
+
+ PROCEDURE ReSchedule;
+ VAR s0: Processes;
+ i, j: CARDINAL;
+ BEGIN
+ s0 := cp;
+ i := Uniform(1, 5);
+ j := i;
+ LOOP
+ cp := cp^.next;
+ IF Runnable(cp) THEN
+ DEC(i);
+ IF i = 0 THEN EXIT END;
+ END;
+ IF (cp = s0) AND (j = i) THEN
+ (* deadlock *)
+ Message("deadlock");
+ HALT
+ END;
+ END;
+ IF cp # s0 THEN TRANSFER(s0^.proc, cp^.proc); END;
+ END ReSchedule;
+
+ PROCEDURE Runnable(p: Processes): BOOLEAN;
+ BEGIN
+ IF p^.waiting = NIL THEN RETURN TRUE; END;
+ IF p^.waiting^.level > 0 THEN
+ p^.waiting^.level := p^.waiting^.level - 1;
+ p^.waiting := NIL;
+ RETURN TRUE;
+ END;
+ RETURN FALSE;
+ END Runnable;
+BEGIN
+ Allocate(cp, SIZE(Process));
+ WITH cp^ DO
+ next := cp;
+ waiting := NIL;
+ END
+END Semaphores.
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Storage;
+(*
+ Module: Dynamic Storage Allocation
+ Author: Ceriel J.H. Jacobs
+ Adapted from a version in C by Hans Tebra
+ Version: $Header$
+*)
+(* This storage manager maintains an array of lists of objects with the
+ same size. Commonly used sizes have their own bucket. The larger ones
+ are put in a single list.
+*)
+ FROM Unix IMPORT sbrk, ILLBREAK;
+ FROM SYSTEM IMPORT ADDRESS, ADR;
+ FROM Traps IMPORT Message;
+
+ CONST
+ NLISTS = 20;
+ MAGICW = 0A5A5H;
+ MAGICC = 175C;
+
+ TYPE
+ ALIGNTYPE =
+ RECORD
+ CASE : INTEGER OF
+ 1: l: LONGINT |
+ 2: p: ADDRESS |
+ 3: d: LONGREAL
+ END
+ END; (* A type with high alignment requirements *)
+ BucketPtr = POINTER TO Bucket;
+ Bucket =
+ RECORD
+ CASE : BOOLEAN OF
+ FALSE:
+ BNEXT: BucketPtr; (* next free Bucket *)
+ BSIZE: CARDINAL; | (* size of user part in UNITs *)
+ TRUE: BXX: ALIGNTYPE
+ END;
+ BSTORE: ALIGNTYPE;
+ END;
+
+ CONST
+ UNIT = SIZE(ALIGNTYPE);
+
+ VAR
+ FreeLists: ARRAY[0..NLISTS] OF BucketPtr; (* small blocks *)
+ Llist: BucketPtr; (* others *)
+ Compacted: BOOLEAN; (* avoid recursive reorganization *)
+ FirstBlock: BucketPtr;
+ USED: ADDRESS;
+
+ PROCEDURE MyAllocate(size: CARDINAL) : ADDRESS;
+ VAR nu : CARDINAL;
+ b : CARDINAL;
+ p, q: BucketPtr;
+ pc: POINTER TO CHAR;
+ brk : ADDRESS;
+ BEGIN
+ IF size > CARDINAL(MAX(INTEGER)-2*UNIT + 1) THEN
+ RETURN NIL;
+ END;
+ nu := (size + (UNIT-1)) DIV UNIT;
+ IF nu = 0 THEN
+ nu := 1;
+ END;
+ IF nu <= NLISTS THEN
+ b := nu;
+ IF FreeLists[b] # NIL THEN
+ (* Exact fit *)
+ p := FreeLists[b];
+ FreeLists[b] := p^.BNEXT;
+ p^.BNEXT := USED;
+ IF p^.BSIZE * UNIT # size THEN
+ pc := ADR(p^.BSTORE) + size;
+ pc^ := MAGICC;
+ END;
+ p^.BSIZE := size;
+ RETURN ADR(p^.BSTORE);
+ END;
+
+ (* Search for a block with >= 2 units more than requested.
+ We pay for an additional header when the block is split.
+ *)
+ FOR b := b+2 TO NLISTS DO
+ IF FreeLists[b] # NIL THEN
+ q := FreeLists[b];
+ FreeLists[b] := q^.BNEXT;
+ p := ADDRESS(q) + (nu+1)*UNIT;
+ (* p indicates the block that must be given
+ back
+ *)
+ p^.BSIZE := q^.BSIZE - nu - 1;
+ p^.BNEXT := FreeLists[p^.BSIZE];
+ FreeLists[p^.BSIZE] := p;
+ q^.BSIZE := nu;
+ q^.BNEXT := USED;
+ IF q^.BSIZE * UNIT # size THEN
+ pc := ADR(q^.BSTORE) + size;
+ pc^ := MAGICC;
+ END;
+ q^.BSIZE := size;
+ RETURN ADR(q^.BSTORE);
+ END;
+ END;
+ END;
+
+ p := Llist;
+ IF p # NIL THEN
+ q := NIL;
+ WHILE (p # NIL) AND (p^.BSIZE < nu) DO
+ q := p;
+ p := p^.BNEXT;
+ END;
+
+ IF p # NIL THEN
+ (* p^.BSIZE >= nu *)
+ IF p^.BSIZE <= nu + NLISTS + 1 THEN
+ (* Remove p from this list *)
+ IF q # NIL THEN q^.BNEXT := p^.BNEXT
+ ELSE Llist := p^.BNEXT;
+ END;
+ p^.BNEXT := USED;
+ IF p^.BSIZE > nu + 1 THEN
+ (* split block,
+ tail goes to FreeLists area
+ *)
+ q := ADDRESS(p) + (nu+1)*UNIT;
+ q^.BSIZE := p^.BSIZE -nu -1;
+ q^.BNEXT := FreeLists[q^.BSIZE];
+ FreeLists[q^.BSIZE] := q;
+ p^.BSIZE := nu;
+ END;
+ IF p^.BSIZE * UNIT # size THEN
+ pc := ADR(p^.BSTORE) + size;
+ pc^ := MAGICC;
+ END;
+ p^.BSIZE := size;
+ RETURN ADR(p^.BSTORE);
+ END;
+ (* Give part of tail of original block.
+ Block stays in this list.
+ *)
+ q := ADDRESS(p) + (p^.BSIZE-nu)*UNIT;
+ q^.BSIZE := nu;
+ p^.BSIZE := p^.BSIZE - nu - 1;
+ q^.BNEXT := USED;
+ IF q^.BSIZE * UNIT # size THEN
+ pc := ADR(q^.BSTORE) + size;
+ pc^ := MAGICC;
+ END;
+ q^.BSIZE := size;
+ RETURN ADR(q^.BSTORE);
+ END;
+ END;
+
+ IF Compacted THEN
+ (* reorganization did not yield sufficient memory *)
+ RETURN NIL;
+ END;
+
+ brk := sbrk(UNIT * (nu + 1));
+ IF brk = ILLBREAK THEN
+ ReOrganize();
+ Compacted := TRUE;
+ brk := MyAllocate(size);
+ Compacted := FALSE;
+ RETURN brk;
+ END;
+
+ p := brk;
+ p^.BSIZE := nu;
+ p^.BNEXT := USED;
+ IF p^.BSIZE * UNIT # size THEN
+ pc := ADR(p^.BSTORE) + size;
+ pc^ := MAGICC;
+ END;
+ p^.BSIZE := size;
+ RETURN ADR(p^.BSTORE);
+ END MyAllocate;
+
+ PROCEDURE ALLOCATE(VAR a: ADDRESS; size: CARDINAL);
+ BEGIN
+ Allocate(a, size);
+ END ALLOCATE;
+
+ PROCEDURE Allocate(VAR a: ADDRESS; size: CARDINAL);
+ BEGIN
+ a := MyAllocate(size);
+ IF a = NIL THEN
+ Message("out of core");
+ HALT;
+ END;
+ END Allocate;
+
+ PROCEDURE Available(size: CARDINAL): BOOLEAN;
+ VAR a: ADDRESS;
+ BEGIN
+ a:= MyAllocate(size);
+ IF a # NIL THEN
+ Deallocate(a, size);
+ RETURN TRUE;
+ END;
+ RETURN FALSE;
+ END Available;
+
+ PROCEDURE DEALLOCATE(VAR a: ADDRESS; size: CARDINAL);
+ BEGIN
+ Deallocate(a, size);
+ END DEALLOCATE;
+
+ PROCEDURE Deallocate(VAR a: ADDRESS; size: CARDINAL);
+ VAR p: BucketPtr;
+ pc: POINTER TO CHAR;
+ BEGIN
+ IF (a = NIL) THEN
+ Message("(Warning) Deallocate: NIL pointer deallocated");
+ RETURN;
+ END;
+ p := a - UNIT;
+ IF (p^.BNEXT # BucketPtr(USED)) THEN
+ Message("(Warning) Deallocate: area already deallocated or heap corrupted");
+ a := NIL;
+ RETURN;
+ END;
+ WITH p^ DO
+ IF BSIZE # size THEN
+ Message("(Warning) Deallocate: wrong size or heap corrupted");
+ END;
+ BSIZE := (size + (UNIT - 1)) DIV UNIT;
+ IF (BSIZE*UNIT # size) THEN
+ pc := a + size;
+ IF pc^ # MAGICC THEN
+ Message("(Warning) Deallocate: heap corrupted");
+ END;
+ END;
+ IF BSIZE <= NLISTS THEN
+ BNEXT := FreeLists[BSIZE];
+ FreeLists[BSIZE] := p;
+ ELSE
+ BNEXT := Llist;
+ Llist := p;
+ END;
+ END;
+ a := NIL
+ END Deallocate;
+
+ PROCEDURE ReOrganize();
+ VAR lastblock: BucketPtr;
+ b, be: BucketPtr;
+ i: CARDINAL;
+ BEGIN
+ lastblock := NIL;
+ FOR i := 1 TO NLISTS DO
+ b := FreeLists[i];
+ WHILE b # NIL DO
+ IF ADDRESS(b) > ADDRESS(lastblock) THEN
+ lastblock := b;
+ END;
+ be := b^.BNEXT;
+ b^.BNEXT := NIL; (* temporary free mark *)
+ b := be;
+ END;
+ END;
+
+ b := Llist;
+ WHILE b # NIL DO
+ IF ADDRESS(b) > ADDRESS(lastblock) THEN
+ lastblock := b;
+ END;
+ be := b^.BNEXT;
+ b^.BNEXT := NIL;
+ b := be;
+ END;
+
+ (* Now, all free blocks have b^.BNEXT = NIL *)
+
+ b := FirstBlock;
+ WHILE ADDRESS(b) < ADDRESS(lastblock) DO
+ LOOP
+ be := ADDRESS(b)+(b^.BSIZE+1)*UNIT;
+ IF b^.BNEXT # NIL THEN
+ (* this block is not free *)
+ EXIT;
+ END;
+ IF ADDRESS(be) > ADDRESS(lastblock) THEN
+ (* no next block *)
+ EXIT;
+ END;
+ IF be^.BNEXT # NIL THEN
+ (* next block is not free *)
+ EXIT;
+ END;
+ (* this block and the next one are free,
+ so merge them, but only if it is not too big
+ *)
+ IF MAX(CARDINAL) - b^.BSIZE > be^.BSIZE THEN
+ b^.BSIZE := b^.BSIZE + be^.BSIZE + 1;
+ ELSE
+ EXIT;
+ END;
+ END;
+ b := be;
+ END;
+
+ (* clear all free lists *)
+ FOR i := 1 TO NLISTS DO FreeLists[i] := NIL; END;
+ Llist := NIL;
+
+ (* collect free blocks in them again *)
+ b := FirstBlock;
+ WHILE ADDRESS(b) <= ADDRESS(lastblock) DO
+ WITH b^ DO
+ IF BNEXT = NIL THEN
+ IF BSIZE <= NLISTS THEN
+ BNEXT := FreeLists[BSIZE];
+ FreeLists[BSIZE] := b;
+ ELSE
+ BNEXT := Llist;
+ Llist := b;
+ END;
+ b := ADDRESS(b) + (BSIZE+1) * UNIT;
+ ELSE
+ b := ADDRESS(b) +
+ ((BSIZE + (UNIT - 1)) DIV UNIT + 1) * UNIT;
+ END;
+ END;
+ END;
+ END ReOrganize;
+
+ PROCEDURE InitStorage();
+ VAR i: CARDINAL;
+ brk: ADDRESS;
+ BEGIN
+ FOR i := 1 TO NLISTS DO
+ FreeLists[i] := NIL;
+ END;
+ Llist := NIL;
+ brk := sbrk(0);
+ brk := sbrk(UNIT - brk MOD UNIT);
+ FirstBlock := sbrk(0);
+ Compacted := FALSE;
+ USED := MAGICW;
+ END InitStorage;
+
+BEGIN
+ InitStorage();
+END Storage.
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: assign string to character array, with possible 0-byte
+ extension
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+StringAssign(dstsiz, srcsiz, dstaddr, srcaddr)
+ register char *dstaddr, *srcaddr;
+{
+ while (srcsiz > 0) {
+ *dstaddr++ = *srcaddr++;
+ srcsiz--;
+ dstsiz--;
+ }
+ if (dstsiz > 0) {
+ *dstaddr = 0;
+ }
+}
--- /dev/null
+#
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Streams;
+(*
+ Module: Stream Input/Output
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+
+ Implementation for Unix
+*)
+
+ FROM SYSTEM IMPORT BYTE, ADR;
+ FROM Epilogue IMPORT CallAtEnd;
+ FROM Storage IMPORT Allocate, Available;
+ FROM StripUnix IMPORT
+ open, close, lseek, read, write, creat;
+ IMPORT StripUnix;
+
+ CONST BUFSIZ = 1024; (* tunable *)
+ TYPE IOB = RECORD
+ kind: StreamKind;
+ mode: StreamMode;
+ eof: BOOLEAN;
+ buffering: StreamBuffering;
+ next : Stream;
+ fildes: INTEGER;
+ cnt, maxcnt: INTEGER;
+ bufferedcnt: INTEGER;
+ buf: ARRAY[1..BUFSIZ] OF BYTE;
+ END;
+ Stream = POINTER TO IOB;
+ VAR
+ ibuf, obuf, ebuf: IOB;
+ head: Stream;
+
+ PROCEDURE getstruct(VAR stream: Stream);
+ BEGIN
+ stream := head;
+ WHILE (stream # NIL) AND (stream^.kind # none) DO
+ stream := stream^.next;
+ END;
+ IF stream = NIL THEN
+ IF NOT Available(SIZE(IOB)) THEN
+ RETURN;
+ END;
+ Allocate(stream,SIZE(IOB));
+ stream^.next := head;
+ head := stream;
+ END;
+ END getstruct;
+
+ PROCEDURE freestruct(stream: Stream);
+ BEGIN
+ stream^.kind := none;
+ END freestruct;
+
+ PROCEDURE OpenStream(VAR stream: Stream;
+ filename: ARRAY OF CHAR;
+ kind: StreamKind;
+ mode: StreamMode;
+ VAR result: StreamResult);
+ VAR fd: INTEGER;
+ i: CARDINAL;
+ BEGIN
+ IF kind = none THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ getstruct(stream);
+ IF stream = NIL THEN
+ result := nomemory;
+ RETURN;
+ END;
+ WITH stream^ DO
+ FOR i := 0 TO HIGH(filename) DO
+ buf[i+1] := BYTE(filename[i]);
+ END;
+ buf[HIGH(filename)+2] := BYTE(0C);
+ END;
+ IF (mode = reading) THEN
+ fd := open(ADR(stream^.buf), 0);
+ ELSE
+ fd := -1;
+ IF (mode = appending) THEN
+ fd := open(ADR(stream^.buf), 1);
+ IF fd >= 0 THEN
+ IF (lseek(fd, 0D , 2) < 0D) THEN ; END;
+ END;
+ END;
+ IF fd < 0 THEN
+ fd := creat(ADR(stream^.buf), 666B);
+ END;
+ END;
+ IF fd < 0 THEN
+ result := openfailed;
+ freestruct(stream);
+ stream := NIL;
+ RETURN;
+ END;
+ result := succeeded;
+ stream^.fildes := fd;
+ stream^.kind := kind;
+ stream^.mode := mode;
+ stream^.buffering := blockbuffered;
+ stream^.bufferedcnt := BUFSIZ;
+ stream^.maxcnt := 0;
+ stream^.eof := FALSE;
+ IF mode = reading THEN
+ stream^.cnt := 1;
+ ELSE
+ stream^.cnt := 0;
+ END;
+ END OpenStream;
+
+ PROCEDURE SetStreamBuffering( stream: Stream;
+ b: StreamBuffering;
+ VAR result: StreamResult);
+ BEGIN
+ result := succeeded;
+ IF (stream = NIL) OR (stream^.kind = none) THEN
+ result := nostream;
+ RETURN;
+ END;
+ IF (stream^.mode = reading) OR
+ ((b = linebuffered) AND (stream^.kind = binary)) THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ FlushStream(stream, result);
+ IF b = unbuffered THEN
+ stream^.bufferedcnt := 1;
+ END;
+ stream^.buffering := b;
+ END SetStreamBuffering;
+
+ PROCEDURE FlushStream(stream: Stream; VAR result: StreamResult);
+ VAR cnt1: INTEGER;
+ BEGIN
+ result := succeeded;
+ IF (stream = NIL) OR (stream^.kind = none) THEN
+ result := nostream;
+ RETURN;
+ END;
+ WITH stream^ DO
+ IF mode = reading THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ IF (cnt > 0) THEN
+ cnt1 := cnt;
+ cnt := 0;
+ IF write(fildes, ADR(buf), cnt1) < 0 THEN END;
+ END;
+ END;
+ END FlushStream;
+
+ PROCEDURE CloseStream(VAR stream: Stream; VAR result: StreamResult);
+ BEGIN
+ IF (stream # NIL) AND (stream^.kind # none) THEN
+ result := succeeded;
+ IF stream^.mode # reading THEN
+ FlushStream(stream, result);
+ END;
+ IF close(stream^.fildes) < 0 THEN ; END;
+ freestruct(stream);
+ ELSE
+ result := nostream;
+ END;
+ stream := NIL;
+ END CloseStream;
+
+ PROCEDURE EndOfStream(stream: Stream; VAR result: StreamResult): BOOLEAN;
+ BEGIN
+ result := succeeded;
+ IF (stream = NIL) OR (stream^.kind = none) THEN
+ result := nostream;
+ RETURN FALSE;
+ END;
+ IF stream^.mode # reading THEN
+ result := illegaloperation;
+ RETURN FALSE;
+ END;
+ IF stream^.eof THEN RETURN TRUE; END;
+ RETURN (CHAR(NextByte(stream)) = 0C) AND stream^.eof;
+ END EndOfStream;
+
+ PROCEDURE FlushLineBuffers();
+ VAR s: Stream;
+ result: StreamResult;
+ BEGIN
+ s := head;
+ WHILE s # NIL DO
+ IF (s^.kind # none) AND (s^.buffering = linebuffered) THEN
+ FlushStream(s, result);
+ END;
+ s := s^.next;
+ END;
+ END FlushLineBuffers;
+
+ PROCEDURE NextByte(stream: Stream): BYTE;
+ VAR c: BYTE;
+ BEGIN
+ WITH stream^ DO
+ IF cnt <= maxcnt THEN
+ c := buf[cnt];
+ ELSE
+ IF eof THEN RETURN BYTE(0C); END;
+ IF stream = InputStream THEN
+ FlushLineBuffers();
+ END;
+ maxcnt := read(fildes, ADR(buf), bufferedcnt);
+ cnt := 1;
+ IF maxcnt <= 0 THEN
+ eof := TRUE;
+ c := BYTE(0C);
+ ELSE
+ c := buf[1];
+ END;
+ END;
+ END;
+ RETURN c;
+ END NextByte;
+
+ PROCEDURE Read(stream: Stream; VAR ch: CHAR; VAR result: StreamResult);
+ VAR EoF: BOOLEAN;
+ BEGIN
+ ch := 0C;
+ EoF := EndOfStream(stream, result);
+ IF result # succeeded THEN RETURN; END;
+ IF EoF THEN
+ result := endoffile;
+ RETURN;
+ END;
+ WITH stream^ DO
+ ch := CHAR(buf[cnt]);
+ INC(cnt);
+ END;
+ END Read;
+
+ PROCEDURE ReadByte(stream: Stream; VAR byte: BYTE; VAR result: StreamResult);
+ VAR EoF: BOOLEAN;
+ BEGIN
+ byte := BYTE(0C);
+ EoF := EndOfStream(stream, result);
+ IF result # succeeded THEN RETURN; END;
+ IF EoF THEN
+ result := endoffile;
+ RETURN;
+ END;
+ WITH stream^ DO
+ byte := buf[cnt];
+ INC(cnt);
+ END;
+ END ReadByte;
+
+ PROCEDURE ReadBytes(stream: Stream;
+ VAR bytes: ARRAY OF BYTE;
+ VAR result: StreamResult);
+ VAR i: CARDINAL;
+ BEGIN
+ FOR i := 0 TO HIGH(bytes) DO
+ ReadByte(stream, bytes[i], result);
+ END;
+ END ReadBytes;
+
+ PROCEDURE Write(stream: Stream; ch: CHAR; VAR result: StreamResult);
+ BEGIN
+ IF (stream = NIL) OR (stream^.kind = none) THEN
+ result := nostream;
+ RETURN;
+ END;
+ IF (stream^.kind # text) OR (stream^.mode = reading) THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ WITH stream^ DO
+ INC(cnt);
+ buf[cnt] := BYTE(ch);
+ IF (cnt >= bufferedcnt) OR
+ ((ch = 12C) AND (buffering = linebuffered))
+ THEN
+ FlushStream(stream, result);
+ END;
+ END;
+ END Write;
+
+ PROCEDURE WriteByte(stream: Stream; byte: BYTE; VAR result: StreamResult);
+ BEGIN
+ IF (stream = NIL) OR (stream^.kind = none) THEN
+ result := nostream;
+ RETURN;
+ END;
+ IF (stream^.kind # binary) OR (stream^.mode = reading) THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ WITH stream^ DO
+ INC(cnt);
+ buf[cnt] := byte;
+ IF cnt >= bufferedcnt THEN
+ FlushStream(stream, result);
+ END;
+ END;
+ END WriteByte;
+
+ PROCEDURE WriteBytes(stream: Stream; bytes: ARRAY OF BYTE; VAR result: StreamResult);
+ VAR i: CARDINAL;
+ BEGIN
+ FOR i := 0 TO HIGH(bytes) DO
+ WriteByte(stream, bytes[i], result);
+ END;
+ END WriteBytes;
+
+ PROCEDURE EndIt;
+ VAR h, h1 : Stream;
+ result: StreamResult;
+ BEGIN
+ h := head;
+ WHILE h # NIL DO
+ h1 := h;
+ CloseStream(h1, result);
+ h := h^.next;
+ END;
+ END EndIt;
+
+ PROCEDURE GetPosition(s: Stream; VAR position: LONGINT;
+ VAR result: StreamResult);
+ BEGIN
+ IF (s = NIL) OR (s^.kind = none) THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ IF (s^.mode # reading) THEN FlushStream(s, result); END;
+ position := lseek(s^.fildes, 0D, 1);
+ IF position < 0D THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ IF s^.mode = reading THEN
+ position := position + LONG(s^.maxcnt - s^.cnt + 1);
+ END;
+ END GetPosition;
+
+ PROCEDURE SetPosition(s: Stream; position: LONGINT; VAR result: StreamResult);
+ VAR currpos: LONGINT;
+ BEGIN
+ currpos := 0D;
+ IF (s = NIL) OR (s^.kind = none) THEN
+ result := nostream;
+ RETURN;
+ END;
+ IF (s^.mode # reading) THEN
+ FlushStream(s, result);
+ ELSE
+ s^.maxcnt := 0;
+ s^.eof := FALSE;
+ END;
+ IF s^.mode = appending THEN
+ currpos := lseek(s^.fildes, 0D, 1);
+ IF currpos < 0D THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ END;
+ IF position < currpos THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ currpos := lseek(s^.fildes, position, 0);
+ IF currpos < 0D THEN
+ result := illegaloperation;
+ RETURN;
+ END;
+ result := succeeded;
+ END SetPosition;
+
+ PROCEDURE isatty(stream: Stream; VAR result: StreamResult): BOOLEAN;
+ BEGIN
+ IF (stream = NIL) OR (stream^.kind = none) THEN
+ result := nostream;
+ RETURN FALSE;
+ END;
+ RETURN StripUnix.isatty(stream^.fildes);
+ END isatty;
+
+ PROCEDURE InitStreams;
+ VAR result: StreamResult;
+ BEGIN
+ InputStream := ADR(ibuf);
+ OutputStream := ADR(obuf);
+ ErrorStream := ADR(ebuf);
+ WITH ibuf DO
+ kind := text;
+ mode := reading;
+ eof := FALSE;
+ next := ADR(obuf);
+ fildes := 0;
+ maxcnt := 0;
+ cnt := 1;
+ bufferedcnt := BUFSIZ;
+ END;
+ WITH obuf DO
+ kind := text;
+ mode := writing;
+ eof := TRUE;
+ next := ADR(ebuf);
+ fildes := 1;
+ maxcnt := 0;
+ cnt := 0;
+ bufferedcnt := BUFSIZ;
+ IF isatty(OutputStream, result) THEN
+ buffering := linebuffered;
+ ELSE
+ buffering := blockbuffered;
+ END;
+ END;
+ WITH ebuf DO
+ kind := text;
+ mode := writing;
+ eof := TRUE;
+ next := NIL;
+ fildes := 2;
+ maxcnt := 0;
+ cnt := 0;
+ bufferedcnt := BUFSIZ;
+ IF isatty(ErrorStream, result) THEN
+ buffering := linebuffered;
+ ELSE
+ buffering := blockbuffered;
+ END;
+ END;
+ head := InputStream;
+ IF CallAtEnd(EndIt) THEN ; END;
+ END InitStreams;
+
+BEGIN
+ InitStreams
+END Streams.
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Strings;
+(*
+ Module: String manipulations
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ PROCEDURE Assign(source: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
+ (* Assign string source to dest
+ *)
+ VAR i: CARDINAL;
+ max: CARDINAL;
+ BEGIN
+ max := HIGH(source);
+ IF HIGH(dest) < max THEN max := HIGH(dest); END;
+ i := 0;
+ WHILE (i <= max) AND (source[i] # 0C) DO
+ dest[i] := source[i];
+ INC(i);
+ END;
+ IF i < HIGH(dest) THEN dest[i] := 0C; END;
+ END Assign;
+
+ PROCEDURE Insert(substr: ARRAY OF CHAR; VAR str: ARRAY OF CHAR; inx: CARDINAL);
+ (* Insert the string substr into str, starting at str[inx].
+ If inx is equal to or greater than Length(str) then substr is appended
+ to the end of str.
+ *)
+ VAR sublen, length, i: CARDINAL;
+ BEGIN
+ sublen := Length(substr);
+ IF sublen = 0 THEN RETURN; END;
+ length := Length(str);
+ IF inx > length THEN inx := length; END;
+ i := length;
+ IF i + sublen - 1 > HIGH(str) THEN i := HIGH(str); END;
+ WHILE i > inx DO
+ str[i+sublen-1] := str[i-1];
+ DEC(i);
+ END;
+ FOR i := 0 TO sublen - 1 DO
+ IF i + inx <= HIGH(str) THEN
+ str[i + inx] := substr[i];
+ ELSE
+ RETURN;
+ END;
+ END;
+ IF length + sublen <= HIGH(str) THEN
+ str[length + sublen] := 0C;
+ END;
+ END Insert;
+
+ PROCEDURE Delete(VAR str: ARRAY OF CHAR; inx, len: CARDINAL);
+ (* Delete len characters from str, starting at str[inx].
+ If inx >= Length(str) then nothing happens.
+ If there are not len characters to delete, characters to the end of the
+ string are deleted.
+ *)
+ VAR length: CARDINAL;
+ BEGIN
+ IF len = 0 THEN RETURN; END;
+ length := Length(str);
+ IF inx >= length THEN RETURN; END;
+ WHILE inx + len < length DO
+ str[inx] := str[inx + len];
+ INC(inx);
+ END;
+ str[inx] := 0C;
+ END Delete;
+
+ PROCEDURE Pos(substr, str: ARRAY OF CHAR): CARDINAL;
+ (* Return the index into str of the first occurrence of substr.
+ Pos returns a value greater than HIGH(str) of no occurrence is found.
+ *)
+ VAR i, j, max, subl: CARDINAL;
+ BEGIN
+ max := Length(str);
+ subl := Length(substr);
+ IF subl > max THEN RETURN HIGH(str) + 1; END;
+ IF subl = 0 THEN RETURN 0; END;
+ max := max - subl;
+ FOR i := 0 TO max DO
+ j := 0;
+ WHILE (j <= subl-1) AND (str[i+j] = substr[j]) DO
+ INC(j);
+ END;
+ IF j = subl THEN RETURN i; END;
+ END;
+ RETURN HIGH(str) + 1;
+ END Pos;
+
+ PROCEDURE Copy(str: ARRAY OF CHAR;
+ inx, len: CARDINAL;
+ VAR result: ARRAY OF CHAR);
+ (* Copy at most len characters from str into result, starting at str[inx].
+ *)
+ VAR i: CARDINAL;
+ BEGIN
+ IF Length(str) <= inx THEN RETURN END;
+ i := 0;
+ LOOP
+ IF i > HIGH(result) THEN RETURN; END;
+ IF len = 0 THEN EXIT; END;
+ IF inx > HIGH(str) THEN EXIT; END;
+ result[i] := str[inx];
+ INC(i); INC(inx); DEC(len);
+ END;
+ IF i <= HIGH(result) THEN result[i] := 0C; END;
+ END Copy;
+
+ PROCEDURE Concat(s1, s2: ARRAY OF CHAR; VAR result: ARRAY OF CHAR);
+ (* Concatenate two strings.
+ *)
+ VAR i, j: CARDINAL;
+ BEGIN
+ i := 0;
+ WHILE (i <= HIGH(s1)) AND (s1[i] # 0C) DO
+ IF i > HIGH(result) THEN RETURN END;
+ result[i] := s1[i];
+ INC(i);
+ END;
+ j := 0;
+ WHILE (j <= HIGH(s2)) AND (s2[j] # 0C) DO
+ IF i > HIGH(result) THEN RETURN END;
+ result[i] := s2[j];
+ INC(i);
+ INC(j);
+ END;
+ IF i <= HIGH(result) THEN result[i] := 0C; END;
+ END Concat;
+
+ PROCEDURE Length(str: ARRAY OF CHAR): CARDINAL;
+ (* Return number of characters in str.
+ *)
+ VAR i: CARDINAL;
+ BEGIN
+ i := 0;
+ WHILE (i <= HIGH(str)) DO
+ IF str[i] = 0C THEN RETURN i; END;
+ INC(i);
+ END;
+ RETURN i;
+ END Length;
+
+ PROCEDURE CompareStr(s1, s2: ARRAY OF CHAR): INTEGER;
+ (* Compare two strings, return -1 if s1 < s2, 0 if s1 = s2, and 1 if s1 > s2.
+ *)
+ VAR i: CARDINAL;
+ max: CARDINAL;
+ BEGIN
+ max := HIGH(s1);
+ IF HIGH(s2) < max THEN max := HIGH(s2); END;
+ i := 0;
+ WHILE (i <= max) DO
+ IF s1[i] < s2[i] THEN RETURN -1; END;
+ IF s1[i] > s2[i] THEN RETURN 1; END;
+ IF s1[i] = 0C THEN RETURN 0; END;
+ INC(i);
+ END;
+ IF (i <= HIGH(s1)) AND (s1[i] # 0C) THEN RETURN 1; END;
+ IF (i <= HIGH(s2)) AND (s2[i] # 0C) THEN RETURN -1; END;
+ RETURN 0;
+ END CompareStr;
+
+END Strings.
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*
+ Module: Interface to termcap database
+ From: Unix manual chapter 3
+ Version: $Header$
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Termcap;
+
+ IMPORT XXTermcap;
+ FROM SYSTEM IMPORT ADR, ADDRESS;
+ FROM Unix IMPORT isatty;
+ FROM Arguments IMPORT
+ GetEnv;
+
+ TYPE STR = ARRAY[1..32] OF CHAR;
+ STRCAP = POINTER TO STR;
+
+ VAR Buf, Buf1 : ARRAY [1..1024] OF CHAR;
+ BufCnt : INTEGER;
+
+ PROCEDURE Tgetent(name: ARRAY OF CHAR) : INTEGER;
+ VAR i: INTEGER;
+ x: STRCAP;
+ BEGIN
+ i := XXTermcap.tgetent(ADR(Buf), ADR(name));
+ BufCnt := 1;
+ IF isatty(1) THEN
+ ELSE
+ (* This used to be something returned by gtty(). To increase
+ * portability we forget about old terminals needing delays.
+ * (kjb)
+ *)
+ XXTermcap.ospeed := 0;
+ END;
+ IF i > 0 THEN
+ IF Tgetstr("pc", x) THEN
+ XXTermcap.PC := x^[1];
+ ELSE XXTermcap.PC := 0C;
+ END;
+ IF Tgetstr("up", x) THEN ; END; XXTermcap.UP := x;
+ IF Tgetstr("bc", x) THEN ; END; XXTermcap.BC := x;
+ END;
+ RETURN i;
+ END Tgetent;
+
+ PROCEDURE Tgetnum(id: ARRAY OF CHAR): INTEGER;
+ BEGIN
+ RETURN XXTermcap.tgetnum(ADR(id));
+ END Tgetnum;
+
+ PROCEDURE Tgetflag(id: ARRAY OF CHAR): BOOLEAN;
+ BEGIN
+ RETURN XXTermcap.tgetflag(ADR(id)) = 1;
+ END Tgetflag;
+
+ PROCEDURE Tgoto(cm: STRCAP; col, line: INTEGER): STRCAP;
+ BEGIN
+ RETURN XXTermcap.tgoto(cm, col, line);
+ END Tgoto;
+
+ PROCEDURE Tgetstr(id: ARRAY OF CHAR; VAR res: STRCAP) : BOOLEAN;
+ VAR a, a2: ADDRESS;
+ b: CARDINAL;
+ BEGIN
+ a := ADR(Buf1[BufCnt]);
+ a2 := XXTermcap.tgetstr(ADR(id), ADR(a));
+ res := a2;
+ IF a2 = NIL THEN
+ RETURN FALSE;
+ END;
+ b := a - a2;
+ INC(BufCnt, b);
+ RETURN TRUE;
+ END Tgetstr;
+
+ PROCEDURE Tputs(cp: STRCAP; affcnt: INTEGER; p: PUTPROC);
+ BEGIN
+ XXTermcap.tputs(cp, affcnt, XXTermcap.PUTPROC(p));
+ END Tputs;
+
+ PROCEDURE InitTermcap;
+ VAR Bf: STR;
+ BEGIN
+ IF GetEnv("TERM", Bf) = 0 THEN
+ Bf := "dumb";
+ END;
+ IF Tgetent(Bf) <= 0 THEN
+ END;
+ END InitTermcap;
+
+BEGIN
+ InitTermcap;
+END Termcap.
--- /dev/null
+#
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Terminal;
+(*
+ Module: Input/Output to/from terminals
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+
+ Implementation for Unix.
+*)
+ FROM SYSTEM IMPORT ADR;
+#ifdef __USG
+ FROM Unix IMPORT read, write, open, fcntl;
+#else
+ FROM Unix IMPORT read, write, open, ioctl;
+#endif
+ VAR fildes: INTEGER;
+ unreadch: CHAR;
+ unread: BOOLEAN;
+ tty: ARRAY[0..8] OF CHAR;
+
+ PROCEDURE Read(VAR ch: CHAR);
+ BEGIN
+ IF unread THEN
+ ch := unreadch;
+ unread := FALSE
+ ELSE
+ IF read(fildes, ADR(ch), 1) < 0 THEN
+ ;
+ END;
+ END;
+ unreadch := ch;
+ END Read;
+
+ PROCEDURE BusyRead(VAR ch: CHAR);
+ VAR l: INTEGER;
+ BEGIN
+ IF unread THEN
+ ch := unreadch;
+ unread := FALSE
+ ELSE
+#ifdef __USG
+ l := fcntl(fildes, (*FGETFL*) 3, 0);
+ IF fcntl(fildes,
+ (* FSETFL *) 4,
+ l + (*ONDELAY*) 2) < 0 THEN
+ ;
+ END;
+ IF read(fildes, ADR(ch), 1) = 0 THEN
+ ch := 0C;
+ ELSE
+ unreadch := ch;
+ END;
+ IF fcntl(fildes, (*FSETFL*)4, l) < 0 THEN
+ ;
+ END;
+#else
+#ifdef __BSD4_2
+ IF ioctl(fildes, INTEGER(ORD('f')*256+127+4*65536+40000000H), ADR(l)) < 0 THEN
+#else
+ IF ioctl(fildes, INTEGER(ORD('f')*256+127), ADR(l)) < 0 THEN
+#endif
+ ;
+ END;
+
+ IF l = 0 THEN
+ ch := 0C;
+ ELSE
+ IF read(fildes, ADR(ch), 1) < 0 THEN
+ ;
+ END;
+ unreadch := ch;
+ END;
+#endif
+ END;
+ END BusyRead;
+
+ PROCEDURE ReadAgain;
+ BEGIN
+ unread := TRUE;
+ END ReadAgain;
+
+ PROCEDURE Write(ch: CHAR);
+ BEGIN
+ IF write(fildes, ADR(ch), 1) < 0 THEN
+ ;
+ END;
+ END Write;
+
+ PROCEDURE WriteLn;
+ BEGIN
+ Write(12C);
+ END WriteLn;
+
+ PROCEDURE WriteString(s: ARRAY OF CHAR);
+ VAR i: CARDINAL;
+ BEGIN
+ i := 0;
+ WHILE (i <= HIGH(s)) & (s[i] # 0C) DO
+ Write(s[i]);
+ INC(i)
+ END
+ END WriteString;
+
+BEGIN
+ tty := "/dev/tty";
+ fildes := open(ADR(tty), 2);
+ unread := FALSE;
+END Terminal.
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE Traps;
+(*
+ Module: Facility for handling traps
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ FROM EM IMPORT SIG, LINO, FILN, TRP;
+ FROM Unix IMPORT write;
+ FROM SYSTEM IMPORT ADDRESS, ADR;
+ FROM Arguments IMPORT
+ Argv;
+
+ PROCEDURE InstallTrapHandler(t: TrapHandler): TrapHandler;
+ (* Install a new trap handler, and return the previous one.
+ Parameter of trap handler is the trap number.
+ *)
+ BEGIN
+ RETURN SIG(t);
+ END InstallTrapHandler;
+
+ PROCEDURE Message(str: ARRAY OF CHAR);
+ (* Write message "str" on standard error, preceeded by filename and
+ linenumber if possible
+ *)
+ VAR p: POINTER TO CHAR;
+ l: CARDINAL;
+ lino: INTEGER;
+ buf, buf2: ARRAY [0..255] OF CHAR;
+ i, j: CARDINAL;
+ BEGIN
+ p := FILN();
+ IF p # NIL THEN
+ i := 1;
+ buf[0] := '"';
+ WHILE p^ # 0C DO
+ buf[i] := p^;
+ INC(i);
+ p := ADDRESS(p) + 1;
+ END;
+ buf[i] := '"';
+ INC(i);
+ IF write(2, ADR(buf), i) < 0 THEN END;
+ ELSE
+ l := Argv(0, buf);
+ IF write(2, ADR(buf), l-1) < 0 THEN END;
+ END;
+ lino := LINO();
+ i := 0;
+ IF lino # 0 THEN
+ i := 7;
+ buf[0] := ','; buf[1] := ' ';
+ buf[2] := 'l'; buf[3] := 'i'; buf[4] := 'n'; buf[5] := 'e';
+ buf[6] := ' ';
+ IF lino < 0 THEN
+ buf[7] := '-';
+ i := 8;
+ lino := - lino;
+ END;
+ j := 0;
+ REPEAT
+ buf2[j] := CHR(CARDINAL(lino) MOD 10 + ORD('0'));
+ lino := lino DIV 10;
+ INC(j);
+ UNTIL lino = 0;
+ WHILE j > 0 DO
+ DEC(j);
+ buf[i] := buf2[j];
+ INC(i);
+ END;
+ END;
+ buf[i] := ':';
+ buf[i+1] := ' ';
+ IF write(2, ADR(buf), i+2) < 0 THEN END;
+ i := 0;
+ WHILE (i <= HIGH(str)) AND (str[i] # 0C) DO
+ INC(i);
+ END;
+ IF write(2, ADR(str), i) < 0 THEN END;
+ buf[0] := 12C;
+ IF write(2, ADR(buf), 1) < 0 THEN END;
+ END Message;
+
+ PROCEDURE Trap(n: INTEGER);
+ (* cause trap number "n" to occur *)
+ BEGIN
+ TRP(n);
+ END Trap;
+
+END Traps.
--- /dev/null
+/*
+ * termcap.c 1.1 20/7/87 agc Joypace Ltd
+ *
+ * Copyright Joypace Ltd, London, UK, 1987. All rights reserved.
+ * This file may be freely distributed provided that this notice
+ * remains attached.
+ *
+ * A public domain implementation of the termcap(3) routines.
+ *
+ * Made fully functional by Ceriel J.H. Jacobs.
+ *
+ * BUGS:
+ * - does not check termcap entry sizes
+ * - not fully tested
+ */
+
+#define CAPABLEN 2
+
+#define ISSPACE(c) ((c) == ' ' || (c) == '\t' || (c) == '\r' || (c) == '\n')
+#define ISDIGIT(x) ((x) >= '0' && (x) <= '9')
+
+short ospeed = 0; /* output speed */
+char PC = 0; /* padding character */
+char *BC = 0; /* back cursor movement */
+char *UP = 0; /* up cursor movement */
+
+static char *capab = 0; /* the capability itself */
+static int check_for_tc();
+static int match_name();
+
+#define NULL 0
+
+/* Some things from C-library, needed here because the C-library is not
+ loaded with Modula-2 programs
+*/
+
+static char *
+strcat(s1, s2)
+register char *s1, *s2;
+{
+ /* Append s2 to the end of s1. */
+
+ char *original = s1;
+
+ /* Find the end of s1. */
+ while (*s1 != 0) s1++;
+
+ /* Now copy s2 to the end of s1. */
+ while (*s1++ = *s2++) /* nothing */ ;
+ return(original);
+}
+
+static char *
+strcpy(s1, s2)
+register char *s1, *s2;
+{
+/* Copy s2 to s1. */
+ char *original = s1;
+
+ while (*s1++ = *s2++) /* nothing */;
+ return(original);
+}
+
+static int
+strlen(s)
+char *s;
+{
+/* Return length of s. */
+
+ char *original = s;
+
+ while (*s != 0) s++;
+ return(s - original);
+}
+
+static int
+strcmp(s1, s2)
+register char *s1, *s2;
+{
+/* Compare 2 strings. */
+
+ for(;;) {
+ if (*s1 != *s2) {
+ if (!*s1) return -1;
+ if (!*s2) return 1;
+ return(*s1 - *s2);
+ }
+ if (*s1++ == 0) return(0);
+ s2++;
+ }
+}
+
+static int
+strncmp(s1, s2, n)
+ register char *s1, *s2;
+ int n;
+{
+/* Compare two strings, but at most n characters. */
+
+ while (n-- > 0) {
+ if (*s1 != *s2) {
+ if (!*s1) return -1;
+ if (!*s2) return 1;
+ return(*s1 - *s2);
+ }
+ if (*s1++ == 0) break;
+ s2++;
+ }
+ return 0;
+}
+
+static char *
+getenv(name)
+register char *name;
+{
+ extern char ***_penviron;
+ register char **v = *_penviron, *p, *q;
+
+ if (v == 0 || name == 0) return 0;
+ while ((p = *v++) != 0) {
+ q = name;
+ while (*q && *q++ == *p++) /* nothing */ ;
+ if (*q || *p != '=') continue;
+ return(p+1);
+ }
+ return(0);
+}
+
+static char *
+fgets(buf, count, fd)
+ char *buf;
+{
+ static char bf[1024];
+ static int cnt = 0;
+ static char *pbf = &bf[0];
+ register char *c = buf;
+
+
+ while (--count) {
+ if (pbf >= &bf[cnt]) {
+ if ((cnt = read(fd, bf, 1024)) <= 0) {
+ if (c == buf) return (char *) NULL;
+ *c = 0;
+ return buf;
+ }
+ pbf = &bf[0];
+ }
+ *c = *pbf++;
+ if (*c++ == '\n') {
+ *c = 0;
+ return buf;
+ }
+ }
+ *c = 0;
+ return buf;
+}
+
+/*
+ * tgetent - get the termcap entry for terminal name, and put it
+ * in bp (which must be an array of 1024 chars). Returns 1 if
+ * termcap entry found, 0 if not found, and -1 if file not found.
+ */
+int
+tgetent(bp, name)
+char *bp;
+char *name;
+{
+ int fp;
+ char *file;
+ char *cp;
+ short len = strlen(name);
+ char buf[1024];
+
+ capab = bp;
+ if ((file = getenv("TERMCAP")) != (char *) NULL) {
+ if (*file != '/' &&
+ (cp = getenv("TERM")) != NULL && strcmp(name, cp) == 0) {
+ (void) strcpy(bp, file);
+ return(1);
+ }
+ else file = "/etc/termcap";
+ } else
+ file = "/etc/termcap";
+ if ((fp = open(file, 0)) < 0) {
+ capab = 0;
+ return(-1);
+ }
+ while (fgets(buf, 1024, fp) != NULL) {
+ if (buf[0] == '#') continue;
+ while (*(cp = &buf[strlen(buf) - 2]) == '\\')
+ if (fgets(cp, 1024, fp) == NULL)
+ return (0);
+ if (match_name(buf, name)) {
+ strcpy(bp, buf);
+ close(fp);
+ if(check_for_tc() == 0) {
+ capab = 0;
+ return 0;
+ }
+ return 1;
+ }
+ }
+ capab = 0;
+ close(fp);
+ return(0);
+}
+
+/*
+ * Compare the terminal name with each termcap entry name; Return 1 if a
+ * match is found.
+ */
+static int
+match_name(buf, name)
+ char *buf;
+ char *name;
+{
+ register char *tp = buf;
+ register char *np;
+
+ for (;;) {
+ for (np = name; *np && *tp == *np; np++, tp++) { }
+ if (*np == 0 && (*tp == '|' || *tp == ':' || *tp == 0))
+ return(1);
+ while (*tp != 0 && *tp != '|' && *tp != ':') tp++;
+ if (*tp++ != '|') return (0);
+ }
+}
+
+/*
+ * Handle tc= definitions recursively.
+ */
+static int
+check_for_tc()
+{
+ static int count = 0;
+ char *savcapab = capab;
+ char buf[1024];
+ char terminalname[128];
+ register char *p = capab + strlen(capab) - 2, *q;
+
+ while (*p != ':')
+ if (--p < capab)
+ return(0); /* no : in termcap entry */
+ if (p[1] != 't' || p[2] != 'c')
+ return(1);
+ if (count > 16) {
+ return(0); /* recursion in tc= definitions */
+ }
+ count++;
+ strcpy(terminalname, &p[4]);
+ q = terminalname;
+ while (*q && *q != ':') q++;
+ *q = 0;
+ if (tgetent(buf, terminalname) != 1) {
+ --count;
+ return(0);
+ }
+ --count;
+ for (q = buf; *q && *q != ':'; q++) { }
+ strcpy(p, q);
+ capab = savcapab;
+ return(1);
+}
+
+/*
+ * tgetnum - get the numeric terminal capability corresponding
+ * to id. Returns the value, -1 if invalid.
+ */
+int
+tgetnum(id)
+char *id;
+{
+ char *cp;
+ int ret;
+
+ if ((cp = capab) == NULL || id == NULL || *cp == 0)
+ return(-1);
+ while (*++cp && *cp != ':')
+ ;
+ while (*cp) {
+ cp++;
+ while (ISSPACE(*cp))
+ cp++;
+ if (strncmp(cp, id, CAPABLEN) == 0) {
+ while (*cp && *cp != ':' && *cp != '#')
+ cp++;
+ if (*cp != '#')
+ return(-1);
+ for (ret = 0, cp++ ; *cp && ISDIGIT(*cp) ; cp++)
+ ret = ret * 10 + *cp - '0';
+ return(ret);
+ }
+ while (*cp && *cp != ':')
+ cp++;
+ }
+ return(-1);
+}
+
+/*
+ * tgetflag - get the boolean flag corresponding to id. Returns -1
+ * if invalid, 0 if the flag is not in termcap entry, or 1 if it is
+ * present.
+ */
+int
+tgetflag(id)
+char *id;
+{
+ char *cp;
+
+ if ((cp = capab) == NULL || id == NULL || *cp == 0)
+ return(-1);
+ while (*++cp && *cp != ':')
+ ;
+ while (*cp) {
+ cp++;
+ while (ISSPACE(*cp))
+ cp++;
+ if (strncmp(cp, id, CAPABLEN) == 0)
+ return(1);
+ while (*cp && *cp != ':')
+ cp++;
+ }
+ return(0);
+}
+
+/*
+ * tgetstr - get the string capability corresponding to id and place
+ * it in area (advancing area at same time). Expand escape sequences
+ * etc. Returns the string, or NULL if it can't do it.
+ */
+char *
+tgetstr(id, area)
+char *id;
+char **area;
+{
+ char *cp;
+ char *ret;
+ int i;
+
+ if ((cp = capab) == NULL || id == NULL || *cp == 0)
+ return(NULL);
+ while (*++cp != ':')
+ ;
+ while (*cp) {
+ cp++;
+ while (ISSPACE(*cp))
+ cp++;
+ if (strncmp(cp, id, CAPABLEN) == 0) {
+ while (*cp && *cp != ':' && *cp != '=')
+ cp++;
+ if (*cp != '=')
+ return(NULL);
+ for (ret = *area, cp++; *cp && *cp != ':' ; (*area)++, cp++)
+ switch(*cp) {
+ case '^' :
+ **area = *++cp - 'A' + 1;
+ break;
+ case '\\' :
+ switch(*++cp) {
+ case 'E' :
+ **area = '\033';
+ break;
+ case 'n' :
+ **area = '\n';
+ break;
+ case 'r' :
+ **area = '\r';
+ break;
+ case 't' :
+ **area = '\t';
+ break;
+ case 'b' :
+ **area = '\b';
+ break;
+ case 'f' :
+ **area = '\f';
+ break;
+ case '0' :
+ case '1' :
+ case '2' :
+ case '3' :
+ for (i=0 ; *cp && ISDIGIT(*cp) ; cp++)
+ i = i * 8 + *cp - '0';
+ **area = i;
+ cp--;
+ break;
+ case '^' :
+ case '\\' :
+ **area = *cp;
+ break;
+ }
+ break;
+ default :
+ **area = *cp;
+ }
+ *(*area)++ = '\0';
+ return(ret);
+ }
+ while (*cp && *cp != ':')
+ cp++;
+ }
+ return(NULL);
+}
+
+/*
+ * tgoto - given the cursor motion string cm, make up the string
+ * for the cursor to go to (destcol, destline), and return the string.
+ * Returns "OOPS" if something's gone wrong, or the string otherwise.
+ */
+char *
+tgoto(cm, destcol, destline)
+char *cm;
+int destcol;
+int destline;
+{
+ register char *rp;
+ static char ret[32];
+ char added[16];
+ int *dp = &destline;
+ int numval;
+ int swapped = 0;
+
+ added[0] = 0;
+ for (rp = ret ; *cm ; cm++) {
+ if (*cm == '%') {
+ switch(*++cm) {
+ case '>' :
+ if (dp == NULL)
+ return("OOPS");
+ cm++;
+ if (*dp > *cm++) {
+ *dp += *cm;
+ }
+ break;
+ case '+' :
+ case '.' :
+ if (dp == NULL)
+ return("OOPS");
+ if (*cm == '+') *dp = *dp + *++cm;
+ for (;;) {
+ switch(*dp) {
+ case 0:
+ case 04:
+ case '\t':
+ case '\n':
+ /* filter these out */
+ if (dp == &destcol || swapped || UP) {
+ strcat(added, dp == &destcol || swapped ?
+ (BC ? BC : "\b") :
+ UP);
+ (*dp)++;
+ continue;
+ }
+ }
+ break;
+ }
+ *rp++ = *dp;
+ dp = (dp == &destline) ? &destcol : NULL;
+ break;
+
+ case 'r' : {
+ int tmp = destline;
+
+ destline = destcol;
+ destcol = tmp;
+ swapped = 1 - swapped;
+ break;
+ }
+ case 'n' :
+ destcol ^= 0140;
+ destline ^= 0140;
+ break;
+
+ case '%' :
+ *rp++ = '%';
+ break;
+
+ case 'i' :
+ destcol++;
+ destline++;
+ break;
+
+ case 'B' :
+ if (dp == NULL)
+ return("OOPS");
+ *dp = 16 * (*dp / 10) + *dp % 10;
+ break;
+
+ case 'D' :
+ if (dp == NULL)
+ return("OOPS");
+ *dp = *dp - 2 * (*dp % 16);
+ break;
+
+ case 'd' :
+ case '2' :
+ case '3' :
+ if (dp == NULL)
+ return("OOPS");
+ numval = *dp;
+ dp = (dp == &destline) ? &destcol : NULL;
+ if (numval >= 100) {
+ *rp++ = '0' + numval / 100;
+ }
+ else if (*cm == '3') {
+ *rp++ = ' ';
+ }
+ if (numval >= 10) {
+ *rp++ = '0' + ((numval%100)/10);
+ }
+ else if (*cm == '3' || *cm == '2') {
+ *rp++ = ' ';
+ }
+ *rp++ = '0' + (numval%10);
+ break;
+ default :
+ return("OOPS");
+ }
+ }
+ else *rp++ = *cm;
+ }
+ *rp = '\0';
+ strcpy(rp, added);
+ return(ret);
+}
+
+static int tens_of_ms_p_char[] = { /* index as returned by gtty */
+ /* assume 10 bits per char */
+ 0, 2000, 1333, 909, 743, 666, 500, 333, 166, 83, 55, 41, 20, 10, 5, 2
+};
+/*
+ * tputs - put the string cp out onto the terminal, using the function
+ * outc. Also handle padding.
+ */
+int
+tputs(cp, affcnt, outc)
+register char *cp;
+int affcnt;
+int (*outc)();
+{
+ int delay = 0;
+ if (cp == NULL)
+ return(1);
+ while (ISDIGIT(*cp)) {
+ delay = delay * 10 + (*cp++ - '0');
+ }
+ delay *= 10;
+ if (*cp == '.') {
+ cp++;
+ if (ISDIGIT(*cp)) {
+ delay += *cp++ - '0';
+ }
+ while (ISDIGIT(*cp)) cp++;
+ }
+ if (*cp == '*') {
+ delay *= affcnt;
+ cp++;
+ }
+ while (*cp)
+ (*outc)(*cp++);
+ if (delay != 0 &&
+ ospeed > 0 &&
+ ospeed < (sizeof tens_of_ms_p_char / sizeof tens_of_ms_p_char[0])) {
+ delay = (delay + tens_of_ms_p_char[ospeed] - 1) /
+ tens_of_ms_p_char[ospeed];
+ while (delay--) (*outc)(PC);
+ }
+ return(1);
+}
+
+/*
+ * That's all, folks...
+ */
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: double abs function
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+#ifndef NOFLOAT
+double
+absd(i)
+ double i;
+{
+ return i >= 0 ? i : -i;
+}
+#endif
--- /dev/null
+#
+;
+; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+; See the copyright notice in the ACK home directory, in the file "Copyright".
+;
+;
+; Module: REAL abs function
+; Author: Ceriel J.H. Jacobs
+; Version: $Header$
+;
+ mes 2,_EM_WSIZE,_EM_PSIZE
+ exp $absf
+ pro $absf,0
+ mes 5
+ mes 9,8
+ lal 0
+ loi _EM_FSIZE
+ zrf _EM_FSIZE
+ cmf _EM_FSIZE
+ zlt *3
+ lal 0
+ loi _EM_FSIZE
+ bra *4
+3
+ lal 0
+ loi _EM_FSIZE
+ ngf _EM_FSIZE
+4
+ ret _EM_FSIZE
+ end 0
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: integer abs function
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+absi(i)
+{
+ return i >= 0 ? i : -i;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: longint abs function
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+long
+absl(i)
+ long i;
+{
+ return i >= 0 ? i : -i;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: block moves
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+#if _EM_WSIZE==_EM_PSIZE
+typedef unsigned pcnt;
+#else
+typedef unsigned long pcnt;
+#endif
+
+blockmove(siz, dst, src)
+ pcnt siz;
+ register char *dst, *src;
+{
+ while (siz--) *dst++ = *src++;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: cap; implementation of CAP
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+cap(u)
+ unsigned u;
+{
+ register unsigned *p = &u;
+
+ if (*p >= 'a' && *p <= 'z') *p += 'A'-'a';
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: default modula-2 trap handler
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+#include <em_abs.h>
+#include <m2_traps.h>
+#include <signal.h>
+
+static struct errm {
+ int errno;
+ char *errmes;
+} errors[] = {
+ { EARRAY, "array bound error"},
+ { ERANGE, "range bound error"},
+ { ESET, "set bound error"},
+ { EIOVFL, "integer overflow"},
+ { EFOVFL, "real overflow"},
+ { EFUNFL, "real underflow"},
+ { EIDIVZ, "divide by 0"},
+ { EFDIVZ, "divide by 0.0"},
+ { EIUND, "undefined integer"},
+ { EFUND, "undefined real"},
+ { ECONV, "conversion error"},
+
+ { ESTACK, "stack overflow"},
+ { EHEAP, "heap overflow"},
+ { EILLINS, "illegal instruction"},
+ { EODDZ, "illegal size argument"},
+ { ECASE, "case error"},
+ { EMEMFLT, "addressing non existent memory"},
+ { EBADPTR, "bad pointer used"},
+ { EBADPC, "program counter out of range"},
+ { EBADLAE, "bad argument of lae"},
+ { EBADMON, "bad monitor call"},
+ { EBADLIN, "argument if LIN too high"},
+ { EBADGTO, "GTO descriptor error"},
+
+ { M2_TOOLARGE, "stack size of process too large"},
+ { M2_TOOMANY, "too many nested traps + handlers"},
+ { M2_NORESULT, "no RETURN from function procedure"},
+ { M2_UOVFL, "cardinal overflow"},
+ { M2_FORCH, "(warning) FOR-loop control variable was changed in the body"},
+ { M2_UUVFL, "cardinal underflow"},
+ { M2_INTERNAL, "internal error; ask an expert for help"},
+ { M2_UNIXSIG, "got a unix signal"},
+ { -1, 0}
+};
+
+catch(trapno)
+ int trapno;
+{
+ register struct errm *ep = &errors[0];
+ char *errmessage;
+ char buf[20];
+ register char *p, *s;
+
+ while (ep->errno != trapno && ep->errmes != 0) ep++;
+ if (p = ep->errmes) {
+ while (*p) p++;
+ _Traps__Message(ep->errmes, 0, (int) (p - ep->errmes), 1);
+ }
+ else {
+ int i = trapno;
+ static char q[] = "error number xxxxxxxxxxxxx";
+
+ p = &q[13];
+ s = buf;
+ if (i < 0) {
+ i = -i;
+ *p++ = '-';
+ }
+ do
+ *s++ = i % 10 + '0';
+ while (i /= 10);
+ while (s > buf) *p++ = *--s;
+ *p = 0;
+ _Traps__Message(q, 0, (int) (p - q), 1);
+ }
+#if !defined(__em24) && !defined(__em44) && !defined(__em22)
+ if (trapno == M2_UNIXSIG) {
+ extern int __signo;
+ signal(__signo, SIG_DFL);
+ _cleanup();
+ kill(getpid(), __signo);
+ _exit(trapno);
+ }
+#endif
+ if (trapno != M2_FORCH) {
+ _cleanup();
+ _exit(trapno);
+ }
+ SIG(catch);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: runtime support for conformant arrays
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+#include <m2_traps.h>
+
+#ifndef EM_WSIZE
+#define EM_WSIZE _EM_WSIZE
+#define EM_PSIZE _EM_PSIZE
+#endif
+
+#if EM_WSIZE==EM_PSIZE
+typedef unsigned pcnt;
+#else
+typedef unsigned long pcnt;
+#endif
+
+struct descr {
+ char *addr;
+ int low;
+ unsigned int highminlow;
+ unsigned int size;
+};
+
+static struct descr *descrs[10];
+static struct descr **ppdescr = descrs;
+
+pcnt
+new_stackptr(pdscr, a)
+ struct descr *pdscr;
+{
+ register struct descr *pdescr = pdscr;
+ pcnt size = (((pdescr->highminlow + 1) * pdescr->size +
+ (EM_WSIZE - 1)) & ~(EM_WSIZE - 1));
+
+ if (ppdescr >= &descrs[10]) {
+ /* to many nested traps + handlers ! */
+ TRP(M2_TOOMANY);
+ }
+ *ppdescr++ = pdescr;
+ if ((char *) &a - (char *) &pdscr > 0) {
+ /* stack grows downwards */
+ return - size;
+ }
+ return size;
+}
+
+copy_array(pp, a)
+ char *pp;
+{
+ register char *p = pp;
+ register char *q;
+ register pcnt sz;
+ char dummy;
+
+ ppdescr--;
+ sz = ((*ppdescr)->highminlow + 1) * (*ppdescr)->size;
+
+ if ((char *) &a - (char *) &pp > 0) {
+ (*ppdescr)->addr = q = (char *) &a;
+ }
+ else (*ppdescr)->addr = q = (char *) &a -
+ ((sz + (EM_WSIZE - 1)) & ~ (EM_WSIZE - 1));
+
+ while (sz--) *q++ = *p++;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: implementation of DIV and MOD
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+ Reason: We cannot use DVI and RMI, because DVI rounds towards 0
+ and Modula-2 requires truncation
+*/
+
+#include <em_abs.h>
+
+int
+dvi(j,i)
+ int j,i;
+{
+ if (j == 0) TRP(EIDIVZ);
+ if ((i < 0) != (j < 0)) {
+ if (i < 0) i = -i;
+ else j = -j;
+ return -((i+j-1)/j);
+ }
+ else return i/j;
+}
+
+long
+dvil(j,i)
+ long j,i;
+{
+ if (j == 0) TRP(EIDIVZ);
+ if ((i < 0) != (j < 0)) {
+ if (i < 0) i = -i;
+ else j = -j;
+ return -((i+j-1)/j);
+ }
+ else return i/j;
+}
+
+int
+rmi(j,i)
+ int j,i;
+{
+ if (j == 0) TRP(EIDIVZ);
+ if (i == 0) return 0;
+ if ((i < 0) != (j < 0)) {
+ if (i < 0) i = -i;
+ else j = -j;
+ return j*((i+j-1)/j)-i;
+ }
+ else return i%j;
+}
+
+long
+rmil(j,i)
+ long j,i;
+{
+ if (j == 0) TRP(EIDIVZ);
+ if (i == 0) return 0L;
+ if ((i < 0) != (j < 0)) {
+ if (i < 0) i = -i;
+ else j = -j;
+ return j*((i+j-1)/j)-i;
+ }
+ else return i%j;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: program termination routines
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+#define MAXPROCS 32
+
+static int callindex = 0;
+static int (*proclist[MAXPROCS])();
+
+_cleanup()
+{
+ while (--callindex >= 0)
+ (*proclist[callindex])();
+ callindex = 0;
+}
+
+CallAtEnd(p)
+ int (*p)();
+{
+ if (callindex >= MAXPROCS) {
+ return 0;
+ }
+ proclist[callindex++] = p;
+ return 1;
+}
+
+halt()
+{
+ _cleanup();
+ _exit(0);
+}
--- /dev/null
+#
+;
+; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+; See the copyright notice in the ACK home directory, in the file "Copyright".
+;
+;
+; Module: Modula-2 runtime startoff
+; Author: Ceriel J.H. Jacobs
+; Version: $Header$
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+ exa handler
+ exa argv
+ exa argc
+ exa MainLB
+ exa bkillbss
+ exp $catch
+ exp $init
+ inp $trap_handler
+
+bkillbss
+ bss _EM_PSIZE,0,0
+
+ exp $_m_a_i_n
+ pro $_m_a_i_n, 0
+
+ lor 0
+ lae MainLB
+ sti _EM_PSIZE
+
+ lal _EM_WSIZE
+ loi _EM_PSIZE
+ lae argv ; save argument pointer
+ sti _EM_PSIZE
+
+ lol 0
+ ste argc ; save argument count
+
+ lpi $trap_handler
+ sig
+ asp _EM_PSIZE
+ cal $init
+ cal $__M2M_
+ cal $halt
+ loc 0 ; should not get here
+ ret _EM_WSIZE
+ end
+
+ pro $trap_handler,0
+ lpi $trap_handler
+ sig
+ lol 0 ; trap number
+ lae handler
+ loi _EM_PSIZE
+ lpi $catch
+ lae handler
+ sti _EM_PSIZE
+ cai
+ asp _EM_PSIZE+_EM_WSIZE
+ rtt
+ end 0
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: initialization and some global vars
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+#include <signal.h>
+#include <em_abs.h>
+#include <m2_traps.h>
+
+/* map unix signals onto EM traps */
+init()
+{
+ sigtrp(M2_UNIXSIG, SIGHUP);
+ sigtrp(M2_UNIXSIG, SIGINT);
+ sigtrp(M2_UNIXSIG, SIGQUIT);
+ sigtrp(EILLINS, SIGILL);
+ sigtrp(M2_UNIXSIG, SIGTRAP);
+ sigtrp(M2_UNIXSIG, SIGIOT);
+ sigtrp(M2_UNIXSIG, SIGEMT);
+ sigtrp(M2_UNIXSIG, SIGFPE);
+ sigtrp(M2_UNIXSIG, SIGBUS);
+ sigtrp(M2_UNIXSIG, SIGSEGV);
+#ifdef SIGSYS
+ sigtrp(EBADMON, SIGSYS);
+#endif
+ sigtrp(M2_UNIXSIG, SIGPIPE);
+ sigtrp(M2_UNIXSIG, SIGALRM);
+ sigtrp(M2_UNIXSIG, SIGTERM);
+}
+
+killbss()
+{
+ /* Fill bss with junk? Make lots of VM pages dirty? No way! */
+}
+
+extern int catch();
+
+int (*handler)() = catch;
+char **argv;
+int argc;
+char *MainLB;
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: get value on stack, byte by byte
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+#include <m2_traps.h>
+
+#ifndef EM_WSIZE
+#define EM_WSIZE _EM_WSIZE
+#define EM_PSIZE _EM_PSIZE
+#endif
+
+#if EM_WSIZE==EM_PSIZE
+typedef unsigned pcnt;
+#else
+typedef long pcnt;
+#endif
+
+load(siz, addr, p)
+ register char *addr;
+ register pcnt siz;
+{
+ /* Make sure, that a value with a size that could have been
+ handled by the LOI instruction ends up at the same place,
+ where it would, were the LOI instruction used.
+ */
+ register char *q = (char *) &p;
+ char t[4];
+
+ if (siz < EM_WSIZE && EM_WSIZE % siz == 0) {
+ /* as long as EM_WSIZE <= 4 ... */
+ if (siz != 2) TRP(M2_INTERNAL); /* internal error */
+ q = &t[0];
+ }
+ while (siz--) *q++ = *addr++;
+ if (q - t == 2) {
+ *((unsigned *)(&p)) = *((unsigned short *) (&t[0]));
+ }
+}
--- /dev/null
+#
+;
+; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+; See the copyright notice in the ACK home directory, in the file "Copyright".
+;
+
+;
+; Module: coroutine primitives
+; Author: Kees Bot, Edwin Scheffer, Ceriel Jacobs
+; Version: $Header$
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+ ; topsize takes care of two things:
+ ; - given a stack-break,
+ ; it computes the size of the chunk of memory needed to save the stack;
+ ; - also, if this stack-break = 0, it creates one, assuming that caller is
+ ; the stack-break.
+ ;
+ ; This implementation assumes a continuous stack growing downwards
+
+ exp $topsize
+#ifdef __sparc
+ inp $topsize2
+ pro $topsize, 0
+ mes 11
+ zer _EM_PSIZE
+ lal 0
+ loi _EM_PSIZE
+ cal $topsize2
+ asp 2*_EM_PSIZE
+ lfr _EM_WSIZE
+ ret _EM_WSIZE
+ end 0
+ pro $topsize2, (3*_EM_WSIZE+3*_EM_PSIZE)
+#else
+ pro $topsize, (3*_EM_WSIZE+3*_EM_PSIZE)
+#endif
+ ; local space for line-number, ignoremask, filename, stack-break, size,
+ ; and stack-pointer (see the topsave routine)
+ mes 11
+ lal 0
+ loi _EM_PSIZE
+ loi _EM_PSIZE ; stack-break or 0
+ zer _EM_PSIZE
+ cmp
+ zne *1
+ lxl 0
+ dch ; local base of caller
+#ifdef __sparc
+ dch ; because of the extra layer
+#endif
+ lal 0
+ loi _EM_PSIZE
+ sti _EM_PSIZE
+1
+ lal 0
+ loi _EM_PSIZE
+ loi _EM_PSIZE
+ lpb ; convert this local base to an argument base.
+ ; An implementation of a sort of "topsize" EM
+ ; instruction should take a local base, and save
+ ; the whole frame.
+
+ lor 1 ; stack-break SP
+ sbs _EM_WSIZE ; stack-break-SP
+ ret _EM_WSIZE ; return size of block to be saved
+ end 3*_EM_WSIZE+3*_EM_PSIZE
+
+ exp $topsave
+#ifdef __sparc
+ inp $topsave2
+ pro $topsave,0
+ mes 11
+ lal 0
+ loi 2*_EM_PSIZE
+ cal $topsave2
+ asp 2*_EM_PSIZE
+ lfr _EM_WSIZE
+ ret _EM_WSIZE
+ end 0
+ pro $topsave2,0
+#else
+ pro $topsave, 0
+#endif
+ mes 11
+ loe 0
+ lae 4 ; load line number and file name
+ loi _EM_PSIZE
+ lim ; ignore mask
+ lor 0 ; LB
+ lal 0
+ loi _EM_PSIZE ; stack-break
+ lpb
+ lor 1
+ sbs _EM_WSIZE
+ loc _EM_WSIZE
+ adu _EM_WSIZE ; gives size
+ dup _EM_WSIZE
+ stl 0 ; save size
+ lor 1 ; SP (the SP BEFORE pushing)
+ lor 1 ; SP (address of stack top to save)
+ lal _EM_PSIZE ; area
+ loi _EM_PSIZE
+ lol 0 ; size
+ bls _EM_WSIZE ; move whole block
+ asp 3*_EM_PSIZE+3*_EM_WSIZE ; remove the lot from the stack
+ loc 1
+ ret _EM_WSIZE ; return 1
+ end 0
+
+sv
+ bss _EM_PSIZE,0,0
+
+ exp $topload
+#ifdef __sparc
+ inp $topload1
+ pro $topload,0
+ lal 0
+ loi _EM_PSIZE
+ cal $topload1
+ asp _EM_PSIZE
+ lfr _EM_WSIZE
+ ret _EM_WSIZE
+ end 0
+ pro $topload1, 0
+#else
+ pro $topload, 0
+#endif
+ mes 11
+
+ lal 0
+ loi _EM_PSIZE
+ lae sv
+ sti _EM_PSIZE ; saved parameter
+
+ lxl 0
+2
+ dup _EM_PSIZE
+ adp -3*_EM_PSIZE
+ lal 0
+ loi _EM_PSIZE ; compare target SP with current LB to see if we must
+ loi _EM_PSIZE
+ cmp ; find another LB first
+ zgt *1
+ dch ; just follow dynamic chain to make sure we find
+ ; a legal one
+ bra *2
+1
+ str 0
+
+ lae sv
+ loi _EM_PSIZE
+ loi _EM_PSIZE ; load indirect to
+ str 1 ; restore SP
+ asp 0-_EM_PSIZE ; to stop int from complaining about non-existent memory
+ lae sv
+ loi _EM_PSIZE ; source address
+ lor 1
+ adp _EM_PSIZE ; destination address
+ lae sv
+ loi _EM_PSIZE
+ adp _EM_PSIZE
+ loi _EM_WSIZE ; size of block
+ bls _EM_WSIZE
+ asp _EM_PSIZE+_EM_WSIZE ; drop size + SP
+ str 0 ; restore local base
+ sim ; ignore mask
+ lae 4
+ sti _EM_PSIZE
+ ste 0 ; line and file
+ loc 0
+ ret _EM_WSIZE
+ end 0
--- /dev/null
+(*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*)
+
+(*$R-*)
+IMPLEMENTATION MODULE random;
+(*
+ Module: random numbers
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*)
+
+ FROM Unix IMPORT getpid, time;
+ TYPE index = [1..55];
+
+ VAR X: ARRAY index OF CARDINAL;
+ j, k: index;
+ tm: LONGINT;
+
+ PROCEDURE Random(): CARDINAL;
+ BEGIN
+ IF k-1 <= 0 THEN k := 55; ELSE DEC(k) END;
+ IF j-1 <= 0 THEN j := 55; ELSE DEC(j) END;
+ X[k] := X[k] + X[j];
+ RETURN X[k]
+ END Random;
+
+ PROCEDURE Uniform (lwb, upb: CARDINAL): CARDINAL;
+ BEGIN
+ IF upb <= lwb THEN RETURN lwb; END;
+ RETURN lwb + (Random() MOD (upb - lwb + 1));
+ END Uniform;
+
+ PROCEDURE StartSeed(seed: CARDINAL);
+ VAR v: CARDINAL;
+ BEGIN
+ FOR k := 1 TO 55 DO
+ seed := 1297 * seed + 123;
+ X[k] := seed;
+ END;
+ FOR k := 1 TO 15 DO
+ j := tm MOD 55D + 1D;
+ v := X[j];
+ tm := tm DIV 7D;
+ j := tm MOD 55D + 1D;
+ X[j] := v;
+ tm := tm * 3D;
+ END;
+ k := 1;
+ j := 25;
+ END StartSeed;
+
+BEGIN
+ tm := time(NIL);
+ X[1] := tm;
+ StartSeed(CARDINAL(getpid()) * X[1]);
+END random.
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ *
+ * Module: range checks for INTEGER, now for array indexing
+ * Author: Ceriel J.H. Jacobs
+ * Version: $Header$
+*/
+
+#include <em_abs.h>
+
+extern TRP();
+
+struct array_descr {
+ int lbound;
+ int n_elts_min_one;
+ unsigned size;
+};
+
+rcka(descr, indx)
+ struct array_descr *descr;
+{
+ if (indx < 0 || indx > descr->n_elts_min_one) TRP(EARRAY);
+}
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ *
+ * Module: range checks for INTEGER
+ * Author: Ceriel J.H. Jacobs
+ * Version: $Header$
+*/
+
+#include <em_abs.h>
+
+extern TRP();
+
+struct range_descr {
+ int low, high;
+};
+
+rcki(descr, val)
+ struct range_descr *descr;
+{
+ if (val < descr->low || val > descr->high) TRP(ERANGE);
+}
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ *
+ * Module: range checks for LONGINT
+ * Author: Ceriel J.H. Jacobs
+ * Version: $Header$
+*/
+
+#include <em_abs.h>
+
+extern TRP();
+
+struct range_descr {
+ long low, high;
+};
+
+rckil(descr, val)
+ struct range_descr *descr;
+ long val;
+{
+ if (val < descr->low || val > descr->high) TRP(ERANGE);
+}
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ *
+ * Module: range checks for CARDINAL
+ * Author: Ceriel J.H. Jacobs
+ * Version: $Header$
+*/
+
+#include <em_abs.h>
+
+extern TRP();
+
+struct range_descr {
+ unsigned low, high;
+};
+
+rcku(descr, val)
+ struct range_descr *descr;
+ unsigned val;
+{
+ if (val < descr->low || val > descr->high) TRP(ERANGE);
+}
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ *
+ * Module: range checks for LONGCARD
+ * Author: Ceriel J.H. Jacobs
+ * Version: $Header$
+*/
+
+#include <em_abs.h>
+
+extern TRP();
+
+struct range_descr {
+ unsigned long low, high;
+};
+
+rckul(descr, val)
+ struct range_descr *descr;
+ unsigned long val;
+{
+ if (val < descr->low || val > descr->high) TRP(ERANGE);
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: Mapping of Unix signals to EM traps
+ (only when not using the MON instruction)
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+#if !defined(__em22) && !defined(__em24) && !defined(__em44)
+
+#define EM_trap(n) TRP(n) /* define to whatever is needed to cause the trap */
+
+#include <signal.h>
+#include <errno.h>
+
+int __signo;
+
+static int __traps[] = {
+ -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
+ -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
+ -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
+};
+
+static void
+__ctchsig(signo)
+{
+ signal(signo,__ctchsig);
+#ifdef __BSD4_2
+ sigsetmask(sigblock(0) & ~(1<<(signo - 1)));
+#endif
+ __signo = signo;
+ EM_trap(__traps[signo]);
+}
+
+int
+sigtrp(trapno, signo)
+{
+ /* Let Unix signal signo cause EM trap trapno to occur.
+ If trapno = -2, restore default,
+ If trapno = -3, ignore.
+ Return old trapnumber.
+ Careful, this could be -2 or -3; But return value of -1
+ indicates failure, with error number in errno.
+ */
+ extern int errno;
+ void (*ctch)() = __ctchsig;
+ void (*oldctch)();
+ int oldtrap;
+
+ if (signo <= 0 || signo >= sizeof(__traps)/sizeof(__traps[0])) {
+ errno = EINVAL;
+ return -1;
+ }
+
+ if (trapno == -3)
+ ctch = SIG_IGN;
+ else if (trapno == -2)
+ ctch = SIG_DFL;
+ else if (trapno >= 0 && trapno <= 252)
+ ;
+ else {
+ errno = EINVAL;
+ return -1;
+ }
+
+ oldtrap = __traps[signo];
+
+ if ((oldctch = signal(signo, ctch)) == (void (*)())-1) /* errno set by signal */
+ return -1;
+
+ else if (oldctch == SIG_IGN) {
+ signal(signo, SIG_IGN);
+ }
+ else __traps[signo] = trapno;
+
+ return oldtrap;
+}
+#endif
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: Dummy priority routines
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+static unsigned prio = 0;
+
+stackprio(n)
+ unsigned n;
+{
+ unsigned old = prio;
+
+ if (n > prio) prio = n;
+ return old;
+}
+
+unstackprio(n)
+ unsigned n;
+{
+ prio = n;
+}
--- /dev/null
+/*
+ (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ See the copyright notice in the ACK home directory, in the file "Copyright".
+*/
+
+/*
+ Module: store values from stack, byte by byte
+ Author: Ceriel J.H. Jacobs
+ Version: $Header$
+*/
+
+#include <m2_traps.h>
+
+#ifndef EM_WSIZE
+#define EM_WSIZE _EM_WSIZE
+#define EM_PSIZE _EM_PSIZE
+#endif
+
+#if EM_WSIZE==EM_PSIZE
+typedef unsigned pcnt;
+#else
+typedef long pcnt;
+#endif
+
+store(siz, addr, p)
+ register char *addr;
+ register pcnt siz;
+{
+ /* Make sure, that a value with a size that could have been
+ handled by the LOI instruction is handled as if it was
+ loaded with the LOI instruction.
+ */
+ register char *q = (char *) &p;
+ char t[4];
+
+ if (siz < EM_WSIZE && EM_WSIZE % siz == 0) {
+ /* as long as EM_WSIZE <= 4 ... */
+ if (siz != 2) TRP(M2_INTERNAL); /* internal error */
+ *((unsigned short *) (&t[0])) = *((unsigned *) q);
+ q = &t[0];
+ }
+ while (siz--) *addr++ = *q++;
+}
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ *
+ * Module: CARDINAL operations with overflow checking
+ * Author: Ceriel J.H. Jacobs
+ * Version: $Header$
+*/
+
+#ifndef EM_WSIZE
+#define EM_WSIZE _EM_WSIZE
+#endif
+#ifndef EM_LSIZE
+#define EM_LSIZE _EM_LSIZE
+#endif
+
+#include <m2_traps.h>
+
+#define MAXCARD ((unsigned)-1)
+#if EM_WSIZE < EM_LSIZE
+#define MAXLONGCARD ((unsigned long) -1L)
+#endif
+
+adduchk(a,b)
+ unsigned a,b;
+{
+ if (MAXCARD - a < b) TRP(M2_UOVFL);
+}
+
+#if EM_WSIZE < EM_LSIZE
+addulchk(a,b)
+ unsigned long a,b;
+{
+ if (MAXLONGCARD - a < b) TRP(M2_UOVFL);
+}
+#endif
+
+muluchk(a,b)
+ unsigned a,b;
+{
+ if (a != 0 && MAXCARD/a < b) TRP(M2_UOVFL);
+}
+
+#if EM_WSIZE < EM_LSIZE
+mululchk(a,b)
+ unsigned long a,b;
+{
+ if (a != 0 && MAXLONGCARD/a < b) TRP(M2_UOVFL);
+}
+#endif
+
+subuchk(a,b)
+ unsigned a,b;
+{
+ if (b < a) TRP(M2_UUVFL);
+}
+
+#if EM_WSIZE < EM_LSIZE
+subulchk(a,b)
+ unsigned long a,b;
+{
+ if (b < a) TRP(M2_UUVFL);
+}
+#endif
--- /dev/null
+# Makefile for lib/ack/libp.
+
+CFLAGS = -O -I../h -wo
+CC1 = $(CC) $(CFLAGS) -c
+
+LIBRARIES = libp
+
+libp_OBJECTS = \
+ abi.o \
+ abl.o \
+ abr.o \
+ arg.o \
+ ass.o \
+ asz.o \
+ atn.o \
+ bcp.o \
+ bts.o \
+ buff.o \
+ catch.o \
+ clock.o \
+ cls.o \
+ cvt.o \
+ diag.o \
+ dis.o \
+ efl.o \
+ eln.o \
+ encaps.o \
+ exp.o \
+ fef.o \
+ fif.o \
+ get.o \
+ gto.o \
+ head_pc.o \
+ hlt.o \
+ hol0.o \
+ incpt.o \
+ ini.o \
+ log.o \
+ mdi.o \
+ mdl.o \
+ new.o \
+ nfa.o \
+ nobuff.o \
+ notext.o \
+ opn.o \
+ outcpt.o \
+ pac.o \
+ pclose.o \
+ pcreat.o \
+ pentry.o \
+ perrno.o \
+ pexit.o \
+ popen.o \
+ put.o \
+ rcka.o \
+ rdc.o \
+ rdi.o \
+ rdl.o \
+ rdr.o \
+ rf.o \
+ rln.o \
+ rnd.o \
+ sav.o \
+ sig.o \
+ sin.o \
+ sqt.o \
+ string.o \
+ trap.o \
+ trp.o \
+ unp.o \
+ uread.o \
+ uwrite.o \
+ wdw.o \
+ wf.o \
+ wrc.o \
+ wrf.o \
+ wri.o \
+ wrl.o \
+ wrr.o \
+ wrs.o \
+ wrz.o \
+
+include ../../Makefile.ack.inc
--- /dev/null
+# Makefile for lib/libp.
+
+CFLAGS = -O -I$(SRCDIR)/ack/h -wo
+CC1 = $(CC) $(CFLAGS) -c
+
+LIBRARY = ../../libp.a
+all: $(LIBRARY)
+
+OBJECTS = \
+ $(LIBRARY)(abi.o) \
+ $(LIBRARY)(abl.o) \
+ $(LIBRARY)(abr.o) \
+ $(LIBRARY)(arg.o) \
+ $(LIBRARY)(ass.o) \
+ $(LIBRARY)(asz.o) \
+ $(LIBRARY)(atn.o) \
+ $(LIBRARY)(bcp.o) \
+ $(LIBRARY)(bts.o) \
+ $(LIBRARY)(buff.o) \
+ $(LIBRARY)(catch.o) \
+ $(LIBRARY)(clock.o) \
+ $(LIBRARY)(cls.o) \
+ $(LIBRARY)(cvt.o) \
+ $(LIBRARY)(diag.o) \
+ $(LIBRARY)(dis.o) \
+ $(LIBRARY)(efl.o) \
+ $(LIBRARY)(eln.o) \
+ $(LIBRARY)(encaps.o) \
+ $(LIBRARY)(exp.o) \
+ $(LIBRARY)(fef.o) \
+ $(LIBRARY)(fif.o) \
+ $(LIBRARY)(get.o) \
+ $(LIBRARY)(gto.o) \
+ $(LIBRARY)(head_pc.o) \
+ $(LIBRARY)(hlt.o) \
+ $(LIBRARY)(hol0.o) \
+ $(LIBRARY)(incpt.o) \
+ $(LIBRARY)(ini.o) \
+ $(LIBRARY)(log.o) \
+ $(LIBRARY)(mdi.o) \
+ $(LIBRARY)(mdl.o) \
+ $(LIBRARY)(new.o) \
+ $(LIBRARY)(nfa.o) \
+ $(LIBRARY)(nobuff.o) \
+ $(LIBRARY)(notext.o) \
+ $(LIBRARY)(opn.o) \
+ $(LIBRARY)(outcpt.o) \
+ $(LIBRARY)(pac.o) \
+ $(LIBRARY)(pclose.o) \
+ $(LIBRARY)(pcreat.o) \
+ $(LIBRARY)(pentry.o) \
+ $(LIBRARY)(perrno.o) \
+ $(LIBRARY)(pexit.o) \
+ $(LIBRARY)(popen.o) \
+ $(LIBRARY)(put.o) \
+ $(LIBRARY)(rcka.o) \
+ $(LIBRARY)(rdc.o) \
+ $(LIBRARY)(rdi.o) \
+ $(LIBRARY)(rdl.o) \
+ $(LIBRARY)(rdr.o) \
+ $(LIBRARY)(rf.o) \
+ $(LIBRARY)(rln.o) \
+ $(LIBRARY)(rnd.o) \
+ $(LIBRARY)(sav.o) \
+ $(LIBRARY)(sig.o) \
+ $(LIBRARY)(sin.o) \
+ $(LIBRARY)(sqt.o) \
+ $(LIBRARY)(string.o) \
+ $(LIBRARY)(trap.o) \
+ $(LIBRARY)(trp.o) \
+ $(LIBRARY)(unp.o) \
+ $(LIBRARY)(uread.o) \
+ $(LIBRARY)(uwrite.o) \
+ $(LIBRARY)(wdw.o) \
+ $(LIBRARY)(wf.o) \
+ $(LIBRARY)(wrc.o) \
+ $(LIBRARY)(wrf.o) \
+ $(LIBRARY)(wri.o) \
+ $(LIBRARY)(wrl.o) \
+ $(LIBRARY)(wrr.o) \
+ $(LIBRARY)(wrs.o) \
+ $(LIBRARY)(wrz.o) \
+
+$(LIBRARY): $(OBJECTS)
+ aal cr $@ *.o
+ rm *.o
+
+$(LIBRARY)(abi.o): abi.c
+ $(CC1) abi.c
+
+$(LIBRARY)(abl.o): abl.c
+ $(CC1) abl.c
+
+$(LIBRARY)(abr.o): abr.c
+ $(CC1) abr.c
+
+$(LIBRARY)(arg.o): arg.c
+ $(CC1) arg.c
+
+$(LIBRARY)(ass.o): ass.c
+ $(CC1) ass.c
+
+$(LIBRARY)(asz.o): asz.c
+ $(CC1) asz.c
+
+$(LIBRARY)(atn.o): atn.c
+ $(CC1) atn.c
+
+$(LIBRARY)(bcp.o): bcp.c
+ $(CC1) bcp.c
+
+$(LIBRARY)(bts.o): bts.e
+ $(CC1) bts.e
+
+$(LIBRARY)(buff.o): buff.c
+ $(CC1) buff.c
+
+$(LIBRARY)(catch.o): catch.c
+ $(CC1) catch.c
+
+$(LIBRARY)(clock.o): clock.c
+ $(CC1) clock.c
+
+$(LIBRARY)(cls.o): cls.c
+ $(CC1) cls.c
+
+$(LIBRARY)(cvt.o): cvt.c
+ $(CC1) cvt.c
+
+$(LIBRARY)(diag.o): diag.c
+ $(CC1) diag.c
+
+$(LIBRARY)(dis.o): dis.c
+ $(CC1) dis.c
+
+$(LIBRARY)(efl.o): efl.c
+ $(CC1) efl.c
+
+$(LIBRARY)(eln.o): eln.c
+ $(CC1) eln.c
+
+$(LIBRARY)(encaps.o): encaps.e
+ $(CC1) encaps.e
+
+$(LIBRARY)(exp.o): exp.c
+ $(CC1) exp.c
+
+$(LIBRARY)(fef.o): fef.e
+ $(CC1) fef.e
+
+$(LIBRARY)(fif.o): fif.e
+ $(CC1) fif.e
+
+$(LIBRARY)(get.o): get.c
+ $(CC1) get.c
+
+$(LIBRARY)(gto.o): gto.e
+ $(CC1) gto.e
+
+$(LIBRARY)(head_pc.o): head_pc.e
+ $(CC1) head_pc.e
+
+$(LIBRARY)(hlt.o): hlt.c
+ $(CC1) hlt.c
+
+$(LIBRARY)(hol0.o): hol0.e
+ $(CC1) hol0.e
+
+$(LIBRARY)(incpt.o): incpt.c
+ $(CC1) incpt.c
+
+$(LIBRARY)(ini.o): ini.c
+ $(CC1) ini.c
+
+$(LIBRARY)(log.o): log.c
+ $(CC1) log.c
+
+$(LIBRARY)(mdi.o): mdi.c
+ $(CC1) mdi.c
+
+$(LIBRARY)(mdl.o): mdl.c
+ $(CC1) mdl.c
+
+$(LIBRARY)(new.o): new.c
+ $(CC1) new.c
+
+$(LIBRARY)(nfa.o): nfa.c
+ $(CC1) nfa.c
+
+$(LIBRARY)(nobuff.o): nobuff.c
+ $(CC1) nobuff.c
+
+$(LIBRARY)(notext.o): notext.c
+ $(CC1) notext.c
+
+$(LIBRARY)(opn.o): opn.c
+ $(CC1) opn.c
+
+$(LIBRARY)(outcpt.o): outcpt.c
+ $(CC1) outcpt.c
+
+$(LIBRARY)(pac.o): pac.c
+ $(CC1) pac.c
+
+$(LIBRARY)(pclose.o): pclose.c
+ $(CC1) pclose.c
+
+$(LIBRARY)(pcreat.o): pcreat.c
+ $(CC1) pcreat.c
+
+$(LIBRARY)(pentry.o): pentry.c
+ $(CC1) pentry.c
+
+$(LIBRARY)(perrno.o): perrno.c
+ $(CC1) perrno.c
+
+$(LIBRARY)(pexit.o): pexit.c
+ $(CC1) pexit.c
+
+$(LIBRARY)(popen.o): popen.c
+ $(CC1) popen.c
+
+$(LIBRARY)(put.o): put.c
+ $(CC1) put.c
+
+$(LIBRARY)(rcka.o): rcka.c
+ $(CC1) rcka.c
+
+$(LIBRARY)(rdc.o): rdc.c
+ $(CC1) rdc.c
+
+$(LIBRARY)(rdi.o): rdi.c
+ $(CC1) rdi.c
+
+$(LIBRARY)(rdl.o): rdl.c
+ $(CC1) rdl.c
+
+$(LIBRARY)(rdr.o): rdr.c
+ $(CC1) rdr.c
+
+$(LIBRARY)(rf.o): rf.c
+ $(CC1) rf.c
+
+$(LIBRARY)(rln.o): rln.c
+ $(CC1) rln.c
+
+$(LIBRARY)(rnd.o): rnd.c
+ $(CC1) rnd.c
+
+$(LIBRARY)(sav.o): sav.e
+ $(CC1) sav.e
+
+$(LIBRARY)(sig.o): sig.e
+ $(CC1) sig.e
+
+$(LIBRARY)(sin.o): sin.c
+ $(CC1) sin.c
+
+$(LIBRARY)(sqt.o): sqt.c
+ $(CC1) sqt.c
+
+$(LIBRARY)(string.o): string.c
+ $(CC1) string.c
+
+$(LIBRARY)(trap.o): trap.e
+ $(CC1) trap.e
+
+$(LIBRARY)(trp.o): trp.e
+ $(CC1) trp.e
+
+$(LIBRARY)(unp.o): unp.c
+ $(CC1) unp.c
+
+$(LIBRARY)(uread.o): uread.c
+ $(CC1) uread.c
+
+$(LIBRARY)(uwrite.o): uwrite.c
+ $(CC1) uwrite.c
+
+$(LIBRARY)(wdw.o): wdw.c
+ $(CC1) wdw.c
+
+$(LIBRARY)(wf.o): wf.c
+ $(CC1) wf.c
+
+$(LIBRARY)(wrc.o): wrc.c
+ $(CC1) wrc.c
+
+$(LIBRARY)(wrf.o): wrf.c
+ $(CC1) wrf.c
+
+$(LIBRARY)(wri.o): wri.c
+ $(CC1) wri.c
+
+$(LIBRARY)(wrl.o): wrl.c
+ $(CC1) wrl.c
+
+$(LIBRARY)(wrr.o): wrr.c
+ $(CC1) wrr.c
+
+$(LIBRARY)(wrs.o): wrs.c
+ $(CC1) wrs.c
+
+$(LIBRARY)(wrz.o): wrz.c
+ $(CC1) wrz.c
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+int _abi(i) int i; {
+ return(i>=0 ? i : -i);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+long _abl(i) long i; {
+ return(i>=0 ? i : -i);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+double _abr(r) double r; {
+ return(r>=0 ? r : -r);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+/* function argc:integer; extern; */
+/* function argv(i:integer):string; extern; */
+/* procedure argshift; extern; */
+/* function environ(i:integer):string; extern; */
+
+extern int _pargc;
+extern char **_pargv;
+extern char ***_penviron;
+
+int argc() {
+ return(_pargc);
+}
+
+char *argv(i) {
+ if (i >= _pargc)
+ return(0);
+ return(_pargv[i]);
+}
+
+argshift() {
+
+ if (_pargc > 1) {
+ --_pargc;
+ _pargv++;
+ }
+}
+
+char *environ(i) {
+ char **p; char *q;
+
+ if (p = *_penviron)
+ while (q = *p++)
+ if (i-- < 0)
+ return(q);
+ return(0);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <em_abs.h>
+#include <pc_err.h>
+
+extern char *_hol0();
+extern _trp();
+
+_ass(line,bool) int line,bool; {
+
+ if (bool==0) {
+ LINO = line;
+ _trp(EASS);
+ }
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+struct descr {
+ int low;
+ int diff;
+ int size;
+};
+
+int _asz(dp) struct descr *dp; {
+ return(dp->size * (dp->diff + 1));
+}
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* $Header$ */
+
+#define __NO_DEFS
+#include <math.h>
+
+#if __STDC__
+#include <pc_math.h>
+#endif
+
+double
+_atn(x)
+ double x;
+{
+ /* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ */
+
+ static double p[] = {
+ -0.13688768894191926929e+2,
+ -0.20505855195861651981e+2,
+ -0.84946240351320683534e+1,
+ -0.83758299368150059274e+0
+ };
+ static double q[] = {
+ 0.41066306682575781263e+2,
+ 0.86157349597130242515e+2,
+ 0.59578436142597344465e+2,
+ 0.15024001160028576121e+2,
+ 1.0
+ };
+ static double a[] = {
+ 0.0,
+ 0.52359877559829887307710723554658381, /* pi/6 */
+ M_PI_2,
+ 1.04719755119659774615421446109316763 /* pi/3 */
+ };
+
+ int neg = x < 0;
+ int n;
+ double g;
+
+ if (neg) {
+ x = -x;
+ }
+ if (x > 1.0) {
+ x = 1.0/x;
+ n = 2;
+ }
+ else n = 0;
+
+ if (x > 0.26794919243112270647) { /* 2-sqtr(3) */
+ n = n + 1;
+ x = (((0.73205080756887729353*x-0.5)-0.5)+x)/
+ (1.73205080756887729353+x);
+ }
+
+ /* ??? avoid underflow ??? */
+
+ g = x * x;
+ x += x * g * POLYNOM3(g, p) / POLYNOM4(g, q);
+ if (n > 1) x = -x;
+ x += a[n];
+ return neg ? -x : x;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+int _bcp(sz,y,x) int sz; unsigned char *y,*x; {
+
+ while (--sz >= 0) {
+ if (*x < *y)
+ return(-1);
+ if (*x++ > *y++)
+ return(1);
+ }
+ return(0);
+}
--- /dev/null
+#
+; $Header$
+;
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+;
+
+; Author: J.W. Stevenson */
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+#define SIZE 0
+#define HIGH _EM_WSIZE
+#define LOWB 2*_EM_WSIZE
+#define BASE 3*_EM_WSIZE
+
+; _bts is called with four parameters:
+; - the initial set (BASE)
+; - low bound of range of bits (LOWB)
+; - high bound of range of bits (HIGH)
+; - set size in bytes (SIZE)
+
+ exp $_bts
+ pro $_bts,0
+ lal BASE ; address of initial set
+ lol SIZE
+ los _EM_WSIZE ; load initial set
+1
+ lol LOWB ; low bound
+ lol HIGH ; high bound
+ bgt *2 ; while low <= high
+ lol LOWB
+ lol SIZE
+ set ? ; create [low]
+ lol SIZE
+ ior ? ; merge with initial set
+ inl LOWB ; increment low bound
+ bra *1 ; loop back
+2
+ lal BASE
+ lol SIZE
+ sts _EM_WSIZE ; store result over initial set
+ ret 0
+ end ?
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+
+extern _flush();
+
+/* procedure buff(var f:file of ?); */
+
+buff(f) struct file *f; {
+ int sz;
+
+ if ((f->flags & (0377|WRBIT)) != (MAGIC|WRBIT))
+ return;
+ _flush(f);
+ sz = f->size;
+ f->count = f->buflen = (sz>PC_BUFLEN ? sz : PC_BUFLEN-PC_BUFLEN%sz);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <em_abs.h>
+#include <pc_err.h>
+#include <pc_file.h>
+
+/* to make it easier to patch ... */
+extern struct file *_curfil;
+
+static struct errm {
+ int errno;
+ char *errmes;
+} errors[] = {
+ { EARRAY, "array bound error"},
+ { ERANGE, "range bound error"},
+ { ESET, "set bound error"},
+ { EIOVFL, "integer overflow"},
+ { EFOVFL, "real overflow"},
+ { EFUNFL, "real underflow"},
+ { EIDIVZ, "divide by 0"},
+ { EFDIVZ, "divide by 0.0"},
+ { EIUND, "undefined integer"},
+ { EFUND, "undefined real"},
+ { ECONV, "conversion error"},
+
+ { ESTACK, "stack overflow"},
+ { EHEAP, "heap overflow"},
+ { EILLINS, "illegal instruction"},
+ { EODDZ, "illegal size argument"},
+ { ECASE, "case error"},
+ { EMEMFLT, "addressing non existent memory"},
+ { EBADPTR, "bad pointer used"},
+ { EBADPC, "program counter out of range"},
+ { EBADLAE, "bad argument of lae"},
+ { EBADMON, "bad monitor call"},
+ { EBADLIN, "argument if LIN too high"},
+ { EBADGTO, "GTO descriptor error"},
+
+ { EARGC, "more args expected" },
+ { EEXP, "error in exp" },
+ { ELOG, "error in ln" },
+ { ESQT, "error in sqrt" },
+ { EASS, "assertion failed" },
+ { EPACK, "array bound error in pack" },
+ { EUNPACK, "array bound error in unpack" },
+ { EMOD, "only positive j in 'i mod j'" },
+ { EBADF, "file not yet open" },
+ { EFREE, "dispose error" },
+ { EFUNASS, "function not assigned" },
+ { EWIDTH, "illegal field width" },
+
+ { EWRITEF, "not writable" },
+ { EREADF, "not readable" },
+ { EEOF, "end of file" },
+ { EFTRUNC, "truncated" },
+ { ERESET, "reset error" },
+ { EREWR, "rewrite error" },
+ { ECLOSE, "close error" },
+ { EREAD, "read error" },
+ { EWRITE, "write error" },
+ { EDIGIT, "digit expected" },
+ { EASCII, "non-ASCII char read" },
+ { -1, 0}
+};
+
+extern int _pargc;
+extern char **_pargv;
+extern char ***_penviron;
+
+extern char *_hol0();
+extern _trp();
+extern _exit();
+extern int _write();
+
+_catch(erno) unsigned erno; {
+ register struct errm *ep = &errors[0];
+ char *p,*q,*s,**qq;
+ char buf[20];
+ unsigned i;
+ int j = erno;
+ char *pp[11];
+ char xbuf[100];
+
+ qq = pp;
+ if (p = FILN)
+ *qq++ = p;
+ else
+ *qq++ = _pargv[0];
+
+ while (ep->errno != erno && ep->errmes != 0) ep++;
+ p = buf;
+ s = xbuf;
+ if (i = LINO) {
+ *qq++ = ", ";
+ do
+ *p++ = i % 10 + '0';
+ while (i /= 10);
+ while (p > buf) *s++ = *--p;
+ }
+ *s++ = ':';
+ *s++ = ' ';
+ *s++ = '\0';
+ *qq++ = xbuf;
+ if ((erno & ~037) == 0140 && (_curfil->flags&0377)==MAGIC) {
+ /* file error */
+ *qq++ = "file ";
+ *qq++ = _curfil->fname;
+ *qq++ = ": ";
+ }
+ if (ep->errmes) *qq++ = ep->errmes;
+ else {
+ *qq++ = "error number ";
+ *qq++ = s;
+ p = buf;
+ if (j < 0) {
+ j = -j;
+ *s++ = '-';
+ }
+ do
+ *p++ = j % 10 + '0';
+ while (j /= 10);
+ while (p > buf) *s++ = *--p;
+ *s = 0;
+ }
+ *qq++ = "\n";
+ *qq = 0;
+ qq = pp;
+ while (q = *qq++) {
+ p = q;
+ while (*p)
+ p++;
+ if (_write(2,q,(int)(p-q)) < 0)
+ ;
+ }
+ _exit(erno);
+error:
+ _trp(erno);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+/* function clock:integer; extern; */
+
+extern int _times();
+
+struct tbuf {
+ long utime;
+ long stime;
+ long cutime;
+ long cstime;
+};
+
+#ifndef EM_WSIZE
+#define EM_WSIZE _EM_WSIZE
+#endif
+
+int clock() {
+ struct tbuf t;
+
+ _times(&t);
+ return( (int)(t.utime + t.stime) &
+#if EM_WSIZE <= 2
+ 077777
+#else
+ 0x7fffffffL
+#endif
+ );
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern struct file *_curfil;
+extern _trp();
+extern _flush();
+extern _outcpt();
+extern int _close();
+
+_xcls(f) struct file *f; {
+
+ if ((f->flags & WRBIT) == 0)
+ return;
+ if ((f->flags & (TXTBIT|ELNBIT)) == TXTBIT) {
+#ifdef CPM
+ *f->ptr = '\r';
+ _outcpt(f);
+#endif
+ *f->ptr = '\n';
+ _outcpt(f);
+ }
+ _flush(f);
+}
+
+_cls(f) struct file *f; {
+#ifdef MAYBE
+ char *p;
+#endif
+
+ _curfil = f;
+ if ((f->flags&0377) != MAGIC)
+ return;
+#ifdef MAYBE
+ p = f->bufadr;
+ if (f->ptr < p)
+ return;
+ if (f->buflen <= 0)
+ return;
+ p += f->buflen;
+ if (f->ptr >= p)
+ return;
+#endif
+ _xcls(f);
+ if (_close(f->ufd) != 0)
+ _trp(ECLOSE);
+ f->flags = 0;
+}
--- /dev/null
+/* $Header$ */
+#ifndef NOFLOAT
+
+#if __STDC__
+#include <float.h>
+#else
+#include <math.h>
+#define DBL_MAX M_MAX_D
+#endif
+
+static char *cvt();
+#define NDIGITS 128
+
+char *
+_ecvt(value, ndigit, decpt, sign)
+ double value;
+ int ndigit, *decpt, *sign;
+{
+ return cvt(value, ndigit, decpt, sign, 1);
+}
+
+char *
+_fcvt(value, ndigit, decpt, sign)
+ double value;
+ int ndigit, *decpt, *sign;
+{
+ return cvt(value, ndigit, decpt, sign, 0);
+}
+
+static struct powers_of_10 {
+ double pval;
+ double rpval;
+ int exp;
+} p10[] = {
+ 1.0e32, 1.0e-32, 32,
+ 1.0e16, 1.0e-16, 16,
+ 1.0e8, 1.0e-8, 8,
+ 1.0e4, 1.0e-4, 4,
+ 1.0e2, 1.0e-2, 2,
+ 1.0e1, 1.0e-1, 1,
+ 1.0e0, 1.0e0, 0
+};
+
+static char *
+cvt(value, ndigit, decpt, sign, ecvtflag)
+ double value;
+ int ndigit, *decpt, *sign;
+{
+ static char buf[NDIGITS+1];
+ register char *p = buf;
+ register char *pe;
+
+ if (ndigit < 0) ndigit = 0;
+ if (ndigit > NDIGITS) ndigit = NDIGITS;
+ pe = &buf[ndigit];
+ buf[0] = '\0';
+
+ *sign = 0;
+ if (value < 0) {
+ *sign = 1;
+ value = -value;
+ }
+
+ *decpt = 0;
+ if (value >= DBL_MAX) {
+ value = DBL_MAX;
+ }
+ if (value != 0.0) {
+ register struct powers_of_10 *pp = &p10[0];
+
+ if (value >= 10.0) do {
+ while (value >= pp->pval) {
+ value *= pp->rpval;
+ *decpt += pp->exp;
+ }
+ } while ((++pp)->exp > 0);
+
+ pp = &p10[0];
+ if (value < 1.0) do {
+ while (value * pp->pval < 10.0) {
+ value *= pp->pval;
+ *decpt -= pp->exp;
+ }
+ } while ((++pp)->exp > 0);
+
+ (*decpt)++; /* because now value in [1.0, 10.0) */
+ }
+ if (! ecvtflag) {
+ /* for fcvt() we need ndigit digits behind the dot */
+ pe += *decpt;
+ if (pe > &buf[NDIGITS]) pe = &buf[NDIGITS];
+ }
+ while (p <= pe) {
+ *p++ = (int)value + '0';
+ value = 10.0 * (value - (int)value);
+ }
+ if (pe >= buf) {
+ p = pe;
+ *p += 5; /* round of at the end */
+ while (*p > '9') {
+ *p = '0';
+ if (p > buf) ++*--p;
+ else {
+ *p = '1';
+ ++*decpt;
+ if (! ecvtflag) {
+ /* maybe add another digit at the end,
+ because the point was shifted right
+ */
+ if (pe > buf) *pe = '0';
+ pe++;
+ }
+ }
+ }
+ *pe = '\0';
+ }
+ return buf;
+}
+#endif
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+
+/* procedure diag(var f:text); */
+
+diag(f) struct file *f; {
+
+ f->ptr = f->bufadr;
+ f->flags = WRBIT|EOFBIT|ELNBIT|TXTBIT|MAGIC;
+ f->fname = "DIAG";
+ f->ufd = 2;
+ f->size = 1;
+ f->count = 1;
+ f->buflen = 1;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+
+#define assert() /* nothing */
+
+/*
+ * use circular list of free blocks from low to high addresses
+ * _highp points to free block with highest address
+ */
+struct adm {
+ struct adm *next;
+ int size;
+};
+
+extern struct adm *_lastp;
+extern struct adm *_highp;
+extern _trp();
+
+static int merge(p1,p2) struct adm *p1,*p2; {
+ struct adm *p;
+
+ p = (struct adm *)((char *)p1 + p1->size);
+ if (p > p2)
+ _trp(EFREE);
+ if (p != p2)
+ return(0);
+ p1->size += p2->size;
+ p1->next = p2->next;
+ return(1);
+}
+
+_dis(n,pp) int n; struct adm **pp; {
+ struct adm *p1,*p2;
+
+ /*
+ * NOTE: dispose only objects whose size is a multiple of sizeof(*pp).
+ * this is always true for objects allocated by _new()
+ */
+ n = ((n+sizeof(*p1)-1) / sizeof(*p1)) * sizeof(*p1);
+ if (n == 0)
+ return;
+ if ((p1= *pp) == (struct adm *) 0)
+ _trp(EFREE);
+ p1->size = n;
+ if ((p2 = _highp) == 0) /*p1 is the only free block*/
+ p1->next = p1;
+ else {
+ if (p2 > p1) {
+ /*search for the preceding free block*/
+ if (_lastp < p1) /*reduce search*/
+ p2 = _lastp;
+ while (p2->next < p1)
+ p2 = p2->next;
+ }
+ /* if p2 preceeds p1 in the circular list,
+ * try to merge them */
+ p1->next = p2->next; p2->next = p1;
+ if (p2 <= p1 && merge(p2,p1))
+ p1 = p2;
+ p2 = p1->next;
+ /* p1 preceeds p2 in the circular list */
+ if (p2 > p1) merge(p1,p2);
+ }
+ if (p1 >= p1->next)
+ _highp = p1;
+ _lastp = p1;
+ *pp = (struct adm *) 0;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern struct file *_curfil;
+extern _trp();
+extern _incpt();
+
+int _efl(f) struct file *f; {
+
+ _curfil = f;
+ if ((f->flags & 0377) != MAGIC)
+ _trp(EBADF);
+ if ((f->flags & (WINDOW|WRBIT|EOFBIT)) == 0)
+ _incpt(f);
+ return((f->flags & EOFBIT) != 0);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern _trp();
+extern _rf();
+
+int _eln(f) struct file *f; {
+
+ _rf(f);
+ if (f->flags & EOFBIT)
+ _trp(EEOF);
+ return((f->flags & ELNBIT) != 0);
+}
--- /dev/null
+#
+
+
+; $Header$
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+; procedure encaps(procedure p; procedure(q(n:integer));
+; {call q if a trap occurs during the execution of p}
+; {if q returns, continue execution of p}
+
+
+ inp $handler
+
+#define PIISZ 2*_EM_PSIZE
+
+#define PARG 0
+#define QARG PIISZ
+#define E_ELB 0-_EM_PSIZE
+#define E_EHA -2*_EM_PSIZE
+
+; encaps is called with two parameters:
+; - procedure instance identifier of q (QARG)
+; - procedure instance identifier of p (PARG)
+; and two local variables:
+; - the lb of the previous encaps (E_ELB)
+; - the procedure identifier of the previous handler (E_EHA)
+;
+; One static variable:
+; - the lb of the currently active encaps (enc_lb)
+
+enc_lb
+ bss _EM_PSIZE,0,0
+
+ exp $encaps
+ pro $encaps,PIISZ
+ ; save lb of previous encaps
+ lae enc_lb
+ loi _EM_PSIZE
+ lal E_ELB
+ sti _EM_PSIZE
+ ; set new lb
+ lxl 0
+ lae enc_lb
+ sti _EM_PSIZE
+ ; save old handler id while setting up the new handler
+ lpi $handler
+ sig
+ lal E_EHA
+ sti _EM_PSIZE
+ ; handler is ready, p can be called
+ ; p doesn't expect parameters except possibly the static link
+ ; always passing the link won't hurt
+ lal PARG
+ loi PIISZ
+ cai
+ asp _EM_PSIZE
+ ; reinstate old handler
+ lal E_ELB
+ loi _EM_PSIZE
+ lae enc_lb
+ sti _EM_PSIZE
+ lal E_EHA
+ loi _EM_PSIZE
+ sig
+ asp _EM_PSIZE
+ ret 0
+ end ?
+
+#define TRAP 0
+#define H_ELB 0-_EM_PSIZE
+
+; handler is called with one parameter:
+; - trap number (TRAP)
+; one local variable
+; - the current LB of the enclosing encaps (H_ELB)
+
+
+ pro $handler,_EM_PSIZE
+ ; save LB of nearest encaps
+ lae enc_lb
+ loi _EM_PSIZE
+ lal H_ELB
+ sti _EM_PSIZE
+ ; fetch setting for previous encaps via LB of nearest
+ lal H_ELB
+ loi _EM_PSIZE
+ adp E_ELB
+ loi _EM_PSIZE ; LB of previous encaps
+ lae enc_lb
+ sti _EM_PSIZE
+ lal H_ELB
+ loi _EM_PSIZE
+ adp E_EHA
+ loi _EM_PSIZE ; previous handler
+ sig
+ asp _EM_PSIZE
+ ; previous handler is re-instated, time to call Q
+ lol TRAP ; the one and only real parameter
+ lal H_ELB
+ loi _EM_PSIZE
+ lpb ; argument base of enclosing encaps
+ adp QARG
+ loi PIISZ
+ exg _EM_PSIZE
+ dup _EM_PSIZE ; The static link is now on top
+ zer _EM_PSIZE
+ cmp
+ zeq *1
+ ; non-zero LB
+ exg _EM_PSIZE
+ cai
+ asp _EM_WSIZE+_EM_PSIZE
+ bra *2
+1
+ ; zero LB
+ asp _EM_PSIZE
+ cai
+ asp _EM_WSIZE
+2
+ ; now reinstate handler for continued execution of p
+ lal H_ELB
+ loi _EM_PSIZE
+ lae enc_lb
+ sti _EM_PSIZE
+ lpi $handler
+ sig
+ asp _EM_PSIZE
+ rtt
+ end ?
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* $Header$ */
+#define __NO_DEFS
+#include <math.h>
+#include <pc_err.h>
+extern _trp();
+
+#if __STDC__
+#include <float.h>
+#include <pc_math.h>
+#define M_MIN_D DBL_MIN
+#define M_MAX_D DBL_MAX
+#define M_DMINEXP DBL_MIN_EXP
+#endif
+#undef HUGE
+#define HUGE 1e1000
+
+static double
+Ldexp(fl,exp)
+ double fl;
+ int exp;
+{
+ extern double _fef();
+ int sign = 1;
+ int currexp;
+
+ if (fl<0) {
+ fl = -fl;
+ sign = -1;
+ }
+ fl = _fef(fl,&currexp);
+ exp += currexp;
+ if (exp > 0) {
+ while (exp>30) {
+ fl *= (double) (1L << 30);
+ exp -= 30;
+ }
+ fl *= (double) (1L << exp);
+ }
+ else {
+ while (exp<-30) {
+ fl /= (double) (1L << 30);
+ exp += 30;
+ }
+ fl /= (double) (1L << -exp);
+ }
+ return sign * fl;
+}
+
+double
+_exp(x)
+ double x;
+{
+ /* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ */
+
+ static double p[] = {
+ 0.25000000000000000000e+0,
+ 0.75753180159422776666e-2,
+ 0.31555192765684646356e-4
+ };
+
+ static double q[] = {
+ 0.50000000000000000000e+0,
+ 0.56817302698551221787e-1,
+ 0.63121894374398503557e-3,
+ 0.75104028399870046114e-6
+ };
+ double xn, g;
+ int n;
+ int negative = x < 0;
+
+ if (x <= M_LN_MIN_D) {
+ g = M_MIN_D/4.0;
+
+ if (g != 0.0) {
+ /* unnormalized numbers apparently exist */
+ if (x < (M_LN2 * (M_DMINEXP - 53))) return 0.0;
+ }
+ else {
+ if (x < M_LN_MIN_D) return 0.0;
+ return M_MIN_D;
+ }
+ }
+ if (x >= M_LN_MAX_D) {
+ if (x > M_LN_MAX_D) {
+ _trp(EEXP);
+ return HUGE;
+ }
+ return M_MAX_D;
+ }
+ if (negative) x = -x;
+
+ n = x * M_LOG2E + 0.5; /* 1/ln(2) = log2(e), 0.5 added for rounding */
+ xn = n;
+ {
+ double x1 = (long) x;
+ double x2 = x - x1;
+
+ g = ((x1-xn*0.693359375)+x2) - xn*(-2.1219444005469058277e-4);
+ }
+ if (negative) {
+ g = -g;
+ n = -n;
+ }
+ xn = g * g;
+ x = g * POLYNOM2(xn, p);
+ n += 1;
+ return (Ldexp(0.5 + x/(POLYNOM3(xn, q) - x), n));
+}
--- /dev/null
+#
+; $Header$
+;
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+#define FARG 0
+#define ERES _EM_DSIZE
+
+; _fef is called with two parameters:
+; - address of exponent result (ERES)
+; - floating point number to be split (FARG)
+; and returns an _EM_DSIZE-byte floating point number
+
+ exp $_fef
+ pro $_fef,0
+ lal FARG
+ loi _EM_DSIZE
+ fef _EM_DSIZE
+ lal ERES
+ loi _EM_PSIZE
+ sti _EM_WSIZE
+ ret _EM_DSIZE
+ end ?
--- /dev/null
+#
+; $Header$
+;
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+#define ARG1 0
+#define ARG2 _EM_DSIZE
+#define IRES 2*_EM_DSIZE
+
+; _fif is called with three parameters:
+; - address of integer part result (IRES)
+; - float two (ARG2)
+; - float one (ARG1)
+; and returns an _EM_DSIZE-byte floating point number
+
+ exp $_fif
+ pro $_fif,0
+ lal 0
+ loi 2*_EM_DSIZE
+ fif _EM_DSIZE
+ lal IRES
+ loi _EM_PSIZE
+ sti _EM_DSIZE
+ ret _EM_DSIZE
+ end ?
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern _rf();
+extern _trp();
+
+_get(f) struct file *f; {
+
+ _rf(f);
+ if (f->flags&EOFBIT)
+ _trp(EEOF);
+ f->flags &= ~WINDOW;
+}
--- /dev/null
+#
+; $Header$
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+
+/* Author: J.W. Stevenson */
+
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+#define TARLB 0
+#define DESCR _EM_PSIZE
+
+#define NEWPC 0
+#define SAVSP _EM_PSIZE
+
+#define D_PC 0
+#define D_SP _EM_PSIZE
+#define D_LB _EM_PSIZE+_EM_PSIZE
+
+#define LOCLB 0-_EM_PSIZE
+
+; _gto is called with two arguments:
+; - pointer to the label descriptor (DESCR)
+; - local base (LB) of target procedure (TARLB)
+; the label descriptor contains two items:
+; - label address i.e. new PC (NEWPC)
+; - offset in target procedure frame (SAVSP)
+; using this offset and the LB of the target procedure, the address of
+; of local variable of the target procedure is constructed.
+; the target procedure must have stored the correct target SP there.
+
+descr
+ bss 3*_EM_PSIZE,0,0
+
+ exp $_gto
+ pro $_gto,_EM_PSIZE
+ lal DESCR
+ loi _EM_PSIZE
+ adp NEWPC
+ loi _EM_PSIZE
+ lae descr+D_PC
+ sti _EM_PSIZE
+ lal TARLB
+ loi _EM_PSIZE
+ zer _EM_PSIZE
+ cmp
+ zeq *1
+ lal TARLB
+ loi _EM_PSIZE
+ bra *2
+1
+ lae _m_lb
+ loi _EM_PSIZE
+2
+ lal LOCLB
+ sti _EM_PSIZE
+ lal LOCLB
+ loi _EM_PSIZE
+ lal DESCR
+ loi _EM_PSIZE
+ adp SAVSP
+ loi _EM_WSIZE ; or _EM_PSIZE ?
+ ads _EM_WSIZE ; or _EM_PSIZE ?
+ loi _EM_PSIZE
+ lae descr+D_SP
+ sti _EM_PSIZE
+ lal LOCLB
+ loi _EM_PSIZE
+ lae descr+D_LB
+ sti _EM_PSIZE
+ gto descr
+ end ?
--- /dev/null
+#
+; $Header$
+ mes 2,_EM_WSIZE,_EM_PSIZE
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+
+extern struct file **_extfl;
+extern int _extflc;
+extern _cls();
+extern _exit();
+
+_hlt(ecode) int ecode; {
+ int i;
+
+ for (i = 0; i < _extflc; i++)
+ if (_extfl[i] != (struct file *) 0)
+ _cls(_extfl[i]);
+ _exit(ecode);
+}
--- /dev/null
+#
+
+; $Header$
+;
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+; _hol0 return the address of the ABS block (hol0)
+
+ exp $_hol0
+ pro $_hol0,0
+ lae 0
+ ret _EM_PSIZE
+ end ?
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+#define EINTR 4
+
+extern int errno;
+extern _trp();
+extern int _read();
+
+_incpt(f) struct file *f; {
+
+ if (f->flags & EOFBIT)
+ _trp(EEOF);
+ f->flags |= WINDOW;
+ f->flags &= ~ELNBIT;
+#ifdef CPM
+ do {
+#endif
+ f->ptr += f->size;
+ if (f->count == 0) {
+ f->ptr = f->bufadr;
+ for(;;) {
+ f->count=_read(f->ufd,f->bufadr,f->buflen);
+ if ( f->count<0 ) {
+ if (errno != EINTR) _trp(EREAD) ;
+ continue ;
+ }
+ break ;
+ }
+ if (f->count == 0) {
+ f->flags |= EOFBIT;
+ *f->ptr = '\0';
+ return;
+ }
+ }
+ if ((f->count -= f->size) < 0)
+ _trp(EFTRUNC);
+#ifdef CPM
+ } while ((f->flags&TXTBIT) && *f->ptr == '\r');
+#endif
+ if (f->flags & TXTBIT) {
+ if (*f->ptr & 0200)
+ _trp(EASCII);
+ if (*f->ptr == '\n') {
+ f->flags |= ELNBIT;
+ *f->ptr = ' ';
+ }
+#ifdef CPM
+ if (*f->ptr == 26) {
+ f->flags |= EOFBIT;
+ *f->ptr = 0;
+ }
+#endif
+ }
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern (*_sig())();
+extern _catch();
+#ifndef CPM
+extern int _isatty();
+#endif
+
+struct file **_extfl;
+int _extflc; /* number of external files */
+char *_m_lb; /* LB of _m_a_i_n */
+struct file *_curfil; /* points to file struct in case of errors */
+int _pargc;
+char **_pargv;
+char ***_penviron;
+int _fp_hook = 1; /* This is for Minix, but does not harm others */
+
+_ini(args,c,p,mainlb) char *args,*mainlb; int c; struct file **p; {
+ struct file *f;
+ char buf[128];
+
+ _pargc= *(int *)args; args += sizeof (int);
+ _pargv= *(char ***)args;
+ _sig(_catch);
+ _extfl = p;
+ _extflc = c;
+ if( !c ) return;
+ _m_lb = mainlb;
+ if ( (f = _extfl[0]) != (struct file *) 0) {
+ f->ptr = f->bufadr;
+ f->flags = MAGIC|TXTBIT;
+ f->fname = "INPUT";
+ f->ufd = 0;
+ f->size = 1;
+ f->count = 0;
+ f->buflen = PC_BUFLEN;
+ }
+ if ( (f = _extfl[1]) != (struct file *) 0) {
+ f->ptr = f->bufadr;
+ f->flags = MAGIC|TXTBIT|WRBIT|EOFBIT|ELNBIT;
+ f->fname = "OUTPUT";
+ f->ufd = 1;
+ f->size = 1;
+#ifdef CPM
+ f->count = 1;
+#else
+ f->count = (_isatty(1) ? 1 : PC_BUFLEN);
+#endif
+ f->buflen = f->count;
+ }
+}
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* $Header$ */
+
+#define __NO_DEFS
+#include <math.h>
+#include <pc_err.h>
+
+#if __STDC__
+#include <pc_math.h>
+#include <float.h>
+#endif
+#undef HUGE
+#define HUGE 1e1000
+
+double
+_log(x)
+ double x;
+{
+ /* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ */
+ static double a[] = {
+ -0.64124943423745581147e2,
+ 0.16383943563021534222e2,
+ -0.78956112887491257267e0
+ };
+ static double b[] = {
+ -0.76949932108494879777e3,
+ 0.31203222091924532844e3,
+ -0.35667977739034646171e2,
+ 1.0
+ };
+
+ extern double _fef();
+ double znum, zden, z, w;
+ int exponent;
+
+ if (x <= 0) {
+ _trp(ELOG);
+ return -HUGE;
+ }
+
+ x = _fef(x, &exponent);
+ if (x > M_1_SQRT2) {
+ znum = (x - 0.5) - 0.5;
+ zden = x * 0.5 + 0.5;
+ }
+ else {
+ znum = x - 0.5;
+ zden = znum * 0.5 + 0.5;
+ exponent--;
+ }
+ z = znum/zden; w = z * z;
+ x = z + z * w * (POLYNOM2(w,a)/POLYNOM3(w,b));
+ z = exponent;
+ x += z * (-2.121944400546905827679e-4);
+ return x + z * 0.693359375;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+
+extern _trp();
+
+int _mdi(j,i) int j,i; {
+
+ if (j <= 0)
+ _trp(EMOD);
+ i = i % j;
+ if (i < 0)
+ i += j;
+ return(i);
+}
+
+long _mdil(j,i) long j,i; {
+
+ if (j <= 0)
+ _trp(EMOD);
+ i = i % j;
+ if (i < 0)
+ i += j;
+ return(i);
+}
+
+int _dvi(j, i) unsigned int j,i; {
+ int neg = 0;
+
+ if ((int)j < 0) {
+ j = -(int)j; neg = 1;
+ }
+ if ((int)i < 0) {
+ i = -(int)i; neg = !neg;
+ }
+ i = i / j;
+ if (neg) return -(int)i;
+ return i;
+}
+
+long _dvil(j, i) unsigned long j,i; {
+ int neg = 0;
+
+ if ((long)j < 0) {
+ j = -(long)j; neg = 1;
+ }
+ if ((long)i < 0) {
+ i = -(long)i; neg = !neg;
+ }
+ i = i / j;
+ if (neg) return -(long)i;
+ return i;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+
+extern _trp();
+
+long _mdl(j,i) long j,i; {
+
+ if (j <= 0)
+ _trp(EMOD);
+ i = i % j;
+ if (i < 0)
+ i += j;
+ return(i);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+extern _sav();
+extern _rst();
+
+#define assert(x) /* nothing */
+#define UNDEF 0x8000
+
+struct adm {
+ struct adm *next;
+ int size;
+};
+
+struct adm *_lastp = 0;
+struct adm *_highp = 0;
+
+_new(n,pp) int n; struct adm **pp; {
+ struct adm *p,*q;
+ int *ptmp;
+
+ n = ((n+sizeof(*p)-1) / sizeof(*p)) * sizeof(*p);
+ if ((p = _lastp) != 0)
+ do {
+ q = p->next;
+ if (q->size >= n) {
+ assert(q->size%sizeof(adm) == 0);
+ if ((q->size -= n) == 0) {
+ if (p == q)
+ p = 0;
+ else
+ p->next = q->next;
+ if (q == _highp)
+ _highp = p;
+ }
+ _lastp = p;
+ p = (struct adm *)((char *)q + q->size);
+ q = (struct adm *)((char *)p + n);
+ goto initialize;
+ }
+ p = q;
+ } while (p != _lastp);
+ /*no free block big enough*/
+ _sav(&p);
+ q = (struct adm *)((char *)p + n);
+ _rst(&q);
+initialize:
+ *pp = p;
+ ptmp = (int *)p;
+ while (ptmp < (int *)q)
+ *ptmp++ = UNDEF;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1990 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+
+/* Author: Hans van Eck */
+
+#include <pc_err.h>
+
+extern _trp();
+
+_nfa(bool)
+{
+ if (! bool) _trp(EFUNASS);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+
+extern _flush();
+
+/* procedure nobuff(var f:file of ?); */
+
+nobuff(f) struct file *f; {
+
+ if ((f->flags & (0377|WRBIT)) != (MAGIC|WRBIT))
+ return;
+ _flush(f);
+ f->count = f->buflen = f->size;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+
+notext(f) struct file *f; {
+ f->flags &= ~TXTBIT;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern struct file **_extfl;
+extern int _extflc;
+extern struct file *_curfil;
+extern int _pargc;
+extern char **_pargv;
+extern char ***_penviron;
+
+extern _cls();
+extern _xcls();
+extern _trp();
+extern int _getpid();
+extern int _creat();
+extern int _open();
+extern int _close();
+extern int _unlink();
+extern long _lseek();
+
+static int tmpfil() {
+ static char namebuf[] = "/usr/tmp/plf.xxxxx";
+ int i; char *p,*q;
+
+ i = _getpid();
+ p = namebuf;
+ q = p + 13;
+ do
+ *q++ = (i & 07) + '0';
+ while (i >>= 3);
+ *q = '\0';
+ if ((i = _creat(p,0644)) < 0)
+ if ((i = _creat(p += 4,0644)) < 0)
+ if ((i = _creat(p += 5,0644)) < 0)
+ goto error;
+ if (_close(i) != 0)
+ goto error;
+ if ((i = _open(p,2)) < 0)
+ goto error;
+ if (_unlink(p) != 0)
+error: _trp(EREWR);
+ return(i);
+}
+
+static int initfl(descr,sz,f) int descr; int sz; struct file *f; {
+ int i;
+
+ _curfil = f;
+ if (sz == 0) {
+ sz++;
+ descr |= TXTBIT;
+ }
+ for (i=0; i<_extflc; i++)
+ if (f == _extfl[i])
+ break;
+ if (i >= _extflc) { /* local file */
+ f->fname = "LOCAL";
+ if ((descr & WRBIT) == 0 && (f->flags & 0377) == MAGIC) {
+ _xcls(f);
+ if (_lseek(f->ufd,(long)0,0) == -1)
+ _trp(ERESET);
+ } else {
+ _cls(f);
+ f->ufd = tmpfil();
+ }
+ } else { /* external file */
+ if (--i <= 0)
+ return(0);
+ if (i >= _pargc)
+ _trp(EARGC);
+ f->fname = _pargv[i];
+ _cls(f);
+ if ((descr & WRBIT) == 0) {
+ if ((f->ufd = _open(f->fname,0)) < 0)
+ _trp(ERESET);
+ } else {
+ if ((f->ufd = _creat(f->fname,0644)) < 0)
+ _trp(EREWR);
+ }
+ }
+ f->buflen = (sz>PC_BUFLEN ? sz : PC_BUFLEN-PC_BUFLEN%sz);
+ f->size = sz;
+ f->ptr = f->bufadr;
+ f->flags = descr;
+ return(1);
+}
+
+_opn(sz,f) int sz; struct file *f; {
+
+ if (initfl(MAGIC,sz,f))
+ f->count = 0;
+}
+
+_cre(sz,f) int sz; struct file *f; {
+
+ if (initfl(WRBIT|EOFBIT|ELNBIT|MAGIC,sz,f))
+ f->count = f->buflen;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+#define EINTR 4
+
+extern int errno;
+extern _trp();
+extern int _write();
+
+_flush(f) struct file *f; {
+ int i,n;
+
+ f->ptr = f->bufadr;
+ n = f->buflen - f->count;
+ if (n <= 0)
+ return;
+ f->count = f->buflen;
+ if ((i = _write(f->ufd,f->bufadr,n)) < 0 && errno == EINTR)
+ return;
+ if (i != n)
+ _trp(EWRITE);
+}
+
+_outcpt(f) struct file *f; {
+
+ f->flags &= ~ELNBIT;
+ f->ptr += f->size;
+ if ((f->count -= f->size) <= 0)
+ _flush(f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+
+extern _trp();
+
+#define assert(x) /* nothing */
+
+#ifndef EM_WSIZE
+#define EM_WSIZE _EM_WSIZE
+#endif
+
+struct descr {
+ int low;
+ int diff;
+ int size;
+};
+
+_pac(ad,zd,zp,i,ap) int i; struct descr *ad,*zd; char *zp,*ap; {
+
+ if (zd->diff > ad->diff ||
+ (i -= ad->low) < 0 ||
+ (i+zd->diff) > ad->diff)
+ _trp(EPACK);
+ ap += (i * ad->size);
+ i = (zd->diff + 1) * zd->size;
+ if (zd->size == 1) {
+ int *aptmp = (int *)ap;
+ assert(ad->size == EM_WSIZE);
+ while (--i >= 0)
+ *zp++ = *aptmp++;
+#if EM_WSIZE > 2
+ } else if (zd->size == 2) {
+ int *aptmp = (int *)ap;
+ short *zptmp = (short *) zp;
+ assert(ad->size == EM_WSIZE);
+ while (--i >= 0)
+ *zptmp++ = *aptmp++;
+#endif
+ } else {
+ assert(ad->size == zd->size);
+ while (--i >= 0)
+ *zp++ = *ap++;
+ }
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+
+extern _cls();
+
+/* procedure pclose(var f:file of ??); */
+
+pclose(f) struct file *f; {
+ _cls(f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern _cls();
+extern _trp();
+extern int _creat();
+
+/* procedure pcreat(var f:text; s:string); */
+
+pcreat(f,s) struct file *f; char *s; {
+
+ _cls(f); /* initializes _curfil */
+ f->ptr = f->bufadr;
+ f->flags = WRBIT|EOFBIT|ELNBIT|TXTBIT|MAGIC;
+ f->fname = s;
+ f->size = 1;
+ f->count = PC_BUFLEN;
+ f->buflen = PC_BUFLEN;
+ if ((f->ufd = _creat(s,0644)) < 0)
+ _trp(EREWR);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+
+extern struct file **_extfl;
+extern _wrs();
+extern _wrz();
+extern _wln();
+
+procentry(name) char *name; {
+ struct file *f;
+
+ f = _extfl[1];
+ _wrs(5,"call ",f);
+ _wrz(name,f);
+ _wln(f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* function perrno:integer; extern; */
+
+extern int errno;
+
+int perrno() {
+ return(errno);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+
+extern struct file **_extfl;
+extern _wrs();
+extern _wrz();
+extern _wln();
+
+procexit(name) char *name; {
+ struct file *f;
+
+ f = _extfl[1];
+ _wrs(5,"exit ",f);
+ _wrz(name,f);
+ _wln(f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern _cls();
+extern _trp();
+extern int _open();
+
+/* procedure popen(var f:text; s:string); */
+
+popen(f,s) struct file *f; char *s; {
+
+ _cls(f); /* initializes _curfil */
+ f->ptr = f->bufadr;
+ f->flags = TXTBIT|MAGIC;
+ f->fname = s;
+ f->size = 1;
+ f->count = 0;
+ f->buflen = PC_BUFLEN;
+ if ((f->ufd = _open(s,0)) < 0)
+ _trp(ERESET);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+
+extern _wf();
+extern _outcpt();
+
+_put(f) struct file *f; {
+ _wf(f);
+ _outcpt(f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1990 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+
+/* Author: Hans van Eck */
+
+#include <em_abs.h>
+
+extern _trp();
+
+struct array_descr {
+ int lbound;
+ unsigned n_elts_min_one;
+ unsigned size; /* doesn't really matter */
+ };
+
+_rcka(descr, index)
+struct array_descr *descr;
+{
+ if( index < descr->lbound ||
+ index > (int) descr->n_elts_min_one + descr->lbound )
+ _trp(EARRAY);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+
+extern _rf();
+extern _incpt();
+
+int _rdc(f) struct file *f; {
+ int c;
+
+ _rf(f);
+ c = *f->ptr;
+ _incpt(f);
+ return(c);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern _trp();
+extern _rf();
+extern _incpt();
+
+_skipsp(f) struct file *f; {
+ while ((*f->ptr == ' ') || (*f->ptr == '\t'))
+ _incpt(f);
+}
+
+int _getsig(f) struct file *f; {
+ int sign;
+
+ if ((sign = (*f->ptr == '-')) || *f->ptr == '+')
+ _incpt(f);
+ return(sign);
+}
+
+int _fstdig(f) struct file *f; {
+ int ch;
+
+ ch = *f->ptr - '0';
+ if ((unsigned) ch > 9) {
+ _trp(EDIGIT);
+ ch = 0;
+ }
+ return(ch);
+}
+
+int _nxtdig(f) struct file *f; {
+ int ch;
+
+ _incpt(f);
+ ch = *f->ptr - '0';
+ if ((unsigned) ch > 9)
+ return(-1);
+ return(ch);
+}
+
+int _getint(f) struct file *f; {
+ int is_signed,i,ch;
+
+ is_signed = _getsig(f);
+ ch = _fstdig(f);
+ i = 0;
+ do
+ i = i*10 - ch;
+ while ((ch = _nxtdig(f)) >= 0);
+ return(is_signed ? i : -i);
+}
+
+int _rdi(f) struct file *f; {
+ _rf(f);
+ _skipsp(f);
+ return(_getint(f));
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+
+extern _rf();
+extern _skipsp();
+extern int _getsig();
+extern int _fstdig();
+extern int _nxtdig();
+
+long _rdl(f) struct file *f; {
+ int is_signed,ch; long l;
+
+ _rf(f);
+ _skipsp(f);
+ is_signed = _getsig(f);
+ ch = _fstdig(f);
+ l = 0;
+ do
+ l = l*10 - ch;
+ while ((ch = _nxtdig(f)) >= 0);
+ return(is_signed ? l : -l);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_file.h>
+
+#define BIG 1e17
+
+extern _rf();
+extern _incpt();
+extern _skipsp();
+extern int _getsig();
+extern int _getint();
+extern int _fstdig();
+extern int _nxtdig();
+
+static double r;
+static int pow10;
+
+static dig(ch) int ch; {
+
+ if (r>BIG)
+ pow10++;
+ else
+ r = r*10.0 + ch;
+}
+
+double _rdr(f) struct file *f; {
+ int i; double e; int is_signed,ch;
+
+ r = 0;
+ pow10 = 0;
+ _rf(f);
+ _skipsp(f);
+ is_signed = _getsig(f);
+ ch = _fstdig(f);
+ do
+ dig(ch);
+ while ((ch = _nxtdig(f)) >= 0);
+ if (*f->ptr == '.') {
+ _incpt(f);
+ ch = _fstdig(f);
+ do {
+ dig(ch);
+ pow10--;
+ } while ((ch = _nxtdig(f)) >= 0);
+ }
+ if ((*f->ptr == 'e') || (*f->ptr == 'E')) {
+ _incpt(f);
+ pow10 += _getint(f);
+ }
+ if ((i = pow10) < 0)
+ i = -i;
+ e = 1.0;
+ while (--i >= 0)
+ e *= 10.0;
+ if (pow10<0)
+ r /= e;
+ else
+ r *= e;
+ return(is_signed? -r : r);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern struct file *_curfil;
+extern _trp();
+extern _incpt();
+
+_rf(f) struct file *f; {
+
+ _curfil = f;
+ if ((f->flags&0377) != MAGIC)
+ _trp(EBADF);
+ if (f->flags & WRBIT)
+ _trp(EREADF);
+ if ((f->flags & WINDOW) == 0)
+ _incpt(f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+
+extern _rf();
+extern _incpt();
+
+_rln(f) struct file *f; {
+
+ _rf(f);
+ while ((f->flags & ELNBIT) == 0)
+ _incpt(f);
+ f->flags &= ~WINDOW;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+double _rnd(r) double r; {
+ return(r + (r<0 ? -0.5 : 0.5));
+}
--- /dev/null
+#
+; $Header$
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+
+/* Author: J.W. Stevenson */
+
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+#define PTRAD 0
+
+#define HP 2
+
+; _sav called with one parameter:
+; - address of pointer variable (PTRAD)
+
+ exp $_sav
+ pro $_sav,0
+ lor HP
+ lal PTRAD
+ loi _EM_PSIZE
+ sti _EM_PSIZE
+ ret 0
+ end ?
+
+; _rst is called with one parameter:
+; - address of pointer variable (PTRAD)
+
+ exp $_rst
+ pro $_rst,0
+ lal PTRAD
+ loi _EM_PSIZE
+ loi _EM_PSIZE
+ str HP
+ ret 0
+ end ?
--- /dev/null
+#define PROC 0
+
+; $Header$
+;
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+; _sig is called with one parameter:
+; - procedure instance identifier (PROC)
+; and returns nothing.
+; only the procedure identifier inside the PROC is used.
+
+ exp $_sig
+ pro $_sig,0
+ lal PROC
+ loi _EM_PSIZE
+ sig
+ asp _EM_PSIZE
+ ret 0 ; ignore the result of sig
+ end ?
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* $Header$ */
+
+#define __NO_DEFS
+#include <math.h>
+
+#if __STDC__
+#include <pc_math.h>
+#endif
+
+static double
+sinus(x, cos_flag)
+ double x;
+{
+ /* Algorithm and coefficients from:
+ "Software manual for the elementary functions"
+ by W.J. Cody and W. Waite, Prentice-Hall, 1980
+ */
+
+ static double r[] = {
+ -0.16666666666666665052e+0,
+ 0.83333333333331650314e-2,
+ -0.19841269841201840457e-3,
+ 0.27557319210152756119e-5,
+ -0.25052106798274584544e-7,
+ 0.16058936490371589114e-9,
+ -0.76429178068910467734e-12,
+ 0.27204790957888846175e-14
+ };
+
+ double xsqr;
+ double y;
+ int neg = 0;
+
+ if (x < 0) {
+ x = -x;
+ neg = 1;
+ }
+ if (cos_flag) {
+ neg = 0;
+ y = M_PI_2 + x;
+ }
+ else y = x;
+
+ /* ??? avoid loss of significance, if y is too large, error ??? */
+
+ y = y * M_1_PI + 0.5;
+
+ /* Use extended precision to calculate reduced argument.
+ Here we used 12 bits of the mantissa for a1.
+ Also split x in integer part x1 and fraction part x2.
+ */
+#define A1 3.1416015625
+#define A2 -8.908910206761537356617e-6
+ {
+ double x1, x2;
+ extern double _fif();
+
+ _fif(y, 1.0, &y);
+ if (_fif(y, 0.5, &x1)) neg = !neg;
+ if (cos_flag) y -= 0.5;
+ x2 = _fif(x, 1.0, &x1);
+ x = x1 - y * A1;
+ x += x2;
+ x -= y * A2;
+#undef A1
+#undef A2
+ }
+
+ if (x < 0) {
+ neg = !neg;
+ x = -x;
+ }
+
+ /* ??? avoid underflow ??? */
+
+ y = x * x;
+ x += x * y * POLYNOM7(y, r);
+ return neg ? -x : x;
+}
+
+double
+_sin(x)
+ double x;
+{
+ return sinus(x, 0);
+}
+
+double
+_cos(x)
+ double x;
+{
+ if (x < 0) x = -x;
+ return sinus(x, 1);
+}
--- /dev/null
+/*
+ * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ *
+ * Author: Ceriel J.H. Jacobs
+ */
+
+/* $Header$ */
+#define __NO_DEFS
+#include <math.h>
+#include <pc_err.h>
+extern _trp();
+
+#define NITER 5
+
+static double
+Ldexp(fl,exp)
+ double fl;
+ int exp;
+{
+ extern double _fef();
+ int sign = 1;
+ int currexp;
+
+ if (fl<0) {
+ fl = -fl;
+ sign = -1;
+ }
+ fl = _fef(fl,&currexp);
+ exp += currexp;
+ if (exp > 0) {
+ while (exp>30) {
+ fl *= (double) (1L << 30);
+ exp -= 30;
+ }
+ fl *= (double) (1L << exp);
+ }
+ else {
+ while (exp<-30) {
+ fl /= (double) (1L << 30);
+ exp += 30;
+ }
+ fl /= (double) (1L << -exp);
+ }
+ return sign * fl;
+}
+
+double
+_sqt(x)
+ double x;
+{
+ extern double _fef();
+ int exponent;
+ double val;
+
+ if (x <= 0) {
+ if (x < 0) _trp(ESQT);
+ return 0;
+ }
+
+ val = _fef(x, &exponent);
+ if (exponent & 1) {
+ exponent--;
+ val *= 2;
+ }
+ val = Ldexp(val + 1.0, exponent/2 - 1);
+ /* was: val = (val + 1.0)/2.0; val = Ldexp(val, exponent/2); */
+ for (exponent = NITER - 1; exponent >= 0; exponent--) {
+ val = (val + x / val) / 2.0;
+ }
+ return val;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* function strbuf(var b:charbuf):string; */
+
+char *strbuf(s) char *s; {
+ return(s);
+}
+
+/* function strtobuf(s:string; var b:charbuf; blen:integer):integer; */
+
+int strtobuf(s,b,l) char *s,*b; {
+ int i;
+
+ i = 0;
+ while (--l>=0) {
+ if ((*b++ = *s++) == 0)
+ break;
+ i++;
+ }
+ return(i);
+}
+
+/* function strlen(s:string):integer; */
+
+int strlen(s) char *s; {
+ int i;
+
+ i = 0;
+ while (*s++)
+ i++;
+ return(i);
+}
+
+/* function strfetch(s:string; i:integer):char; */
+
+int strfetch(s,i) char *s; {
+ return(s[i-1]);
+}
+
+/* procedure strstore(s:string; i:integer; c:char); */
+
+strstore(s,i,c) char *s; {
+ s[i-1] = c;
+}
--- /dev/null
+#
+
+; $Header$
+;
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+#define TRAP 0
+
+; trap is called with one parameter:
+; - trap number (TRAP)
+
+ exp $trap
+ pro $trap,0
+ lol TRAP
+ trp
+ ret 0
+ end ?
--- /dev/null
+#
+
+; $Header$
+;
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+;
+
+ mes 2,_EM_WSIZE,_EM_PSIZE
+
+#define TRAP 0
+
+; _trp() and trap() perform the same function,
+; but have to be separate. trap exists to facilitate the user.
+; _trp is there for the system, trap cannot be used for that purpose
+; because a user might define its own Pascal routine called trap.
+
+; _trp is called with one parameter:
+; - trap number (TRAP)
+
+ exp $_trp
+ pro $_trp,0
+ lol TRAP
+ trp
+ ret 0
+ end ?
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+
+extern _trp();
+
+#define assert(x) /* nothing */
+
+#ifndef EM_WSIZE
+#define EM_WSIZE _EM_WSIZE
+#endif
+
+struct descr {
+ int low;
+ int diff;
+ int size;
+};
+
+_unp(ad,zd,i,ap,zp,noext) int i; struct descr *ad,*zd; char *ap,*zp; int noext; {
+
+ if (zd->diff > ad->diff ||
+ (i -= ad->low) < 0 ||
+ (i+zd->diff) > ad->diff)
+ _trp(EUNPACK);
+ ap += (i * ad->size);
+ i = (zd->diff + 1) * zd->size;
+ if (zd->size == 1) {
+ int *aptmp = (int *) ap;
+ assert(ad->size == EM_WSIZE);
+ while (--i >= 0)
+ if (noext) *aptmp++ = *zp++ & 0377;
+ else *aptmp++ = *zp++;
+#if EM_WSIZE > 2
+ } else if (zd->size == 2) {
+ int *aptmp = (int *) ap;
+ short *zptmp = (short *) zp;
+ assert(ad->size == EM_WSIZE);
+ while (--i >= 0)
+ if (noext) *aptmp++ = *zptmp++ & 0177777;
+ else *aptmp++ = *zptmp++;
+#endif
+ } else {
+ assert(ad->size == zd->size);
+ while (--i >= 0)
+ *ap++ = *zp++;
+ }
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* function uread(fd:integer; var b:buf; n:integer):integer; */
+
+extern int _read();
+
+int uread(fd,b,n) char *b; int fd,n; {
+ return(_read(fd,b,n));
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* function uwrite(fd:integer; var b:buf; n:integer):integer; */
+
+extern int _write();
+
+int uwrite(fd,b,n) char *b; int fd,n; {
+ return(_write(fd,b,n));
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+
+extern struct file *_curfil;
+extern _incpt();
+
+char *_wdw(f) struct file *f; {
+
+ _curfil = f;
+ if ((f->flags & (WINDOW|WRBIT|0377)) == MAGIC)
+ _incpt(f);
+ return(f->ptr);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+#include <pc_err.h>
+
+extern struct file *_curfil;
+extern _trp();
+
+_wf(f) struct file *f; {
+
+ _curfil = f;
+ if ((f->flags&0377) != MAGIC)
+ _trp(EBADF);
+ if ((f->flags & WRBIT) == 0)
+ _trp(EWRITEF);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_file.h>
+
+extern _wf();
+extern _outcpt();
+
+_wrc(c,f) int c; struct file *f; {
+ *f->ptr = c;
+ _wf(f);
+ _outcpt(f);
+}
+
+_wln(f) struct file *f; {
+#ifdef CPM
+ _wrc('\r',f);
+#endif
+ _wrc('\n',f);
+ f->flags |= ELNBIT;
+}
+
+_pag(f) struct file *f; {
+ _wrc('\014',f);
+ f->flags |= ELNBIT;
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+#include <pc_file.h>
+
+extern _wstrin();
+extern char *_fcvt();
+
+#define assert(x) /* nothing */
+
+#if __STDC__
+#include <float.h>
+#define HUGE_DIG DBL_MAX_10_EXP /* log10(maxreal) */
+#else
+#define HUGE_DIG 400 /* log10(maxreal) */
+#endif
+#define PREC_DIG 80 /* the maximum digits returned by _fcvt() */
+#define FILL_CHAR '0' /* char printed if all of _fcvt() used */
+#define BUFSIZE HUGE_DIG + PREC_DIG + 3
+
+_wrf(n,w,r,f) int n,w; double r; struct file *f; {
+ char *p,*b; int s,d; char buf[BUFSIZE];
+
+ if ( n < 0 || w < 0) _trp(EWIDTH);
+ p = buf;
+ if (n > PREC_DIG)
+ n = PREC_DIG;
+ b = _fcvt(r,n,&d,&s);
+ assert(abs(d) <= HUGE_DIG);
+ if (s)
+ *p++ = '-';
+ if (d<=0)
+ *p++ = '0';
+ else
+ do
+ *p++ = (*b ? *b++ : FILL_CHAR);
+ while (--d > 0);
+ if (n > 0)
+ *p++ = '.';
+ while (++d <= 0) {
+ if (--n < 0)
+ break;
+ *p++ = '0';
+ }
+ while (--n >= 0) {
+ *p++ = (*b ? *b++ : FILL_CHAR);
+ assert(p <= buf+BUFSIZE);
+ }
+ _wstrin(w,(int)(p-buf),buf,f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_err.h>
+#include <pc_file.h>
+
+extern _wstrin();
+
+#ifndef EM_WSIZE
+#ifdef _EM_WSIZE
+#define EM_WSIZE _EM_WSIZE
+#endif
+#endif
+
+#if EM_WSIZE==4
+#define SZ 11
+#define MININT -2147483648
+#define STRMININT "-2147483648"
+#endif
+#if EM_WSIZE==2
+#define SZ 6
+#define MININT -32768
+#define STRMININT "-32768"
+#endif
+#if EM_WSIZE==1
+#define SZ 4
+#define MININT -128
+#define STRMININT "-128"
+#endif
+
+#ifndef STRMININT
+Something wrong here!
+#endif
+
+_wsi(w,i,f) int w,i; struct file *f; {
+ char *p; int j; char buf[SZ];
+
+ if (w < 0) _trp(EWIDTH);
+ p = &buf[SZ];
+ if ((j=i) < 0) {
+ if (i == MININT) {
+ _wstrin(w,SZ,STRMININT,f);
+ return;
+ }
+ j = -j;
+ }
+ do
+ *--p = '0' + j%10;
+ while (j /= 10);
+ if (i<0)
+ *--p = '-';
+ _wstrin(w,(int)(&buf[SZ]-p),p,f);
+}
+
+_wri(i,f) int i; struct file *f; {
+ _wsi(SZ,i,f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+#include <pc_file.h>
+
+extern _wstrin();
+
+#define MAXNEGLONG -2147483648
+
+_wsl(w,l,f) int w; long l; struct file *f; {
+ char *p,c; long j; char buf[11];
+
+ if (w < 0) _trp(EWIDTH);
+ p = &buf[11];
+ if ((j=l) < 0) {
+ if (l == MAXNEGLONG) {
+ _wstrin(w,11,"-2147483648",f);
+ return;
+ }
+ j = -j;
+ }
+ do {
+ c = j%10;
+ *--p = c + '0';
+ } while (j /= 10);
+ if (l<0)
+ *--p = '-';
+ _wstrin(w,(int)(&buf[11]-p),p,f);
+}
+
+_wrl(l,f) long l; struct file *f; {
+ _wsl(11,l,f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+#include <pc_file.h>
+
+extern _wstrin();
+extern char *_ecvt();
+
+#define PREC_DIG 80 /* maximum digits produced by _ecvt() */
+
+_wsr(w,r,f) int w; double r; struct file *f; {
+ char *p,*b; int s,d,i; char buf[PREC_DIG+7];
+
+ if (w < 0) _trp(EWIDTH);
+ p = buf;
+ if ((i = w-6) < 2)
+ i = 2;
+ b = _ecvt(r,i,&d,&s);
+ *p++ = s? '-' : ' ';
+ if (*b == '0')
+ d++;
+ *p++ = *b++;
+ *p++ = '.';
+ while (--i > 0)
+ *p++ = *b++;
+ *p++ = 'e';
+ d--;
+ if (d < 0) {
+ d = -d;
+ *p++ = '-';
+ } else
+ *p++ = '+';
+
+ if (d >= 1000) {
+ *p++ = '*';
+ *p++ = '*';
+ *p++ = '*';
+ }
+ else {
+ *p++ = '0' + d/100;
+ *p++ = '0' + (d/10) % 10;
+ *p++ = '0' + d%10;
+ }
+ _wstrin(w,(int)(p-buf),buf,f);
+}
+
+_wrr(r,f) double r; struct file *f; {
+ _wsr(13,r,f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: J.W. Stevenson */
+
+#include <pc_err.h>
+#include <pc_file.h>
+
+extern _wf();
+extern _outcpt();
+
+_wstrin(width,len,buf,f) int width,len; char *buf; struct file *f; {
+
+ _wf(f);
+ for (width -= len; width>0; width--) {
+ *f->ptr = ' ';
+ _outcpt(f);
+ }
+ while (--len >= 0) {
+ *f->ptr = *buf++;
+ _outcpt(f);
+ }
+}
+
+_wsc(w,c,f) int w; char c; struct file *f; {
+
+ if (w < 0) _trp(EWIDTH);
+ _wss(w,1,&c,f);
+}
+
+_wss(w,len,s,f) int w,len; char *s; struct file *f; {
+
+ if (w < 0 || len < 0) _trp(EWIDTH);
+ if (w < len)
+ len = w;
+ _wstrin(w,len,s,f);
+}
+
+_wrs(len,s,f) int len; char *s; struct file *f; {
+ if (len < 0) _trp(EWIDTH);
+ _wss(len,len,s,f);
+}
+
+_wsb(w,b,f) int w,b; struct file *f; {
+ if (b)
+ _wss(w,4,"true",f);
+ else
+ _wss(w,5,"false",f);
+}
+
+_wrb(b,f) int b; struct file *f; {
+ _wsb(5,b,f);
+}
--- /dev/null
+/* $Header$ */
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+#include <pc_err.h>
+#include <pc_file.h>
+
+extern _wss();
+extern _wrs();
+
+_wsz(w,s,f) int w; char *s; struct file *f; {
+ char *p;
+
+ if (w < 0) _trp(EWIDTH);
+ for (p=s; *p; p++);
+ _wss(w,(int)(p-s),s,f);
+}
+
+_wrz(s,f) char *s; struct file *f; {
+ char *p;
+
+ for (p=s; *p; p++);
+ _wrs((int)(p-s),s,f);
+}
--- /dev/null
+# Makefile for lib/liby.
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE -wo
+
+LIBRARIES = liby
+
+liby_OBJECTS = \
+ main.o \
+ yyerror.o \
+
+include ../../Makefile.ack.inc
--- /dev/null
+# Makefile for lib/liby.
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE -wo
+CC1 = $(CC) $(CFLAGS) -c
+
+LIBRARY = ../../liby.a
+all: $(LIBRARY)
+
+OBJECTS = \
+ $(LIBRARY)(main.o) \
+ $(LIBRARY)(yyerror.o) \
+
+$(LIBRARY): $(OBJECTS)
+ aal cr $@ *.o
+ rm *.o
+
+$(LIBRARY)(main.o): main.c
+ $(CC1) main.c
+
+$(LIBRARY)(yyerror.o): yyerror.c
+ $(CC1) yyerror.c
--- /dev/null
+/*-
+ * Copyright (c) 1990 The Regents of the University of California.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. All advertising materials mentioning features or use of this software
+ * must display the following acknowledgement:
+ * This product includes software developed by the University of
+ * California, Berkeley and its contributors.
+ * 4. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#if defined(LIBC_SCCS) && !defined(lint)
+static char sccsid[] = "@(#)main.c 5.3 (Berkeley) 1/13/91";
+#endif /* not lint */
+
+main()
+{
+ exit(yyparse());
+}
--- /dev/null
+/*-
+ * Copyright (c) 1990 The Regents of the University of California.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. All advertising materials mentioning features or use of this software
+ * must display the following acknowledgement:
+ * This product includes software developed by the University of
+ * California, Berkeley and its contributors.
+ * 4. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#if defined(LIBC_SCCS) && !defined(lint)
+static char sccsid[] = "@(#)yyerror.c 5.2 (Berkeley) 5/15/90";
+#endif /* not lint */
+
+#include <stdio.h>
+
+yyerror(msg)
+char *msg;
+{
+ (void)fprintf(stderr, "%s\n", msg);
+ return(0);
+}
--- /dev/null
+# Makefile for lib/ack/math.
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE
+
+LIBRARIES = libc
+
+libc_OBJECTS = \
+ frexp.o \
+ modf.o \
+ isnan.o \
+ ldexp.o \
+
+include ../../Makefile.ack.inc
--- /dev/null
+# Makefile for lib/math.
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE
+CC1 = $(CC) $(CFLAGS) -c
+
+LIBRARY = ../../libc.a
+all: $(LIBRARY)
+
+OBJECTS = \
+ $(LIBRARY)(frexp.o) \
+ $(LIBRARY)(modf.o) \
+ $(LIBRARY)(isnan.o) \
+ $(LIBRARY)(ldexp.o) \
+
+$(LIBRARY): $(OBJECTS)
+ aal cr $@ *.o
+ rm *.o
+
+$(LIBRARY)(frexp.o): frexp.s
+ $(CC1) frexp.s
+
+$(LIBRARY)(modf.o): modf.s
+ $(CC1) modf.s
+
+$(LIBRARY)(isnan.o): isnan.c
+ $(CC1) isnan.c
+
+$(LIBRARY)(ldexp.o): ldexp.c
+ $(CC1) ldexp.c
--- /dev/null
+#
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.extern _frexp
+.sect .text
+_frexp:
+#if __i386
+ push ebp
+ mov ebp, esp
+ push 12(ebp)
+ push 8(ebp)
+ mov eax, esp
+ add eax, -4
+ push eax
+ call .fef8
+ mov eax, 16(ebp)
+ pop (eax)
+ pop eax
+ pop edx
+ leave
+ ret
+#else /* i86 */
+ push bp
+ mov bp, sp
+ lea bx, 4(bp)
+ mov cx, #8
+ call .loi
+ mov ax, sp
+ add ax, #-2
+ push ax
+ call .fef8
+ mov bx, 12(bp)
+ pop (bx)
+ call .ret8
+ jmp .cret
+#endif
--- /dev/null
+int __IsNan(double d)
+{
+#if defined(vax) || defined(pdp)
+#else
+ float f = d;
+
+ if ((*((long *) &f) & 0x7f800000) == 0x7f800000 &&
+ (*((long *) &f) & 0x007fffff) != 0) return 1;
+#endif
+ return 0;
+}
--- /dev/null
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+/* $Header$ */
+
+#include <math.h>
+#include <float.h>
+#include <errno.h>
+
+double
+ldexp(double fl, int exp)
+{
+ int sign = 1;
+ int currexp;
+
+ if (__IsNan(fl)) {
+ errno = EDOM;
+ return fl;
+ }
+ if (fl == 0.0) return 0.0;
+ if (fl<0) {
+ fl = -fl;
+ sign = -1;
+ }
+ if (fl > DBL_MAX) { /* for infinity */
+ errno = ERANGE;
+ return sign * fl;
+ }
+ fl = frexp(fl,&currexp);
+ exp += currexp;
+ if (exp > 0) {
+ if (exp > DBL_MAX_EXP) {
+ errno = ERANGE;
+ return sign * HUGE_VAL;
+ }
+ while (exp>30) {
+ fl *= (double) (1L << 30);
+ exp -= 30;
+ }
+ fl *= (double) (1L << exp);
+ }
+ else {
+ /* number need not be normalized */
+ if (exp < DBL_MIN_EXP - DBL_MANT_DIG) {
+ return 0.0;
+ }
+ while (exp<-30) {
+ fl /= (double) (1L << 30);
+ exp += 30;
+ }
+ fl /= (double) (1L << -exp);
+ }
+ return sign * fl;
+}
--- /dev/null
+#
+.sect .text; .sect .rom; .sect .data; .sect .bss
+.extern _modf
+.sect .text
+_modf:
+#if __i386
+ push ebp
+ mov ebp, esp
+ push 12(ebp)
+ push 8(ebp)
+ push 1
+ push 4
+ call .cif8
+ mov eax, esp
+ push eax
+ call .fif8
+ pop ecx
+ mov edx, 16(ebp)
+ pop ecx
+ pop ebx
+ mov 0(edx), ecx
+ mov 4(edx), ebx
+ pop eax
+ pop edx
+ leave
+ ret
+#else /* i86 */
+ push bp
+ mov bp, sp
+ lea bx, 4(bp)
+ mov cx, #8
+ call .loi
+ mov dx, #1
+ push dx
+ push dx
+ push dx
+ mov ax, #2
+ push ax
+ call .cif8
+ mov ax, sp
+ push ax
+ call .fif8
+ pop bx
+ mov bx, 12(bp)
+ mov cx, #8
+ call .sti
+ call .ret8
+ jmp .cret
+#endif
--- /dev/null
+# Makefile for lib/ack/rts.
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE
+
+LIBRARIES = libc
+
+libc_OBJECTS = \
+ setjmp.o \
+
+include ../../Makefile.ack.inc
--- /dev/null
+# Makefile for lib/rts.
+
+CFLAGS = -O -D_MINIX -D_POSIX_SOURCE
+CC1 = $(CC) $(CFLAGS) -c
+
+LIBRARY = ../../libc.a
+
+all: \
+ $(LIBRARY)
+
+OBJECTS = \
+ $(LIBRARY)(setjmp.o) \
+
+$(LIBRARY): $(OBJECTS)
+ aal cr $@ *.o
+ rm *.o
+
+$(LIBRARY)(setjmp.o): setjmp.e
+ $(CC1) setjmp.e
--- /dev/null
+#
+ mes 2,_EM_WSIZE,_EM_PSIZE
+;
+; layout of a setjmp buffer:
+;
+; -----------------
+; | flag | (!0 when blocked signals saved (POSIX))
+; -----------------
+; | signal mask/set | (for Berkeley 4.[2-] / POSIX)
+; -----------------
+; | |
+; | GTO descriptor |
+; | (SP, LB, PC) |
+; | |
+; -----------------
+;
+; setjmp saves the signalmask, PC, SP, and LB of caller, and creates a
+; GTO descriptor from this.
+; The big problem here is how to get the return address, i.e. the PC of
+; the caller; This problem is solved by the front-end, which must pass
+; it as an extra parameter to setjmp.
+
+; a GTO descriptor must be in the global data area
+gtobuf
+ bss 3*_EM_PSIZE,0,0
+
+ inp $fill_ret_area
+ exp $__setjmp
+ pro $__setjmp,0
+#if defined(_POSIX_SOURCE)
+; save mask of currently blocked signals.
+; longjmp must restore this mask
+ lol _EM_PSIZE ; the flag integer at offset _EM_PSIZE
+ lal 0
+ loi _EM_PSIZE
+ stf 3*_EM_PSIZE+_EM_LSIZE
+ lol _EM_PSIZE ; the flag integer at offset _EM_PSIZE
+ zeq *1
+ lal 0
+ loi _EM_PSIZE
+ adp 3*_EM_PSIZE
+ cal $__newsigset
+ asp _EM_PSIZE
+1
+#elif defined(__BSD4_2)
+ loc 0
+ cal $sigblock
+ asp _EM_WSIZE
+ lfr _EM_WSIZE
+ lal 0
+ loi _EM_PSIZE
+ stf 3*_EM_PSIZE
+#endif
+; create GTO descriptor for longjmp
+ lxl 0
+ dch ; Local Base of caller
+ lxa 0 ; Stackpointer of caller
+ lal _EM_PSIZE+_EM_WSIZE
+ loi _EM_PSIZE ; Return address of caller
+ lal 0
+ loi _EM_PSIZE ; address of jmpbuf
+ sti 3*_EM_PSIZE ; LB, SP, and PC stored in jmpbuf
+ loc 0
+ ret _EM_WSIZE ; setjmp must return 0
+ end 0
+
+ pro $fill_ret_area,0
+; put argument in function result area
+ lol 0
+ ret _EM_WSIZE
+ end 0
+
+ exp $longjmp
+ pro $longjmp,?
+#if defined(_POSIX_SOURCE)
+; restore blocked mask
+ lal 0
+ loi _EM_PSIZE
+ lof 3*_EM_PSIZE+_EM_LSIZE
+ zeq *2
+ lal 0
+ loi _EM_PSIZE
+ adp 3*_EM_PSIZE
+ cal $__oldsigset
+ asp _EM_PSIZE
+2
+#elif defined(__BSD4_2)
+; restore signal mask
+ lal 0
+ loi _EM_PSIZE
+ lof 3*_EM_PSIZE
+ cal $_sigsetmask
+ asp _EM_WSIZE
+ lfr _EM_WSIZE
+ asp _EM_WSIZE
+#endif
+ lal 0
+ loi _EM_PSIZE ; address of jmpbuf
+ lae gtobuf
+ blm 3*_EM_PSIZE ; fill GTO descriptor from jmpbuf
+ lol _EM_PSIZE ; second parameter of longjmp: the return value
+ dup _EM_WSIZE
+ zne *3
+; of course, longjmp may not return 0!
+ inc
+3
+; put return value in function result area
+ cal $fill_ret_area
+ asp _EM_WSIZE
+ gto gtobuf ; there we go ...
+; ASP and GTO do not damage function result area
+ end 0