6502
/
VolksForth
mirror of https://github.com/forth-ev/VolksForth.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity

Atari 8bit: cleanup

This commit is contained in:
Carsten Strotmann 2020-07-26 13:22:46 +02:00
parent c30e4f24e8
commit c632249474
28 changed files with 745 additions and 161 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
6502/Atari8bit/3.81.4/AS65.TXT → 6502/Atari8bit/3.81.4/AS65.FTH
View File

146
6502/Atari8bit/3.81.4/readme.org Normal file
View File

@ -0,0 +1,146 @@
#+Title: VolksForth Atari 8-bit Readme Version 1.1
#+Date: 13. August 2006
#+Author: Carsten Strotmann
VolksForth is a 16bit Forth System produced by the german Forth
Gesellschaft e.V. Main development of this system was done between
1985 until 1989. The VolksForth Project was revived in 2005 with the
goal to produce a managable Forthsystem for computer systems with
restricted system resources.
Some modern Forth Systems were influenced by or were derived from
VolksForth (GNU-Forth, bigForth).
The current Version of VolskForth is 3.81. Work on Version 3.90 has
been started.
At this time VolksForth is available for this Systems:
* VolksForth MS-DOS (Intel x86 Architecture i8086-ia64)
* VolksForth 6502 (Commodore 64, Commodore Plus 4, Atari 8bit, Apple I, Apple II)
* VolksForth Z80 (CP/M, Schneider CPC CP/M)
* VolksForth 68000 (Atari ST)
VolksForth is in work for this Systems:
* VolksForth MS-DOS (Atari Portfolio)
* VolksForth Z80 (Schneider CPC AMSDOS)
* VolksForth 68000 (Mac Classic, Amiga)
Copyright
The VolksForth Sources are made avail- able under the terms of the BSD
License http://www.opensource.org/licenses/bsd-license.php
The Handbook is Copyright (c) 1985 - 2020 Forth Gesellschaft e.V. (
Klaus Schleisiek, Ulrich Hoffmann, Bernd Pennemann, Georg Rehfeld and
Dietrich Weineck).
The Handbook, binary Files and Source- code for VolksForth as well as
Informa- tion about Forth Gesellschaft are available on the Forth
Gesellschaft Webserver at http://www.forth-ev.de/
(most of the Information is still in german. We are planning to
provide future versions with full englisch documentation)
Information and Help about the Program- ming Language Forth can be
found in the Internet, starting with the Website of the
Forthgesellschaft, or in the Usenet Forum de.comp.lang.forth (via
Google Groups: http://groups.google.de/group/de.comp.lang.forth )
** Details on VolksForth 6502 (Atari 8bit)
*** Requirements
Atari 8bit with 48 KB RAM, Floppy Atari 800, 800XL, Atari 130 XE
600XL (+ Atari 1064),
*** Files
This is list of VolksForth Files in this Distribution.
#+begin_example
DISK 1:
DOS.SYS
DUP.SYS - Atari DOS 2.5
VFORTH.COM - the plain volksForth
kernel
4TH.COM - volksForth binary
STAR4TH.COM - volksForth with
SPARTA/REAL/BEWE
DOS Extensions
DEBUG.COM - volksForth with
Debug Tools
(Tracer etc)
CALL.F - Sourcecode for CALL,
to call Machine-
language Suproutines
CREATE.F - Sourcecode for CREATE
DIR.F - Sourcecode for DIR and
DIR" Commands, to list
Diskdirectories
AS65.F - Sourcecode for the
resident 6502 Assembler
TAS65.F - Sourcecode for the
transient 6502 Assembler
(living in HEAP)
SAVESYS.F - Sourcecode for
SAVE-SYSTEM command
SIEVE.F - Primes Sieve Benchmark
4TH.F - Build volksForth binary
from plain kernel
README.TXT - This Text
COPYING - License Information
Disk 2
DOS.SYS
DUP.SYS - Atari DOS 2.5
4TH.COM - volksForth binary
COPYING - License Information
DEBUG.F - Script to build an
volksForth with
DEBUGGER
TAS65.F - Sourcecode for the
transient 6502 Assembler
(living in HEAP)
CREATE.F - Sourcecode for CREATE
TOOLS.F - Debugging Tools
TRACER.F - Interactive Tracer
DEBUGT.F - more Debugging Tools
SEE.F - build Decompiler without
Disassembler
SEE2.F - built Decompiler with
Disassembler
DISAS.F - 6502 Disassembler
DECOMP.F - volksForth Decompiler
DIS.F - build 6502 Disassembler
MTASK.F - volksForth Multitasker
MTDEMO.F - Multitask Demo
"RatRace"
CALL.F - Sourcecode for CALL,
to call Machine-
language Suproutines
SPARTA.F - Sparta/Real/BEWE-DOS
Support
LAUNCH.F - Sparta DOS CLI
Support
SPAR4TH.F - Build volksForth with
Sparta-DOS Support
TEST.F
TEST2.F
TEST3.F - Test Files for
nested INCLUDE"
#+end_example
*** Editor
This verion of volksForth for Atari 8bit does not contain an Editor
for Sourcecode. An Forth Editor will be supplied for Version 3.90. We
recommend Ken Siders KEDIT ( http://atari.ksiders.tzo.com/ ) or the
CompyShop Editor.
*** Emulator
VolksForth 6502 Atari 8bit 3.81 has been tested in the Atari 8bit
Emulator "Atari800" (atari800.sourceforge.net)
Have fun with VolksForth
the VolksForth Team

BIN
6502/Atari8bit/source.3.81.3/4thker.prg
View File

Binary file not shown.

BIN
6502/Atari8bit/source.3.81.3/bin2hex
View File

Binary file not shown.

161
6502/Atari8bit/source.3.81.3/bin2hex.c
View File

@ -1,161 +0,0 @@
#include <stdio.h>
#include <unistd.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <sys/stat.h>
void help(char *name)
{
printf("%s - BINARY to Intel HEX file convertor version 1.00\n"\
"(c)BCL Vysoke Myto 2001 (benedikt@lphard.cz)\n\n",name);
printf("Usage: %s [-option] binfile hexfile\n"\
" -l Bytes to read from binary file\n"\
" -i Binary file starting offset\n"\
" -o Output file offset (where HEX data starts)\n"\
" -t Exclude EOF record\n"\
" -a Append to end of existing HEX file\n"\
" -q Quiet mode (no statistics are printed)\n", name);
}
int main(int argc,char *argv[])/*Main routine*/
{
char *ifile = NULL;
char *ofile = NULL;
char c;
FILE *inp, *outp;
int ch,csum;
int ofsa = 0;
int cnt = 0;
struct stat statbuf;
long int foffset = 0;
long int fsize = 0;
long int fsub;
long int fpoint = 0;
long int adrs = 0;
unsigned char quiet = 0;
unsigned char eofrec = 0;
unsigned char append = 0;
opterr = 0; //print error message if unknown option
while ((c = getopt (argc, argv, "l:i:o:taqv")) != -1)
switch (c) {
case 'l':
fsize = atol(optarg);
break;
case 'i':
foffset = atol(optarg);
break;
case 'o':
adrs = atol(optarg);
break;
case 't':
eofrec = 1;
break;
case 'a':
append = 1;
break;
case 'q':
quiet = 1;
break;
case 'v':
printf("%s - BINARY to Intel HEX file convertor version 1.00\n"\
"(c)BCL Vysoke Myto 2001 (benedikt@lphard.cz)\n",argv[0]);
return 0;
case '?':
help (argv[0]);
return 1;
}
if ((argc - optind) != 2) {
printf("ERROR: Missing input/output file.\n");
help(argv[0]);
return 1;
}
ifile = argv[optind];
ofile = argv[optind+1];
/*Open file check*/
if((inp = fopen(ifile, "rb")) == NULL){
printf("ERROR: Cannot open input file.\n");
return 1;
}
fseek (inp, foffset, SEEK_SET);
if (append == 0) {
if((outp = fopen(ofile, "wt")) == NULL){
printf("ERROR: Cannot open output file.\n");
return 1;
}
} else {
if((outp = fopen(ofile, "at")) == NULL){
printf("ERROR: Cannot re-open output file.\n");
return 1;
}
fseek (outp, 0, SEEK_END);
}
fstat(fileno(inp), &statbuf);
if (quiet == 0) printf("Input file size=%ld\n",statbuf.st_size);
if (foffset > statbuf.st_size) {
printf("ERROR: Input offset > input file length\n");
}
if ((fsize == 0) || (fsize > (statbuf.st_size - foffset)))
fsize = statbuf.st_size - foffset;
// fprintf(outp,":020000020000FC\n");/*Start Header*/
fsub = fsize - fpoint;
if (fsub > 0x20) {
fprintf(outp,":20%04X00",adrs);/*Hex line Header*/
csum = 0x20 + (adrs>>8) + (adrs & 0xFF);
adrs += 0x20;
}
else {
fprintf(outp, ":%02X%04X00", fsub,adrs);/*Hex line Header*/
csum = fsub + (adrs>>8) + (adrs & 0xFF);
adrs += fsub;
}
while (fsub > 0){
ch = fgetc(inp);
fprintf(outp,"%02X",ch);/*Put data*/
cnt++; fpoint++;
fsub = fsize - fpoint;
csum = ch + csum;
if((fsub == 0)||(cnt == 0x20)){
cnt = 0; csum = 0xFF & (~csum + 1);
fprintf(outp,"%02X\n",csum);/*Put checksum*/
if(fsub == 0) break;
if(adrs > 0xFFFF){
ofsa = 0x1000 + ofsa;
adrs = 0;
fprintf(outp,":02000002%04X",ofsa);/*Change offset address*/
csum = 0x02 + 0x02 + (ofsa>>8) + (ofsa & 0xFF);
csum = 0xFF & (~csum + 1);
fprintf(outp,"%02X\n", csum);
}
adrs = 0xFFFF & adrs;
if (fsub > 0x20) {
fprintf(outp,":20%04X00",adrs);/*Next Hex line Header*/
csum = 0x20 + (adrs>>8) + (adrs & 0xFF);
adrs += 0x20;
}
else {
if(fsub > 0){
fprintf(outp, ":%02X%04X00", fsub,adrs);/*Next Hex line Header*/
csum = fsub + (adrs>>8) + (adrs & 0xFF);
adrs += fsub;
}
}
}
}
if (eofrec == 0) fprintf(outp,":00000001FF\n");/*End footer*/
fflush (outp);
fstat(fileno(outp), &statbuf);
if (quiet == 0) printf("Output file size=%ld\n",statbuf.st_size);
fclose(inp);
fclose(outp);
return 0;
}

0
sources/Apple1/2words.fth → sources/6502/Apple1/2words.fth
View File

0
sources/Apple1/6502f83.fth → sources/6502/Apple1/6502f83.fth
View File

0
sources/Apple1/as65.fth → sources/6502/Apple1/as65.fth
View File

0
sources/Apple1/assemble.fth → sources/6502/Apple1/assemble.fth
View File

0
sources/Apple1/ccompile.fth → sources/6502/Apple1/ccompile.fth
View File

0
sources/Apple1/crostarg.fth → sources/6502/Apple1/crostarg.fth
View File

0
sources/Apple1/systemio.fth → sources/6502/Apple1/systemio.fth
View File

0
sources/Apple1/tasker.fth → sources/6502/Apple1/tasker.fth
View File

0
sources/Apple1/tools.fth → sources/6502/Apple1/tools.fth
View File

15
sources/6502/Atari8bit/4th.fth Normal file
View File

@ -0,0 +1,15 @@
CR
.( Build 4TH.COM from plain kernel )
\needs SAVESYSTEM INCLUDE" D:SAVESYS.F"
\needs CALL INCLUDE" D:CALL.F"
\needs S" INCLUDE" D:STRING.F"
\needs 2@ INCLUDE" D:2WORDS.F"
\needs DIR INCLUDE" D:DIR.F"
SAVE
SAVE-SYSTEM D:4TH.COM
CR
.( 4TH.COM saved )
CR

150
sources/6502/Atari8bit/as65.fs Normal file
View File

@ -0,0 +1,150 @@
\ 6502 Assembler clv10oct87
\ Basis: Forth Dimensions VOL III No. 5)
\ internal loading 04may85BP/re)
\ Forth-6502 Assembler clv10oct87
\ Basis: Forth Dimensions VOL III No. 5)
CR .( Loading 6502 Assembler...) CR
Onlyforth Assembler also definitions
\ Forth-83 6502-Assembler 20oct87re
: end-code context 2- @ context ! ;
Create index
$0909 , $1505 , $0115 , $8011 ,
$8009 , $1D0D , $8019 , $8080 ,
$0080 , $1404 , $8014 , $8080 ,
$8080 , $1C0C , $801C , $2C80 ,
| Variable mode
: Mode: ( n -) Create c,
Does> ( -) c@ mode ! ;
0 Mode: .A 1 Mode: #
2 | Mode: mem 3 Mode: ,X
4 Mode: ,Y 5 Mode: X)
6 Mode: )Y $F Mode: )
\ upmode cpu 20oct87re
| : upmode ( addr0 f0 - addr1 f1)
IF mode @ 8 or mode ! THEN
1 mode @ $F and ?dup IF
0 DO dup + LOOP THEN
over 1+ @ and 0= ;
: cpu ( 8b -) Create c,
Does> ( -) c@ c, mem ;
00 cpu brk $18 cpu clc $D8 cpu cld
$58 cpu cli $B8 cpu clv $CA cpu dex
$88 cpu dey $E8 cpu inx $C8 cpu iny
$EA cpu nop $48 cpu pha $08 cpu php
$68 cpu pla $28 cpu plp $40 cpu rti
$60 cpu rts $38 cpu sec $F8 cpu sed
$78 cpu sei $AA cpu tax $A8 cpu tay
$BA cpu tsx $8A cpu txa $9A cpu txs
$98 cpu tya
\ m/cpu 20oct87re
: m/cpu ( mode opcode -) Create c, ,
Does>
dup 1+ @ $80 and IF $10 mode +! THEN
over $FF00 and upmode upmode
IF mem true Abort" invalid" THEN
c@ mode @ index + c@ + c, mode @ 7 and
IF mode @ $F and 7 <
IF c, ELSE , THEN THEN mem ;
$1C6E $60 m/cpu adc $1C6E $20 m/cpu and
$1C6E $C0 m/cpu cmp $1C6E $40 m/cpu eor
$1C6E $A0 m/cpu lda $1C6E $00 m/cpu ora
$1C6E $E0 m/cpu sbc $1C6C $80 m/cpu sta
$0D0D $01 m/cpu asl $0C0C $C1 m/cpu dec
$0C0C $E1 m/cpu inc $0D0D $41 m/cpu lsr
$0D0D $21 m/cpu rol $0D0D $61 m/cpu ror
$0414 $81 m/cpu stx $0486 $E0 m/cpu cpx
$0486 $C0 m/cpu cpy $1496 $A2 m/cpu ldx
$0C8E $A0 m/cpu ldy $048C $80 m/cpu sty
$0480 $14 m/cpu jsr $8480 $40 m/cpu jmp
$0484 $20 m/cpu bit
\ Assembler conditionals 20oct87re
| : range? ( branch -- branch )
dup abs $7F u> Abort" out of range " ;
: [[ ( BEGIN) here ;
: ?] ( UNTIL) c, here 1+ - range? c, ;
: ?[ ( IF) c, here 0 c, ;
: ?[[ ( WHILE) ?[ swap ;
: ]? ( THEN) here over c@ IF swap !
ELSE over 1+ - range? swap c! THEN ;
: ][ ( ELSE) here 1+ 1 jmp
swap here over 1+ - range? swap c! ;
: ]] ( AGAIN) jmp ;
: ]]? ( REPEAT) jmp ]? ;
\ Assembler conditionals 20oct87re
$90 Constant CS $B0 Constant CC
$D0 Constant 0= $F0 Constant 0<>
$10 Constant 0< $30 Constant 0>=
$50 Constant VS $70 Constant VC
: not $20 [ Forth ] xor ;
: beq 0<> ?] ; : bmi 0>= ?] ;
: bne 0= ?] ; : bpl 0< ?] ;
: bcc CS ?] ; : bvc VS ?] ;
: bcs CC ?] ; : bvs VC ?] ;
\ 2inc/2dec winc/wdec 20oct87re
: 2inc ( adr -- )
dup lda clc 2 # adc
dup sta CS ?[ swap 1+ inc ]? ;
: 2dec ( adr -- )
dup lda sec 2 # sbc
dup sta CC ?[ swap 1+ dec ]? ;
: winc ( adr -- )
dup inc 0= ?[ swap 1+ inc ]? ;
: wdec ( adr -- )
dup lda 0= ?[ over 1+ dec ]? dec ;
: ;c:
recover jsr end-code ] 0 last ! 0 ;
\ ;code Code code> bp/re03feb85
Onlyforth
: Assembler
Assembler [ Assembler ] mem ;
: ;Code
[compile] Does> -3 allot
[compile] ; -2 allot Assembler ;
immediate
: Code Create here dup 2- ! Assembler ;
: >label ( adr -)
here | Create immediate swap ,
4 hallot heap 1 and hallot ( 6502-alig)
here 4 - heap 4 cmove
heap last @ count $1F and + ! dp !
Does> ( - adr) @
state @ IF [compile] Literal THEN ;
: Label
[ Assembler ] here >label Assembler ;
Onlyforth

