Apple-2gs-SW
/
ORCALib
mirror of https://github.com/byteworksinc/ORCALib.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

Compare commits

base: Apple-2gs-SW:gno-orcalib-220b6
Branches Tags
Apple-2gs-SW:master
Apple-2gs-SW:gno-version
Apple-2gs-SW:gno-orcalib-220
Apple-2gs-SW:orcalib-220
Apple-2gs-SW:orcalib-220b7
Apple-2gs-SW:gno-orcalib-220b7
Apple-2gs-SW:orcalib-220b6
Apple-2gs-SW:gno-orcalib-220b6
Apple-2gs-SW:gno-orcalib-220b5
Apple-2gs-SW:orcalib-220b5
Apple-2gs-SW:gno-orcalib-220b4
Apple-2gs-SW:orcalib-220b4
Apple-2gs-SW:orcalib-220b3
...
compare: Apple-2gs-SW:master
Branches Tags
Apple-2gs-SW:master
Apple-2gs-SW:gno-version
Apple-2gs-SW:gno-orcalib-220
Apple-2gs-SW:orcalib-220
Apple-2gs-SW:orcalib-220b7
Apple-2gs-SW:gno-orcalib-220b7
Apple-2gs-SW:orcalib-220b6
Apple-2gs-SW:gno-orcalib-220b6
Apple-2gs-SW:gno-orcalib-220b5
Apple-2gs-SW:orcalib-220b5
Apple-2gs-SW:gno-orcalib-220b4
Apple-2gs-SW:orcalib-220b4
Apple-2gs-SW:orcalib-220b3

62 Commits
gno-orcali ... master

Author SHA1 Message Date
Stephen Heumann 5b04986f08 Add tool glue code for ReadMouse2. 
This is documented in TBR3 and is already declared in <misctool.h>, but did not previously have glue code. TBR3 says "Applications should never make this call," but it may be useful in system utilities.
 2024-04-17 19:57:23 -05:00
Stephen Heumann d9e26d4467 Small optimizations related to 8/16-bit register switching. 2024-03-22 21:10:33 -05:00
Stephen Heumann 0e519e1e58 Small optimizations in memset and memcpy. 2024-02-29 17:16:47 -06:00
Stephen Heumann 49ffb1065b Unroll the core loop of strlen one time. 
This makes the core loop about 10% faster at the cost of 5 extra code bytes, which seems like a reasonable tradeoff.
 2024-02-26 22:14:59 -06:00
Stephen Heumann 9181b0bd73 fclose: Free the file buffer earlier. 
This moves the free() call for the file buffer before the malloc() that occurs when closing a temp file, which should at least slightly reduce the chances that the malloc() call fails.
 2024-02-20 22:22:26 -06:00
Stephen Heumann 7384c82667 fclose: Check for malloc failure when closing temp files. 
Previously, the code for closing a temporary file assumed that malloc would succeed. If it did not, the code would trash memory and (at least in my testing) crash the system. Now it checks for and handles malloc failures, although they will still lead to the temporary file not being deleted.

Here is a test program illustrating the problem:

#include <stdio.h>
#include <stdlib.h>

int main(void) {
        FILE *f = tmpfile();
        if (!f)
                return 0;

        void *p;
        do {
                p = malloc(8*1024);
        } while (p);

        fclose(f);
}
 2024-02-20 22:20:17 -06:00
Stephen Heumann 16c7952648 fclose: close stream even if there is an error flushing buffered data. 
This can happen, e.g., if there is an IO error or if there is insufficient free disk space to flush the data. In this case, fclose should return -1 to report an error, but it should still effectively close the stream and deallocate the buffer for it. (This behavior is explicitly specified in the C99 and later standards.)

Previously, ORCA/C effectively left the stream open in these cases. As a result, the buffer was not deallocated. More importantly, this could cause the program to hang at exit, because the stream would never be removed from the list of open files.

Here is an example program that demonstrates the problem:

/*
 * Run this on a volume with less than 1MB of free space, e.g. a floppy.
 * The fclose return value should be -1 (EOF), indicating an error, but
 * the two RealFreeMem values should be close to each other (indicating
 * that the buffer was freed), and the program should not hang on exit.
 */

#include <stdio.h>
#include <stddef.h>
#include <memory.h>

#define BUFFER_SIZE 1000000

int main(void) {
        size_t i;
        int ret;

        printf("At start, RealFreeMem = %lu\n", RealFreeMem());

        FILE *f = fopen("testfile", "wb");
        if (!f)
                return 0;

        setvbuf(f, NULL, _IOFBF, BUFFER_SIZE);

        for (i = 0; i < BUFFER_SIZE; i++) {
                putc('x', f);
        }

        ret = fclose(f);
        printf("fclose return value = %d\n", ret);

        printf("At end, RealFreeMem = %lu (should be close to start value)\n",
                RealFreeMem());
}
 2024-02-19 22:30:15 -06:00
Stephen Heumann 9d42552756 strncmp: Fix issues related to very large n values. 
This fixes the following issues:
*If n was 0x80000000 or greater, strncmp would return 0 without performing a comparison.
*If n was 0x1000000 or greater, strncmp might compare fewer characters than it should because the high byte of n was effectively ignored, causing it to return 0 when it should not.

Here is an example demonstrating these issues:

#pragma memorymodel 1
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#define LEN 100000
int main(void) {
        char *s1 = malloc(LEN+1);
        char *s2 = malloc(LEN+1);
        if (!s1 || !s2)
                return 0;
        for (unsigned long i = 0; i < LEN; i++) {
                s2[i] = s1[i] = '0' + (i & 0x07);
        }
        s1[LEN] = 'x';
        return strncmp(s1,s2,0xFFFFFFFF);
}
 2024-02-19 22:12:26 -06:00
Stephen Heumann bbfad1e299 strncat: fix more issues related to large n values. 
This addresses the following issues:
*If the low-order 16 bits of n were 0x0000, no concatenation would be performed.
*If n was 0x1000000 or greater, the output could be cut off prematurely because the high byte of n was effectively ignored.

The following test program demonstrates these issues:

#pragma memorymodel 1
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#define LEN2 100000
int main(void) {
        char *s1 = malloc(LEN2+2);
        char *s2 = malloc(LEN2+1);
        if (!s1 || !s2)
                return 0;
        for (unsigned long i = 0; i < LEN2; i++)
                s2[i] = '0' + (i & 0x07);
        strcpy(s1,"a");
        strncat(s1, s2, 0x1000000);
        puts(s1);
        printf("len = %zu\n", strlen(s1));
}
 2024-02-19 22:01:53 -06:00
Stephen Heumann f1582be5a2 Fix handling of large strings in strncat. 
There were two issues:
*If bit 15 of the n value was set, the second string would not be copied.
*If the length of the second string was 64K or more, it would not be copied properly because the pointers were not updated.

This test program demonstrates both issues:

#pragma memorymodel 1
#include <stdlib.h>
#include <string.h>
#include <stdio.h>
#define LEN2 100000
int main(void) {
        char *s1 = malloc(LEN2+2);
        char *s2 = malloc(LEN2+1);
        if (!s1 || !s2)
                return 0;
        for (unsigned long i = 0; i < LEN2; i++)
                s2[i] = '0' + (i & 0x07);
        strcpy(s1,"a");
        strncat(s1, s2, LEN2);
        puts(s1);
        printf("len = %zu\n", strlen(s1));
}
 2024-02-18 21:53:03 -06:00
Stephen Heumann b60c307ee6 Make strcat and strncat work properly when first string crosses a bank boundary. 
Previously, the pointer was not properly updated to account for the bank crossing, so the characters from the second string would be written to the wrong bank.

Here is an example that illustrates this:

#include <memory.h>
#include <string.h>
#include <orca.h>
#include <stdio.h>
int main(void) {
        Handle hndl = NewHandle(0x1000f, userid(), 0xC000, 0);
        if (toolerror())
                return 0;
        char *s = *hndl;
        s = (void*)((unsigned long)s | 0xffff);
        strcpy(s, "foo");
        strcat(s, "bar");
        strncat(s, "baz", 5);
        puts(s);
}
 2024-02-18 21:01:01 -06:00
Stephen Heumann bf3a4d7ceb Small optimizations in library code. 
There should be no functional differences.
 2024-02-18 17:35:21 -06:00
Stephen Heumann ce87c0e008 Add script to set filetypes. 2023-08-06 17:48:41 -05:00
Stephen Heumann 3f70daed7d Remove floating-point code from ORCALib. 
It is being moved to SysFloat.
 2023-06-23 15:52:46 -05:00
Stephen Heumann a81a9964c2 Change several JMP instructions to BRL. 
This avoids the need for run-time relocation and makes executables smaller.
 2023-06-19 18:05:46 -05:00
Stephen Heumann a5504be621 scanf: skip remaining directives after encountering EOF. 
Encountering EOF is an input failure, which terminates scanf processing. Thus, remaining directives (even %n) should not be processed.
 2023-06-11 16:07:19 -05:00
Stephen Heumann 6bc1c3741c scanf: Do not test for EOF at the beginning of scanf processing. 
If the format string is empty or contains only %n conversions, then nothing should be read from the stream, so no error should be indicated even if it is at EOF. If a directive does read from the stream and encounter EOF, that will be handled when the directive is processed.

This could cause scanf to pause waiting for input from the console in cases where it should not.
 2023-06-11 16:05:12 -05:00
Stephen Heumann 614af65c68 printf: print inf/nan rather than INF/NAN when using f and a formats. 
This works in conjunction with SysFloat commit e409ecd4717, and at least that version of SysFloat is now required.
 2023-06-01 20:10:12 -05:00
Stephen Heumann b21a51ba33 Optimize lgamma. 
This includes adjustments that make it a little faster for most input values, but especially for |x| < 7. The impact on accuracy should be minimal.
 2023-05-22 18:05:15 -05:00
Stephen Heumann 97a295522c Implement lgamma (C99). 
This uses an approximation based on the Stirling series for most positive values, but uses separate rational approximations for greater accuracy near 1 and 2. A reflection formula is used for negative values.
 2023-05-21 18:24:01 -05:00
Stephen Heumann afff478793 More small size optimizations for (f)printf. 2023-04-18 22:27:49 -05:00
Stephen Heumann 78a9e1d93b printf: Unify code for hex and octal formatting. 
These are similar enough that they can use the same code with just a few conditionals, which saves space.

(This same code can also be used for binary when that is added.)
 2023-04-17 21:52:26 -05:00
Stephen Heumann 67ae5f7b44 printf: optimize hex and octal printing code. 
This also fixes a bug: printf("%#.0o\n", 0) should print "0", rather than nothing.
 2023-04-17 19:36:45 -05:00
Stephen Heumann 80c0bbc32b Small size optimizations in printf code. 2023-04-16 22:14:15 -05:00
Stephen Heumann 34f78fb1f2 printf: add support for 'a'/'A' conversion specifiers (C99). 
These print a floating-point number in a hexadecimal format, with several variations based on the conversion specification:

