From c1a44d416636e38fab5db6633384c1e76669b8ff Mon Sep 17 00:00:00 2001 From: gdr Date: Wed, 17 Sep 1997 16:36:41 +0000 Subject: [PATCH] - initial checkin, as submitted by Soenke Behrens --- lib/lsaneglue/Makefile | 46 + lib/lsaneglue/README | 245 +++++ lib/lsaneglue/findfpcp.asm | 106 +++ lib/lsaneglue/findfpe.c | 13 + lib/lsaneglue/fpnumtest.c | 31 + lib/lsaneglue/fpspecnum.asm | 104 +++ lib/lsaneglue/sane.h | 183 ++++ lib/lsaneglue/saneglue.asm | 1689 ++++++++++++++++++++++++++++++++++ lib/lsaneglue/saneglue.macro | 55 ++ lib/lsaneglue/sanetest.c | 597 ++++++++++++ 10 files changed, 3069 insertions(+) create mode 100644 lib/lsaneglue/Makefile create mode 100644 lib/lsaneglue/README create mode 100644 lib/lsaneglue/findfpcp.asm create mode 100644 lib/lsaneglue/findfpe.c create mode 100644 lib/lsaneglue/fpnumtest.c create mode 100644 lib/lsaneglue/fpspecnum.asm create mode 100644 lib/lsaneglue/sane.h create mode 100644 lib/lsaneglue/saneglue.asm create mode 100644 lib/lsaneglue/saneglue.macro create mode 100644 lib/lsaneglue/sanetest.c diff --git a/lib/lsaneglue/Makefile b/lib/lsaneglue/Makefile new file mode 100644 index 0000000..ca35f9f --- /dev/null +++ b/lib/lsaneglue/Makefile @@ -0,0 +1,46 @@ +# Makefile for SANE glue code +# 1997 Soenke Behrens + +# All paths assume a GNO/ME setup as described in Devin Reade's +# GNO/ME FAQ. For installation under ORCA/Shell, see the README +# file + +LIBDIR = 13 +# Change INCDIR to 13/orcacdefs if you are using the "old-style" +# path naming convention +# Or set to /lang/orca/include if you wish to completely replace +# ORCA/C's sane.h. +INCDIR = /usr/include + +# You should not have to modify anything beyond this point + +all: sanetest findfpe lsaneglue + +sanetest: sanetest.o saneglue.o + $(RM) saneglue.root + occ -o sanetest sanetest.o saneglue.o + +findfpe: findfpe.o findfpcp.o + $(RM) findfpcp.root + occ -o findfpe findfpe.o findfpcp.o + +saneglue.o:: saneglue.mac + +saneglue.mac: saneglue.asm saneglue.macro + macgen saneglue.asm saneglue.mac saneglue.mac saneglue.macro \ +13:ainclude:m16.sane 13:orcainclude:m16.orca + +findfpcp.o:: findfpcp.mac + +findfpcp.mac: findfpcp.asm + macgen findfpcp.asm findfpcp.mac findfpcp.mac \ +13:orcainclude:m16.orca + +lsaneglue: saneglue.o findfpcp.o + $(RM) lsaneglue + makelib lsaneglue +saneglue.o +findfpcp.o + copyfork lsaneglue.r lsaneglue + +install: + cp -f sane.h $(INCDIR) + cp -f lsaneglue $(LIBDIR) diff --git a/lib/lsaneglue/README b/lib/lsaneglue/README new file mode 100644 index 0000000..f4537db --- /dev/null +++ b/lib/lsaneglue/README @@ -0,0 +1,245 @@ +SANE Glue Code for ORCA/C 2.1 or later +Written in 1997 by Soenke Behrens + +Legal Stuff +=========== + +This library and the accompanying source code are hereby placed +into the Public Domain. There is no warranty, express or implied, +on the performance of the library or source code. The author is not +liable for any damage that may occur as a direct or indirect result +of using the library or source code. + +Installation +============ + +In GNO/ME, run "dmake install". +This will copy a changed sane.h to /lang/orca/include and the library +lsaneglue to 13. +If, on your system, includes are kept in a different directory (say +13/orcacdefs), either copy the files manually or edit the file +"makefile" to use a different path. + +In ORCA/Shell, copy the changed include file and the library +manually. + +Afterwards, use a directory ordering utility such as ProSel-16 +to make sure lsaneglue comes _before_ ORCALIB. + +Documentation, Use +================== + +lsaneglue is a library that contains code to let you call +SANE functions directly from ORCA/C. To avoid namespace +conflicts with math.h, it was necessary to change sane.h. +Thus, all SANE functions are now prefixed with "s_" (e.g. +"annuity" became "s_annuity", and "sin" became "s_sin"). +This lets you choose easily between the SANE and ISO/C +implementations of the same function. + +Below you will find a brief overview over the functions in +lsaneglue. This overview does not replace, however, proper +documentation. To fully understand SANE, you will need the +"Apple Numerics Manual, 2nd Edition" by Apple Computer, Inc., +ISBN 0-201-17738-2, published by Addison-Wesley Publishing +Company, Inc. +SANE is also introduced in the "Apple IIgs Toolbox Reference, +Volume 2", Chapter 18. + +I find the functions to control the SANE environment (rounding +direction, halts &c.), the functions to spot NaNs (classification +functions) as well as the functions that give you a good pi, NaN +and INF particularly useful. + +Brief SANE function overview +============================ + +There is one function in lsaneglue that has nothing to do with +SANE: + +int findfpcp(void); + +This function will find an FPE or NC card and return the slot number +(or -1 if card not found). You can use the output of this function +for the ORCA/C setfpeslot(), which is used when having ORCA/C +create code for the FPE/NC directly (#pragma float 1 1). + +Now for the SANE interface functions. +I will give the prototype of the function, and a one-line description +on the following line. Page numbers refer to Apple Numerics Manual. + +NB: Use the file "sane.h" itself as reference for constants used + to set/test exceptions, rounding direction, rounding precision, + number classes, ordering relations, formatting styles and NAN codes. + +void s_num2dec(DecForm *f, extended x, Decimal *d); + Convert x to SANE decimal record. Pg 28 + +extended s_dec2num(Decimal *d); + Convert SANE decimal record to extended. Pg 28f + +void s_str2dec(char *s, short *ix, Decimal *d, short *vp); + Convert string s to SANE decimal record. Pg 30f + +void s_dec2str(DecForm *f, Decimal *d, char *s); + Convert SANE decimal record d to string. Pg 31ff + +extended s_fabs(extended x); + Get the absolute of x (make sign positive). Pg 49 + +extended s_fneg(extended x); + Reverse sign of x. Pg 49 + +extended s_remainder(extended x, extended y, short *quo); + Get the remainder of x and y. Pg 46f + +extended s_sqrt(extended x); + Compute square root of x. Pg 46 + +extended s_rint(extended x); + Round x to integer in current rounding direction. Pg 47 + +extended s_scalb(short n, extended x); + Return (x times 2^n). Pg 50 + +extended s_logb(extended x); + Compute binary exponent of normalized x. Pg 50 + +extended s_copysign(extended x, extended y); + Return y with sign of x. Pg 49 + +extended s_nextfloat(extended x, extended y); + Return next float number after x in direction of y. Pg 50 + +extended s_nextdouble(extended x, extended y); + Return next double number after x in direction of y. Pg 50 + +extended s_nextextended(extended x, extended y); + Return next extended number after x in direction of y. Pg 50 + +extended s_log2(extended x); + Return base-2 logarithm of x. Pg 62 + +extended s_log(extended x); + Return base-e (natural) logarithm of x. Pg 62 + +extended s_log1(extended x); + Return base-e (natural) logarithm of (x+1). Pg 62 + +extended s_exp2(extended x); + Return base-2 exponantial of x (2^x). Pg 63f + +extended s_exp(extended x); + Return base-e (natural) exponantial of x (x^e). Pg 63f + +extended s_exp1(extended x); + Return base-e (natural) exponantial of x, minus 1 (x^e - 1). Pg 63f + +extended s_power(extended x, extended y); + Return x^y. Pg 63f + +extended s_ipower(extended x, short i); + Return x^i. Pg 63f + +extended s_compound(extended r, extended n); + Compute compound (1+r)^n. Pg 64f + +extended s_annuity(extended r, extended n); + Compute annuity (1-(1+r)^n)/r. Pg 65 + +extended s_tan(extended x); + Return tangent of x. Pg 67f + +extended s_sin(extended x); + Return sine of x. Pg 67 + +extended s_cos(extended x); + Return cosine of x. Pg 67 + +extended s_atan(extended x); + Return arctangent of x. Pg 67f + +extended s_randomx(extended *x); + Return pseudorandom integer value with seed x. Pg 67 + +numclass s_classfloat(extended x); + Return classification of float x. Pg 44 + +numclass s_classdouble(extended x); + Return classification of double x. Pg 44 + +numclass s_classcomp(extended x); + Return classification of comp x. Pg 44 + +numclass s_classextended(extended); + Return classification of extended x. Pg 44 + +int s_signnum(extended x); + Return sign of x: 0 if positive, 1 if negative. Pg 44 + +void s_setexception(exception e, long b); + Clear or set SANE exceptions. Pg 54ff + +long s_testexception(exception e); + Check whether SANE exception is currently set. Pg 54ff + +void s_sethalt(exception e, long b); + Clear or set SANE exception halts. Pg 54ff + +long s_testhalt(exception e); + Check whether SANE exception halt is currently set. Pg 54ff + +void s_setround(rounddir r); + Set SANE rounding direction. Pg 52f + +rounddir s_getround(void); + Get SANE rounding direction. Pg 52f + +void s_setprecision(roundpre p); + Set SANE rounding precision. Pg 53 + +roundpre s_getprecision(void); + Get SANE rounding precision. Pg 53 + +void s_setenvironment(environment e); + Set SANE environment word. Pg 57 + +void s_getenvironment(environment *e); + Get SANE environment word. Pg 57 + +void s_procentry(environment *e); + Save SANE environment word, then default it. Pg 57 + +void s_procexit(environment e); + Restore SANE environment word, then signal exceptions. Pg 57 + +haltvector s_gethaltvector(void); + Get SANE halt vector. Pg 54 + +void s_sethaltvector(haltvector v); + Set SANE halt vector. Pg 54 + +relop s_relation(extended x, extended y); + Return relation of x to y. Pg 49 + +extended s_nan(unsigned char c); + Return NaN(c). + +extended s_inf(void); + Return +INF (Infinity). + +extended s_pi(void); + Return pi constant (3.141592653589793238512808959) + + +Errors in SANE toolkit +====================== + +The fclass functions should return the sign of the passed number +in n-bit and Y. They do not report the sign at all, though, which +has to be considered a bug. s_signnum() has been rewritten to not +rely on fclassx any more. + +Soenke Behrens +September 1997 +sbehrens@bigfoot.com diff --git a/lib/lsaneglue/findfpcp.asm b/lib/lsaneglue/findfpcp.asm new file mode 100644 index 0000000..e9b0b83 --- /dev/null +++ b/lib/lsaneglue/findfpcp.asm @@ -0,0 +1,106 @@ + case on + mcopy findfpcp.mac + +* +* Find the slot the FPE or NumberCruncher card is in +* +* Returns the slot number or -1 if FPCP card cannot be found. +* +* For slots 1-5 and 7, findfpcp() can find the card +* regardless of the Slot setting in the Control Panel. +* For slot 6, the Control Panel must be set to "Your Card" +* for the function to be able to find the card. +* +* Written in 1997 by Soenke Behrens, from Merlin code by +* Albert Chin-A-Young +* This code is hereby place into the Public Domain +* + +* +* Dummy function to take care of findfpcp.root, which +* can then be discarded. +* + +dummy start + end + +**************************************************************** +* +* int findfpcp (void); +* +* Find slot FPCP card is in +* +* See also: Floating-Point Coprocessor Manual by Albert +* Chin-A-Young +* +**************************************************************** +* + +findfpcp start +SETINTC3ROM equ $e1c00a ; enable internal slot 3 ROM +SETSLOTC3ROM equ $e1c00b ; enable external slot 3 ROM +RDC3ROM equ $e1c017 ; bit 7 = 1 if slot c3 space enabled +SLTROMSEL equ $e1c02d ; slot ROM select + + csub + + sei Disable interrupts + short m 8-bit accumulator + lda #0 enable slot 3 ROM as FPCP + sta SETSLOTC3ROM might be in slot 3 +lab1 lda RDC3ROM wait for external slot 3 + bpl lab1 space to be enabled + lda SLTROMSEL store previous value in Y + tay + ora #%10110110 enable slot 1, 2, 4, 5, 7 ROM + sta SLTROMSEL + long m 16-bit accumulator + + ldx #$c100 Start with slot 1 +search lda $e00004,x read slot at address $04, + cmp id_bytes $06 and $0b. If no match + bne next_slot is found, exit, else set up + lda $e00006,x base address + cmp id_bytes+2 + bne next_slot + lda $e0000b,x + cmp id_bytes+4 + beq found + +next_slot txa try next slot + clc + adc #$100 + tax + cmp #$c000 last slot + $100 + bne search + + lda #$FFFF + sta slot_num store -1 to + bra end indicate FPCP not found + +found txa slot number of FPCP + xba + and #$0f strip slot number + sta slot_num save slot number + + +end short m + lda #0 re-enable internal slot 3 ROM + sta SETINTC3ROM +lab2 lda RDC3ROM wait for internal slot 3 + bmi lab2 space to be enabled + tya re-enable other internal + sta SLTROMSEL slot ROM + long m + + cli re-enable interrupts + ret 2:slot_num + +id_bytes anop + dc h'3838' + dc h'1818' + dc h'01af' + +slot_num ds 2 + + end diff --git a/lib/lsaneglue/findfpe.c b/lib/lsaneglue/findfpe.c new file mode 100644 index 0000000..58f8b83 --- /dev/null +++ b/lib/lsaneglue/findfpe.c @@ -0,0 +1,13 @@ +#include + +int main(void) +{ + int s = findfpcp(); + + if (s == -1) + printf("FPE not found\n"); + else + printf("FPE found in slot %d\n", s); + + return (0); +} diff --git a/lib/lsaneglue/fpnumtest.c b/lib/lsaneglue/fpnumtest.c new file mode 100644 index 0000000..542e9ff --- /dev/null +++ b/lib/lsaneglue/fpnumtest.c @@ -0,0 +1,31 @@ +/* + * Test the _isnan and _isinf functions. + * Requires lsaneglue to link and compile + */ + +#include +#include /* Modified sane.h from lsaneglue */ + +int _isnan (extended); +int _isinf (extended); + +int main (void) +{ + int i; + + if (_isinf(s_inf()) && _isinf(-s_inf())) + printf("_isinf() test successful.\n"); + else + printf("_isinf() test failed.\n"); + + for (i = 0; i < 256; ++i) + { + if (_isnan(s_nan(i)) != 1) + { + printf("_isnan() test failed.\n"); + return 1; + } + } + printf("_isnan() test successful.\n"); + return 0; +} diff --git a/lib/lsaneglue/fpspecnum.asm b/lib/lsaneglue/fpspecnum.asm new file mode 100644 index 0000000..6bbee55 --- /dev/null +++ b/lib/lsaneglue/fpspecnum.asm @@ -0,0 +1,104 @@ + case on + mcopy fpspecnum.mac + +* +* Test an extended to see whether it is NaN or INF +* + +* +* Dummy function to take care of fpspecnum.root, which +* can then be discarded. +* + +dummy start + copy 13:ainclude:e16.sane ; Apple-supplied SANE EQUs + end + +**************************************************************** +* +* int _isnan (extended x); +* +* Check whether x is NaN, if so, return 1, otherwise, return 0. +* +**************************************************************** +* + +_isnan start +result equ 1 +space equ result+2 + + csub (10:ext_x),space + + short m clear the specific NaN code + stz ext_x+6 + long m + + lda ext_x and do the compare + cmp nan_x + bne diff + lda ext_x+2 + cmp nan_x+2 + bne diff + lda ext_x+4 + cmp nan_x+4 + bne diff + lda ext_x+6 + cmp nan_x+6 + bne diff + lda ext_x+8 + cmp nan_x+8 + bne diff + lda #1 + sta result + bra bye +diff stz result + +bye ret (2:result) + +nan_x dc h'0000000000000040FF7F' ; Hex encoding of a NaN + end + +**************************************************************** +* +* int _isinf (extended x); +* +* Check whether x is INF, if so, return 1, otherwise, return 0. +* +**************************************************************** +* + +_isinf start +result equ 1 +space equ result+2 + + csub (10:ext_x),space + short m + lda ext_x+9 get rid of sign bit + and #%01111111 + sta ext_x+9 + long m + + lda ext_x and do the compare + cmp inf_x + bne diff + lda ext_x+2 + cmp inf_x+2 + bne diff + lda ext_x+4 + cmp inf_x+4 + bne diff + lda ext_x+6 + cmp inf_x+6 + bne diff + lda ext_x+8 + cmp inf_x+8 + bne diff + lda #1 + sta result + bra bye +diff stz result + +bye ret (2:result) + +inf_x dc h'0000000000000000FF7F' ; Hex encoding of +INF + end diff --git a/lib/lsaneglue/sane.h b/lib/lsaneglue/sane.h new file mode 100644 index 0000000..15815d7 --- /dev/null +++ b/lib/lsaneglue/sane.h @@ -0,0 +1,183 @@ +/* + * File: SANE.h + * + * Declarations, macros and prototypes for + * the SANE glue functions in library + * lsaneglue. + * + * Written in 1997 by Soenke Behrens. + * This code is hereby placed into the Public Domain. + */ + +#ifndef __SANE__ +#define __SANE__ + +#ifndef __TYPES__ +#include +#endif + +/* Decimal representation constants */ +#define SIGDIGLEN 0x001C +#define DECSTROUTLEN 0x0050 + +/* IEEE default environment constant */ +#define IEEEDEFAULTENV 0x0000 +typedef short environment; + +/* Decimal formatting styles */ +#define FLOATDECIMAL 0x0000 +#define FIXEDDECIMAL 0x0001 + +/* Exceptions */ +#define INVALID 0x0001 +#define UNDERFLOW 0x0002 +#define OVERFLOW 0x0004 +#define DIVBYZERO 0x0008 +#define INEXACT 0x0010 +typedef short exception; + +/* Ordering relations */ +#define GREATERTHAN 0 +#define LESSTHAN 1 +#define EQUALTO 2 +#define UNORDERED 3 +typedef short relop; + +/* Inquiry classes */ +#define SNAN 0 +#define QNAN 1 +#define INFINITE 2 +#define ZERONUM 3 +#define NORMALNUM 4 +#define DENORMALNUM 5 +typedef short numclass; + +/* Environmental control */ + +/* Rounding directions */ +#define TONEAREST 0 +#define UPWARD 1 +#define DOWNWARD 2 +#define TOWARDZERO 3 +typedef short rounddir; + +/* Rounding precisions */ +#define EXTPRECISION 0 +#define DBLPRECISION 1 +#define FLOATPRECISION 2 +typedef short roundpre; + +/* NAN codes */ +#define NANSQRT 1 /* Invalid square root such as sqrt(-1) */ +#define NANADD 2 /* Invalid addition such as +INF - +INF */ +#define NANDIV 4 /* Invalid division such as 0/0 */ +#define NANMUL 8 /* Invalid multiply such as 0 * INF */ +#define NANREM 9 /* Invalid rem or mod such as x REM 0 */ +#define NANASCBIN 17 /* Conversion of invalid ASCII string */ +#define NANCOMP 20 /* Comp NaN converted to floating */ +#define NANZERO 21 /* Attempt to create a NaN with zero code */ +#define NANTRIG 33 /* Invalid argument to trig routine */ +#define NANINVTRIG 34 /* Invalid arg to inverse trig routine */ +#define NANLOG 36 /* Invalid argument to log routine */ +#define NANPOWER 37 /* Invalid argument to x^i or x^y routine */ +#define NANFINAN 38 /* Invalid argument to financial function */ + +typedef struct decimal +{ + short sgn; /* sign 0 for +, 1 for - */ + short exp; /* decimal exponent */ + struct + { + unsigned char length, text[SIGDIGLEN], unused; + }sig; /* significant digits */ +} decimal, Decimal; + +typedef struct decform +{ + short style; /* FLOATDECIMAL or FIXEDDECIMAL */ + short digits; +} decform, DecForm; + +typedef void (*haltvector)(void); + +/* SANE types are: + * float -- IEEE single precision + * double -- IEEE double precision + * extended -- IEEE extended precision + * comp -- SANE comp type + * Decimal -- SANE decimal string + * DecForm -- Controls formatting of decimal strings + */ + +/* Function declarations */ + +void s_num2dec(DecForm *, extended, Decimal *); +extended s_dec2num(Decimal *); +void s_str2dec(char *, short *, Decimal *, short *); +void s_dec2str(DecForm *, Decimal *, char *); +extended s_fabs(extended); +extended s_fneg(extended); +extended s_remainder(extended, extended, short *); +extended s_sqrt(extended); +extended s_rint(extended); +extended s_scalb(short, extended); +extended s_logb(extended); +extended s_copysign(extended, extended); +extended s_nextfloat(extended, extended); +extended s_nextdouble(extended, extended); +extended s_nextextended(extended, extended); +extended s_log2(extended); +extended s_log(extended); +extended s_log1(extended); +extended s_exp2(extended); +extended s_exp(extended); +extended s_exp1(extended); +extended s_power(extended, extended); +extended s_ipower(extended, short); +extended s_compound(extended, extended); +extended s_annuity(extended, extended); +extended s_tan(extended); +extended s_sin(extended); +extended s_cos(extended); +extended s_atan(extended); +extended s_randomx(extended *); +numclass s_classfloat(extended); +numclass s_classdouble(extended); +numclass s_classcomp(extended); +numclass s_classextended(extended); +long s_signnum(extended); +void s_setexception(exception, long); +long s_testexception(exception); +void s_sethalt(exception, long); +long s_testhalt(exception); +void s_setround(rounddir); +rounddir s_getround(void); +void s_setprecision(roundpre); +roundpre s_getprecision(void); +void s_setenvironment(environment); +void s_getenvironment(environment *); +void s_procentry(environment *); +void s_procexit(environment); +haltvector s_gethaltvector(void); +void s_sethaltvector(haltvector); +relop s_relation(extended, extended); +extended s_nan(unsigned char); +extended s_inf(void); +extended s_pi(void); + +/* SANE tool calls */ + +extern pascal void SANEBootInit(void) inline(0x010A,dispatcher); +extern pascal void SANEStartUp(Word) inline(0x020A,dispatcher); +extern pascal void SANEShutDown(void) inline(0x030A,dispatcher); +extern pascal Word SANEVersion(void) inline(0x040A,dispatcher); +extern pascal void SANEReset(void) inline(0x050A,dispatcher); +extern pascal Boolean SANEStatus(void) inline(0x060A,dispatcher); +extern pascal void SANEFP816(Word, ...) inline(0x090A,dispatcher); +extern pascal void SANEDecStr816(Word, ...) inline(0x0A0A,dispatcher); +extern pascal void SANEElems816(Word, ...) inline(0x0B0A,dispatcher); + +/* FPCP find routine, not part of SANE tool set, found in lsaneglue */ +int findfpcp(void); /* Returns slot number of FPCP card or -1 if not found */ + +#endif diff --git a/lib/lsaneglue/saneglue.asm b/lib/lsaneglue/saneglue.asm new file mode 100644 index 0000000..206478a --- /dev/null +++ b/lib/lsaneglue/saneglue.asm @@ -0,0 +1,1689 @@ + case on + mcopy saneglue.mac + +* +* Provide SANE glue code for functions declared in +* +* Supported functions at this time: +* s_num2dec +* s_dec2num +* s_str2dec +* s_dec2str +* s_fabs +* s_fneg +* s_remainder +* s_sqrt +* s_rint +* s_scalb +* s_logb +* s_copysign +* s_nextfloat +* s_nextdouble +* s_nextextended +* s_log2 +* s_log +* s_log1 +* s_exp2 +* s_exp +* s_exp1 +* s_power +* s_ipower +* s_compound +* s_annuity +* s_tan +* s_sin +* s_cos +* s_atan +* s_randomx +* s_classfloat +* s_classdouble +* s_classcomp +* s_classextended +* s_signnum +* s_setexception +* s_testexception +* s_sethalt +* s_testhalt +* s_setround +* s_getround +* s_setprecision +* s_getprecision +* s_setenvironment +* s_getenvironment +* s_procentry +* s_procexit +* s_gethaltvector +* s_sethaltvector +* s_relation +* s_nan +* s_inf +* s_pi +* +* Written in 1997 by Soenke Behrens. +* This code is hereby placed into the Public Domain. +* + +* +* Dummy function to take care of saneglue.root, which +* can then be discarded. +* + +dummy start + copy 13:ainclude:e16.sane ; Apple-supplied SANE EQUs + end + +**************************************************************** +* +* void s_num2dec (DecForm *f, extended x, Decimal *d); +* +* Convert SANE extended to SANE decimal record +* +* See also: Apple Numerics Manual, pg 26ff +* +**************************************************************** +* + +s_num2dec start + + csub (4:decf_p,10:ext_x,4:dec_p) + + ph4 decf_p + phptr ext_x + ph4 dec_p + fx2dec + sterr + + ret + end + +**************************************************************** +* +* extended s_dec2num (Decimal *d); +* +* Convert SANE decimal record to SANE extended +* +* See also: Apple Numerics Manual, pg 26ff +* +**************************************************************** +* + +s_dec2num start + using sane_tmp + csub (4:dec_p) + + ph4 dec_p + ph4 #ext_tmp + fdec2x + sterr + + ret 10:ext_tmp + end + +**************************************************************** +* +* void s_str2dec (char *s, short *index, Decimal *d, short *validPrefix); +* +* Convert SANE decimal string (C-style) to SANE decimal record +* +* See also: Apple Numerics Manual, pg 30f +* +**************************************************************** +* + +s_str2dec start + + csub (4:str_p,4:idx_p,4:dec_p,4:bool_p) + + ph4 str_p + ph4 idx_p + ph4 dec_p + ph4 bool_p + fcstr2dec + sterr + + ret + end + +**************************************************************** +* +* void s_dec2str (DecForm *f, Decimal *d, char *s); +* +* Convert SANE decimal record to SANE decimal string (C-style) +* +* See also: Apple Numerics Manual, pg 31ff +* +**************************************************************** +* + +s_dec2str start +str_l equ 1 +space equ str_l+2 + + csub (4:decf_p,4:dec_p,4:str_p),space + + ph4 decf_p + ph4 dec_p + ph4 str_p + fdec2str + sterr + +* Now convert the P-string pointed to by str_p into a C-string +* Get length of string + stz str_l + short m + lda [str_p] + sta str_l +* If string is empty, don't try to copy + bne lab1 + bra break +* Move string backwards one byte +lab1 ldy #0 +loop iny + lda [str_p],y + dey + sta [str_p],y + iny + cpy str_l + bne loop +* Terminate string with 0 +break lda #0 + ldy str_l + sta [str_p],y + long m + + ret + end + +*************************************************************** +* +* extended s_fabs (extended x); +* +* Return absolute value of x +* +* See also: Apple Numerics Manual, pg 49 +* +**************************************************************** +* + +s_fabs start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fabsx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +*************************************************************** +* +* extended s_fneg (extended x); +* +* Return negated value of x +* +* See also: Apple Numerics Manual, pg 49 +* +**************************************************************** +* + +s_fneg start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fnegx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_remainder (extended x, extended y, short *quo); +* +* Compute remainder of x and y (x rem y) +* +* See also: Apple Numerics Manual, pg 46f +* +**************************************************************** +* + +s_remainder start + using sane_tmp + csub (10:ext_x,10:ext_y,4:quo_p) + + phptr ext_y + phptr ext_x + fremx + sterr + txa ; store 7 low-order bits of magnitude of + sta [quo_p] ; integer quotient + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_sqrt (extended x); +* +* Compute square root of x +* +* See also: Apple Numerics Manual, pg 46 +* +**************************************************************** +* + +s_sqrt start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fsqrtx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_rint (extended x); +* +* Round x to integral value +* +* See also: Apple Numerics Manual, pg 46f +* +**************************************************************** +* + +s_rint start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + frintx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_scalb (short n, extended x); +* +* Scale binary exponent, result = x * 2^n +* +* See also: Apple Numerics Manual, pg 50 +* +**************************************************************** +* + +s_scalb start + using sane_tmp + csub (2:n,10:ext_x) + + ph2 n + phptr ext_x + fscalbx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_logb (extended x); +* +* Compute binary exponent of normalized x +* +* See also: Apple Numerics Manual, pg 50 +* +**************************************************************** +* + +s_logb start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + flogbx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_copysign (extended x, extended y); +* +* Return y with sign of x +* +* See also: Apple Numerics Manual, pg 49 +* +**************************************************************** +* + +s_copysign start + using sane_tmp + csub (10:ext_x,10:ext_y) + + phptr ext_x + phptr ext_y + fcpysgnx + sterr + copyx ext_y,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_nextfloat (extended x, extended y); +* +* Return next float number after (float) x in direction of +* (float) y +* +* See also: Apple Numerics Manual, pg 50 +* +**************************************************************** +* + +s_nextfloat start + using sane_tmp + csub (10:ext_x,10:ext_y) + +* Convert extended parameters to single + phptr ext_x + ph4 #sgl_x + fx2s + sterr + phptr ext_y + ph4 #sgl_y + fx2s + sterr +* Now invoke nextafter function + ph4 #sgl_y + ph4 #sgl_x + fnexts + sterr +* Convert result back to extended + ph4 #sgl_x + ph4 #ext_tmp + fs2x + sterr + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_nextdouble (extended x, extended y); +* +* Return next double number after (double) x in direction of +* (double) y +* +* See also: Apple Numerics Manual, pg 50 +* +**************************************************************** +* + +s_nextdouble start + using sane_tmp + csub (10:ext_x,10:ext_y) + +* Convert extended parameters to double + phptr ext_x + ph4 #dbl_x + fx2d + sterr + phptr ext_y + ph4 #dbl_y + fx2d + sterr +* Now invoke nextafter function + ph4 #dbl_y + ph4 #dbl_x + fnextd + sterr +* Convert result back to extended + ph4 #dbl_x + ph4 #ext_tmp + fd2x + sterr + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_nextextended (extended x, extended y); +* +* Return next extended number after x in direction of y +* +* See also: Apple Numerics Manual, pg 50 +* +**************************************************************** +* + +s_nextextended start + using sane_tmp + csub (10:ext_x,10:ext_y) + + phptr ext_y + phptr ext_x + fnextx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_log2 (extended x); +* +* Compute base-2 logarithm of x +* +* See also: Apple Numerics Manual, pg 62 +* +**************************************************************** +* + +s_log2 start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + flog2x + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_log (extended x); +* +* Compute natural (base-e) logarithm of x +* +* See also: Apple Numerics Manual, pg 62 +* +**************************************************************** +* + +s_log start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + flnx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_log1 (extended x); +* +* Compute natural (base-e) logarithm of (1+x) +* +* See also: Apple Numerics Manual, pg 62 +* +**************************************************************** +* + +s_log1 start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fln1x + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_exp2 (extended x); +* +* Compute base-2 exponential of x +* +* See also: Apple Numerics Manual, pg 63f. +* +**************************************************************** +* + +s_exp2 start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fexp2x + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_exp (extended x); +* +* Compute natural (base-e) exponential of x +* +* See also: Apple Numerics Manual, pg 63f. +* +**************************************************************** +* + +s_exp start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fexpx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_exp1 (extended x); +* +* Compute the base-e exponential minus 1 (exp(x)-1) +* +* See also: Apple Numerics Manual, pg 63f. +* +**************************************************************** +* + +s_exp1 start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fexp1x + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_power (extended x, extended y); +* +* Compute the general exponential x^y +* +* See also: Apple Numerics Manual, pg 63f. +* +**************************************************************** +* + +s_power start + using sane_tmp + csub (10:ext_x,10:ext_y) + + phptr ext_y + phptr ext_x + fxpwry + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_ipower (extended x, short i); +* +* Compute the integer exponential x^i +* +* See also: Apple Numerics Manual, pg 63f. +* +**************************************************************** +* + +s_ipower start + using sane_tmp + csub (10:ext_x,2:i) + + ph2 i + phptr ext_x + fxpwri + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_compound (extended r, extended n); +* +* Compute compound (1+r)^n, where r is interest rate and n is +* periods (may be non-integral) +* +* See also: Apple Numerics Manual, pg 64f. +* +**************************************************************** +* + +s_compound start + using sane_tmp + csub (10:ext_r,10:ext_n) + + phptr ext_r + phptr ext_n + ph4 #ext_tmp + fcompound + sterr + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_annuity (extended r, extended n); +* +* Compute annuity (1-(1+r)^n)/r, where r is interest rate and +* n is periods (may be non-integral) +* +* See also: Apple Numerics Manual, pg 65 +* +**************************************************************** +* + +s_annuity start + using sane_tmp + csub (10:ext_r,10:ext_n) + + phptr ext_r + phptr ext_n + ph4 #ext_tmp + fannuity + sterr + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_tan (extended x); +* +* Compute the tangent of x +* +* See also: Apple Numerics Manual, pg 66f. +* +**************************************************************** +* + +s_tan start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + ftanx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_sin (extended x); +* +* Compute the sine of x +* +* See also: Apple Numerics Manual, pg 66f. +* +**************************************************************** +* + +s_sin start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fsinx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_cos (extended x); +* +* Compute the cosine of x +* +* See also: Apple Numerics Manual, pg 66f. +* +**************************************************************** +* + +s_cos start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fcosx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_atan (extended x); +* +* Compute the arctangent of x +* +* See also: Apple Numerics Manual, pg 66f. +* +**************************************************************** +* + +s_atan start + using sane_tmp + csub (10:ext_x) + + phptr ext_x + fatanx + sterr + copyx ext_x,ext_tmp + + ret 10:ext_tmp + end + +**************************************************************** +* +* extended s_randomx (extended *x); +* +* Return next pseudo-random number and update integral x +* +* See also: Apple Numerics Manual, pg 67 +* +**************************************************************** +* + +s_randomx start + using sane_tmp + csub (4:ext_p) + + ph4 ext_p + frandx + sterr + + ret 4:ext_p + end + +**************************************************************** +* +* numclass s_classfloat (extended x); +* +* Return classification of (float) x +* +* See also: Apple Numerics Manual, pg 44 +* +**************************************************************** +* + +s_classfloat start +res equ 1 +space equ res+2 + using sane_tmp + csub (10:ext_x),space + +* Convert parameter to float + phptr ext_x + ph4 #sgl_x + fx2s + sterr +* Call class function + ph4 #sgl_x + fclasss + sterr +* Store result + short i ; set high byte to 0 + long i + txa +* Convert to C return values + cmp #FCSNAN ; Signaling NaN + bne lab1 + lda #$0000 + bra bye +lab1 cmp #FCQNAN ; Quiet NaN + bne lab2 + lda #$0001 + bra bye +lab2 cmp #FCINF ; Infinity + bne lab3 + lda #$0002 + bra bye +lab3 cmp #FCZERO ; Zero + bne lab4 + lda #$0003 + bra bye +lab4 cmp #FCNORM ; Normalized + bne lab5 + lda #$0004 + bra bye +lab5 cmp #FCDENORM ; Denormalized + bne err + lda #$0005 + bra bye +err lda #$FFFF ; Unknown return code, return -1 +bye sta res + + ret 2:res + end + +**************************************************************** +* +* numclass s_classdouble (extended x); +* +* Return classification of (double) x +* +* See also: Apple Numerics Manual, pg 44 +* +**************************************************************** +* + +s_classdouble start +res equ 1 +space equ res+2 + using sane_tmp + csub (10:ext_x),space + +* Convert parameter to double + phptr ext_x + ph4 #dbl_x + fx2d + sterr +* Call class function + ph4 #dbl_x + fclassd + sterr +* Store result + short i ; set high byte to 0 + long i + txa +* Convert to C return values + cmp #FCSNAN ; Signaling NaN + bne lab1 + lda #$0000 + bra bye +lab1 cmp #FCQNAN ; Quiet NaN + bne lab2 + lda #$0001 + bra bye +lab2 cmp #FCINF ; Infinity + bne lab3 + lda #$0002 + bra bye +lab3 cmp #FCZERO ; Zero + bne lab4 + lda #$0003 + bra bye +lab4 cmp #FCNORM ; Normalized + bne lab5 + lda #$0004 + bra bye +lab5 cmp #FCDENORM ; Denormalized + bne err + lda #$0005 + bra bye +err lda #$FFFF ; Unknown return code, return -1 +bye sta res + + ret 2:res + end + +**************************************************************** +* +* numclass s_classcomp (extended x); +* +* Return classification of (comp) x +* +* See also: Apple Numerics Manual, pg 44 +* +**************************************************************** +* + +s_classcomp start +res equ 1 +space equ res+2 + using sane_tmp + csub (10:ext_x),space + +* Convert parameter to comp + phptr ext_x + ph4 #cmp_x + fx2c + sterr +* Call class function + ph4 #cmp_x + fclassc + sterr +* Store result + short i ; set high byte to 0 + long i + txa +* Convert to C return values + cmp #FCSNAN ; Signaling NaN + bne lab1 + lda #$0000 + bra bye +lab1 cmp #FCQNAN ; Quiet NaN + bne lab2 + lda #$0001 + bra bye +lab2 cmp #FCINF ; Infinity + bne lab3 + lda #$0002 + bra bye +lab3 cmp #FCZERO ; Zero + bne lab4 + lda #$0003 + bra bye +lab4 cmp #FCNORM ; Normalized + bne lab5 + lda #$0004 + bra bye +lab5 cmp #FCDENORM ; Denormalized + bne err + lda #$0005 + bra bye +err lda #$FFFF ; Unknown return code, return -1 +bye sta res + + ret 2:res + end + +**************************************************************** +* +* numclass s_classextended (extended x); +* +* Return classification of x +* +* See also: Apple Numerics Manual, pg 44 +* +**************************************************************** +* + +s_classextended start +res equ 1 +space equ res+2 + + csub (10:ext_x),space + + phptr ext_x + fclassx + sterr +* Store result + short i ; set high byte to 0 + long i + txa +* Convert to C return values + cmp #FCSNAN ; Signaling NaN + bne lab1 + lda #$0000 + bra bye +lab1 cmp #FCQNAN ; Quiet NaN + bne lab2 + lda #$0001 + bra bye +lab2 cmp #FCINF ; Infinity + bne lab3 + lda #$0002 + bra bye +lab3 cmp #FCZERO ; Zero + bne lab4 + lda #$0003 + bra bye +lab4 cmp #FCNORM ; Normalized + bne lab5 + lda #$0004 + bra bye +lab5 cmp #FCDENORM ; Denormalized + bne err + lda #$0005 + bra bye +err lda #$FFFF ; Unknown return code, return -1 +bye sta res + + ret 2:res + end + +**************************************************************** +* +* long s_signnum (extended x); +* +* Return sign of x, 0 if positive and 1 if negative +* +* See also: Apple Numerics Manual, pg 44 +* +**************************************************************** +* + +s_signnum start +res equ 1 +space equ res+4 + + csub (10:ext_x),space + lda ext_x+8 get sign bit + bmi lab1 + stz res + bra lab2 +lab1 lda #1 + sta res + +lab2 stz res+2 + ret 4:res + end + +* This, the original implementation of s_signnum, had to be +* discarded because of a bug in SANE fclassx. Rather than fix +* fclassx, s_signnum was rewritten. +* +*s_signnum start +*res equ 1 +*space equ res+4 +* +* csub (10:ext_x),space +* +* phptr ext_x +* fclassx +* sterr +* Store result +* bpl plus +* lda #1 +* sta res +* bra lab1 +*plus stz res +* +*lab1 stz res+2 +* ret 4:res +* end + +**************************************************************** +* +* void s_setexception (exception e, long b); +* +* Clears SANE exceptions according to flags in e if b is 0, sets +* these exceptions otherwise; may cause halt +* +* See also: Apple Numerics Manual, pg 54ff +* +**************************************************************** +* + +s_setexception start + csub (2:e,4:b) + +* As e is passed, the exceptions are in 0-4. + lda e +* Just to be extra-cautious, clear all bits but 0-4 + and #%0000000000011111 + sta e +* Now check whether to set or clear flags + lda b + ora b+2 ; if b == 0 + bne lab1 ; clear flags, don't set them + lda e + xba ; flags need to be in high word + eor #$FFFF ; reverse contents of e + sta e + fgetenv + sterr + txa + and e ; clear bits indicated by e + pha + fsetenv + sterr + bra lab2 +lab1 lda e ; set flags + pha + fsetxcp + sterr + +lab2 ret + end + +**************************************************************** +* +* long s_testexception (exception e); +* +* Return true if any SANE exception indicated by flags in e is +* set, return false otherwise +* +* See also: Apple Numerics Manual, pg 54ff +* +**************************************************************** +* + +s_testexception start +res equ 1 +space equ res+4 + + csub (2:e),space + +* As e is passed, the exceptions are in 0-4. + lda e +* Just to be extra-cautious, clear all bits but 0-4 + and #%0000000000011111 + sta e + + ph2 e + ftestxcp + beq lab1 ; No exceptions set -> lab1 + sterr + lda #1 + sta res + bra lab2 +lab1 sterr + stz res +lab2 stz res+2 + + ret 4:res + end + +**************************************************************** +* +* void s_sethalt (exception e, long b); +* +* Clears SANE exception halts according to flags in e if b is 0, +* sets these halts otherwise +* +* See also: Apple Numerics Manual, pg 54ff +* +**************************************************************** +* + +s_sethalt start + csub (2:e,4:b) + +* Just to be extra-cautious, clear all bits in e that +* don't refer to halts: Everything but bits 0-4 + lda e + and #%0000000000011111 + sta e +* Now check whether to set or clear flags + lda b + ora b+2 ; if b == 0 + bne lab1 ; clear flags, don't set them + lda e + eor #$FFFF ; reverse contents of e + sta e + fgetenv + sterr + txa + and e ; clear bits indicated by e + pha + fsetenv + sterr + bra lab2 +lab1 fgetenv ; set bits indicated by e + sterr + txa + ora e + pha + fsetenv + sterr + +lab2 ret + end + +**************************************************************** +* +* long s_testhalt (exception e); +* +* Return true if any SANE exception halt indicated by flags in e +* is set, return false otherwise +* +* See also: Apple Numerics Manual, pg 54ff +* +**************************************************************** +* + +s_testhalt start +res equ 1 +space equ res+4 + + csub (2:e),space + +* Just to be extra-cautious, clear all bits in e that +* don't refer to halts: Everything but bits 0-4 + lda e + and #%0000000000011111 + sta e + + fgetenv + sterr + txa + and e + beq lab1 ; No halts set -> lab1 + lda #1 + sta res + bra lab2 +lab1 stz res +lab2 stz res+2 + + ret 4:res + end + +**************************************************************** +* +* void s_setround (rounddir r); +* +* Set rounding direction to r +* +* See also: Apple Numerics Manual, pg 52f +* +**************************************************************** +* + +s_setround start + csub (2:r) + +* Shift r into bits 14/15 + lda r ; Bits 0/1 + xba ; 8/9 + asl a ; 9/10 + asl a ; 10/11 + asl a ; 11/12 + asl a ; 12/13 + asl a ; 13/14 + asl a ; 14/15, done + sta r + + fgetenv + sterr + txa + and #%0011111111111111 ; Clear bits 14/15 + ora r ; Set them according to r + pha + fsetenv + sterr + + ret + end + +**************************************************************** +* +* rounddir s_getround (void); +* +* Get rounding direction +* +* See also: Apple Numerics Manual, pg 52f +* +**************************************************************** +* + +s_getround start +res equ 1 +space equ res+2 + + csub ,space + + fgetenv + sterr + txa + and #%1100000000000000 ; Clear everything but bits 14/15 + xba ; Put into 6/7 + lsr a ; 5/6 + lsr a ; 4/5 + lsr a ; 3/4 + lsr a ; 2/3 + lsr a ; 1/2 + lsr a ; 0/1, done + sta res + + ret 2:res + end + +**************************************************************** +* +* void s_setprecision (roundpre p); +* +* Set rounding precision to p +* +* See also: Apple Numerics Manual, pg 53 +* +**************************************************************** +* + +s_setprecision start + csub (2:p) + +* Shift p into bits 6/7 + lda p ; Bits 0/1 + asl a ; 1/2 + asl a ; 2/3 + asl a ; 3/4 + asl a ; 4/5 + asl a ; 5/6 + asl a ; 6/7, done + sta p + + fgetenv + sterr + txa + and #%1111111100111111 ; Clear bits 6/7 + ora p ; Set them according to p + pha + fsetenv + sterr + + ret + end + +**************************************************************** +* +* roundpre s_getprecision (void); +* +* Get rounding precision +* +* See also: Apple Numerics Manual, pg 53 +* +**************************************************************** +* + +s_getprecision start +res equ 1 +space equ res+2 + + csub ,space + + fgetenv + sterr + txa + and #%0000000011000000 ; Clear everything but bits 6/7 + lsr a ; 5/6 + lsr a ; 4/5 + lsr a ; 3/4 + lsr a ; 2/3 + lsr a ; 1/2 + lsr a ; 0/1, done + sta res + + ret 2:res + end + +**************************************************************** +* +* void s_setenvironment (environment e); +* +* Set SANE environment word to e +* +* See also: Apple Numerics Manual, pg 57 +* +**************************************************************** +* + +s_setenvironment start + csub (2:e) + + ph2 e + fsetenv + sterr + + ret + end + +**************************************************************** +* +* void s_getenvironment (environment *e); +* +* Get SANE environment word and store it in e +* +* See also: Apple Numerics Manual, pg 57 +* +**************************************************************** +* + +s_getenvironment start + csub (4:eptr) + + fgetenv + sterr + txa + sta [eptr] + + ret + end + +**************************************************************** +* +* void s_procentry (environment *e); +* +* Get SANE environment word and store it in e, set SANE +* environment word to IEEE default (all zero) +* +* See also: Apple Numerics Manual, pg 57 +* +**************************************************************** +* + +s_procentry start + csub (4:eptr) + + ph4 eptr + fprocentry + sterr + + ret + end + +**************************************************************** +* +* void s_procexit (environment e); +* +* Store current exceptions, set SANE environment word to e, +* signal stored exceptions. +* +* See also: Apple Numerics Manual, pg 57 +* +**************************************************************** +* + +s_procexit start + csub (2:e) + + ph2 e + fprocexit + sterr + + ret + end + +**************************************************************** +* +* haltvector s_gethaltvector (void); +* +* Return SANE halt vector +* +* See also: Apple Numerics Manual, pg 54 +* +**************************************************************** +* + +s_gethaltvector start +res equ 1 +space equ res+4 + + csub ,space + + fgethv + sterr + stx res ; low portion of pointer + tya ; Y contains bytes 2 and 3 + xba ; put 3 into low position in A + and #$00FF ; and discard 2 + sta res+2 + + ret 4:res + end + +**************************************************************** +* +* void s_sethaltvector (haltvector v); +* +* Set SANE halt vector to v +* +* See also: Apple Numerics Manual, pg 54 +* +**************************************************************** +* + +s_sethaltvector start + csub (4:v) + + ph4 v + fsethv + sterr + + ret + end + +**************************************************************** +* +* relop s_relation (extended x, extended y); +* +* Compare x and y, return their relation so that "x Relation y" +* is true +* +* See also: Apple Numerics Manual, pg 49 +* +**************************************************************** +* + +s_relation start +res equ 1 +space equ res+2 + + csub (10:ext_x,10:ext_y),space + + phptr ext_x + phptr ext_y + fcmpx + sterr + short i + txa + cmp #$0040 ; x > y + bne lab1 + lda #$0000 + bra bye +lab1 cmp #$0080 ; x < y + bne lab2 + lda #$0001 + bra bye +lab2 cmp #$0002 ; x == y + beq bye + cmp #$0001 ; x unordered y + bne err + lda #$0003 + bra bye +err lda #$FFFF ; Unknown return code, return -1 +bye sta res + long i + + ret 2:res + end + +**************************************************************** +* +* extended s_nan (unsigned char c); +* +* Return a NaN with code c +* +**************************************************************** +* + +s_nan start + + csub (2:c) + + lda c + bne lab1 + lda #$15 +lab1 short m + sta nan_x+6 + long m + + ret 10:nan_x + +nan_x dc h'0000000000000040FF7F' ; Hex encoding of a NaN + end + +**************************************************************** +* +* extended s_inf (void); +* +* Return +INF +* +**************************************************************** +* + +s_inf start + + csub + + ret 10:inf_x + +inf_x dc h'0000000000000000FF7F' ; Hex encoding of +INF + end + +**************************************************************** +* +* extended s_pi (void); +* +* Return pi constant, which is stored as 3.1415926535897932385 +* +**************************************************************** +* + +s_pi start + + csub + + ret 10:pi_x + +pi_x dc h'35C26821A2DA0FC90040' ; Hex encoding of pi + end + +**************************************************************** +* +* Common data area for glue code +* +**************************************************************** +* + +sane_tmp privdata +ext_tmp dc e'0' ; Temporary result variable +sgl_x dc f'0' ; Float parameter 1 +sgl_y dc f'0' ; Float parameter 2 +dbl_x dc d'0' ; Double parameter 1 +dbl_y dc d'0' ; Double parameter 2 +cmp_x dc d'0' ; Comp parameter 1 + end + +* End Of File diff --git a/lib/lsaneglue/saneglue.macro b/lib/lsaneglue/saneglue.macro new file mode 100644 index 0000000..8e8890d --- /dev/null +++ b/lib/lsaneglue/saneglue.macro @@ -0,0 +1,55 @@ +* +* Macros for SANE glue code in saneglue.asm +* +* Written in 1997 by Soenke Behrens. +* This code is hereby placed into the Public Domain. +* + +* +* phptr - push a pointer to a variable on the DP +* of a function as DP+offset: Pointer is valid +* even if DP is changed. +* + + macro +&lab phptr &n1 +&lab pea $0 + tdc + clc + adc #&n1 + pha + mend + +* +* copyx - copy an 'extended' variable to another +* + + macro +&lab copyx &n1,&n2 +&lab lda &n1 + sta &n2 + lda &n1+2 + sta &n2+2 + lda &n1+4 + sta &n2+4 + lda &n1+6 + sta &n2+6 + lda &n1+8 + sta &n2+8 + mend + +* +* sterr - store returned error code in _toolErr +* Must be used _immediately_ after tool call because +* it relies on carry flag being set and A containing +* the error code (if any). +* + + macro +&lab sterr +&lab bcs ~&SYSCNT + lda #0 +~&SYSCNT sta _toolErr + mend + +* End Of File diff --git a/lib/lsaneglue/sanetest.c b/lib/lsaneglue/sanetest.c new file mode 100644 index 0000000..0336bdc --- /dev/null +++ b/lib/lsaneglue/sanetest.c @@ -0,0 +1,597 @@ +/* + * Test SANE glue code from saneglue.asm + * NB: The purpose of this code is _not_ to perform rigorous + * testing of the numerical correctness of SANE. That is + * taken for a given. The sole purpose is to test the SANE + * glue code (and, by extension, SANE patches such as fpcp). + * + * Does not test gethaltvector/sethaltvector (yet). + * + * Written in 1997 by Soenke Behrens. + * This code is hereby placed into the Public Domain. + */ + +#include +#include +#include +#include + +#pragma lint -1 + +#include "sane.h" + +#pragma optimize 0x0048 /* Catch errors in parameter passing */ + +void a_function(void); + +int main (void) +{ + short i,j; + DecForm convert; + Decimal d; + extended x,y,z; + static char s[258]; + rounddir r; + roundpre rp; + environment e1, e2, e3; + haltvector hv1, hv2; + + /* + * Test whether we start with IEEE default environment set + */ + + s_getenvironment(&e2); + if (e2 != IEEEDEFAULTENV) + printf("SANE environment does not match default environment: %#.4x.\n",e2); + + /* + * Test fabs + */ + + x = s_fabs(-3.275); + if (x != 3.275) + printf("s_fabs() test failed.\n"); + else + printf("s_fabs() test successful.\n"); + + /* + * Test fneg + */ + + x = s_fneg(3.275); + if (x != -3.275) + printf("s_fneg() test failed.\n"); + else + printf("s_fneg() test successful.\n"); + + /* + * Test num2dec and dec2num + */ + convert.style = FLOATDECIMAL; + convert.digits = 8; + s_num2dec(&convert,3.1415926,&d); + if (d.sgn != 0 || d.exp != -7 || + strncmp(d.sig.text,"31415926",d.sig.length) != 0) + printf("s_num2dec() test failed.\n"); + else + printf("s_num2dec() test successful.\n"); + x = s_dec2num(&d); + + if (fabs(x - 3.1415926) < 1E-15) + printf("s_dec2num() test successful.\n"); + else + printf("s_dec2num() test failed.\n"); + + /* + * Test dec2str and str2dec + */ + convert.style = FLOATDECIMAL; + convert.digits = 8; + s_num2dec(&convert,2.7182818,&d); + s_dec2str(&convert,&d,s); + if (strcmp(s," 2.7182818e+0") != 0) + printf("s_dec2str() test failed.\n"); + else + printf("s_dec2str() test successful.\n"); + + i = 1; + s_str2dec(s,&i,&d,&j); + if (j != 1) + { + fprintf (stderr,"s_str2dec() rejected input string.\n"); + exit (EXIT_FAILURE); + } + x = s_dec2num (&d); + + if (fabs(x - 2.7182818) < 1E-15) + printf("s_str2dec() test successful.\n"); + else + printf("s_str2dec() test failed.\n"); + + /* + * Test remainder + */ + z = s_remainder (3.1415926,2.7182818,&i); + if (fabs(z - 0.4233108) < 1E-15) + printf("s_remainder() test successful.\n"); + else + printf("s_remainder() test failed.\n"); + + /* + * Test sqrt + */ + + z = s_sqrt (2.0); + if (fabs(z - 1.414213562373095048763788073) < 1E-15) + printf("s_sqrt() test successful.\n"); + else + printf("s_sqrt() test failed.\n"); + + /* + * Test rint + */ + + z = s_rint (3.1415926); + if (z == 3.0) + printf("s_rint() test successful.\n"); + else + printf("s_rint() test failed.\n"); + + /* + * Test scalb + */ + + z = s_scalb (2,1.4142136); + if (fabs(z - 5.6568544) < 1E-15) + printf("s_scalb() test successful.\n"); + else + printf("s_scalb() test failed.\n"); + + /* + * Test logb + */ + + z = s_logb (1.234e308); + if (z == 1023.0) + printf("s_logb() test successful.\n"); + else + printf("s_logb() test failed.\n"); + + /* + * Test copysign + */ + + z = s_copysign(1.234,-5.678); + if (z == 5.678) + printf("s_copysign() test successful.\n"); + else + printf("s_copysign() test failed.\n"); + + /* + * Test nextfloat + */ + + z = s_nextfloat(1.0,1.1); + if (z == 1.00000011920928955078125) + printf("s_nextfloat() test successful.\n"); + else + printf("s_nextfloat() test failed.\n"); + + /* + * Test nextdouble + */ + + z = s_nextdouble(1.0,1.1); + if (z == 1.000000000000000222044604925) + printf("s_nextdouble() test successful.\n"); + else + printf("s_nextdouble() test failed.\n"); + + /* + * Test nextextended + */ + + z = s_nextextended(1.0,1.1); + /* I only have double constants, so testing this is a bit tricky */ + if (fabs(z - 1.000000000000000000108420217) < 1E-15) + printf("s_nextextended() test successful.\n"); + else + printf("s_nextextended() test failed.\n"); + + /* + * Test log2 + */ + + z = s_log2(1.1); + if (fabs(z - 0.1375035237499350248218483658) < 1E-15) + printf("s_log2() test successful.\n"); + else + printf("s_log2() test failed.\n"); + + /* + * Test log + */ + + z = s_log(1.1); + if (fabs(z - 0.09531017980432494078943525193) < 1E-15) + printf("s_log() test successful.\n"); + else + printf("s_log() test failed.\n"); + + /* + * Test log1 + */ + + z = s_log1(1.1); + if (fabs(z - 0.7419373447293773548238092486) < 1E-15) + printf("s_log1() test successful.\n"); + else + printf("s_log1() test failed.\n"); + + /* + * Test exp2 + */ + + z = s_exp2(1.1); + if (fabs(z - 2.143546925072586460409712616) < 1E-15) + printf("s_exp2() test successful.\n"); + else + printf("s_exp2() test failed.\n"); + + /* + * Test exp + */ + + z = s_exp(1.1); + if (fabs(z - 3.004166023946433378968498551) < 1E-15) + printf("s_exp() test successful.\n"); + else + printf("s_exp() test failed.\n"); + + /* + * Test exp1 + */ + + z = s_exp1(1.1); + if (fabs(z - 2.004166023946433378968498551) < 1E-15) + printf("s_exp1() test successful.\n"); + else + printf("s_exp1() test failed.\n"); + + /* + * Test power + */ + + z = s_power(1.1,2.2); + if (fabs(z - 1.233286300554662750887657818) < 1E-15) + printf("s_power() test successful.\n"); + else + printf("s_power() test failed.\n"); + + /* + * Test ipower + */ + + z = s_ipower(1.12345,2); + if (fabs(z - 1.26213990250000013411922628) < 1E-15) + printf("s_ipower() test successful.\n"); + else + printf("s_ipower() test failed.\n"); + + /* + * Test compound + */ + + z = s_compound(0.12,2.3); + if (fabs(z - 1.297781121042242946086661681) < 1E-15) + printf("s_compound() test successful.\n"); + else + printf("s_compound() test failed.\n"); + + /* + * Test annuity + */ + + z = s_annuity(0.12,2.3); + if (fabs(z - 1.91211699860898026910333708) < 1E-15) + printf("s_annuity() test successful.\n"); + else + printf("s_annuity() test failed.\n"); + + /* + * Test tan + */ + + z = s_tan(1.1); + if (fabs(z - 1.96475965724865238239311982) < 1E-15) + printf("s_tan() test successful.\n"); + else + printf("s_tan() test failed.\n"); + + /* + * Test sin + */ + + z = s_sin(1.1); + if (fabs(z - 0.8912073600614353802488142031) < 1E-15) + printf("s_sin() test successful.\n"); + else + printf("s_sin() test failed.\n"); + + /* + * Test cos + */ + + z = s_cos(1.1); + if (fabs(z - 0.4535961214255773086276909284) < 1E-15) + printf("s_cos() test successful.\n"); + else + printf("s_cos() test failed.\n"); + + /* + * Test atan + */ + + z = s_atan(1.1); + if (fabs(z - 0.8329812666744317456186258442) < 1E-15) + printf("s_atan() test successful.\n"); + else + printf("s_atan() test failed.\n"); + + /* + * Test randomx + */ + + x = 1.0; + z = s_randomx(&x); + if (z == 16807.0) + printf("s_randomx() test successful.\n"); + else + printf("s_randomx() test failed.\n"); + + /* + * Test classfloat + */ + + i = s_classfloat(-0.0); + if (i == 0x03) + printf("s_classfloat() test successful.\n"); + else + printf("s_classfloat() test failed.\n"); + + /* + * Test classdouble + */ + + i = s_classdouble(-0.0); + if (i == 0x03) + printf("s_classdouble() test successful.\n"); + else + printf("s_classdouble() test failed.\n"); + + /* + * Test classcomp + */ + + i = s_classcomp(-0.0); + if (i == 0x03) + printf("s_classcomp() test successful.\n"); + else + printf("s_classcomp() test failed.\n"); + + /* + * Test classextended + */ + + i = s_classextended(-0.0); + if (i == 0x03) + printf("s_classextended() test successful.\n"); + else + printf("s_classextended() test failed.\n"); + + /* + * Test signnum + */ + + if (s_signnum(-123.45) == 1 && s_signnum(123.45) == 0) + printf("s_signnum() test successful.\n"); + else + printf("s_signnum() test failed.\n"); + + /* + * Test relation + */ + + i = s_relation(1.23,s_nan(2)); + if (i == UNORDERED) + printf("s_relation() test successful.\n"); + else + printf("s_relation() test failed.\n"); + + /* + * For the following tests, clear all exceptions the previous + * tests might have generated. + */ + s_setenvironment(IEEEDEFAULTENV); + + /* + * Test setexception and testexception + */ + + s_setexception(OVERFLOW | INEXACT, 1); + if (s_testexception(INEXACT) && s_testexception(OVERFLOW)) + printf("s_setexception() and s_testexception() tests successful.\n"); + else + printf("s_setexception() and s_testexception() tests failed.\n"); + /* Clear exceptions again */ + s_setexception(OVERFLOW | INEXACT, 0); + + /* + * Test sethalt and testhalt + */ + + s_sethalt(OVERFLOW | INEXACT, 1); + if (s_testhalt(INEXACT) && s_testhalt(OVERFLOW)) + printf("s_sethalt() and s_testhalt() tests successful.\n"); + else + printf("s_sethalt() and s_testhalt() tests failed.\n"); + /* Clear halts again */ + s_sethalt(OVERFLOW | INEXACT, 0); + + /* + * Test setround and getround + */ + + if ((r = s_getround()) != TONEAREST) + { + printf("Rounding direction is not default TONEAREST as required by SANE:\n"); + switch (r) + { + case TONEAREST: + printf("Program error, please investigate.\n"); + break; + case UPWARD: + printf("Rounding direction is UPWARD.\n"); + break; + case DOWNWARD: + printf("Rounding direction is DOWNWARD.\n"); + break; + case TOWARDZERO: + printf("Rounding direction is TOWARDZERO.\n"); + break; + default: + printf("Undefined rounding direction: %d\n",r); + break; + } + } + s_setround(TOWARDZERO); + if (s_getround() == TOWARDZERO) + printf("s_setround() and s_getround() tests successful.\n"); + else + printf("s_setround() and s_getround() tests failed.\n"); + /* Set back to earlier value */ + s_setround(r); + + /* + * Test setprecision and getprecision + */ + if ((rp = s_getprecision()) != EXTPRECISION) + { + printf("Rounding precision is not default \"extended\" as required by SANE:\n"); + switch (rp) + { + case EXTPRECISION: + printf("Program error, please investigate.\n"); + break; + case DBLPRECISION: + printf("Rounding precision is \"double\".\n"); + break; + case FLOATPRECISION: + printf("Rounding precision is \"single\".\n"); + break; + default: + printf("Undefined rounding precision: %d\n",r); + break; + } + } + s_setprecision(FLOATPRECISION); + if (s_getprecision() == FLOATPRECISION) + printf("s_setprecision() and s_getprecision() tests successful.\n"); + else + printf("s_setprecision() and s_getprecision() tests failed.\n"); + /* Set back to earlier value */ + s_setprecision(rp); + + /* + * Test setenvironment and getenvironment + */ + + s_getenvironment(&e2); + if (e2 != IEEEDEFAULTENV) + printf("SANE environment does not match default environment: %#.4x.\n",e2); + s_setenvironment(0x0A0A); /* nonsense value */ + s_getenvironment(&e1); + if (e1 == 0x0A0A) + printf("s_setenvironment() and s_getenvironment() tests successful.\n"); + else + printf("s_setenvironment() and s_getenvironment() tests failed.\n"); + /* Now restore the original environment word */ + s_setenvironment(e2); + + /* + * Test procentry and procexit + */ + + s_getenvironment(&e3); + s_setenvironment(0x0A0A); /* nonsense value */ + s_procentry(&e2); + s_getenvironment(&e1); + if (e1 == IEEEDEFAULTENV) + printf("s_procentry() test successful.\n"); + else + printf("s_procentry test failed.\n"); + s_procexit(e2); + s_getenvironment(&e1); + if (e1 == 0x0A0A) + printf("s_procexit() test successful.\n"); + else + printf("s_procexit() test failed.\n"); + /* Set environment back to what it was */ + s_setenvironment(e3); + + /* + * Test sethaltvector and gethaltvector + */ + + hv1 = s_gethaltvector(); + s_sethaltvector(a_function); + hv2 = s_gethaltvector(); + if (hv2 == a_function) + printf("s_sethaltvector() and s_gethaltvector() tests successful.\n"); + else + printf("s_sethaltvector() and s_gethaltvector() tests failed.\n"); + /* Now restore original vector */ + s_sethaltvector(hv1); + + /* + * Test pi + */ + + z = s_pi(); + if (fabs(z - 3.141592653589793238512808959) < 1E-15) + printf("s_pi() test successful.\n"); + else + printf("s_pi() test failed.\n"); + + /* + * Test nan + */ + + z = s_nan(5); + sprintf(s,"%f",z); + if (strcmp(s,"NAN(005)") == 0) + printf("s_nan() test successful.\n"); + else + printf("s_nan() test failed.\n"); + + /* + * Test inf + */ + + z = s_inf(); + sprintf(s,"%f",z); + if (strcmp(s,"INF") == 0) + printf("s_inf() test successful.\n"); + else + printf("s_inf() test failed.\n"); + + return (0); +} + +void a_function(void) +{ + printf("Halt occured.\n"); + return; +} + +/* End Of File */