150
sources/6502/Atari8bit/as65.fth Normal file
View File

@ -0,0 +1,150 @@
\ 6502 Assembler clv10oct87
\ Basis: Forth Dimensions VOL III No. 5)
\ internal loading 04may85BP/re)
\ Forth-6502 Assembler clv10oct87
\ Basis: Forth Dimensions VOL III No. 5)
CR .( Loading 6502 Assembler...) CR
Onlyforth Assembler also definitions
\ Forth-83 6502-Assembler 20oct87re
: end-code context 2- @ context ! ;
Create index
$0909 , $1505 , $0115 , $8011 ,
$8009 , $1D0D , $8019 , $8080 ,
$0080 , $1404 , $8014 , $8080 ,
$8080 , $1C0C , $801C , $2C80 ,
| Variable mode
: Mode: ( n -) Create c,
Does> ( -) c@ mode ! ;
0 Mode: .A 1 Mode: #
2 | Mode: mem 3 Mode: ,X
4 Mode: ,Y 5 Mode: X)
6 Mode: )Y $F Mode: )
\ upmode cpu 20oct87re
| : upmode ( addr0 f0 - addr1 f1)
IF mode @ 8 or mode ! THEN
1 mode @ $F and ?dup IF
0 DO dup + LOOP THEN
over 1+ @ and 0= ;
: cpu ( 8b -) Create c,
Does> ( -) c@ c, mem ;
00 cpu brk $18 cpu clc $D8 cpu cld
$58 cpu cli $B8 cpu clv $CA cpu dex
$88 cpu dey $E8 cpu inx $C8 cpu iny
$EA cpu nop $48 cpu pha $08 cpu php
$68 cpu pla $28 cpu plp $40 cpu rti
$60 cpu rts $38 cpu sec $F8 cpu sed
$78 cpu sei $AA cpu tax $A8 cpu tay
$BA cpu tsx $8A cpu txa $9A cpu txs
$98 cpu tya
\ m/cpu 20oct87re
: m/cpu ( mode opcode -) Create c, ,
Does>
dup 1+ @ $80 and IF $10 mode +! THEN
over $FF00 and upmode upmode
IF mem true Abort" invalid" THEN
c@ mode @ index + c@ + c, mode @ 7 and
IF mode @ $F and 7 <
IF c, ELSE , THEN THEN mem ;
$1C6E $60 m/cpu adc $1C6E $20 m/cpu and
$1C6E $C0 m/cpu cmp $1C6E $40 m/cpu eor
$1C6E $A0 m/cpu lda $1C6E $00 m/cpu ora
$1C6E $E0 m/cpu sbc $1C6C $80 m/cpu sta
$0D0D $01 m/cpu asl $0C0C $C1 m/cpu dec
$0C0C $E1 m/cpu inc $0D0D $41 m/cpu lsr
$0D0D $21 m/cpu rol $0D0D $61 m/cpu ror
$0414 $81 m/cpu stx $0486 $E0 m/cpu cpx
$0486 $C0 m/cpu cpy $1496 $A2 m/cpu ldx
$0C8E $A0 m/cpu ldy $048C $80 m/cpu sty
$0480 $14 m/cpu jsr $8480 $40 m/cpu jmp
$0484 $20 m/cpu bit
\ Assembler conditionals 20oct87re
| : range? ( branch -- branch )
dup abs $7F u> Abort" out of range " ;
: [[ ( BEGIN) here ;
: ?] ( UNTIL) c, here 1+ - range? c, ;
: ?[ ( IF) c, here 0 c, ;
: ?[[ ( WHILE) ?[ swap ;
: ]? ( THEN) here over c@ IF swap !
ELSE over 1+ - range? swap c! THEN ;
: ][ ( ELSE) here 1+ 1 jmp
swap here over 1+ - range? swap c! ;
: ]] ( AGAIN) jmp ;
: ]]? ( REPEAT) jmp ]? ;
\ Assembler conditionals 20oct87re
$90 Constant CS $B0 Constant CC
$D0 Constant 0= $F0 Constant 0<>
$10 Constant 0< $30 Constant 0>=
$50 Constant VS $70 Constant VC
: not $20 [ Forth ] xor ;
: beq 0<> ?] ; : bmi 0>= ?] ;
: bne 0= ?] ; : bpl 0< ?] ;
: bcc CS ?] ; : bvc VS ?] ;
: bcs CC ?] ; : bvs VC ?] ;
\ 2inc/2dec winc/wdec 20oct87re
: 2inc ( adr -- )
dup lda clc 2 # adc
dup sta CS ?[ swap 1+ inc ]? ;
: 2dec ( adr -- )
dup lda sec 2 # sbc
dup sta CC ?[ swap 1+ dec ]? ;
: winc ( adr -- )
dup inc 0= ?[ swap 1+ inc ]? ;
: wdec ( adr -- )
dup lda 0= ?[ over 1+ dec ]? dec ;
: ;c:
recover jsr end-code ] 0 last ! 0 ;
\ ;code Code code> bp/re03feb85
Onlyforth
: Assembler
Assembler [ Assembler ] mem ;
: ;Code
[compile] Does> -3 allot
[compile] ; -2 allot Assembler ;
immediate
: Code Create here dup 2- ! Assembler ;
: >label ( adr -)
here | Create immediate swap ,
4 hallot heap 1 and hallot ( 6502-alig)
here 4 - heap 4 cmove
heap last @ count $1F and + ! dp !
Does> ( - adr) @
state @ IF [compile] Literal THEN ;
: Label
[ Assembler ] here >label Assembler ;
Onlyforth