Upper or lower case letters (%A or %a)
Number of digits after decimal point (precision)
Use + sign for positive numbers? (+ flag)
Use leading space for positive numbers (space flag)
Include decimal point when there are no more digits? (# flag)
Pad with leading zeros after 0x? (0 flag)

If no precision is given, enough digits are printed to represent the value exactly. Otherwise, the value is correctly rounded based on the rounding mode.
 2023-04-16 20:23:53 -05:00
Stephen Heumann 578e544174 Update comments about printf. 2023-04-16 15:41:00 -05:00
Stephen Heumann b7b4182cd2 printf: ignore '0' flag if '-' is also used. 
This is what the standards require. Previously, the '0' flag would effectively override '-'.

Here is a program that demonstrates the problem:

#include <stdio.h>
int main(void) {
        printf("|%-020d|\n", 123);
        printf("|%0-20d|\n", 123);
        printf("|%0*d|\n", -20, 123);
}
 2023-04-16 15:39:49 -05:00
Stephen Heumann bdfed3628d Fix fma to support large memory model. 
It was not using long addressing where needed, so it could store results in the wrong bank.
 2023-04-06 14:34:40 -05:00
Stephen Heumann 2f2d3d2056 Save a few bytes in floating-to-long long conversion code. 2023-04-04 18:06:21 -05:00
Stephen Heumann cd6131abab Small optimization of strto* functions. 2023-04-03 20:16:22 -05:00
Stephen Heumann fca8c1ef85 Save a few bytes in printf and scanf. 2023-04-03 13:26:37 -05:00
Stephen Heumann de978dab48 Use more efficient code to return values from various math functions. 2023-04-02 16:33:24 -05:00
Stephen Heumann 68fc475721 Implement fma(). 
This tries to carefully follow the C and IEEE standards regarding rounding, exceptions, etc. Like the other ORCA/C <math.h> functions, there is really just one version that has extended precision, so double rounding is still possible if the result gets assigned to a float or double variable.

In addition to the tests I added to the ORCA/C test suite, I have also tested this against (somewhat modified versions of) the following:

*FreeBSD fma tests by David Schultz:
https://github.com/freebsd/freebsd-src/blob/release/9.3.0/tools/regression/lib/msun/test-fma.c

*Tests by Bruno Haible, in the Gnulib test suite and attached to this bug report:
https://sourceware.org/bugzilla/show_bug.cgi?id=13304
 2023-04-02 16:30:29 -05:00
Stephen Heumann 3c1f357b0c Save a few bytes in the startup code. 2023-03-28 21:38:55 -05:00
Stephen Heumann a4ba2403fe Call atexit functions with correct data bank in large memory model 
Previously, the functions registered with atexit() would be called with data bank corresponding to the blank segment, which is correct in the small memory model but not necessarily in the large memory model. This could cause memory corruption or misbehavior for certain operations accessing global variables.
 2023-03-28 18:52:14 -05:00
Stephen Heumann 48371dc669 tmpnam: allow slightly longer temp directory name 
ORCA/C's tmpnam() implementation is designed to use prefix 3 if it is defined and the path is sufficiently short. I think it was intended to allow up to a 15-character disk name to be specified, but it used a GS/OS result buffer size of 16, which only leaves 12 characters for the path, including initial and terminal : characters. As such, only up to a 10-character disk name could be used. This patch increases the specified buffer size to 21, allowing for a 17-character path that can encompass a 15-character disk name.
 2023-03-08 18:59:10 -06:00
Stephen Heumann b03e462125 bsearch: return NULL without calling compare function if count==0. 
This is explicitly required in C99 and later.
 2023-02-17 20:31:55 -06:00
Stephen Heumann b3f028da2f Avoid address comparison error in qsort. 
If the last element in the range being sorted has the smallest value, rsort can be called with last set to first-1, i.e. pointing to (what would be) the element before the first one. But with large enough element sizes and appropriate address values, this address computation can wrap around and produce a negative value for last. We need to treat such a value as being less than first, so it terminates that branch of the recursive computation. Previously, we were doing an unsigned comparison, so such a last value would be treated as greater than first and would lead to improper behavior including memory trashing.

Here is an example program that can show this (depending on memory layout):

#pragma memorymodel 1
#include <stdlib.h>
#include <stdio.h>

#define PADSIZE 2000000 /* may need to adjust based on memory size/layout */
#define N 2

struct big {
        int i;
        char pad[PADSIZE];
};

int cmp(const void *p1, const void *p2) {
        int a = ((struct big *)p1)->i;
        int b = ((struct big *)p2)->i;

        return (a < b) ? -1 : (a > b);
}

int main(void) {
        int j;
        struct big *p = malloc(sizeof(struct big) * N);
        if (!p)
                return 0;

        for (j = 0; j < N; j++) {
                p[j].i = N-j;
        }

        qsort(p, N, sizeof(struct big), cmp);

        for (j = 0; j < N; j++) {
                printf("%i\n", p[j].i);
        }
}
 2023-02-16 18:45:03 -06:00
Stephen Heumann 2540b28ca3 Avoid excessively deep recursion in qsort. 
It could have O(n) recursion depth for some inputs (e.g. if already sorted or reverse sorted), which could easily cause stack overflows.

Now, recursion is only used for the smaller of the two subarrays at each step, so the maximum recursion depth is bounded to log2(n).
 2023-02-15 22:04:10 -06:00
Stephen Heumann 3417a98d10 Use proper data bank when calling comparison function in qsort. 
When using the large memory model, the wrong data bank (that of the library code rather than the program's static data) would be in place when the comparison function was called, potentially leading to data corruption or other incorrect behavior.
 2023-02-15 18:46:46 -06:00
Stephen Heumann 60d49c7dc3 Fix qsort code for swapping elements with a size of 64KiB or more. 
This code did not previously work properly, because the X register value was overwritten within the loop. This could result in incorrect behavior such as hanging or data corruption when using qsort with element sizes >= 64KiB.
 2023-02-14 18:43:40 -06:00
Stephen Heumann 74de206058 Add library function for null pointer checking. 
This is used by the new ORCA/C debugging option to check for illegal use of null pointers. It is similar to an existing routine in PasLib used by ORCA/Pascal's similar checks.
 2023-02-12 18:57:56 -06:00
Stephen Heumann 3551644355 Fix stack handling in localtime. 
This was broken by commit 882af9e075.
 2023-01-05 20:00:44 -06:00
Stephen Heumann 506b070439 Rename CVars to ~CVars to avoid namespace pollution. 2023-01-02 18:41:45 -06:00
Stephen Heumann 69765a96ef Use a variable to control use of Time Tool. 
This ensures use of the Time Tool is fully under the control of the programmer, rather than potentially being affected by other things that may load it (like the Time Zone CDev). It also avoids calls to tiStatus in the default non-Time Tool code paths, and thereby allows them to work under Golden Gate.
 2023-01-02 18:01:28 -06:00
Stephen Heumann c4d485e960 Implement timespec_get (C11). 
This follows gmtime in using the Time Tool to get UTC time if it is active, but otherwise just using local time.
 2023-01-01 21:33:00 -06:00
Stephen Heumann 44c3078ab3 mktime: force struct tm components to their normal ranges. 
This is done by calling ~gmlocaltime after computing the time_t value in mktime.
 2022-12-31 22:06:25 -06:00
Stephen Heumann 7e4f067c35 Compute tm_yday and tm_wday directly in ~gmlocaltime. 
This avoids calling mktime (future versions of which may call ~gmlocaltime), and also deals correctly with time zones.
 2022-12-31 19:10:36 -06:00
Stephen Heumann 882af9e075 Make gmlocaltime take a parameter for the struct tm to use. 
This will be needed for gmtime_r/localtime_r, but also is a step toward using this code to normalize the struct tm values for mktime.
 2022-12-30 18:46:51 -06:00
Stephen Heumann 3b0c1c2149 Fix gmtime() handling of times very near the limits of time_t. 
The UTC time may be several hours before or after local time, and therefore the UTC time/date may be slightly outside the limits of what can be represented as a local time/date. This is now handled correctly.

This also more generally fixes handling of negative seconds/minutes/hours, which is also applicable to mktime().
 2022-12-30 17:28:16 -06:00
Stephen Heumann 32c5fd94a1 Handle out-of-range months in mktime() input. 2022-12-29 23:54:10 -06:00
Stephen Heumann f15caf8096 Make gmtime/localtime properly support times near the limits of the time_t range. 
They did not properly handle times in 1969 or 2105 (for the latter, they would infinite-loop).
 2022-12-29 23:18:48 -06:00
Stephen Heumann b302a85fd6 Switch time "factor" code over to 0-based month indexing. 
This matches both struct tm and ReadTimeHex, so it avoids needing to increment the values.

Also, simplify the time() code a little bit.
 2022-12-29 22:53:37 -06:00
Stephen Heumann 17faeda1de Rework time "factor" routine to work for the full 32-bit time range. 
ORCA/C uses an unsigned 32-bit time_t which should give a range up to 2105, but calculations on it were being done with signed types, causing them not to work correctly beyond 2036-2038. Now the factor routine, mktime(), and time() should work up to 2105. (In the case of time(), this assumes ReadTimeHex reports the time correctly.)

The factor routine actually computes a 64-bit time value. Currently, the rest of the code only takes the bottom 32 bits of it, but this could be extended if we ever wanted to switch to 64-bit time_t.
 2022-12-29 22:31:31 -06:00
Stephen Heumann d30ee1a2e5 Adjust comments in time.asm to reflect actual starting date of time_t. 
It was clearly supposed to be 1 Jan 1970, but it's actually not, probably because the number of days from 1 Jan 1900 to 1 Jan 1970 was miscalculated. Changing it now could potentially cause compatibility issues (especially for GNO, which uses time_t in some kernel call interfaces and file formats), so for now it is left as is and just documented appropriately.

Nothing in the C standards requires the time_t epoch to be 1 Jan 1970, so this does not cause any standards-compliance problem for the C standards. (It is different from POSIX, though.)
 2022-12-29 14:25:24 -06:00
Stephen Heumann e2de990f4d strftime: use Time Tool Set to get time zone offset. 
This is used for the %z conversion specifier (giving the time zone offset in +-HHMM format). The %Z conversion specifier (giving the locale's time zone name or abbreviation) also prints the same thing for now.

As with gmtime, this will only use the Time Tool Set if it has already been started. Otherwise, these conversions simply produce no output.
 2022-12-28 19:55:48 -06:00
Stephen Heumann 4019e9f370 gmtime: support time zone adjustment with Time Tool Set. 
If the Time Tool Set (tool 56, by Geoff Weiss) is present and active, gmtime will use it (plus the DST flag) to determine the local time offset from UTC, allowing it to produce the correct UTC time. If not, it will still treat local time as being equal to UTC, like it did previously.

The library code will not try to load or start the Time Tool Set, so the program will have to do that before calling gmtime if it wants to use this functionality.
 2022-12-28 19:46:49 -06:00
Stephen Heumann 89664d2921 Slightly improve tgamma calculation for x < 8. 
Previously, 1-4 low-order bits of the input value were essentially ignored when calculating the numerator, but used to some degree when calculating the denominator. This would lead to the calculated tgamma values decreasing slightly over the range of several consecutive input values (when they should increase). Now, the low-order bits of the input value are effectively just rounded away. This should give slightly more accurate results, and greatly reduces the frequency of cases where consecutive output values go in the wrong direction.
 2022-12-24 21:59:52 -06:00
Stephen Heumann 5985e7d774 Implement tgamma (c99). 
This uses an approximation based on the Stirling series for large enough x (for which it is highly accurate). For smaller x, identities are used to express gamma(x) in terms of gamma(x+1) or gamma(1-x), ultimately letting the Stirling series approximation be used.
 2022-12-24 20:20:40 -06:00
Stephen Heumann 88e764f72d Implement the erf and erfc functions (C99). 
This implementation is based on the approximations given in the following paper:

W. J. Cody, Rational Chebyshev Approximations for the Error Function, Mathematics of Computation, Vol. 23, No. 107 (Jul., 1969), pp. 631-637.

Per the paper, the approximations have maximal relative error of 6e-19 or lower (although I have not verified what the figure is for this actual implementation).

See also Cody's FORTRAN implementation based on the same approach:

https://netlib.org/specfun/erf
 2022-12-17 22:25:53 -06:00
Stephen Heumann 73ed0778f2 Add cleanup code for CDev calls. 
The new CDev root code generated by ORCA/C will now branch to this code after each CDev call, giving it an opportunity to clean up if necessary. Specifically, it will dispose of the user ID allocated for the CDev if it is going away after this call. There are several cases where this occurs, which need to be detected based on the message code passed to the CDev and in some cases other factors.
 2022-12-12 18:01:28 -06:00
Stephen Heumann b81b4e1109 Fix several bugs in fgets() and gets(). 
Bugs fixes:
*fgets() would write 2 bytes in the buffer if called with n=1 (should be 1).
*fgets() would write 2 bytes in the buffer if it encountered EOF before reading any characters, but the EOF flag had not previously been set. (It should not modify the buffer in this case.)
*fgets() and gets() would return NULL if EOF was encountered after reading one or more characters. (They should return the buffer pointer).
 2022-10-15 19:01:16 -05:00
22 changed files with 1143 additions and 5144 deletions
Show Stats Expand all files Collapse all files

105
cc.asm
View File

@ -187,6 +187,7 @@ TAB equ 9 TAB key code
stz ~QuickExitList
stz ~QuickExitList+2
case on
stz __useTimeTool do not use Time Tool
jsl ~InitIO reset standard I/O
case off
@ -243,8 +244,6 @@ lb6 long M
phy
sec
adc 1,S
ply
pha
pha
pea 0
pha
@ -264,20 +263,19 @@ lb7 pl4 argv get the pointer to the area
lda [argv]
sta targv
stx targv+2
clc get a pointer to the command line string
adc start
; clc (already clear)
adc start get a pointer to the command line string
bcc lb8
inx
lb8 sta argv
stx argv+2
short M move the command line string
ldy #0
lb9 lda [cLine],Y
ldy #-1
lb9 iny
lda [cLine],Y
sta [argv],Y
beq lb10
iny
bra lb9
lb10 long M
bne lb9
long M
move4 argv,cLine save the pointer
move4 targv,argv set up the pointer to argv
@ -363,6 +361,9 @@ start ds 2 start of the command line string
stz ~ExitList+2
stz ~QuickExitList
stz ~QuickExitList+2
case on
stz __useTimeTool do not use Time Tool
case off
lda #~RTL set up so exit(), etc. call ~RTL
sta ~C_Quit+1
@ -375,6 +376,78 @@ start ds 2 start of the command line string
targv ds 4
end
****************************************************************
*
* ~CDevCleanup - cleanup code run after a CDev call
*
* Inputs:
* A+X - CDev result value
* 1,S - Original data bank to restore
* 2,S - Return address
* 5,S - Message code passed to CDev
* 7,S - Old user ID from before the call (0 if none)
*
* Notes:
* This routine handles cases where the CDev is going
* away and so the user ID allocated for it needs to be
* disposed of to avoid being leaked.
*
****************************************************************
*
~CDevCleanup start
MachineCDEV equ 1
BootCDEV equ 2
CloseCDEV equ 5
AboutCDEV equ 8
tay stash low word of result
lda 5,s if message == CloseCDEV
cmp #CloseCDEV
beq cleanup
cmp #BootCDEV or message == BootCDEV
beq cleanup
cmp #AboutCDEV or message == AboutCDEV
bne lb1
lda 7,s and original user ID was 0
beq cleanup (i.e. CDev window was not open)
bra ret
lb1 cmp #MachineCDEV or message == MachineCDEV
bne ret
tya and return value is 0
bne ret
txa
bne ret
cleanup pea 0 ...then dispose of user ID
jsl >~DAID
ret tya store return value in result space
sta 5,s
txa
sta 7,s
plb restore data bank
rtl return to original caller
end
****************************************************************
*
* ~CheckPtrC - check a pointer to insure it is not null
*
* Inputs:
* 1,S - return address
* 4,S - pointer
*
****************************************************************
*
~CheckPtrC start
lda 4,S
ora 5,S
bne lb1
error #1 subrange exceeded
lb1 rtl
end
****************************************************************
*
* ~CUMul2 - unsigned multiply
@ -446,10 +519,7 @@ ptr equ 3 pointer to exit routines
;
; Set up our stack frame
;
phb
phk
plb
ph4 ~ExitList set up our stack frame
ph4 >~ExitList set up our stack frame
phd
tsc
tcd
@ -498,7 +568,6 @@ lb3 lda >stderr+6 while there is a next file
lb4 pld return
pla
pla
plb
rts
end
@ -516,10 +585,7 @@ ptr equ 3 pointer to exit routines
;
; Set up our stack frame
;
phb
phk
plb
ph4 ~QuickExitList set up our stack frame
ph4 >~QuickExitList set up our stack frame
phd
tsc
tcd
@ -556,7 +622,6 @@ lb2 ldy #2 dereference the pointer
lb3 pld return
pla
pla
plb
rts
end

369
fenv.asm
View File

@ -1,369 +0,0 @@
keep obj/fenv
mcopy fenv.macros
case on
****************************************************************
*
* Fenv - Floating-point environment access
*
* This code provides routines to query and modify the
* floating-point environment.
*
* Note: This relies on and only works with SANE.
*
****************************************************************
*
fenv private dummy segment
end
FE_ALL_EXCEPT gequ $001F
****************************************************************
*
* int feclearexcept(int excepts);
*
* Clear floating-point exceptions
*
* Inputs:
* excepts - floating-point exceptions to clear
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
*
feclearexcept start
csubroutine (2:excepts),0
FGETENV get current environment
phx
lda excepts
and #FE_ALL_EXCEPT
eor #$FFFF mask off excepts to clear
xba
and 1,S
sta 1,S
FSETENV clear them
stz excepts
creturn 2:excepts
end
****************************************************************
*
* int fegetexceptflag(fexcept_t *flagp, int excepts);
*
* Get floating-point exception flags.
*
* Inputs:
* flagp - pointer to location to store exception flags
* excepts - floating-point exceptions to get
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
*
fegetexceptflag start
csubroutine (4:flagp,2:excepts),0
FGETENV get current environment
tya
and excepts get desired exceptions
and #FE_ALL_EXCEPT
sta [flagp] store them in *flagp
stz excepts
creturn 2:excepts
end
****************************************************************
*
* int feraiseexcept(int excepts);
*
* Raise floating-point exceptions
*
* Inputs:
* excepts - floating-point exceptions to raise
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
*
feraiseexcept start
csubroutine (2:excepts),0
lda excepts
and #FE_ALL_EXCEPT
beq done
pha
FSETXCP raise exceptions
done stz excepts
creturn 2:excepts
end
****************************************************************
*
* int fesetexceptflag(fexcept_t *flagp, int excepts);
*
* Set (but do not raise) floating-point exception flags
*
* Inputs:
* flagp - pointer to stored exception flags
* excepts - floating-point exceptions to set
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
fesetexceptflag start
csubroutine (4:flagp,2:excepts),0
FGETENV get env with excepts masked off
phx
lda excepts
and #FE_ALL_EXCEPT
eor #$FFFF
xba
and 1,S
sta 1,S
lda [flagp] set new exceptions
and excepts
and #FE_ALL_EXCEPT
xba
ora 1,S
sta 1,S
FSETENV
stz excepts
creturn 2:excepts
end
****************************************************************
*
* int fetestexcept(int excepts);
*
* Test if floating-point exception flags are set
*
* Inputs:
* excepts - floating-point exceptions to test for
*
* Outputs:
* Bitwise or of exceptions that are set
*
****************************************************************
*
fetestexcept start
csubroutine (2:excepts),0
FGETENV get exception flags
tya
and excepts mask to just the ones we want
and #FE_ALL_EXCEPT
sta excepts
creturn 2:excepts
end
****************************************************************
*
* int fegetround(void);
*
* Get the current rounding direction
*
* Outputs:
* The current rounding direction
*
****************************************************************
*
fegetround start
FGETENV get high word of environment
tya
and #$00C0 just rounding direction
rtl
end
****************************************************************
*
* int fesetround(int round);
*
* Set the current rounding direction
*
* Inputs:
* round - the rounding direction to set
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
*
fesetround start
csubroutine (2:round),0
lda round flip words
xba
sta round
and #$3FFF do nothing if not a valid rounding dir
bne done
FGETENV set the rounding direction
txa
and #$3FFF
ora round
pha
FSETENV
stz round
done creturn 2:round
end
****************************************************************
*
* int fegetenv(fenv_t *envp);
*
* Get the current floating-point environment
*
* Inputs:
* envp - pointer to location to store environment
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
*
fegetenv start
csubroutine (4:envp),0
FGETENV get the environment
txa
sta [envp] store it in *envp
stz envp
creturn 2:envp
end
****************************************************************
*
* int feholdexcept(fenv_t *envp);
*
* Get environment, then clear status flags and disable halts
*
* Inputs:
* envp - pointer to location to store environment
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
*
feholdexcept start
csubroutine (4:envp),0
FGETENV get the environment
txa
sta [envp] store it in *envp
and #$E0E0 clear exception flags and disable halts
pha
FSETENV set the new environment
stz envp
creturn 2:envp
end
****************************************************************
*
* int fesetenv(const fenv_t *envp);
*
* Set the floating-point environment
*
* Inputs:
* envp - pointer to environment to set
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
*
fesetenv start
csubroutine (4:envp),0
lda [envp] set the environment
pha
FSETENV
stz envp
creturn 2:envp
end
****************************************************************
*
* int feupdateenv(const fenv_t *envp);
*
* Save exceptions, set environment, then re-raise exceptions
*
* Inputs:
* envp - pointer to environment to set
*
* Outputs:
* Returns 0 if successful, non-zero otherwise
*
****************************************************************
*
feupdateenv start
csubroutine (4:envp),0
lda [envp] set the environment
pha
FPROCEXIT
stz envp
creturn 2:envp
end
****************************************************************
*
* Default floating-point environment
*
****************************************************************
*
__FE_DFL_ENV start
dc i2'0'
end
****************************************************************
*
* int __get_flt_rounds(void);
*
* Get the value of FLT_ROUNDS, accounting for rounding mode
*
* Outputs:
* Current value of FLT_ROUNDS
*
****************************************************************
*
__get_flt_rounds start
FGETENV
tya get rounding direction in low bits of A
asl a
asl a
xba
inc a convert to values used by FLT_ROUNDS
and #$0003
rtl
end

117
fenv.macros
View File

@ -1,117 +0,0 @@
MACRO
&lab csubroutine &parms,&work
&lab anop
aif c:&work,.a
lclc &work
&work setc 0
.a
gbla &totallen
gbla &worklen
&worklen seta &work
&totallen seta 0
aif c:&parms=0,.e
lclc &len
lclc &p
lcla &i
&i seta 1
.b
&p setc &parms(&i)
&len amid &p,2,1
aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+4+&work
&totallen seta &totallen+&len
&i seta &i+1
aif &i<=c:&parms,^b
.e
tsc
aif &work=0,.f
sec
sbc #&work
tcs
.f
phd
tcd
mend
MACRO
&lab creturn &r
&lab anop
lclc &len
aif c:&r,.a
lclc &r
&r setc 0
&len setc 0
ago .h
.a
&len amid &r,2,1
aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
aif &len<>2,.d
ldy &r
ago .h
.d
aif &len<>4,.e
ldx &r+2
ldy &r
ago .h
.e
aif &len<>10,.g
ldy #&r
ldx #^&r
ago .h
.g
mnote 'Not a valid return length',16
mexit
.h
aif &totallen=0,.i
lda &worklen+2
sta &worklen+&totallen+2
lda &worklen+1
sta &worklen+&totallen+1
.i
pld
tsc
clc
adc #&worklen+&totallen
tcs
aif &len=0,.j
tya
.j
rtl
mend
MACRO
&LAB FGETENV
&LAB PEA $03
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSETENV
&LAB PEA $01
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSETXCP
&LAB PEA $15
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FPROCEXIT
&LAB PEA $19
LDX #$090A
JSL $E10000
MEND

116
fpextra.asm
View File

@ -1,116 +0,0 @@
keep obj/fpextra
mcopy fpextra.macros
****************************************************************
*
* FPextra - extra floating-point routines
*
* This code provides routines dealing with floating-point
* numbers that are used only by ORCA/C, supplementing the
* ones in SysFloat.
*
****************************************************************
*
fpextra private dummy segment
end
****************************************************************
*
* ~SinglePrecision - limit fp value to single precision & range
*
* Inputs:
* extended-format real on stack
*
****************************************************************
*
~SinglePrecision start
tsc
clc
adc #4
ldy #0
phy
pha
phy
pha
phy
pha
phy
pha
FX2S
FS2X
rtl
end
****************************************************************
*
* ~DoublePrecision - limit fp value to double precision & range
*
* Inputs:
* extended-format real on stack
*
****************************************************************
*
~DoublePrecision start
tsc
clc
adc #4
ldy #0
phy
pha
phy
pha
phy
pha
phy
pha
FX2D
FD2X
rtl
end
****************************************************************
*
* ~CompPrecision - limit fp value to comp precision & range
*
* Inputs:
* extended-format real on stack
*
* Note: This avoids calling FX2C on negative numbers,
* because it is buggy for certain values.
*
****************************************************************
*
~CompPrecision start
tsc round to integer
clc
adc #4
pea 0
pha
FRINTX
lda 4+8,s
pha save original sign
asl a force sign to positive
lsr a
sta 6+8,s
tsc limit precision
clc
adc #6
ldy #0
phy
pha
phy
pha
phy
pha
phy
pha
FX2C
FC2X
pla restore original sign
bpl ret
lda 4+8,s
ora #$8000
sta 4+8,s
ret rtl
end

42
fpextra.macros
View File

@ -1,42 +0,0 @@
MACRO
&LAB FX2S
&LAB PEA $0210
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FX2D
&LAB PEA $0110
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FX2C
&LAB PEA $0510
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FC2X
&LAB PEA $050E
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FD2X
&LAB PEA $010E
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FS2X
&LAB PEA $020E
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FRINTX
&LAB PEA $0014
LDX #$090A
JSL $E10000
MEND

269
int64.asm
View File

@ -515,272 +515,3 @@ loop1 asl num1 do the remaining shift
rt0 pld
rtl rtl
end
****************************************************************
*
* ~CnvULongLongReal - convert an unsigned long long integer
* into an extended SANE real
*
* Inputs:
* unsigned long long int on stack
*
* Outputs:
* extended real on stack
*
****************************************************************
*
~CnvULongLongReal start
mantissa equ 4 mantissa (integer and fraction)
exponent equ mantissa+8 biased exponent and sign bit
lda 1,S move return value
pha
lda 4,S
sta 2,S
tsc set up DP
phd
tcd
lda mantissa+2 move 64-bit value to mantissa
sta mantissa
lda mantissa+4
sta mantissa+2
lda mantissa+6
sta mantissa+4
lda mantissa+8
sta mantissa+6
ora mantissa if value is 0 then
ora mantissa+2
ora mantissa+4
beq ret return
lda #63+16383 set initial exponent (2^63) and sign
sta exponent
lda mantissa+6 if number is normalized (i=1) then
bmi ret return
lp1 dec exponent normalize number
asl mantissa
rol mantissa+2
rol mantissa+4
rol mantissa+6
bpl lp1
ret pld
rtl
end
****************************************************************
*
* ~CnvLongLongReal - convert a long long integer into
* an extended SANE real
*
* Inputs:
* signed long long int on stack
*
* Outputs:
* extended real on stack
*
****************************************************************
*
~CnvLongLongReal start
mantissa equ 4 mantissa (integer and fraction)
exponent equ mantissa+8 biased exponent and sign bit
lda 1,S move return value
pha
lda 4,S
sta 2,S
tsc set up DP
phd
tcd
lda mantissa+2 move 64-bit value to mantissa
sta mantissa
lda mantissa+4
sta mantissa+2
lda mantissa+6
sta mantissa+4
lda mantissa+8
sta mantissa+6
ora mantissa if value is 0 then
ora mantissa+2
ora mantissa+4
beq ret return
ldy #0 default sign bit is 0 (positive)
lda mantissa+6 if mantissa is negative then
bpl lb0
negate8 mantissa negate it
ldy #$8000 sign bit is 1 (negative)
lb0 tya set sign
ora #63+16383 set initial exponent (2^63)
sta exponent
lda mantissa+6 if number is normalized (i=1) then
bmi ret return
lp1 dec exponent normalize number
asl mantissa
rol mantissa+2
rol mantissa+4
rol mantissa+6
bpl lp1
ret pld
rtl
end
****************************************************************
*
* ~CnvRealLongLong - convert an extended SANE real into
* a long long integer
*
* Inputs:
* extended real on stack
*
* Outputs:
* signed long long int on stack
*
* Note: This avoids calling FX2C on negative numbers,
* because it is buggy for certain values.
*
****************************************************************
*
~CnvRealLongLong start
tsc
clc
adc #4
pea 0 push src address for fcpxx
pha
pea llmin|-16 push dst address for fcpxx
pea llmin
pea 0 push operand address for ftintx
pha
ftintx round
fcpxx compare with LLONG_MIN
bne convert
lda #$8000 if it is LONG_MIN, use that value
sta 12,s
asl a
sta 10,s
sta 8,s
sta 6,s
bra done otherwise
convert lda 4+8,s
pha save original sign
asl a force sign to positive
lsr a
sta 6+8,s
tsc
clc
adc #6
pea 0 push src address for fx2c
pha
pea 0 push dst address for fx2c
inc a
inc a
pha
fx2c convert
pla if original value was negative
bpl done
sec
lda #0 negate result
sbc 6,s
sta 6,s
lda #0
sbc 6+2,s
sta 6+2,s
lda #0
sbc 6+4,s
sta 6+4,s
lda #0
sbc 6+6,s
sta 6+6,s
done phb move return address
pla
plx
ply
phx
pha
plb
rtl
llmin dc e'-9223372036854775808'
end
****************************************************************
*
* ~CnvRealULongLong - convert an extended SANE real into
* an unsigned long long integer
*
* Inputs:
* extended real on stack
*
* Outputs:
* unsigned long long int on stack
*
****************************************************************
*
~CnvRealULongLong start
pea 0 initially assume val <= LLONG_MAX
tsc
clc
adc #6
pea 0 push src address for fcpxx
pha
pea llbig|-16 push dst address for fcpxx
pea llbig
pea 0 push operand address for ftintx
pha
ftintx round
fcpxx compare with LLONG_MAX+1
bmi convert
lda #1 if val > LLONG_MAX:
sta 1,S save flag to indicate this
tsc
clc
adc #6
pea llbig|-16 push src address for fsubx
pea llbig
pea 0 push dst address for fsubx
pha
fsubx val -= LLONG_MAX+1
convert tsc
clc
adc #6
pea 0 push src address for fx2c
pha
pea 0 push dst address for fx2c
inc a
inc a
pha
fx2c convert val as comp
pla if orig val was > LLONG_MAX:
beq done
lda 12,s
eor #$8000
sta 12,s result += LLONG_MAX+1
done phb move return address
pla
plx
ply
phx
pha
plb
rtl
llbig dc e'9223372036854775808'
end

43
int64.macros
View File

@ -1,23 +1,4 @@
macro
&l negate8 &n1
&l ~setm
sec
ldy #0
tya
sbc &n1
sta &n1
tya
sbc &n1+2
sta &n1+2
tya
sbc &n1+4
sta &n1+4
tya
sbc &n1+6
sta &n1+6
~restm
mend
macro
&l move4 &m1,&m2
lclb &yistwo
&l ~setm
@ -140,27 +121,3 @@
.d
sta 2+&op
mend
MACRO
&LAB FTINTX
&LAB PEA $0016
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FX2C
&LAB PEA $0510
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FCPXX
&LAB PEA $0A
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSUBX
&LAB PEA 2
LDX #$090A
JSL $E10000
MEND

4
make
View File

@ -19,7 +19,7 @@ if {#} == 0
unset exit
end
for i in cc ctype string stdlib time setjmp orca fcntl vars toolglue signal int64 fenv fpextra math2 locale uchar
for i in cc ctype string stdlib time setjmp orca fcntl vars toolglue signal int64 locale uchar
Newer obj/{i}.a {i}.asm
if {Status} != 0
set exit on
@ -40,7 +40,7 @@ delete orcalib
set list vars.a assert.a cc.a setjmp.a ctype.a string.a stdlib.a
set list {list} time.a signal.a toolglue.a orca.a fcntl.a stdio.a int64.a
set list {list} fenv.a fpextra.a math2.a locale.a uchar.a
set list {list} locale.a uchar.a
for i in {list}
echo makelib orcalib +obj/{i}
makelib orcalib +obj/{i}

2905
math2.asm
View File

File diff suppressed because it is too large Load Diff

654
math2.macros
View File

@ -1,654 +0,0 @@
macro
&l ph4 &n1
&l anop
aif "&n1"="*",.f
lclc &c
&c amid &n1,1,1
aif "&c"="#",.d
aif s:longa=1,.a
rep #%00100000
.a
aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
ldy #2
lda (&n1),y
pha
lda (&n1)
pha
ago .e
.b
aif "&c"<>"[",.c
ldy #2
lda &n1,y
pha
lda &n1
pha
ago .e
.c
aif "&c"<>"<",.c1
&n1 amid &n1,2,l:&n1-1
pei &n1+2
pei &n1
ago .e
.c1
lda &n1+2
pha
lda &n1
pha
ago .e
.d
&n1 amid &n1,2,l:&n1-1
pea +(&n1)|-16
pea &n1
ago .f
.e
aif s:longa=1,.f
sep #%00100000
.f
mexit
.g
mnote "Missing closing '}'",16
mend
MACRO
&lab csubroutine &parms,&work
&lab anop
aif c:&work,.a
lclc &work
&work setc 0
.a
gbla &totallen
gbla &worklen
&worklen seta &work
&totallen seta 0
aif c:&parms=0,.e
lclc &len
lclc &p
lcla &i
&i seta 1
.b
&p setc &parms(&i)
&len amid &p,2,1
aif "&len"=":",.c
&len amid &p,1,2
&p amid &p,4,l:&p-3
ago .d
.c
&len amid &p,1,1
&p amid &p,3,l:&p-2
.d
&p equ &totallen+4+&work
&totallen seta &totallen+&len
&i seta &i+1
aif &i<=c:&parms,^b
.e
tsc
aif &work=0,.f
sec
sbc #&work
tcs
.f
phd
tcd
mend
MACRO
&lab creturn &r
&lab anop
lclc &len
aif c:&r,.a
lclc &r
&r setc 0
&len setc 0
ago .h
.a
&len amid &r,2,1
aif "&len"=":",.b
&len amid &r,1,2
&r amid &r,4,l:&r-3
ago .c
.b
&len amid &r,1,1
&r amid &r,3,l:&r-2
.c
aif &len<>2,.d
ldy &r
ago .h
.d
aif &len<>4,.e
ldx &r+2
ldy &r
ago .h
.e
aif &len<>10,.g
ldy #&r
ldx #^&r
ago .h
.g
mnote 'Not a valid return length',16
mexit
.h
aif &totallen=0,.i
lda &worklen+2
sta &worklen+&totallen+2
lda &worklen+1
sta &worklen+&totallen+1
.i
pld
tsc
clc
adc #&worklen+&totallen
tcs
aif &len=0,.j
tya
.j
rtl
mend
macro
&l cmp4 &n1,&n2
lclb &yistwo
&l ~setm
~lda.h &n1
~op.h eor,&n2
bpl ~a&SYSCNT
~lda.h &n2
~op.h cmp,&n1
bra ~b&SYSCNT
~a&SYSCNT ~lda.h &n1
~op.h cmp,&n2
bne ~b&SYSCNT
~lda &n1
~op cmp,&n2
~b&SYSCNT anop
~restm
mend
macro
&l ~lda &op
lclc &c
&c amid "&op",1,1
aif "&c"<>"{",.b
&c amid "&op",l:&op,1
aif "&c"="}",.a
mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l lda &op
mend
macro
&l ~lda.h &op
&l anop
lclc &c
&c amid "&op",1,1
aif "&c"="[",.b
aif "&c"<>"{",.d
&c amid "&op",l:&op,1
aif "&c"="}",.a
mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
aif &yistwo,.c
&yistwo setb 1
ldy #2
.c
&op setc "&op,y"
lda &op
mexit
.d
aif "&c"<>"#",.e
&op amid "&op",2,l:&op-1
&op setc "#^&op"
lda &op
mexit
.e
lda 2+&op
mend
macro
&l ~op &opc,&op
lclc &c
&c amid "&op",1,1
aif "&c"<>"{",.b
&c amid "&op",l:&op,1
aif "&c"="}",.a
mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l &opc &op
mend
macro
&l ~op.h &opc,&op
&l anop
lclc &c
&c amid "&op",1,1
aif "&c"="[",.b
aif "&c"<>"{",.d
&c amid "&op",l:&op,1
aif "&c"="}",.a
mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
aif &yistwo,.c
&yistwo setb 1
ldy #2
.c
&op setc "&op,y"
&opc &op
mexit
.d
aif "&c"<>"#",.e
&op amid "&op",2,l:&op-1
&op setc "#^&op"
&opc &op
mexit
.e
&opc 2+&op
mend
macro
&l ~restm
&l anop
aif (&~la+&~li)=2,.i
sep #32*(.not.&~la)+16*(.not.&~li)
aif &~la,.h
longa off
.h
aif &~li,.i
longi off
.i
mend
macro
&l ~setm
&l anop
aif c:&~la,.b
gblb &~la
gblb &~li
.b
&~la setb s:longa
&~li setb s:longi
aif s:longa.and.s:longi,.a
rep #32*(.not.&~la)+16*(.not.&~li)
longa on
longi on
.a
mend
macro
&l inc4 &a
&l ~setm
inc &a
bne ~&SYSCNT
inc 2+&a
~&SYSCNT ~restm
mend
macro
&l sub4 &m1,&m2,&m3
lclb &yistwo
lclc &c
&l ~setm
aif c:&m3,.a
&c amid "&m2",1,1
aif "&c"<>"#",.a
&c amid "&m1",1,1
aif "&c"="{",.a
aif "&c"="[",.a
&c amid "&m2",2,l:&m2-1
aif &c>=65536,.a
sec
~lda &m1
~op sbc,&m2
~sta &m1
bcs ~&SYSCNT
~op.h dec,&m1
~&SYSCNT anop
ago .c
.a
aif c:&m3,.b
lclc &m3
&m3 setc &m1
.b
sec
~lda &m1
~op sbc,&m2
~sta &m3
~lda.h &m1
~op.h sbc,&m2
~sta.h &m3
.c
~restm
mend
macro
&l ~sta &op
lclc &c
&c amid "&op",1,1
aif "&c"<>"{",.b
&c amid "&op",l:&op,1
aif "&c"="}",.a
mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
&l sta &op
mend
macro
&l ~sta.h &op
&l anop
lclc &c
&c amid "&op",1,1
aif "&c"="[",.b
aif "&c"<>"{",.d
&c amid "&op",l:&op,1
aif "&c"="}",.a
mnote "Missing closing '}'",2
&op setc &op}
.a
&op amid "&op",2,l:&op-2
&op setc (&op)
.b
aif &yistwo,.c
&yistwo setb 1
ldy #2
.c
&op setc "&op,y"
sta &op
mexit
.d
sta 2+&op
mend
macro
&l cmpl &n1,&n2
lclb &yistwo
&l ~setm
~lda.h &n1
~op.h cmp,&n2
bne ~a&SYSCNT
~lda &n1
~op cmp,&n2
~a&SYSCNT anop
~restm
mend
MACRO
&LAB FCLASSS
&LAB PEA $021C
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FCLASSD
&LAB PEA $011C
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FCLASSX
&LAB PEA $001C
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FX2S
&LAB PEA $0210
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FX2D
&LAB PEA $0110
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FCMPX
&LAB PEA $0008
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FEXP2X
&LAB PEA $000A
LDX #$0B0A
JSL $E10000
MEND
MACRO
&LAB FEXP1X
&LAB PEA $000C
LDX #$0B0A
JSL $E10000
MEND
MACRO
&LAB FLN1X
&LAB PEA $0004
LDX #$0B0A
JSL $E10000
MEND
MACRO
&LAB FLOG2X
&LAB PEA $0002
LDX #$0B0A
JSL $E10000
MEND
MACRO
&LAB FLOGBX
&LAB PEA $001A
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FX2I
&LAB PEA $0410
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FTINTX
&LAB PEA $0016
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FRINTX
&LAB PEA $0014
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FXPWRY
&LAB PEA $0012
LDX #$0B0A
JSL $E10000
MEND
MACRO
&LAB FREMX
&LAB PEA $000C
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSCALBX
&LAB PEA $0018
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSUBX
&LAB PEA $0002
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FGETENV
&LAB PEA $03
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSETENV
&LAB PEA $01
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FX2C
&LAB PEA $0510
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FCPXX
&LAB PEA $0A
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FNEXTX
&LAB PEA $001E
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FX2X
&LAB PEA $0010
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FCPXD
&LAB PEA $010A
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FNEXTD
&LAB PEA $011E
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FD2X
&LAB PEA $010E
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FS2X
&LAB PEA $020E
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FNEXTS
&LAB PEA $021E
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FCPXS
&LAB PEA $020A
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FPROCENTRY
&LAB PEA $0017
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FPROCEXIT
&LAB PEA $0019
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FTESTXCP
&LAB PEA $001B
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FADDS
&LAB PEA $0200
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSETXCP
&LAB PEA $0015
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FADDX
&LAB PEA $0000
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FADDI
&LAB PEA $0400
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSUBI
&LAB PEA $0402
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FMULX
&LAB PEA $0004
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FSQRTX
&LAB PEA $0012
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FLNX
&LAB PEA $0000
LDX #$0B0A
JSL $E10000
MEND
MACRO
&lab _SDivide
&lab ldx #$0A0B
jsl $E10000
MEND
MACRO
&LAB FMULI
&LAB PEA $0404
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FDIVI
&LAB PEA $0406
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FDIVX
&LAB PEA $0006
LDX #$090A
JSL $E10000
MEND
MACRO
&LAB FXPWRI
&LAB PEA $0010
LDX #$0B0A
JSL $E10000
MEND

8
orca.asm
View File

@ -53,7 +53,7 @@ lb1 rtl
*
enddesk start
jmp ~ENDDESK
brl ~ENDDESK
end
****************************************************************
@ -64,7 +64,7 @@ enddesk start
*
endgraph start
jmp ~ENDGRAPH
brl ~ENDGRAPH
end
****************************************************************
@ -119,7 +119,7 @@ id dc 8c' ',i1'0'
*
startdesk start
jmp ~STARTDESK
brl ~STARTDESK
end
****************************************************************
@ -130,7 +130,7 @@ startdesk start
*
startgraph start
jmp ~STARTGRAPH
brl ~STARTGRAPH
end
****************************************************************

10
settypes Normal file
View File

@ -0,0 +1,10 @@
filetype -p =.asm src; change -p =.asm asm65816
filetype -p =.macros src; change -p =.macros asm65816
filetype m16.int64 src; change m16.int64 exec
filetype smac src; change smac asm65816
filetype backup src; change backup exec
filetype make src; change make exec
filetype settypes src; change settypes exec
filetype LICENSE txt
filetype README.md txt
filetype obj:README.txt txt

5
signal.asm
View File

@ -107,9 +107,8 @@ lb2 asl A get the signal handler address
tay
lda >subABRT-2,X
bmi lb3 skip if it is SIG_DFL or SIG_IGN
short M set up the call address
sta >jsl+3
long M
xba set up the call address
sta >jsl+2
tya
sta >jsl+1
ph2 <sig call the user signal handler

667
stdio.asm
View File

@ -83,16 +83,13 @@ stdfile equ 7 is this a standard file?
phk
plb
lda #EOF assume we will get an error
sta err
ph4 <stream verify that stream exists
jsl ~VerifyStream
jcs rts
jcs rts_err
ph4 <stream do any pending I/O
jsl fflush
tax
jne rts
sta err initialize err to fflush result
stz stdfile not a standard file
lda stream+2 bypass file disposal if the file is
@ -110,11 +107,10 @@ lb1 inc stdfile
cl0 lla p,stderr+4 find the file record that points to this
ldy #2 one
cl1 lda [p]
ora [p],Y
jeq rts
lda [p],Y
cl1 lda [p],Y
tax
ora [p]
jeq rts_err
lda [p]
cmp stream
bne cl2
@ -128,46 +124,10 @@ cl3 lda [stream] remove stream from the file list
sta [p]
lda [stream],Y
sta [p],Y
cl3a ldy #FILE_flag if the file was opened by tmpfile then
lda [stream],Y
and #_IOTEMPFILE
beq cl3d
ph4 #nameBuffSize p = malloc(nameBuffSize)
jsl malloc grPathname = p
sta p dsPathname = p+2
stx p+2
sta grPathname
stx grPathname+2
clc
adc #2
bcc cl3b
inx
cl3b sta dsPathname
stx dsPathname+2
lda #nameBuffSize p->size = nameBuffSize
sta [p]
ldy #FILE_file clRefnum = grRefnum = stream->_file
lda [stream],Y
beq cl3e
sta grRefnum
GetRefInfoGS gr GetRefInfoGS(gr)
bcs cl3c
lda grRefnum OSClose(cl)
sta clRefNum
OSClose cl
DestroyGS ds DestroyGS(ds)
cl3c ph4 <p free(p)
jsl free
bra cl3e else
cl3d ldy #FILE_file close the file
lda [stream],Y
beq cl3e
sta clRefNum
OSClose cl
cl3e ldy #FILE_flag if the buffer was allocated by fopen then
cl3a ldy #FILE_flag if the buffer was allocated by fopen then
lda [stream],Y
and #_IOMYBUF
beq cl4
beq cl3b
ldy #FILE_base+2 dispose of the file buffer
lda [stream],Y
pha
@ -176,6 +136,47 @@ cl3e ldy #FILE_flag if the buffer was allocated by fopen the
lda [stream],Y
pha
jsl free
cl3b ldy #FILE_flag if the file was opened by tmpfile then
lda [stream],Y
and #_IOTEMPFILE
beq cl3f
ph4 #nameBuffSize p = malloc(nameBuffSize)
jsl malloc
sta p
stx p+2
ora p+2 if p == NULL then
bne cl3c
lda #EOF flag error
sta err
bra cl3f just close the file
cl3c lda p
sta grPathname grPathname = p
stx grPathname+2
clc dsPathname = p+2
adc #2
bcc cl3d
inx
cl3d sta dsPathname
stx dsPathname+2
lda #nameBuffSize p->size = nameBuffSize
sta [p]
ldy #FILE_file clRefnum = grRefnum = stream->_file
lda [stream],Y
beq cl4
sta grRefnum
sta clRefNum
GetRefInfoGS gr GetRefInfoGS(gr)
bcs cl3e
OSClose cl OSClose(cl)
DestroyGS ds DestroyGS(ds)
cl3e ph4 <p free(p)
jsl free
bra cl4 else
cl3f ldy #FILE_file close the file
lda [stream],Y
beq cl4
sta clRefNum
OSClose cl
cl4 lda stdfile if this is not a standard file then
bne cl5
ph4 <stream dispose of the file buffer
@ -189,7 +190,10 @@ cl6 lda [p],Y
dey
cpy #2
bne cl6
cl7 stz err no error found
cl7 bra rts no error found
rts_err lda #EOF
sta err
rts plb
creturn 2:err
@ -688,24 +692,26 @@ disp equ 1 disp in s
ph4 <stream verify that stream exists
jsl ~VerifyStream
bcs err1
ph4 <stream quit with NULL if at EOF
jsl feof
tax
beq lb0
err1 stz s
stz s+2
bra rts
lb0 stz disp no characters processed so far
lda #0
sta [s]
bcs err
stz disp no characters processed so far
dec n leave room for the null terminator
bmi err
beq err
bne lb1
short M n = 1: store null terminator only
lda #0
sta [s]
long M
bra rts
lb1 ph4 <stream get a character
jsl fgetc
tax quit with error if it is an EOF
tax if error or EOF encountered
bpl lb2
lda disp if no characters read, return NULL
beq err
ldy #FILE_flag if error encountered, return NULL
lda [stream],Y
and #_IOERR
beq rts else return s
err stz s
stz s+2
bra rts
@ -1320,11 +1326,10 @@ fprintf start
sta stream+2
phy restore return address/data bank
phx
ldx stream
plb
lda >stream+2 verify that stream exists
pha
lda >stream
pha
pha verify that stream exists
phx
jsl ~VerifyStream
bcc lb1
lda #EIO
@ -2249,9 +2254,15 @@ disp equ 1 disp in s
stz disp no characters processed so far
lb1 jsl getchar get a character
tax quit with error if it is an EOF
tax if error or EOF encountered
bpl lb2
stz s
lda disp if no characters read, return NULL
beq err
ph4 >stdin if error encountered, return NULL
jsl ferror
tax
beq rts else return s
err stz s
stz s+2
bra rts
lb2 cmp #LF quit if it was a \n
@ -3202,9 +3213,8 @@ pr dc i'2' parameter block for OSGet_Prefix
dc i'3'
dc a4'name'
name dc i'16,0' GS/OS name buffer
name dc i'17+4,0' GS/OS name buffer
cname ds 26 part of name; also C buffer
GS_OSname dc i'8' used for OSGet_File_Info
syscxxxx dc c'SYSC0000',i1'0' for creating unique names
GIParm dc i'2' used to see if the file exists
@ -3320,11 +3330,10 @@ vfprintf start
sta stream+2
phy restore return address/data bank
phx
ldx stream
plb
lda >stream+2 verify that stream exists
pha
lda >stream
pha
pha verify that stream exists
phx
jsl ~VerifyStream
bcc lb1
lda #EIO
@ -3874,40 +3883,33 @@ argp equ 7 argument pointer
;
; For signed numbers, if the value is negative, use the sign flag
;
lda ~isLongLong handle long long values
beq sn0
ldy #6
lda [argp],Y
bpl cn0
sec
lda #0
sbc [argp]
sta [argp]
ldy #2
lda #0
sbc [argp],Y
sta [argp],Y
iny
iny
lda #0
sbc [argp],Y
sta [argp],Y
iny
iny
lda #0
sbc [argp],Y
sta [argp],Y
bra sn2
sn0 lda ~isLong handle long values
lda ~isLong handle long and long long values
beq sn0a
ldy #2
lda [argp],Y
lda ~isLongLong
beq sn0
ldy #6
sn0 lda [argp],Y
bpl cn0
sec
lda #0
ldx #0
txa
sbc [argp]
sta [argp]
lda #0
ldy #2
txa
sbc [argp],Y
sta [argp],Y
lda ~isLongLong
beq sn2
iny
iny
txa
sbc [argp],Y
sta [argp],Y
iny
iny
txa
sbc [argp],Y
sta [argp],Y
bra sn2
@ -3957,13 +3959,12 @@ cn1 lda [argp] push an int value
cn1a pha
cn2 ph4 #~str push the string addr
ph2 #l:~str push the string buffer length
ph2 #0 do an unsigned conversion
lda ~isLongLong do the proper conversion
beq cn2a
pla
jsr ~ULongLong2Dec
bra pd1
cn2a lda ~isLong
cn2a ph2 #0 do an unsigned conversion
lda ~isLong
beq cn3
_Long2Dec
bra pd1
@ -4050,17 +4051,8 @@ pn1 lda ~hexPrefix if there is a hex prefix then
jsl ~putchar
ph2 ~hexPrefix+1
jsl ~putchar
pn1a lda ~paddChar if the number needs 0 padding then
cmp #'0'
bne pn1c
lda ~fieldWidth
bmi pn1c
beq pn1c
pn1b ph2 ~paddChar print padd zeros
jsl ~putchar
dec ~fieldWidth
bne pn1b
pn1c lda ~precision if the number needs more padding then
pn1a jsr ~ZeroPad pad with '0's if needed
lda ~precision if the number needs more padding then
beq pn3
pn2 ph2 #'0' print padd characters
jsl ~putchar
@ -4088,10 +4080,10 @@ pn5 cpy #l:~str quit if we're at the end of the ~str
;
rn1 lda ~isLongLong
beq rn2
inc argp
inc argp
inc argp
inc argp
lda argp
clc
adc #4
sta argp
rn2 lda ~isLong
beq rn3
inc argp
@ -4237,9 +4229,12 @@ lb1 clc restore the original argp+4
****************************************************************
*
* ~Format_o - format an octal number
* ~Format_x - format a hexadecimal number (lowercase output)
* ~Format_X - format a hexadecimal number (uppercase output)
* ~Format_p - format a pointer
*
* Inputs:
* ~altForm - use a leading '0'?
* ~altForm - use a leading '0' (octal) or '0x' (hex)?
* ~fieldWidth - output field width
* ~paddChar - padd character
* ~leftJustify - left justify the output?
@ -4253,15 +4248,34 @@ lb1 clc restore the original argp+4
~Format_o private
using ~printfCommon
argp equ 7 argument pointer
lda #3 use 3 bits per output character
bra cn0
~Format_x entry
;
; Set the "or" value; this is used to set the case of character results
;
lda #$20*256
sta ~orVal
bra hx0
~Format_p entry
inc ~isLong
~Format_X entry
stz ~orVal
hx0 lda #4 use 4 bits per output character
;
; Initialization
;
cn0 sta bitsPerChar
stz ~hexPrefix assume we won't lead with 0x
stz ~sign ignore the sign flag
lda #' ' initialize the string to blanks
sta ~str
move ~str,~str+1,#l:~str-1
stz ~num+2 get the value to convert
lda ~isLongLong
lda ~isLongLong get the value to convert
beq cn1
ldy #6
lda [argp],Y
@ -4272,7 +4286,7 @@ argp equ 7 argument pointer
sta ~num+4
cn1 lda ~isLong
beq cn2
cn1a ldy #2
ldy #2
lda [argp],Y
sta ~num+2
cn2 lda [argp]
@ -4280,57 +4294,71 @@ cn2 lda [argp]
beq cn2a
and #$00FF
cn2a sta ~num
ldx bitsPerChar if doing hex format then
cpx #3
beq cn2b
ldx ~altForm if alt form has been selected then
beq cn2b
ora ~num+2 if value is not 0 then
ora ~num+4
ora ~num+6
beq cn2b
lda #'X0' set hex prefix to '0X' or '0x'
ora ~orVal
sta ~hexPrefix
;
; Convert the number to an ASCII string
;
short I,M
ldy #l:~str-1 set up the character index
cn3 lda ~num+7 quit if the number is zero
ora ~num+6
ora ~num+5
ora ~num+4
ora ~num+3
ora ~num+2
ora ~num+1
ora ~num
beq al1
lda #0 roll off 3 bits
ldx #3
cn4 lsr ~num+7
ror ~num+6
ror ~num+5
cn2b ldy #l:~str-1 set up the character index
cn3 lda #' 0' roll off 4 bits
ldx bitsPerChar
cn4 lsr ~num+6
ror ~num+4
ror ~num+3
ror ~num+2
ror ~num+1
ror ~num
ror A
dex
bne cn4
lsr A form a character
lsr A
lsr A
lsr A
lsr A
ora #'0'
xba form a character
ldx bitsPerChar
cn4a asl A
dex
bne cn4a
cmp #('9'+1)*256+' ' if the character should be alpha then
blt cn5
clc
adc #7*256 adjust it
ora ~orVal
cn5 dey
sta ~str,Y save the character
dey
bra cn3
lda ~num+6 loop if the number is not zero
ora ~num+4
ora ~num+2
ora ~num
bne cn3
;
; If a leading zero is required, be sure we include one
; If a leading '0x' is required, be sure we include one
;
al1 cpy #l:~str-1 include a zero if no characters have
beq al2 been placed in the string
lda ~altForm branch if no leading zero is required
lda bitsPerChar if doing octal format then
cmp #3
bne al3
lda ~altForm if alt form has been selected then
beq al3
al2 lda #'0'
sta ~str,Y
al3 long I,M
lda ~precision make sure precision is non-zero
bne al2
inc ~precision
al2 lda #'0 ' if the result is not ' 0' then
cmp ~str+l:~str-2
beq al3
sta ~str-1,Y include a zero in the string
;
; Piggy back off of ~Format_d for output
;
stz ~hexPrefix don't lead with 0x
brl ~Format_IntOut
al3 brl ~Format_IntOut
;
; Local data
;
bitsPerChar ds 2 bits per output character
end
****************************************************************
@ -4350,36 +4378,36 @@ al3 long I,M
using ~printfCommon
argp equ 7 argument pointer
ph4 <argp save the original argp
ldy #2 dereference argp
lda [argp],Y
tax
lda [argp]
sta argp
stx argp+2
short M determine the length of the string
ldy #-1
lb1 iny
lda [argp],Y
bne lb1
long M
tya
bra lb1a
sec set flag for c-string
bra lb0
~Format_b entry
~Format_P entry
ph4 <argp save the original argp
clc set flag for p-string
lb0 ph4 <argp save the original argp
ldy #2 dereference argp
lda [argp],Y
tax
lda [argp]
sta argp
stx argp+2
lda [argp] get the length of the string
bcs lb1 if formatting a p-string then
lda [argp] get the length of the string
and #$00FF
inc4 argp
bra lb1x else if formatting a c-string then
lb1 short M compute the length of the string
ldy #-1
lb1a iny
lda [argp],Y
bne lb1a
long M
tya
lb1a ldx ~precisionSpecified if the precision is specified then
lb1x ldx ~precisionSpecified if the precision is specified then
beq lb2
cmp ~precision if the precision is smaller then
blt lb2
@ -4408,133 +4436,6 @@ lb4 clc restore and increment argp
brl ~LeftJustify handle left justification
end
****************************************************************
*
* ~Format_x - format a hexadecimal number (lowercase output)
* ~Format_X - format a hexadecimal number (uppercase output)
* ~Format_p - format a pointer
*
* Inputs:
* ~altForm - use a leading '0x'?
* ~fieldWidth - output field width
* ~paddChar - padd character
* ~leftJustify - left justify the output?
* ~isLong - is the operand long?
* ~isLongLong - is the operand long long?
* ~precision - precision of output
* ~precisionSpecified - was the precision specified?
*
****************************************************************
*
~Format_x private
using ~printfCommon
argp equ 7 argument pointer
;
; Set the "or" value; this is used to set the case of character results
;
lda #$20
sta orVal
bra cn0
~Format_p entry
lda #1
sta ~isLong
~Format_X entry
stz orVal
;
; Initialization
;
cn0 stz ~sign ignore the sign flag
lda #' ' initialize the string to blanks
sta ~str
move ~str,~str+1,#l:~str-1
stz ~num+2 get the value to convert
stz ~num+4
stz ~num+6
lda ~isLongLong
beq cn1
ldy #6
lda [argp],Y
sta ~num+6
dey
dey
lda [argp],Y
sta ~num+4
cn1 lda ~isLong
beq cn2
ldy #2
lda [argp],Y
sta ~num+2
cn2 lda [argp]
ldx ~isByte
beq cn2a
and #$00FF
cn2a sta ~num
ora ~num+2
ora ~num+4
ora ~num+6
bne cn2b
stz ~altForm if value is 0, do not print hex prefix
cn2b stz ~hexPrefix assume we won't lead with 0x
;
; Convert the number to an ASCII string
;
short I,M
ldy #l:~str-1 set up the character index
cn3 lda #0 roll off 4 bits
ldx #4
cn4 lsr ~num+7
ror ~num+6
ror ~num+5
ror ~num+4
ror ~num+3
ror ~num+2
ror ~num+1
ror ~num
ror A
dex
bne cn4
lsr A form a character
lsr A
lsr A
lsr A
ora #'0'
cmp #'9'+1 if the character should be alpha,
blt cn5 adjust it
adc #6
ora orVal
cn5 sta ~str,Y save the character
dey
lda ~num+7 loop if the number is not zero
ora ~num+6
ora ~num+5
ora ~num+4
ora ~num+3
ora ~num+2
ora ~num+1
ora ~num
bne cn3
;
; If a leading '0x' is required, be sure we include one
;
lda ~altForm branch if no leading '0x' is required
beq al3
al2 lda #'X' insert leading '0x'
ora orVal
sta ~hexPrefix+1
lda #'0'
sta ~hexPrefix
al3 long I,M
;
; Piggy back off of ~Format_d for output
;
brl ~Format_IntOut
;
; Local data
;
orVal ds 2 for setting the case of characters
end
****************************************************************
*
* ~Format_Percent - format the '%' character
@ -4662,10 +4563,12 @@ stream equ 3 input stream
*
* ~LeftJustify - print padd characters for left justification
* ~RightJustify - print padd characters for right justification
* ~ZeroPad - print zeros to pad to field width
*
* Inputs:
* ~fieldWidth - # chars to print ( <= 0 prints none)
* ~leftJustify - left justify the output?
* ~paddChar - padding character
*
****************************************************************
*
@ -4688,6 +4591,19 @@ lb1 ph2 #' ' write the proper # of padd characters
dec ~fieldWidth
bne lb1
rts
~ZeroPad entry
lda ~paddChar if the number needs 0 padding then
cmp #'0'
bne zp2
lda ~fieldWidth
bmi zp2
beq zp2
zp1 ph2 ~paddChar print padd zeros
jsl ~putchar
dec ~fieldWidth
bne zp1
zp2 rts
end
****************************************************************
@ -4786,7 +4702,7 @@ lb3 creturn 4:ptr
* -----------------------
*
* An 'l' indicates that the 'd', 'o', 'u', 'x' or 'X' argument is
* long. 'L' and 'u' are also accepted for compliance with ANSI C,
* long. 'L' and 'h' are also accepted for compliance with ANSI C,
* but have no effect in this implementation.
*
* Conversion Specifier
@ -4799,12 +4715,14 @@ lb3 creturn 4:ptr
* while 'X' generates uppercase hex digits.
* c Character.
* s String.
* p Pascal string.
* P,b Pascal string.
* p Pointer.
* n The argument is (int *); the number of characters written so
* far is written to the location.
* f Signed decimal floating point.
* f,F Signed decimal floating point.
* e,E Exponential format floating point.
* g,G Use f,e or E, as appropriate.
* a,A Hexadecimal format floating point.
* % Write a '%' character.
*
****************************************************************
@ -4909,20 +4827,20 @@ fm4 cmp #'L' else if *format in ['L','h'] then
inc ~isByte
fm5 inc4 format ++format
lda [format] find the proper format character
and #$00FF
fm6 inc4 format
ldx #fListEnd-fList-4
short M,I
ldx #fListEnd-fList-3
fm7 cmp fList,X
beq fm8
dex
dex
dex
dex
bpl fm7
long M,I
brl ps1 none found - continue
fm8 pea ps1-1 push the return address
fm8 long M,I
pea ps1-1 push the return address
inx call the subroutine
inx
jmp (fList,X)
;
; Flag - Read and process a flag character
@ -4933,23 +4851,23 @@ Flag lda [format] get the character
and #$00FF
cmp #'-' if it is a '-' then
bne fl1
lda #1 left justify the output
sta ~leftJustify
sta ~leftJustify left justify the output
lda #' ' pad with spaces (ignore any '0' flag)
sta ~paddChar
bra fl5
fl1 cmp #'0' if it is a '0' then
bne fl2
sta ~paddChar padd with '0' characters
ldx ~leftJustify if not left justifying then
bne fl5
sta ~paddChar padd with '0' characters
bra fl5
fl2 cmp #'+' if it is a '+' or ' ' then
beq fl3
cmp #' '
bne fl4
ldx ~sign
cpx #'+'
beq fl5
fl3 sta ~sign set the sign flag
fl3 tsb ~sign set the sign flag ('+' overrides ' ')
bra fl5
fl4 cmp #'#' if it is a '#' then
@ -4979,8 +4897,10 @@ GetSize stz val assume a value of 0
bne fv0
eor #$ffff negative field width is like
inc a positive with - flag
ldx #1
ldx #'-'
stx ~leftJustify
ldx #' '
stx ~paddChar
bra fv1
fv0 lda #0 negative precision is ignored
stz ~precisionSpecified
@ -5013,27 +4933,27 @@ val ds 2 value
;
; List of format specifiers and the equivalent subroutines
;
fList dc c'%',i1'0',a'~Format_Percent' %
dc c'a',i1'0',a'~Format_e' a (not formatted correctly)
dc c'A',i1'0',a'~Format_E' A (not formatted correctly)
dc c'f',i1'0',a'~Format_f' f
dc c'F',i1'0',a'~Format_f' F
dc c'e',i1'0',a'~Format_e' e
dc c'E',i1'0',a'~Format_E' E
dc c'g',i1'0',a'~Format_g' g
dc c'G',i1'0',a'~Format_G' G
dc c'n',i1'0',a'~Format_n' n
dc c's',i1'0',a'~Format_s' s
dc c'b',i1'0',a'~Format_b' b
dc c'P',i1'0',a'~Format_P' P
dc c'p',i1'0',a'~Format_p' p
dc c'c',i1'0',a'~Format_c' c
dc c'X',i1'0',a'~Format_X' X
dc c'x',i1'0',a'~Format_x' x
dc c'o',i1'0',a'~Format_o' o
dc c'u',i1'0',a'~Format_u' u
dc c'd',i1'0',a'~Format_d' d
dc c'i',i1'0',a'~Format_d' i
fList dc c'%',a'~Format_Percent' %
dc c'a',a'~Format_a' a
dc c'A',a'~Format_A' A
dc c'f',a'~Format_f' f
dc c'F',a'~Format_F' F
dc c'e',a'~Format_e' e
dc c'E',a'~Format_E' E
dc c'g',a'~Format_g' g
dc c'G',a'~Format_G' G
dc c'n',a'~Format_n' n
dc c's',a'~Format_s' s
dc c'b',a'~Format_b' b
dc c'P',a'~Format_P' P
dc c'p',a'~Format_p' p
dc c'c',a'~Format_c' c
dc c'X',a'~Format_X' X
dc c'x',a'~Format_x' x
dc c'o',a'~Format_o' o
dc c'u',a'~Format_u' u
dc c'd',a'~Format_d' d
dc c'i',a'~Format_d' i
fListEnd anop
end
@ -5067,8 +4987,9 @@ fListEnd anop
;
; Work buffers
;
~num ds 8 long long integer
~num ds 8 long long integer (must be 0 after each conversion)
~numChars ds 2 number of characters printed with this printf
~orVal ds 2 value to 'or' with to set case of characters
~str ds 83 string buffer
;
; Real formatting
@ -5951,13 +5872,9 @@ ps stz ~assignments no assignments yet
stz ~scanCount no characters scanned
stz ~scanError no scan error so far
stz ~eofFound eof was not the first char
jsl ~getchar test for eof
cmp #EOF
bne ps0
sta ~eofFound
ps0 jsl ~putback
ps1 lda ~scanError quit if a scan error has occurred
ora ~eofFound
bne rm1
lda [format] get a character
and #$00FF
@ -6117,7 +6034,7 @@ fm2b inc ~size
fm2c inc ~size
bra fm4
fm3 cmp #'h' 'h' specifies short int
bne fm5
bne fm6
inc4 format unless it is 'hh' for char types
lda [format]
and #$00FF
@ -6126,21 +6043,21 @@ fm3 cmp #'h' 'h' specifies short int
dec ~size
fm4 inc4 format ignore the character
fm5 lda [format] find the proper format character
and #$00FF
lda [format] find the proper format character
fm6 inc4 format
ldx #fListEnd-fList-4
short M,I
ldx #fListEnd-fList-3
fm7 cmp fList,X
beq fm8
dex
dex
dex
dex
bpl fm7
long M,I
brl ps1 none found - continue
fm8 pea ps1-1 push the return address
fm8 long M,I
pea ps1-1 push the return address
inx call the subroutine
inx
jmp (fList,X)
;
; GetSize - get a numeric value
@ -6182,28 +6099,28 @@ val ds 2 value
;
; List of format specifiers and the equivalent subroutines
;
fList dc c'd',i1'0',a'~Scan_d' d
dc c'i',i1'0',a'~Scan_i' i
dc c'u',i1'0',a'~Scan_u' u
dc c'o',i1'0',a'~Scan_o' o
dc c'x',i1'0',a'~Scan_x' x
dc c'X',i1'0',a'~Scan_x' X
dc c'p',i1'0',a'~Scan_p' p
dc c'c',i1'0',a'~Scan_c' c
dc c's',i1'0',a'~Scan_s' s
dc c'b',i1'0',a'~Scan_b' b
dc c'P',i1'0',a'~Scan_P' P
dc c'n',i1'0',a'~Scan_n' n
dc c'a',i1'0',a'~Scan_f' a
dc c'A',i1'0',a'~Scan_f' A
dc c'f',i1'0',a'~Scan_f' f
dc c'F',i1'0',a'~Scan_f' F
dc c'e',i1'0',a'~Scan_f' e
dc c'E',i1'0',a'~Scan_f' E
dc c'g',i1'0',a'~Scan_f' g
dc c'G',i1'0',a'~Scan_f' G
dc c'%',i1'0',a'~Scan_percent' %
dc c'[',i1'0',a'~Scan_lbrack' [
fList dc c'd',a'~Scan_d' d
dc c'i',a'~Scan_i' i
dc c'u',a'~Scan_u' u
dc c'o',a'~Scan_o' o
dc c'x',a'~Scan_x' x
dc c'X',a'~Scan_x' X
dc c'p',a'~Scan_p' p
dc c'c',a'~Scan_c' c
dc c's',a'~Scan_s' s
dc c'b',a'~Scan_b' b
dc c'P',a'~Scan_P' P
dc c'n',a'~Scan_n' n
dc c'a',a'~Scan_f' a
dc c'A',a'~Scan_f' A
dc c'f',a'~Scan_f' f
dc c'F',a'~Scan_f' F
dc c'e',a'~Scan_f' e
dc c'E',a'~Scan_f' E
dc c'g',a'~Scan_f' g
dc c'G',a'~Scan_f' G
dc c'%',a'~Scan_percent' %
dc c'[',a'~Scan_lbrack' [
fListEnd anop
;
; Other local data

128
stdlib.asm
View File

@ -37,7 +37,7 @@ abort start
ph2 #SIGABRT
jsl raise
lda #-1
jmp ~C_QUIT
brl ~C_QUIT
end
****************************************************************
@ -333,6 +333,10 @@ addr equ 13 address of array element of index test
csubroutine (4:key,4:base,4:count,4:size,4:compar),16
lda count if count is 0 then
ora count+2
jeq lb5 just return a null pointer
lda compar patch the call address
sta >jsl+1
lda compar+1
@ -436,14 +440,14 @@ exit start
_exit entry
_Exit entry
lda 4,S
jmp ~C_QUIT
brl ~C_QUIT
end
quick_exit start
jsr ~QUICKEXIT
lda 4,S
jmp ~C_QUIT
brl ~C_QUIT
end
****************************************************************
@ -700,13 +704,14 @@ ret stx n
qsort start
csubroutine (4:base,4:count,4:size,4:compar),0
phb
phk
plb
lda count nothing to do if count is 0
ora count+2
beq done
phb
phk
plb
dec4 count set count to the addr of the last entry
mul4 count,size
add4 count,base
@ -717,12 +722,13 @@ qsort start
lda compar+1
sta jsl1+2
sta jsl2+2
plb
ph4 <count do the sort
ph4 <base
jsl rsort
done plb
creturn
done creturn
end
****************************************************************
@ -765,26 +771,31 @@ right equ 5 right address
csubroutine (4:first,4:last),8
phb
sr0 phb
phk
plb
sr0 lda last+2 if last <= first then quit
lda last+2 if last <= first then quit
bmi sr1a
cmp first+2
bne sr1
lda last
cmp first
sr1 bgt sr1a
plb
sr1 bgt sr1b
sr1a plb
creturn
sr1a move4 last,right right = last
sr1b move4 last,right right = last
move4 first,left left = first
bra sr3
sr2 add4 left,lsize inc left until *left >= *last
sr3 ph4 <last
sr3 plb
ph4 <last
ph4 <left
jsl1 entry
jsl jsl1
phb
phk
plb
tax
bmi sr2
sr4 lda right quit if right = first
@ -794,10 +805,14 @@ sr4 lda right quit if right = first
cmp first+2
beq sr4b
sr4a sub4 right,lsize dec right until *right <= *last
plb
ph4 <last
ph4 <right
jsl2 entry
jsl jsl2
phb
phk
plb
dec A
bpl sr4
sr4b ph4 <left swap left/right entries
@ -815,11 +830,24 @@ sr5 blt sr2
ph4 <left swap left/last entries
ph4 <last
jsr swap
sub4 left,lsize,right sort left part of array
ph4 <right
sub4 left,lsize,right calculate bounds of subarrays
add4 left,lsize (first..right and left..last)
add4 first,last,mid calculate midpoint of range being sorted
lsr mid+2
ror mid
cmpl right,mid if right < mid then
bge sr6
plb
ph4 <right sort left subarray recursively
ph4 <first
jsl rsort
add4 left,lsize,first sort right part of array
move4 left,first sort right subarray via tail call
brl sr0
sr6 plb else
ph4 <last sort right subarray recursively
ph4 <left
jsl rsort
move4 right,last sort left subarray via tail call
brl sr0
;
; swap - swap two entries
@ -830,8 +858,9 @@ r equ 7 right entry
swap tsc set up addressing
phd
tcd
ldx lsize+2 move 64K chunks
lda lsize+2 move 64K chunks
beq sw2
sta banks
ldy #0
sw1 lda [l],Y
tax
@ -844,7 +873,7 @@ sw1 lda [l],Y
bne sw1
inc l+2
inc r+2
dex
dec banks
bne sw1
sw2 lda lsize if there are an odd number of bytes then
lsr A
@ -893,6 +922,8 @@ sw6 pld
;
lsize entry
ds 4 local copy of size
banks ds 2 number of whole banks to swap
mid ds 4 midpoint of the elements being sorted
end
****************************************************************
@ -968,9 +999,10 @@ rtl equ 7 return address
val equ 3 value
negative equ 1 is the number negative?
pea 0 make room for & initialize val
pea 0
pea 0 make room for & initialize negative
lda #0
pha make room for & initialize val
pha
pha make room for & initialize negative
tsc set up direct page addressing
phd
tcd
@ -1095,10 +1127,11 @@ foundOne equ 1 have we found a number?
ldx #1
init pea 1 make room for & initialize rangeOK
pea 0 make room for & initialize negative
pea 0 make room for & initialize val
pea 0
pea 0 make room for & initialize foundOne
lda #0
pha make room for & initialize negative
pha make room for & initialize val
pha
pha make room for & initialize foundOne
tsc set up direct page addressing
phd
tcd
@ -1286,13 +1319,14 @@ retptr equ 11 pointer to location for return value
val equ 3 value
negative equ 1 is the number negative?
pea 0 make room for & initialize retptr
lda #0
pha make room for & initialize retptr
phx
pea 0 make room for & initialize val
pea 0
pea 0
pea 0
pea 0 make room for & initialize negative
pha make room for & initialize val
pha
pha
pha
pha make room for & initialize negative
tsc set up direct page addressing
phd
tcd
@ -1435,15 +1469,16 @@ foundOne equ 1 have we found a number?
~strtoull entry alt entry point called from strtoll
ldy #1
init pea 0 make room for & initialize retptr
init lda #0
pha make room for & initialize retptr
phx
pea 1 make room for & initialize rangeOK
pea 0 make room for & initialize negative
pea 0 make room for & initialize val
pea 0
pea 0
pea 0
pea 0 make room for & initialize foundOne
pha make room for & initialize negative
pha make room for & initialize val
pha
pha
pha
pha make room for & initialize foundOne
tsc set up direct page addressing
phd
tcd
@ -1549,16 +1584,13 @@ cn3 cmp base branch if the digit is too big
cn3a clc add in the new digit
adc val
sta val
lda val+2
adc #0
sta val+2
lda val+4
adc #0
sta val+4
lda val+6
adc #0
sta val+6
bcc cn4
inc val+2
bne cn4
inc val+4
bne cn4
inc val+6
bne cn4
stz rangeOK
cn4 inc4 str next char
bra cn1

12
stdlib.macros
View File

@ -734,3 +734,15 @@
&l bne *+5
brl &bp
mend
macro
&l cmpl &n1,&n2
lclb &yistwo
&l ~setm
~lda.h &n1
~op.h cmp,&n2
bne ~a&SYSCNT
~lda &n1
~op cmp,&n2
~a&SYSCNT anop
~restm
mend

117
string.asm
View File

@ -244,8 +244,8 @@ lb3 lda [p1],Y scan until the end of memory is reached
dex
bne lb3
ldx #0 memory matches
bra lb5
; ldx #0
bra lb5 memory matches
lb4 blt less memory differs - set the result
ldx #1
@ -253,9 +253,9 @@ lb4 blt less memory differs - set the result
less ldx #-1
lb5 long M
lda rtl remove the parameters from the stack
lb5 lda rtl remove the parameters from the stack
sta len+1
long M
lda rtl+1
sta len+2
pld
@ -303,8 +303,8 @@ rtl equ 1 return address
short M move 1 byte now
lda [p2]
sta [p1]
long M
dec len
long M
inc4 p1
inc4 p2
lb1 anop endif
@ -436,11 +436,11 @@ lb10 lda [p2],Y
dex
bne lb9
lb11 long M
ply get the original source pointer
lb11 ply get the original source pointer
plx
lda rtl remove the parameters from the stack
sta len+1
long M
lda rtl+1
sta len+2
pld
@ -482,19 +482,19 @@ rtl equ 1 return address
ph4 <p save the pointer
short M
lda val form a 2 byte value
sta val+1
short I,M
ldx val form a 2 byte value
stx val+1
lda len if there are an odd # of bytes then
lsr A
bcc lb1
lda val set 1 byte now
txa set 1 byte now
sta [p]
long M
dec len
long I,M
inc4 p
lb1 long M endif
lb1 long I,M endif
lda val set len bytes
ldx len+2 set full banks
@ -616,7 +616,9 @@ lb2 long M
clc
adc s1
sta s1
short M copy characters 'til the null is found
bcc lb2a
inc s1+2
lb2a short M copy characters 'til the null is found
ldy #0
lb3 lda [s2],Y
sta [s1],Y
@ -627,9 +629,9 @@ lb3 lda [s2],Y
inc s2+2
bra lb3
lb4 long M return to the caller
lda rtl
lb4 lda rtl return to the caller
sta s2+1
long M
lda rtl+1
sta s2+2
ldx rval+2
@ -749,9 +751,9 @@ less ldx #-1 It wasn't, so *s1 < *s2
lb3 blt less the strings differ - set the result
ldx #1
lb4 long M
lda rtl remove the parameters from the stack
lb4 lda rtl remove the parameters from the stack
sta s2+1
long M
lda rtl+1
sta s2+2
pld
@ -828,9 +830,9 @@ lb1 lda [s2],Y
inc s2+2
bra lb1
lb2 long M return to the caller
lda rtl
lb2 lda rtl return to the caller
sta s2+1
long M
lda rtl+1
sta s2+2
ldx rval+2
@ -956,9 +958,12 @@ str equ 4 pointer to the string
tcd
ldy #0 advance s1 to point to the terminating
ldx #0 null
tyx null
short M
lb1 lda [str],Y
beq lb2
iny
lda [str],Y
beq lb2
iny
bne lb1
@ -966,10 +971,10 @@ lb1 lda [str],Y
inc str+2
bra lb1
lb2 long M
pld remove str from the stack
lda 2,S
sta 6,S
lb2 pld remove str from the stack
lda 3,S
sta 7,S
long M
pla
sta 3,S
pla
@ -1013,27 +1018,35 @@ lb2 long M
clc
adc s1
sta s1
short M copy characters 'til the null is found
bcc lb2a
inc s1+2
lb2a ldx n copy characters 'til the null is found
bne lb2b
lda n+2
beq lb6
lb2b short M
ldy #0
ldx n
beq lb4
bmi lb4
lb3 lda [s2],Y
sta [s1],Y
beq lb4
beq lb5
iny
dex
bne lb3a
inc s1+2
inc s2+2
lb3a dex
bne lb3
lda n+2
ldx n+2
beq lb4
dec n+2
dex
stx n+2
ldx #0
bra lb3
lb4 lda #0 write the terminating null
sta [s1],Y
long M return to the caller
lb5 long M return to the caller
creturn 4:rval
lb6 creturn 4:rval
end
****************************************************************
@ -1060,7 +1073,6 @@ flag equ 1 return flag
ldy #0 scan until the end of string is reached
ldx n+2 or a difference is found
bmi equal
bne lb0
ldx n
beq equal
@ -1072,9 +1084,11 @@ lb1 lda [s1],Y
bne lb3
dex
bne lb1a
lda n+2
ldx n+2
beq equal
dec n+2
dex
stx n+2
ldx #0
lb1a iny
bne lb1
inc s1+2
@ -1189,20 +1203,19 @@ lb1 lda [s],Y
short M
bra lb1
lb2 long I,M no match found -> return NULL
ldx #0
lb2 ldx #0 no match found -> return NULL
txy
long I,M
bra lb4
lb3 long I,M increment s by Y and load the value
tya
and #$00FF
clc
adc s
tay
lda s+2
adc #0
tax
ldx s+2
bcc lb4
inx
lb4 lda rtl+1 remove the parameters
sta set+2
@ -1252,10 +1265,10 @@ lb1 lda [str],Y
lb2 ldy #-1 no match found -> return -1
lb3 long M
pld remove parameters from the stack
lda 2,S
sta 8,S
lb3 pld remove parameters from the stack
lda 3,S
sta 9,S
long M
pla
sta 5,S
pla
@ -1363,10 +1376,10 @@ lb2 cmp #0
iny
bpl lb1
lb3 long M
pld remove parameters from the stack
lda 2,S
sta 8,S
lb3 pld remove parameters from the stack
lda 3,S
sta 9,S
long M
pla
sta 5,S
pla

613
time.asm
View File

@ -19,7 +19,18 @@
*
****************************************************************
*
Time start dummy segment
Time private dummy segment
; struct tm fields
tm_sec gequ 0 seconds 0..59
tm_min gequ tm_sec+2 minutes 0..59
tm_hour gequ tm_min+2 hours 0..23
tm_mday gequ tm_hour+2 day 1..31
tm_mon gequ tm_mday+2 month 0..11
tm_year gequ tm_mon+2 year 69..205 (1900=0)
tm_wday gequ tm_year+2 day of week 0..6 (Sun = 0)
tm_yday gequ tm_wday+2 day of year 0..365
tm_isdst gequ tm_yday+2 daylight savings? 1 = yes, 0 = no
end
****************************************************************
@ -30,15 +41,15 @@ Time start dummy segment
*
TimeCommon privdata
;
; For conversion to/from seconds since 1970
; For conversion to/from seconds since 13 Nov 1969
;
year ds 4 year 0..99
month ds 4 month 1..12
year ds 4 year (years since 1900)
month ds 4 month 0..11
day ds 4 day 1..31
hour ds 4 hour 0..23
minute ds 4 minute 0..59
second ds 4 second 0..59
count ds 4 seconds since 1 Jan 1970
count ds 8 seconds since 13 Nov 1969
t1 ds 4 work variable
t2 ds 4 work variable
@ -225,63 +236,260 @@ mk1 inx
****************************************************************
*
* factor - compute the seconds since 1 Jan 1970 from date
* factor - compute the seconds since 13 Nov 1969 from date
*
* factor_second32 - alt entry point taking second as a
* signed 32-bit input value
*
* Inputs:
* year,month,day,hour,minute,second - time to convert
* (each treated as a signed 16-bit value, with the
* exception of second when using factor_second32)
*
* Outputs:
* count - seconds since 1 Jan 1970
* count - seconds since 13 Nov 1969 (signed 64-bit value)
*
* Note: Input values outside their normal ranges are allowed.
*
****************************************************************
*
factor private
using TimeCommon
;
; compute the # of days since 1 Jan 1970
; sign-extend time components to 4 bytes
;
mul4 year,#365,count count := 365*year + day + 31*(month-1)
stz second+2
lda second
bpl lb0
dec second+2
factor_second32 entry
lb0 stz year+2
lda year
bpl lb0a
dec year+2
lb0a stz month+2
stz day+2
lda day
bpl lb0b
dec day+2
lb0b stz hour+2
lda hour
bpl lb0c
dec hour+2
lb0c stz minute+2
lda minute
bpl lb0e
dec minute+2
;
; adjust for out-of-range month values
;
lb0e lda month
bpl lb0f
clc
adc #12
sta month
dec4 year
bra lb0e
lb0f sec
sbc #12
bmi lb0x
sta month
inc4 year
bra lb0e
;
; compute the # of days since 13 Nov 1969
;
lb0x mul4 year,#365,count count := 365*year + day + 31*month
add4 count,day
mul4 month,#31,t1
add4 count,t1
sub4 count,#31
move4 year,t2 t2 := year
add4 year,#32800,t2 t2 := year + 32800 (so it is positive)
lda month if January or February then
cmp #3
cmp #2
bge lb1
dec t2 year := year-1
dec4 t2 year := year-1
bra lb2 else
lb1 mul4 month,#4,t1 count := count - (month*4+23) div 10
add4 t1,#23
lb1 mul4 month,#4,t1 count := count - (month*4+27) div 10
add4 t1,#27
div4 t1,#10
sub4 count,t1
lb2 lda t2 count := count + year div 4
lsr A
lsr A
clc
adc count
sta count
bcc lb3
inc count+2
lb3 add4 t2,#300 count := count -
div4 t2,#100 ((300+year) div 100+1)*3 div 4
lb2 div4 t2,#4,t1 count := count + (year+32800) div 4
add4 count,t1
add4 t2,#300 count := count -
div4 t2,#100 ((300+year+32800) div 100+1)*3 div 4
inc4 t2
mul4 t2,#3
div4 t2,#4
sub4 count,t2
sub4 count,#25516 subtract off days between 1 Jan 00 and
! 1 Jan 70
sub4 count,#25518-2+7954 subtract off days between 1 Jan 1900
! and 13 Nov 1969, minus 2 to adjust for
! skipped leap days in 1700 and 1800,
! plus 7954 to adjust for leap days in
! an additional 32800 years
;
; Convert to seconds and add in time of day in seconds
;
mul4 count,#24*60*60 convert to seconds
mul4 hour,#3600,t1 add in hours*3600
add4 count,t1
lda count+2 convert to 64-bit count of seconds
pha
bpl lb3 if count is negative, negate it
sub4 #0,count,count
lb3 tsc compute count*24*60*60
sec
sbc #8
tcs
ph4 count
ph4 #24*60*60
_LongMul
pla
sta count
pla
sta count+2
pla
sta count+4
pla
sta count+6
pla
bpl lb4 if count was negative, negate result
negate8 count
lb4 mul4 hour,#3600,t1 add in hours*3600
jsr add_t1_to_count
mul4 minute,#60,t1 add in minutes*60
add4 count,t1
add4 count,second add in seconds
jsr add_t1_to_count
move4 second,t1 add in seconds
;
; Add t1 (4 bytes) to count (8 bytes).
; (This is called as a subroutine and also run at the end of factor.)
;
add_t1_to_count anop
clc
lda t1
adc count
sta count
lda t1+2
tax
adc count+2
sta count+2
lda #0
txy
bpl ad1
dec a
ad1 tay
adc count+4
sta count+4
tya
adc count+6
sta count+6
rts
end
****************************************************************
*
* ~get_tz_offset - get current time zone offset from UTC
*
* Outputs:
* A-X - time zone offset from UTC
*
****************************************************************
*
~get_tz_offset private
lda >__useTimeTool if not using time tool
beq no_tz assume we have no TZ offset
pha make space for TZ prefs
pha
pea 1 get one record element only (TZ offset)
tsc get time zone preference
inc a
pea 0
pha
_tiGetTimePrefs
pla
bcc have_tz
pla
pla
lda #0 assume 0 offset if TZ info not available
no_tz tax
rts
have_tz pha determine if it's daylight savings
ph2 #$5E
_ReadBParam
pla
lsr a
lsr a
bcs ret
; clc
lda #60*60 adjust for DST (+1 hour) if needed
adc 1,s
sta 1,s
lda #0
adc 3,s
sta 3,s
ret pla return offset value
plx
rts
end
****************************************************************
*
* gmlocaltime_tm - struct tm used by gmtime and localtime
*
****************************************************************
*
gmlocaltime_tm private
ds 9*2
end
****************************************************************
*
* struct tm *gmtime(t)
* time_t *t;
*
* Inputs:
* t - pointer to # of seconds since 13 Nov 1969
*
* Outputs:
* returns a pointer to a time record for UTC time
*
****************************************************************
*
gmtime start
t equ 6
phd
tsc
tcd
ldy #2 dereference the pointer to time_t
lda [t],Y
tax
lda [t]
tay
pld
phb
pla move return address
sta 3,s
pla
sta 3,s
plb
ph4 #gmlocaltime_tm push address of struct tm to use
pea 0 push tm_isdst value (no DST for UTC)
phx push time_t value to convert
phy
jsr ~get_tz_offset push time zone offset
phx
pha
doit jsl ~gmlocaltime use common gmtime/localtime code
rtl
end
****************************************************************
*
@ -289,106 +497,172 @@ lb3 add4 t2,#300 count := count -
* time_t *t;
*
* Inputs:
* t - # seconds since 1 Jan 1970
* t - pointer to # of seconds since 13 Nov 1969
*
* Outputs:
* returns a pointer to a time record for local time
*
****************************************************************
*
localtime start
using TimeCommon
t equ 6
phd
tsc
tcd
ldy #2 dereference the pointer to time_t
lda [t],Y
tax
lda [t]
tay
pld
phb
pla move return address
sta 3,s
pla
sta 3,s
lda #-1 default DST setting = -1 (unknown)
cpy lasttime determine DST setting, if we can
bne lb1
cpx lasttime+2
bne lb1
lda lastDST
lb1 plb
ph4 #gmlocaltime_tm push address of struct tm to use
pha push tm_isdst value
phx push time_t value to convert
phy
pea 0 no time zone offset
pea 0
jsl ~gmlocaltime use common gmtime/localtime code
rtl
end
****************************************************************
*
* ~gmlocaltime - common code for gmtime and localtime
*
* Inputs:
* tz_offset - offset of local time from desired time zone
* t - time_t value (# of seconds since 13 Nov 1969)
* isdst - value for tm_isdst flag
* tm - pointer to struct tm for result
*
* Outputs:
* returns a pointer to a time record
*
****************************************************************
*
localtime start
gmtime entry
~gmlocaltime private
using TimeCommon
csubroutine (4:t),0
csubroutine (4:tz_offset,4:t,2:isdst,4:tm),0
phb
phk
plb
ldy #2 dereference the pointer
lda [t],Y
tax
lda [t]
sta t
stx t+2
ldy #-1 default DST setting = -1 (unknown)
cmp lasttime determine DST setting, if we can
bne lb0
cpx lasttime+2
bne lb0
ldy lastDST
lb0 sty tm_isdst
lda #69 find the year
sta year
lda #1
sta month
sta day
stz month
stz hour
stz minute
stz second
lda tz_offset
sta second
lda tz_offset+2
sta second+2
lb1 inc year
jsr factor
jsr factor_second32
lda count+4
bne lb1b
lda count+2
cmp t+2
bne lb1a
lda count
cmp t
lb1a ble lb1
dec year
lb1b dec year
lb2 inc month find the month
jsr factor
jsr factor_second32
lda count+4
bmi lb2
bne lb2b
lda count+2
cmp t+2
bne lb2a
lda count
cmp t
lb2a ble lb2
dec month
jsr factor recompute the factor
lb2b dec month
jsr factor_second32 recompute the factor
lda year set the year
sta tm_year
ldy #tm_year
sta [tm],y
lda month set the month
dec A
sta tm_mon
ldy #tm_mon
sta [tm],y
ph4 <t save original t value
sub4 t,count find the number of seconds
move4 t,t1
div4 t,#60
mul4 t,#60,t2
sub4 t1,t2
lda t1
sta tm_sec
ldy #tm_sec
sta [tm],y
move4 t,t1 find the number of minutes
div4 t,#60
mul4 t,#60,t2
sub4 t1,t2
lda t1
sta tm_min
ldy #tm_min
sta [tm],y
move4 t,t1 find the number of hours
div4 t,#24
mul4 t,#24,t2
sub4 t1,t2
lda t1
sta tm_hour
ldy #tm_hour
sta [tm],y
lda t set the day
inc A
sta tm_mday
ph4 #tm_sec set the day of week/year
jsl mktime
lla t,tm_sec
ldy #tm_mday
sta [tm],y
pl4 t restore original t value
stz month compute the days since the start of the
jsr factor_second32 year (in desired time zone)
sub4 t,count,count
div4 count,#60*60*24
ldy #tm_yday set the day of year
lda count
sta [tm],y
lb3 cmpl t,#7*3000*60*60*24 compute the day of week
blt lb3a
sub4 t,#7*3000*60*60*24
bra lb3
lb3a add4 t,#4*60*60*24
sec (adjust for time zone)
lda t
sbc tz_offset
sta t
lda t+2
sbc tz_offset+2
sta t+2
div4 t,#60*60*24
mod4 t,#7
lda t set the day of week
ldy #tm_wday
sta [tm],y
lda isdst set the DST flag
ldy #tm_isdst
sta [tm],y
plb
creturn 4:t
tm_sec ds 2 seconds 0..59
tm_min ds 2 minutes 0..59
tm_hour ds 2 hours 0..23
tm_mday ds 2 day 1..31
tm_mon ds 2 month 0..11
tm_year ds 2 year 70..200 (1900=0)
tm_wday ds 2 day of week 0..6 (Sun = 0)
tm_yday ds 2 day of year 0..365
tm_isdst ds 2 daylight savings? 1 = yes, 0 = no
creturn 4:tm
end
****************************************************************
@ -402,7 +676,7 @@ tm_isdst ds 2 daylight savings? 1 = yes, 0 = no
* Outputs:
* tmptr->wday - day of week
* tmptr->yday - day of year
* returns the ime in seconds since 1 Jan 1970
* returns the ime in seconds since 13 Nov 1969
*
****************************************************************
*
@ -416,16 +690,12 @@ temp2 equ 5 temp variable
phk
plb
lla temp,-1 assume we can't do it
ldy #10 error if year < 70
ldy #tm_year set time parameters
lda [tmptr],Y
sta year
cmp #70
jlt lb1
dey set the other time parameters
dey
dey
lda [tmptr],Y
inc A
sta month
dey
dey
@ -441,24 +711,22 @@ temp2 equ 5 temp variable
sta minute
lda [tmptr]
sta second
jsr factor compute seconds since 1970
move4 count,temp save the value for later return
lda #1 compute the days since the start of the
sta month year
sta day
jsr factor
sub4 temp,count,count
div4 count,#60*60*24
ldy #14 set the days
lda count
sta [tmptr],Y
div4 temp,#60*60*24,temp2 compute the day of week
add4 temp2,#4
mod4 temp2,#7
lda temp2 set the day of week
ldy #12
sta [tmptr],Y
jsr factor compute seconds since 13 Nov 1969
lda count+4 if time is unrepresentable
ora count+6
beq lb0
lda #-1 return -1
sta temp
sta temp+2
brl lb1
lb0 move4 count,temp save the value for later return
ph4 <tmptr recompute struct tm values
ldy #tm_isdst
lda [tmptr],y
pha
ph4 <temp
ph4 #0
jsl ~gmlocaltime
lb1 plb
creturn 4:temp
end
@ -494,20 +762,16 @@ time start
and #$00FF
inc A
sta day
lda 5,S set the month
and #$FF00
xba
inc A
lda 6,S set the month
and #$00FF
sta month
lda 3,S set the year
and #$FF00
xba
lda 4,S set the year
and #$00FF
sta year
lda 3,S set the hour
and #$00FF
sta hour
lda 1,S set the minute
xba
lda 2,S set the minute
and #$00FF
sta minute
pla set the second
@ -517,7 +781,13 @@ time start
pla
pla
jsr factor convert the seconds
lda tptr if tptr <> nil then
lda count+4 if time is unrepresentable
ora count+6
beq lb0
lda #-1 set return value to -1
sta count
sta count+2
lb0 lda tptr if tptr <> nil then
ora tptr+2
beq lb1
ldy #2 place the result there
@ -544,6 +814,70 @@ lb1 lda count
creturn 4:tptr
end
****************************************************************
*
* int timespec_get(struct timespec *ts, int base);
*
* Inputs:
* ts - pointer to structure for result
* base - requested time base
*
* Outputs:
* *tptr - the requested time (if successful)
* returns base if successful, or 0 otherwise
*
****************************************************************
*
timespec_get start
using TimeCommon
tz_offset equ 1 time zone offset from UTC
current_time equ 5 current time
TIME_UTC equ 1 UTC time base
tv_sec equ 0 struct timespec members
tv_nsec equ 4
csubroutine (4:ts,2:base),8
lda base
cmp #TIME_UTC
bne err
ph4 #0 get current time (in count)
jsl time
sta current_time
stx current_time+2
and current_time+2 if time is not available
inc a
beq err report error
jsr ~get_tz_offset get time zone offset
sta tz_offset
stx tz_offset+2
sec adjust for time zone & store result
lda current_time
sbc tz_offset
sta [ts]
lda current_time+2
sbc tz_offset+2
ldy #tv_sec+2
sta [ts],y
ldy #tv_nsec ts->tv_nsec = 0
lda #0
sta [ts],y
iny
iny
sta [ts],y
bra ret
err stz base unsupported base: return 0
ret creturn 2:base
end
****************************************************************
*
* size_t strftime(
@ -978,12 +1312,53 @@ Y_skip inx
rts
;%z - offset from UTC, if available
;we print nothing, because time zone info is not available
fmt_z rts
;%Z - time zone name or abbreviation, if available
;we print nothing, because time zone info is not available
fmt_Z rts
;we print the numeric offset for both, or nothing if time zone is not available
fmt_z anop
fmt_Z lda >__useTimeTool if not using Time Tool
beq z_ret write nothing
pea 0 push pointer to string buffer
tdc
clc
adc #numstr
pha
pha make space for TZ preferences record
pha
pea 1 get one record element only (TZ offset)
tsc get time zone preference
inc a
pea 0
pha
_tiGetTimePrefs
pla
bcc z_dst
z_bail pla bail out in case of error
pla
pla
pla
z_ret rts
z_dst ldy #tm_isdst adjust for DST (+1 hour) if needed
lda [timeptr],y
bmi z_bail bail out if DST is unknown
beq z_fmtstr
; clc
pla
adc #60*60
tay
pla
adc #0
pha
phy
z_fmtstr pea 0 no DST mangling
_tiOffset2TimeZoneString get TZ offset string
bcs z_ret
ldx #1
z_loop lda numstr,x print the digits
jsr writech
inx
cpx #5+1
blt z_loop
rts
fmt_invalid rts

56
time.macros
View File

@ -477,11 +477,6 @@
~&SYSCNT ~RESTM
MEND
MACRO
&LAB JLT &BP
&LAB BGE *+5
BRL &BP
MEND
MACRO
&LAB LLA &AD1,&AD2
&LAB ANOP
LCLA &L
@ -621,3 +616,54 @@
&LAB LDX #$260B
JSL $E10000
MEND
MACRO
&lab _tiStatus
&lab ldx #$0638
jsl $E10000
MEND
MACRO
&lab _tiGetTimePrefs
&lab ldx #$0938
jsl $E10000
MEND
MACRO
&lab _tiOffset2TimeZoneString
&lab ldx #$1138
jsl $E10000
MEND
MACRO
&lab _LongMul
&lab ldx #$0C0B
jsl $E10000
MEND
macro
&l negate8 &n1
&l ~setm
sec
ldy #0
tya
sbc &n1
sta &n1
tya
sbc &n1+2
sta &n1+2
tya
sbc &n1+4
sta &n1+4
tya
sbc &n1+6
sta &n1+6
~restm
mend
macro
&l cmpl &n1,&n2
lclb &yistwo
&l ~setm
~lda.h &n1
~op.h cmp,&n2
bne ~a&SYSCNT
~lda &n1
~op cmp,&n2
~a&SYSCNT anop
~restm
mend

38
toolglue.asm
View File

@ -206,6 +206,44 @@ yPos ds 2
xPos ds 2
end
****************************************************************
*
* ReadMouse2 - return mouse statistics
*
* Outputs:
* Returns a pointer to a record with the following
* structure:
*
* typedef struct MouseRec {
* char mouseMode;
* char mouseStatus;
* int yPos;
* int xPos;
* }
*
****************************************************************
*
ReadMouse2 start
pha
pha
pha
_ReadMouse2
sta >~TOOLERROR
pl2 >mouseMode
pl2 >yPos
pl2 >xPos
lda #mouseMode
ldx #^mouseMode
rtl
mouseMode ds 1
mouseStatus ds 1
yPos ds 2
xPos ds 2
end
****************************************************************
*
* ReadTimeHex - returns the time in hex format

5
toolglue.macros
View File

@ -384,3 +384,8 @@
&lab ldx #$1F23
jsl $E10000
MEND
MACRO
&lab _ReadMouse2
&lab ldx #$3303
jsl $E10000
MEND

4
vars.asm
View File

@ -23,7 +23,7 @@ Dummy start (dummy root segment)
*
****************************************************************
*
CVars start
~CVars start
errno entry library error number
ds 2
@ -35,6 +35,8 @@ sys_nerr entry # of error messages
_toolErr entry last error in a tool call (C)
~TOOLERROR entry last error in a tool call (Pascal)
ds 2
__useTimeTool entry use Time Tool in <time.h> functions?
ds 2
end
****************************************************************