17
sources/6502/Atari8bit/call.fth Normal file
View File

@ -0,0 +1,17 @@
\NEEDS CODE INCLUDE" D:TAS65.F"
( Call Machine Routine at "addr" )
( return value is A-Reg and Y-Reg)
HEX
CODE CALL ( addr -- res )
4C # lda n sta
SP x) lda n 1+ sta
SP )y lda n 2+ sta
n jsr
n sta
n 1+ sty
00 # ldx
01 # ldy
n lda SP x) sta
n 1+ lda SP )y sta
next jmp end-code

23
sources/6502/Atari8bit/dir.fth Normal file
View File

@ -0,0 +1,23 @@
CR
.( List Directory Command for volksForth )
-1 ?HEAD ! ( move head of DIRX in Heap )
: DIRX
&6 OPEN-FILE DUP
$80 > IF ." File Error:" . ABORT THEN
DROP SOURCE-ID ! CR
BEGIN $580 &18 SOURCE-ID @ READ-LINE
$80 < WHILE
DROP $580 SWAP TYPE
REPEAT 2DROP
SOURCE-ID @ CLOSE-FILE DROP CR ;
( Generic Directory listing for )
( current directory )
: DIR " D:*.*" COUNT DIRX ;
( Directory Listing with Parameter )
( Example: DIR" D2:*.COM"
: DIR" FILE" DIRX ;
CR .( DIR and DIR" Command loaded )
CR

9
sources/6502/Atari8bit/random.fth Normal file
View File

@ -0,0 +1,9 @@
\ Random Numbers
: RND ( -- n ) \ Random Number 0-255
$D20A C@ ;
: RANDOM ( n -- 0..n-1 )
RND $100 * RND + UM* NIP ;

19
sources/6502/Atari8bit/savesys.fth Normal file
View File

@ -0,0 +1,19 @@
: SAVESYSTEM
$FFFF $600 !
ORIGIN 8 - $602 !
HERE $604 !
FILE" W/O OPEN-FILE DROP
DUP $600 6 ROT
WRITE-FILE ( save header ) DROP
DUP ORIGIN 8 - HERE
ORIGIN 8 - - 1+ ROT
WRITE-FILE DROP
$02E0 $602 !
$02E1 $604 !
ORIGIN 8 - $606 !
DUP $602 6 ROT
WRITE-FILE DROP
CLOSE-FILE DROP ;
' SAVESYSTEM ALIAS SAVE-SYSTEM

9
sources/6502/Atari8bit/sound.fth Normal file
View File

@ -0,0 +1,9 @@
\ Atari Sound Commands
( $D200 = Pokey AUDBASE )
: SOUND ( CH# FREQ DIST VOL -- )
SWAP $10 * + ROT DUP + $D200 +
ROT OVER C! 1+ C! ;

20
sources/6502/Atari8bit/tas65.fth Normal file
View File

@ -0,0 +1,20 @@
\ transient Assembler clv10oct87
\ Basis: Forth Dimensions VOL III No. 5)
\ internal loading 04may85BP/re)
\ Forth-6502 Assembler clv10oct87
\ Basis: Forth Dimensions VOL III No. 5)
CR .( Loading 6502 transient Assembler...) CR
Onlyforth Assembler also definitions
here $800 hallot heap dp !
INCLUDE" D:AS65.FS"
dp !
Onlyforth
CR .( Transient Assembler loaded...) CR

122
sources/6502/math.fth Normal file
View File

@ -0,0 +1,122 @@
\ A SINUS-TABLE 20OCT87RE
\ SINUS-TABLE FROM FD Vol IV/1
\needs code INCLUDE" D:TAS65.FS"
| : TABLE ( VALUES N -)
CREATE 0 DO , LOOP
;CODE ( N - VALUE)
SP X) LDA CLC 1 # ADC .A ASL TAY
W )Y LDA SP X) STA
INY W )Y LDA 1 # LDY SP )Y STA
NEXT JMP END-CODE
10000 9998 9994 9986 9976 9962 9945 9925
9903 9877 9848 9816 9781 9744 9703 9659
9613 9563 9511 9455 9397 9336 9272 9205
9135 9063 8988 8910 8829 8746 8660 8572
8480 8387 8290 8192 8090 7986 7880 7771
7660 7547 7431 7314 7193 7071 6947 6820
6691 6561 6428 6293 6157 6018 5878 5736
5592 5446 5299 5150 5000 4848 4695 4540
4384 4226 4067 3907 3746 3584 3420 3256
3090 2924 2756 2588 2419 2250 2079 1908
1736 1564 1392 1219 1045 0872 0698 0523
0349 0175 0000
&91 | TABLE SINTABLE
| : S180 ( DEG -- SIN*10000:SIN 0-180)
DUP &90 >
IF &180 SWAP - THEN
SINTABLE ;
: SIN ( DEG -- SIN*10000)
&360 MOD DUP 0< IF &360 + THEN
DUP &180 >
IF &180 - S180 NEGATE
ELSE S180 THEN ;
: COS ( DEG -- COS*10000)
&360 MOD &90 + SIN ;
: TAN ( DEG -- TAN*10000)
DUP SIN SWAP COS ?DUP
IF &100 SWAP */ ELSE 3 * THEN ;
CODE D2* ( D1 - D2)
2 # LDA SETUP JSR
N 2+ ASL N 3 + ROL N ROL N 1+ ROL
SP 2DEC N 3 + LDA SP )Y STA
N 2+ LDA SP X) STA
SP 2DEC N 1+ LDA SP )Y STA
N LDA SP X) STA
NEXT JMP END-CODE
: DU< &32768 + ROT &32768 + ROT ROT D< ;
| : EASY-BITS ( N1 -- N2)
0 DO
>R D2* D2* R@ - DUP 0<
IF R@ + R> 2* 1-
ELSE R> 2* 3 +
THEN
LOOP ;
| : 2'S-BIT
>R D2* DUP 0<
IF D2* R@ - R> 1+
ELSE D2* R@ 2DUP U<
IF DROP R> 1- ELSE - R> 1+ THEN
THEN ;
| : 1'S-BIT
>R DUP 0<
IF 2DROP R> 1+
ELSE D2* &32768 R@ DU< 0=
NEGATE R> +
THEN ;
: SQRT ( UD1 - U2)
0 1 8 EASY-BITS
ROT DROP 6 EASY-BITS
2'S-BIT 1'S-BIT ;
\ Test
\
\ : XX
\ &16 * &62500 UM*
\ SQRT 0 <# # # # ASCII . HOLD #S #>
\ TYPE SPACE ;
CODE 100* ( N1 - N2)
SP X) LDA N STA SP )Y LDA N 1+ STA
N ASL N 1+ ROL N ASL N 1+ ROL
N LDA N 2+ STA N 1+ LDA N 3 + STA
N 2+ ASL N 3 + ROL N 2+ ASL N 3 + ROL
N 2+ ASL N 3 + ROL
CLC N LDA N 2+ ADC N STA
N 1+ LDA N 3 + ADC N 1+ STA
N 2+ ASL N 3 + ROL
CLC N LDA N 2+ ADC SP X) STA
N 1+ LDA N 3 + ADC SP )Y STA
NEXT JMP END-CODE
LABEL 4/+
N 7 + LSR N 6 + ROR N 5 + ROR N 4 + ROR
N 7 + LSR N 6 + ROR N 5 + ROR N 4 + ROR
CLC N LDA N 4 + ADC N STA
N 1+ LDA N 5 + ADC N 1+ STA
SP X) LDA N 6 + ADC SP X) STA
SP )Y LDA N 7 + ADC SP )Y STA RTS
CODE 100U/ ( U - N)
N STX N 4 + STX
SP X) LDA .A ASL N 1+ STA N 5 + STA
SP )Y LDA .A ROL SP X) STA N 6 + STA
TXA .A ROL SP )Y STA N 7 + STA
4/+ JSR
N 7 + LSR N 6 + ROR N 5 + ROR N 4 + ROR
4/+ JSR
NEXT JMP END-CODE

19
sources/generic/array.fth Normal file
View File

@ -0,0 +1,19 @@
\ Arrays with bounds checking
| : (ARRAYERROR
ABORT" Array out of bounds!" ;
: ARRAY ( size -- )
CREATE DUP , 2* ALLOT
DOES> ( i -- addr )
OVER 0< (ARRAYERROR
2DUP @ 1- - 0> (ARRAYERROR
SWAP 1+ 2* + ;
: CARRAY ( size -- )
CREATE DUP , ALLOT
DOES> ( i -- addr )
OVER 0< (ARRAYERROR
2DUP @ 1- - 0> (ARRAYERROR
+ 1+ ;

4
sources/generic/create.fth Normal file
View File

@ -0,0 +1,4 @@
: CREATE: create hide
current @ context ! 0 ] ;

9
sources/generic/double.fth Normal file
View File

@ -0,0 +1,9 @@
\ Double Cell 32bit arithmetics words
.( load additional double 32bit words )
: D/ ( d u -- d ) \ floored result
SWAP OVER /MOD >R
SWAP UM/MOD SWAP DROP R> ;

33
sources/generic/sieve.fth Normal file
View File

@ -0,0 +1,33 @@
\ Sieve benchmark
CR .( Loading Sieve Benchmark... ) CR
Onlyforth
: allot ( u --)
dup sp@ here - $180 - u>
abort" no room" allot ;
&8192 Constant size
Create flags size allot
: do-prime ( -- #primes )
flags size 1 fill 0
size 0 DO flags I + c@
IF I 2* 3+ dup I +
BEGIN dup size <
WHILE 0 over flags + c!
over +
REPEAT 2drop 1+
THEN
LOOP ;
: benchmark
do-prime . ." Primzahlen" ;
: .primes size 0 DO flags I + c@
IF I 2* 3+ . THEN ?cr
stop? IF LEAVE THEN LOOP ;
CR .( Start Benchmark ) CR
benchmark CR
.primes CR
.( Benchmark finished ) CR