From fabfc2158653c8b43954d47b400607f39af656f8 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Mon, 20 Jul 2020 23:47:02 +0200 Subject: [PATCH] Tools: fb2fth (Forth-Block to Forth Source) in gforth --- sources/Apple1/2words.fb.src | 68 - sources/Apple1/2words.fth | 68 + sources/Apple1/6502f83.fb.src | 2244 -------------------------- sources/Apple1/6502f83.fth | 2244 ++++++++++++++++++++++++++ sources/Apple1/as65.fb.src | 204 --- sources/Apple1/as65.fth | 204 +++ sources/Apple1/assemble.fb.src | 323 ---- sources/Apple1/assemble.fth | 323 ++++ sources/Apple1/ccompile.fb.src | 34 - sources/Apple1/ccompile.fth | 34 + sources/Apple1/crostarg.fb.src | 680 -------- sources/Apple1/crostarg.fth | 680 ++++++++ sources/Apple1/systemio.fb.src | 187 --- sources/Apple1/systemio.fth | 187 +++ sources/Apple1/tasker.fb.src | 170 -- sources/Apple1/tasker.fth | 170 ++ sources/Apple1/tools.fb.src | 255 --- sources/Apple1/tools.fth | 255 +++ sources/AtariST/ALLOCATE.FB.src | 34 - sources/AtariST/ALLOCATE.fth | 34 + sources/AtariST/ASSEMBLE.FB.src | 323 ---- sources/AtariST/ASSEMBLE.fth | 323 ++++ sources/AtariST/C.FB.src | 34 - sources/AtariST/C.fth | 34 + sources/AtariST/CROSTARG.FB.src | 680 -------- sources/AtariST/CROSTARG.fth | 680 ++++++++ sources/AtariST/DEMO.FB.src | 255 --- sources/AtariST/DEMO.fth | 255 +++ sources/AtariST/DISASS.FB.src | 357 ----- sources/AtariST/DISASS.fth | 357 +++++ sources/AtariST/DRAGON1.FB.src | 136 -- sources/AtariST/DRAGON1.fth | 136 ++ sources/AtariST/EDIICON.FB.src | 102 -- sources/AtariST/EDIICON.fth | 102 ++ sources/AtariST/EDITOR.FB.src | 1598 ------------------- sources/AtariST/EDITOR.fth | 1598 +++++++++++++++++++ sources/AtariST/EDWINDOW.FB.src | 306 ---- sources/AtariST/EDWINDOW.fth | 306 ++++ sources/AtariST/ERRORBOX.FB.src | 102 -- sources/AtariST/ERRORBOX.fth | 102 ++ sources/AtariST/FILEINT.FB.src | 1258 --------------- sources/AtariST/FILEINT.fth | 1258 +++++++++++++++ sources/AtariST/FORTH83.FB.src | 2261 --------------------------- sources/AtariST/FORTH83.fth | 2261 +++++++++++++++++++++++++++ sources/AtariST/GEM/AES.FB.src | 680 -------- sources/AtariST/GEM/AES.fth | 680 ++++++++ sources/AtariST/GEM/BASICS.FB.src | 170 -- sources/AtariST/GEM/BASICS.fth | 170 ++ sources/AtariST/GEM/GEMDEFS.FB.src | Bin 6690 -> 0 bytes sources/AtariST/GEM/GEMDEFS.fth | Bin 0 -> 6420 bytes sources/AtariST/GEM/SUPERGEM.FB.src | 272 ---- sources/AtariST/GEM/SUPERGEM.fth | 272 ++++ sources/AtariST/GEM/VDI.FB.src | 714 --------- sources/AtariST/GEM/VDI.fth | 714 +++++++++ sources/AtariST/INDEX.FB.src | 34 - sources/AtariST/INDEX.fth | 34 + sources/AtariST/LINE_A.FB.src | 629 -------- sources/AtariST/LINE_A.fth | 629 ++++++++ sources/AtariST/MISC.FB.src | 170 -- sources/AtariST/MISC.fth | 170 ++ sources/AtariST/PATCH.FB.src | 68 - sources/AtariST/PATCH.fth | 68 + sources/AtariST/PRINTER.FB.src | 510 ------ sources/AtariST/PRINTER.fth | 510 ++++++ sources/AtariST/RAMDISK.FB.src | 442 ------ sources/AtariST/RAMDISK.fth | 442 ++++++ sources/AtariST/RELOCATE.FB.src | 51 - sources/AtariST/RELOCATE.fth | 51 + sources/AtariST/RFEDIT.FB.src | 51 - sources/AtariST/RFEDIT.fth | 51 + sources/AtariST/STARTUP.FB.src | 34 - sources/AtariST/STARTUP.fth | 34 + sources/AtariST/STRINGS.FB.src | 204 --- sources/AtariST/STRINGS.fth | 204 +++ sources/AtariST/TARGET.FB.src | 680 -------- sources/AtariST/TARGET.fth | 680 ++++++++ sources/AtariST/TASKER.FB.src | 136 -- sources/AtariST/TASKER.fth | 136 ++ sources/AtariST/TOOLS.FB.src | 272 ---- sources/AtariST/TOOLS.fth | 272 ++++ sources/AtariST/TUTORIAL.FB.src | 85 - sources/AtariST/TUTORIAL.fth | 85 + sources/AtariST/UNDO.FB.src | 51 - sources/AtariST/UNDO.fth | 51 + sources/cpm/ASS8080.FB.src | 306 ---- sources/cpm/ASSTRAN.FB.src | 34 - sources/cpm/COPY.FB.src | 34 - sources/cpm/DISASS.FB.src | 306 ---- sources/cpm/DOUBLE.FB.src | 51 - sources/cpm/EDITOR.FB.src | 544 ------- sources/cpm/FILEINT.FB.src | 544 ------- sources/cpm/HASHCASH.FB.src | 85 - sources/cpm/INSTALL.FB.src | 85 - sources/cpm/PORT8080.FB.src | 34 - sources/cpm/PORTZ80.FB.src | 51 - sources/cpm/PRIMED.FB.src | 51 - sources/cpm/PRINTER.FB.src | 272 ---- sources/cpm/RELOCATE.FB.src | 51 - sources/cpm/SAVESYS.FB.src | 34 - sources/cpm/SEE.FB.src | 408 ----- sources/cpm/SIMPFILE.FB.src | 68 - sources/cpm/SOURCE.FB.src | 2176 -------------------------- sources/cpm/STARTUP.FB.src | 34 - sources/cpm/TARGET.FB.src | 578 ------- sources/cpm/TASKER.FB.src | 119 -- sources/cpm/TERMINAL.FB.src | 34 - sources/cpm/TIMES.FB.src | 34 - sources/cpm/TOOLS.FB.src | 306 ---- sources/cpm/XINOUT.FB.src | 136 -- sources/cpm/ass8080.fth | 306 ++++ sources/cpm/asstran.fth | 34 + sources/cpm/copy.fth | 34 + sources/cpm/disass.fth | 306 ++++ sources/cpm/double.fth | 51 + sources/cpm/editor.fth | 544 +++++++ sources/cpm/fileint.fth | 544 +++++++ sources/cpm/hashcash.fth | 85 + sources/cpm/install.fth | 85 + sources/cpm/port8080.fth | 34 + sources/cpm/portz80.fth | 51 + sources/cpm/primed.fth | 51 + sources/cpm/printer.fth | 272 ++++ sources/cpm/relocate.fth | 51 + sources/cpm/savesys.fth | 34 + sources/cpm/see.fth | 408 +++++ sources/cpm/simpfile.fth | 68 + sources/cpm/source.fth | 2176 ++++++++++++++++++++++++++ sources/cpm/startup.fth | 34 + sources/cpm/target.fth | 578 +++++++ sources/cpm/tasker.fth | 119 ++ sources/cpm/terminal.fth | 34 + sources/cpm/times.fth | 34 + sources/cpm/tools.fth | 306 ++++ sources/cpm/xinout.fth | 136 ++ sources/msdos/ansi.fth | 136 ++ sources/msdos/ansi.vid.src | 136 -- sources/msdos/anstest.fth | 34 + sources/msdos/asm.fb.src | 391 ----- sources/msdos/asm.fth | 391 +++++ sources/msdos/bios.fth | 153 ++ sources/msdos/bios.vid.src | 153 -- sources/msdos/blocking.fb.src | 51 - sources/msdos/blocking.fth | 51 + sources/msdos/ced.fb.src | 136 -- sources/msdos/ced.fth | 136 ++ sources/msdos/coretest.fth | 1207 ++++++++++++++ sources/msdos/disasm.fb.src | 748 --------- sources/msdos/disasm.fth | 748 +++++++++ sources/msdos/dos.fb.src | 306 ---- sources/msdos/dos.fth | 306 ++++ sources/msdos/double.fb.src | 85 - sources/msdos/double.fth | 85 + sources/msdos/editor.fb.src | 714 --------- sources/msdos/editor.fth | 714 +++++++++ sources/msdos/emu2-4th.fth | 85 + sources/msdos/extend.fb.src | 187 --- sources/msdos/extend.fth | 187 +++ sources/msdos/f83asm.fb.src | 578 ------- sources/msdos/f83asm.fth | 578 +++++++ sources/msdos/install.fb.src | 306 ---- sources/msdos/install.fth | 306 ++++ sources/msdos/kernel.fb.src | Bin 178610 -> 0 bytes sources/msdos/kernel.fth | Bin 0 -> 171554 bytes sources/msdos/krnlbios.fth | Bin 0 -> 171554 bytes sources/msdos/meta.fb.src | 901 ----------- sources/msdos/meta.fth | 901 +++++++++++ sources/msdos/minimal.fth | 102 ++ sources/msdos/minimal.sys.src | 102 -- sources/msdos/miniterm.fth | 340 ++++ sources/msdos/multi.fth | 306 ++++ sources/msdos/multi.vid.src | 306 ---- sources/msdos/primed.fb.src | 119 -- sources/msdos/primed.fth | 119 ++ sources/msdos/rfe.fb.src | 51 - sources/msdos/scratch.fth | 578 +++++++ sources/msdos/see.fb.src | 2074 ------------------------ sources/msdos/see.fth | 2074 ++++++++++++++++++++++++ sources/msdos/serial.fb.src | 374 ----- sources/msdos/serial.fth | 374 +++++ sources/msdos/stream.fb.src | 187 --- sources/msdos/stream.fth | 187 +++ sources/msdos/tasker.fb.src | 85 - sources/msdos/tasker.fth | 85 + sources/msdos/tester.fth | 136 ++ sources/msdos/timer.fb.src | 85 - sources/msdos/timer.fth | 85 + sources/msdos/tools.fb.src | 221 --- sources/msdos/tools.fth | 221 +++ sources/msdos/volks4th.fth | 85 + sources/msdos/volks4th.sys.src | 85 - tools/dumpblock.fth | 14 + tools/dumpblock.sh | 4 +- tools/gensourcefiles.sh | 20 +- 193 files changed, 33975 insertions(+), 31632 deletions(-) delete mode 100644 sources/Apple1/2words.fb.src create mode 100644 sources/Apple1/2words.fth delete mode 100644 sources/Apple1/6502f83.fb.src create mode 100644 sources/Apple1/6502f83.fth delete mode 100644 sources/Apple1/as65.fb.src create mode 100644 sources/Apple1/as65.fth delete mode 100644 sources/Apple1/assemble.fb.src create mode 100644 sources/Apple1/assemble.fth delete mode 100644 sources/Apple1/ccompile.fb.src create mode 100644 sources/Apple1/ccompile.fth delete mode 100644 sources/Apple1/crostarg.fb.src create mode 100644 sources/Apple1/crostarg.fth delete mode 100644 sources/Apple1/systemio.fb.src create mode 100644 sources/Apple1/systemio.fth delete mode 100644 sources/Apple1/tasker.fb.src create mode 100644 sources/Apple1/tasker.fth delete mode 100644 sources/Apple1/tools.fb.src create mode 100644 sources/Apple1/tools.fth delete mode 100644 sources/AtariST/ALLOCATE.FB.src create mode 100644 sources/AtariST/ALLOCATE.fth delete mode 100644 sources/AtariST/ASSEMBLE.FB.src create mode 100644 sources/AtariST/ASSEMBLE.fth delete mode 100644 sources/AtariST/C.FB.src create mode 100644 sources/AtariST/C.fth delete mode 100644 sources/AtariST/CROSTARG.FB.src create mode 100644 sources/AtariST/CROSTARG.fth delete mode 100644 sources/AtariST/DEMO.FB.src create mode 100644 sources/AtariST/DEMO.fth delete mode 100644 sources/AtariST/DISASS.FB.src create mode 100644 sources/AtariST/DISASS.fth delete mode 100644 sources/AtariST/DRAGON1.FB.src create mode 100644 sources/AtariST/DRAGON1.fth delete mode 100644 sources/AtariST/EDIICON.FB.src create mode 100644 sources/AtariST/EDIICON.fth delete mode 100644 sources/AtariST/EDITOR.FB.src create mode 100644 sources/AtariST/EDITOR.fth delete mode 100644 sources/AtariST/EDWINDOW.FB.src create mode 100644 sources/AtariST/EDWINDOW.fth delete mode 100644 sources/AtariST/ERRORBOX.FB.src create mode 100644 sources/AtariST/ERRORBOX.fth delete mode 100644 sources/AtariST/FILEINT.FB.src create mode 100644 sources/AtariST/FILEINT.fth delete mode 100644 sources/AtariST/FORTH83.FB.src create mode 100644 sources/AtariST/FORTH83.fth delete mode 100644 sources/AtariST/GEM/AES.FB.src create mode 100644 sources/AtariST/GEM/AES.fth delete mode 100644 sources/AtariST/GEM/BASICS.FB.src create mode 100644 sources/AtariST/GEM/BASICS.fth delete mode 100644 sources/AtariST/GEM/GEMDEFS.FB.src create mode 100644 sources/AtariST/GEM/GEMDEFS.fth delete mode 100644 sources/AtariST/GEM/SUPERGEM.FB.src create mode 100644 sources/AtariST/GEM/SUPERGEM.fth delete mode 100644 sources/AtariST/GEM/VDI.FB.src create mode 100644 sources/AtariST/GEM/VDI.fth delete mode 100644 sources/AtariST/INDEX.FB.src create mode 100644 sources/AtariST/INDEX.fth delete mode 100644 sources/AtariST/LINE_A.FB.src create mode 100644 sources/AtariST/LINE_A.fth delete mode 100644 sources/AtariST/MISC.FB.src create mode 100644 sources/AtariST/MISC.fth delete mode 100644 sources/AtariST/PATCH.FB.src create mode 100644 sources/AtariST/PATCH.fth delete mode 100644 sources/AtariST/PRINTER.FB.src create mode 100644 sources/AtariST/PRINTER.fth delete mode 100644 sources/AtariST/RAMDISK.FB.src create mode 100644 sources/AtariST/RAMDISK.fth delete mode 100644 sources/AtariST/RELOCATE.FB.src create mode 100644 sources/AtariST/RELOCATE.fth delete mode 100644 sources/AtariST/RFEDIT.FB.src create mode 100644 sources/AtariST/RFEDIT.fth delete mode 100644 sources/AtariST/STARTUP.FB.src create mode 100644 sources/AtariST/STARTUP.fth delete mode 100644 sources/AtariST/STRINGS.FB.src create mode 100644 sources/AtariST/STRINGS.fth delete mode 100644 sources/AtariST/TARGET.FB.src create mode 100644 sources/AtariST/TARGET.fth delete mode 100644 sources/AtariST/TASKER.FB.src create mode 100644 sources/AtariST/TASKER.fth delete mode 100644 sources/AtariST/TOOLS.FB.src create mode 100644 sources/AtariST/TOOLS.fth delete mode 100644 sources/AtariST/TUTORIAL.FB.src create mode 100644 sources/AtariST/TUTORIAL.fth delete mode 100644 sources/AtariST/UNDO.FB.src create mode 100644 sources/AtariST/UNDO.fth delete mode 100644 sources/cpm/ASS8080.FB.src delete mode 100644 sources/cpm/ASSTRAN.FB.src delete mode 100644 sources/cpm/COPY.FB.src delete mode 100644 sources/cpm/DISASS.FB.src delete mode 100644 sources/cpm/DOUBLE.FB.src delete mode 100644 sources/cpm/EDITOR.FB.src delete mode 100644 sources/cpm/FILEINT.FB.src delete mode 100644 sources/cpm/HASHCASH.FB.src delete mode 100644 sources/cpm/INSTALL.FB.src delete mode 100644 sources/cpm/PORT8080.FB.src delete mode 100644 sources/cpm/PORTZ80.FB.src delete mode 100644 sources/cpm/PRIMED.FB.src delete mode 100644 sources/cpm/PRINTER.FB.src delete mode 100644 sources/cpm/RELOCATE.FB.src delete mode 100644 sources/cpm/SAVESYS.FB.src delete mode 100644 sources/cpm/SEE.FB.src delete mode 100644 sources/cpm/SIMPFILE.FB.src delete mode 100644 sources/cpm/SOURCE.FB.src delete mode 100644 sources/cpm/STARTUP.FB.src delete mode 100644 sources/cpm/TARGET.FB.src delete mode 100644 sources/cpm/TASKER.FB.src delete mode 100644 sources/cpm/TERMINAL.FB.src delete mode 100644 sources/cpm/TIMES.FB.src delete mode 100644 sources/cpm/TOOLS.FB.src delete mode 100644 sources/cpm/XINOUT.FB.src create mode 100644 sources/cpm/ass8080.fth create mode 100644 sources/cpm/asstran.fth create mode 100644 sources/cpm/copy.fth create mode 100644 sources/cpm/disass.fth create mode 100644 sources/cpm/double.fth create mode 100644 sources/cpm/editor.fth create mode 100644 sources/cpm/fileint.fth create mode 100644 sources/cpm/hashcash.fth create mode 100644 sources/cpm/install.fth create mode 100644 sources/cpm/port8080.fth create mode 100644 sources/cpm/portz80.fth create mode 100644 sources/cpm/primed.fth create mode 100644 sources/cpm/printer.fth create mode 100644 sources/cpm/relocate.fth create mode 100644 sources/cpm/savesys.fth create mode 100644 sources/cpm/see.fth create mode 100644 sources/cpm/simpfile.fth create mode 100644 sources/cpm/source.fth create mode 100644 sources/cpm/startup.fth create mode 100644 sources/cpm/target.fth create mode 100644 sources/cpm/tasker.fth create mode 100644 sources/cpm/terminal.fth create mode 100644 sources/cpm/times.fth create mode 100644 sources/cpm/tools.fth create mode 100644 sources/cpm/xinout.fth create mode 100644 sources/msdos/ansi.fth delete mode 100644 sources/msdos/ansi.vid.src create mode 100644 sources/msdos/anstest.fth delete mode 100644 sources/msdos/asm.fb.src create mode 100644 sources/msdos/asm.fth create mode 100644 sources/msdos/bios.fth delete mode 100644 sources/msdos/bios.vid.src delete mode 100644 sources/msdos/blocking.fb.src create mode 100644 sources/msdos/blocking.fth delete mode 100644 sources/msdos/ced.fb.src create mode 100644 sources/msdos/ced.fth create mode 100644 sources/msdos/coretest.fth delete mode 100644 sources/msdos/disasm.fb.src create mode 100644 sources/msdos/disasm.fth delete mode 100644 sources/msdos/dos.fb.src create mode 100644 sources/msdos/dos.fth delete mode 100644 sources/msdos/double.fb.src create mode 100644 sources/msdos/double.fth delete mode 100644 sources/msdos/editor.fb.src create mode 100644 sources/msdos/editor.fth create mode 100644 sources/msdos/emu2-4th.fth delete mode 100644 sources/msdos/extend.fb.src create mode 100644 sources/msdos/extend.fth delete mode 100644 sources/msdos/f83asm.fb.src create mode 100644 sources/msdos/f83asm.fth delete mode 100644 sources/msdos/install.fb.src create mode 100644 sources/msdos/install.fth delete mode 100644 sources/msdos/kernel.fb.src create mode 100644 sources/msdos/kernel.fth create mode 100644 sources/msdos/krnlbios.fth delete mode 100644 sources/msdos/meta.fb.src create mode 100644 sources/msdos/meta.fth create mode 100644 sources/msdos/minimal.fth delete mode 100644 sources/msdos/minimal.sys.src create mode 100644 sources/msdos/miniterm.fth create mode 100644 sources/msdos/multi.fth delete mode 100644 sources/msdos/multi.vid.src delete mode 100644 sources/msdos/primed.fb.src create mode 100644 sources/msdos/primed.fth delete mode 100644 sources/msdos/rfe.fb.src create mode 100644 sources/msdos/scratch.fth delete mode 100644 sources/msdos/see.fb.src create mode 100644 sources/msdos/see.fth delete mode 100644 sources/msdos/serial.fb.src create mode 100644 sources/msdos/serial.fth delete mode 100644 sources/msdos/stream.fb.src create mode 100644 sources/msdos/stream.fth delete mode 100644 sources/msdos/tasker.fb.src create mode 100644 sources/msdos/tasker.fth create mode 100644 sources/msdos/tester.fth delete mode 100644 sources/msdos/timer.fb.src create mode 100644 sources/msdos/timer.fth delete mode 100644 sources/msdos/tools.fb.src create mode 100644 sources/msdos/tools.fth create mode 100644 sources/msdos/volks4th.fth delete mode 100644 sources/msdos/volks4th.sys.src create mode 100755 tools/dumpblock.fth diff --git a/sources/Apple1/2words.fb.src b/sources/Apple1/2words.fb.src deleted file mode 100644 index 80852df..0000000 --- a/sources/Apple1/2words.fb.src +++ /dev/null @@ -1,68 +0,0 @@ -Screen 0 not modified - 0 \ Additional definitions for 32bit values cas 26jan06 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ 2Words Loadscreen cas 26jan06 - 1 - 2 hex - 3 &2 &3 thru - 4 decimal - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ 2! 2@ 2VARIABLE 2CONSTANT 08JUL85RE) - 1 - 2 CODE 2! ( D ADR --) - 3 TYA SETUP JSR 3 # LDY - 4 [[ SP )Y LDA N )Y STA DEY 0< ?] - 5 1 # LDY POPTWO JMP END-CODE - 6 - 7 CODE 2@ ( ADR -- D) - 8 SP X) LDA N STA SP )Y LDA N 1+ STA - 9 SP 2DEC 3 # LDY -10 [[ N )Y LDA SP )Y STA DEY 0< ?] -11 XYNEXT JMP END-CODE -12 -13 -14 -15 -Screen 3 not modified - 0 \ - 1 - 2 : 2VARIABLE ( --) CREATE 4 ALLOT ; - 3 ( -- ADR) - 4 - 5 : 2CONSTANT ( D --) CREATE , , DOES> ( -- D) 2@ ; - 6 - 7 \ 2DUP EXISTS - 8 \ 2SWAP EXISTS - 9 \ 2DROP EXISTS -10 -11 -12 -13 -14 -15 diff --git a/sources/Apple1/2words.fth b/sources/Apple1/2words.fth new file mode 100644 index 0000000..d71d3fb --- /dev/null +++ b/sources/Apple1/2words.fth @@ -0,0 +1,68 @@ +\ *** Block No. 0 Hexblock 0 +\ Additional definitions for 32bit values cas 26jan06 + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ 2Words Loadscreen cas 26jan06 + +hex + &2 &3 thru +decimal + + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ 2! 2@ 2VARIABLE 2CONSTANT 08JUL85RE) + +CODE 2! ( D ADR --) + TYA SETUP JSR 3 # LDY + [[ SP )Y LDA N )Y STA DEY 0< ?] + 1 # LDY POPTWO JMP END-CODE + +CODE 2@ ( ADR -- D) + SP X) LDA N STA SP )Y LDA N 1+ STA + SP 2DEC 3 # LDY + [[ N )Y LDA SP )Y STA DEY 0< ?] + XYNEXT JMP END-CODE + + + + +\ *** Block No. 3 Hexblock 3 +\ + +: 2VARIABLE ( --) CREATE 4 ALLOT ; + ( -- ADR) + +: 2CONSTANT ( D --) CREATE , , DOES> ( -- D) 2@ ; + +\ 2DUP EXISTS +\ 2SWAP EXISTS +\ 2DROP EXISTS + + + + + + diff --git a/sources/Apple1/6502f83.fb.src b/sources/Apple1/6502f83.fb.src deleted file mode 100644 index c90ddc5..0000000 --- a/sources/Apple1/6502f83.fb.src +++ /dev/null @@ -1,2244 +0,0 @@ -Screen 0 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 ende 123 -14 -15 -Screen 1 not modified - 0 \ volksFORTH Loadscreen cas2013apr05 - 1 forth definitions - 2 : (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE - 3 - 4 $0300 CONSTANT BASEADDR \ base address of forth image - 5 $7F00 CONSTANT TOPADDR - 6 BASEADDR DISPLACE ! - 7 TARGET DEFINITIONS BASEADDR HERE! - 8 - 9 hex &01 &126 +THRU -10 decimal -11 \ ASSEMBLER NONRELOCATE -12 -13 .UNRESOLVED \ if this prints unresolved -14 \ definitions, check code -15 CR .( SAVE-TARGET 6502-FORTH83) -Screen 2 not modified - 0 \ FORTH PREAMBLE AND ID cas20130405 - 1 - 2 - 3 ASSEMBLER - 4 NOP 0 JMP HERE 2- >LABEL >COLD - 5 NOP 0 JMP HERE 2- >LABEL >RESTART - 6 - 7 HERE DUP ORIGIN! - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ Coldstartvalues and user variables cas2013apr05 - 1 \ - 2 - 3 0 JMP 0 JSR HERE 2- >LABEL >WAKE - 4 END-CODE - 5 - 6 0D6 ALLOT - 7 - 8 \ Bootlabel - 9 ," VolksForth-83 3.8 COMPILED 05apr13CS" -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ ZERO PAGE VARIABLES & NEXT cas 26jan06 - 1 \ adjust this to match your architecture - 2 - 3 - 4 20 DUP >LABEL RP 2+ - 5 DUP >LABEL UP 2+ - 6 DUP >LABEL PUTA 1+ - 7 DUP >LABEL SP 2+ - 8 DUP >LABEL NEXT - 9 DUP 5 + >LABEL IP -10 13 + >LABEL W -11 -12 W 8 + >LABEL N -13 -14 -15 -Screen 5 not modified - 0 \ NEXT, MOVED INTO ZERO PAGE 08APR85BP) - 1 - 2 LABEL BOOTNEXT - 3 -1 STA \ -1 IS DUMMY SP - 4 IP )Y LDA W 1+ STA - 5 -1 LDA W STA \ -1 IS DUMMY IP - 6 CLC IP LDA 2 # ADC IP STA - 7 CS NOT ?[ LABEL WJMP -1 ) JMP ]? - 8 IP 1+ INC WJMP BCS END-CODE - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 \ Bootnext and Endtrace cas 26jan06 - 1 HERE BOOTNEXT - >LABEL BOOTNEXTLEN - 2 - 3 CODE END-TRACE ( PATCH NEXT FOR TRACE ) - 4 0A5 # LDA NEXT 0A + STA - 5 IP # LDA NEXT 0B + STA - 6 069 # LDA NEXT 0C + STA - 7 02 # LDA NEXT 0D + STA - 8 NEXT JMP END-CODE - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ ;C: NOOP cas 26jan06 - 1 - 2 CREATE RECOVER ASSEMBLER - 3 PLA W STA PLA W 1+ STA - 4 W WDEC 0 JMP END-CODE - 5 - 6 HERE 2- >LABEL >RECOVER - 7 \ manual forward reference for JMP command - 8 - 9 -10 COMPILER ASSEMBLER ALSO DEFINITIONS -11 H : ;C: 0 T RECOVER JSR -12 END-CODE ] H ; -13 TARGET -14 CODE NOOP NEXT HERE 2- ! END-CODE -15 -Screen 8 not modified - 0 \ USER VARIABLES cas2013apr05 - 1 - 2 CONSTANT ORIGIN 8 UALLOT DROP - 3 \ FOR MULTITASKER - 4 - 5 \ Adjust memory values for data stack and return stack here - 6 USER S0 TOPADDR $F00 - S0 ! USER R0 TOPADDR $480 - R0 ! - 7 USER DP USER OFFSET 0 OFFSET ! - 8 USER BASE &10 BASE ! USER OUTPUT - 9 USER INPUT -10 USER ERRORHANDLER \ POINTER FOR ABORT" -CODE -11 USER VOC-LINK -12 USER UDP \ POINTS TO NEXT FREE ADDR IN USER -13 -14 -15 -Screen 9 not modified - 0 \ MANIPULATE SYSTEM POINTERS 29JAN85BP) - 1 - 2 CODE SP@ ( -- ADDR) - 3 SP LDA N STA SP 1+ LDA N 1+ STA - 4 N # LDX - 5 LABEL XPUSH - 6 SP 2DEC 1 ,X LDA SP )Y STA - 7 0 ,X LDA 0 # LDX PUTA JMP END-CODE - 8 - 9 CODE SP! ( ADDR --) -10 SP X) LDA TAX SP )Y LDA -11 SP 1+ STA SP STX 0 # LDX -12 NEXT JMP END-CODE -13 -14 -15 -Screen 10 not modified - 0 \ UP@ UP! XPULL (XYDROP (DROP cas 26jan06 - 1 CODE UP@ ( -- ADDR) - 2 UP # LDX XPUSH JMP END-CODE - 3 - 4 CODE UP! ( ADDR --) UP # LDX - 5 LABEL XPULL SP )Y LDA 1 ,X STA - 6 DEY SP )Y LDA 0 ,X STA - 7 LABEL (XYDROP 0 # LDX 1 # LDY - 8 LABEL (DROP SP 2INC NEXT JMP - 9 END-CODE RESTRICT -10 -11 -12 -13 -14 -15 -Screen 11 not modified - 0 \ MANIPULATE RETURNSTACK 16FEB85BP/KS) - 1 CODE RP@ ( -- ADDR ) - 2 RP # LDX XPUSH JMP END-CODE - 3 - 4 CODE RP! ( ADDR -- ) - 5 RP # LDX XPULL JMP END-CODE RESTRICT - 6 - 7 CODE >R ( 16B -- ) - 8 RP 2DEC SP X) LDA RP X) STA - 9 SP )Y LDA RP )Y STA (DROP JMP -10 END-CODE RESTRICT -11 -12 -13 -14 -15 -Screen 12 not modified - 0 \ R> (RDROP (NRDROP cas 26jan06 - 1 CODE R> ( -- 16B) - 2 SP 2DEC RP X) LDA SP X) STA - 3 RP )Y LDA SP )Y STA - 4 LABEL (RDROP 2 # LDA - 5 - 6 LABEL (NRDROP CLC RP ADC RP STA - 7 CS ?[ RP 1+ INC ]? - 8 NEXT JMP END-CODE RESTRICT - 9 -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ R@ RDROP EXIT ?EXIT 08APR85BP) - 1 - 2 CODE R@ ( -- 16B) - 3 SP 2DEC RP )Y LDA SP )Y STA - 4 RP X) LDA PUTA JMP - 5 END-CODE - 6 CODE RDROP (RDROP HERE 2- ! - 7 END-CODE RESTRICT - 8 - 9 CODE EXIT -10 RP X) LDA IP STA -11 RP )Y LDA IP 1+ STA -12 (RDROP JMP END-CODE -13 -14 -15 -Screen 14 not modified - 0 \ EXECUTE PERFORM 08APR85BP) - 1 - 2 CODE ?EXIT ( FLAG -- ) - 3 SP X) LDA SP )Y ORA - 4 PHP SP 2INC PLP - 5 ' EXIT @ BNE NEXT JMP - 6 END-CODE - 7 - 8 CODE EXECUTE ( ADDR --) - 9 SP X) LDA W STA -10 SP )Y LDA W 1+ STA -11 SP 2INC W 1- JMP END-CODE -12 -13 : PERFORM ( ADDR -- ) @ EXECUTE ; -14 -15 -Screen 15 not modified - 0 \ C@ C! CTOGGLE 10JAN85BP) - 1 - 2 CODE C@ ( ADDR -- 8B) - 3 - 4 SP X) LDA N STA SP )Y LDA N 1+ STA - 5 LABEL (C@ 0 # LDA SP )Y STA - 6 N X) LDA PUTA JMP END-CODE - 7 - 8 CODE C! ( 16B ADDR --) - 9 SP X) LDA N STA SP )Y LDA N 1+ STA -10 INY SP )Y LDA N X) STA DEY -11 LABEL (2DROP -12 SP LDA CLC 4 # ADC SP STA -13 CS ?[ SP 1+ INC ]? -14 NEXT JMP END-CODE -15 -Screen 16 not modified - 0 \ @ ! +! 08APR85BP) er14dez88 - 1 - 2 : CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; - 3 - 4 CODE @ ( ADDR -- 16B) - 5 SP X) LDA N STA SP )Y LDA N 1+ STA - 6 N )Y LDA SP )Y STA - 7 N X) LDA PUTA JMP END-CODE - 8 - 9 CODE ! ( 16B ADDR --) -10 SP X) LDA N STA SP )Y LDA N 1+ STA -11 INY SP )Y LDA N X) STA -12 INY SP )Y LDA 1 # LDY -13 LABEL (! -14 N )Y STA (2DROP JMP END-CODE -15 -Screen 17 not modified - 0 \ +! DROP cas 26jan06 - 1 - 2 CODE +! ( N ADDR --) - 3 SP X) LDA N STA SP )Y LDA N 1+ STA - 4 INY SP )Y LDA CLC N X) ADC N X) STA - 5 INY SP )Y LDA 1 # LDY N )Y ADC - 6 (! JMP END-CODE - 7 - 8 CODE DROP ( 16B --) - 9 (DROP HERE 2- ! END-CODE -10 -11 -12 -13 -14 -15 -Screen 18 not modified - 0 \ SWAP cas 26jan06 - 1 CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) - 2 SP )Y LDA TAX - 3 3 # LDY SP )Y LDA N STA - 4 TXA SP )Y STA - 5 N LDA 1 # LDY SP )Y STA - 6 INY 0 # LDX - 7 SP )Y LDA N STA SP X) LDA SP )Y STA - 8 DEY - 9 N LDA PUTA JMP END-CODE -10 -11 -12 -13 -14 -15 -Screen 19 not modified - 0 \ DUP ?DUP 08MAY85BP) cas 26jan06 - 1 - 2 CODE DUP ( 16B -- 16B 16B) - 3 SP 2DEC - 4 3 # LDY SP )Y LDA 1 # LDY SP )Y STA - 5 INY SP )Y LDA DEY - 6 PUTA JMP END-CODE - 7 - 8 CODE ?DUP ( 16B -- 16B 16B / FALSE) - 9 SP X) LDA SP )Y ORA -10 0= ?[ NEXT JMP ]? -11 ' DUP @ JMP END-CODE -12 \\ ?DUP and DUP in FORTH -13 \ : ?DUP ( 16B -- 16B 16B / FALSE) -14 \ DUP IF DUP THEN ; -15 \ : DUP SP@ @ ; -Screen 20 not modified - 0 \ OVER ROT 13JUN84KS) cas 26jan06 - 1 - 2 CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) - 3 SP 2DEC 4 # LDY SP )Y LDA SP X) STA - 4 INY SP )Y LDA 1 # LDY SP )Y STA - 5 NEXT JMP END-CODE - 6 - 7 \\ ROT OVER in FORTH - 8 \ : ROT >R SWAP R> SWAP ; - 9 \ : OVER >R DUP R> SWAP ; -10 -11 -12 -13 -14 -15 -Screen 21 not modified - 0 \ ROT cas 26jan06 - 1 CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) - 2 3 # LDY SP )Y LDA N 1+ STA - 3 1 # LDY SP )Y LDA 3 # LDY SP )Y STA - 4 5 # LDY SP )Y LDA N STA - 5 N 1+ LDA SP )Y STA - 6 1 # LDY N LDA SP )Y STA - 7 INY SP )Y LDA N 1+ STA - 8 SP X) LDA SP )Y STA - 9 4 # LDY SP )Y LDA SP X) STA -10 N 1+ LDA SP )Y STA -11 1 # LDY NEXT JMP END-CODE -12 -13 -14 -15 -Screen 22 not modified - 0 \ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06 - 1 : -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) - 2 ROT ROT ; - 3 - 4 : NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; - 5 - 6 : UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; - 7 - 8 : PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; - 9 -10 : ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; -11 -12 \\ : -ROLL ( N --) -13 >R DUP SP@ DUP 2+ DUP 2+ SWAP -14 R@ 2* CMOVE R> 1+ 2* + ! ; -15 -Screen 23 not modified - 0 \ DOUBLE WORD STACK MANIP. 21APR83KS) - 1 - 2 : 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; - 3 - 4 CODE 2DROP ( 32B -- ) - 5 (2DROP HERE 2- ! END-CODE - 6 - 7 : 2DUP ( 32B -- 32B 32B) OVER OVER ; - 8 - 9 \ : 2DROP ( 32B -- ) DROP DROP ; -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 \ + AND OR XOR 08APR85BP) - 1 COMPILER ASSEMBLER ALSO DEFINITIONS - 2 - 3 H : DYADOP ( OPCODE --) T - 4 INY SP X) LDA DUP C, SP C, SP )Y STA - 5 DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA - 6 (XYDROP JMP H ; - 7 TARGET - 8 - 9 CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE -10 -11 CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE -12 -13 CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE -14 -15 CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE -Screen 25 not modified - 0 \ - NOT NEGATE 24DEC83KS) - 1 - 2 CODE - ( N1 N2 -- N3) - 3 INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA - 4 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE - 5 - 6 CODE NOT ( 16B1 -- 16B2) CLC - 7 LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA - 8 NEXT JMP END-CODE - 9 -10 CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE -11 -12 \ : - NEGATE + ; -13 -14 -15 -Screen 26 not modified - 0 \ DNEGATE SETUP D+ 14JUN84KS) - 1 - 2 CODE DNEGATE ( D1 -- -D1) - 3 INY SEC - 4 TXA SP )Y SBC SP )Y STA INY - 5 TXA SP )Y SBC SP )Y STA - 6 TXA SP X) SBC SP X) STA 1 # LDY - 7 TXA SP )Y SBC SP )Y STA - 8 NEXT JMP END-CODE - 9 LABEL SETUP ( QUAN IN A) -10 .A ASL TAX TAY DEY -11 [[ SP )Y LDA N ,Y STA DEY 0< ?] -12 TXA CLC SP ADC SP STA -13 CS ?[ SP 1+ INC ]? -14 0 # LDX 1 # LDY RTS END-CODE -15 -Screen 27 not modified - 0 \ D+ cas 26jan06 - 1 CODE D+ ( D1 D2 -- D3) - 2 2 # LDA SETUP JSR INY - 3 SP )Y LDA CLC N 2+ ADC SP )Y STA INY - 4 SP )Y LDA N 3 + ADC SP )Y STA - 5 SP X) LDA N ADC SP X) STA 1 # LDY - 6 SP )Y LDA N 1+ ADC SP )Y STA - 7 NEXT JMP END-CODE - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 28 not modified - 0 \ 1+ 2+ 3+ 1- 2- 08APR85BP) - 1 - 2 CODE 1+ ( N1 -- N2) 1 # LDA - 3 LABEL N+ CLC SP X) ADC - 4 CS NOT ?[ PUTA JMP ]? - 5 SP X) STA SP )Y LDA 0 # ADC SP )Y STA - 6 NEXT JMP END-CODE - 7 - 8 CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE - 9 -10 CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE -11 -12 | CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE -13 -14 | CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE -15 -Screen 29 not modified - 0 \ NUMBER CONSTANTS 24DEC83KS) - 1 CODE 1- ( N1 -- N2) SEC - 2 LABEL (1- SP X) LDA 1 # SBC - 3 CS ?[ PUTA JMP ]? - 4 SP X) STA SP )Y LDA 0 # SBC SP )Y STA - 5 NEXT JMP END-CODE - 6 CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE - 7 - 8 -1 CONSTANT TRUE 0 CONSTANT FALSE - 9 ' TRUE ALIAS -1 ' FALSE ALIAS 0 -10 -11 1 CONSTANT 1 2 CONSTANT 2 -12 3 CONSTANT 3 4 CONSTANT 4 -13 -14 : ON ( ADDR -- ) TRUE SWAP ! ; -15 : OFF ( ADDR -- ) FALSE SWAP ! ; -Screen 30 not modified - 0 \ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05 - 1 - 2 CODE CLIT ( -- 8B) - 3 SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC - 4 NEXT JMP END-CODE RESTRICT - 5 - 6 CODE LIT ( -- 16B) - 7 SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA - 8 LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT - 9 : LITERAL ( 16B --) DUP 0FF00 AND -10 IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; -11 IMMEDIATE RESTRICT -12 -13 \\ : LIT R> DUP 2+ >R @ ; -14 : CLIT R> DUP 1+ >R C@ ; -15 -Screen 31 not modified - 0 \ COMPARISION CODE WORDS 13JUN84KS) - 1 CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ - 2 LABEL PUTTRUE 0FF # LDA 024 C, ]? - 3 LABEL PUTFALSE TXA SP )Y STA - 4 PUTA JMP END-CODE - 5 - 6 CODE 0= ( 16B -- FLAG) - 7 SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE - 8 - 9 CODE UWITHIN ( U1 [LOW UP[ -- FLAG) -10 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP -11 SP )Y LDA N 1+ SBC -12 CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP -13 SP )Y LDA N 3 + SBC -14 PUTTRUE BCS ]? -15 PUTFALSE JMP END-CODE -Screen 32 not modified - 0 \ COMPARISION CODE WORDS 13JUN84KS) - 1 - 2 CODE < ( N1 N2 -- FLAG) - 3 SP X) LDA N STA SP )Y LDA N 1+ STA - 4 SP 2INC - 5 N 1+ LDA SP )Y EOR ' 0< @ BMI - 6 SP X) LDA N CMP SP )Y LDA N 1+ SBC - 7 ' 0< @ 2+ JMP END-CODE - 8 - 9 CODE U< ( U1 U2 -- FLAG) -10 SP X) LDA N STA SP )Y LDA N 1+ STA -11 SP 2INC -12 SP X) LDA N CMP SP )Y LDA N 1+ SBC -13 CS NOT ?[ PUTTRUE JMP ]? -14 PUTFALSE JMP END-CODE -15 -Screen 33 not modified - 0 \ COMPARISION WORDS 24DEC83KS) - 1 - 2 | : 0< 8000 AND 0<> ; - 3 - 4 : > ( N1 N2 -- FLAG) SWAP < ; - 5 : 0> ( N -- FLAG) NEGATE 0< ; - 6 : 0<> ( N -- FLAG) 0= NOT ; - 7 : U> ( U1 U2 -- FLAG) SWAP U< ; - 8 : = ( N1 N2 -- FLAG) - 0= ; - 9 : D0= ( D -- FLAG) OR 0= ; -10 : D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; -11 : D< ( D1 D2 -- FLAG) ROT 2DUP - -12 IF > NIP NIP ELSE 2DROP U< THEN ; -13 -14 -15 -Screen 34 not modified - 0 \ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06 - 1 - 2 | : MINIMAX ( N1 N2 FLAG -- N3) - 3 RDROP IF SWAP THEN DROP ; - 4 - 5 : MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT - 6 : MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT - 7 : UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT - 8 : UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT - 9 -10 : EXTEND ( N -- D) DUP 0< ; -11 -12 : DABS ( D -- UD) EXTEND IF DNEGATE THEN ; -13 : ABS ( N -- U) EXTEND IF NEGATE THEN ; -14 -15 -Screen 35 not modified - 0 \ LOOP PRIMITIVES 08FEB85BP/KS) - 1 - 2 | : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; - 3 - 4 - 5 : (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT - 6 - 7 : (?DO ( LIMIT START -- ) - 8 OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT - 9 -10 : BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; -11 -12 CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT -13 -14 \\ DODO PUTS "INDEX \ LIMIT \ -15 ADR.OF.DO" ON RETURN-STACK -Screen 36 not modified - 0 \ (LOOP (+LOOP 08APR85BP) - 1 CODE (LOOP - 2 CLC 1 # LDA RP X) ADC RP X) STA - 3 CS ?[ RP )Y LDA 0 # ADC RP )Y STA - 4 CS ?[ NEXT JMP ]? ]? - 5 LABEL DOLOOP 5 # LDY - 6 RP )Y LDA IP 1+ STA DEY - 7 RP )Y LDA IP STA 1 # LDY - 8 NEXT JMP END-CODE RESTRICT - 9 -10 CODE (+LOOP -11 CLC SP X) LDA RP X) ADC RP X) STA -12 SP )Y LDA RP )Y ADC RP )Y STA -13 .A ROR SP )Y EOR -14 PHP SP 2INC PLP DOLOOP BPL -15 NEXT JMP END-CODE RESTRICT -Screen 37 not modified - 0 \ LOOP INDICES 08APR85BP) - 1 - 2 CODE I ( -- N) 0 # LDY - 3 LABEL LOOPINDEX SP 2DEC CLC - 4 RP )Y LDA INY INY - 5 RP )Y ADC SP X) STA DEY - 6 RP )Y LDA INY INY - 7 RP )Y ADC 1 # LDY SP )Y STA - 8 NEXT JMP END-CODE RESTRICT - 9 -10 CODE J ( -- N) -11 6 # LDY LOOPINDEX BNE -12 END-CODE RESTRICT -13 -14 -15 -Screen 38 not modified - 0 \ BRANCHING 24DEC83KS) - 1 - 2 CODE BRANCH - 3 CLC IP LDA IP X) ADC N STA - 4 IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA - 5 NEXT JMP END-CODE RESTRICT - 6 - 7 CODE ?BRANCH - 8 SP X) LDA SP )Y ORA PHP SP 2INC PLP - 9 ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT -10 -11 \\ : BRANCH R> DUP @ + >R ; RESTRICT -12 -13 : ?BRANCH -14 0= R> OVER NOT OVER 2+ AND -ROT -15 DUP @ + AND OR >R ; RESTRICT -Screen 39 not modified - 0 \ RESOLVE LOOPS AND BRANCHES 03FEB85BP) - 1 - 2 : >MARK ( -- ADDR) HERE 0 , ; - 3 - 4 : >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; - 5 - 6 : MARK 1 ; IMMEDIATE RESTRICT - 3 : THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT - 4 : ELSE 1 ?PAIRS COMPILE BRANCH >MARK - 5 SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT - 6 : BEGIN MARK -2 2SWAP ; IMMEDIATE RESTRICT - 9 | : (REPTIL RESOLVE REPEAT ; -11 -12 : REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT -13 -14 : UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT -15 -Screen 42 not modified - 0 \ LOOPS 29JAN85KS/BP) - 1 - 2 : DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT - 3 - 4 : ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT - 5 - 6 : LOOP 3 ?PAIRS COMPILE (LOOP - 7 COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT - 8 - 9 : +LOOP 3 ?PAIRS COMPILE (+LOOP -10 COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT -11 -12 : LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT -13 -14 \\ RETURNSTACK: CALLADR \ INDEX -15 LIMIT \ ADR OF DO -Screen 43 not modified - 0 \ UM* BP/KS13.2.85) - 1 CODE UM* ( U1 U2 -- UD) - 2 SP )Y LDA N STA SP X) LDA N 1+ STA - 3 INY N 2 + STX N 3 + STX 010 # LDX - 4 [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL - 5 CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA - 6 INY SP )Y LDA DEY N 2 + ADC N 2 + STA - 7 CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? - 8 DEX 0= ?] - 9 N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY -10 N LDA SP )Y STA N 1+ LDA SP X) STA -11 NEXT JMP END-CODE -12 -13 \\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0 -14 DO DUP 2/ >R 1 AND IF 2OVER D+ THEN -15 >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; -Screen 44 not modified - 0 \ M* 2* 04JUL84KS) - 1 - 2 : M* ( N1 N2 -- D) - 3 DUP 0< DUP >R IF NEGATE THEN - 4 SWAP DUP 0< IF NEGATE R> NOT >R THEN - 5 UM* R> IF DNEGATE THEN ; - 6 - 7 : * ( N N -- PROD) UM* DROP ; - 8 - 9 CODE 2* ( N1 -- N2) -10 SP X) LDA .A ASL SP X) STA -11 SP )Y LDA .A ROL SP )Y STA -12 NEXT JMP END-CODE -13 | : 2* DUP + ; -14 -15 -Screen 45 not modified - 0 \ UM/MOD 04JUL84KS) - 1 - 2 | : DIVOVL - 3 TRUE ABORT" DIVISION OVERFLOW" ; - 4 - 5 CODE UM/MOD ( UD U -- UREM UQUOT) - 6 SP X) LDA N 5 + STA - 7 SP )Y LDA N 4 + STA SP 2INC - 8 SP X) LDA N 1+ STA - 9 SP )Y LDA N STA INY -10 SP )Y LDA N 3 + STA INY -11 SP )Y LDA N 2+ STA 011 # LDX CLC -12 [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC -13 TAY N LDA N 4 + SBC -14 CS NOT ?[ N 6 + ROL ]? -15 CS ?[ N STA N 1+ STY ]? -Screen 46 not modified - 0 \ - 1 N 3 + ROL N 2+ ROL N 1+ ROL N ROL - 2 DEX 0= ?] - 3 1 # LDY N ROR N 1+ ROR - 4 CS ?[ ;C: DIVOVL ; ASSEMBLER ]? - 5 N 2+ LDA SP )Y STA INY - 6 N 1+ LDA SP )Y STA INY - 7 N LDA SP )Y STA 1 # LDY - 8 N 3 + LDA - 9 PUTA JMP END-CODE -10 -11 -12 -13 -14 -15 -Screen 47 not modified - 0 \ 2/ M/MOD 24DEC83KS) - 1 - 2 : M/MOD ( D N -- MOD QUOT) - 3 DUP >R ABS OVER - 4 0< IF UNDER + SWAP THEN - 5 UM/MOD R@ - 6 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- - 7 THEN THEN RDROP ; - 8 - 9 CODE 2/ ( N1 -- N2) -10 SP )Y LDA .A ASL -11 SP )Y LDA .A ROR SP )Y STA -12 SP X) LDA .A ROR -13 PUTA JMP END-CODE -14 -15 -Screen 48 not modified - 0 \ /MOD / MOD */MOD */ U/MOD UD/MOD KS) - 1 - 2 : /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; - 3 - 4 : / ( N1 N2 -- QUOT) /MOD NIP ; - 5 - 6 : MOD ( N1 N2 -- REM) /MOD DROP ; - 7 - 8 : */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; - 9 -10 : */ ( N1 N2 N3 -- QUOT) */MOD NIP ; -11 -12 : U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; -13 -14 : UD/MOD ( UD1 U2 -- UREM UDQUOT) -15 >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; -Screen 49 not modified - 0 \ CMOVE CMOVE> (CMOVE> BP 08APR85) - 1 - 2 CODE CMOVE ( FROM TO QUAN --) - 3 3 # LDA SETUP JSR DEY - 4 [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ - 5 1 # LDY NEXT JMP ]? ]? - 6 N 4 + )Y LDA N 2+ )Y STA INY 0= ?] - 7 N 5 + INC N 3 + INC ]] END-CODE - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 50 not modified - 0 \ CMOVE> MOVE cas 26jan06 - 1 CODE CMOVE> ( FROM TO QUAN --) - 2 3 # LDA SETUP JSR - 3 CLC N 1+ LDA N 3 + ADC N 3 + STA - 4 CLC N 1+ LDA N 5 + ADC N 5 + STA - 5 N 1+ INC N LDY CLC CS ?[ - 6 LABEL (CMOVE> - 7 DEY N 4 + )Y LDA N 2+ )Y STA ]? - 8 TYA (CMOVE> BNE - 9 N 3 + DEC N 5 + DEC N 1+ DEC -10 (CMOVE> BNE 1 # LDY -11 NEXT JMP END-CODE -12 -13 : MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN -14 R> CMOVE ; -15 -Screen 51 not modified - 0 \ PLACE COUNT ERASE 16FEB85BP/KS) - 1 - 2 : PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; - 3 - 4 CODE COUNT ( ADDR -- ADDR+1 LEN) - 5 SP X) LDA N STA CLC 1 # ADC SP X) STA - 6 SP )Y LDA N 1+ STA 0 # ADC SP )Y STA - 7 SP 2DEC (C@ JMP END-CODE - 8 - 9 \ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; -10 -11 : ERASE ( ADDR QUAN --) 0 FILL ; -12 -13 -14 -15 -Screen 52 not modified - 0 \ FILL 11JUN85BP) - 1 - 2 CODE FILL ( ADDR QUAN 8B -- ) - 3 3 # LDA SETUP JSR DEY - 4 N LDA N 3 + LDX - 5 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] - 6 N 5 + INC DEX 0= ?] - 7 ]? N 2+ LDX - 8 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] - 9 ]? 1 # LDY -10 NEXT JMP END-CODE -11 -12 \\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP -13 IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; -14 -15 -Screen 53 not modified - 0 \ HERE PAD ALLOT , C, COMPILE 24DEC83KS) - 1 - 2 : HERE ( -- ADDR) DP @ ; - 3 - 4 : PAD ( -- ADDR) HERE 042 + ; - 5 - 6 : ALLOT ( N --) DP +! ; - 7 - 8 : , ( 16B --) HERE ! 2 ALLOT ; - 9 -10 : C, ( 8B --) HERE C! 1 ALLOT ; -11 -12 : COMPILE R> DUP 2+ >R @ , ; RESTRICT -13 -14 -15 -Screen 54 not modified - 0 \ INPUT STRINGS 24DEC83KS) - 1 - 2 VARIABLE #TIB 0 #TIB ! - 3 VARIABLE >TIB $100 >TIB ! \ 050 ALLOT - 4 VARIABLE >IN 0 >IN ! - 5 VARIABLE BLK 0 BLK ! - 6 VARIABLE SPAN 0 SPAN ! - 7 - 8 : TIB ( -- ADDR ) >TIB @ ; - 9 -10 : QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; -11 -12 -13 -14 -15 -Screen 55 not modified - 0 \ SCAN SKIP /STRING 12OCT84BP) - 1 - 2 : SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R - 3 BEGIN DUP WHILE OVER C@ R@ - - 4 WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; - 5 - 6 : SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R - 7 BEGIN DUP WHILE OVER C@ R@ = - 8 WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; - 9 -10 -11 : /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) -12 OVER UMIN ROT OVER + -ROT - ; -13 -14 -15 -Screen 56 not modified - 0 \ CAPITAL 03APR85BP) - 1 (C LABEL (CAPITAL \ FOR COMMODORE ONLY - 2 PHA 0DF # AND \ 2ND UPPER TO LOWER - 3 ASCII A # CMP - 4 CS ?[ ASCII Z 1+ # CMP - 5 CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS - 6 ]? ]? PLA RTS END-CODE ) - 7 - 8 LABEL (CAPITAL \ FOR ASCII ONLY - 9 ASCII a # CMP -10 CS ?[ ASCII z 1+ # CMP -11 CC ?[ SEC ASCII a ASCII A - # SBC -12 ]? ]? RTS END-CODE -13 -14 CODE CAPITAL ( CHAR -- CHAR' ) -15 SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE -Screen 57 not modified - 0 \ CAPITALIZE 03APR85BP) - 1 - 2 CODE CAPITALIZE ( STRING -- STRING ) - 3 SP X) LDA N STA SP )Y LDA N 1+ STA - 4 N X) LDA N 2+ STA DEY - 5 [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? - 6 INY N )Y LDA (CAPITAL JSR N )Y STA - 7 ]] END-CODE - 8 - 9 \\ : CAPITALIZE ( STRING -- STRING ) -10 DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; -11 -12 \\ CAPITAL ( CHAR -- CHAR ) -13 ASCII A ASCII Z 1+ UWITHIN -14 IF I C@ [ ASCII A ASCII A - ] LITERAL - ; -15 -Screen 58 not modified - 0 \ (WORD 08APR85BP) - 1 - 2 | CODE (WORD ( CHAR ADR0 LEN0 -- ADR) - 3 \ N : LENGTH OF SOURCE - 4 \ N+2 : PTR IN SOURCE / NEXT CHAR - 5 \ N+4 : STRING START ADRESS - 6 \ N+6 : STRING LENGTH - 7 N 6 + STX \ 0 =: STRING_LENGTH - 8 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] - 9 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA -10 \ >IN+ADR0 =: N+2 -11 >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA -12 \ LEN0->IN =: N -13 N 1+ LDA >IN 1+ SBC N 1+ STA -14 CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED -15 SP )Y LDA >IN 1+ STA -Screen 59 not modified - 0 \ (WORD 08APR85BP) - 1 - 2 ][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S - 3 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 - 4 0= ?[[ N 2+ WINC N WDEC ]]? - 5 N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS - 6 N 3 + LDA N 5 + STA - 7 [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR - 8 N 2+ WINC N WDEC PLP - 9 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH -10 N LDA N 1+ ORA -11 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) -12 SEC 2 # LDY -13 \ ADR_AFTER_STRING - ADR0 =: >IN) -14 N 2+ LDA SP )Y SBC >IN STA INY -15 N 3 + LDA SP )Y SBC >IN 1+ STA -Screen 60 not modified - 0 \ (WORD 08APR85BP) - 1 - 2 ]? \ FROM 1ST ][, STREAM WAS EXHAUSTED - 3 \ WHEN WORD CALLED) - 4 CLC 4 # LDA SP ADC SP STA - 5 CS ?[ SP 1+ INC ]? \ 2DROP - 6 USER' DP # LDY UP )Y LDA - 7 SP X) STA N STA INY - 8 UP )Y LDA 1 # LDY - 9 SP )Y STA N 1+ STA \ DP @ -10 DEY N 6 + LDA \ STORE COUNT BYTE FIRST -11 [[ N )Y STA N 4 + )Y LDA INY -12 N 6 + DEC 0< ?] -13 020 # LDA N )Y STA \ ADD A BLANK -14 1 # LDY NEXT JMP END-CODE -15 -Screen 61 not modified - 0 \ SOURCE WORD PARSE NAME 08APR85BP) - 1 - 2 : SOURCE ( -- ADDR LEN) - 3 BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ; - 4 - 5 : WORD ( CHAR -- ADDR) SOURCE (WORD ; - 6 - 7 : PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP - 8 R> SCAN >R OVER - DUP R> 0<> - >IN +! ; - 9 -10 : NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; -11 -12 \\ : WORD ( CHAR -- ADDR) >R -13 SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> -14 SCAN >R ROT OVER SWAP - R> 0<> - >IN ! -15 OVER - HERE PLACE BL HERE COUNT + C! HERE ; -Screen 62 not modified - 0 \ STATE ASCII ," (" " 24DEC83KS) - 1 - 2 VARIABLE STATE 0 STATE ! - 3 - 4 : ASCII BL WORD 1+ C@ STATE @ - 5 IF [COMPILE] LITERAL THEN ; IMMEDIATE - 6 - 7 : ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; - 8 - 9 : "LIT R> R> UNDER COUNT + >R >R ; RESTRICT -10 -11 : (" "LIT ; RESTRICT -12 -13 : " COMPILE (" ," ; IMMEDIATE RESTRICT -14 -15 -Screen 63 not modified - 0 \ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) - 1 : (." "LIT COUNT TYPE ; RESTRICT - 2 - 3 : ." COMPILE (." ," ; IMMEDIATE RESTRICT - 4 - 5 : ( ASCII ) PARSE 2DROP ; IMMEDIATE - 6 - 7 : .( ASCII ) PARSE TYPE ; IMMEDIATE - 8 - 9 : \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE -10 -11 : \\ B/BLK >IN ! ; IMMEDIATE -12 -13 : \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; -14 -15 : HEX 010 BASE ! ; : DECIMAL 0A BASE ! ; -Screen 64 not modified - 0 \ NUMBER CONV.: DIGIT? ACCUMULATE KS) - 1 : DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) - 2 ASCII 0 - DUP 9 U> - 3 IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> - 4 IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN - 5 BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; - 6 - 7 : ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) - 8 SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; - 9 -10 : CONVERT ( +D1 ADDR0 -- +D2 ADDR2) -11 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; -12 -13 | : END? ( -- FLAG ) PTR @ 0= ; -14 | : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; -15 | : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; -Screen 65 not modified - 0 \ ?NONUM ?NUM FIXBASE? 13FEB85KS) - 1 - 2 VARIABLE DPL -1 DPL ! - 3 - 4 | : ?NONUM ( FLAG -- EXIT IF TRUE ) - 5 IF RDROP 2DROP DROP RDROP FALSE THEN ; - 6 - 7 | : ?NUM ( FLAG -- EXIT IF TRUE ) - 8 IF RDROP DROP R> IF DNEGATE THEN - 9 ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; -10 | : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) -11 ASCII & CASE? IF 0A TRUE EXIT THEN -12 ASCII $ CASE? IF 10 TRUE EXIT THEN -13 ASCII H CASE? IF 10 TRUE EXIT THEN -14 ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ; -15 -Screen 66 not modified - 0 \ 13FEB85KS) - 1 - 2 | : PUNCTUATION? ( CHAR -- FLAG) - 3 ASCII , OVER = SWAP ASCII . = OR ; - 4 - 5 | : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; - 6 - 7 | VARIABLE PTR \ POINTS INTO STRING - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 67 not modified - 0 \ (NUMBER NUMBER 13FEB85KS) - 1 : NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) - 2 BASE PUSH DUP COUNT PTR ! DPL ON - 3 0 >R ( +SIGN) - 4 0.0 ROT END? ?NONUM CHAR - 5 ASCII - CASE? - 6 IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? - 7 IF BASE ! END? ?NONUM CHAR THEN - 8 BEGIN DIGIT? 0= ?NONUM - 9 BEGIN ACCUMULATE ?DPL END? ?NUM -10 CHAR DIGIT? 0= UNTIL -11 PREVIOUS PUNCTUATION? 0= ?NONUM -12 DPL OFF END? ?NUM CHAR -13 REPEAT ; -14 : NUMBER ( STRING -- D ) -15 NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; -Screen 68 not modified - 0 \ HIDE REVEAL IMMEDIATE RESTRICT KS) - 1 VARIABLE LAST 0 LAST ! - 2 - 3 | : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; - 4 - 5 : HIDE LAST? IF 2- @ CURRENT @ ! THEN ; - 6 - 7 : REVEAL LAST? IF 2- CURRENT @ ! THEN ; - 8 - 9 : RECURSIVE REVEAL ; IMMEDIATE RESTRICT -10 -11 | : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; -12 -13 : IMMEDIATE 040 FLAG! ; -14 -15 : RESTRICT 080 FLAG! ; -Screen 69 not modified - 0 \ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06 - 1 - 2 CODE CLEARSTACK USER' S0 # LDY - 3 UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA - 4 1 # LDY NEXT JMP END-CODE - 5 - 6 : HALLOT ( QUAN -- ) S0 @ OVER - SWAP - 7 SP@ 2+ DUP ROT - DUP S0 ! - 8 2 PICK OVER - MOVE CLEARSTACK S0 ! ; - 9 -10 : HEAP ( -- ADDR) S0 @ 6+ ; -11 -12 : HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; -13 -14 | : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - -15 DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; -Screen 70 not modified - 0 \ DOES> ; 30DEC84KS/BP) - 1 - 2 LABEL (DODOES> RP 2DEC - 3 IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP - 4 CLC W X) LDA 3 # ADC IP STA - 5 TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP - 6 LABEL DOCREATE - 7 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE - 8 - 9 | : (;CODE R> LAST @ NAME> ! ; -10 -11 : DOES> COMPILE (;CODE 04C C, -12 COMPILE (DODOES> ; IMMEDIATE RESTRICT -13 -14 -15 -Screen 71 not modified - 0 \ 6502-ALIGN ?HEAD \ 08SEP84BP) - 1 - 2 | : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ; - 3 - 4 - 5 | : 6502-ALIGN/2 ( LFA -- LFA ) - 6 HERE 0FF AND 0FF = - 7 IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID - 8 1 LAST +! 1 ALLOT THEN ; - 9 -10 VARIABLE ?HEAD 0 ?HEAD ! -11 -12 : | ?HEAD @ ?EXIT -1 ?HEAD ! ; -13 -14 -15 -Screen 72 not modified - 0 \ WARNING CREATE 30DEC84BP) - 1 - 2 VARIABLE WARNING 0 WARNING ! - 3 - 4 | : EXISTS? - 5 WARNING @ ?EXIT - 6 LAST @ CURRENT @ (FIND NIP - 7 IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; - 8 - 9 : CREATE HERE BLK @ , CURRENT @ @ , -10 NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" -11 HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ -12 IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE -13 HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! -14 ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , -15 ;CODE DOCREATE JMP END-CODE -Screen 73 not modified - 0 \ NFA? 30DEC84BP) - 1 | CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) - 2 SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC - 3 [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA - 4 N 2+ ORA 0= ?[ PUTFALSE JMP ]? - 5 N 2+ )Y LDA SP )Y STA N 1+ STA - 6 N 2+ X) LDA SP X) STA N STA - 7 N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK - 8 N 2INC N X) LDA PHA SEC 01F # AND - 9 N ADC N STA CS ?[ N 1+ INC ]? -10 PLA 020 # AND 0= NOT -11 ?[ N )Y LDA PHA -12 N X) LDA N STA PLA N 1+ STA ]? -13 N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 -14 N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY -15 ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT -Screen 74 not modified - 0 \ >NAME NAME> >BODY .NAME 03FEB85BP) - 1 - 2 : >NAME ( CFA -- NFA / FALSE) VOC-LINK - 3 BEGIN @ DUP WHILE 2DUP 4 - SWAP - 4 NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; - 5 - 6 | : (NAME> ( NFA -- CFA) COUNT 01F AND + ; - 7 - 8 : NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ; - 9 -10 : >BODY ( CFA -- PFA) 2+ ; -11 -12 : .NAME ( NFA --) -13 ?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE -14 ELSE ." ???" THEN SPACE ; -15 -Screen 75 not modified - 0 \ : ; CONSTANT VARIABLE 09JAN85KS/BP) - 1 - 2 : : CREATE HIDE CURRENT @ CONTEXT ! ] 0 - 3 ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE - 4 RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA - 5 W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA - 6 NEXT JMP END-CODE - 7 - 8 : ; 0 ?PAIRS COMPILE EXIT - 9 [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT -10 -11 : CONSTANT ( 16B --) CREATE , -12 ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY -13 W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE -14 -15 : VARIABLE CREATE 2 ALLOT ; -Screen 76 not modified - 0 \ UALLOT USER ALIAS 10JAN85KS/BP) - 1 - 2 : UALLOT ( QUAN -- OFFSET) - 3 DUP UDP @ + 0FF U> ABORT" USERAREA FULL" - 4 UDP @ SWAP UDP +! ; - 5 - 6 : USER CREATE 2 UALLOT C, - 7 ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA - 8 TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE - 9 -10 : ALIAS ( CFA --) -11 CREATE LAST @ DUP C@ 020 AND -12 IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ; -13 -14 -15 -Screen 77 not modified - 0 \ VOC-LINK VP CURRENT CONTEXT ALSO BP) - 1 CREATE VP 10 ALLOT - 2 - 3 VARIABLE CURRENT - 4 - 5 : CONTEXT ( -- ADR ) VP DUP @ + 2+ ; - 6 - 7 | : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; - 8 \ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : - 9 \ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER -10 -11 : ALSO VP @ -12 0A > ERROR" VOCABULARY STACK FULL" -13 CONTEXT @ 2 VP +! CONTEXT ! ; -14 -15 : TOSS -2 VP +! ; -Screen 78 not modified - 0 \ VOCABULARY FORTH ONLY FORTH-83 KS/BP) - 1 - 2 : VOCABULARY CREATE 0 , 0 , - 3 HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; - 4 - 5 \ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK - 6 - 7 VOCABULARY FORTH - 8 - 9 VOCABULARY ONLY -10 ] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! -11 -12 : ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; -13 -14 -15 -Screen 79 not modified - 0 \ DEFINITIONS ORDER WORDS 13JAN84BP/KS) - 1 - 2 : DEFINITIONS CONTEXT @ CURRENT ! ; - 3 - 4 | : .VOC ( ADR -- ) @ 2- >NAME .NAME ; - 5 - 6 : ORDER - 7 THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; - 8 - 9 : WORDS CONTEXT @ -10 BEGIN @ DUP STOP? 0= AND -11 WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; -12 -13 -14 -15 -Screen 80 not modified - 0 \ (FIND 08APR85BP) - 1 - 2 CODE (FIND ( STRING THREAD - 3 -- STRING FALSE / NAMEFIELD TRUE) - 4 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] - 5 N 2+ X) LDA 01F # AND N 4 + STA - 6 LABEL FINDLOOP 0 # LDY - 7 N )Y LDA TAX INY - 8 N )Y LDA N 1+ STA N STX N ORA - 9 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? -10 INY N )Y LDA 01F # AND N 4 + CMP -11 FINDLOOP BNE \ COUNTBYTE MATCH -12 CLC 2 # LDA N ADC N 5 + STA -13 0 # LDA N 1+ ADC N 6 + STA -14 N 4 + LDY -15 [[ N 2+ )Y LDA N 5 + )Y CMP -Screen 81 not modified - 0 \ - 1 FINDLOOP BNE DEY 0= ?] - 2 3 # LDY N 6 + LDA SP )Y STA DEY - 3 N 5 + LDA SP )Y STA - 4 DEY 0 # LDX PUTTRUE JMP END-CODE - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 82 not modified - 0 \ FOUND 29JAN85BP) - 1 - 2 | CODE FOUND ( NFA -- CFA N ) - 3 SP X) LDA N STA SP )Y LDA N 1+ STA - 4 N X) LDA N 2+ STA 01F # AND SEC N ADC N STA - 5 CS ?[ N 1+ INC ]? - 6 N 2+ LDA 020 # AND - 7 0= ?[ N LDA SP X) STA N 1+ LDA - 8 ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA - 9 SP 2DEC N 2+ LDA 0< ?[ INY ]? -10 .A ASL -11 0< NOT ?[ TYA 0FF # EOR TAY INY ]? -12 TYA SP X) STA -13 0< ?[ 0FF # LDA 24 C, ]? -14 TXA 1 # LDY SP )Y STA -15 NEXT JMP END-CODE -Screen 83 not modified - 0 \\ - 1 - 2 | : FOUND ( NFA -- CFA N ) - 3 DUP C@ >R (NAME> - 4 R@ 020 AND IF @ THEN - 5 -1 R@ 080 AND IF 1- THEN - 6 R> 040 AND IF NEGATE THEN ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 84 not modified - 0 \ FIND ' ['] 13JAN85BP) cas2013apr05 - 1 - 2 : FIND ( STRING -- CFA N / STRING FALSE) - 3 CONTEXT DUP @ OVER 2- @ = IF 2- THEN - 4 BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN - 5 OVER VP 2+ U> - 6 WHILE SWAP 2- REPEAT NIP FALSE ; - 7 - 8 : ' ( -- CFA ) NAME FIND 0= ABORT" WHAT?" ; - 9 -10 : [COMPILE] ' , ; IMMEDIATE RESTRICT -11 -12 : ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT -13 -14 : NULLSTRING? ( STRING -- STRING FALSE / TRUE) -15 DUP C@ 0= DUP IF NIP THEN ; -Screen 85 not modified - 0 \ >INTERPRET 28FEB85BP) - 1 - 2 LABEL JUMP - 3 INY CLC W )Y LDA 2 # ADC IP STA - 4 INY W )Y LDA 0 # ADC IP 1+ STA - 5 1 # LDY NEXT JMP END-CODE - 6 VARIABLE >INTERPRET - 7 - 8 JUMP ' >INTERPRET ! - 9 -10 \\ MAKE VARIABLE >INTERPRET TO SPECIAL -11 DEFER -12 -13 -14 -15 -Screen 86 not modified - 0 \ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06 - 1 - 2 DEFER NOTFOUND - 3 - 4 : NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 - 5 - 6 ' NO.EXTENSIONS IS NOTFOUND - 7 - 8 : INTERPRET >INTERPRET ; -2 ALLOT - 9 -10 | : INTERACTIVE ?STACK NAME FIND ?DUP -11 IF 1 AND IF EXECUTE >INTERPRET THEN -12 ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? -13 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT -14 -15 ' INTERACTIVE >INTERPRET ! -Screen 87 not modified - 0 \ COMPILING [ ] 20DEC84BP) - 1 - 2 | : COMPILING - 3 ?STACK NAME FIND ?DUP - 4 IF 0> IF EXECUTE >INTERPRET THEN - 5 , >INTERPRET THEN - 6 NULLSTRING? ?EXIT NUMBER? ?DUP - 7 IF 0> IF SWAP [COMPILE] LITERAL THEN - 8 [COMPILE] LITERAL - 9 ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT -10 -11 : [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE -12 -13 : ] ['] COMPILING IS >INTERPRET STATE ON ; -14 -15 -Screen 88 not modified - 0 \ PERFOM DEFER IS 03FEB85BP) - 1 - 2 | : CRASH TRUE ABORT" CRASH" ; - 3 - 4 : DEFER CREATE ['] CRASH , - 5 ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA - 6 W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE - 7 - 8 : (IS R> DUP 2+ >R @ ! ; - 9 -10 | : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = -11 SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; -12 -13 : IS ( ADR -- ) ' DUP DEF? >BODY -14 STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE -15 -Screen 89 not modified - 0 \ ?STACK 08SEP84KS) - 1 - 2 | : STACKFULL ( -- ) - 3 DEPTH 20 > ABORT" TIGHT STACK" - 4 REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN - 5 (FORGET THEN TRUE ABORT" DICTIONARY FULL" ; - 6 - 7 CODE ?STACK USER' DP # LDY - 8 SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC - 9 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? -10 USER' S0 # LDY UP )Y LDA SP CMP INY -11 UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? -12 ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT -13 -14 \\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN -15 SP@ S0 @ U> ABORT" STACK EMPTY" ; -Screen 90 not modified - 0 \ .STATUS PUSH LOAD 08SEP84KS) - 1 - 2 DEFER .STATUS ' NOOP IS .STATUS - 3 - 4 | CREATE PULL 0 ] R> R> ! ; - 5 - 6 : PUSH ( ADDR -- ) - 7 R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT - 8 - 9 -10 : LOAD ( BLK --) -11 ?DUP 0= ?EXIT BLK PUSH BLK ! -12 >IN PUSH >IN OFF .STATUS INTERPRET ; -13 -14 -15 -Screen 91 not modified - 0 \ +LOAD THRU +THRU --> RDEPTH DEPTH KS) - 1 - 2 : +LOAD ( OFFSET --) BLK @ + LOAD ; - 3 - 4 : THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ; - 5 - 6 : +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ; - 7 - 8 : --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE - 9 -10 : RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; -11 -12 : DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; -13 -14 -15 -Screen 92 not modified - 0 \ QUIT (QUIT ABORT 07JUN85BP) - 1 - 2 | : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ; - 3 - 4 : (QUIT - 5 BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT - 6 - 7 DEFER 'QUIT ' (QUIT IS 'QUIT - 8 - 9 : QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT -10 -11 : STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; -12 -13 DEFER 'ABORT ' NOOP IS 'ABORT -14 -15 : ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT -Screen 93 not modified - 0 \ (ERROR ABORT" ERROR" 20MAR85BP) - 1 - 2 VARIABLE SCR 1 SCR ! - 3 - 4 VARIABLE R# 0 R# ! - 5 - 6 : (ERROR ( STRING -- ) - 7 STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR - 8 BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT - 9 -10 ' (ERROR ERRORHANDLER ! -11 -12 : (ABORT" "LIT SWAP IF -13 >R CLEARSTACK R> ERRORHANDLER PERFORM -14 EXIT THEN DROP ; RESTRICT -15 -Screen 94 not modified - 0 \ - 1 - 2 | : (ERR" "LIT SWAP - 3 IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT - 4 - 5 : ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT - 6 - 7 : ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 95 not modified - 0 \ -TRAILING 08APR85BP) - 1 - 2 020 CONSTANT BL - 3 - 4 CODE -TRAILING ( ADDR N1 -- ADR N2 ) - 5 TYA SETUP JSR - 6 SP X) LDA N 2+ STA CLC - 7 SP )Y LDA N 1+ ADC N 3 + STA - 8 N LDY CLC CS ?[ - 9 LABEL (-TRAIL -10 DEY N 2+ )Y LDA BL # CMP -11 0<> ?[ INY 0= ?[ N 1+ INC ]? -12 TYA PHA N 1+ LDA PUSH JMP ]? -13 ]? TYA (-TRAIL BNE -14 N 3 + DEC N 1 + DEC (-TRAIL BPL -15 TYA PUSH0A JMP END-CODE -Screen 96 not modified - 0 \ SPACE SPACES 29JAN85KS/BP) - 1 - 2 : SPACE BL EMIT ; - 3 - 4 : SPACES ( U --) 0 ?DO SPACE LOOP ; - 5 - 6 \\ - 7 : -TRAILING ( ADDR N1 -- ADDR N2) - 8 2DUP BOUNDS - 9 ?DO 2DUP + 1- C@ BL - -10 IF LEAVE THEN 1- LOOP ; -11 -12 -13 -14 -15 -Screen 97 not modified - 0 \ HOLD <# #> SIGN # #S 24DEC83KS) - 1 | : HLD ( -- ADDR) PAD 2- ; - 2 - 3 : HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; - 4 - 5 : <# HLD HLD ! ; - 6 - 7 : #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; - 8 - 9 : SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; -10 -11 : # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER < -12 IF [ ASCII A ASCII 9 - 1- ] LITERAL + -13 THEN ASCII 0 + HOLD ; -14 -15 : #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; -Screen 98 not modified - 0 \ PRINT NUMBERS 24DEC83KS) - 1 - 2 : D.R -ROT UNDER DABS <# #S ROT SIGN #> - 3 ROT OVER MAX OVER - SPACES TYPE ; - 4 - 5 : .R SWAP EXTEND ROT D.R ; - 6 - 7 : U.R 0 SWAP D.R ; - 8 - 9 : D. 0 D.R SPACE ; -10 -11 : . EXTEND D. ; -12 -13 : U. 0 D. ; -14 -15 -Screen 99 not modified - 0 \ .S LIST C/L L/S 24DEC83KS) - 1 - 2 : .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; - 3 - 4 40 CONSTANT C/L \ SCREEN LINE LENGTH - 5 - 6 10 CONSTANT L/S \ LINES PER SCREEN - 7 - 8 : LIST ( BLK --) - 9 SCR ! ." SCR " SCR @ DUP U. -10 ." DR " DRV? . -11 L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK -12 I C/L * + C/L -TRAILING TYPE LOOP CR ; -13 -14 -15 -Screen 100 not modified - 0 \ MULTITASKER PRIMITIVES BP03NOV85) - 1 CODE PAUSE NEXT HERE 2- ! END-CODE - 2 - 3 : LOCK ( ADDR --) - 4 DUP @ UP@ = IF DROP EXIT THEN - 5 BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; - 6 - 7 : UNLOCK ( ADDR --) DUP LOCK OFF ; - 8 - 9 LABEL WAKE WAKE >WAKE ! -10 PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA -11 04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA -12 INY UP )Y LDA SP 1+ STA 1 # LDY -13 SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC -14 IP # LDX XPULL JMP END-CODE -15 -Screen 101 not modified - 0 \ BUFFER MECHANISM 15DEC83KS) cas 26jan06 - 1 - 2 USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK - 3 - 4 VARIABLE PREV 0 PREV ! \ LISTHEAD - 5 - 6 | VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR - 7 - 8 0408 CONSTANT B/BUF \ size of buffer - 9 -10 -11 -12 -13 -14 -15 -Screen 102 not modified - 0 \\ structure of buffer (same for all volksFORTH ) cas 26jan06 - 1 0 : LINK - 2 2 : FILE - 3 6 : BLOCKNR - 4 8 : STATUSFLAGS - 5 0A : DATA .. 1 KB .. - 6 - 7 STATUSFLAG BITS: 15 1 -> UPDATED - 8 - 9 FILE = -1 EMPTY BUFFER -10 = 0 NO FCB , DIRECT ACCESS -11 = ELSE ADR OF FCB -12 ( SYSTEM DEPENDENT ) -13 -14 -15 -Screen 103 not modified - 0 \ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP) - 1 - 2 LABEL THISBUFFER? 2 # LDY - 3 [[ N 4 + )Y LDA N 2- ,Y CMP - 4 0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER ) - 5 - 6 | CODE (CORE? ( BLK FILE -- ADDR / BLK FILE ) - 7 \ N-AREA : 0 BLK 2 FILE 4 BUFFER - 8 \ 6 PREDECESSOR - 9 3 # LDY -10 [[ SP )Y LDA N ,Y STA DEY 0< ?] -11 USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA -12 INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA -13 PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[ -14 -15 -Screen 104 not modified - 0 \ " 11JUN85BP) - 1 - 2 LABEL BLOCKFOUND SP 2INC 1 # LDY - 3 8 # LDA CLC N 4 + ADC SP X) STA - 4 N 5 + LDA 0 # ADC SP )Y STA - 5 ' EXIT @ JMP ]? - 6 [[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA - 7 N 6 + X) LDA N 4 + STA 1 # LDY - 8 N 6 + )Y LDA N 5 + STA N 4 + ORA - 9 0= ?[ ( LIST EMPTY ) NEXT JMP ]? -10 THISBUFFER? JSR 0= ?] \ FOUND, RELINK -11 N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA -12 PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA -13 N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA -14 BLOCKFOUND JMP END-CODE -15 -Screen 105 not modified - 0 \\ (CORE? 23SEP85BP - 1 | : this? ( blk file bufadr -- flag ) - 2 DUP 4+ @ SWAP 2+ @ D= ; - 3 - 4 | : (CORE? ( BLK FILE -- DATAADDR / BLK FILE ) - 5 BEGIN OVER OFFSET @ + OVER PREV @ - 6 THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN - 7 2DUP >R OFFSET @ + >R PREV @ - 8 BEGIN DUP @ ?DUP - 9 0= IF RDROP RDROP DROP EXIT THEN -10 DUP R> R> 2DUP >R >R ROT THIS? 0= -11 WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV ! -12 RDROP RDROP REPEAT ; -2 ALLOT -13 -14 -15 -Screen 106 not modified - 0 \ (DISKERR 11JUN85BP) - 1 - 2 : (DISKERR ." ERROR ! R TO RETRY " - 3 KEY DUP ASCII R = SWAP ASCII R = - 4 OR NOT ABORT" ABORTED" ; - 5 - 6 - 7 DEFER DISKERR ' (DISKERR IS DISKERR - 8 - 9 DEFER R/W -10 -11 -12 -13 -14 -15 -Screen 107 not modified - 0 \ BACKUP EMPTYBUF READBLK 11JUN85BP) - 1 | : BACKUP ( BUFADDR --) - 2 DUP 6+ @ 0< - 3 IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1 - 4 IF INPUT PUSH OUTPUT PUSH STANDARDI/O - 5 BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W - 6 WHILE ." WRITE " DISKERR - 7 REPEAT THEN - 8 080 OVER 4+ 1+ CTOGGLE THEN DROP ; - 9 -10 | : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ; -11 -12 | : READBLK ( BLK FILE ADDR -- BLK FILE ADDR) -13 DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R -14 BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W -15 WHILE ." READ " DISKERR REPEAT R> ; -Screen 108 not modified - 0 \ TAKE MARK UPDATES? FULL? CORE? BP) - 1 - 2 | : TAKE ( -- BUFADDR) PREV - 3 BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL - 4 BUFFERS LOCK DUP BACKUP ; - 5 - 6 | : MARK ( BLK FILE BUFADDR -- BLK FILE ) - 7 2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ ! - 8 R> 4+ OFF BUFFERS UNLOCK ; - 9 -10 | : UPDATES? ( -- BUFADDR / FLAG) -11 PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ; -12 -13 | : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ; -14 -15 : CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ; -Screen 109 not modified - 0 \ BLOCK & BUFFER MANIPULATION 11JUN85BP) - 1 - 2 : (BUFFER ( BLK FILE -- ADDR) - 3 BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT - 4 - 5 : (BLOCK ( BLK FILE -- ADDR) - 6 BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT - 7 - 8 | CODE FILE@ ( -- N ) USER' FILE # LDY - 9 UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE -10 -11 : BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ; -12 -13 : BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ; -14 -15 -Screen 110 not modified - 0 \ BLOCK & BUFFER MANIPULATION 09SEP84KS) - 1 - 2 : UPDATE 080 PREV @ 6+ 1+ C! ; - 3 - 4 : SAVE-BUFFERS - 5 BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT - 6 BUFFERS UNLOCK ; - 7 - 8 : EMPTY-BUFFERS - 9 BUFFERS LOCK PREV -10 BEGIN @ ?DUP -11 WHILE DUP EMPTYBUF -12 REPEAT BUFFERS UNLOCK ; -13 -14 : FLUSH SAVE-BUFFERS EMPTY-BUFFERS ; -15 -Screen 111 not modified - 0 \ MOVING BLOCKS 15DEC83KS) cas 26jan06 - 1 | : (COPY ( FROM TO --) DUP FILE@ - 2 CORE? IF PREV @ EMPTYBUF THEN - 3 FULL? IF SAVE-BUFFERS THEN - 4 OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ; - 5 - 6 | : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R - 7 OVER R@ + OVER U> >R 2DUP U< R> AND - 8 IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP - 9 ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP -10 THEN SAVE-BUFFERS 2DROP ; -11 -12 : COPY ( FROM TO --) 1 BLKMOVE ; -13 -14 : CONVEY ( [BLK1 BLK2] [TO.BLK --) -15 SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ; -Screen 112 not modified - 0 \ ALLOCATING BUFFERS 23SEP83KS) cas2013apr04 - 1 - 2 7F00 CONSTANT LIMIT VARIABLE FIRST - 3 - 4 : ALLOTBUFFER ( -- ) - 5 FIRST @ R0 @ - B/BUF 2+ U< ?EXIT - 6 B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF - 7 PREV @ OVER ! PREV ! ; - 8 - 9 : FREEBUFFER ( -- ) -10 FIRST @ LIMIT B/BUF - U< -11 IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT -12 FIRST @ @ SWAP ! B/BUF FIRST +! THEN ; -13 -14 : ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ; -15 -Screen 113 not modified - 0 \ ENDPOINTS OF FORGET 04JAN85BP/KS) - 1 | : \? ( NFA -- FLAG ) C@ 020 AND ; - 2 - 3 | : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? - 4 NAME> UNDER 1+ U< SWAP HEAP? OR ; - 5 - 6 | : ENDPOINTS ( ADDR -- ADDR SYMB) - 7 HEAP VOC-LINK @ >R - 8 BEGIN R> @ ?DUP \ THROUGH ALL VOCABS - 9 WHILE DUP >R 4 - >R \ LINK ON RETURNST. -10 BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR -11 SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR -12 WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP -13 R@ 2+ \? IF OVER R@ 2+ FORGET? -14 IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB -15 THEN REPEAT RDROP REPEAT ; -Screen 114 not modified - 0 \ REMOVE 23JUL85WE - 1 - 2 | CODE REMOVE ( DIC SYMB THR - DIC SYMB) - 3 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY - 4 CLC UP )Y LDA 6 # ADC N 6 + STA - 5 INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY - 6 [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> - 7 ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS - 8 ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC - 9 ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC -10 ]? CC -11 ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA -12 ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? -13 ]]? (DROP JMP END-CODE -14 -15 -Screen 115 not modified - 0 \ REMOVE- FORGET-WORDS 29APR85BP) - 1 - 2 | : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) - 3 VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; - 4 - 5 | : REMOVE-TASKS ( DIC --) - 6 UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN - 7 IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; - 8 - 9 | : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) -10 VOC-LINK REMOVE THRU.VOCSTACK -11 DO 2DUP I @ -ROT UWITHIN -12 IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP -13 2DUP CURRENT @ -ROT UWITHIN -14 IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; -15 -Screen 116 not modified - 0 \ FORGET-WORDS cas 26jan06 - 1 - 2 | : FORGET-WORDS ( DIC SYMB --) - 3 OVER REMOVE-TASKS REMOVE-VOCS - 4 REMOVE-WORDS - 5 HEAP SWAP - HALLOT DP ! 0 LAST ! ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 117 not modified - 0 \ DELETING WORDS FROM DICT. 13JAN83KS) - 1 - 2 : CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; - 3 - 4 : (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" - 5 ENDPOINTS FORGET-WORDS ; - 6 - 7 : FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" - 8 >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; - 9 -10 : EMPTY [ DP ] LITERAL @ -11 UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; -12 -13 -14 -15 -Screen 118 not modified - 0 \ SAVE BYE STOP? ?CR 20OCT84KS/BP) - 1 - 2 : SAVE - 3 HERE UP@ FORGET-WORDS VOC-LINK @ - 4 BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL - 5 UP@ ORIGIN 0100 CMOVE ; - 6 - 7 : BYE FLUSH EMPTY (BYE ; - 8 - 9 | : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ; -10 -11 : STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; -12 -13 : ?CR COL C/L 0A - U> IF CR THEN ; -14 -15 -Screen 119 not modified - 0 \ IN/OUTPUT STRUCTURE 02MAR85BP) - 1 | : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; - 2 - 3 : OUTPUT: CREATE ] DOES> OUTPUT ! ; - 4 0 OUT: EMIT OUT: CR OUT: TYPE - 5 OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP - 6 - 7 : ROW ( -- ROW) AT? DROP ; - 8 : COL ( -- COL) AT? NIP ; - 9 -10 | : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; -11 -12 : INPUT: CREATE ] DOES> INPUT ! ; -13 -14 0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP -15 -Screen 120 not modified - 0 \ ALIAS ONLY DEFINITIONEN 29JAN85BP) - 1 - 2 ONLY DEFINITIONS FORTH - 3 - 4 : SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) - 5 - 6 ' ONLY ALIAS ONLY - 7 ' FORTH ALIAS FORTH - 8 ' WORDS ALIAS WORDS - 9 ' ALSO ALIAS ALSO -10 ' DEFINITIONS ALIAS DEFINITIONS -11 HOST TARGET -12 -13 -14 -15 -Screen 121 not modified - 0 \ 'COLD 07JUN85BP) cas2013apr05 - 1 | : INIT-VOCABULARYS VOC-LINK @ - 2 BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; - 3 - 4 | : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ; - 5 - 6 DEFER 'COLD ' NOOP IS 'COLD - 7 - 8 | : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH - 9 ." volksFORTH-83 3.8.7 05apr13 CS" CR RESTART ; -2 ALLOT -10 -11 DEFER 'RESTART ' NOOP IS 'RESTART -12 | : (RESTART ['] (QUIT IS 'QUIT -13 DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! -14 ['] NOOP IS 'ABORT ABORT ; -2 ALLOT -15 -Screen 122 not modified - 0 \ COLD BOOTSYSTEM RESTART 09JUL85WE) - 1 CODE COLD HERE >COLD ! - 2 ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA - 3 - 4 LABEL BOOTSYSTEM CLI 0 # LDY - 5 CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA - 6 [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] - 7 LABEL WARMBOOT BOOTNEXTLEN 1- # LDY - 8 [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] - 9 CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA -10 USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA -11 USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA -12 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA -13 PLA IP STA PLA IP 1+ STA -14 LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE -15 -Screen 123 not modified - 0 \ ( RESTART PARAM.-PASSING TO FORTH BP) - 1 - 2 CODE RESTART HERE >RESTART ! - 3 ' (RESTART >BODY 100 U/MOD - 4 # LDA PHA # LDA PHA WARMBOOT JMP END-CODE - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 124 not modified - 0 \ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06 - 1 - 2 \ Include system dependent Input / Output code - 3 \ (Keyboard and Screen) - 4 include systemio.fb - 5 - 6 - 7 HOST ' TRANSIENT 8 + @ - 8 TRANSIENT FORTH CONTEXT @ 6 + ! - 9 TARGET -10 -11 FORTH ALSO DEFINITIONS -12 -13 : FORTH-83 ; \ LAST WORD IN DICTIONARY -14 -15 -Screen 125 not modified - 0 \ SYSTEM DEPENDENT CONSTANTS BP/KS) - 1 - 2 VOCABULARY ASSEMBLER - 3 ASSEMBLER DEFINITIONS - 4 TRANSIENT ASSEMBLER - 5 PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK - 6 PUSH0A CONSTANT PUSH0A \ PUT A ON STACK - 7 PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK - 8 RP CONSTANT RP - 9 UP CONSTANT UP -10 SP CONSTANT SP -11 IP CONSTANT IP -12 N CONSTANT N -13 PUTA CONSTANT PUTA -14 W CONSTANT W -15 SETUP CONSTANT SETUP -Screen 126 not modified - 0 \ - 1 NEXT CONSTANT NEXT - 2 XYNEXT CONSTANT XYNEXT - 3 (2DROP CONSTANT POPTWO - 4 (DROP CONSTANT POP - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 127 not modified - 0 \ SYSTEM PATCHUP 05JAN85BP) cas2013apr05 - 1 - 2 FORTH DEFINITIONS - 3 - 4 \ change memory layout for stacks and buffers here - 5 TOPADDR ' LIMIT >BODY ! - 6 TOPADDR $F00 - S0 ! TOPADDR $480 - R0 ! - 7 - 8 S0 @ DUP S0 2- ! 6 + S0 7 - ! - 9 HERE DP ! -10 -11 HOST TUDP @ TARGET UDP ! -12 HOST TVOC-LINK @ TARGET VOC-LINK ! -13 HOST MOVE-THREADS -14 -15 ) -Screen 128 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 129 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 130 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 131 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/Apple1/6502f83.fth b/sources/Apple1/6502f83.fth new file mode 100644 index 0000000..85cb140 --- /dev/null +++ b/sources/Apple1/6502f83.fth @@ -0,0 +1,2244 @@ +\ *** Block No. 0 Hexblock 0 + + + + + + + + + + + + + +ende 123 + + +\ *** Block No. 1 Hexblock 1 +\ volksFORTH Loadscreen cas2013apr05 +forth definitions +: (C [compile] ( ; IMMEDIATE \ : ) ; IMMEDIATE + +$0300 CONSTANT BASEADDR \ base address of forth image +$7F00 CONSTANT TOPADDR +BASEADDR DISPLACE ! +TARGET DEFINITIONS BASEADDR HERE! + +hex &01 &126 +THRU +decimal +\ ASSEMBLER NONRELOCATE + +.UNRESOLVED \ if this prints unresolved + \ definitions, check code +CR .( SAVE-TARGET 6502-FORTH83) +\ *** Block No. 2 Hexblock 2 +\ FORTH PREAMBLE AND ID cas20130405 + + +ASSEMBLER + NOP 0 JMP HERE 2- >LABEL >COLD + NOP 0 JMP HERE 2- >LABEL >RESTART + +HERE DUP ORIGIN! + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ Coldstartvalues and user variables cas2013apr05 +\ + +0 JMP 0 JSR HERE 2- >LABEL >WAKE + END-CODE + +0D6 ALLOT + +\ Bootlabel +," VolksForth-83 3.8 COMPILED 05apr13CS" + + + + + + +\ *** Block No. 4 Hexblock 4 +\ ZERO PAGE VARIABLES & NEXT cas 26jan06 +\ adjust this to match your architecture + + +20 DUP >LABEL RP 2+ + DUP >LABEL UP 2+ + DUP >LABEL PUTA 1+ + DUP >LABEL SP 2+ + DUP >LABEL NEXT + DUP 5 + >LABEL IP + 13 + >LABEL W + + W 8 + >LABEL N + + + +\ *** Block No. 5 Hexblock 5 +\ NEXT, MOVED INTO ZERO PAGE 08APR85BP) + +LABEL BOOTNEXT + -1 STA \ -1 IS DUMMY SP + IP )Y LDA W 1+ STA + -1 LDA W STA \ -1 IS DUMMY IP + CLC IP LDA 2 # ADC IP STA + CS NOT ?[ LABEL WJMP -1 ) JMP ]? + IP 1+ INC WJMP BCS END-CODE + + + + + + + +\ *** Block No. 6 Hexblock 6 +\ Bootnext and Endtrace cas 26jan06 +HERE BOOTNEXT - >LABEL BOOTNEXTLEN + +CODE END-TRACE ( PATCH NEXT FOR TRACE ) + 0A5 # LDA NEXT 0A + STA + IP # LDA NEXT 0B + STA + 069 # LDA NEXT 0C + STA + 02 # LDA NEXT 0D + STA + NEXT JMP END-CODE + + + + + + + +\ *** Block No. 7 Hexblock 7 +\ ;C: NOOP cas 26jan06 + +CREATE RECOVER ASSEMBLER + PLA W STA PLA W 1+ STA + W WDEC 0 JMP END-CODE + +HERE 2- >LABEL >RECOVER +\ manual forward reference for JMP command + + +COMPILER ASSEMBLER ALSO DEFINITIONS + H : ;C: 0 T RECOVER JSR + END-CODE ] H ; +TARGET +CODE NOOP NEXT HERE 2- ! END-CODE + +\ *** Block No. 8 Hexblock 8 +\ USER VARIABLES cas2013apr05 + +CONSTANT ORIGIN 8 UALLOT DROP + \ FOR MULTITASKER + +\ Adjust memory values for data stack and return stack here +USER S0 TOPADDR $F00 - S0 ! USER R0 TOPADDR $480 - R0 ! +USER DP USER OFFSET 0 OFFSET ! +USER BASE &10 BASE ! USER OUTPUT +USER INPUT +USER ERRORHANDLER \ POINTER FOR ABORT" -CODE +USER VOC-LINK +USER UDP \ POINTS TO NEXT FREE ADDR IN USER + + + +\ *** Block No. 9 Hexblock 9 +\ MANIPULATE SYSTEM POINTERS 29JAN85BP) + +CODE SP@ ( -- ADDR) + SP LDA N STA SP 1+ LDA N 1+ STA + N # LDX +LABEL XPUSH + SP 2DEC 1 ,X LDA SP )Y STA + 0 ,X LDA 0 # LDX PUTA JMP END-CODE + +CODE SP! ( ADDR --) + SP X) LDA TAX SP )Y LDA + SP 1+ STA SP STX 0 # LDX + NEXT JMP END-CODE + + + +\ *** Block No. 10 Hexblock A +\ UP@ UP! XPULL (XYDROP (DROP cas 26jan06 +CODE UP@ ( -- ADDR) + UP # LDX XPUSH JMP END-CODE + +CODE UP! ( ADDR --) UP # LDX +LABEL XPULL SP )Y LDA 1 ,X STA + DEY SP )Y LDA 0 ,X STA +LABEL (XYDROP 0 # LDX 1 # LDY +LABEL (DROP SP 2INC NEXT JMP +END-CODE RESTRICT + + + + + + +\ *** Block No. 11 Hexblock B +\ MANIPULATE RETURNSTACK 16FEB85BP/KS) +CODE RP@ ( -- ADDR ) + RP # LDX XPUSH JMP END-CODE + +CODE RP! ( ADDR -- ) + RP # LDX XPULL JMP END-CODE RESTRICT + +CODE >R ( 16B -- ) + RP 2DEC SP X) LDA RP X) STA + SP )Y LDA RP )Y STA (DROP JMP +END-CODE RESTRICT + + + + + +\ *** Block No. 12 Hexblock C +\ R> (RDROP (NRDROP cas 26jan06 +CODE R> ( -- 16B) + SP 2DEC RP X) LDA SP X) STA + RP )Y LDA SP )Y STA +LABEL (RDROP 2 # LDA + +LABEL (NRDROP CLC RP ADC RP STA + CS ?[ RP 1+ INC ]? + NEXT JMP END-CODE RESTRICT + + + + + + + +\ *** Block No. 13 Hexblock D +\ R@ RDROP EXIT ?EXIT 08APR85BP) + +CODE R@ ( -- 16B) + SP 2DEC RP )Y LDA SP )Y STA + RP X) LDA PUTA JMP +END-CODE +CODE RDROP (RDROP HERE 2- ! +END-CODE RESTRICT + +CODE EXIT + RP X) LDA IP STA + RP )Y LDA IP 1+ STA + (RDROP JMP END-CODE + + + +\ *** Block No. 14 Hexblock E +\ EXECUTE PERFORM 08APR85BP) + +CODE ?EXIT ( FLAG -- ) + SP X) LDA SP )Y ORA + PHP SP 2INC PLP + ' EXIT @ BNE NEXT JMP +END-CODE + +CODE EXECUTE ( ADDR --) + SP X) LDA W STA + SP )Y LDA W 1+ STA + SP 2INC W 1- JMP END-CODE + +: PERFORM ( ADDR -- ) @ EXECUTE ; + + +\ *** Block No. 15 Hexblock F +\ C@ C! CTOGGLE 10JAN85BP) + +CODE C@ ( ADDR -- 8B) + + SP X) LDA N STA SP )Y LDA N 1+ STA +LABEL (C@ 0 # LDA SP )Y STA + N X) LDA PUTA JMP END-CODE + +CODE C! ( 16B ADDR --) + SP X) LDA N STA SP )Y LDA N 1+ STA + INY SP )Y LDA N X) STA DEY +LABEL (2DROP + SP LDA CLC 4 # ADC SP STA + CS ?[ SP 1+ INC ]? + NEXT JMP END-CODE + +\ *** Block No. 16 Hexblock 10 +\ @ ! +! 08APR85BP) er14dez88 + +: CTOGGLE ( 8B ADDR --) UNDER C@ XOR SWAP C! ; + +CODE @ ( ADDR -- 16B) + SP X) LDA N STA SP )Y LDA N 1+ STA + N )Y LDA SP )Y STA + N X) LDA PUTA JMP END-CODE + +CODE ! ( 16B ADDR --) + SP X) LDA N STA SP )Y LDA N 1+ STA + INY SP )Y LDA N X) STA + INY SP )Y LDA 1 # LDY +LABEL (! + N )Y STA (2DROP JMP END-CODE + +\ *** Block No. 17 Hexblock 11 +\ +! DROP cas 26jan06 + +CODE +! ( N ADDR --) + SP X) LDA N STA SP )Y LDA N 1+ STA + INY SP )Y LDA CLC N X) ADC N X) STA + INY SP )Y LDA 1 # LDY N )Y ADC + (! JMP END-CODE + +CODE DROP ( 16B --) + (DROP HERE 2- ! END-CODE + + + + + + +\ *** Block No. 18 Hexblock 12 +\ SWAP cas 26jan06 +CODE SWAP ( 16B1 16B2 -- 16B2 16B1 ) + SP )Y LDA TAX + 3 # LDY SP )Y LDA N STA + TXA SP )Y STA + N LDA 1 # LDY SP )Y STA + INY 0 # LDX + SP )Y LDA N STA SP X) LDA SP )Y STA + DEY + N LDA PUTA JMP END-CODE + + + + + + +\ *** Block No. 19 Hexblock 13 +\ DUP ?DUP 08MAY85BP) cas 26jan06 + +CODE DUP ( 16B -- 16B 16B) + SP 2DEC + 3 # LDY SP )Y LDA 1 # LDY SP )Y STA + INY SP )Y LDA DEY + PUTA JMP END-CODE + +CODE ?DUP ( 16B -- 16B 16B / FALSE) + SP X) LDA SP )Y ORA + 0= ?[ NEXT JMP ]? + ' DUP @ JMP END-CODE +\\ ?DUP and DUP in FORTH +\ : ?DUP ( 16B -- 16B 16B / FALSE) +\ DUP IF DUP THEN ; +\ : DUP SP@ @ ; +\ *** Block No. 20 Hexblock 14 +\ OVER ROT 13JUN84KS) cas 26jan06 + +CODE OVER ( 16B1 16B2 - 16B1 16B3 16B1) + SP 2DEC 4 # LDY SP )Y LDA SP X) STA + INY SP )Y LDA 1 # LDY SP )Y STA + NEXT JMP END-CODE + +\\ ROT OVER in FORTH +\ : ROT >R SWAP R> SWAP ; +\ : OVER >R DUP R> SWAP ; + + + + + + +\ *** Block No. 21 Hexblock 15 +\ ROT cas 26jan06 +CODE ROT ( 16B1 16B2 16B3 -- 16B2 16B3 16B1) + 3 # LDY SP )Y LDA N 1+ STA + 1 # LDY SP )Y LDA 3 # LDY SP )Y STA + 5 # LDY SP )Y LDA N STA + N 1+ LDA SP )Y STA + 1 # LDY N LDA SP )Y STA + INY SP )Y LDA N 1+ STA + SP X) LDA SP )Y STA + 4 # LDY SP )Y LDA SP X) STA + N 1+ LDA SP )Y STA + 1 # LDY NEXT JMP END-CODE + + + + +\ *** Block No. 22 Hexblock 16 +\ -ROT NIP UNDER PICK ROLL 24DEC83KS) cas 26jan06 +: -ROT ( 16B1 16B2 16B3 -- 16B3 16B1 16B2) + ROT ROT ; + +: NIP ( 16B1 16B2 -- 16B2) SWAP DROP ; + +: UNDER ( 16B1 16B2 -- 16B2 16B1 16B2) SWAP OVER ; + +: PICK ( N -- 16B.N ) 1+ 2* SP@ + @ ; + +: ROLL ( N --) DUP >R PICK SP@ DUP 2+ R> 1+ 2* CMOVE> DROP ; + +\\ : -ROLL ( N --) + >R DUP SP@ DUP 2+ DUP 2+ SWAP + R@ 2* CMOVE R> 1+ 2* + ! ; + +\ *** Block No. 23 Hexblock 17 +\ DOUBLE WORD STACK MANIP. 21APR83KS) + +: 2SWAP ( 32B1 32B2 -- 32B2 32B1) ROT >R ROT R> ; + +CODE 2DROP ( 32B -- ) + (2DROP HERE 2- ! END-CODE + +: 2DUP ( 32B -- 32B 32B) OVER OVER ; + +\ : 2DROP ( 32B -- ) DROP DROP ; + + + + + + +\ *** Block No. 24 Hexblock 18 +\ + AND OR XOR 08APR85BP) +COMPILER ASSEMBLER ALSO DEFINITIONS + +H : DYADOP ( OPCODE --) T + INY SP X) LDA DUP C, SP C, SP )Y STA + DEY SP )Y LDA 3 # LDY C, SP C, SP )Y STA + (XYDROP JMP H ; +TARGET + +CODE + ( N1 N2 -- N3) CLC 071 DYADOP END-CODE + +CODE OR ( 16B1 16B2 -- 16B3) 011 DYADOP END-CODE + +CODE AND ( 16B1 16B2 -- 16B3) 031 DYADOP END-CODE + +CODE XOR ( 16B1 16B2 -- 16B3) 051 DYADOP END-CODE +\ *** Block No. 25 Hexblock 19 +\ - NOT NEGATE 24DEC83KS) + +CODE - ( N1 N2 -- N3) + INY SP )Y LDA SEC SP X) SBC SP )Y STA INY SP )Y LDA + 1 # LDY SP )Y SBC 3 # LDY SP )Y STA (XYDROP JMP END-CODE + +CODE NOT ( 16B1 -- 16B2) CLC +LABEL (NOT TXA SP X) SBC SP X) STA TXA SP )Y SBC SP )Y STA + NEXT JMP END-CODE + +CODE NEGATE ( N1 -- N2 ) SEC (NOT BCS END-CODE + +\ : - NEGATE + ; + + + +\ *** Block No. 26 Hexblock 1A +\ DNEGATE SETUP D+ 14JUN84KS) + +CODE DNEGATE ( D1 -- -D1) + INY SEC + TXA SP )Y SBC SP )Y STA INY + TXA SP )Y SBC SP )Y STA + TXA SP X) SBC SP X) STA 1 # LDY + TXA SP )Y SBC SP )Y STA + NEXT JMP END-CODE +LABEL SETUP ( QUAN IN A) + .A ASL TAX TAY DEY + [[ SP )Y LDA N ,Y STA DEY 0< ?] + TXA CLC SP ADC SP STA + CS ?[ SP 1+ INC ]? + 0 # LDX 1 # LDY RTS END-CODE + +\ *** Block No. 27 Hexblock 1B +\ D+ cas 26jan06 +CODE D+ ( D1 D2 -- D3) + 2 # LDA SETUP JSR INY + SP )Y LDA CLC N 2+ ADC SP )Y STA INY + SP )Y LDA N 3 + ADC SP )Y STA + SP X) LDA N ADC SP X) STA 1 # LDY + SP )Y LDA N 1+ ADC SP )Y STA + NEXT JMP END-CODE + + + + + + + + +\ *** Block No. 28 Hexblock 1C +\ 1+ 2+ 3+ 1- 2- 08APR85BP) + +CODE 1+ ( N1 -- N2) 1 # LDA +LABEL N+ CLC SP X) ADC + CS NOT ?[ PUTA JMP ]? + SP X) STA SP )Y LDA 0 # ADC SP )Y STA + NEXT JMP END-CODE + +CODE 2+ ( N1 -- N2) 2 # LDA N+ BNE END-CODE + +CODE 3+ ( N1 -- N2) 3 # LDA N+ BNE END-CODE + +| CODE 4+ ( N1 -- N2) 4 # LDA N+ BNE END-CODE + +| CODE 6+ ( N1 -- N2) 6 # LDA N+ BNE END-CODE + +\ *** Block No. 29 Hexblock 1D +\ NUMBER CONSTANTS 24DEC83KS) +CODE 1- ( N1 -- N2) SEC +LABEL (1- SP X) LDA 1 # SBC + CS ?[ PUTA JMP ]? + SP X) STA SP )Y LDA 0 # SBC SP )Y STA + NEXT JMP END-CODE +CODE 2- ( N1 -- N2) CLC (1- BCC END-CODE + +-1 CONSTANT TRUE 0 CONSTANT FALSE +' TRUE ALIAS -1 ' FALSE ALIAS 0 + +1 CONSTANT 1 2 CONSTANT 2 +3 CONSTANT 3 4 CONSTANT 4 + +: ON ( ADDR -- ) TRUE SWAP ! ; +: OFF ( ADDR -- ) FALSE SWAP ! ; +\ *** Block No. 30 Hexblock 1E +\ WORDS FOR NUMBER LITERALS 24MAY84KS) cs08aug05 + +CODE CLIT ( -- 8B) + SP 2DEC IP X) LDA SP X) STA TXA SP )Y STA IP WINC + NEXT JMP END-CODE RESTRICT + +CODE LIT ( -- 16B) + SP 2DEC IP )Y LDA SP )Y STA IP X) LDA SP X) STA +LABEL (BUMP IP 2INC NEXT JMP END-CODE RESTRICT +: LITERAL ( 16B --) DUP 0FF00 AND + IF COMPILE LIT , EXIT THEN COMPILE CLIT C, ; + IMMEDIATE RESTRICT + +\\ : LIT R> DUP 2+ >R @ ; + : CLIT R> DUP 1+ >R C@ ; + +\ *** Block No. 31 Hexblock 1F +\ COMPARISION CODE WORDS 13JUN84KS) +CODE 0< ( N -- FLAG) SP )Y LDA 0< ?[ + LABEL PUTTRUE 0FF # LDA 024 C, ]? + LABEL PUTFALSE TXA SP )Y STA + PUTA JMP END-CODE + +CODE 0= ( 16B -- FLAG) + SP X) LDA SP )Y ORA PUTTRUE BEQ PUTFALSE BNE END-CODE + +CODE UWITHIN ( U1 [LOW UP[ -- FLAG) + 2 # LDA SETUP JSR 1 # LDY SP X) LDA N CMP + SP )Y LDA N 1+ SBC + CS NOT ?[ ( N>SP) SP X) LDA N 2+ CMP + SP )Y LDA N 3 + SBC + PUTTRUE BCS ]? + PUTFALSE JMP END-CODE +\ *** Block No. 32 Hexblock 20 +\ COMPARISION CODE WORDS 13JUN84KS) + +CODE < ( N1 N2 -- FLAG) + SP X) LDA N STA SP )Y LDA N 1+ STA + SP 2INC + N 1+ LDA SP )Y EOR ' 0< @ BMI + SP X) LDA N CMP SP )Y LDA N 1+ SBC + ' 0< @ 2+ JMP END-CODE + +CODE U< ( U1 U2 -- FLAG) + SP X) LDA N STA SP )Y LDA N 1+ STA + SP 2INC + SP X) LDA N CMP SP )Y LDA N 1+ SBC + CS NOT ?[ PUTTRUE JMP ]? + PUTFALSE JMP END-CODE + +\ *** Block No. 33 Hexblock 21 +\ COMPARISION WORDS 24DEC83KS) + +| : 0< 8000 AND 0<> ; + +: > ( N1 N2 -- FLAG) SWAP < ; +: 0> ( N -- FLAG) NEGATE 0< ; +: 0<> ( N -- FLAG) 0= NOT ; +: U> ( U1 U2 -- FLAG) SWAP U< ; +: = ( N1 N2 -- FLAG) - 0= ; +: D0= ( D -- FLAG) OR 0= ; +: D= ( D1 D2 -- FLAG) DNEGATE D+ D0= ; +: D< ( D1 D2 -- FLAG) ROT 2DUP - + IF > NIP NIP ELSE 2DROP U< THEN ; + + + +\ *** Block No. 34 Hexblock 22 +\ MIN MAX UMAX UMIN EXTEND DABS ABS cas 26jan06 + +| : MINIMAX ( N1 N2 FLAG -- N3) + RDROP IF SWAP THEN DROP ; + +: MIN ( N1 N2 -- N3) 2DUP > MINIMAX ; -2 ALLOT +: MAX ( N1 N2 -- N3) 2DUP < MINIMAX ; -2 ALLOT +: UMAX ( U1 U2 -- U3) 2DUP U< MINIMAX ; -2 ALLOT +: UMIN ( U1 U2 -- U3) 2DUP U> MINIMAX ; -2 ALLOT + +: EXTEND ( N -- D) DUP 0< ; + +: DABS ( D -- UD) EXTEND IF DNEGATE THEN ; +: ABS ( N -- U) EXTEND IF NEGATE THEN ; + + +\ *** Block No. 35 Hexblock 23 +\ LOOP PRIMITIVES 08FEB85BP/KS) + +| : DODO RDROP R> 2+ DUP >R ROT >R SWAP >R >R ; + + +: (DO ( LIMIT STAR -- ) OVER - DODO ; -2 ALLOT RESTRICT + +: (?DO ( LIMIT START -- ) + OVER - ?DUP IF DODO THEN R> DUP @ + >R DROP ; RESTRICT + +: BOUNDS ( START COUNT -- LIMIT START ) OVER + SWAP ; + +CODE ENDLOOP 6 # LDA (NRDROP JMP END-CODE RESTRICT + +\\ DODO PUTS "INDEX \ LIMIT \ + ADR.OF.DO" ON RETURN-STACK +\ *** Block No. 36 Hexblock 24 +\ (LOOP (+LOOP 08APR85BP) +CODE (LOOP + CLC 1 # LDA RP X) ADC RP X) STA + CS ?[ RP )Y LDA 0 # ADC RP )Y STA + CS ?[ NEXT JMP ]? ]? +LABEL DOLOOP 5 # LDY + RP )Y LDA IP 1+ STA DEY + RP )Y LDA IP STA 1 # LDY + NEXT JMP END-CODE RESTRICT + +CODE (+LOOP + CLC SP X) LDA RP X) ADC RP X) STA + SP )Y LDA RP )Y ADC RP )Y STA + .A ROR SP )Y EOR + PHP SP 2INC PLP DOLOOP BPL + NEXT JMP END-CODE RESTRICT +\ *** Block No. 37 Hexblock 25 +\ LOOP INDICES 08APR85BP) + +CODE I ( -- N) 0 # LDY +LABEL LOOPINDEX SP 2DEC CLC + RP )Y LDA INY INY + RP )Y ADC SP X) STA DEY + RP )Y LDA INY INY + RP )Y ADC 1 # LDY SP )Y STA + NEXT JMP END-CODE RESTRICT + +CODE J ( -- N) + 6 # LDY LOOPINDEX BNE + END-CODE RESTRICT + + + +\ *** Block No. 38 Hexblock 26 +\ BRANCHING 24DEC83KS) + +CODE BRANCH + CLC IP LDA IP X) ADC N STA + IP 1+ LDA IP )Y ADC IP 1+ STA N LDA IP STA + NEXT JMP END-CODE RESTRICT + +CODE ?BRANCH + SP X) LDA SP )Y ORA PHP SP 2INC PLP + ' BRANCH @ BEQ (BUMP JMP END-CODE RESTRICT + +\\ : BRANCH R> DUP @ + >R ; RESTRICT + + : ?BRANCH + 0= R> OVER NOT OVER 2+ AND -ROT + DUP @ + AND OR >R ; RESTRICT +\ *** Block No. 39 Hexblock 27 +\ RESOLVE LOOPS AND BRANCHES 03FEB85BP) + +: >MARK ( -- ADDR) HERE 0 , ; + +: >RESOLVE ( ADDR --) HERE OVER - SWAP ! ; + +: MARK 1 ; IMMEDIATE RESTRICT +: THEN ABS 1 ?PAIRS >RESOLVE ; IMMEDIATE RESTRICT +: ELSE 1 ?PAIRS COMPILE BRANCH >MARK + SWAP >RESOLVE -1 ; IMMEDIATE RESTRICT +: BEGIN MARK -2 2SWAP ; IMMEDIATE RESTRICT +| : (REPTIL RESOLVE REPEAT ; + +: REPEAT 2 ?PAIRS COMPILE BRANCH (REPTIL ; IMMEDIATE RESTRICT + +: UNTIL 2 ?PAIRS COMPILE ?BRANCH (REPTIL ; IMMEDIATE RESTRICT + +\ *** Block No. 42 Hexblock 2A +\ LOOPS 29JAN85KS/BP) + +: DO COMPILE (DO >MARK 3 ; IMMEDIATE RESTRICT + +: ?DO COMPILE (?DO >MARK 3 ; IMMEDIATE RESTRICT + +: LOOP 3 ?PAIRS COMPILE (LOOP + COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT + +: +LOOP 3 ?PAIRS COMPILE (+LOOP + COMPILE ENDLOOP >RESOLVE ; IMMEDIATE RESTRICT + +: LEAVE ENDLOOP R> 2- DUP @ + >R ; RESTRICT + +\\ RETURNSTACK: CALLADR \ INDEX + LIMIT \ ADR OF DO +\ *** Block No. 43 Hexblock 2B +\ UM* BP/KS13.2.85) +CODE UM* ( U1 U2 -- UD) + SP )Y LDA N STA SP X) LDA N 1+ STA + INY N 2 + STX N 3 + STX 010 # LDX + [[ N 3 + ASL N 2+ ROL N 1+ ROL N ROL + CS ?[ CLC SP )Y LDA N 3 + ADC N 3 + STA + INY SP )Y LDA DEY N 2 + ADC N 2 + STA + CS ?[ N 1+ INC 0= ?[ N INC ]? ]? ]? + DEX 0= ?] + N 3 + LDA SP )Y STA INY N 2 + LDA SP )Y STA 1 # LDY + N LDA SP )Y STA N 1+ LDA SP X) STA + NEXT JMP END-CODE + +\\ : UM* ( U1 U2 -- UD3) >R 0 0 0 R> 010 0 + DO DUP 2/ >R 1 AND IF 2OVER D+ THEN + >R >R 2DUP D+ R> R> R> LOOP DROP 2SWAP 2DROP ; +\ *** Block No. 44 Hexblock 2C +\ M* 2* 04JUL84KS) + +: M* ( N1 N2 -- D) + DUP 0< DUP >R IF NEGATE THEN + SWAP DUP 0< IF NEGATE R> NOT >R THEN + UM* R> IF DNEGATE THEN ; + +: * ( N N -- PROD) UM* DROP ; + +CODE 2* ( N1 -- N2) + SP X) LDA .A ASL SP X) STA + SP )Y LDA .A ROL SP )Y STA + NEXT JMP END-CODE +| : 2* DUP + ; + + +\ *** Block No. 45 Hexblock 2D +\ UM/MOD 04JUL84KS) + +| : DIVOVL + TRUE ABORT" DIVISION OVERFLOW" ; + +CODE UM/MOD ( UD U -- UREM UQUOT) + SP X) LDA N 5 + STA + SP )Y LDA N 4 + STA SP 2INC + SP X) LDA N 1+ STA + SP )Y LDA N STA INY + SP )Y LDA N 3 + STA INY + SP )Y LDA N 2+ STA 011 # LDX CLC + [[ N 6 + ROR SEC N 1+ LDA N 5 + SBC + TAY N LDA N 4 + SBC + CS NOT ?[ N 6 + ROL ]? + CS ?[ N STA N 1+ STY ]? +\ *** Block No. 46 Hexblock 2E +\ + N 3 + ROL N 2+ ROL N 1+ ROL N ROL + DEX 0= ?] + 1 # LDY N ROR N 1+ ROR + CS ?[ ;C: DIVOVL ; ASSEMBLER ]? + N 2+ LDA SP )Y STA INY + N 1+ LDA SP )Y STA INY + N LDA SP )Y STA 1 # LDY + N 3 + LDA + PUTA JMP END-CODE + + + + + + +\ *** Block No. 47 Hexblock 2F +\ 2/ M/MOD 24DEC83KS) + +: M/MOD ( D N -- MOD QUOT) + DUP >R ABS OVER + 0< IF UNDER + SWAP THEN + UM/MOD R@ + 0< IF NEGATE OVER IF SWAP R@ + SWAP 1- + THEN THEN RDROP ; + +CODE 2/ ( N1 -- N2) + SP )Y LDA .A ASL + SP )Y LDA .A ROR SP )Y STA + SP X) LDA .A ROR + PUTA JMP END-CODE + + +\ *** Block No. 48 Hexblock 30 +\ /MOD / MOD */MOD */ U/MOD UD/MOD KS) + +: /MOD ( N1 N2 -- REM QUOT) >R EXTEND R> M/MOD ; + +: / ( N1 N2 -- QUOT) /MOD NIP ; + +: MOD ( N1 N2 -- REM) /MOD DROP ; + +: */MOD ( N1 N2 N3 -- REM QUOT) >R M* R> M/MOD ; + +: */ ( N1 N2 N3 -- QUOT) */MOD NIP ; + +: U/MOD ( U1 U2 -- UREM UQUOT) 0 SWAP UM/MOD ; + +: UD/MOD ( UD1 U2 -- UREM UDQUOT) + >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ; +\ *** Block No. 49 Hexblock 31 +\ CMOVE CMOVE> (CMOVE> BP 08APR85) + +CODE CMOVE ( FROM TO QUAN --) + 3 # LDA SETUP JSR DEY + [[ [[ N CPY 0= ?[ N 1+ DEC 0< ?[ + 1 # LDY NEXT JMP ]? ]? + N 4 + )Y LDA N 2+ )Y STA INY 0= ?] + N 5 + INC N 3 + INC ]] END-CODE + + + + + + + + +\ *** Block No. 50 Hexblock 32 +\ CMOVE> MOVE cas 26jan06 +CODE CMOVE> ( FROM TO QUAN --) + 3 # LDA SETUP JSR + CLC N 1+ LDA N 3 + ADC N 3 + STA + CLC N 1+ LDA N 5 + ADC N 5 + STA + N 1+ INC N LDY CLC CS ?[ +LABEL (CMOVE> + DEY N 4 + )Y LDA N 2+ )Y STA ]? + TYA (CMOVE> BNE + N 3 + DEC N 5 + DEC N 1+ DEC + (CMOVE> BNE 1 # LDY + NEXT JMP END-CODE + +: MOVE ( FROM TO QUAN --) >R 2DUP U< IF R> CMOVE> EXIT THEN + R> CMOVE ; + +\ *** Block No. 51 Hexblock 33 +\ PLACE COUNT ERASE 16FEB85BP/KS) + +: PLACE ( ADDR LEN TO --) OVER >R ROT OVER 1+ R> MOVE C! ; + +CODE COUNT ( ADDR -- ADDR+1 LEN) + SP X) LDA N STA CLC 1 # ADC SP X) STA + SP )Y LDA N 1+ STA 0 # ADC SP )Y STA + SP 2DEC (C@ JMP END-CODE + +\ : COUNT ( ADR -- ADR+1 LEN ) DUP 1+ SWAP C@ ; + +: ERASE ( ADDR QUAN --) 0 FILL ; + + + + +\ *** Block No. 52 Hexblock 34 +\ FILL 11JUN85BP) + +CODE FILL ( ADDR QUAN 8B -- ) + 3 # LDA SETUP JSR DEY + N LDA N 3 + LDX + 0<> ?[ [[ [[ N 4 + )Y STA INY 0= ?] + N 5 + INC DEX 0= ?] + ]? N 2+ LDX + 0<> ?[ [[ N 4 + )Y STA INY DEX 0= ?] + ]? 1 # LDY + NEXT JMP END-CODE + +\\ : FILL ( ADDR QUAN 8B --) SWAP ?DUP + IF >R OVER C! DUP 1+ R> 1- CMOVE EXIT THEN 2DROP ; + + +\ *** Block No. 53 Hexblock 35 +\ HERE PAD ALLOT , C, COMPILE 24DEC83KS) + +: HERE ( -- ADDR) DP @ ; + +: PAD ( -- ADDR) HERE 042 + ; + +: ALLOT ( N --) DP +! ; + +: , ( 16B --) HERE ! 2 ALLOT ; + +: C, ( 8B --) HERE C! 1 ALLOT ; + +: COMPILE R> DUP 2+ >R @ , ; RESTRICT + + + +\ *** Block No. 54 Hexblock 36 +\ INPUT STRINGS 24DEC83KS) + +VARIABLE #TIB 0 #TIB ! +VARIABLE >TIB $100 >TIB ! \ 050 ALLOT +VARIABLE >IN 0 >IN ! +VARIABLE BLK 0 BLK ! +VARIABLE SPAN 0 SPAN ! + +: TIB ( -- ADDR ) >TIB @ ; + +: QUERY TIB 050 EXPECT SPAN @ #TIB ! >IN OFF BLK OFF ; + + + + + +\ *** Block No. 55 Hexblock 37 +\ SCAN SKIP /STRING 12OCT84BP) + +: SCAN ( ADDR0 LEN0 CHAR -- ADDR1 LEN1) >R + BEGIN DUP WHILE OVER C@ R@ - + WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; + +: SKIP ( ADDR LEN DEL -- ADDR1 LEN1) >R + BEGIN DUP WHILE OVER C@ R@ = + WHILE 1- SWAP 1+ SWAP REPEAT RDROP ; + + +: /STRING ( ADDR0 LEN0 +N - ADDR1 LEN1) + OVER UMIN ROT OVER + -ROT - ; + + + +\ *** Block No. 56 Hexblock 38 +\ CAPITAL 03APR85BP) +(C LABEL (CAPITAL \ FOR COMMODORE ONLY + PHA 0DF # AND \ 2ND UPPER TO LOWER + ASCII A # CMP + CS ?[ ASCII Z 1+ # CMP + CC ?[ PLA CLC ASCII A ASCII A - # ADC RTS + ]? ]? PLA RTS END-CODE ) + +LABEL (CAPITAL \ FOR ASCII ONLY + ASCII a # CMP + CS ?[ ASCII z 1+ # CMP + CC ?[ SEC ASCII a ASCII A - # SBC + ]? ]? RTS END-CODE + +CODE CAPITAL ( CHAR -- CHAR' ) + SP X) LDA (CAPITAL JSR SP X) STA NEXT JMP END-CODE +\ *** Block No. 57 Hexblock 39 +\ CAPITALIZE 03APR85BP) + +CODE CAPITALIZE ( STRING -- STRING ) + SP X) LDA N STA SP )Y LDA N 1+ STA + N X) LDA N 2+ STA DEY + [[ N 2+ CPY 0= ?[ 1 # LDY NEXT JMP ]? + INY N )Y LDA (CAPITAL JSR N )Y STA + ]] END-CODE + +\\ : CAPITALIZE ( STRING -- STRING ) + DUP COUNT BOUNDS ?DO I C@ CAPITAL I C! THEN LOOP ; + +\\ CAPITAL ( CHAR -- CHAR ) + ASCII A ASCII Z 1+ UWITHIN + IF I C@ [ ASCII A ASCII A - ] LITERAL - ; + +\ *** Block No. 58 Hexblock 3A +\ (WORD 08APR85BP) + +| CODE (WORD ( CHAR ADR0 LEN0 -- ADR) + \ N : LENGTH OF SOURCE + \ N+2 : PTR IN SOURCE / NEXT CHAR + \ N+4 : STRING START ADRESS + \ N+6 : STRING LENGTH + N 6 + STX \ 0 =: STRING_LENGTH + 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] + 1 # LDY CLC >IN LDA N 2+ ADC N 2+ STA + \ >IN+ADR0 =: N+2 + >IN 1+ LDA N 3 + ADC N 3 + STA SEC N LDA >IN SBC N STA + \ LEN0->IN =: N + N 1+ LDA >IN 1+ SBC N 1+ STA + CC ?[ SP X) LDA >IN STA \ STREAM EXHAUSTED + SP )Y LDA >IN 1+ STA +\ *** Block No. 59 Hexblock 3B +\ (WORD 08APR85BP) + +][ 4 # LDY [[ N LDA N 1+ ORA \ SKIP CHAR'S + 0= NOT ?[[ N 2+ X) LDA SP )Y CMP \ WHILE COUNT <>0 + 0= ?[[ N 2+ WINC N WDEC ]]? + N 2+ LDA N 4 + STA \ SAVE STRING_START_ADRESS + N 3 + LDA N 5 + STA + [[ N 2+ X) LDA SP )Y CMP PHP \ SCAN FOR CHAR + N 2+ WINC N WDEC PLP + 0= NOT ?[[ N 6 + INC \ COUNT STRING_LENGTH + N LDA N 1+ ORA + 0= ?] ]? ]? \ FROM COUNT = 0 IN SKIP) + SEC 2 # LDY + \ ADR_AFTER_STRING - ADR0 =: >IN) + N 2+ LDA SP )Y SBC >IN STA INY + N 3 + LDA SP )Y SBC >IN 1+ STA +\ *** Block No. 60 Hexblock 3C +\ (WORD 08APR85BP) + +]? \ FROM 1ST ][, STREAM WAS EXHAUSTED + \ WHEN WORD CALLED) + CLC 4 # LDA SP ADC SP STA + CS ?[ SP 1+ INC ]? \ 2DROP + USER' DP # LDY UP )Y LDA + SP X) STA N STA INY + UP )Y LDA 1 # LDY + SP )Y STA N 1+ STA \ DP @ + DEY N 6 + LDA \ STORE COUNT BYTE FIRST + [[ N )Y STA N 4 + )Y LDA INY + N 6 + DEC 0< ?] + 020 # LDA N )Y STA \ ADD A BLANK + 1 # LDY NEXT JMP END-CODE + +\ *** Block No. 61 Hexblock 3D +\ SOURCE WORD PARSE NAME 08APR85BP) + +: SOURCE ( -- ADDR LEN) + BLK @ ?DUP IF BLOCK B/BLK EXIT THEN TIB #TIB @ ; + +: WORD ( CHAR -- ADDR) SOURCE (WORD ; + +: PARSE ( CHAR -- ADDR LEN) >R SOURCE >IN @ /STRING OVER SWAP + R> SCAN >R OVER - DUP R> 0<> - >IN +! ; + +: NAME ( -- ADDR) BL WORD CAPITALIZE EXIT ; + +\\ : WORD ( CHAR -- ADDR) >R + SOURCE OVER SWAP >IN @ /STRING R@ SKIP OVER SWAP R> + SCAN >R ROT OVER SWAP - R> 0<> - >IN ! + OVER - HERE PLACE BL HERE COUNT + C! HERE ; +\ *** Block No. 62 Hexblock 3E +\ STATE ASCII ," (" " 24DEC83KS) + +VARIABLE STATE 0 STATE ! + +: ASCII BL WORD 1+ C@ STATE @ + IF [COMPILE] LITERAL THEN ; IMMEDIATE + +: ," ASCII " PARSE HERE OVER 1+ ALLOT PLACE ; + +: "LIT R> R> UNDER COUNT + >R >R ; RESTRICT + +: (" "LIT ; RESTRICT + +: " COMPILE (" ," ; IMMEDIATE RESTRICT + + +\ *** Block No. 63 Hexblock 3F +\ ." ( .( \ \\ HEX DECIMAL 08SEP84KS) +: (." "LIT COUNT TYPE ; RESTRICT + +: ." COMPILE (." ," ; IMMEDIATE RESTRICT + +: ( ASCII ) PARSE 2DROP ; IMMEDIATE + +: .( ASCII ) PARSE TYPE ; IMMEDIATE + +: \ >IN @ C/L / 1+ C/L * >IN ! ; IMMEDIATE + +: \\ B/BLK >IN ! ; IMMEDIATE + +: \NEEDS NAME FIND NIP IF [COMPILE] \ THEN ; + +: HEX 010 BASE ! ; : DECIMAL 0A BASE ! ; +\ *** Block No. 64 Hexblock 40 +\ NUMBER CONV.: DIGIT? ACCUMULATE KS) +: DIGIT? ( CHAR -- DIGIT TRUE/ FALSE ) + ASCII 0 - DUP 9 U> + IF [ ASCII A ASCII 9 - 1- ] LITERAL - DUP 9 U> + IF [ 2SWAP ( UNSTRUKTURIERT) ] THEN + BASE @ OVER U> ?DUP ?EXIT THEN DROP FALSE ; + +: ACCUMULATE ( +D0 ADR DIGIT - +D1 ADR) + SWAP >R SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> ; + +: CONVERT ( +D1 ADDR0 -- +D2 ADDR2) + 1+ BEGIN COUNT DIGIT? WHILE ACCUMULATE REPEAT 1- ; + +| : END? ( -- FLAG ) PTR @ 0= ; +| : CHAR ( ADDR0 -- ADDR1 CHAR ) COUNT -1 PTR +! ; +| : PREVIOUS ( ADDR0 -- ADDR0 CHAR) 1- COUNT ; +\ *** Block No. 65 Hexblock 41 +\ ?NONUM ?NUM FIXBASE? 13FEB85KS) + +VARIABLE DPL -1 DPL ! + +| : ?NONUM ( FLAG -- EXIT IF TRUE ) + IF RDROP 2DROP DROP RDROP FALSE THEN ; + +| : ?NUM ( FLAG -- EXIT IF TRUE ) + IF RDROP DROP R> IF DNEGATE THEN + ROT DROP DPL @ 1+ ?DUP ?EXIT DROP TRUE THEN ; +| : FIXBASE? ( CHAR - CHAR FALSE / NEWBASE TRUE ) + ASCII & CASE? IF 0A TRUE EXIT THEN + ASCII $ CASE? IF 10 TRUE EXIT THEN + ASCII H CASE? IF 10 TRUE EXIT THEN + ASCII % CASE? IF 2 TRUE EXIT THEN FALSE ; + +\ *** Block No. 66 Hexblock 42 +\ 13FEB85KS) + +| : PUNCTUATION? ( CHAR -- FLAG) + ASCII , OVER = SWAP ASCII . = OR ; + +| : ?DPL DPL @ -1 = ?EXIT 1 DPL +! ; + +| VARIABLE PTR \ POINTS INTO STRING + + + + + + + + +\ *** Block No. 67 Hexblock 43 +\ (NUMBER NUMBER 13FEB85KS) +: NUMBER? ( STRING - STRING FALSE / N 0< / D 0> ) + BASE PUSH DUP COUNT PTR ! DPL ON + 0 >R ( +SIGN) + 0.0 ROT END? ?NONUM CHAR + ASCII - CASE? + IF RDROP TRUE >R END? ?NONUM CHAR THEN FIXBASE? + IF BASE ! END? ?NONUM CHAR THEN + BEGIN DIGIT? 0= ?NONUM + BEGIN ACCUMULATE ?DPL END? ?NUM + CHAR DIGIT? 0= UNTIL + PREVIOUS PUNCTUATION? 0= ?NONUM + DPL OFF END? ?NUM CHAR + REPEAT ; +: NUMBER ( STRING -- D ) + NUMBER? ?DUP 0= ABORT" ?" 0< IF EXTEND THEN ; +\ *** Block No. 68 Hexblock 44 +\ HIDE REVEAL IMMEDIATE RESTRICT KS) +VARIABLE LAST 0 LAST ! + +| : LAST? ( -- FALSE / ACF TRUE) LAST @ ?DUP ; + +: HIDE LAST? IF 2- @ CURRENT @ ! THEN ; + +: REVEAL LAST? IF 2- CURRENT @ ! THEN ; + +: RECURSIVE REVEAL ; IMMEDIATE RESTRICT + +| : FLAG! ( 8B --) LAST? IF UNDER C@ OR OVER C! THEN DROP ; + +: IMMEDIATE 040 FLAG! ; + +: RESTRICT 080 FLAG! ; +\ *** Block No. 69 Hexblock 45 +\ CLEARSTACK HALLOT HEAP HEAP? cas 26jan06 + +CODE CLEARSTACK USER' S0 # LDY + UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA + 1 # LDY NEXT JMP END-CODE + +: HALLOT ( QUAN -- ) S0 @ OVER - SWAP + SP@ 2+ DUP ROT - DUP S0 ! + 2 PICK OVER - MOVE CLEARSTACK S0 ! ; + +: HEAP ( -- ADDR) S0 @ 6+ ; + +: HEAP? ( ADDR -- FLAG) HEAP UP@ UWITHIN ; + +| : HEAPMOVE ( FROM -- FROM) DUP HERE OVER - + DUP HALLOT HEAP SWAP CMOVE HEAP OVER - LAST +! REVEAL ; +\ *** Block No. 70 Hexblock 46 +\ DOES> ; 30DEC84KS/BP) + +LABEL (DODOES> RP 2DEC + IP 1+ LDA RP )Y STA IP LDA RP X) STA \ PUT IP ON RP + CLC W X) LDA 3 # ADC IP STA + TXA W )Y ADC IP 1+ STA \ W@ + 3 -> IP +LABEL DOCREATE + 2 # LDA CLC W ADC PHA TXA W 1+ ADC PUSH JMP END-CODE + +| : (;CODE R> LAST @ NAME> ! ; + +: DOES> COMPILE (;CODE 04C C, + COMPILE (DODOES> ; IMMEDIATE RESTRICT + + + +\ *** Block No. 71 Hexblock 47 +\ 6502-ALIGN ?HEAD \ 08SEP84BP) + +| : 6502-ALIGN/1 ( ADR -- ADR' ) DUP 0FF AND 0FF = - ; + + +| : 6502-ALIGN/2 ( LFA -- LFA ) + HERE 0FF AND 0FF = + IF DUP DUP 1+ HERE OVER - 1+ CMOVE> \ LFA NOW INVALID + 1 LAST +! 1 ALLOT THEN ; + +VARIABLE ?HEAD 0 ?HEAD ! + +: | ?HEAD @ ?EXIT -1 ?HEAD ! ; + + + +\ *** Block No. 72 Hexblock 48 +\ WARNING CREATE 30DEC84BP) + +VARIABLE WARNING 0 WARNING ! + +| : EXISTS? + WARNING @ ?EXIT + LAST @ CURRENT @ (FIND NIP + IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; + +: CREATE HERE BLK @ , CURRENT @ @ , + NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" + HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ + IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE + HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! + ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , + ;CODE DOCREATE JMP END-CODE +\ *** Block No. 73 Hexblock 49 +\ NFA? 30DEC84BP) +| CODE NFA? ( VOCABTHREAD CFA -- NFA / FALSE) + SP X) LDA N 4 + STA SP )Y LDA N 5 + STA SP 2INC + [[ [[ SP X) LDA N 2+ STA SP )Y LDA N 3 + STA + N 2+ ORA 0= ?[ PUTFALSE JMP ]? + N 2+ )Y LDA SP )Y STA N 1+ STA + N 2+ X) LDA SP X) STA N STA + N 1+ ORA 0= ?[ NEXT JMP ]? \ N=LINK + N 2INC N X) LDA PHA SEC 01F # AND + N ADC N STA CS ?[ N 1+ INC ]? + PLA 020 # AND 0= NOT + ?[ N )Y LDA PHA + N X) LDA N STA PLA N 1+ STA ]? + N LDA N 4 + CMP 0= ?] \ VOCABTHREAD=0 + N 1+ LDA N 5 + CMP 0= ?] \ D.H. LEERES VOCABULARY + ' 2+ @ JMP END-CODE \ IN NFA? IST ERLAUBT +\ *** Block No. 74 Hexblock 4A +\ >NAME NAME> >BODY .NAME 03FEB85BP) + +: >NAME ( CFA -- NFA / FALSE) VOC-LINK + BEGIN @ DUP WHILE 2DUP 4 - SWAP + NFA? ?DUP IF -ROT 2DROP EXIT THEN REPEAT NIP ; + +| : (NAME> ( NFA -- CFA) COUNT 01F AND + ; + +: NAME> ( NFA -- CFA) DUP (NAME> SWAP C@ 020 AND IF @ THEN ; + +: >BODY ( CFA -- PFA) 2+ ; + +: .NAME ( NFA --) + ?DUP IF DUP HEAP? IF ." |" THEN COUNT 01F AND TYPE + ELSE ." ???" THEN SPACE ; + +\ *** Block No. 75 Hexblock 4B +\ : ; CONSTANT VARIABLE 09JAN85KS/BP) + +: : CREATE HIDE CURRENT @ CONTEXT ! ] 0 + ;CODE HERE >RECOVER ! \ RESOLVE FWD. REFERENCE + RP 2DEC IP LDA RP X) STA IP 1+ LDA RP )Y STA + W LDA CLC 2 # ADC IP STA TXA W 1+ ADC IP 1+ STA + NEXT JMP END-CODE + +: ; 0 ?PAIRS COMPILE EXIT + [COMPILE] [ REVEAL ; IMMEDIATE RESTRICT + +: CONSTANT ( 16B --) CREATE , + ;CODE SP 2DEC 2 # LDY W )Y LDA SP X) STA INY + W )Y LDA 1 # LDY SP )Y STA NEXT JMP END-CODE + +: VARIABLE CREATE 2 ALLOT ; +\ *** Block No. 76 Hexblock 4C +\ UALLOT USER ALIAS 10JAN85KS/BP) + +: UALLOT ( QUAN -- OFFSET) + DUP UDP @ + 0FF U> ABORT" USERAREA FULL" + UDP @ SWAP UDP +! ; + +: USER CREATE 2 UALLOT C, + ;CODE SP 2DEC 2 # LDY W )Y LDA CLC UP ADC SP X) STA + TXA INY UP 1+ ADC 1 # LDY SP )Y STA NEXT JMP END-CODE + +: ALIAS ( CFA --) + CREATE LAST @ DUP C@ 020 AND + IF -2 ALLOT ELSE 020 FLAG! THEN (NAME> ! ; + + + +\ *** Block No. 77 Hexblock 4D +\ VOC-LINK VP CURRENT CONTEXT ALSO BP) +CREATE VP 10 ALLOT + +VARIABLE CURRENT + +: CONTEXT ( -- ADR ) VP DUP @ + 2+ ; + +| : THRU.VOCSTACK ( -- FROM TO ) VP 2+ CONTEXT ; +\ "ONLY FORTH ALSO ASSEMBLER" GIVES VP : +\ COUNTWORD = 6 \ONLY\FORTH\ASSEMBLER + +: ALSO VP @ + 0A > ERROR" VOCABULARY STACK FULL" + CONTEXT @ 2 VP +! CONTEXT ! ; + +: TOSS -2 VP +! ; +\ *** Block No. 78 Hexblock 4E +\ VOCABULARY FORTH ONLY FORTH-83 KS/BP) + +: VOCABULARY CREATE 0 , 0 , + HERE VOC-LINK @ , VOC-LINK ! DOES> CONTEXT ! ; + +\ NAME \ CODE \ THREAD \ COLDTHREAD \ VOC-LINK + +VOCABULARY FORTH + +VOCABULARY ONLY +] DOES> [ ONLYPATCH ] 0 VP ! CONTEXT ! ALSO ; ' ONLY ! + +: ONLYFORTH ONLY FORTH ALSO DEFINITIONS ; + + + +\ *** Block No. 79 Hexblock 4F +\ DEFINITIONS ORDER WORDS 13JAN84BP/KS) + +: DEFINITIONS CONTEXT @ CURRENT ! ; + +| : .VOC ( ADR -- ) @ 2- >NAME .NAME ; + +: ORDER + THRU.VOCSTACK DO I .VOC -2 +LOOP 2 SPACES CURRENT .VOC ; + +: WORDS CONTEXT @ + BEGIN @ DUP STOP? 0= AND + WHILE ?CR DUP 2+ .NAME SPACE REPEAT DROP ; + + + + +\ *** Block No. 80 Hexblock 50 +\ (FIND 08APR85BP) + +CODE (FIND ( STRING THREAD + -- STRING FALSE / NAMEFIELD TRUE) + 3 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] + N 2+ X) LDA 01F # AND N 4 + STA +LABEL FINDLOOP 0 # LDY + N )Y LDA TAX INY + N )Y LDA N 1+ STA N STX N ORA + 0= ?[ 1 # LDY 0 # LDX PUTFALSE JMP ]? + INY N )Y LDA 01F # AND N 4 + CMP + FINDLOOP BNE \ COUNTBYTE MATCH + CLC 2 # LDA N ADC N 5 + STA + 0 # LDA N 1+ ADC N 6 + STA + N 4 + LDY + [[ N 2+ )Y LDA N 5 + )Y CMP +\ *** Block No. 81 Hexblock 51 +\ + FINDLOOP BNE DEY 0= ?] + 3 # LDY N 6 + LDA SP )Y STA DEY + N 5 + LDA SP )Y STA + DEY 0 # LDX PUTTRUE JMP END-CODE + + + + + + + + + + + +\ *** Block No. 82 Hexblock 52 +\ FOUND 29JAN85BP) + +| CODE FOUND ( NFA -- CFA N ) + SP X) LDA N STA SP )Y LDA N 1+ STA + N X) LDA N 2+ STA 01F # AND SEC N ADC N STA + CS ?[ N 1+ INC ]? + N 2+ LDA 020 # AND + 0= ?[ N LDA SP X) STA N 1+ LDA + ][ N X) LDA SP X) STA N )Y LDA ]? SP )Y STA + SP 2DEC N 2+ LDA 0< ?[ INY ]? + .A ASL + 0< NOT ?[ TYA 0FF # EOR TAY INY ]? + TYA SP X) STA + 0< ?[ 0FF # LDA 24 C, ]? + TXA 1 # LDY SP )Y STA + NEXT JMP END-CODE +\ *** Block No. 83 Hexblock 53 +\\ + +| : FOUND ( NFA -- CFA N ) + DUP C@ >R (NAME> + R@ 020 AND IF @ THEN + -1 R@ 080 AND IF 1- THEN + R> 040 AND IF NEGATE THEN ; + + + + + + + + + +\ *** Block No. 84 Hexblock 54 +\ FIND ' ['] 13JAN85BP) cas2013apr05 + +: FIND ( STRING -- CFA N / STRING FALSE) + CONTEXT DUP @ OVER 2- @ = IF 2- THEN + BEGIN UNDER @ (FIND IF NIP FOUND EXIT THEN + OVER VP 2+ U> + WHILE SWAP 2- REPEAT NIP FALSE ; + +: ' ( -- CFA ) NAME FIND 0= ABORT" WHAT?" ; + +: [COMPILE] ' , ; IMMEDIATE RESTRICT + +: ['] ' [COMPILE] LITERAL ; IMMEDIATE RESTRICT + +: NULLSTRING? ( STRING -- STRING FALSE / TRUE) + DUP C@ 0= DUP IF NIP THEN ; +\ *** Block No. 85 Hexblock 55 +\ >INTERPRET 28FEB85BP) + +LABEL JUMP + INY CLC W )Y LDA 2 # ADC IP STA + INY W )Y LDA 0 # ADC IP 1+ STA + 1 # LDY NEXT JMP END-CODE +VARIABLE >INTERPRET + +JUMP ' >INTERPRET ! + +\\ MAKE VARIABLE >INTERPRET TO SPECIAL + DEFER + + + + +\ *** Block No. 86 Hexblock 56 +\ INTERPRET INTERACTIVE 31DEC84KS/BP) cas 26jan06 + +DEFER NOTFOUND + +: NO.EXTENSIONS ( STRING -- ) ERROR" WHAT?" ; \ STRING NOT 0 + +' NO.EXTENSIONS IS NOTFOUND + +: INTERPRET >INTERPRET ; -2 ALLOT + +| : INTERACTIVE ?STACK NAME FIND ?DUP + IF 1 AND IF EXECUTE >INTERPRET THEN + ABORT" COMPILE ONLY" THEN NULLSTRING? ?EXIT NUMBER? + 0= IF NOTFOUND THEN >INTERPRET ; -2 ALLOT + +' INTERACTIVE >INTERPRET ! +\ *** Block No. 87 Hexblock 57 +\ COMPILING [ ] 20DEC84BP) + +| : COMPILING + ?STACK NAME FIND ?DUP + IF 0> IF EXECUTE >INTERPRET THEN + , >INTERPRET THEN + NULLSTRING? ?EXIT NUMBER? ?DUP + IF 0> IF SWAP [COMPILE] LITERAL THEN + [COMPILE] LITERAL + ELSE NOTFOUND THEN >INTERPRET ; -2 ALLOT + +: [ ['] INTERACTIVE IS >INTERPRET STATE OFF ; IMMEDIATE + +: ] ['] COMPILING IS >INTERPRET STATE ON ; + + +\ *** Block No. 88 Hexblock 58 +\ PERFOM DEFER IS 03FEB85BP) + +| : CRASH TRUE ABORT" CRASH" ; + +: DEFER CREATE ['] CRASH , + ;CODE 2 # LDY W )Y LDA PHA INY W )Y LDA + W 1+ STA PLA W STA 1 # LDY W 1- JMP END-CODE + +: (IS R> DUP 2+ >R @ ! ; + +| : DEF? ( CFA -- ) @ ['] NOTFOUND @ OVER = + SWAP ['] >INTERPRET @ = OR NOT ABORT" NOT DEFERRED" ; + +: IS ( ADR -- ) ' DUP DEF? >BODY + STATE @ IF COMPILE (IS , EXIT THEN ! ; IMMEDIATE + +\ *** Block No. 89 Hexblock 59 +\ ?STACK 08SEP84KS) + +| : STACKFULL ( -- ) + DEPTH 20 > ABORT" TIGHT STACK" + REVEAL LAST? IF DUP HEAP? IF NAME> ELSE 4 - THEN + (FORGET THEN TRUE ABORT" DICTIONARY FULL" ; + +CODE ?STACK USER' DP # LDY + SEC SP LDA UP )Y SBC N STA INY SP 1+ LDA UP )Y SBC + 0= ?[ 1 # LDY ;C: STACKFULL ; ASSEMBLER ]? + USER' S0 # LDY UP )Y LDA SP CMP INY + UP )Y LDA SP 1+ SBC 1 # LDY CS ?[ NEXT JMP ]? + ;C: TRUE ABORT" STACK EMPTY" ; -2 ALLOT + +\\ : ?STACK SP@ HERE - 100 U< IF STACKFULL THEN + SP@ S0 @ U> ABORT" STACK EMPTY" ; +\ *** Block No. 90 Hexblock 5A +\ .STATUS PUSH LOAD 08SEP84KS) + +DEFER .STATUS ' NOOP IS .STATUS + +| CREATE PULL 0 ] R> R> ! ; + +: PUSH ( ADDR -- ) + R> SWAP DUP >R @ >R PULL >R >R ; RESTRICT + + +: LOAD ( BLK --) + ?DUP 0= ?EXIT BLK PUSH BLK ! + >IN PUSH >IN OFF .STATUS INTERPRET ; + + + +\ *** Block No. 91 Hexblock 5B +\ +LOAD THRU +THRU --> RDEPTH DEPTH KS) + +: +LOAD ( OFFSET --) BLK @ + LOAD ; + +: THRU ( FROM TO --) 1+ SWAP DO I LOAD LOOP ; + +: +THRU ( OFF0 OFF1 --) 1+ SWAP DO I +LOAD LOOP ; + +: --> 1 BLK +! >IN OFF .STATUS ; IMMEDIATE + +: RDEPTH ( -- +N) R0 @ RP@ 2+ - 2/ ; + +: DEPTH ( -- +N) SP@ S0 @ SWAP - 2/ ; + + + +\ *** Block No. 92 Hexblock 5C +\ QUIT (QUIT ABORT 07JUN85BP) + +| : PROMPT STATE @ IF ." COMPILING" EXIT THEN ." OK" ; + +: (QUIT + BEGIN .STATUS CR QUERY INTERPRET PROMPT REPEAT ; -2 ALLOT + +DEFER 'QUIT ' (QUIT IS 'QUIT + +: QUIT R0 @ RP! [COMPILE] [ 'QUIT ; -2 ALLOT + +: STANDARDI/O [ OUTPUT ] LITERAL OUTPUT 4 CMOVE ; + +DEFER 'ABORT ' NOOP IS 'ABORT + +: ABORT CLEARSTACK END-TRACE 'ABORT STANDARDI/O QUIT ; -2 ALLOT +\ *** Block No. 93 Hexblock 5D +\ (ERROR ABORT" ERROR" 20MAR85BP) + +VARIABLE SCR 1 SCR ! + +VARIABLE R# 0 R# ! + +: (ERROR ( STRING -- ) + STANDARDI/O SPACE HERE .NAME COUNT TYPE SPACE ?CR + BLK @ ?DUP IF SCR ! >IN @ R# ! THEN QUIT ; -2 ALLOT + +' (ERROR ERRORHANDLER ! + +: (ABORT" "LIT SWAP IF + >R CLEARSTACK R> ERRORHANDLER PERFORM + EXIT THEN DROP ; RESTRICT + +\ *** Block No. 94 Hexblock 5E +\ + +| : (ERR" "LIT SWAP + IF ERRORHANDLER PERFORM EXIT THEN DROP ; RESTRICT + +: ABORT" COMPILE (ABORT" ," ; IMMEDIATE RESTRICT + +: ERROR" COMPILE (ERR" ," ; IMMEDIATE RESTRICT + + + + + + + + +\ *** Block No. 95 Hexblock 5F +\ -TRAILING 08APR85BP) + +020 CONSTANT BL + +CODE -TRAILING ( ADDR N1 -- ADR N2 ) + TYA SETUP JSR + SP X) LDA N 2+ STA CLC + SP )Y LDA N 1+ ADC N 3 + STA + N LDY CLC CS ?[ +LABEL (-TRAIL + DEY N 2+ )Y LDA BL # CMP + 0<> ?[ INY 0= ?[ N 1+ INC ]? + TYA PHA N 1+ LDA PUSH JMP ]? + ]? TYA (-TRAIL BNE + N 3 + DEC N 1 + DEC (-TRAIL BPL + TYA PUSH0A JMP END-CODE +\ *** Block No. 96 Hexblock 60 +\ SPACE SPACES 29JAN85KS/BP) + +: SPACE BL EMIT ; + +: SPACES ( U --) 0 ?DO SPACE LOOP ; + +\\ +: -TRAILING ( ADDR N1 -- ADDR N2) + 2DUP BOUNDS + ?DO 2DUP + 1- C@ BL - + IF LEAVE THEN 1- LOOP ; + + + + + +\ *** Block No. 97 Hexblock 61 +\ HOLD <# #> SIGN # #S 24DEC83KS) +| : HLD ( -- ADDR) PAD 2- ; + +: HOLD ( CHAR -- ) -1 HLD +! HLD @ C! ; + +: <# HLD HLD ! ; + +: #> ( 32B -- ADDR +N ) 2DROP HLD @ HLD OVER - ; + +: SIGN ( N -- ) 0< IF ASCII - HOLD THEN ; + +: # ( +D1 -- +D2) BASE @ UD/MOD ROT 09 OVER < + IF [ ASCII A ASCII 9 - 1- ] LITERAL + + THEN ASCII 0 + HOLD ; + +: #S ( +D -- 0 0 ) BEGIN # 2DUP D0= UNTIL ; +\ *** Block No. 98 Hexblock 62 +\ PRINT NUMBERS 24DEC83KS) + +: D.R -ROT UNDER DABS <# #S ROT SIGN #> + ROT OVER MAX OVER - SPACES TYPE ; + +: .R SWAP EXTEND ROT D.R ; + +: U.R 0 SWAP D.R ; + +: D. 0 D.R SPACE ; + +: . EXTEND D. ; + +: U. 0 D. ; + + +\ *** Block No. 99 Hexblock 63 +\ .S LIST C/L L/S 24DEC83KS) + +: .S SP@ S0 @ OVER - 020 UMIN BOUNDS ?DO I @ U. 2 +LOOP ; + +40 CONSTANT C/L \ SCREEN LINE LENGTH + +10 CONSTANT L/S \ LINES PER SCREEN + +: LIST ( BLK --) + SCR ! ." SCR " SCR @ DUP U. + ." DR " DRV? . + L/S 0 DO CR I 2 .R SPACE SCR @ BLOCK + I C/L * + C/L -TRAILING TYPE LOOP CR ; + + + +\ *** Block No. 100 Hexblock 64 +\ MULTITASKER PRIMITIVES BP03NOV85) +CODE PAUSE NEXT HERE 2- ! END-CODE + +: LOCK ( ADDR --) + DUP @ UP@ = IF DROP EXIT THEN + BEGIN DUP @ WHILE PAUSE REPEAT UP@ SWAP ! ; + +: UNLOCK ( ADDR --) DUP LOCK OFF ; + +LABEL WAKE WAKE >WAKE ! + PLA SEC 5 # SBC UP STA PLA 0 # SBC UP 1+ STA + 04C # LDA UP X) STA 6 # LDY UP )Y LDA SP STA + INY UP )Y LDA SP 1+ STA 1 # LDY + SP X) LDA RP STA SP )Y LDA RP 1+ STA SP 2INC + IP # LDX XPULL JMP END-CODE + +\ *** Block No. 101 Hexblock 65 +\ BUFFER MECHANISM 15DEC83KS) cas 26jan06 + +USER FILE 0 FILE ! \ ADR OF FILE CONTROL BLOCK + +VARIABLE PREV 0 PREV ! \ LISTHEAD + +| VARIABLE BUFFERS 0 BUFFERS ! \ SEMAPHOR + +0408 CONSTANT B/BUF \ size of buffer + + + + + + + +\ *** Block No. 102 Hexblock 66 +\\ structure of buffer (same for all volksFORTH ) cas 26jan06 + 0 : LINK + 2 : FILE + 6 : BLOCKNR + 8 : STATUSFLAGS +0A : DATA .. 1 KB .. + +STATUSFLAG BITS: 15 1 -> UPDATED + +FILE = -1 EMPTY BUFFER + = 0 NO FCB , DIRECT ACCESS + = ELSE ADR OF FCB + ( SYSTEM DEPENDENT ) + + + +\ *** Block No. 103 Hexblock 67 +\ SEARCH FOR BLOCKS IN MEMORY 11JUN85BP) + +LABEL THISBUFFER? 2 # LDY + [[ N 4 + )Y LDA N 2- ,Y CMP + 0= ?[[ INY 6 # CPY 0= ?] ]? RTS \ ZERO IF THIS BUFFER ) + +| CODE (CORE? ( BLK FILE -- ADDR / BLK FILE ) + \ N-AREA : 0 BLK 2 FILE 4 BUFFER + \ 6 PREDECESSOR + 3 # LDY + [[ SP )Y LDA N ,Y STA DEY 0< ?] + USER' OFFSET # LDY CLC UP )Y LDA N 2+ ADC N 2+ STA + INY UP )Y LDA N 3 + ADC N 3 + STA PREV LDA N 4 + STA + PREV 1+ LDA N 5 + STA THISBUFFER? JSR 0= ?[ + + +\ *** Block No. 104 Hexblock 68 +\ " 11JUN85BP) + +LABEL BLOCKFOUND SP 2INC 1 # LDY + 8 # LDA CLC N 4 + ADC SP X) STA + N 5 + LDA 0 # ADC SP )Y STA + ' EXIT @ JMP ]? + [[ N 4 + LDA N 6 + STA N 5 + LDA N 7 + STA + N 6 + X) LDA N 4 + STA 1 # LDY + N 6 + )Y LDA N 5 + STA N 4 + ORA + 0= ?[ ( LIST EMPTY ) NEXT JMP ]? + THISBUFFER? JSR 0= ?] \ FOUND, RELINK + N 4 + X) LDA N 6 + X) STA 1 # LDY N 4 + )Y LDA N 6 + )Y STA + PREV LDA N 4 + X) STA PREV 1+ LDA N 4 + )Y STA + N 4 + LDA PREV STA N 5 + LDA PREV 1+ STA + BLOCKFOUND JMP END-CODE + +\ *** Block No. 105 Hexblock 69 +\\ (CORE? 23SEP85BP +| : this? ( blk file bufadr -- flag ) + DUP 4+ @ SWAP 2+ @ D= ; + +| : (CORE? ( BLK FILE -- DATAADDR / BLK FILE ) + BEGIN OVER OFFSET @ + OVER PREV @ + THIS? IF RDROP 2DROP PREV @ 8 + EXIT THEN + 2DUP >R OFFSET @ + >R PREV @ + BEGIN DUP @ ?DUP + 0= IF RDROP RDROP DROP EXIT THEN + DUP R> R> 2DUP >R >R ROT THIS? 0= + WHILE NIP REPEAT DUP @ ROT ! PREV @ OVER ! PREV ! + RDROP RDROP REPEAT ; -2 ALLOT + + + +\ *** Block No. 106 Hexblock 6A +\ (DISKERR 11JUN85BP) + +: (DISKERR ." ERROR ! R TO RETRY " + KEY DUP ASCII R = SWAP ASCII R = + OR NOT ABORT" ABORTED" ; + + +DEFER DISKERR ' (DISKERR IS DISKERR + +DEFER R/W + + + + + + +\ *** Block No. 107 Hexblock 6B +\ BACKUP EMPTYBUF READBLK 11JUN85BP) +| : BACKUP ( BUFADDR --) + DUP 6+ @ 0< + IF 2+ DUP @ 1+ \ BUFFER EMPTY IF FILE = -1 + IF INPUT PUSH OUTPUT PUSH STANDARDI/O + BEGIN DUP 6+ OVER 2+ @ 2 PICK @ 0 R/W + WHILE ." WRITE " DISKERR + REPEAT THEN + 080 OVER 4+ 1+ CTOGGLE THEN DROP ; + +| : EMPTYBUF ( BUFADDR --) 2+ DUP ON 4+ OFF ; + +| : READBLK ( BLK FILE ADDR -- BLK FILE ADDR) + DUP EMPTYBUF INPUT PUSH OUTPUT PUSH STANDARDI/O >R + BEGIN OVER OFFSET @ + OVER R@ 8 + -ROT 1 R/W + WHILE ." READ " DISKERR REPEAT R> ; +\ *** Block No. 108 Hexblock 6C +\ TAKE MARK UPDATES? FULL? CORE? BP) + +| : TAKE ( -- BUFADDR) PREV + BEGIN DUP @ WHILE @ DUP 2+ @ -1 = UNTIL + BUFFERS LOCK DUP BACKUP ; + +| : MARK ( BLK FILE BUFADDR -- BLK FILE ) + 2+ >R 2DUP R@ ! OFFSET @ + R@ 2+ ! + R> 4+ OFF BUFFERS UNLOCK ; + +| : UPDATES? ( -- BUFADDR / FLAG) + PREV BEGIN @ DUP WHILE DUP 6+ @ 0< UNTIL ; + +| : FULL? ( -- FLAG) PREV BEGIN @ DUP @ 0= UNTIL 6+ @ 0< ; + +: CORE? ( BLK FILE -- ADDR /FALSE) (CORE? 2DROP FALSE ; +\ *** Block No. 109 Hexblock 6D +\ BLOCK & BUFFER MANIPULATION 11JUN85BP) + +: (BUFFER ( BLK FILE -- ADDR) + BEGIN (CORE? TAKE MARK REPEAT ; -2 ALLOT + +: (BLOCK ( BLK FILE -- ADDR) + BEGIN (CORE? TAKE READBLK MARK REPEAT ; -2 ALLOT + +| CODE FILE@ ( -- N ) USER' FILE # LDY + UP )Y LDA PHA INY UP )Y LDA PUSH JMP END-CODE + +: BUFFER ( BLK -- ADDR ) FILE@ (BUFFER ; + +: BLOCK ( BLK -- ADDR ) FILE@ (BLOCK ; + + +\ *** Block No. 110 Hexblock 6E +\ BLOCK & BUFFER MANIPULATION 09SEP84KS) + +: UPDATE 080 PREV @ 6+ 1+ C! ; + +: SAVE-BUFFERS + BUFFERS LOCK BEGIN UPDATES? ?DUP WHILE BACKUP REPEAT + BUFFERS UNLOCK ; + +: EMPTY-BUFFERS + BUFFERS LOCK PREV + BEGIN @ ?DUP + WHILE DUP EMPTYBUF + REPEAT BUFFERS UNLOCK ; + +: FLUSH SAVE-BUFFERS EMPTY-BUFFERS ; + +\ *** Block No. 111 Hexblock 6F +\ MOVING BLOCKS 15DEC83KS) cas 26jan06 +| : (COPY ( FROM TO --) DUP FILE@ + CORE? IF PREV @ EMPTYBUF THEN + FULL? IF SAVE-BUFFERS THEN + OFFSET @ + SWAP BLOCK 2- 2- ! UPDATE ; + +| : BLKMOVE ( FROM TO QUAN --) SAVE-BUFFERS >R + OVER R@ + OVER U> >R 2DUP U< R> AND + IF R@ R@ D+ R> 0 ?DO -1 -2 D+ 2DUP (COPY LOOP + ELSE R> 0 ?DO 2DUP (COPY 1 1 D+ LOOP + THEN SAVE-BUFFERS 2DROP ; + +: COPY ( FROM TO --) 1 BLKMOVE ; + +: CONVEY ( [BLK1 BLK2] [TO.BLK --) + SWAP 1+ 2 PICK - DUP 0> NOT ABORT" NO!!" BLKMOVE ; +\ *** Block No. 112 Hexblock 70 +\ ALLOCATING BUFFERS 23SEP83KS) cas2013apr04 + +7F00 CONSTANT LIMIT VARIABLE FIRST + +: ALLOTBUFFER ( -- ) + FIRST @ R0 @ - B/BUF 2+ U< ?EXIT + B/BUF NEGATE FIRST +! FIRST @ DUP EMPTYBUF + PREV @ OVER ! PREV ! ; + +: FREEBUFFER ( -- ) + FIRST @ LIMIT B/BUF - U< + IF SAVE-BUFFERS BEGIN DUP @ FIRST @ - WHILE @ REPEAT + FIRST @ @ SWAP ! B/BUF FIRST +! THEN ; + +: ALL-BUFFERS BEGIN FIRST @ ALLOTBUFFER FIRST @ = UNTIL ; + +\ *** Block No. 113 Hexblock 71 +\ ENDPOINTS OF FORGET 04JAN85BP/KS) +| : \? ( NFA -- FLAG ) C@ 020 AND ; + +| : FORGET? ( ADR NFA -- FLAG ) \ CODE IN HEAP OR ABOVE ADR ? + NAME> UNDER 1+ U< SWAP HEAP? OR ; + +| : ENDPOINTS ( ADDR -- ADDR SYMB) + HEAP VOC-LINK @ >R + BEGIN R> @ ?DUP \ THROUGH ALL VOCABS + WHILE DUP >R 4 - >R \ LINK ON RETURNST. + BEGIN R> @ >R OVER 1- DUP R@ U< \ UNTIL LINK OR + SWAP R@ 2+ NAME> U< AND \ CODE UNDER ADR + WHILE R@ HEAP? [ 2DUP ] UNTIL \ SEARCH FOR A NAME IN HEAP + R@ 2+ \? IF OVER R@ 2+ FORGET? + IF R@ 2+ (NAME> 2+ UMAX THEN \ THEN UPDATE SYMB + THEN REPEAT RDROP REPEAT ; +\ *** Block No. 114 Hexblock 72 +\ REMOVE 23JUL85WE + +| CODE REMOVE ( DIC SYMB THR - DIC SYMB) + 5 # LDY [[ SP )Y LDA N ,Y STA DEY 0< ?] USER' S0 # LDY + CLC UP )Y LDA 6 # ADC N 6 + STA + INY UP )Y LDA 0 # ADC N 7 + STA 1 # LDY + [[ N X) LDA N 8 + STA N )Y LDA N 9 + STA N 8 + ORA 0<> + ?[[ N 8 + LDA N 6 + CMP N 9 + LDA N 7 + SBC CS + ?[ N 8 + LDA N 2 + CMP N 9 + LDA N 3 + SBC + ][ N 4 + LDA N 8 + CMP N 5 + LDA N 9 + SBC + ]? CC + ?[ N 8 + X) LDA N X) STA N 8 + )Y LDA N )Y STA + ][ N 8 + LDA N STA N 9 + LDA N 1+ STA ]? + ]]? (DROP JMP END-CODE + + +\ *** Block No. 115 Hexblock 73 +\ REMOVE- FORGET-WORDS 29APR85BP) + +| : REMOVE-WORDS ( DIC SYMB -- DIC SYMB) + VOC-LINK BEGIN @ ?DUP WHILE DUP >R 4 - REMOVE R> REPEAT ; + +| : REMOVE-TASKS ( DIC --) + UP@ BEGIN 1+ DUP @ UP@ - WHILE 2DUP @ SWAP HERE UWITHIN + IF DUP @ 1+ @ OVER ! 1- ELSE @ THEN REPEAT 2DROP ; + +| : REMOVE-VOCS ( DIC SYMB -- DIC SYMB) + VOC-LINK REMOVE THRU.VOCSTACK + DO 2DUP I @ -ROT UWITHIN + IF [ ' FORTH 2+ ] LITERAL I ! THEN -2 +LOOP + 2DUP CURRENT @ -ROT UWITHIN + IF [ ' FORTH 2+ ] LITERAL CURRENT ! THEN ; + +\ *** Block No. 116 Hexblock 74 +\ FORGET-WORDS cas 26jan06 + +| : FORGET-WORDS ( DIC SYMB --) + OVER REMOVE-TASKS REMOVE-VOCS + REMOVE-WORDS + HEAP SWAP - HALLOT DP ! 0 LAST ! ; + + + + + + + + + + +\ *** Block No. 117 Hexblock 75 +\ DELETING WORDS FROM DICT. 13JAN83KS) + +: CLEAR HERE DUP UP@ FORGET-WORDS DP ! ; + +: (FORGET ( ADR --) DUP HEAP? ABORT" IS SYMBOL" + ENDPOINTS FORGET-WORDS ; + +: FORGET ' DUP [ DP ] LITERAL @ U< ABORT" PROTECTED" + >NAME DUP HEAP? IF NAME> ELSE 2- 2- THEN (FORGET ; + +: EMPTY [ DP ] LITERAL @ + UP@ FORGET-WORDS [ UDP ] LITERAL @ UDP ! ; + + + + +\ *** Block No. 118 Hexblock 76 +\ SAVE BYE STOP? ?CR 20OCT84KS/BP) + +: SAVE + HERE UP@ FORGET-WORDS VOC-LINK @ + BEGIN DUP 2- 2- @ OVER 2- ! @ ?DUP 0= UNTIL + UP@ ORIGIN 0100 CMOVE ; + +: BYE FLUSH EMPTY (BYE ; + +| : END? KEY #CR (C 3 ) = IF TRUE RDROP THEN ; + +: STOP? ( -- FLAG) KEY? IF END? END? THEN FALSE ; + +: ?CR COL C/L 0A - U> IF CR THEN ; + + +\ *** Block No. 119 Hexblock 77 +\ IN/OUTPUT STRUCTURE 02MAR85BP) +| : OUT: CREATE DUP C, 2+ DOES> C@ OUTPUT @ + PERFORM ; + + : OUTPUT: CREATE ] DOES> OUTPUT ! ; +0 OUT: EMIT OUT: CR OUT: TYPE + OUT: DEL OUT: PAGE OUT: AT OUT: AT? DROP + +: ROW ( -- ROW) AT? DROP ; +: COL ( -- COL) AT? NIP ; + +| : IN: CREATE DUP C, 2+ DOES> C@ INPUT @ + PERFORM ; + + : INPUT: CREATE ] DOES> INPUT ! ; + +0 IN: KEY IN: KEY? IN: DECODE IN: EXPECT DROP + +\ *** Block No. 120 Hexblock 78 +\ ALIAS ONLY DEFINITIONEN 29JAN85BP) + +ONLY DEFINITIONS FORTH + +: SEAL 0 ['] ONLY >BODY ! ; \ KILL ALL WORDS IN ONLY) + + ' ONLY ALIAS ONLY + ' FORTH ALIAS FORTH + ' WORDS ALIAS WORDS + ' ALSO ALIAS ALSO +' DEFINITIONS ALIAS DEFINITIONS +HOST TARGET + + + + +\ *** Block No. 121 Hexblock 79 +\ 'COLD 07JUN85BP) cas2013apr05 +| : INIT-VOCABULARYS VOC-LINK @ + BEGIN DUP 2- @ OVER 4 - ! @ ?DUP 0= UNTIL ; + +| : INIT-BUFFERS 0 PREV ! LIMIT FIRST ! ALL-BUFFERS ; + +DEFER 'COLD ' NOOP IS 'COLD + +| : (COLD INIT-VOCABULARYS INIT-BUFFERS PAGE 'COLD ONLYFORTH + ." volksFORTH-83 3.8.7 05apr13 CS" CR RESTART ; -2 ALLOT + +DEFER 'RESTART ' NOOP IS 'RESTART +| : (RESTART ['] (QUIT IS 'QUIT + DRVINIT 'RESTART [ ERRORHANDLER ] LITERAL @ ERRORHANDLER ! + ['] NOOP IS 'ABORT ABORT ; -2 ALLOT + +\ *** Block No. 122 Hexblock 7A +\ COLD BOOTSYSTEM RESTART 09JUL85WE) +CODE COLD HERE >COLD ! + ' (COLD >BODY 100 U/MOD # LDA PHA # LDA PHA + +LABEL BOOTSYSTEM CLI 0 # LDY + CLC S0 LDA 6 # ADC N STA S0 1+ LDA 0 # ADC N 1+ STA + [[ ORIGIN ,Y LDA N )Y STA INY 0= ?] +LABEL WARMBOOT BOOTNEXTLEN 1- # LDY + [[ BOOTNEXT ,Y LDA PUTA ,Y STA DEY 0< ?] + CLC S0 LDA 6 # ADC UP STA S0 1+ LDA 0 # ADC UP 1+ STA + USER' S0 # LDY UP )Y LDA SP STA INY UP )Y LDA SP 1+ STA + USER' R0 # LDY UP )Y LDA RP STA INY UP )Y LDA RP 1+ STA + 0 # LDX 1 # LDY TXA RP X) STA RP )Y STA + PLA IP STA PLA IP 1+ STA +LABEL XYNEXT 0 # LDX 1 # LDY NEXT JMP END-CODE + +\ *** Block No. 123 Hexblock 7B +\ ( RESTART PARAM.-PASSING TO FORTH BP) + +CODE RESTART HERE >RESTART ! + ' (RESTART >BODY 100 U/MOD + # LDA PHA # LDA PHA WARMBOOT JMP END-CODE + + + + + + + + + + + +\ *** Block No. 124 Hexblock 7C +\ CODE FOR PARAMETER-PASSING TO FORTH cas 26jan06 + +\ Include system dependent Input / Output code +\ (Keyboard and Screen) +include systemio.fb + + +HOST ' TRANSIENT 8 + @ +TRANSIENT FORTH CONTEXT @ 6 + ! +TARGET + +FORTH ALSO DEFINITIONS + +: FORTH-83 ; \ LAST WORD IN DICTIONARY + + +\ *** Block No. 125 Hexblock 7D +\ SYSTEM DEPENDENT CONSTANTS BP/KS) + +VOCABULARY ASSEMBLER +ASSEMBLER DEFINITIONS +TRANSIENT ASSEMBLER +PUSHA CONSTANT PUSHA \ PUT A SIGN-EXTENDED ON STACK +PUSH0A CONSTANT PUSH0A \ PUT A ON STACK +PUSH CONSTANT PUSH \ MSB IN A AND LSB ON JSR-STACK +RP CONSTANT RP +UP CONSTANT UP +SP CONSTANT SP +IP CONSTANT IP +N CONSTANT N +PUTA CONSTANT PUTA +W CONSTANT W +SETUP CONSTANT SETUP +\ *** Block No. 126 Hexblock 7E +\ +NEXT CONSTANT NEXT +XYNEXT CONSTANT XYNEXT +(2DROP CONSTANT POPTWO +(DROP CONSTANT POP + + + + + + + + + + + +\ *** Block No. 127 Hexblock 7F +\ SYSTEM PATCHUP 05JAN85BP) cas2013apr05 + +FORTH DEFINITIONS + +\ change memory layout for stacks and buffers here +TOPADDR ' LIMIT >BODY ! +TOPADDR $F00 - S0 ! TOPADDR $480 - R0 ! + +S0 @ DUP S0 2- ! 6 + S0 7 - ! +HERE DP ! + +HOST TUDP @ TARGET UDP ! +HOST TVOC-LINK @ TARGET VOC-LINK ! +HOST MOVE-THREADS + + ) +\ *** Block No. 128 Hexblock 80 + + + + + + + + + + + + + + + + +\ *** Block No. 129 Hexblock 81 + + + + + + + + + + + + + + + + +\ *** Block No. 130 Hexblock 82 + + + + + + + + + + + + + + + + +\ *** Block No. 131 Hexblock 83 + + + + + + + + + + + + + + + + diff --git a/sources/Apple1/as65.fb.src b/sources/Apple1/as65.fb.src deleted file mode 100644 index b897f53..0000000 --- a/sources/Apple1/as65.fb.src +++ /dev/null @@ -1,204 +0,0 @@ -Screen 0 not modified - 0 \ FORTH-6502 ASSEMBLER WFR ) cas 26jan06 - 1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5) - 2 - 3 Load from Screen 1 for the transient assembler: - 4 This 6502 Forth Assembler can be loaded into the heap - 5 and then not be saved in the final binary to save memory. - 6 - 7 Load from Screen 2 for the regular assembler: - 8 This 6502 Forth Assembler will be loaded into normal - 9 memory and will be saved into the final binary. -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ TRANSIENT FORTH-6502 ASSEMBLER WFR ) er14dez88 - 1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5) - 2 - 3 ( INTERNAL LOADING 04MAY85BP/RE) - 4 hex - 5 \ HERE $200 HALLOT HEAP DP ! - 6 &10 LOAD - 7 &11 LOAD - 8 3 &8 THRU - 9 &9 LOAD \ for System-Assembler -10 -11 \ DP ! -12 -13 ONLYFORTH -14 decimal -15 -Screen 2 not modified - 0 \ FORTH-65 ASSEMBLER WFR ) er14dez88 - 1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5) - 2 ONLYFORTH - 3 Vocabulary tassembler - 4 TASSEMBLER ALSO DEFINITIONS - 5 hex - 6 - 7 8 +load \ relocate - 8 1 6 +THRU - 9 \ 7 +load \ System Assembler -10 decimal -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ FORTH-83 6502-ASSEMBLER ) er14dez88 - 1 : END-CODE CONTEXT 2- @ CONTEXT ! ; - 2 CREATE INDEX - 3 09 c, 09 c, 05 c, 15 c, 15 c, 01 c, 11 c, 80 c, - 4 09 c, 80 c, 0D c, 1D c, 19 c, 80 c, 80 c, 80 c, - 5 80 c, 00 c, 04 c, 14 c, 14 c, 80 c, 80 c, 80 c, - 6 80 c, 80 c, 0C c, 1C c, 1C c, 80 c, 80 c, 2C c, - 7 - 8 | VARIABLE MODE - 9 -10 : MODE: ( N -) CREATE C, DOES> ( -) C@ MODE ! ; -11 -12 0 MODE: .A 1 MODE: # 2 | MODE: MEM 3 MODE: ,X -13 4 MODE: ,Y 5 MODE: X) 6 MODE: )Y 0F MODE: ) -14 6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: ) -15 6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: ) -Screen 4 not modified - 0 \ UPMODE CPU ) er14dez88 - 1 | : UPMODE ( ADDR0 F0 - ADDR1 F1) - 2 IF MODE @ 8 OR MODE ! THEN 1 MODE @ 0F AND ?DUP IF - 3 0 DO DUP + LOOP THEN OVER 1+ @ AND 0= ; - 4 - 5 : CPU ( 8B -) CREATE C, DOES> ( -) C@ >c, MEM ; - 6 - 7 00 CPU BRK 18 CPU CLC D8 CPU CLD - 8 58 CPU CLI B8 CPU CLV CA CPU DEX - 9 88 CPU DEY E8 CPU INX C8 CPU INY -10 EA CPU NOP 48 CPU PHA 08 CPU PHP -11 68 CPU PLA 28 CPU PLP 40 CPU RTI -12 60 CPU RTS 38 CPU SEC F8 CPU SED -13 78 CPU SEI AA CPU TAX A8 CPU TAY -14 BA CPU TSX 8A CPU TXA 9A CPU TXS -15 98 CPU TYA -Screen 5 not modified - 0 \ M/CPU ) er14dez88 - 1 - 2 : M/CPU ( MODE OPCODE -) CREATE C, , DOES> - 3 DUP 1+ @ 80 AND IF 10 MODE +! THEN OVER FF00 AND UPMODE UPMODE - 4 IF MEM TRUE ABORT" INVALID" THEN - 5 C@ MODE @ INDEX + C@ + >c, MODE @ 7 AND - 6 IF MODE @ 0F AND 7 < IF >c, ELSE >, THEN THEN MEM ; - 7 - 8 1C6E 60 M/CPU ADC 1C6E 20 M/CPU AND 1C6E C0 M/CPU CMP - 9 1C6E 40 M/CPU EOR 1C6E A0 M/CPU LDA 1C6E 00 M/CPU ORA -10 1C6E E0 M/CPU SBC 1C6C 80 M/CPU STA 0D0D 01 M/CPU ASL -11 0C0C C1 M/CPU DEC 0C0C E1 M/CPU INC 0D0D 41 M/CPU LSR -12 0D0D 21 M/CPU ROL 0D0D 61 M/CPU ROR 0414 81 M/CPU STX -13 0486 E0 M/CPU CPX 0486 C0 M/CPU CPY 1496 A2 M/CPU LDX -14 0C8E A0 M/CPU LDY 048C 80 M/CPU STY 0480 14 M/CPU JSR -15 8480 40 M/CPU JMP 0484 20 M/CPU BIT -Screen 6 not modified - 0 \ ASSEMBLER CONDITIONALS ) er14dez88 - 1 - 2 | : RANGE? ( BRANCH -- BRANCH ) - 3 DUP ABS 07F U> ABORT" OUT OF RANGE " ; - 4 - 5 : [[ ( BEGIN) >here ; - 6 : ?] ( UNTIL) >c, >here 1+ - RANGE? >c, ; - 7 : ?[ ( IF) >c, >here 0 >c, ; - 8 : ?[[ ( WHILE) ?[ SWAP ; - 9 : ]? ( THEN) >here OVER >c@ IF SWAP >! -10 ELSE OVER 1+ - RANGE? SWAP >c! THEN ; -11 : ][ ( ELSE) >here 1+ 1 JMP -12 SWAP >here OVER 1+ - RANGE? SWAP >c! ; -13 : ]] ( AGAIN) JMP ; -14 : ]]? ( REPEAT) JMP ]? ; -15 -Screen 7 not modified - 0 \ ASSEMBLER CONDITIONALS ) er14dez88 - 1 - 2 90 CONSTANT CS B0 CONSTANT CC - 3 D0 CONSTANT 0= F0 CONSTANT 0<> - 4 10 CONSTANT 0< 30 CONSTANT 0>= - 5 50 CONSTANT VS 70 CONSTANT VC - 6 - 7 : NOT 20 [ FORTH ] XOR ; - 8 - 9 : BEQ 0<> ?] ; : BMI 0>= ?] ; -10 : BNE 0= ?] ; : BPL 0< ?] ; -11 : BCC CS ?] ; : BVC VS ?] ; -12 : BCS CC ?] ; : BVS VC ?] ; -13 -14 -15 -Screen 8 not modified - 0 \ 2INC/2DEC WINC/WDEC KS 19 MAY 84 ) er14dez88 - 1 - 2 : 2INC - 3 DUP LDA CLC 2 # ADC DUP STA CS ?[ SWAP 1+ INC ]? ; - 4 - 5 : 2DEC - 6 DUP LDA SEC 2 # SBC DUP STA CC ?[ SWAP 1+ DEC ]? ; - 7 - 8 : WINC DUP INC 0= ?[ SWAP 1+ INC ]? ; - 9 -10 : WDEC DUP LDA 0= ?[ OVER 1+ DEC ]? DEC ; -11 -12 : ;C: RECOVER JSR END-CODE ] 0 LAST ! 0 ; -13 -14 -15 -Screen 9 not modified - 0 \ ;CODE CODE CODE> BP 03 02 85) er14dez88 - 1 ONLYFORTH - 2 - 3 : ASSEMBLER ASSEMBLER [ ASSEMBLER ] MEM ; - 4 - 5 : ;CODE [COMPILE] DOES> -3 >allot - 6 [COMPILE] ; -2 >allot ASSEMBLER ; IMMEDIATE - 7 - 8 : CODE CREATE >here DUP 2- >! ASSEMBLER ; - 9 -10 : >LABEL ( ADR -) -11 >here | CREATE SWAP , 4 HALLOT -12 HEAP 1 AND HALLOT ( 6502-ALIGN) HERE 4 - HEAP 4 CMOVE -13 HEAP LAST @ COUNT 01F AND + ! DP ! DOES> ( - ADR) @ ; -14 -15 : LABEL [ ASSEMBLER ] >here >LABEL ASSEMBLER ; -Screen 10 not modified - 0 \ Code generating primitives er14dez88 - 1 - 2 Variable >codes - 3 | Create nrc ] c, , c@ here allot ! c! [ - 4 - 5 : nonrelocate nrc >codes ! ; nonrelocate - 6 - 7 | : >exec Create c, - 8 Does> c@ >codes @ + @ execute ; - 9 -10 | 0 >exec >c, | 2 >exec >, | 4 >exec >c@ -11 | 6 >exec >here | 8 >exec >allot | $0A >exec >! -12 | $0C >exec >c! -13 -14 -15 -Screen 11 not modified - 0 \ FORTH-65 ASSEMBLER WFR ) er14dez88 - 1 ( BASIS: FORTH DIMENSIONS VOL III NO. 5) - 2 ONLYFORTH - 3 - 4 ASSEMBLER ALSO DEFINITIONS - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/Apple1/as65.fth b/sources/Apple1/as65.fth new file mode 100644 index 0000000..1db870a --- /dev/null +++ b/sources/Apple1/as65.fth @@ -0,0 +1,204 @@ +\ *** Block No. 0 Hexblock 0 +\ FORTH-6502 ASSEMBLER WFR ) cas 26jan06 +( BASIS: FORTH DIMENSIONS VOL III NO. 5) + +Load from Screen 1 for the transient assembler: +This 6502 Forth Assembler can be loaded into the heap +and then not be saved in the final binary to save memory. + +Load from Screen 2 for the regular assembler: +This 6502 Forth Assembler will be loaded into normal +memory and will be saved into the final binary. + + + + + + +\ *** Block No. 1 Hexblock 1 +\ TRANSIENT FORTH-6502 ASSEMBLER WFR ) er14dez88 +( BASIS: FORTH DIMENSIONS VOL III NO. 5) + +( INTERNAL LOADING 04MAY85BP/RE) +hex +\ HERE $200 HALLOT HEAP DP ! + &10 LOAD + &11 LOAD + 3 &8 THRU + &9 LOAD \ for System-Assembler + +\ DP ! + +ONLYFORTH +decimal + +\ *** Block No. 2 Hexblock 2 +\ FORTH-65 ASSEMBLER WFR ) er14dez88 +( BASIS: FORTH DIMENSIONS VOL III NO. 5) +ONLYFORTH +Vocabulary tassembler +TASSEMBLER ALSO DEFINITIONS +hex + + 8 +load \ relocate +1 6 +THRU +\ 7 +load \ System Assembler +decimal + + + + + +\ *** Block No. 3 Hexblock 3 +\ FORTH-83 6502-ASSEMBLER ) er14dez88 +: END-CODE CONTEXT 2- @ CONTEXT ! ; +CREATE INDEX +09 c, 09 c, 05 c, 15 c, 15 c, 01 c, 11 c, 80 c, +09 c, 80 c, 0D c, 1D c, 19 c, 80 c, 80 c, 80 c, +80 c, 00 c, 04 c, 14 c, 14 c, 80 c, 80 c, 80 c, +80 c, 80 c, 0C c, 1C c, 1C c, 80 c, 80 c, 2C c, + +| 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 0F MODE: ) +6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: ) +6 MODE: )Y 0F MODE: ) 6 MODE: )Y 0F MODE: ) +\ *** Block No. 4 Hexblock 4 +\ UPMODE CPU ) er14dez88 +| : UPMODE ( ADDR0 F0 - ADDR1 F1) + IF MODE @ 8 OR MODE ! THEN 1 MODE @ 0F 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 +\ *** Block No. 5 Hexblock 5 +\ M/CPU ) er14dez88 + +: 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 @ 0F 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 +\ *** Block No. 6 Hexblock 6 +\ ASSEMBLER CONDITIONALS ) er14dez88 + +| : RANGE? ( BRANCH -- BRANCH ) + DUP ABS 07F 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 ]? ; + +\ *** Block No. 7 Hexblock 7 +\ ASSEMBLER CONDITIONALS ) er14dez88 + +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 ?] ; + + + +\ *** Block No. 8 Hexblock 8 +\ 2INC/2DEC WINC/WDEC KS 19 MAY 84 ) er14dez88 + +: 2INC + DUP LDA CLC 2 # ADC DUP STA CS ?[ SWAP 1+ INC ]? ; + +: 2DEC + DUP LDA SEC 2 # SBC DUP STA CC ?[ SWAP 1+ DEC ]? ; + +: WINC DUP INC 0= ?[ SWAP 1+ INC ]? ; + +: WDEC DUP LDA 0= ?[ OVER 1+ DEC ]? DEC ; + +: ;C: RECOVER JSR END-CODE ] 0 LAST ! 0 ; + + + +\ *** Block No. 9 Hexblock 9 +\ ;CODE CODE CODE> BP 03 02 85) er14dez88 +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 SWAP , 4 HALLOT + HEAP 1 AND HALLOT ( 6502-ALIGN) HERE 4 - HEAP 4 CMOVE + HEAP LAST @ COUNT 01F AND + ! DP ! DOES> ( - ADR) @ ; + +: LABEL [ ASSEMBLER ] >here >LABEL ASSEMBLER ; +\ *** Block No. 10 Hexblock A +\ Code generating primitives er14dez88 + +Variable >codes +| Create nrc ] c, , c@ here allot ! c! [ + +: nonrelocate nrc >codes ! ; nonrelocate + +| : >exec Create c, + Does> c@ >codes @ + @ execute ; + +| 0 >exec >c, | 2 >exec >, | 4 >exec >c@ +| 6 >exec >here | 8 >exec >allot | $0A >exec >! +| $0C >exec >c! + + + +\ *** Block No. 11 Hexblock B +\ FORTH-65 ASSEMBLER WFR ) er14dez88 +( BASIS: FORTH DIMENSIONS VOL III NO. 5) +ONLYFORTH + +ASSEMBLER ALSO DEFINITIONS + + + + + + + + + + + diff --git a/sources/Apple1/assemble.fb.src b/sources/Apple1/assemble.fb.src deleted file mode 100644 index cbb4b67..0000000 --- a/sources/Apple1/assemble.fb.src +++ /dev/null @@ -1,323 +0,0 @@ -Screen 0 not modified - 0 \\ *** Assembler *** 25may86we - 1 - 2 Dieses File enth„lt den 68000-Assembler fr volksFORTH-83. - 3 Der Assembler basiert auf dem von Michael Perry fr F83 entwik- - 4 kelten, enth„lt aber einige zus„tzliche Features. - 5 Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels - 6 verwendbar. Aus Geschwindigkeitsgrnden enth„lt der Assembler - 7 kaum Fehlerberprfung, es empfiehlt sich daher, nach getaner - 8 Tat die Code-Worte mit einem Disassembler zu berprfen. - 9 -10 Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten -11 Assembler auf den Heap laden kann, damit er w„hrend der Kompila- -12 tionszeit zur Verfgung steht, aber keinen Platz im Dictionary -13 verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt, -14 wenn er nicht mehr ben”tigt wird. -15 -Screen 1 not modified - 0 \ 68000 Assembler Load Screen 26oct86we - 1 - 2 Onlyforth - 3 Vocabulary Assembler Assembler also definitions - 4 - 5 : end-code context 2- @ context ! ; - 6 ' swap | Alias *swap - 7 - 8 base @ 4 $11 +thru base ! - 9 -10 : reg) size push .l 0 *swap FP DI) ; -11 : Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp -12 >here next-link @ , next-link ! ; -13 -14 2 3 +thru Onlyforth -15 -Screen 2 not modified - 0 \ Internal Assembler 09sep86we - 1 - 2 Onlyforth - 3 - 4 here - 5 $1300 hallot heap dp ! -1 +load - 6 dp ! - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ Extended adressing modes 09sep86we - 1 - 2 : R#) ( addr -- ) size push - 3 [ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg) - 4 [ Forth ] exit THEN .w FP D) ; - 5 - 6 - 7 | : inrange? ( addr -- offset f ) [ Forth ] - 8 >here 2+ - >here 0< IF dup $FFFE >here - < exit THEN - 9 dup >here negate > ; -10 : pcrel) ( addr -- ) \ pc-relativ adressing mode -11 inrange? [ Forth ] 0= abort" out of range" pcd) ; -12 -13 : ;c: 0 recover R#) jsr end-code ] ; -14 -15 -Screen 4 not modified - 0 \ Assembler Forth words 09sep86we - 1 Forth definitions - 2 : Assembler Assembler [ Assembler ] .w ; - 3 : Code Create here dup 2- ! Assembler ; - 4 - 5 | : (;code r> last @ name> ! ; - 6 : ;Code 0 ?pairs compile (;code [compile] [ reveal - 7 Assembler ; immediate restrict - 8 - 9 : >label ( addr -- ) here | Create swap , immediate -10 4 hallot >here 4- heap 4 cmove -11 heap last @ count $1F and + even ! dp ! -12 Does> ( -- addr ) @ -13 state @ IF [compile] Literal THEN ; -14 : Label [ Assembler ] >here [ Forth ] 1 and -15 [ Assembler ] >allot >here >label Assembler ; -Screen 5 not modified - 0 \ Code generating primitives 26oct86we - 1 - 2 Variable >codes - 3 | Create nrc ] c, , c@ here allot ! c! [ - 4 - 5 : nonrelocate nrc >codes ! ; nonrelocate - 6 - 7 | : >exec Create c, - 8 Does> c@ >codes @ + @ execute ; - 9 -10 | 0 >exec >c, | 2 >exec >, | 4 >exec >c@ -11 | 6 >exec >here | 8 >exec >allot | $0A >exec >! -12 | $0C >exec >c! -13 -14 -15 -Screen 6 not modified - 0 \ 68000 Meta Assembler 04sep86we - 1 - 2 | : ?, IF >, THEN >, ; - 3 | : 2, >, >, ; - 4 8 base ! - 5 Variable size - 6 : .b 10000 size ! ; - 7 : .w 30100 size ! ; .w - 8 : .l 24600 size ! ; - 9 -10 | : Sz Constant Does> @ size @ and or ; -11 00300 | Sz sz3 00400 | Sz sz4 -12 04000 | Sz sz40 30000 | Sz sz300 -13 -14 | : long? size @ 24600 = ; -15 | : -sz1 long? IF 100 or THEN ; -Screen 7 not modified - 0 \ addressing modes 09sep86we - 1 - 2 | : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ; - 3 | : Mode Constant Does> @ *swap 7007 and or ; - 4 0000 Regs D0 D1 D2 D3 D4 D5 D6 D7 - 5 0110 Regs A0 A1 A2 A3 A4 A5 A6 A7 - 6 0220 Mode ) \ address register indirect - 7 0330 Mode )+ \ adr reg ind post-increment - 8 0440 Mode -) \ adr reg ind pre-decrement - 9 0550 Mode D) \ adr reg ind displaced -10 0660 Mode (DI) \ adr reg ind displaced indexed s.u. -11 0770 Constant #) \ immediate address -12 1771 Constant L#) \ immediate long address -13 2772 Constant pcD) \ pc relative displaced -14 3773 Constant (pcDI) \ pc relative displaced indexed -15 4774 Constant # \ immediate data -Screen 8 not modified - 0 \ fields and register assignments 08sep86we - 1 - 2 | : Field Constant Does> @ and ; - 3 7000 | Field rd 0007 | Field rs - 4 0070 | Field ms 0077 | Field eas - 5 0377 | Field low - 6 | : dn? ( ea -- ea flag ) dup ms 0= ; - 7 | : src ( ea instr -- ea instr' ) over eas or ; - 8 | : dst ( ea instr -- ea instr' ) *swap rd or ; - 9 -10 | : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ; -11 | : ??an ( mod -- mod ) dup ms 1 = -12 abort" needs Adress-Register" ; -13 -14 A6 Constant SP A5 Constant RP A4 Constant IP -15 A3 Constant FP -Screen 9 not modified - 0 \ extended addressing 09sep86we - 1 : DI) (DI) size @ *swap ; - 2 : pcDI) (pcDI) size @ *swap ; - 3 - 4 | : double? ( mode -- flag) dup L#) = *swap - 5 # = long? and or ; - 6 | : index? ( {n} mode -- {m} mode ) - 7 dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or - 8 IF size @ >r size ! - 9 dup rd 10 * *swap ms IF 100000 or THEN -10 sz40 *swap low or r> size ! -11 THEN r> ; -12 -13 | : more? ( ea -- ea flag ) dup ms 0040 > ; -14 | : ,more ( ea -- ) more? -15 IF index? double? ?, ELSE drop THEN ; -Screen 10 not modified - 0 \ extended addressing extras 09sep86we - 1 - 2 | Create extra here 5 dup allot erase \ temporary storage area - 3 - 4 | : extra? ( {n} mode -- mode ) more? - 5 IF >r r@ index? double? extra 1+ *swap - 6 IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r> - 7 ELSE 0 extra ! - 8 THEN ; - 9 -10 | : ,extra ( -- ) extra c@ ?dup -11 IF extra 1+ *swap 1 = -12 IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase -13 THEN ; -14 -15 -Screen 11 not modified - 0 \ immediates & address register specific 15jan86we - 1 | : Imm Constant Does> @ >r extra? eas r> or - 2 sz3 >, long? ?, ,extra ; ( n ea) - 3 0000 Imm ori 1000 Imm andi - 4 2000 Imm subi 3000 Imm addi - 5 5000 Imm eori 6000 Imm cmpi - 6 | : Immsr Constant Does> @ sz3 2, ; ( n ) - 7 001074 Immsr andi>sr - 8 005074 Immsr eori>sr - 9 000074 Immsr ori>sr -10 | : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or -11 r> or sz3 >, ,extra ; ( n ea ) -12 050000 Iq addq 050400 Iq subq -13 | : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an ) -14 150300 Ieaa adda 130300 Ieaa cmpa -15 040700 Ieaa lea 110300 Ieaa suba -Screen 12 not modified - 0 \ shifts, rotates, and bit manipulation 15jan86we - 1 | : Isr Constant Does> @ >r dn? - 2 IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN - 3 rd *swap rs or r> or 160000 or sz3 >, - 4 ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or - 5 160000 or >, ,more - 6 THEN ; ( dm dn ) ( m # dn ) ( ea ) - 7 400 Isr asl 000 Isr asr - 8 410 Isr lsl 010 Isr lsr - 9 420 Isr roxl 020 Isr roxr -10 430 Isr rol 030 Isr ror -11 | : Ibit Constant does> @ >r extra? dn? -12 IF rd src 400 ELSE drop dup eas 4000 THEN -13 or r> or >, ,extra ,more ; ( ea dn ) ( ea n # ) -14 000 Ibit btst 100 Ibit bchg -15 200 Ibit bclr 300 Ibit bset -Screen 13 not modified - 0 \ branch, loop, and set conditionals 15jan86we - 1 - 2 | : Setclass ' *swap 0 DO I over execute LOOP drop ; - 3 | : Ibra 400 * 060000 or Constant ( label ) - 4 Does> @ *swap >here 2+ - dup abs 200 < - 5 IF low or >, ELSE *swap 2, THEN ; - 6 20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq - 7 bvc bvs bpl bmi bge blt bgt ble - 8 | : Idbr 400 * 050310 or Constant ( label \ dn - ) - 9 Does> @ *swap rs or >, >here - >, ; -10 20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq -11 dbvc dbvs dbpl dbmi dbge dblt dbgt dble -12 | : Iset 400 * 050300 or Constant ( ea ) -13 Does> @ src >, ,more ; -14 20 Setclass Iset set sno shi sls scc scs sne seq -15 svc svs spl smi sge slt sgt sle -Screen 14 not modified - 0 \ moves 15jan86we - 1 - 2 : move extra? 7700 and src sz300 >, - 3 ,more ,extra ; ( ea ea ) - 4 : moveq ??dn rd *swap low or 070000 or >, ; ( n dn ) - 5 : move>usp ??an rs 047140 or >, ; ( an ) - 6 : move, ; ( an ) - 7 : movem> - 8 extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea ) - 9 : movem< -10 extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea ) -11 : movep dn? IF rd *swap rs or 410 or -12 ELSE rs rot rd or 610 or THEN -sz1 2, ; -13 ( dm d an ) ( d an dm ) -14 : lmove 7700 and *swap eas or 20000 or >, ; -15 ( long reg move ) -Screen 15 not modified - 0 \ odds and ends 15jan86we - 1 - 2 : cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ ) - 3 : exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r - 4 ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap - 5 THEN rs dst r> or >, ; ( rn rm ) - 6 : ext ??dn rs 044200 or -sz1 >, ; ( dn ) - 7 : swap ??dn rs 044100 or >, ; ( dn ) - 8 : stop 47162 2, ; ( n ) - 9 : trap 17 and 47100 or >, ; ( n ) -10 : link ??an rs 047120 or 2, ; ( n an ) -11 : unlk ??an rs 047130 or >, ; ( an ) -12 : eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea ) -13 : cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn ) -14 -15 -Screen 16 not modified - 0 \ arithmetic and logic 15jan86we - 1 | : Ibcd Constant Does> @ dst over rs or *swap ms - 2 IF 10 or THEN >, ; ( dn dm ) ( an@- am@- ) - 3 140400 Ibcd abcd 100400 Ibcd sbcd - 4 | : Idd Constant Does> @ dst over rs or *swap ms - 5 IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- ) - 6 150400 Idd addx 110400 Idd subx - 7 | : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea ) - 8 IF rd src r> or sz3 >, ,more - 9 ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ; -10 150000 Idea add 110000 Idea sub -11 140000 Idea and 100000 Idea or -12 | : Iead Constant Does> @ >r ??dn r> dst src -13 >, ,more ; ( ea dn) -14 040600 Iead chk 100300 Iead divu 100700 Iead divs -15 140300 Iead mulu 140700 Iead muls -Screen 17 not modified - 0 \ arithmetic and control 15jan86we - 1 - 2 | : Iea Constant Does> @ src >, ,more ; ( ea ) - 3 047200 Iea jsr 047300 Iea jmp - 4 042300 Iea move>ccr - 5 040300 Iea movesr - 6 044000 Iea nbcd 044100 Iea pea - 7 045300 Iea tas - 8 | : Ieas Constant Does> @ src sz3 >, ,more ; ( ea ) - 9 041000 Ieas clr 043000 Ieas not -10 042000 Ieas neg 040000 Ieas negx -11 045000 Ieas tst -12 | : Icon Constant Does> @ >, ; -13 47160 Icon reset 47161 Icon nop -14 47163 Icon rte 47165 Icon rts -15 47166 Icon trapv 47167 Icon rtr -Screen 18 not modified - 0 \ structured conditionals +/- 256 bytes 15jan86we - 1 : THEN >here over 2+ - *swap 1+ >c! ; - 2 : IF >, >here 2- ; hex - 3 : ELSE 6000 IF *swap THEN ; - 4 : BEGIN >here ; - 5 : UNTIL >, >here - >here 1- >c! ; - 6 : AGAIN 6000 UNTIL ; - 7 : WHILE IF *swap ; - 8 : REPEAT AGAIN THEN ; - 9 : DO >here *swap ; -10 : LOOP dbra ; -11 6600 Constant 0= 6700 Constant 0<> -12 6A00 Constant 0< 6B00 Constant 0>= -13 6C00 Constant < 6D00 Constant >= -14 6E00 Constant <= 6F00 Constant > -15 6500 Constant CC 6400 Constant CS diff --git a/sources/Apple1/assemble.fth b/sources/Apple1/assemble.fth new file mode 100644 index 0000000..d52fb7e --- /dev/null +++ b/sources/Apple1/assemble.fth @@ -0,0 +1,323 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Assembler *** 25may86we + +Dieses File enth„lt den 68000-Assembler fr volksFORTH-83. +Der Assembler basiert auf dem von Michael Perry fr F83 entwik- +kelten, enth„lt aber einige zus„tzliche Features. +Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels +verwendbar. Aus Geschwindigkeitsgrnden enth„lt der Assembler +kaum Fehlerberprfung, es empfiehlt sich daher, nach getaner +Tat die Code-Worte mit einem Disassembler zu berprfen. + +Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten +Assembler auf den Heap laden kann, damit er w„hrend der Kompila- +tionszeit zur Verfgung steht, aber keinen Platz im Dictionary +verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt, +wenn er nicht mehr ben”tigt wird. + +\ *** Block No. 1 Hexblock 1 +\ 68000 Assembler Load Screen 26oct86we + +Onlyforth +Vocabulary Assembler Assembler also definitions + +: end-code context 2- @ context ! ; +' swap | Alias *swap + +base @ 4 $11 +thru base ! + +: reg) size push .l 0 *swap FP DI) ; +: Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp + >here next-link @ , next-link ! ; + +2 3 +thru Onlyforth + +\ *** Block No. 2 Hexblock 2 +\ Internal Assembler 09sep86we + +Onlyforth + +here + $1300 hallot heap dp ! -1 +load +dp ! + + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ Extended adressing modes 09sep86we + +: R#) ( addr -- ) size push + [ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg) + [ Forth ] exit THEN .w FP D) ; + + +| : inrange? ( addr -- offset f ) [ Forth ] + >here 2+ - >here 0< IF dup $FFFE >here - < exit THEN + dup >here negate > ; +: pcrel) ( addr -- ) \ pc-relativ adressing mode + inrange? [ Forth ] 0= abort" out of range" pcd) ; + +: ;c: 0 recover R#) jsr end-code ] ; + + +\ *** Block No. 4 Hexblock 4 +\ Assembler Forth words 09sep86we +Forth definitions +: Assembler Assembler [ Assembler ] .w ; +: Code Create here dup 2- ! Assembler ; + +| : (;code r> last @ name> ! ; +: ;Code 0 ?pairs compile (;code [compile] [ reveal + Assembler ; immediate restrict + +: >label ( addr -- ) here | Create swap , immediate + 4 hallot >here 4- heap 4 cmove + heap last @ count $1F and + even ! dp ! + Does> ( -- addr ) @ + state @ IF [compile] Literal THEN ; +: Label [ Assembler ] >here [ Forth ] 1 and + [ Assembler ] >allot >here >label Assembler ; +\ *** Block No. 5 Hexblock 5 +\ Code generating primitives 26oct86we + +Variable >codes +| Create nrc ] c, , c@ here allot ! c! [ + +: nonrelocate nrc >codes ! ; nonrelocate + +| : >exec Create c, + Does> c@ >codes @ + @ execute ; + +| 0 >exec >c, | 2 >exec >, | 4 >exec >c@ +| 6 >exec >here | 8 >exec >allot | $0A >exec >! +| $0C >exec >c! + + + +\ *** Block No. 6 Hexblock 6 +\ 68000 Meta Assembler 04sep86we + +| : ?, IF >, THEN >, ; +| : 2, >, >, ; +8 base ! +Variable size +: .b 10000 size ! ; +: .w 30100 size ! ; .w +: .l 24600 size ! ; + +| : Sz Constant Does> @ size @ and or ; +00300 | Sz sz3 00400 | Sz sz4 +04000 | Sz sz40 30000 | Sz sz300 + +| : long? size @ 24600 = ; +| : -sz1 long? IF 100 or THEN ; +\ *** Block No. 7 Hexblock 7 +\ addressing modes 09sep86we + +| : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ; +| : Mode Constant Does> @ *swap 7007 and or ; +0000 Regs D0 D1 D2 D3 D4 D5 D6 D7 +0110 Regs A0 A1 A2 A3 A4 A5 A6 A7 +0220 Mode ) \ address register indirect +0330 Mode )+ \ adr reg ind post-increment +0440 Mode -) \ adr reg ind pre-decrement +0550 Mode D) \ adr reg ind displaced +0660 Mode (DI) \ adr reg ind displaced indexed s.u. +0770 Constant #) \ immediate address +1771 Constant L#) \ immediate long address +2772 Constant pcD) \ pc relative displaced +3773 Constant (pcDI) \ pc relative displaced indexed +4774 Constant # \ immediate data +\ *** Block No. 8 Hexblock 8 +\ fields and register assignments 08sep86we + +| : Field Constant Does> @ and ; +7000 | Field rd 0007 | Field rs +0070 | Field ms 0077 | Field eas +0377 | Field low +| : dn? ( ea -- ea flag ) dup ms 0= ; +| : src ( ea instr -- ea instr' ) over eas or ; +| : dst ( ea instr -- ea instr' ) *swap rd or ; + +| : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ; +| : ??an ( mod -- mod ) dup ms 1 = + abort" needs Adress-Register" ; + +A6 Constant SP A5 Constant RP A4 Constant IP +A3 Constant FP +\ *** Block No. 9 Hexblock 9 +\ extended addressing 09sep86we +: DI) (DI) size @ *swap ; +: pcDI) (pcDI) size @ *swap ; + +| : double? ( mode -- flag) dup L#) = *swap + # = long? and or ; +| : index? ( {n} mode -- {m} mode ) + dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or + IF size @ >r size ! + dup rd 10 * *swap ms IF 100000 or THEN + sz40 *swap low or r> size ! + THEN r> ; + +| : more? ( ea -- ea flag ) dup ms 0040 > ; +| : ,more ( ea -- ) more? + IF index? double? ?, ELSE drop THEN ; +\ *** Block No. 10 Hexblock A +\ extended addressing extras 09sep86we + +| Create extra here 5 dup allot erase \ temporary storage area + +| : extra? ( {n} mode -- mode ) more? + IF >r r@ index? double? extra 1+ *swap + IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r> + ELSE 0 extra ! + THEN ; + +| : ,extra ( -- ) extra c@ ?dup + IF extra 1+ *swap 1 = + IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase + THEN ; + + +\ *** Block No. 11 Hexblock B +\ immediates & address register specific 15jan86we +| : Imm Constant Does> @ >r extra? eas r> or + sz3 >, long? ?, ,extra ; ( n ea) +0000 Imm ori 1000 Imm andi +2000 Imm subi 3000 Imm addi +5000 Imm eori 6000 Imm cmpi +| : Immsr Constant Does> @ sz3 2, ; ( n ) +001074 Immsr andi>sr +005074 Immsr eori>sr +000074 Immsr ori>sr +| : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or + r> or sz3 >, ,extra ; ( n ea ) +050000 Iq addq 050400 Iq subq +| : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an ) +150300 Ieaa adda 130300 Ieaa cmpa +040700 Ieaa lea 110300 Ieaa suba +\ *** Block No. 12 Hexblock C +\ shifts, rotates, and bit manipulation 15jan86we +| : Isr Constant Does> @ >r dn? + IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN + rd *swap rs or r> or 160000 or sz3 >, + ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or + 160000 or >, ,more + THEN ; ( dm dn ) ( m # dn ) ( ea ) +400 Isr asl 000 Isr asr +410 Isr lsl 010 Isr lsr +420 Isr roxl 020 Isr roxr +430 Isr rol 030 Isr ror +| : Ibit Constant does> @ >r extra? dn? + IF rd src 400 ELSE drop dup eas 4000 THEN + or r> or >, ,extra ,more ; ( ea dn ) ( ea n # ) +000 Ibit btst 100 Ibit bchg +200 Ibit bclr 300 Ibit bset +\ *** Block No. 13 Hexblock D +\ branch, loop, and set conditionals 15jan86we + +| : Setclass ' *swap 0 DO I over execute LOOP drop ; +| : Ibra 400 * 060000 or Constant ( label ) + Does> @ *swap >here 2+ - dup abs 200 < + IF low or >, ELSE *swap 2, THEN ; +20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq + bvc bvs bpl bmi bge blt bgt ble +| : Idbr 400 * 050310 or Constant ( label \ dn - ) + Does> @ *swap rs or >, >here - >, ; +20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq + dbvc dbvs dbpl dbmi dbge dblt dbgt dble +| : Iset 400 * 050300 or Constant ( ea ) + Does> @ src >, ,more ; +20 Setclass Iset set sno shi sls scc scs sne seq + svc svs spl smi sge slt sgt sle +\ *** Block No. 14 Hexblock E +\ moves 15jan86we + +: move extra? 7700 and src sz300 >, + ,more ,extra ; ( ea ea ) +: moveq ??dn rd *swap low or 070000 or >, ; ( n dn ) +: move>usp ??an rs 047140 or >, ; ( an ) +: move, ; ( an ) +: movem> + extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea ) +: movem< + extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea ) +: movep dn? IF rd *swap rs or 410 or + ELSE rs rot rd or 610 or THEN -sz1 2, ; + ( dm d an ) ( d an dm ) +: lmove 7700 and *swap eas or 20000 or >, ; + ( long reg move ) +\ *** Block No. 15 Hexblock F +\ odds and ends 15jan86we + +: cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ ) +: exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r + ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap + THEN rs dst r> or >, ; ( rn rm ) +: ext ??dn rs 044200 or -sz1 >, ; ( dn ) +: swap ??dn rs 044100 or >, ; ( dn ) +: stop 47162 2, ; ( n ) +: trap 17 and 47100 or >, ; ( n ) +: link ??an rs 047120 or 2, ; ( n an ) +: unlk ??an rs 047130 or >, ; ( an ) +: eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea ) +: cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn ) + + +\ *** Block No. 16 Hexblock 10 +\ arithmetic and logic 15jan86we +| : Ibcd Constant Does> @ dst over rs or *swap ms + IF 10 or THEN >, ; ( dn dm ) ( an@- am@- ) +140400 Ibcd abcd 100400 Ibcd sbcd +| : Idd Constant Does> @ dst over rs or *swap ms + IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- ) +150400 Idd addx 110400 Idd subx +| : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea ) + IF rd src r> or sz3 >, ,more + ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ; +150000 Idea add 110000 Idea sub +140000 Idea and 100000 Idea or +| : Iead Constant Does> @ >r ??dn r> dst src + >, ,more ; ( ea dn) +040600 Iead chk 100300 Iead divu 100700 Iead divs +140300 Iead mulu 140700 Iead muls +\ *** Block No. 17 Hexblock 11 +\ arithmetic and control 15jan86we + +| : Iea Constant Does> @ src >, ,more ; ( ea ) +047200 Iea jsr 047300 Iea jmp +042300 Iea move>ccr +040300 Iea movesr +044000 Iea nbcd 044100 Iea pea +045300 Iea tas +| : Ieas Constant Does> @ src sz3 >, ,more ; ( ea ) +041000 Ieas clr 043000 Ieas not +042000 Ieas neg 040000 Ieas negx +045000 Ieas tst +| : Icon Constant Does> @ >, ; +47160 Icon reset 47161 Icon nop +47163 Icon rte 47165 Icon rts +47166 Icon trapv 47167 Icon rtr +\ *** Block No. 18 Hexblock 12 +\ structured conditionals +/- 256 bytes 15jan86we +: THEN >here over 2+ - *swap 1+ >c! ; +: IF >, >here 2- ; hex +: ELSE 6000 IF *swap THEN ; +: BEGIN >here ; +: UNTIL >, >here - >here 1- >c! ; +: AGAIN 6000 UNTIL ; +: WHILE IF *swap ; +: REPEAT AGAIN THEN ; +: DO >here *swap ; +: LOOP dbra ; +6600 Constant 0= 6700 Constant 0<> +6A00 Constant 0< 6B00 Constant 0>= +6C00 Constant < 6D00 Constant >= +6E00 Constant <= 6F00 Constant > +6500 Constant CC 6400 Constant CS diff --git a/sources/Apple1/ccompile.fb.src b/sources/Apple1/ccompile.fb.src deleted file mode 100644 index 558088a..0000000 --- a/sources/Apple1/ccompile.fb.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \ Crosscompile Script for 6502 Target cas 26jan06 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ loadscreen for cross-compiler cas 26jan06 - 1 - 2 include assemble.fb \ load 68000 assembler - 3 2 loadfrom as65.fb page \ load 6502 assembler - 4 include crostarg.fb page \ load target compiler - 5 include 6502f83.fb \ load Forth Kernel Source - 6 - 7 save-target f6502.com \ save new forth as f6502.com - 8 key drop page .( Ready ) cr \ wait for keypress - 9 bye \ and exit forth -10 -11 -12 -13 -14 -15 diff --git a/sources/Apple1/ccompile.fth b/sources/Apple1/ccompile.fth new file mode 100644 index 0000000..74f658e --- /dev/null +++ b/sources/Apple1/ccompile.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\ Crosscompile Script for 6502 Target cas 26jan06 + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ loadscreen for cross-compiler cas 26jan06 + +include assemble.fb \ load 68000 assembler +2 loadfrom as65.fb page \ load 6502 assembler +include crostarg.fb page \ load target compiler +include 6502f83.fb \ load Forth Kernel Source + +save-target f6502.com \ save new forth as f6502.com +key drop page .( Ready ) cr \ wait for keypress +bye \ and exit forth + + + + + + diff --git a/sources/Apple1/crostarg.fb.src b/sources/Apple1/crostarg.fb.src deleted file mode 100644 index 4f47fc0..0000000 --- a/sources/Apple1/crostarg.fb.src +++ /dev/null @@ -1,680 +0,0 @@ -Screen 0 not modified - 0 \\ *** volksFORTH-84 Target-Compiler *** cas 26jan06 - 1 - 2 This Target Compiler can be used to create a new Forth System - 3 using the Sourcecode 6502F82.FB. - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Target compiler loadscr 09sep86we - 1 \ Idea and first Implementation by ks/bp - 2 \ Implemented on 6502 by ks/bp - 3 \ ultraFORTH83-Version by bp/we - 4 \ Atari 520 ST - Version by we - 5 Onlyforth Assembler nonrelocate - 6 07 Constant imagepage \ Virtual memory bank - 7 Vocabulary Ttools - 8 Vocabulary Defining - 9 : .stat .blk .s ; ' .stat Is .status -10 \ : 65( [compile] ( ; immediate -11 : 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte| -12 1 $14 +thru \ Target compiler -13 $15 $17 +thru \ Target Tools -14 $18 $1A +thru \ Redefinitions -15 save $1B $24 +thru \ Predefinitions -Screen 2 not modified - 0 \ Target header pointers bp05mar86we - 1 - 2 Variable tdp : there tdp @ ; - 3 Variable displace - 4 Variable ?thead 0 ?thead ! - 5 Variable tlast 0 tlast ! - 6 Variable glast' 0 glast' ! - 7 Variable tdoes> - 8 Variable >in: - 9 Variable tvoc 0 tvoc ! -10 Variable tvoc-link 0 tvoc-link ! -11 Variable tnext-link 0 tnext-link ! -12 -13 : c+! ( 8b addr -- ) dup c@ rot + swap c! ; -14 -15 -Screen 3 not modified - 0 \ Image and byteorder 15sep86we - 1 - 2 : >image ( addr1 - addr2 ) displace @ - ; - 3 - 4 : >heap ( from quan - ) - 5 heap over - 1 and + \ 68000-align - 6 dup hallot heap swap cmove ; - 7 \\ - 8 : >ascii 2drop ; ' noop Alias C64>ascii - 9 -10 Code Lc@ ( laddr -- 8b ) -11 .l SP )+ A0 move .w D0 clr .b A0 ) D0 move -12 .w D0 SP -) move Next end-code -13 Code Lc! ( 8b addr -- ) -14 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move -15 Next end-code -Screen 4 not modified - 0 \ Ghost-creating 05mar86we - 1 - 2 0 | Constant 0 | Constant - 3 - 4 | : Make.ghost ( - cfa.ghost ) - 5 here dup 1 and allot here - 6 state @ IF context @ ELSE current THEN @ - 7 dup @ , name - 8 dup c@ 1 $1F uwithin not abort" inval.Gname" - 9 dup c@ 1+ over c! -10 c@ dup 1+ allot 1 and 0= IF bl c, THEN -11 here 2 pick - -rot -12 , 0 , 0 , -13 swap here over - >heap -14 heap swap ! swap dp ! -15 heap + ; -Screen 5 not modified - 0 \ ghost words 05mar86we - 1 - 2 : gfind ( string - cfa tf / string ff ) - 3 dup count + 1+ bl swap c! - 4 dup >r 1 over c+! find -1 r> c+! ; - 5 - 6 : ghost ( - cfa ) - 7 >in @ name gfind IF nip exit THEN - 8 drop >in ! Make.ghost ; - 9 -10 : Word, ghost execute ; -11 -12 : gdoes> ( cfa.ghost - cfa.does ) -13 4+ dup @ IF @ exit THEN -14 here dup , 0 , 4 >heap -15 dp ! heap dup rot ! ; -Screen 6 not modified - 0 \ ghost utilities 04dec85we - 1 - 2 : g' name gfind 0= abort" ?" ; - 3 - 4 : '. - 5 g' dup @ case? - 6 IF ." forw" ELSE - abort" ??" ." res" THEN - 7 2+ dup @ 5 u.r - 8 2+ @ ?dup - 9 IF dup @ case? -10 IF ." fdef" ELSE - abort" ??" ." rdef" THEN -11 2+ @ 5 u.r THEN ; -12 -13 ' ' Alias h' -14 -15 -Screen 7 not modified - 0 \ .unresolved 05mar86we - 1 - 2 | : forward? ( cfa - cfa / exit&true ) - 3 dup @ = over 2+ @ and IF drop true rdrop exit THEN ; - 4 - 5 | : unresolved? ( addr - f ) - 6 2+ dup c@ $1F and over + c@ BL = - 7 IF name> forward? 4+ @ dup IF forward? THEN - 8 THEN drop false ; - 9 -10 | : unresolved-words -11 BEGIN @ ?dup WHILE dup unresolved? -12 IF dup 2+ .name ?cr THEN REPEAT ; -13 -14 : .unresolved voc-link @ -15 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; -Screen 8 not modified - 0 \ Extending Vocabularys for Target-Compilation 05mar86we - 1 - 2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; - 3 - 4 Vocabulary Transient 0 tvoc ! - 5 - 6 Only definitions Forth also - 7 - 8 : T Transient ; immediate - 9 : H Forth ; immediate -10 -11 definitions -12 -13 -14 -15 -Screen 9 not modified - 0 \ Transient primitives 05mar86we - 1 - 2 Code byte> ( 8bh 8bl -- 16b ) - 3 SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move - 4 .w D0 SP ) move Next end-code - 5 Code >byte ( 16b -- 8bl 8bh ) - 6 SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr - 7 D0 SP -) move D1 SP -) move Next end-code - 8 - 9 Transient definitions -10 : c@ H >image imagepage lc@ ; -11 : c! H >image imagepage lc! ; -12 : @ dup T c@ swap 1+ T c@ 65( swap ) byte> ; -13 : ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ; -14 : cmove ( from.mem to.target quan -) -15 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; -Screen 10 not modified - 0 \ Transient primitives bp05mar86we - 1 - 2 : here there ; - 3 : allot Tdp +! ; - 4 : c, T here c! 1 allot H ; - 5 : , T here ! 2 allot H ; - 6 - 7 : ," Ascii " parse dup T c, - 8 under there swap cmove - 9 .( dup 1 and 0= IF 1+ THEN ) allot H ; -10 -11 : fill ( addr quan 8b -) -12 -rot bounds ?DO dup I T c! H LOOP drop ; -13 : erase 0 T fill ; -14 : blank bl T fill ; -15 : here! H Tdp ! ; -Screen 11 not modified - 0 \ Resolving 08dec85we - 1 Forth definitions - 2 : resolve ( cfa.ghost cfa.target -) - 3 over dup @ = - 4 IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN - 5 >r >r 2+ @ ?dup - 6 IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! - 7 H ?dup 0= UNTIL - 8 THEN r> r> over ! 2+ ! ; - 9 -10 : resdoes> ( cfa.ghost cfa.target -) -11 swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; -12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ; -13 ' >body ! -14 ] Does> [ here 4- 0 ] @ T , H ; -15 ' >body ! -Screen 12 not modified - 0 \ move-threads 68000-align cas 26jan06 - 1 - 2 : move-threads Tvoc @ Tvoc-link @ - 3 BEGIN over ?dup - 4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT - 5 error" some undef. Target-Vocs left" drop ; - 6 - 7 | : tlatest ( - addr) current @ 6 + ; - 8 - 9 \\ -10 not used for the 6502 architecture -11 -12 | : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ; -13 -14 -15 -Screen 13 not modified - 0 \ save-target 09sep86we - 1 - 2 Dos definitions - 3 - 4 Code (filewrite ( buff len handle -- n) - 5 SP )+ D0 move .l D2 clr .w SP )+ D2 move - 6 .l 0 imagepage # D1 move .w SP )+ D1 move - 7 .l D1 A7 -) move \ buffer adress - 8 .l D2 A7 -) move \ buffer length - 9 .w D0 A7 -) move \ handle -10 $40 # A7 -) move \ call WRITE -11 1 trap $0C # A7 adda -12 .w D0 SP -) move Next end-code Forth definitions -13 -14 -15 -Screen 14 not modified - 0 \ save Target-System 09sep86we - 1 - 2 : save-target [ Dos ] - 3 bl word count dup 0= abort" missing filename" - 4 over + off (createfile dup >r 0< abort" no device " - 5 T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header - 6 0 there r@ (filewrite there - abort" write error" - 7 r> (closefile 0< abort" close error" ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \\ 6502-ALIGN ?HEAD \ 08SEP84BP) - 1 - 2 | : 6502-align/1 ( adr -- adr' ) dup 0FF and 0FF = - ; - 3 - 4 - 5 | : 6502-align/2 ( lfa -- lfa ) - 6 there 0FF and 0FF = - 7 IF dup dup 1+ there over - 1+ cmove> \ lfa now invalid - 8 1 tlast +! 1 tallot THEN ; - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \\ WARNING CREATE 30DEC84BP) - 1 - 2 VARIABLE WARNING 0 WARNING ! - 3 - 4 | : EXISTS? - 5 WARNING @ ?EXIT - 6 LAST @ CURRENT @ (FIND NIP - 7 IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; - 8 - 9 : CREATE HERE BLK @ , CURRENT @ @ , -10 NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" -11 HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ -12 IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE -13 HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! -14 ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , -15 ;CODE DOCREATE JMP END-CODE -Screen 17 not modified - 0 \ compiling names into targ. 05mar86we - 1 - 2 : (theader - 3 ?thead @ IF 1 ?thead +! - 4 there $FF and $FF = IF 1 T allot H THEN exit THEN - 5 >in @ name swap >in ! - 6 dup c@ 1 $20 uwithin not abort" inval. Tname" - 7 dup c@ 3 + there + $FF and $FF = - 8 there 2+ $FF and $FF = or IF 1 T allot H THEN - 9 blk @ T , H there tlatest dup @ T , H ! there dup tlast ! -10 over c@ 1+ .( even ) dup T allot cmove H ; -11 -12 : Theader tlast off -13 (theader Ghost dup glast' ! -14 there resolve ; -15 -Screen 18 not modified - 0 \ prebuild defining words bp27jun85we - 1 - 2 | : executable? ( adr - adr f ) dup ; - 3 | : tpfa, there , ; - 4 | : (prebuild ( cfa.adr -- ) - 5 >in @ Create >in ! here 2- ! ; - 6 - 7 : prebuild ( adr 0.from.: - 0 ) - 8 0 ?pairs executable? dup >r - 9 IF [compile] Literal compile (prebuild ELSE drop THEN -10 compile Theader Ghost gdoes> , -11 r> IF compile tpfa, THEN 0 ; immediate restrict -12 -13 -14 -15 -Screen 19 not modified - 0 \ code portion of def.words bp11sep86we - 1 - 2 : dummy 0 ; - 3 - 4 : DO> ( - adr.of.jmp.dodoes> 0 ) - 5 [compile] Does> here 4- compile @ 0 ] ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 20 not modified - 0 \ the 68000 Assembler 11sep86we - 1 - 2 Forth definitions - 3 | Create relocate ] T c, , c@ here allot ! c! H [ - 4 - 5 Transient definitions - 6 - 7 : Assembler H [ Tassembler ] relocate >codes ! Tassembler ; - 8 : >label ( 16b -) H >in @ name gfind rot >in ! - 9 IF over resolve dup THEN drop Constant ; -10 : Label T .( here 1 and allot ) here >label Assembler H ; -11 : Code H Theader there 2+ T , Assembler H ; -12 -13 -14 -15 -Screen 21 not modified - 0 \ immed. restr. ' \ compile bp05mar86we - 1 - 2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ; - 3 : >mark ( - addr ) H there T 0 , H ; - 4 : >resolve ( addr - ) H there over - swap T ! H ; - 5 : - cfa ) H g' dup @ - abort" ?" 2+ @ ; -12 : | H ?thead @ ?exit ?thead on ; -13 : compile H Ghost , ; immediate restrict -14 -15 -Screen 22 not modified - 0 \ Target tools ks05mar86we - 1 - 2 Onlyforth Ttools also definitions - 3 - 4 | : ttype ( adr n -) bounds ?DO I T c@ H dup - 5 bl > IF emit ELSE drop Ascii . emit THEN LOOP ; - 6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype - 7 ELSE ." ??? " THEN space ?cr ; - 8 | : nfa? ( cfa lfa - nfa / cfa ff) - 9 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) = -10 IF 2+ nip exit THEN -11 T @ H REPEAT ; -12 : >name ( cfa - nfa / ff) -13 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup -14 IF nip exit THEN -15 swap REPEAT nip ; -Screen 23 not modified - 0 \ Ttools for decompiling ks05mar86we - 1 - 2 | : ?: dup 4 u.r ." :" ; - 3 | : @? dup T @ H 6 u.r ; - 4 | : c? dup T c@ H 3 .r ; - 5 - 6 : s ( addr - addr+ ) ?: space c? 3 spaces - 7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ; - 8 - 9 : n ( addr - addr+2 ) ?: @? 2 spaces -10 dup T @ H [ Ttools ] >name .name H 2+ ; -11 -12 : d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP -13 2 spaces -rot ttype ; -14 -15 -Screen 24 not modified - 0 \ Tools for decompiling bp05mar86we - 1 - 2 : l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ; - 3 - 4 : c ( addr -- addr+1 ) 1 d ; - 5 - 6 : b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ; - 7 - 8 : dump ( adr n -) bounds ?DO cr I $10 d drop - 9 stop? IF LEAVE THEN $10 +LOOP ; -10 -11 : view T ' H [ Ttools ] >name ?dup -12 IF 4- T @ H l THEN ; -13 -14 -15 -Screen 25 not modified - 0 \ reinterpretation def.-words 05mar86we - 1 - 2 Onlyforth - 3 - 4 : redefinition - 5 tdoes> @ IF >in push [ ' >interpret >body ] Literal push - 6 state push context push >in: @ >in ! - 7 name [ ' Transient 2+ ] Literal (find nip 0= - 8 IF cr ." Redefinition: " here .name - 9 >in: @ >in ! : Defining interpret THEN -10 THEN 0 tdoes> ! ; -11 -12 -13 -14 -15 -Screen 26 not modified - 0 \ Create..does> structure bp05mar86we - 1 - 2 | : (;tcode - 3 Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ; - 4 | : changecfa compile lit tdoes> @ , compile (;tcode ; - 5 - 6 Defining definitions - 7 - 8 : ;code 0 ?pairs changecfa reveal rdrop ; - 9 immediate restrict -10 -11 Defining ' ;code Alias does> immediate restrict -12 -13 : ; [compile] ; rdrop ; immediate restrict -14 -15 -Screen 27 not modified - 0 \ redefinition conditionals bp27jun85we - 1 - 2 ' DO Alias DO immediate restrict - 3 ' ?DO Alias ?DO immediate restrict - 4 ' LOOP Alias LOOP immediate restrict - 5 ' IF Alias IF immediate restrict - 6 ' THEN Alias THEN immediate restrict - 7 ' ELSE Alias ELSE immediate restrict - 8 ' BEGIN Alias BEGIN immediate restrict - 9 ' UNTIL Alias UNTIL immediate restrict -10 ' WHILE Alias WHILE immediate restrict -11 ' REPEAT Alias REPEAT immediate restrict -12 -13 -14 -15 -Screen 28 not modified - 0 \ clear Liter. Ascii ['] ." bp05mar86we - 1 - 2 Onlyforth Transient definitions - 3 - 4 : clear true abort" There are ghosts" ; - 5 : Literal ( n -) T compile lit , H ; immediate - 6 : Ascii H bl word 1+ c@ state @ - 7 IF T [compile] Literal H THEN ; immediate - 8 : ['] T ' [compile] Literal H ; immediate restrict - 9 : " T compile (" ," H ; immediate restrict -10 : ." T compile (." ," H ; immediate restrict -11 -12 -13 -14 -15 -Screen 29 not modified - 0 \ Target compilation ] [ bp05mar86we - 1 - 2 Forth definitions - 3 - 4 : tcompile - 5 ?stack >in @ name find ?dup - 6 IF 0> IF nip execute >interpret THEN - 7 drop dup >in ! name - 8 THEN gfind IF nip execute >interpret THEN - 9 nullstring? IF drop exit THEN -10 number? ?dup IF 0> IF swap T [compile] Literal THEN -11 [compile] Literal H drop >interpret THEN -12 drop >in ! Word, >interpret ; -13 -14 Transient definitions -15 : ] H state on ['] tcompile is >interpret ; -Screen 30 not modified - 0 \ Target conditionals bp05mar86we - 1 - 2 : IF T compile ?branch >mark H 1 ; immediate restrict - 3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict - 4 : ELSE T 1 ?pairs compile branch >mark swap >resolve - 5 H -1 ; immediate restrict - 6 : BEGIN T mark -2 H 2swap ; - 8 immediate restrict - 9 | : (repeat T 2 ?pairs resolve H REPEAT ; -11 : UNTIL T compile ?branch (repeat H ; immediate restrict -12 : REPEAT T compile branch (repeat H ; immediate restrict -13 -14 -15 -Screen 31 not modified - 0 \ Target conditionals bp27jun85we - 1 - 2 : DO T compile (do >mark H 3 ; immediate restrict - 3 : ?DO T compile (?do >mark H 3 ; immediate restrict - 4 : LOOP T 3 ?pairs compile (loop compile endloop - 5 >resolve H ; immediate restrict - 6 : +LOOP T 3 ?pairs compile (+loop compile endloop - 7 >resolve H ; immediate restrict - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 32 not modified - 0 \ predefinitions bp05mar86we - 1 - 2 : abort" T compile (abort" ," H ; immediate - 3 : error" T compile (err" ," H ; immediate - 4 - 5 Forth definitions - 6 - 7 Variable torigin - 8 Variable tudp 0 Tudp ! - 9 -10 : >user T c@ H torigin @ + ; -11 -12 -13 -14 -15 -Screen 33 not modified - 0 \ Datatypes bp05mar86we - 1 - 2 Transient definitions - 3 : origin! H torigin ! ; - 4 : user' ( -- n ) T ' >body c@ H ; - 5 : uallot ( n -- ) H tudp @ swap tudp +! ; - 6 - 7 DO> >user ; - 8 : User prebuild User 2 T uallot c, ; - 9 -10 DO> ; -11 : Create prebuild Create ; -12 -13 DO> T @ H ; -14 : Constant prebuild Constant T , ; -15 : Variable Create 2 T allot ; -Screen 34 not modified - 0 \ Datatypes bp05mar86we - 1 - 2 dummy - 3 : Vocabulary - 4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , - 5 here H tvoc-link @ T , H tvoc-link ! ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 35 not modified - 0 \ target defining words bp08sep86we - 1 - 2 Do> ; - 3 : Defer prebuild Defer 2 T allot ; - 4 : Is T ' H >body state @ IF T compile (is , H - 5 ELSE T ! H THEN ; immediate - 6 | : dodoes> T compile (;code H Glast' @ - 7 there resdoes> there tdoes> ! ; - 8 - 9 : ;code 0 T ?pairs dodoes> Assembler H [compile] [ -10 redefinition ; immediate restrict -11 -12 : does> T dodoes> $04C C, -13 compile (dodoes> H ; immediate restrict -14 -15 -Screen 36 not modified - 0 \ : Alias ; bp25mar86we - 1 - 2 : Create: T Create H current @ context ! T ] H 0 ; - 3 - 4 dummy - 5 : : H tdoes> off >in @ >in: ! T prebuild : - 6 H current @ context ! T ] H 0 ; - 7 - 8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve - 9 tlast @ T c@ H $20 or tlast @ T c! , H ; -10 -11 : ; T 0 ?pairs compile exit .( unnest gegen exit getauscht) -12 [compile] [ H redefinition ; immediate restrict -13 -14 -15 -Screen 37 not modified - 0 \ predefinitions bp11sep86we - 1 - 2 : compile T compile compile H ; immediate restrict - 3 : Host H Onlyforth Ttools also ; - 4 : Compiler T Host H Transient also definitions ; - 5 : [compile] H Word, ; immediate restrict - 6 : Onlypatch H there 3 - 0 tdoes> ! 0 ; - 7 - 8 Onlyforth - 9 : Target Onlyforth Transient also definitions ; -10 -11 Transient definitions -12 Ghost c, drop -13 -14 -15 -Screen 38 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 39 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/Apple1/crostarg.fth b/sources/Apple1/crostarg.fth new file mode 100644 index 0000000..9f0e056 --- /dev/null +++ b/sources/Apple1/crostarg.fth @@ -0,0 +1,680 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** volksFORTH-84 Target-Compiler *** cas 26jan06 + +This Target Compiler can be used to create a new Forth System +using the Sourcecode 6502F82.FB. + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Target compiler loadscr 09sep86we +\ Idea and first Implementation by ks/bp +\ Implemented on 6502 by ks/bp +\ ultraFORTH83-Version by bp/we +\ Atari 520 ST - Version by we +Onlyforth Assembler nonrelocate +07 Constant imagepage \ Virtual memory bank +Vocabulary Ttools +Vocabulary Defining +: .stat .blk .s ; ' .stat Is .status +\ : 65( [compile] ( ; immediate +: 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte| + 1 $14 +thru \ Target compiler +$15 $17 +thru \ Target Tools +$18 $1A +thru \ Redefinitions +save $1B $24 +thru \ Predefinitions +\ *** Block No. 2 Hexblock 2 +\ Target header pointers bp05mar86we + +Variable tdp : there tdp @ ; +Variable displace +Variable ?thead 0 ?thead ! +Variable tlast 0 tlast ! +Variable glast' 0 glast' ! +Variable tdoes> +Variable >in: +Variable tvoc 0 tvoc ! +Variable tvoc-link 0 tvoc-link ! +Variable tnext-link 0 tnext-link ! + +: c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + +\ *** Block No. 3 Hexblock 3 +\ Image and byteorder 15sep86we + +: >image ( addr1 - addr2 ) displace @ - ; + +: >heap ( from quan - ) + heap over - 1 and + \ 68000-align + dup hallot heap swap cmove ; +\\ +: >ascii 2drop ; ' noop Alias C64>ascii + +Code Lc@ ( laddr -- 8b ) +.l SP )+ A0 move .w D0 clr .b A0 ) D0 move +.w D0 SP -) move Next end-code +Code Lc! ( 8b addr -- ) +.l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move +Next end-code +\ *** Block No. 4 Hexblock 4 +\ Ghost-creating 05mar86we + +0 | Constant 0 | Constant + +| : Make.ghost ( - cfa.ghost ) + here dup 1 and allot here + state @ IF context @ ELSE current THEN @ + dup @ , name + dup c@ 1 $1F uwithin not abort" inval.Gname" + dup c@ 1+ over c! + c@ dup 1+ allot 1 and 0= IF bl c, THEN + here 2 pick - -rot + , 0 , 0 , + swap here over - >heap + heap swap ! swap dp ! + heap + ; +\ *** Block No. 5 Hexblock 5 +\ ghost words 05mar86we + +: gfind ( string - cfa tf / string ff ) + dup count + 1+ bl swap c! + dup >r 1 over c+! find -1 r> c+! ; + +: ghost ( - cfa ) + >in @ name gfind IF nip exit THEN + drop >in ! Make.ghost ; + +: Word, ghost execute ; + +: gdoes> ( cfa.ghost - cfa.does ) + 4+ dup @ IF @ exit THEN + here dup , 0 , 4 >heap + dp ! heap dup rot ! ; +\ *** Block No. 6 Hexblock 6 +\ ghost utilities 04dec85we + +: g' name gfind 0= abort" ?" ; + +: '. + g' dup @ case? + IF ." forw" ELSE - abort" ??" ." res" THEN + 2+ dup @ 5 u.r + 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + +' ' Alias h' + + +\ *** Block No. 7 Hexblock 7 +\ .unresolved 05mar86we + +| : forward? ( cfa - cfa / exit&true ) + dup @ = over 2+ @ and IF drop true rdrop exit THEN ; + +| : unresolved? ( addr - f ) + 2+ dup c@ $1F and over + c@ BL = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + +: .unresolved voc-link @ + BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; +\ *** Block No. 8 Hexblock 8 +\ Extending Vocabularys for Target-Compilation 05mar86we + +: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + +Vocabulary Transient 0 tvoc ! + +Only definitions Forth also + +: T Transient ; immediate +: H Forth ; immediate + +definitions + + + + +\ *** Block No. 9 Hexblock 9 +\ Transient primitives 05mar86we + +Code byte> ( 8bh 8bl -- 16b ) + SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move + .w D0 SP ) move Next end-code +Code >byte ( 16b -- 8bl 8bh ) + SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr + D0 SP -) move D1 SP -) move Next end-code + +Transient definitions +: c@ H >image imagepage lc@ ; +: c! H >image imagepage lc! ; +: @ dup T c@ swap 1+ T c@ 65( swap ) byte> ; +: ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ; +: cmove ( from.mem to.target quan -) + bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; +\ *** Block No. 10 Hexblock A +\ Transient primitives bp05mar86we + +: here there ; +: allot Tdp +! ; +: c, T here c! 1 allot H ; +: , T here ! 2 allot H ; + +: ," Ascii " parse dup T c, + under there swap cmove + .( dup 1 and 0= IF 1+ THEN ) allot H ; + +: fill ( addr quan 8b -) + -rot bounds ?DO dup I T c! H LOOP drop ; +: erase 0 T fill ; +: blank bl T fill ; +: here! H Tdp ! ; +\ *** Block No. 11 Hexblock B +\ Resolving 08dec85we +Forth definitions +: resolve ( cfa.ghost cfa.target -) + over dup @ = + IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN + >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! + H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + +: resdoes> ( cfa.ghost cfa.target -) + swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; +] Does> [ here 4- 0 ] dup @ there rot ! T , H ; +' >body ! +] Does> [ here 4- 0 ] @ T , H ; +' >body ! +\ *** Block No. 12 Hexblock C +\ move-threads 68000-align cas 26jan06 + +: move-threads Tvoc @ Tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + error" some undef. Target-Vocs left" drop ; + +| : tlatest ( - addr) current @ 6 + ; + +\\ +not used for the 6502 architecture + +| : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ; + + + +\ *** Block No. 13 Hexblock D +\ save-target 09sep86we + +Dos definitions + +Code (filewrite ( buff len handle -- n) + SP )+ D0 move .l D2 clr .w SP )+ D2 move + .l 0 imagepage # D1 move .w SP )+ D1 move + .l D1 A7 -) move \ buffer adress + .l D2 A7 -) move \ buffer length + .w D0 A7 -) move \ handle + $40 # A7 -) move \ call WRITE + 1 trap $0C # A7 adda + .w D0 SP -) move Next end-code Forth definitions + + + +\ *** Block No. 14 Hexblock E +\ save Target-System 09sep86we + +: save-target [ Dos ] + bl word count dup 0= abort" missing filename" + over + off (createfile dup >r 0< abort" no device " + T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header + 0 there r@ (filewrite there - abort" write error" + r> (closefile 0< abort" close error" ; + + + + + + + + +\ *** Block No. 15 Hexblock F +\\ 6502-ALIGN ?HEAD \ 08SEP84BP) + +| : 6502-align/1 ( adr -- adr' ) dup 0FF and 0FF = - ; + + +| : 6502-align/2 ( lfa -- lfa ) + there 0FF and 0FF = + IF dup dup 1+ there over - 1+ cmove> \ lfa now invalid + 1 tlast +! 1 tallot THEN ; + + + + + + + +\ *** Block No. 16 Hexblock 10 +\\ WARNING CREATE 30DEC84BP) + +VARIABLE WARNING 0 WARNING ! + +| : EXISTS? + WARNING @ ?EXIT + LAST @ CURRENT @ (FIND NIP + IF SPACE LAST @ .NAME ." EXISTS " ?CR THEN ; + +: CREATE HERE BLK @ , CURRENT @ @ , + NAME C@ DUP 1 020 UWITHIN NOT ABORT" INVALID NAME" + HERE LAST ! 1+ ALLOT EXISTS? ?HEAD @ + IF 1 ?HEAD +! DUP 6502-ALIGN/1 , \ POINTER TO CODE + HEAPMOVE 020 FLAG! 6502-ALIGN/1 DP ! + ELSE 6502-ALIGN/2 DROP THEN REVEAL 0 , + ;CODE DOCREATE JMP END-CODE +\ *** Block No. 17 Hexblock 11 +\ compiling names into targ. 05mar86we + +: (theader + ?thead @ IF 1 ?thead +! + there $FF and $FF = IF 1 T allot H THEN exit THEN + >in @ name swap >in ! + dup c@ 1 $20 uwithin not abort" inval. Tname" + dup c@ 3 + there + $FF and $FF = + there 2+ $FF and $FF = or IF 1 T allot H THEN + blk @ T , H there tlatest dup @ T , H ! there dup tlast ! + over c@ 1+ .( even ) dup T allot cmove H ; + +: Theader tlast off + (theader Ghost dup glast' ! + there resolve ; + +\ *** Block No. 18 Hexblock 12 +\ prebuild defining words bp27jun85we + +| : executable? ( adr - adr f ) dup ; +| : tpfa, there , ; +| : (prebuild ( cfa.adr -- ) + >in @ Create >in ! here 2- ! ; + +: prebuild ( adr 0.from.: - 0 ) + 0 ?pairs executable? dup >r + IF [compile] Literal compile (prebuild ELSE drop THEN + compile Theader Ghost gdoes> , + r> IF compile tpfa, THEN 0 ; immediate restrict + + + + +\ *** Block No. 19 Hexblock 13 +\ code portion of def.words bp11sep86we + +: dummy 0 ; + +: DO> ( - adr.of.jmp.dodoes> 0 ) + [compile] Does> here 4- compile @ 0 ] ; + + + + + + + + + + +\ *** Block No. 20 Hexblock 14 +\ the 68000 Assembler 11sep86we + +Forth definitions +| Create relocate ] T c, , c@ here allot ! c! H [ + +Transient definitions + +: Assembler H [ Tassembler ] relocate >codes ! Tassembler ; +: >label ( 16b -) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; +: Label T .( here 1 and allot ) here >label Assembler H ; +: Code H Theader there 2+ T , Assembler H ; + + + + +\ *** Block No. 21 Hexblock 15 +\ immed. restr. ' \ compile bp05mar86we + +: ?pairs ( n1 n2 -- ) H - abort" unstructured" ; +: >mark ( - addr ) H there T 0 , H ; +: >resolve ( addr - ) H there over - swap T ! H ; +: - cfa ) H g' dup @ - abort" ?" 2+ @ ; +: | H ?thead @ ?exit ?thead on ; +: compile H Ghost , ; immediate restrict + + +\ *** Block No. 22 Hexblock 16 +\ Target tools ks05mar86we + +Onlyforth Ttools also definitions + +| : ttype ( adr n -) bounds ?DO I T c@ H dup + bl > IF emit ELSE drop Ascii . emit THEN LOOP ; +: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype + ELSE ." ??? " THEN space ?cr ; +| : nfa? ( cfa lfa - nfa / cfa ff) + BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) = + IF 2+ nip exit THEN + T @ H REPEAT ; +: >name ( cfa - nfa / ff) + Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup + IF nip exit THEN + swap REPEAT nip ; +\ *** Block No. 23 Hexblock 17 +\ Ttools for decompiling ks05mar86we + +| : ?: dup 4 u.r ." :" ; +| : @? dup T @ H 6 u.r ; +| : c? dup T c@ H 3 .r ; + +: s ( addr - addr+ ) ?: space c? 3 spaces + dup 1+ over T c@ H ttype dup T c@ H + 1+ ; + +: n ( addr - addr+2 ) ?: @? 2 spaces + dup T @ H [ Ttools ] >name .name H 2+ ; + +: d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP + 2 spaces -rot ttype ; + + +\ *** Block No. 24 Hexblock 18 +\ Tools for decompiling bp05mar86we + +: l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ; + +: c ( addr -- addr+1 ) 1 d ; + +: b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ; + +: dump ( adr n -) bounds ?DO cr I $10 d drop + stop? IF LEAVE THEN $10 +LOOP ; + +: view T ' H [ Ttools ] >name ?dup + IF 4- T @ H l THEN ; + + + +\ *** Block No. 25 Hexblock 19 +\ reinterpretation def.-words 05mar86we + +Onlyforth + +: redefinition + tdoes> @ IF >in push [ ' >interpret >body ] Literal push + state push context push >in: @ >in ! + name [ ' Transient 2+ ] Literal (find nip 0= + IF cr ." Redefinition: " here .name + >in: @ >in ! : Defining interpret THEN + THEN 0 tdoes> ! ; + + + + + +\ *** Block No. 26 Hexblock 1A +\ Create..does> structure bp05mar86we + +| : (;tcode + Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ; +| : changecfa compile lit tdoes> @ , compile (;tcode ; + +Defining definitions + +: ;code 0 ?pairs changecfa reveal rdrop ; + immediate restrict + +Defining ' ;code Alias does> immediate restrict + +: ; [compile] ; rdrop ; immediate restrict + + +\ *** Block No. 27 Hexblock 1B +\ redefinition conditionals bp27jun85we + +' DO Alias DO immediate restrict +' ?DO Alias ?DO immediate restrict +' LOOP Alias LOOP immediate restrict +' IF Alias IF immediate restrict +' THEN Alias THEN immediate restrict +' ELSE Alias ELSE immediate restrict +' BEGIN Alias BEGIN immediate restrict +' UNTIL Alias UNTIL immediate restrict +' WHILE Alias WHILE immediate restrict +' REPEAT Alias REPEAT immediate restrict + + + + +\ *** Block No. 28 Hexblock 1C +\ clear Liter. Ascii ['] ." bp05mar86we + +Onlyforth Transient definitions + +: clear true abort" There are ghosts" ; +: Literal ( n -) T compile lit , H ; immediate +: Ascii H bl word 1+ c@ state @ + IF T [compile] Literal H THEN ; immediate +: ['] T ' [compile] Literal H ; immediate restrict +: " T compile (" ," H ; immediate restrict +: ." T compile (." ," H ; immediate restrict + + + + + +\ *** Block No. 29 Hexblock 1D +\ Target compilation ] [ bp05mar86we + +Forth definitions + +: tcompile + ?stack >in @ name find ?dup + IF 0> IF nip execute >interpret THEN + drop dup >in ! name + THEN gfind IF nip execute >interpret THEN + nullstring? IF drop exit THEN + number? ?dup IF 0> IF swap T [compile] Literal THEN + [compile] Literal H drop >interpret THEN + drop >in ! Word, >interpret ; + +Transient definitions +: ] H state on ['] tcompile is >interpret ; +\ *** Block No. 30 Hexblock 1E +\ Target conditionals bp05mar86we + +: IF T compile ?branch >mark H 1 ; immediate restrict +: THEN abs 1 T ?pairs >resolve H ; immediate restrict +: ELSE T 1 ?pairs compile branch >mark swap >resolve + H -1 ; immediate restrict +: BEGIN T mark -2 H 2swap ; + immediate restrict +| : (repeat T 2 ?pairs resolve H REPEAT ; +: UNTIL T compile ?branch (repeat H ; immediate restrict +: REPEAT T compile branch (repeat H ; immediate restrict + + + +\ *** Block No. 31 Hexblock 1F +\ Target conditionals bp27jun85we + +: DO T compile (do >mark H 3 ; immediate restrict +: ?DO T compile (?do >mark H 3 ; immediate restrict +: LOOP T 3 ?pairs compile (loop compile endloop + >resolve H ; immediate restrict +: +LOOP T 3 ?pairs compile (+loop compile endloop + >resolve H ; immediate restrict + + + + + + + + +\ *** Block No. 32 Hexblock 20 +\ predefinitions bp05mar86we + +: abort" T compile (abort" ," H ; immediate +: error" T compile (err" ," H ; immediate + +Forth definitions + +Variable torigin +Variable tudp 0 Tudp ! + +: >user T c@ H torigin @ + ; + + + + + +\ *** Block No. 33 Hexblock 21 +\ Datatypes bp05mar86we + +Transient definitions +: origin! H torigin ! ; +: user' ( -- n ) T ' >body c@ H ; +: uallot ( n -- ) H tudp @ swap tudp +! ; + + DO> >user ; +: User prebuild User 2 T uallot c, ; + + DO> ; +: Create prebuild Create ; + + DO> T @ H ; +: Constant prebuild Constant T , ; +: Variable Create 2 T allot ; +\ *** Block No. 34 Hexblock 22 +\ Datatypes bp05mar86we + +dummy +: Vocabulary + H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , + here H tvoc-link @ T , H tvoc-link ! ; + + + + + + + + + + +\ *** Block No. 35 Hexblock 23 +\ target defining words bp08sep86we + + Do> ; +: Defer prebuild Defer 2 T allot ; +: Is T ' H >body state @ IF T compile (is , H + ELSE T ! H THEN ; immediate +| : dodoes> T compile (;code H Glast' @ + there resdoes> there tdoes> ! ; + +: ;code 0 T ?pairs dodoes> Assembler H [compile] [ + redefinition ; immediate restrict + +: does> T dodoes> $04C C, + compile (dodoes> H ; immediate restrict + + +\ *** Block No. 36 Hexblock 24 +\ : Alias ; bp25mar86we + +: Create: T Create H current @ context ! T ] H 0 ; + +dummy +: : H tdoes> off >in @ >in: ! T prebuild : + H current @ context ! T ] H 0 ; + +: Alias ( n -- ) H Tlast off (theader Ghost over resolve + tlast @ T c@ H $20 or tlast @ T c! , H ; + +: ; T 0 ?pairs compile exit .( unnest gegen exit getauscht) + [compile] [ H redefinition ; immediate restrict + + + +\ *** Block No. 37 Hexblock 25 +\ predefinitions bp11sep86we + +: compile T compile compile H ; immediate restrict +: Host H Onlyforth Ttools also ; +: Compiler T Host H Transient also definitions ; +: [compile] H Word, ; immediate restrict +: Onlypatch H there 3 - 0 tdoes> ! 0 ; + +Onlyforth +: Target Onlyforth Transient also definitions ; + +Transient definitions +Ghost c, drop + + + +\ *** Block No. 38 Hexblock 26 + + + + + + + + + + + + + + + + +\ *** Block No. 39 Hexblock 27 + + + + + + + + + + + + + + + + diff --git a/sources/Apple1/systemio.fb.src b/sources/Apple1/systemio.fb.src deleted file mode 100644 index f8fd8b2..0000000 --- a/sources/Apple1/systemio.fb.src +++ /dev/null @@ -1,187 +0,0 @@ -Screen 0 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ loadscreen for system IO for Apple1 cas2013apr05 - 1 - 2 - 3 1 9 +thru - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ 65KEY? GETKEY cas2013apr05 - 1 | $D010 Constant KBDDTA - 2 | $D011 Constant KBDCTL - 3 - 4 | CODE 65KEY? ( -- FLAG) KBDCTL lda 0>= ?[ 0 # lda ][ 1 # lda ]? - 5 push0a jmp end-code - 6 - 7 | CODE GETKEY ( -- 8B) KBDDTA lda $7F # AND - 8 push0a jmp end-code - 9 -10 | CODE CURON ( --) NEXT JMP END-CODE -11 -12 | CODE CUROFF ( --) NEXT JMP END-CODE -13 -14 : 65KEY ( -- 8B) -15 CURON BEGIN PAUSE 65KEY? UNTIL CUROFF GETKEY ; -Screen 3 not modified - 0 \ DECODE EXPECT KEYBOARD BP28MAY85) cs08aug05 - 1 08 CONSTANT #BS $0D CONSTANT #CR &27 CONSTANT #ESC - 2 - 3 : 65DECODE ( ADDR CNT1 KEY -- ADDR CNT2) - 4 #BS CASE? IF DUP IF DEL 1- THEN EXIT THEN - 5 #CR CASE? IF DUP SPAN ! EXIT THEN - 6 >R 2DUP + R@ SWAP C! R> EMIT 1+ ; - 7 - 8 : 65EXPECT ( ADDR LEN1 -- ) SPAN ! 0 - 9 BEGIN DUP SPAN @ U< -10 WHILE KEY DECODE -11 REPEAT 2DROP SPACE ; -12 -13 INPUT: KEYBOARD [ HERE INPUT ! ] -14 65KEY 65KEY? 65DECODE 65EXPECT [ -15 -Screen 4 not modified - 0 \ senden? (emit 65emit 25JAN85RE) cas2013apr05 - 1 - 2 | $D012 Constant DSP - 3 - 4 | Code send? ( -- flg ) - 5 DSP lda $80 # AND $80 # EOR push0a jmp end-code - 6 - 7 Code (emit ( 8b -- ) - 8 SP X) LDA DSP sta (drop jmp end-code - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ EMIT CR DEL PAGE AT AT? 25JAN85RE) cas2013apr05 - 1 - 2 | Variable out 0 out ! | &40 Constant c/row - 3 - 4 : 65emit ( 8b -- ) BEGIN pause send? UNTIL 1 out +! (emit ; - 5 - 6 : 65CR #CR 65emit out @ c/row / 1+ c/row * out ! ; - 7 - 8 : 65DEL ASCII _ 65emit -1 out +! ; - 9 -10 : 65PAGE &24 0 DO CR LOOP out off ; -11 -12 : 65at ( row col -- ) .( at einf. ) swap c/row * + out ! ; -13 -14 : 65AT? ( -- ROW COL ) out @ c/row /mod &24 min swap ; -15 -Screen 6 not modified - 0 \ er14dez88 - 1 - 2 : 65type ( adr len -- ) bounds ?DO I c@ emit LOOP ; - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ TYPE DISPLAY (BYE BP 28MAY85RE) er14dez88 - 1 - 2 OUTPUT: DISPLAY [ HERE OUTPUT ! ] - 3 65EMIT 65CR 65TYPE 65DEL 65PAGE 65AT 65AT? [ - 4 - 5 - 6 | : (bye ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ B/BLK DRIVE >DRIVE DRVINIT 28MAY85RE) er14dez88 - 1 - 2 $400 CONSTANT B/BLK - 3 - 4 $0AA CONSTANT BLK/DRV - 5 - 6 | VARIABLE (DRV 0 (DRV ! - 7 - 8 | : DISK ( -- DEV.NO ) (DRV @ 8 + ; - 9 -10 : DRIVE ( DRV# -- ) BLK/DRV * OFFSET ! ; -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ er14dez88 - 1 : >DRIVE ( BLOCK DRV# -- BLOCK' ) - 2 BLK/DRV * + OFFSET @ - ; - 3 : DRV? ( BLOCK -- DRV# ) - 4 OFFSET @ + BLK/DRV / ; - 5 - 6 : DRVINIT NOOP ; - 7 .( fuer reads. u. writes. ist errorhandler erforderlich ) - 8 | : readserial ( adr blk -- ) - 9 &27 emit .( rb ) space base push decimal . cr -10 $400 bounds DO key I c! LOOP ; -11 -12 | : writeserial ( adr blk -- ) -13 &27 emit .( wb ) space base push decimal . cr -14 $400 bounds DO I c@ emit LOOP ; -15 -Screen 10 not modified - 0 \ (r/w er14decas - 1 - 2 : (R/W ( ADR BLK FILE R/WF -- FLAG) - 3 swap abort" no file" - 4 IF readserial ELSE writeserial THEN false ; - 5 - 6 ' (R/W IS R/W - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/Apple1/systemio.fth b/sources/Apple1/systemio.fth new file mode 100644 index 0000000..42d6f4d --- /dev/null +++ b/sources/Apple1/systemio.fth @@ -0,0 +1,187 @@ +\ *** Block No. 0 Hexblock 0 + + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ loadscreen for system IO for Apple1 cas2013apr05 + + + 1 9 +thru + + + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ 65KEY? GETKEY cas2013apr05 +| $D010 Constant KBDDTA +| $D011 Constant KBDCTL + +| CODE 65KEY? ( -- FLAG) KBDCTL lda 0>= ?[ 0 # lda ][ 1 # lda ]? + push0a jmp end-code + +| CODE GETKEY ( -- 8B) KBDDTA lda $7F # AND + push0a jmp end-code + +| CODE CURON ( --) NEXT JMP END-CODE + +| CODE CUROFF ( --) NEXT JMP END-CODE + +: 65KEY ( -- 8B) + CURON BEGIN PAUSE 65KEY? UNTIL CUROFF GETKEY ; +\ *** Block No. 3 Hexblock 3 +\ DECODE EXPECT KEYBOARD BP28MAY85) cs08aug05 +08 CONSTANT #BS $0D CONSTANT #CR &27 CONSTANT #ESC + +: 65DECODE ( ADDR CNT1 KEY -- ADDR CNT2) + #BS CASE? IF DUP IF DEL 1- THEN EXIT THEN + #CR CASE? IF DUP SPAN ! EXIT THEN + >R 2DUP + R@ SWAP C! R> EMIT 1+ ; + +: 65EXPECT ( ADDR LEN1 -- ) SPAN ! 0 + BEGIN DUP SPAN @ U< + WHILE KEY DECODE + REPEAT 2DROP SPACE ; + +INPUT: KEYBOARD [ HERE INPUT ! ] + 65KEY 65KEY? 65DECODE 65EXPECT [ + +\ *** Block No. 4 Hexblock 4 +\ senden? (emit 65emit 25JAN85RE) cas2013apr05 + +| $D012 Constant DSP + +| Code send? ( -- flg ) + DSP lda $80 # AND $80 # EOR push0a jmp end-code + +Code (emit ( 8b -- ) + SP X) LDA DSP sta (drop jmp end-code + + + + + + + +\ *** Block No. 5 Hexblock 5 +\ EMIT CR DEL PAGE AT AT? 25JAN85RE) cas2013apr05 + +| Variable out 0 out ! | &40 Constant c/row + +: 65emit ( 8b -- ) BEGIN pause send? UNTIL 1 out +! (emit ; + +: 65CR #CR 65emit out @ c/row / 1+ c/row * out ! ; + +: 65DEL ASCII _ 65emit -1 out +! ; + +: 65PAGE &24 0 DO CR LOOP out off ; + +: 65at ( row col -- ) .( at einf. ) swap c/row * + out ! ; + +: 65AT? ( -- ROW COL ) out @ c/row /mod &24 min swap ; + +\ *** Block No. 6 Hexblock 6 +\ er14dez88 + +: 65type ( adr len -- ) bounds ?DO I c@ emit LOOP ; + + + + + + + + + + + + + +\ *** Block No. 7 Hexblock 7 +\ TYPE DISPLAY (BYE BP 28MAY85RE) er14dez88 + +OUTPUT: DISPLAY [ HERE OUTPUT ! ] + 65EMIT 65CR 65TYPE 65DEL 65PAGE 65AT 65AT? [ + + +| : (bye ; + + + + + + + + + +\ *** Block No. 8 Hexblock 8 +\ B/BLK DRIVE >DRIVE DRVINIT 28MAY85RE) er14dez88 + +$400 CONSTANT B/BLK + +$0AA CONSTANT BLK/DRV + +| VARIABLE (DRV 0 (DRV ! + +| : DISK ( -- DEV.NO ) (DRV @ 8 + ; + +: DRIVE ( DRV# -- ) BLK/DRV * OFFSET ! ; + + + + + +\ *** Block No. 9 Hexblock 9 +\ er14dez88 +: >DRIVE ( BLOCK DRV# -- BLOCK' ) + BLK/DRV * + OFFSET @ - ; +: DRV? ( BLOCK -- DRV# ) + OFFSET @ + BLK/DRV / ; + +: DRVINIT NOOP ; +.( fuer reads. u. writes. ist errorhandler erforderlich ) +| : readserial ( adr blk -- ) + &27 emit .( rb ) space base push decimal . cr + $400 bounds DO key I c! LOOP ; + +| : writeserial ( adr blk -- ) + &27 emit .( wb ) space base push decimal . cr + $400 bounds DO I c@ emit LOOP ; + +\ *** Block No. 10 Hexblock A +\ (r/w er14decas + +: (R/W ( ADR BLK FILE R/WF -- FLAG) + swap abort" no file" + IF readserial ELSE writeserial THEN false ; + +' (R/W IS R/W + + + + + + + + + diff --git a/sources/Apple1/tasker.fb.src b/sources/Apple1/tasker.fb.src deleted file mode 100644 index 1bf38bb..0000000 --- a/sources/Apple1/tasker.fb.src +++ /dev/null @@ -1,170 +0,0 @@ -Screen 0 not modified - 0 \ Multitasking Extension to volksFORTH cas 26jan06 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Tasker Loadscreen - 1 - 2 \NEEDS CODE abort( Assembler needed ) - 3 hex - 4 1 5 +thru \ load Tasker - 5 7 load \ Task-Demo - 6 decimal - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ MULTITASKER BP 13.9.84 ) - 1 - 2 CODE STOP - 3 SP 2DEC IP LDA SP X) STA IP 1+ LDA SP )Y STA - 4 SP 2DEC RP LDA SP X) STA RP 1+ LDA SP )Y STA - 5 6 # LDY SP LDA UP )Y STA INY SP 1+ LDA UP )Y STA - 6 1 # LDY TYA CLC UP ADC W STA - 7 TXA UP 1+ ADC W 1+ STA W 1- JMP END-CODE - 8 - 9 | CREATE TASKPAUSE ASSEMBLER -10 2C # LDA UP X) STA ' STOP @ JMP END-CODE -11 -12 : SINGLETASK [ ' PAUSE @ ] LITERAL ['] PAUSE ! ; -13 -14 : MULTITASK TASKPAUSE ['] PAUSE ! ; -15 -Screen 3 not modified - 0 \ PASS ACTIVATE KS 8 MAY 84 ) - 1 - 2 : PASS ( N0 .. NR-1 TADR R -- ) - 3 BEGIN [ ROT ( TRICK ! ) ] - 4 SWAP 02C OVER C! \ AWAKE TASK - 5 R> -ROT \ IP R ADDR - 6 8 + >R \ S0 OF TASK - 7 R@ 2+ @ SWAP \ IP R0 R - 8 2+ 2* \ BYTES ON TASKSTACK - 9 \ INCL. R0 & IP -10 R@ @ OVER - \ NEW SP -11 DUP R> 2- ! \ INTO SSAVE -12 SWAP BOUNDS ?DO I ! 2 +LOOP ; RESTRICT -13 -14 -15 -Screen 4 not modified - 0 \ - 1 - 2 : ACTIVATE ( TADR --) - 3 0 [ -ROT ( TRICK ! ) ] REPEAT ; -2 ALLOT RESTRICT - 4 - 5 : SLEEP ( TADR --) 4C SWAP C! ; \ JMP-OPCODE - 6 - 7 : WAKE ( TADR --) 2C SWAP C! ; \ BIT-OPCODE - 8 - 9 | : TASKERROR ( STRING -) -10 STANDARDI/O SINGLETASK ." TASK ERROR : " COUNT TYPE -11 MULTITASK STOP ; -12 -13 -14 -15 -Screen 5 not modified - 0 \ BUILDING A TASK BP 13.9.84 ) - 1 - 2 : TASK ( RLEN SLEN -- ) - 3 ALLOT \ STACK - 4 HERE 00FF AND 0FE = - 5 IF 1 ALLOT THEN \ 6502-ALIGN - 6 UP@ HERE 100 CMOVE \ INIT USER AREA - 7 HERE 04C C, \ JMP OPCODE TO SLEEP TASK - 8 UP@ 1+ @ , - 9 DUP UP@ 1+ ! \ LINK TASK -10 3 ALLOT \ ALLOT JSR WAKE -11 DUP 6 - DUP , , \ SSAVE AND S0 -12 2DUP + , \ HERE + RLEN = R0 -13 UNDER + HERE - 2+ ALLOT ['] TASKERROR OVER -14 [ ' ERRORHANDLER >BODY C@ ] LITERAL + ! CONSTANT ; -15 -Screen 6 not modified - 0 \ MORE TASKS KS/BP 26APR85RE) - 1 - 2 : RENDEZVOUS ( SEMAPHORADR -) DUP UNLOCK PAUSE LOCK ; - 3 - 4 | : STATESMART STATE @ IF [COMPILE] LITERAL THEN ; - 5 - 6 : 'S ( TADR - ADR.OF.TASKUSERVAR) - 7 ' >BODY C@ + STATESMART ; IMMEDIATE - 8 - 9 \ SYNTAX: 2 DEMOTASK 'S BASE ! \ MAKES DEMOTASK WORKING BINARY -10 -11 : TASKS ( -) ." MAIN " CR UP@ DUP 1+ @ -12 BEGIN 2DUP - WHILE -13 DUP [ ' R0 >BODY C@ ] LITERAL + @ 6 + NAME> >NAME .NAME -14 DUP C@ 04C = IF ." SLEEPING" THEN CR 1+ @ REPEAT 2DROP ; -15 -Screen 7 not modified - 0 \ TASKDEMO 27APR85RE) - 1 : TASKMARK ; - 2 - 3 VARIABLE COUNTER COUNTER OFF - 4 - 5 100 100 TASK BACKGROUND - 6 - 7 : >COUNT ( N -) BACKGROUND 1 PASS COUNTER ! - 8 BEGIN COUNTER @ DUP 1- COUNTER ! ?DUP - 9 WHILE PAUSE 0 <# #S #> type REPEAT stop ; -10 -11 : WAIT BACKGROUND SLEEP ; -12 -13 : GO BACKGROUND WAKE ; -14 -15 -Screen 8 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/Apple1/tasker.fth b/sources/Apple1/tasker.fth new file mode 100644 index 0000000..2f70960 --- /dev/null +++ b/sources/Apple1/tasker.fth @@ -0,0 +1,170 @@ +\ *** Block No. 0 Hexblock 0 +\ Multitasking Extension to volksFORTH cas 26jan06 + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Tasker Loadscreen + +\NEEDS CODE abort( Assembler needed ) +hex + 1 5 +thru \ load Tasker + 7 load \ Task-Demo +decimal + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ MULTITASKER BP 13.9.84 ) + +CODE STOP + SP 2DEC IP LDA SP X) STA IP 1+ LDA SP )Y STA + SP 2DEC RP LDA SP X) STA RP 1+ LDA SP )Y STA + 6 # LDY SP LDA UP )Y STA INY SP 1+ LDA UP )Y STA + 1 # LDY TYA CLC UP ADC W STA + TXA UP 1+ ADC W 1+ STA W 1- JMP END-CODE + +| CREATE TASKPAUSE ASSEMBLER + 2C # LDA UP X) STA ' STOP @ JMP END-CODE + +: SINGLETASK [ ' PAUSE @ ] LITERAL ['] PAUSE ! ; + +: MULTITASK TASKPAUSE ['] PAUSE ! ; + +\ *** Block No. 3 Hexblock 3 +\ PASS ACTIVATE KS 8 MAY 84 ) + +: PASS ( N0 .. NR-1 TADR R -- ) + BEGIN [ ROT ( TRICK ! ) ] + SWAP 02C OVER C! \ AWAKE TASK + R> -ROT \ IP R ADDR + 8 + >R \ S0 OF TASK + R@ 2+ @ SWAP \ IP R0 R + 2+ 2* \ BYTES ON TASKSTACK + \ INCL. R0 & IP + R@ @ OVER - \ NEW SP + DUP R> 2- ! \ INTO SSAVE + SWAP BOUNDS ?DO I ! 2 +LOOP ; RESTRICT + + + +\ *** Block No. 4 Hexblock 4 +\ + +: ACTIVATE ( TADR --) + 0 [ -ROT ( TRICK ! ) ] REPEAT ; -2 ALLOT RESTRICT + +: SLEEP ( TADR --) 4C SWAP C! ; \ JMP-OPCODE + +: WAKE ( TADR --) 2C SWAP C! ; \ BIT-OPCODE + +| : TASKERROR ( STRING -) + STANDARDI/O SINGLETASK ." TASK ERROR : " COUNT TYPE + MULTITASK STOP ; + + + + +\ *** Block No. 5 Hexblock 5 +\ BUILDING A TASK BP 13.9.84 ) + +: TASK ( RLEN SLEN -- ) + ALLOT \ STACK + HERE 00FF AND 0FE = + IF 1 ALLOT THEN \ 6502-ALIGN + UP@ HERE 100 CMOVE \ INIT USER AREA + HERE 04C C, \ JMP OPCODE TO SLEEP TASK + UP@ 1+ @ , + DUP UP@ 1+ ! \ LINK TASK + 3 ALLOT \ ALLOT JSR WAKE + DUP 6 - DUP , , \ SSAVE AND S0 + 2DUP + , \ HERE + RLEN = R0 + UNDER + HERE - 2+ ALLOT ['] TASKERROR OVER + [ ' ERRORHANDLER >BODY C@ ] LITERAL + ! CONSTANT ; + +\ *** Block No. 6 Hexblock 6 +\ MORE TASKS KS/BP 26APR85RE) + +: RENDEZVOUS ( SEMAPHORADR -) DUP UNLOCK PAUSE LOCK ; + +| : STATESMART STATE @ IF [COMPILE] LITERAL THEN ; + +: 'S ( TADR - ADR.OF.TASKUSERVAR) + ' >BODY C@ + STATESMART ; IMMEDIATE + +\ SYNTAX: 2 DEMOTASK 'S BASE ! \ MAKES DEMOTASK WORKING BINARY + +: TASKS ( -) ." MAIN " CR UP@ DUP 1+ @ + BEGIN 2DUP - WHILE + DUP [ ' R0 >BODY C@ ] LITERAL + @ 6 + NAME> >NAME .NAME + DUP C@ 04C = IF ." SLEEPING" THEN CR 1+ @ REPEAT 2DROP ; + +\ *** Block No. 7 Hexblock 7 +\ TASKDEMO 27APR85RE) +: TASKMARK ; + +VARIABLE COUNTER COUNTER OFF + +100 100 TASK BACKGROUND + +: >COUNT ( N -) BACKGROUND 1 PASS COUNTER ! + BEGIN COUNTER @ DUP 1- COUNTER ! ?DUP + WHILE PAUSE 0 <# #S #> type REPEAT stop ; + +: WAIT BACKGROUND SLEEP ; + +: GO BACKGROUND WAKE ; + + +\ *** Block No. 8 Hexblock 8 + + + + + + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 + + + + + + + + + + + + + + + + diff --git a/sources/Apple1/tools.fb.src b/sources/Apple1/tools.fb.src deleted file mode 100644 index 416ffcb..0000000 --- a/sources/Apple1/tools.fb.src +++ /dev/null @@ -1,255 +0,0 @@ -Screen 0 not modified - 0 \ Development Tools cas 26jan06 - 1 - 2 Interactive Tracer - 3 - 4 One-Step Debugger - 5 - 6 Traps - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ TOOLS LOADSCREEN 22MAR85RE) - 1 - 2 ONLYFORTH - 3 - 4 \NEEDS CODE abort( Assembler is needed ) - 5 - 6 VOCABULARY TOOLS - 7 - 8 TOOLS ALSO DEFINITIONS - 9 hex -10 1 &11 +THRU -11 decimal -12 ONLYFORTH -13 -14 -15 -Screen 2 not modified - 0 \ HANDLE STEPS BP 10 02 85) - 1 - 2 ASSEMBLER ALSO DEFINITIONS - 3 - 4 ONLY FORTH ALSO TOOLS ALSO DEFINITIONS - 5 | VARIABLE (W | VARIABLE RPT - 6 - 7 | CODE STEP - 8 RPT DEC RP X) LDA IP STA - 9 RP )Y LDA IP 1+ STA RP 2INC -10 (W LDA W STA (W 1+ LDA W 1+ STA -11 W 1- JMP END-CODE -12 -13 | CREATE NEXTSTEP ] STEP [ -14 -15 -Screen 3 not modified - 0 \ THROW STATUS ON R-STACK B 23JUL85RE) - 1 - 2 | CREATE NPULL 0 ] - 3 RP@ COUNT 2DUP + RP! R> SWAP CMOVE ; - 4 - 5 : NPUSH ( ADDR LEN -) - 6 R> -ROT OVER >R RP@ OVER 1+ - DUP RP! PLACE - 7 NPULL >R >R ; - 8 - 9 | : ONELINE .STATUS SPACE QUERY INTERPRET -10 -82 ALLOT RDROP ( DELETE QUIT FROM TNEXT ) ; -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ TRAP AND DISPLAY KS 26MAR85RE) - 1 LABEL TNEXT - 2 IP 2INC RP LDA RPT CMP 0<> ?[ - 3 [[ W 1- JMP SWAP ]? - 4 RP 1+ LDA RPT 1+ CMP 0= ?] - 5 LABEL DOTRACE - 6 RPT INC ( DISABLE TRACER ) - 7 W LDA (W STA W 1+ LDA (W 1+ STA - 8 ;C: R@ NEXTSTEP >R - 9 INPUT PUSH KEYBOARD -10 OUTPUT PUSH DISPLAY -11 CR 2- DUP 4 U.R @ DUP 5 U.R 2 SPACES -12 >NAME .NAME 1C COL - 0 MAX SPACES .S -13 STATE PUSH BLK PUSH >IN PUSH -14 [ ' 'QUIT >BODY ] LITERAL PUSH -15 [ ' >INTERPRET >BODY ] LITERAL PUSH -Screen 5 not modified - 0 \ - 1 #TIB PUSH TIB #TIB @ NPUSH R0 PUSH - 2 RP@ R0 ! 082 ALLOT - 3 ['] ONELINE IS 'QUIT QUIT ; -2 ALLOT - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 \ TRACER COMMANDS BP 23JUL85RE) - 1 - 2 | CODE (TRACE TNEXT 0 100 M/MOD - 3 # LDA NEXT 0C + STA - 4 # LDA NEXT 0B + STA - 5 04C # LDA NEXT 0A + STA NEXT JMP END-CODE - 6 - 7 : TRACE' RP@ 2- RPT ! ' (TRACE EXECUTE END-TRACE ; - 8 - 9 : BREAK RP@ 2+ RPT ! (TRACE ; RESTRICT -10 -11 : TRACEL: CREATE , DOES> @ RPT +! ; -12 -13 -6 TRACEL: +DO 6 TRACEL: -DO -14 -2 TRACEL: +R 2 TRACEL: -R -15 -6 TRACEL: +PUSH 6 TRACEL: -PUSH -Screen 7 not modified - 0 \ WATCH TRAP BP 10 02 85 ) - 1 - 2 | VARIABLE WATCHPT 2 ALLOT - 3 - 4 LABEL WNEXT IP 2INC - 5 WATCHPT LDA N STA WATCHPT 1+ LDA N 1+ STA - 6 N X) LDA WATCHPT 2+ CMP 0<> ?[ - 7 [[ RP LDA RPT STA RP 1+ LDA RPT 1+ STA - 8 ( SET TO TNEXT) TNEXT 0 100 M/MOD - 9 # LDA NEXT 0C + STA # LDA NEXT 0B + STA -10 DOTRACE JMP SWAP ]? -11 N )Y LDA WATCHPT 3 + CMP 0= ?] W 1- JMP END-CODE -12 -13 -14 -15 -Screen 8 not modified - 0 \ WATCH COMMANDS BP 10 02 85 ) - 1 - 2 | CODE (WATCH WNEXT 0 100 M/MOD - 3 # LDA NEXT 0C + STA - 4 # LDA NEXT 0B + STA - 5 04C # LDA NEXT 0A + STA NEXT JMP END-CODE - 6 - 7 : WATCH' ( ADR -- ) - 8 DUP WATCHPT ! @ WATCHPT 2+ ! ' (WATCH EXECUTE END-TRACE ; - 9 -10 : CONT ( -) WATCHPT @ @ WATCHPT 2+ ! (WATCH ; -11 -12 ( SYNTAX : WATCH' ) -13 -14 -15 -Screen 9 not modified - 0 \ TOOLS FOR DECOMPILING, KS 4 APR 83 ) - 1 ( INTERACTIVE USE ) - 2 | : ?: DUP 4 U.R ." :" ; - 3 | : @? DUP @ 6 U.R ; - 4 | : C? DUP C@ 3 .R ; - 5 | : BL 024 COL - 0 MAX SPACES ; - 6 - 7 : S ( ADR - ADR+) ( PRINT LITERAL STRING) - 8 ?: SPACE C? 4 SPACES DUP COUNT TYPE - 9 DUP C@ + 1+ BL ; ( COUNT + RE) -10 -11 : N ( ADR - ADR+2) ( PRINT NAME OF NEXT WORD BY ITS CFA) -12 ?: @? 2 SPACES DUP @ >NAME .NAME 2+ BL ; -13 -14 : L ( ADR - ADR+2) ( PRINT LITERAL VALUE) ?: @? 2+ BL ; -15 -Screen 10 not modified - 0 \ TOOLS FOR DECOMPILING, INTERACTIVE ) - 1 - 2 : D ( ADR N - ADR+N) ( DUMP N BYTES) - 3 2DUP SWAP ?: 3 SPACES SWAP 0 DO C? 1+ LOOP - 4 4 SPACES -ROT TYPE BL ; - 5 - 6 : C ( ADR - ADR+1) ( PRINT BYTE AS UNSIGNED VALUE) 1 D ; - 7 - 8 : B ( ADR - ADR+2) ( PRINT BRANCH TARGET LOCATION ) - 9 ?: @? DUP @ OVER + 6 U.R 2+ BL ; -10 -11 ( USED FOR : ) -12 ( NAME STRING LITERAL DUMP CLIT BRANCH ) -13 ( - - - - - - ) -14 -15 -Screen 11 not modified - 0 \ DEBUGGING UTILITIES BP 19 02 85 ) - 1 - 2 : UNRAVEL \ UNRAVEL PERFORM (ABORT" - 3 RDROP RDROP RDROP CR ." TRACE DUMP IS " CR - 4 - 5 BEGIN RP@ R0 @ - - 6 WHILE R> DUP 8 U.R SPACE 2- @ >NAME .NAME CR - 7 REPEAT (ERROR ; - 8 - 9 ' UNRAVEL ERRORHANDLER ! -10 -11 -12 -13 -14 -15 -Screen 12 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 14 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/Apple1/tools.fth b/sources/Apple1/tools.fth new file mode 100644 index 0000000..8459e2d --- /dev/null +++ b/sources/Apple1/tools.fth @@ -0,0 +1,255 @@ +\ *** Block No. 0 Hexblock 0 +\ Development Tools cas 26jan06 + +Interactive Tracer + +One-Step Debugger + +Traps + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ TOOLS LOADSCREEN 22MAR85RE) + +ONLYFORTH + +\NEEDS CODE abort( Assembler is needed ) + +VOCABULARY TOOLS + +TOOLS ALSO DEFINITIONS +hex +1 &11 +THRU +decimal +ONLYFORTH + + + +\ *** Block No. 2 Hexblock 2 +\ HANDLE STEPS BP 10 02 85) + +ASSEMBLER ALSO DEFINITIONS + +ONLY FORTH ALSO TOOLS ALSO DEFINITIONS +| VARIABLE (W | VARIABLE RPT + +| CODE STEP + RPT DEC RP X) LDA IP STA + RP )Y LDA IP 1+ STA RP 2INC + (W LDA W STA (W 1+ LDA W 1+ STA + W 1- JMP END-CODE + +| CREATE NEXTSTEP ] STEP [ + + +\ *** Block No. 3 Hexblock 3 +\ THROW STATUS ON R-STACK B 23JUL85RE) + +| CREATE NPULL 0 ] + RP@ COUNT 2DUP + RP! R> SWAP CMOVE ; + +: NPUSH ( ADDR LEN -) + R> -ROT OVER >R RP@ OVER 1+ - DUP RP! PLACE + NPULL >R >R ; + +| : ONELINE .STATUS SPACE QUERY INTERPRET + -82 ALLOT RDROP ( DELETE QUIT FROM TNEXT ) ; + + + + + +\ *** Block No. 4 Hexblock 4 +\ TRAP AND DISPLAY KS 26MAR85RE) +LABEL TNEXT + IP 2INC RP LDA RPT CMP 0<> ?[ + [[ W 1- JMP SWAP ]? + RP 1+ LDA RPT 1+ CMP 0= ?] +LABEL DOTRACE + RPT INC ( DISABLE TRACER ) + W LDA (W STA W 1+ LDA (W 1+ STA + ;C: R@ NEXTSTEP >R + INPUT PUSH KEYBOARD + OUTPUT PUSH DISPLAY + CR 2- DUP 4 U.R @ DUP 5 U.R 2 SPACES + >NAME .NAME 1C COL - 0 MAX SPACES .S + STATE PUSH BLK PUSH >IN PUSH + [ ' 'QUIT >BODY ] LITERAL PUSH + [ ' >INTERPRET >BODY ] LITERAL PUSH +\ *** Block No. 5 Hexblock 5 +\ + #TIB PUSH TIB #TIB @ NPUSH R0 PUSH + RP@ R0 ! 082 ALLOT + ['] ONELINE IS 'QUIT QUIT ; -2 ALLOT + + + + + + + + + + + + +\ *** Block No. 6 Hexblock 6 +\ TRACER COMMANDS BP 23JUL85RE) + +| CODE (TRACE TNEXT 0 100 M/MOD + # LDA NEXT 0C + STA + # LDA NEXT 0B + STA + 04C # LDA NEXT 0A + STA NEXT JMP END-CODE + +: TRACE' RP@ 2- RPT ! ' (TRACE EXECUTE END-TRACE ; + +: BREAK RP@ 2+ RPT ! (TRACE ; RESTRICT + +: TRACEL: CREATE , DOES> @ RPT +! ; + +-6 TRACEL: +DO 6 TRACEL: -DO +-2 TRACEL: +R 2 TRACEL: -R +-6 TRACEL: +PUSH 6 TRACEL: -PUSH +\ *** Block No. 7 Hexblock 7 +\ WATCH TRAP BP 10 02 85 ) + +| VARIABLE WATCHPT 2 ALLOT + +LABEL WNEXT IP 2INC + WATCHPT LDA N STA WATCHPT 1+ LDA N 1+ STA + N X) LDA WATCHPT 2+ CMP 0<> ?[ + [[ RP LDA RPT STA RP 1+ LDA RPT 1+ STA + ( SET TO TNEXT) TNEXT 0 100 M/MOD + # LDA NEXT 0C + STA # LDA NEXT 0B + STA + DOTRACE JMP SWAP ]? + N )Y LDA WATCHPT 3 + CMP 0= ?] W 1- JMP END-CODE + + + + +\ *** Block No. 8 Hexblock 8 +\ WATCH COMMANDS BP 10 02 85 ) + +| CODE (WATCH WNEXT 0 100 M/MOD + # LDA NEXT 0C + STA + # LDA NEXT 0B + STA + 04C # LDA NEXT 0A + STA NEXT JMP END-CODE + +: WATCH' ( ADR -- ) + DUP WATCHPT ! @ WATCHPT 2+ ! ' (WATCH EXECUTE END-TRACE ; + +: CONT ( -) WATCHPT @ @ WATCHPT 2+ ! (WATCH ; + +( SYNTAX : WATCH' ) + + + +\ *** Block No. 9 Hexblock 9 +\ TOOLS FOR DECOMPILING, KS 4 APR 83 ) +( INTERACTIVE USE ) +| : ?: DUP 4 U.R ." :" ; +| : @? DUP @ 6 U.R ; +| : C? DUP C@ 3 .R ; +| : BL 024 COL - 0 MAX SPACES ; + +: S ( ADR - ADR+) ( PRINT LITERAL STRING) + ?: SPACE C? 4 SPACES DUP COUNT TYPE + DUP C@ + 1+ BL ; ( COUNT + RE) + +: N ( ADR - ADR+2) ( PRINT NAME OF NEXT WORD BY ITS CFA) + ?: @? 2 SPACES DUP @ >NAME .NAME 2+ BL ; + +: L ( ADR - ADR+2) ( PRINT LITERAL VALUE) ?: @? 2+ BL ; + +\ *** Block No. 10 Hexblock A +\ TOOLS FOR DECOMPILING, INTERACTIVE ) + +: D ( ADR N - ADR+N) ( DUMP N BYTES) + 2DUP SWAP ?: 3 SPACES SWAP 0 DO C? 1+ LOOP + 4 SPACES -ROT TYPE BL ; + +: C ( ADR - ADR+1) ( PRINT BYTE AS UNSIGNED VALUE) 1 D ; + +: B ( ADR - ADR+2) ( PRINT BRANCH TARGET LOCATION ) + ?: @? DUP @ OVER + 6 U.R 2+ BL ; + +( USED FOR : ) +( NAME STRING LITERAL DUMP CLIT BRANCH ) +( - - - - - - ) + + +\ *** Block No. 11 Hexblock B +\ DEBUGGING UTILITIES BP 19 02 85 ) + +: UNRAVEL \ UNRAVEL PERFORM (ABORT" + RDROP RDROP RDROP CR ." TRACE DUMP IS " CR + + BEGIN RP@ R0 @ - + WHILE R> DUP 8 U.R SPACE 2- @ >NAME .NAME CR + REPEAT (ERROR ; + +' UNRAVEL ERRORHANDLER ! + + + + + + +\ *** Block No. 12 Hexblock C + + + + + + + + + + + + + + + + +\ *** Block No. 13 Hexblock D + + + + + + + + + + + + + + + + +\ *** Block No. 14 Hexblock E + + + + + + + + + + + + + + + + diff --git a/sources/AtariST/ALLOCATE.FB.src b/sources/AtariST/ALLOCATE.FB.src deleted file mode 100644 index 9de5a9b..0000000 --- a/sources/AtariST/ALLOCATE.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \\ *** Allocate *** 12oct86we - 1 - 2 Dieses File enth„lt die Betriebssystemroutinen, mit denen man - 3 RAM-Speicher beim Betriebssystem an- und abmelden kann. - 4 - 5 MALLOC erwartet die - doppelt genaue - Anzahl der zu reservie- - 6 renden Bytes und gibt die Langadresse des allokierten Speicher- - 7 bereichs zurck. Wenn nicht genug Speicherplatz zur Verfgung - 8 steht, wird der Befehl abgebrochen. - 9 -10 MFREE gibt den Speicher ab laddr wieder frei. Bei Fehlern wird -11 der Befehl abgebrochen. -12 -13 -14 -15 -Screen 1 not modified - 0 \ malloc mfree 16oct86we - 1 - 2 Code malloc ( d -- laddr ) - 3 .l SP ) A7 -) move .w $48 # A7 -) move 1 trap - 4 6 A7 addq .l D0 SP ) move - 5 ;c: 2dup or 0= abort" No more RAM" ; - 6 - 7 Code mfree ( laddr -- ) - 8 .l SP )+ A7 -) move .w $49 # A7 -) move 1 trap - 9 6 A7 addq .w D0 SP -) move ;c: abort" mfree Error!" ; -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/ALLOCATE.fth b/sources/AtariST/ALLOCATE.fth new file mode 100644 index 0000000..5fa81f6 --- /dev/null +++ b/sources/AtariST/ALLOCATE.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Allocate *** 12oct86we + +Dieses File enth„lt die Betriebssystemroutinen, mit denen man +RAM-Speicher beim Betriebssystem an- und abmelden kann. + +MALLOC erwartet die - doppelt genaue - Anzahl der zu reservie- + renden Bytes und gibt die Langadresse des allokierten Speicher- + bereichs zurck. Wenn nicht genug Speicherplatz zur Verfgung + steht, wird der Befehl abgebrochen. + +MFREE gibt den Speicher ab laddr wieder frei. Bei Fehlern wird + der Befehl abgebrochen. + + + + +\ *** Block No. 1 Hexblock 1 +\ malloc mfree 16oct86we + +Code malloc ( d -- laddr ) + .l SP ) A7 -) move .w $48 # A7 -) move 1 trap + 6 A7 addq .l D0 SP ) move + ;c: 2dup or 0= abort" No more RAM" ; + +Code mfree ( laddr -- ) + .l SP )+ A7 -) move .w $49 # A7 -) move 1 trap + 6 A7 addq .w D0 SP -) move ;c: abort" mfree Error!" ; + + + + + + diff --git a/sources/AtariST/ASSEMBLE.FB.src b/sources/AtariST/ASSEMBLE.FB.src deleted file mode 100644 index cbb4b67..0000000 --- a/sources/AtariST/ASSEMBLE.FB.src +++ /dev/null @@ -1,323 +0,0 @@ -Screen 0 not modified - 0 \\ *** Assembler *** 25may86we - 1 - 2 Dieses File enth„lt den 68000-Assembler fr volksFORTH-83. - 3 Der Assembler basiert auf dem von Michael Perry fr F83 entwik- - 4 kelten, enth„lt aber einige zus„tzliche Features. - 5 Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels - 6 verwendbar. Aus Geschwindigkeitsgrnden enth„lt der Assembler - 7 kaum Fehlerberprfung, es empfiehlt sich daher, nach getaner - 8 Tat die Code-Worte mit einem Disassembler zu berprfen. - 9 -10 Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten -11 Assembler auf den Heap laden kann, damit er w„hrend der Kompila- -12 tionszeit zur Verfgung steht, aber keinen Platz im Dictionary -13 verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt, -14 wenn er nicht mehr ben”tigt wird. -15 -Screen 1 not modified - 0 \ 68000 Assembler Load Screen 26oct86we - 1 - 2 Onlyforth - 3 Vocabulary Assembler Assembler also definitions - 4 - 5 : end-code context 2- @ context ! ; - 6 ' swap | Alias *swap - 7 - 8 base @ 4 $11 +thru base ! - 9 -10 : reg) size push .l 0 *swap FP DI) ; -11 : Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp -12 >here next-link @ , next-link ! ; -13 -14 2 3 +thru Onlyforth -15 -Screen 2 not modified - 0 \ Internal Assembler 09sep86we - 1 - 2 Onlyforth - 3 - 4 here - 5 $1300 hallot heap dp ! -1 +load - 6 dp ! - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ Extended adressing modes 09sep86we - 1 - 2 : R#) ( addr -- ) size push - 3 [ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg) - 4 [ Forth ] exit THEN .w FP D) ; - 5 - 6 - 7 | : inrange? ( addr -- offset f ) [ Forth ] - 8 >here 2+ - >here 0< IF dup $FFFE >here - < exit THEN - 9 dup >here negate > ; -10 : pcrel) ( addr -- ) \ pc-relativ adressing mode -11 inrange? [ Forth ] 0= abort" out of range" pcd) ; -12 -13 : ;c: 0 recover R#) jsr end-code ] ; -14 -15 -Screen 4 not modified - 0 \ Assembler Forth words 09sep86we - 1 Forth definitions - 2 : Assembler Assembler [ Assembler ] .w ; - 3 : Code Create here dup 2- ! Assembler ; - 4 - 5 | : (;code r> last @ name> ! ; - 6 : ;Code 0 ?pairs compile (;code [compile] [ reveal - 7 Assembler ; immediate restrict - 8 - 9 : >label ( addr -- ) here | Create swap , immediate -10 4 hallot >here 4- heap 4 cmove -11 heap last @ count $1F and + even ! dp ! -12 Does> ( -- addr ) @ -13 state @ IF [compile] Literal THEN ; -14 : Label [ Assembler ] >here [ Forth ] 1 and -15 [ Assembler ] >allot >here >label Assembler ; -Screen 5 not modified - 0 \ Code generating primitives 26oct86we - 1 - 2 Variable >codes - 3 | Create nrc ] c, , c@ here allot ! c! [ - 4 - 5 : nonrelocate nrc >codes ! ; nonrelocate - 6 - 7 | : >exec Create c, - 8 Does> c@ >codes @ + @ execute ; - 9 -10 | 0 >exec >c, | 2 >exec >, | 4 >exec >c@ -11 | 6 >exec >here | 8 >exec >allot | $0A >exec >! -12 | $0C >exec >c! -13 -14 -15 -Screen 6 not modified - 0 \ 68000 Meta Assembler 04sep86we - 1 - 2 | : ?, IF >, THEN >, ; - 3 | : 2, >, >, ; - 4 8 base ! - 5 Variable size - 6 : .b 10000 size ! ; - 7 : .w 30100 size ! ; .w - 8 : .l 24600 size ! ; - 9 -10 | : Sz Constant Does> @ size @ and or ; -11 00300 | Sz sz3 00400 | Sz sz4 -12 04000 | Sz sz40 30000 | Sz sz300 -13 -14 | : long? size @ 24600 = ; -15 | : -sz1 long? IF 100 or THEN ; -Screen 7 not modified - 0 \ addressing modes 09sep86we - 1 - 2 | : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ; - 3 | : Mode Constant Does> @ *swap 7007 and or ; - 4 0000 Regs D0 D1 D2 D3 D4 D5 D6 D7 - 5 0110 Regs A0 A1 A2 A3 A4 A5 A6 A7 - 6 0220 Mode ) \ address register indirect - 7 0330 Mode )+ \ adr reg ind post-increment - 8 0440 Mode -) \ adr reg ind pre-decrement - 9 0550 Mode D) \ adr reg ind displaced -10 0660 Mode (DI) \ adr reg ind displaced indexed s.u. -11 0770 Constant #) \ immediate address -12 1771 Constant L#) \ immediate long address -13 2772 Constant pcD) \ pc relative displaced -14 3773 Constant (pcDI) \ pc relative displaced indexed -15 4774 Constant # \ immediate data -Screen 8 not modified - 0 \ fields and register assignments 08sep86we - 1 - 2 | : Field Constant Does> @ and ; - 3 7000 | Field rd 0007 | Field rs - 4 0070 | Field ms 0077 | Field eas - 5 0377 | Field low - 6 | : dn? ( ea -- ea flag ) dup ms 0= ; - 7 | : src ( ea instr -- ea instr' ) over eas or ; - 8 | : dst ( ea instr -- ea instr' ) *swap rd or ; - 9 -10 | : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ; -11 | : ??an ( mod -- mod ) dup ms 1 = -12 abort" needs Adress-Register" ; -13 -14 A6 Constant SP A5 Constant RP A4 Constant IP -15 A3 Constant FP -Screen 9 not modified - 0 \ extended addressing 09sep86we - 1 : DI) (DI) size @ *swap ; - 2 : pcDI) (pcDI) size @ *swap ; - 3 - 4 | : double? ( mode -- flag) dup L#) = *swap - 5 # = long? and or ; - 6 | : index? ( {n} mode -- {m} mode ) - 7 dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or - 8 IF size @ >r size ! - 9 dup rd 10 * *swap ms IF 100000 or THEN -10 sz40 *swap low or r> size ! -11 THEN r> ; -12 -13 | : more? ( ea -- ea flag ) dup ms 0040 > ; -14 | : ,more ( ea -- ) more? -15 IF index? double? ?, ELSE drop THEN ; -Screen 10 not modified - 0 \ extended addressing extras 09sep86we - 1 - 2 | Create extra here 5 dup allot erase \ temporary storage area - 3 - 4 | : extra? ( {n} mode -- mode ) more? - 5 IF >r r@ index? double? extra 1+ *swap - 6 IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r> - 7 ELSE 0 extra ! - 8 THEN ; - 9 -10 | : ,extra ( -- ) extra c@ ?dup -11 IF extra 1+ *swap 1 = -12 IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase -13 THEN ; -14 -15 -Screen 11 not modified - 0 \ immediates & address register specific 15jan86we - 1 | : Imm Constant Does> @ >r extra? eas r> or - 2 sz3 >, long? ?, ,extra ; ( n ea) - 3 0000 Imm ori 1000 Imm andi - 4 2000 Imm subi 3000 Imm addi - 5 5000 Imm eori 6000 Imm cmpi - 6 | : Immsr Constant Does> @ sz3 2, ; ( n ) - 7 001074 Immsr andi>sr - 8 005074 Immsr eori>sr - 9 000074 Immsr ori>sr -10 | : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or -11 r> or sz3 >, ,extra ; ( n ea ) -12 050000 Iq addq 050400 Iq subq -13 | : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an ) -14 150300 Ieaa adda 130300 Ieaa cmpa -15 040700 Ieaa lea 110300 Ieaa suba -Screen 12 not modified - 0 \ shifts, rotates, and bit manipulation 15jan86we - 1 | : Isr Constant Does> @ >r dn? - 2 IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN - 3 rd *swap rs or r> or 160000 or sz3 >, - 4 ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or - 5 160000 or >, ,more - 6 THEN ; ( dm dn ) ( m # dn ) ( ea ) - 7 400 Isr asl 000 Isr asr - 8 410 Isr lsl 010 Isr lsr - 9 420 Isr roxl 020 Isr roxr -10 430 Isr rol 030 Isr ror -11 | : Ibit Constant does> @ >r extra? dn? -12 IF rd src 400 ELSE drop dup eas 4000 THEN -13 or r> or >, ,extra ,more ; ( ea dn ) ( ea n # ) -14 000 Ibit btst 100 Ibit bchg -15 200 Ibit bclr 300 Ibit bset -Screen 13 not modified - 0 \ branch, loop, and set conditionals 15jan86we - 1 - 2 | : Setclass ' *swap 0 DO I over execute LOOP drop ; - 3 | : Ibra 400 * 060000 or Constant ( label ) - 4 Does> @ *swap >here 2+ - dup abs 200 < - 5 IF low or >, ELSE *swap 2, THEN ; - 6 20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq - 7 bvc bvs bpl bmi bge blt bgt ble - 8 | : Idbr 400 * 050310 or Constant ( label \ dn - ) - 9 Does> @ *swap rs or >, >here - >, ; -10 20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq -11 dbvc dbvs dbpl dbmi dbge dblt dbgt dble -12 | : Iset 400 * 050300 or Constant ( ea ) -13 Does> @ src >, ,more ; -14 20 Setclass Iset set sno shi sls scc scs sne seq -15 svc svs spl smi sge slt sgt sle -Screen 14 not modified - 0 \ moves 15jan86we - 1 - 2 : move extra? 7700 and src sz300 >, - 3 ,more ,extra ; ( ea ea ) - 4 : moveq ??dn rd *swap low or 070000 or >, ; ( n dn ) - 5 : move>usp ??an rs 047140 or >, ; ( an ) - 6 : move, ; ( an ) - 7 : movem> - 8 extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea ) - 9 : movem< -10 extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea ) -11 : movep dn? IF rd *swap rs or 410 or -12 ELSE rs rot rd or 610 or THEN -sz1 2, ; -13 ( dm d an ) ( d an dm ) -14 : lmove 7700 and *swap eas or 20000 or >, ; -15 ( long reg move ) -Screen 15 not modified - 0 \ odds and ends 15jan86we - 1 - 2 : cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ ) - 3 : exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r - 4 ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap - 5 THEN rs dst r> or >, ; ( rn rm ) - 6 : ext ??dn rs 044200 or -sz1 >, ; ( dn ) - 7 : swap ??dn rs 044100 or >, ; ( dn ) - 8 : stop 47162 2, ; ( n ) - 9 : trap 17 and 47100 or >, ; ( n ) -10 : link ??an rs 047120 or 2, ; ( n an ) -11 : unlk ??an rs 047130 or >, ; ( an ) -12 : eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea ) -13 : cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn ) -14 -15 -Screen 16 not modified - 0 \ arithmetic and logic 15jan86we - 1 | : Ibcd Constant Does> @ dst over rs or *swap ms - 2 IF 10 or THEN >, ; ( dn dm ) ( an@- am@- ) - 3 140400 Ibcd abcd 100400 Ibcd sbcd - 4 | : Idd Constant Does> @ dst over rs or *swap ms - 5 IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- ) - 6 150400 Idd addx 110400 Idd subx - 7 | : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea ) - 8 IF rd src r> or sz3 >, ,more - 9 ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ; -10 150000 Idea add 110000 Idea sub -11 140000 Idea and 100000 Idea or -12 | : Iead Constant Does> @ >r ??dn r> dst src -13 >, ,more ; ( ea dn) -14 040600 Iead chk 100300 Iead divu 100700 Iead divs -15 140300 Iead mulu 140700 Iead muls -Screen 17 not modified - 0 \ arithmetic and control 15jan86we - 1 - 2 | : Iea Constant Does> @ src >, ,more ; ( ea ) - 3 047200 Iea jsr 047300 Iea jmp - 4 042300 Iea move>ccr - 5 040300 Iea movesr - 6 044000 Iea nbcd 044100 Iea pea - 7 045300 Iea tas - 8 | : Ieas Constant Does> @ src sz3 >, ,more ; ( ea ) - 9 041000 Ieas clr 043000 Ieas not -10 042000 Ieas neg 040000 Ieas negx -11 045000 Ieas tst -12 | : Icon Constant Does> @ >, ; -13 47160 Icon reset 47161 Icon nop -14 47163 Icon rte 47165 Icon rts -15 47166 Icon trapv 47167 Icon rtr -Screen 18 not modified - 0 \ structured conditionals +/- 256 bytes 15jan86we - 1 : THEN >here over 2+ - *swap 1+ >c! ; - 2 : IF >, >here 2- ; hex - 3 : ELSE 6000 IF *swap THEN ; - 4 : BEGIN >here ; - 5 : UNTIL >, >here - >here 1- >c! ; - 6 : AGAIN 6000 UNTIL ; - 7 : WHILE IF *swap ; - 8 : REPEAT AGAIN THEN ; - 9 : DO >here *swap ; -10 : LOOP dbra ; -11 6600 Constant 0= 6700 Constant 0<> -12 6A00 Constant 0< 6B00 Constant 0>= -13 6C00 Constant < 6D00 Constant >= -14 6E00 Constant <= 6F00 Constant > -15 6500 Constant CC 6400 Constant CS diff --git a/sources/AtariST/ASSEMBLE.fth b/sources/AtariST/ASSEMBLE.fth new file mode 100644 index 0000000..d52fb7e --- /dev/null +++ b/sources/AtariST/ASSEMBLE.fth @@ -0,0 +1,323 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Assembler *** 25may86we + +Dieses File enth„lt den 68000-Assembler fr volksFORTH-83. +Der Assembler basiert auf dem von Michael Perry fr F83 entwik- +kelten, enth„lt aber einige zus„tzliche Features. +Wegen der Heap-Struktur im volksFORTH sind z.B. echte Labels +verwendbar. Aus Geschwindigkeitsgrnden enth„lt der Assembler +kaum Fehlerberprfung, es empfiehlt sich daher, nach getaner +Tat die Code-Worte mit einem Disassembler zu berprfen. + +Screen $11 enth„lt einen Loadscreen, mit dem man der kompletten +Assembler auf den Heap laden kann, damit er w„hrend der Kompila- +tionszeit zur Verfgung steht, aber keinen Platz im Dictionary +verbraucht. Mit CLEAR oder SAVE wird der Assembler entfernt, +wenn er nicht mehr ben”tigt wird. + +\ *** Block No. 1 Hexblock 1 +\ 68000 Assembler Load Screen 26oct86we + +Onlyforth +Vocabulary Assembler Assembler also definitions + +: end-code context 2- @ context ! ; +' swap | Alias *swap + +base @ 4 $11 +thru base ! + +: reg) size push .l 0 *swap FP DI) ; +: Next .w IP )+ D7 move D7 reg) D6 move D6 reg) jmp + >here next-link @ , next-link ! ; + +2 3 +thru Onlyforth + +\ *** Block No. 2 Hexblock 2 +\ Internal Assembler 09sep86we + +Onlyforth + +here + $1300 hallot heap dp ! -1 +load +dp ! + + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ Extended adressing modes 09sep86we + +: R#) ( addr -- ) size push + [ Forth ] dup 0< IF [ Assembler ] .w # D6 move D6 reg) + [ Forth ] exit THEN .w FP D) ; + + +| : inrange? ( addr -- offset f ) [ Forth ] + >here 2+ - >here 0< IF dup $FFFE >here - < exit THEN + dup >here negate > ; +: pcrel) ( addr -- ) \ pc-relativ adressing mode + inrange? [ Forth ] 0= abort" out of range" pcd) ; + +: ;c: 0 recover R#) jsr end-code ] ; + + +\ *** Block No. 4 Hexblock 4 +\ Assembler Forth words 09sep86we +Forth definitions +: Assembler Assembler [ Assembler ] .w ; +: Code Create here dup 2- ! Assembler ; + +| : (;code r> last @ name> ! ; +: ;Code 0 ?pairs compile (;code [compile] [ reveal + Assembler ; immediate restrict + +: >label ( addr -- ) here | Create swap , immediate + 4 hallot >here 4- heap 4 cmove + heap last @ count $1F and + even ! dp ! + Does> ( -- addr ) @ + state @ IF [compile] Literal THEN ; +: Label [ Assembler ] >here [ Forth ] 1 and + [ Assembler ] >allot >here >label Assembler ; +\ *** Block No. 5 Hexblock 5 +\ Code generating primitives 26oct86we + +Variable >codes +| Create nrc ] c, , c@ here allot ! c! [ + +: nonrelocate nrc >codes ! ; nonrelocate + +| : >exec Create c, + Does> c@ >codes @ + @ execute ; + +| 0 >exec >c, | 2 >exec >, | 4 >exec >c@ +| 6 >exec >here | 8 >exec >allot | $0A >exec >! +| $0C >exec >c! + + + +\ *** Block No. 6 Hexblock 6 +\ 68000 Meta Assembler 04sep86we + +| : ?, IF >, THEN >, ; +| : 2, >, >, ; +8 base ! +Variable size +: .b 10000 size ! ; +: .w 30100 size ! ; .w +: .l 24600 size ! ; + +| : Sz Constant Does> @ size @ and or ; +00300 | Sz sz3 00400 | Sz sz4 +04000 | Sz sz40 30000 | Sz sz300 + +| : long? size @ 24600 = ; +| : -sz1 long? IF 100 or THEN ; +\ *** Block No. 7 Hexblock 7 +\ addressing modes 09sep86we + +| : Regs 10 0 DO dup 1001 I * or Constant LOOP drop ; +| : Mode Constant Does> @ *swap 7007 and or ; +0000 Regs D0 D1 D2 D3 D4 D5 D6 D7 +0110 Regs A0 A1 A2 A3 A4 A5 A6 A7 +0220 Mode ) \ address register indirect +0330 Mode )+ \ adr reg ind post-increment +0440 Mode -) \ adr reg ind pre-decrement +0550 Mode D) \ adr reg ind displaced +0660 Mode (DI) \ adr reg ind displaced indexed s.u. +0770 Constant #) \ immediate address +1771 Constant L#) \ immediate long address +2772 Constant pcD) \ pc relative displaced +3773 Constant (pcDI) \ pc relative displaced indexed +4774 Constant # \ immediate data +\ *** Block No. 8 Hexblock 8 +\ fields and register assignments 08sep86we + +| : Field Constant Does> @ and ; +7000 | Field rd 0007 | Field rs +0070 | Field ms 0077 | Field eas +0377 | Field low +| : dn? ( ea -- ea flag ) dup ms 0= ; +| : src ( ea instr -- ea instr' ) over eas or ; +| : dst ( ea instr -- ea instr' ) *swap rd or ; + +| : ??dn ( mod -- mod ) dn? 0= abort" needs Data-Register" ; +| : ??an ( mod -- mod ) dup ms 1 = + abort" needs Adress-Register" ; + +A6 Constant SP A5 Constant RP A4 Constant IP +A3 Constant FP +\ *** Block No. 9 Hexblock 9 +\ extended addressing 09sep86we +: DI) (DI) size @ *swap ; +: pcDI) (pcDI) size @ *swap ; + +| : double? ( mode -- flag) dup L#) = *swap + # = long? and or ; +| : index? ( {n} mode -- {m} mode ) + dup >r dup 0770 and A0 (DI) = *swap (pcDI) = or + IF size @ >r size ! + dup rd 10 * *swap ms IF 100000 or THEN + sz40 *swap low or r> size ! + THEN r> ; + +| : more? ( ea -- ea flag ) dup ms 0040 > ; +| : ,more ( ea -- ) more? + IF index? double? ?, ELSE drop THEN ; +\ *** Block No. 10 Hexblock A +\ extended addressing extras 09sep86we + +| Create extra here 5 dup allot erase \ temporary storage area + +| : extra? ( {n} mode -- mode ) more? + IF >r r@ index? double? extra 1+ *swap + IF under ! 2+ ! 2 ELSE ! 1 THEN extra c! r> + ELSE 0 extra ! + THEN ; + +| : ,extra ( -- ) extra c@ ?dup + IF extra 1+ *swap 1 = + IF @ >, ELSE dup 2+ @ *swap @ 2, THEN extra 5 erase + THEN ; + + +\ *** Block No. 11 Hexblock B +\ immediates & address register specific 15jan86we +| : Imm Constant Does> @ >r extra? eas r> or + sz3 >, long? ?, ,extra ; ( n ea) +0000 Imm ori 1000 Imm andi +2000 Imm subi 3000 Imm addi +5000 Imm eori 6000 Imm cmpi +| : Immsr Constant Does> @ sz3 2, ; ( n ) +001074 Immsr andi>sr +005074 Immsr eori>sr +000074 Immsr ori>sr +| : Iq Constant Does> @ >r extra? eas *swap rs 1000 * or + r> or sz3 >, ,extra ; ( n ea ) +050000 Iq addq 050400 Iq subq +| : Ieaa Constant Does> @ dst src sz4 >, ,more ; ( ea an ) +150300 Ieaa adda 130300 Ieaa cmpa +040700 Ieaa lea 110300 Ieaa suba +\ *** Block No. 12 Hexblock C +\ shifts, rotates, and bit manipulation 15jan86we +| : Isr Constant Does> @ >r dn? + IF *swap dn? IF r> 40 or >r ELSE drop *swap 1000 * THEN + rd *swap rs or r> or 160000 or sz3 >, + ELSE dup eas 300 or r@ 400 and or r> 70 and 100 * or + 160000 or >, ,more + THEN ; ( dm dn ) ( m # dn ) ( ea ) +400 Isr asl 000 Isr asr +410 Isr lsl 010 Isr lsr +420 Isr roxl 020 Isr roxr +430 Isr rol 030 Isr ror +| : Ibit Constant does> @ >r extra? dn? + IF rd src 400 ELSE drop dup eas 4000 THEN + or r> or >, ,extra ,more ; ( ea dn ) ( ea n # ) +000 Ibit btst 100 Ibit bchg +200 Ibit bclr 300 Ibit bset +\ *** Block No. 13 Hexblock D +\ branch, loop, and set conditionals 15jan86we + +| : Setclass ' *swap 0 DO I over execute LOOP drop ; +| : Ibra 400 * 060000 or Constant ( label ) + Does> @ *swap >here 2+ - dup abs 200 < + IF low or >, ELSE *swap 2, THEN ; +20 Setclass Ibra bra bsr bhi bls bcc bcs bne beq + bvc bvs bpl bmi bge blt bgt ble +| : Idbr 400 * 050310 or Constant ( label \ dn - ) + Does> @ *swap rs or >, >here - >, ; +20 Setclass Idbr dxit dbra dbhi dbls dbcc dbcs dbne dbeq + dbvc dbvs dbpl dbmi dbge dblt dbgt dble +| : Iset 400 * 050300 or Constant ( ea ) + Does> @ src >, ,more ; +20 Setclass Iset set sno shi sls scc scs sne seq + svc svs spl smi sge slt sgt sle +\ *** Block No. 14 Hexblock E +\ moves 15jan86we + +: move extra? 7700 and src sz300 >, + ,more ,extra ; ( ea ea ) +: moveq ??dn rd *swap low or 070000 or >, ; ( n dn ) +: move>usp ??an rs 047140 or >, ; ( an ) +: move, ; ( an ) +: movem> + extra? eas 044200 or -sz1 >, >, ,extra ; ( n ea ) +: movem< + extra? eas 046200 or -sz1 >, >, ,extra ; ( n ea ) +: movep dn? IF rd *swap rs or 410 or + ELSE rs rot rd or 610 or THEN -sz1 2, ; + ( dm d an ) ( d an dm ) +: lmove 7700 and *swap eas or 20000 or >, ; + ( long reg move ) +\ *** Block No. 15 Hexblock F +\ odds and ends 15jan86we + +: cmpm rd *swap rs or 130410 or sz3 >, ; ( an@+ am@+ ) +: exg dn? IF *swap dn? IF 140500 ELSE 140610 THEN >r + ELSE *swap dn? IF 140610 ELSE 140510 THEN >r *swap + THEN rs dst r> or >, ; ( rn rm ) +: ext ??dn rs 044200 or -sz1 >, ; ( dn ) +: swap ??dn rs 044100 or >, ; ( dn ) +: stop 47162 2, ; ( n ) +: trap 17 and 47100 or >, ; ( n ) +: link ??an rs 047120 or 2, ; ( n an ) +: unlk ??an rs 047130 or >, ; ( an ) +: eor extra? eas dst sz3 130400 or >, ,extra ; ( dn ea ) +: cmp ??dn 130000 dst src sz3 >, ,more ; ( ea dn ) + + +\ *** Block No. 16 Hexblock 10 +\ arithmetic and logic 15jan86we +| : Ibcd Constant Does> @ dst over rs or *swap ms + IF 10 or THEN >, ; ( dn dm ) ( an@- am@- ) +140400 Ibcd abcd 100400 Ibcd sbcd +| : Idd Constant Does> @ dst over rs or *swap ms + IF 10 or THEN sz3 >, ; ( dn dm ) ( an@- am@- ) +150400 Idd addx 110400 Idd subx +| : Idea Constant Does> @ >r dn? ( ea dn ) ( dn ea ) + IF rd src r> or sz3 >, ,more + ELSE extra? eas dst 400 or r> or sz3 >, ,extra THEN ; +150000 Idea add 110000 Idea sub +140000 Idea and 100000 Idea or +| : Iead Constant Does> @ >r ??dn r> dst src + >, ,more ; ( ea dn) +040600 Iead chk 100300 Iead divu 100700 Iead divs +140300 Iead mulu 140700 Iead muls +\ *** Block No. 17 Hexblock 11 +\ arithmetic and control 15jan86we + +| : Iea Constant Does> @ src >, ,more ; ( ea ) +047200 Iea jsr 047300 Iea jmp +042300 Iea move>ccr +040300 Iea movesr +044000 Iea nbcd 044100 Iea pea +045300 Iea tas +| : Ieas Constant Does> @ src sz3 >, ,more ; ( ea ) +041000 Ieas clr 043000 Ieas not +042000 Ieas neg 040000 Ieas negx +045000 Ieas tst +| : Icon Constant Does> @ >, ; +47160 Icon reset 47161 Icon nop +47163 Icon rte 47165 Icon rts +47166 Icon trapv 47167 Icon rtr +\ *** Block No. 18 Hexblock 12 +\ structured conditionals +/- 256 bytes 15jan86we +: THEN >here over 2+ - *swap 1+ >c! ; +: IF >, >here 2- ; hex +: ELSE 6000 IF *swap THEN ; +: BEGIN >here ; +: UNTIL >, >here - >here 1- >c! ; +: AGAIN 6000 UNTIL ; +: WHILE IF *swap ; +: REPEAT AGAIN THEN ; +: DO >here *swap ; +: LOOP dbra ; +6600 Constant 0= 6700 Constant 0<> +6A00 Constant 0< 6B00 Constant 0>= +6C00 Constant < 6D00 Constant >= +6E00 Constant <= 6F00 Constant > +6500 Constant CC 6400 Constant CS diff --git a/sources/AtariST/C.FB.src b/sources/AtariST/C.FB.src deleted file mode 100644 index ab798bf..0000000 --- a/sources/AtariST/C.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 ( Target compiler commands for volksForth Atari ST/TTcas20130105 - 1 - 2 include c.fb to build a new volksforth kernel named - 3 "4thimg.prg" - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 ( load screen for target compilation ) - 1 - 2 include assemble.fb ( load assembler ) - 3 include target.fb ( load target compiler ) - 4 include forth83.fb ( compile volksForth from source ) - 5 - 6 save-target 4thimg.prg ( save the new minimal image ) - 7 - 8 .( Done ) - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/C.fth b/sources/AtariST/C.fth new file mode 100644 index 0000000..227b981 --- /dev/null +++ b/sources/AtariST/C.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +( Target compiler commands for volksForth Atari ST/TTcas20130105 + +include c.fb to build a new volksforth kernel named +"4thimg.prg" + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +( load screen for target compilation ) + +include assemble.fb ( load assembler ) +include target.fb ( load target compiler ) +include forth83.fb ( compile volksForth from source ) + +save-target 4thimg.prg ( save the new minimal image ) + +.( Done ) + + + + + + + diff --git a/sources/AtariST/CROSTARG.FB.src b/sources/AtariST/CROSTARG.FB.src deleted file mode 100644 index 7f88377..0000000 --- a/sources/AtariST/CROSTARG.FB.src +++ /dev/null @@ -1,680 +0,0 @@ -Screen 0 not modified - 0 \\ *** volksFORTH-84 Target-Compiler *** - 1 - 2 Mit dem Target-Compiler l„žt sich ein neues System aus dem - 3 Quelltext FORTH_83.SCR 'hochziehen'. - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Target compiler loadscr 09sep86we - 1 \ Idea and first Implementation by ks/bp - 2 \ Implemented on 6502 by ks/bp - 3 \ ultraFORTH83-Version by bp/we - 4 \ Atari 520 ST - Version by we - 5 Onlyforth Assembler nonrelocate - 6 07 Constant imagepage \ Virtual memory bank - 7 Vocabulary Ttools - 8 Vocabulary Defining - 9 : .stat .blk .s ; ' .stat Is .status -10 \ : 65( [compile] ( ; immediate -11 : 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte| -12 1 $14 +thru \ Target compiler -13 $15 $17 +thru \ Target Tools -14 $18 $1A +thru \ Redefinitions -15 save $1B $25 +thru \ Predefinitions -Screen 2 not modified - 0 \ Target header pointers bp05mar86we - 1 - 2 Variable tdp : there tdp @ ; - 3 Variable displace - 4 Variable ?thead 0 ?thead ! - 5 Variable tlast 0 tlast ! - 6 Variable glast' 0 glast' ! - 7 Variable tdoes> - 8 Variable >in: - 9 Variable tvoc 0 tvoc ! -10 Variable tvoc-link 0 tvoc-link ! -11 Variable tnext-link 0 tnext-link ! -12 Variable tdodo -13 Variable tfile-link 0 tfile-link ! -14 -15 : c+! ( 8b addr -- ) dup c@ rot + swap c! ; -Screen 3 not modified - 0 \ Image and byteorder 15sep86we - 1 - 2 : >image ( addr1 - addr2 ) displace @ - ; - 3 - 4 : >heap ( from quan - ) - 5 heap over - 1 and + \ 68000-align - 6 dup hallot heap swap cmove ; - 7 - 8 \ : >ascii 2drop ; ' noop Alias C64>ascii - 9 -10 Code Lc@ ( laddr -- 8b ) -11 .l SP )+ A0 move .w D0 clr .b A0 ) D0 move -12 .w D0 SP -) move Next end-code -13 Code Lc! ( 8b addr -- ) -14 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move -15 Next end-code -Screen 4 not modified - 0 \ Ghost-creating 05mar86we - 1 - 2 0 | Constant 0 | Constant - 3 - 4 | : Make.ghost ( - cfa.ghost ) - 5 here dup 1 and allot here - 6 state @ IF context @ ELSE current THEN @ - 7 dup @ , name - 8 dup c@ 1 $1F uwithin not abort" inval.Gname" - 9 dup c@ 1+ over c! -10 c@ dup 1+ allot 1 and 0= IF bl c, THEN -11 here 2 pick - -rot -12 , 0 , 0 , -13 swap here over - >heap -14 heap swap ! swap dp ! -15 heap + ; -Screen 5 not modified - 0 \ ghost words 05mar86we - 1 - 2 : gfind ( string - cfa tf / string ff ) - 3 dup count + 1+ bl swap c! - 4 dup >r 1 over c+! find -1 r> c+! ; - 5 - 6 : ghost ( - cfa ) - 7 >in @ name gfind IF nip exit THEN - 8 drop >in ! Make.ghost ; - 9 -10 : Word, ghost execute ; -11 -12 : gdoes> ( cfa.ghost - cfa.does ) -13 4+ dup @ IF @ exit THEN -14 here dup , 0 , 4 >heap -15 dp ! heap dup rot ! ; -Screen 6 not modified - 0 \ ghost utilities 04dec85we - 1 - 2 : g' name gfind 0= abort" ?" ; - 3 - 4 : '. - 5 g' dup @ case? - 6 IF ." forw" ELSE - abort" ??" ." res" THEN - 7 2+ dup @ 5 u.r - 8 2+ @ ?dup - 9 IF dup @ case? -10 IF ." fdef" ELSE - abort" ??" ." rdef" THEN -11 2+ @ 5 u.r THEN ; -12 -13 ' ' Alias h' -14 -15 -Screen 7 not modified - 0 \ .unresolved 05mar86we - 1 - 2 | : forward? ( cfa - cfa / exit&true ) - 3 dup @ = over 2+ @ and IF drop true rdrop exit THEN ; - 4 - 5 | : unresolved? ( addr - f ) - 6 2+ dup c@ $1F and over + c@ BL = - 7 IF name> forward? 4+ @ dup IF forward? THEN - 8 THEN drop false ; - 9 -10 | : unresolved-words -11 BEGIN @ ?dup WHILE dup unresolved? -12 IF dup 2+ .name ?cr THEN REPEAT ; -13 -14 : .unresolved voc-link @ -15 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; -Screen 8 not modified - 0 \ Extending Vocabularys for Target-Compilation 05mar86we - 1 - 2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; - 3 - 4 Vocabulary Transient 0 tvoc ! - 5 - 6 Only definitions Forth also - 7 - 8 : T Transient ; immediate - 9 : H Forth ; immediate -10 -11 definitions -12 -13 -14 -15 -Screen 9 not modified - 0 \ Transient primitives 05mar86we - 1 Code byte> ( 8bh 8bl -- 16b ) - 2 SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move - 3 .w D0 SP ) move Next end-code - 4 Code >byte ( 16b -- 8bl 8bh ) - 5 SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr - 6 D0 SP -) move D1 SP -) move Next end-code - 7 Transient definitions - 8 : c@ H >image imagepage lc@ ; - 9 : c! H >image imagepage lc! ; -10 : @ dup T c@ swap 1+ T c@ 65( swap ) byte> ; -11 : ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ; -12 : cmove ( from.mem to.target quan -) -13 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; -14 : place ( addr len to --) -15 over >r rot over 1+ r> T cmove c! H ; -Screen 10 not modified - 0 \ Transient primitives bp05mar86we - 1 - 2 : here there ; - 3 : allot Tdp +! ; - 4 : c, T here c! 1 allot H ; - 5 : , T here ! 2 allot H ; - 6 - 7 : ," Ascii " parse dup T c, - 8 under there swap cmove - 9 .( dup 1 and 0= IF 1+ THEN ) allot H ; -10 -11 : fill ( addr quan 8b -) -12 -rot bounds ?DO dup I T c! H LOOP drop ; -13 : erase 0 T fill ; -14 : blank bl T fill ; -15 : here! H Tdp ! ; -Screen 11 not modified - 0 \ Resolving 08dec85we - 1 Forth definitions - 2 : resolve ( cfa.ghost cfa.target -) - 3 over dup @ = - 4 IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN - 5 >r >r 2+ @ ?dup - 6 IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! - 7 H ?dup 0= UNTIL - 8 THEN r> r> over ! 2+ ! ; - 9 -10 : resdoes> ( cfa.ghost cfa.target -) -11 swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; -12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ; -13 ' >body ! -14 ] Does> [ here 4- 0 ] @ T , H ; -15 ' >body ! -Screen 12 not modified - 0 \ move-threads 68000-align 13jun86we - 1 - 2 : move-threads Tvoc @ Tvoc-link @ - 3 BEGIN over ?dup - 4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT - 5 error" some undef. Target-Vocs left" drop ; - 6 - 7 | : tlatest ( - addr) current @ 6 + ; - 8 - 9 \\ -10 wird fuer 6502 nicht gebraucht -11 -12 | : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ; -13 -14 -15 -Screen 13 not modified - 0 \ save-target 09sep86we - 1 - 2 Dos definitions - 3 - 4 Code (filewrite ( buff len handle -- n) - 5 SP )+ D0 move .l D2 clr .w SP )+ D2 move - 6 .l 0 imagepage # D1 move .w SP )+ D1 move - 7 .l D1 A7 -) move \ buffer adress - 8 .l D2 A7 -) move \ buffer length - 9 .w D0 A7 -) move \ handle -10 $40 # A7 -) move \ call WRITE -11 1 trap $0C # A7 adda -12 .w D0 SP -) move Next end-code Forth definitions -13 -14 -15 -Screen 14 not modified - 0 \ save Target-System 09sep86we - 1 - 2 : save-target [ Dos ] - 3 bl word count dup 0= abort" missing filename" - 4 over + off (createfile dup >r 0< abort" no device " - 5 T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header - 6 0 there r@ (filewrite there - abort" write error" - 7 r> (closefile 0< abort" close error" ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ 8086-ALIGN - 1 - 2 : even ( addr -- addr1 ) ; immediate - 3 : align ( -- ) ; immediate - 4 : halign ( -- ) ; immediate - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \\ Create Variable ks 19 m„r 88 - 1 - 2 Defer makeview ' 0 Is makeview - 3 - 4 : Create align here makeview , current @ @ , - 5 name c@ dup 1 $20 uwithin not Abort" invalid name" - 6 here last ! 1+ allot align ?exists - 7 ?head @ IF 1 ?head +! dup , \ Pointer to Code - 8 halign heapmove $20 flag! dup dp ! - 9 THEN drop reveal 0 , -10 ;Code ( -- addr ) D push 2 W D) D lea Next end-code -11 -12 : Variable Create 0 , ; -13 -14 -15 -Screen 17 not modified - 0 \ compiling names into targ. 05mar86we - 1 - 2 : (theader - 3 ?thead @ IF 1 ?thead +! - 4 .( there $FF and $FF = IF 1 T allot H THEN ) exit THEN - 5 >in @ name swap >in ! - 6 dup c@ 1 $20 uwithin not abort" inval. Tname" - 7 .( dup c@ 3 + there + $FF and $FF = - 8 there 2+ $FF and $FF = or IF 1 T allot H THEN ) - 9 blk @ T , H there tlatest dup @ T , H ! there dup tlast ! -10 over c@ 1+ .( even ) dup T allot cmove H ; -11 -12 : Theader tlast off -13 (theader Ghost dup glast' ! -14 there resolve ; -15 -Screen 18 not modified - 0 \ prebuild defining words bp27jun85we - 1 - 2 | : executable? ( adr - adr f ) dup ; - 3 | : tpfa, there , ; - 4 | : (prebuild ( cfa.adr -- ) - 5 >in @ Create >in ! here 2- ! ; - 6 - 7 : prebuild ( adr 0.from.: - 0 ) - 8 0 ?pairs executable? dup >r - 9 IF [compile] Literal compile (prebuild ELSE drop THEN -10 compile Theader Ghost gdoes> , -11 r> IF compile tpfa, THEN 0 ; immediate restrict -12 -13 -14 -15 -Screen 19 not modified - 0 \ code portion of def.words bp11sep86we - 1 - 2 : dummy 0 ; - 3 - 4 : DO> ( - adr.of.jmp.dodoes> 0 ) - 5 [compile] Does> here 4- compile @ 0 ] ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 20 not modified - 0 \ the 68000 Assembler 11sep86we - 1 - 2 Forth definitions - 3 | Create relocate ] T c, , c@ here allot ! c! H [ - 4 - 5 Transient definitions - 6 - 7 : Assembler H [ Tassembler ] relocate >codes ! - 8 Tassembler ; - 9 : >label ( 16b -) H >in @ name gfind rot >in ! -10 IF over resolve dup THEN drop Constant ; -11 : Label T .( here 1 and allot ) here >label Assembler H ; -12 : Code H Theader there 2+ T , Assembler H ; -13 -14 -15 -Screen 21 not modified - 0 \ immed. restr. ' \ compile bp05mar86we - 1 - 2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ; - 3 : >mark ( - addr ) H there T 0 , H ; - 4 : >resolve ( addr - ) H there over - swap T ! H ; - 5 : - cfa ) H g' dup @ - abort" ?" 2+ @ ; -12 : | H ?thead @ ?exit ?thead on ; -13 : compile H Ghost , ; immediate restrict -14 -15 -Screen 22 not modified - 0 \ Target tools ks05mar86we - 1 - 2 Onlyforth Ttools also definitions - 3 - 4 | : ttype ( adr n -) bounds ?DO I T c@ H dup - 5 bl > IF emit ELSE drop Ascii . emit THEN LOOP ; - 6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype - 7 ELSE ." ??? " THEN space ?cr ; - 8 | : nfa? ( cfa lfa - nfa / cfa ff) - 9 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) = -10 IF 2+ nip exit THEN -11 T @ H REPEAT ; -12 : >name ( cfa - nfa / ff) -13 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup -14 IF nip exit THEN -15 swap REPEAT nip ; -Screen 23 not modified - 0 \ Ttools for decompiling ks05mar86we - 1 - 2 | : ?: dup 4 u.r ." :" ; - 3 | : @? dup T @ H 6 u.r ; - 4 | : c? dup T c@ H 3 .r ; - 5 - 6 : s ( addr - addr+ ) ?: space c? 3 spaces - 7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ; - 8 - 9 : n ( addr - addr+2 ) ?: @? 2 spaces -10 dup T @ H [ Ttools ] >name .name H 2+ ; -11 -12 : d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP -13 2 spaces -rot ttype ; -14 -15 -Screen 24 not modified - 0 \ Tools for decompiling bp05mar86we - 1 - 2 : l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ; - 3 - 4 : c ( addr -- addr+1 ) 1 d ; - 5 - 6 : b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ; - 7 - 8 : dump ( adr n -) bounds ?DO cr I $10 d drop - 9 stop? IF LEAVE THEN $10 +LOOP ; -10 -11 : view T ' H [ Ttools ] >name ?dup -12 IF 4- T @ H l THEN ; -13 -14 -15 -Screen 25 not modified - 0 \ reinterpretation def.-words 05mar86we - 1 - 2 Onlyforth - 3 - 4 : redefinition - 5 tdoes> @ IF >in push [ ' >interpret >body ] Literal push - 6 state push context push >in: @ >in ! - 7 name [ ' Transient 2+ ] Literal (find nip 0= - 8 IF cr ." Redefinition: " here .name - 9 >in: @ >in ! : Defining interpret THEN -10 THEN 0 tdoes> ! ; -11 -12 -13 -14 -15 -Screen 26 not modified - 0 \ Create..does> structure bp05mar86we - 1 - 2 | : (;tcode - 3 Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ; - 4 | : changecfa compile lit tdoes> @ , compile (;tcode ; - 5 - 6 Defining definitions - 7 - 8 : ;code 0 ?pairs changecfa reveal rdrop ; - 9 immediate restrict -10 -11 Defining ' ;code Alias does> immediate restrict -12 -13 : ; [compile] ; rdrop ; immediate restrict -14 -15 -Screen 27 not modified - 0 \ redefinition conditionals bp27jun85we - 1 - 2 ' DO Alias DO immediate restrict - 3 ' ?DO Alias ?DO immediate restrict - 4 ' LOOP Alias LOOP immediate restrict - 5 ' IF Alias IF immediate restrict - 6 ' THEN Alias THEN immediate restrict - 7 ' ELSE Alias ELSE immediate restrict - 8 ' BEGIN Alias BEGIN immediate restrict - 9 ' UNTIL Alias UNTIL immediate restrict -10 ' WHILE Alias WHILE immediate restrict -11 ' REPEAT Alias REPEAT immediate restrict -12 -13 -14 -15 -Screen 28 not modified - 0 \ clear Liter. Ascii ['] ." bp05mar86we - 1 - 2 Onlyforth Transient definitions - 3 - 4 : clear true abort" There are ghosts" ; - 5 - 6 : Literal ( 16b -- ) - 7 dup $FF00 and IF T compile lit , H exit THEN - 8 T compile clit c, H ; immediate restrict - 9 -10 : Ascii H bl word 1+ c@ state @ -11 IF T [compile] Literal H THEN ; immediate -12 : ['] T ' [compile] Literal H ; immediate restrict -13 : " T compile (" ," align H ; immediate restrict -14 : ." T compile (." ," align H ; immediate restrict -15 -Screen 29 not modified - 0 \ Target compilation ] [ bp05mar86we - 1 - 2 Forth definitions - 3 - 4 : tcompile - 5 ?stack >in @ name find ?dup - 6 IF 0> IF nip execute >interpret THEN - 7 drop dup >in ! name - 8 THEN gfind IF nip execute >interpret THEN - 9 nullstring? IF drop exit THEN -10 number? ?dup IF 0> IF swap T [compile] Literal THEN -11 [compile] Literal H drop >interpret THEN -12 drop >in ! Word, >interpret ; -13 -14 Transient definitions -15 : ] H state on ['] tcompile is >interpret ; -Screen 30 not modified - 0 \ Target conditionals bp05mar86we - 1 - 2 : IF T compile ?branch >mark H 1 ; immediate restrict - 3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict - 4 : ELSE T 1 ?pairs compile branch >mark swap >resolve - 5 H -1 ; immediate restrict - 6 : BEGIN T mark -2 H 2swap ; - 8 immediate restrict - 9 | : (repeat T 2 ?pairs resolve H REPEAT ; -11 : UNTIL T compile ?branch (repeat H ; immediate restrict -12 : REPEAT T compile branch (repeat H ; immediate restrict -13 -14 -15 -Screen 31 not modified - 0 \ Target conditionals bp27jun85we - 1 - 2 : DO T compile (do >mark H 3 ; immediate restrict - 3 : ?DO T compile (?do >mark H 3 ; immediate restrict - 4 : LOOP T 3 ?pairs compile (loop compile endloop - 5 >resolve H ; immediate restrict - 6 : +LOOP T 3 ?pairs compile (+loop compile endloop - 7 >resolve H ; immediate restrict - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 32 not modified - 0 \ predefinitions bp05mar86we - 1 - 2 : abort" T compile (abort" ," H ; immediate - 3 : error" T compile (error" ," H ; immediate - 4 - 5 Forth definitions - 6 - 7 Variable torigin - 8 Variable tudp 0 Tudp ! - 9 -10 : >user T c@ H torigin @ + ; -11 -12 : >udefer T @ H torigin @ + ; -13 -14 -15 -Screen 33 not modified - 0 \ Datatypes bp05mar86we - 1 - 2 Transient definitions - 3 : origin! H torigin ! ; - 4 : user' ( -- n ) T ' >body c@ H ; - 5 : uallot ( n -- ) H tudp @ swap tudp +! ; - 6 - 7 DO> >user ; - 8 : User prebuild User 2 T uallot c, ; - 9 -10 DO> ; -11 : Create prebuild Create ; -12 -13 DO> T @ H ; -14 : Constant prebuild Constant T , ; -15 : Variable Create 2 T allot ; -Screen 34 not modified - 0 \ Datatypes bp05mar86we - 1 - 2 dummy - 3 : Vocabulary - 4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , - 5 here H tvoc-link @ T , H tvoc-link ! ; - 6 - 7 : off ( tadr -- ) H false swap T ! H ; - 8 - 9 : on ( tadr -- ) H true swap T ! H ; -10 -11 Forth definitions -12 : Fcbytes ( n1 len -- n2 ) Create over H c, + Does> c@ + ; -13 -14 -15 -Screen 35 not modified - 0 \ File >file ks 23 m„r 88 - 1 &30 Constant tfnamelen \ default length in FCB - 2 \ first field for file-link - 3 2 1 Fcbytes tf.no \ must be first field - 4 2 Fcbytes tf.handle - 5 2 Fcbytes tf.date - 6 2 Fcbytes tf.time - 7 4 Fcbytes tf.size - 8 tfnamelen Fcbytes tf.name Constant tb/fcb - 9 Transient definitions -10 dummy -11 : File H >in @ >r prebuild File H tfile-link @ -12 there tfile-link ! T , H -13 there [ tb/fcb 2 - ] Literal dup T allot erase H -14 tfile-link @ dup T @ H tf.no T c@ H 1+ over tf.no T c! -15 H r> >in ! name count $1F and rot tf.name T place ; -Screen 36 not modified - 0 \ target defining words bp08sep86we - 1 \ Do> ; - 2 \ : Defer prebuild Defer 2 T allot ; - 3 \ : Is T ' H >body state @ IF T compile (is , H - 4 \ ELSE T ! H THEN ; immediate - 5 Do> ; - 6 : Defer prebuild Defer 2 T uallot , ; - 7 : Is T ' H >body state @ IF T compile (is T @ , H - 8 ELSE >udefer T ! H THEN ; immediate - 9 | : dodoes> T compile (;code H Glast' @ -10 there resdoes> there tdoes> ! ; -11 : ;code 0 T ?pairs dodoes> Assembler H [compile] [ -12 redefinition ; immediate restrict -13 -14 : does> T dodoes> $E9 C, \ JMP Code -15 H tdodo @ there 2+ - T , H ; immediate restrict -Screen 37 not modified - 0 \ : Alias ; bp25mar86we - 1 - 2 : Create: T Create H current @ context ! T ] H 0 ; - 3 - 4 dummy - 5 : : H tdoes> off >in @ >in: ! T prebuild : - 6 H current @ context ! T ] H 0 ; - 7 - 8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve - 9 tlast @ T c@ H $20 or tlast @ T c! , H ; -10 -11 : ; T 0 ?pairs compile unnest -12 [compile] [ H redefinition ; immediate restrict -13 -14 -15 -Screen 38 not modified - 0 \ predefinitions bp11sep86we - 1 - 2 : compile T compile compile H ; immediate restrict - 3 : Host H Onlyforth Ttools also ; - 4 : Compiler T Host H Transient also definitions ; - 5 : [compile] H Word, ; immediate restrict - 6 : Onlypatch H there 3 - 0 tdoes> ! 0 ; - 7 - 8 Onlyforth - 9 : Target Onlyforth Transient also definitions ; -10 -11 Transient definitions -12 Ghost c, drop -13 -14 -15 -Screen 39 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/CROSTARG.fth b/sources/AtariST/CROSTARG.fth new file mode 100644 index 0000000..214ec47 --- /dev/null +++ b/sources/AtariST/CROSTARG.fth @@ -0,0 +1,680 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** volksFORTH-84 Target-Compiler *** + +Mit dem Target-Compiler l„žt sich ein neues System aus dem +Quelltext FORTH_83.SCR 'hochziehen'. + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Target compiler loadscr 09sep86we +\ Idea and first Implementation by ks/bp +\ Implemented on 6502 by ks/bp +\ ultraFORTH83-Version by bp/we +\ Atari 520 ST - Version by we +Onlyforth Assembler nonrelocate +07 Constant imagepage \ Virtual memory bank +Vocabulary Ttools +Vocabulary Defining +: .stat .blk .s ; ' .stat Is .status +\ : 65( [compile] ( ; immediate +: 65( ; immediate : ) ; immediate \ cpu-addressing|lbyte|hbyte| + 1 $14 +thru \ Target compiler +$15 $17 +thru \ Target Tools +$18 $1A +thru \ Redefinitions +save $1B $25 +thru \ Predefinitions +\ *** Block No. 2 Hexblock 2 +\ Target header pointers bp05mar86we + +Variable tdp : there tdp @ ; +Variable displace +Variable ?thead 0 ?thead ! +Variable tlast 0 tlast ! +Variable glast' 0 glast' ! +Variable tdoes> +Variable >in: +Variable tvoc 0 tvoc ! +Variable tvoc-link 0 tvoc-link ! +Variable tnext-link 0 tnext-link ! +Variable tdodo +Variable tfile-link 0 tfile-link ! + +: c+! ( 8b addr -- ) dup c@ rot + swap c! ; +\ *** Block No. 3 Hexblock 3 +\ Image and byteorder 15sep86we + +: >image ( addr1 - addr2 ) displace @ - ; + +: >heap ( from quan - ) + heap over - 1 and + \ 68000-align + dup hallot heap swap cmove ; + +\ : >ascii 2drop ; ' noop Alias C64>ascii + +Code Lc@ ( laddr -- 8b ) +.l SP )+ A0 move .w D0 clr .b A0 ) D0 move +.w D0 SP -) move Next end-code +Code Lc! ( 8b addr -- ) +.l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move +Next end-code +\ *** Block No. 4 Hexblock 4 +\ Ghost-creating 05mar86we + +0 | Constant 0 | Constant + +| : Make.ghost ( - cfa.ghost ) + here dup 1 and allot here + state @ IF context @ ELSE current THEN @ + dup @ , name + dup c@ 1 $1F uwithin not abort" inval.Gname" + dup c@ 1+ over c! + c@ dup 1+ allot 1 and 0= IF bl c, THEN + here 2 pick - -rot + , 0 , 0 , + swap here over - >heap + heap swap ! swap dp ! + heap + ; +\ *** Block No. 5 Hexblock 5 +\ ghost words 05mar86we + +: gfind ( string - cfa tf / string ff ) + dup count + 1+ bl swap c! + dup >r 1 over c+! find -1 r> c+! ; + +: ghost ( - cfa ) + >in @ name gfind IF nip exit THEN + drop >in ! Make.ghost ; + +: Word, ghost execute ; + +: gdoes> ( cfa.ghost - cfa.does ) + 4+ dup @ IF @ exit THEN + here dup , 0 , 4 >heap + dp ! heap dup rot ! ; +\ *** Block No. 6 Hexblock 6 +\ ghost utilities 04dec85we + +: g' name gfind 0= abort" ?" ; + +: '. + g' dup @ case? + IF ." forw" ELSE - abort" ??" ." res" THEN + 2+ dup @ 5 u.r + 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + +' ' Alias h' + + +\ *** Block No. 7 Hexblock 7 +\ .unresolved 05mar86we + +| : forward? ( cfa - cfa / exit&true ) + dup @ = over 2+ @ and IF drop true rdrop exit THEN ; + +| : unresolved? ( addr - f ) + 2+ dup c@ $1F and over + c@ BL = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + +: .unresolved voc-link @ + BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; +\ *** Block No. 8 Hexblock 8 +\ Extending Vocabularys for Target-Compilation 05mar86we + +: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + +Vocabulary Transient 0 tvoc ! + +Only definitions Forth also + +: T Transient ; immediate +: H Forth ; immediate + +definitions + + + + +\ *** Block No. 9 Hexblock 9 +\ Transient primitives 05mar86we +Code byte> ( 8bh 8bl -- 16b ) + SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move + .w D0 SP ) move Next end-code +Code >byte ( 16b -- 8bl 8bh ) + SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr + D0 SP -) move D1 SP -) move Next end-code +Transient definitions +: c@ H >image imagepage lc@ ; +: c! H >image imagepage lc! ; +: @ dup T c@ swap 1+ T c@ 65( swap ) byte> ; +: ! >r >byte 65( swap ) r@ T c! r> 1+ T c! ; +: cmove ( from.mem to.target quan -) + bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; +: place ( addr len to --) + over >r rot over 1+ r> T cmove c! H ; +\ *** Block No. 10 Hexblock A +\ Transient primitives bp05mar86we + +: here there ; +: allot Tdp +! ; +: c, T here c! 1 allot H ; +: , T here ! 2 allot H ; + +: ," Ascii " parse dup T c, + under there swap cmove + .( dup 1 and 0= IF 1+ THEN ) allot H ; + +: fill ( addr quan 8b -) + -rot bounds ?DO dup I T c! H LOOP drop ; +: erase 0 T fill ; +: blank bl T fill ; +: here! H Tdp ! ; +\ *** Block No. 11 Hexblock B +\ Resolving 08dec85we +Forth definitions +: resolve ( cfa.ghost cfa.target -) + over dup @ = + IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN + >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! + H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + +: resdoes> ( cfa.ghost cfa.target -) + swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; +] Does> [ here 4- 0 ] dup @ there rot ! T , H ; +' >body ! +] Does> [ here 4- 0 ] @ T , H ; +' >body ! +\ *** Block No. 12 Hexblock C +\ move-threads 68000-align 13jun86we + +: move-threads Tvoc @ Tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + error" some undef. Target-Vocs left" drop ; + +| : tlatest ( - addr) current @ 6 + ; + +\\ +wird fuer 6502 nicht gebraucht + +| : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ; + + + +\ *** Block No. 13 Hexblock D +\ save-target 09sep86we + +Dos definitions + +Code (filewrite ( buff len handle -- n) + SP )+ D0 move .l D2 clr .w SP )+ D2 move + .l 0 imagepage # D1 move .w SP )+ D1 move + .l D1 A7 -) move \ buffer adress + .l D2 A7 -) move \ buffer length + .w D0 A7 -) move \ handle + $40 # A7 -) move \ call WRITE + 1 trap $0C # A7 adda + .w D0 SP -) move Next end-code Forth definitions + + + +\ *** Block No. 14 Hexblock E +\ save Target-System 09sep86we + +: save-target [ Dos ] + bl word count dup 0= abort" missing filename" + over + off (createfile dup >r 0< abort" no device " + T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header + 0 there r@ (filewrite there - abort" write error" + r> (closefile 0< abort" close error" ; + + + + + + + + +\ *** Block No. 15 Hexblock F +\ 8086-ALIGN + + : even ( addr -- addr1 ) ; immediate + : align ( -- ) ; immediate + : halign ( -- ) ; immediate + + + + + + + + + + + +\ *** Block No. 16 Hexblock 10 +\\ Create Variable ks 19 m„r 88 + + Defer makeview ' 0 Is makeview + + : Create align here makeview , current @ @ , + name c@ dup 1 $20 uwithin not Abort" invalid name" + here last ! 1+ allot align ?exists + ?head @ IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dup dp ! + THEN drop reveal 0 , + ;Code ( -- addr ) D push 2 W D) D lea Next end-code + + : Variable Create 0 , ; + + + +\ *** Block No. 17 Hexblock 11 +\ compiling names into targ. 05mar86we + +: (theader + ?thead @ IF 1 ?thead +! + .( there $FF and $FF = IF 1 T allot H THEN ) exit THEN + >in @ name swap >in ! + dup c@ 1 $20 uwithin not abort" inval. Tname" + .( dup c@ 3 + there + $FF and $FF = + there 2+ $FF and $FF = or IF 1 T allot H THEN ) + blk @ T , H there tlatest dup @ T , H ! there dup tlast ! + over c@ 1+ .( even ) dup T allot cmove H ; + +: Theader tlast off + (theader Ghost dup glast' ! + there resolve ; + +\ *** Block No. 18 Hexblock 12 +\ prebuild defining words bp27jun85we + +| : executable? ( adr - adr f ) dup ; +| : tpfa, there , ; +| : (prebuild ( cfa.adr -- ) + >in @ Create >in ! here 2- ! ; + +: prebuild ( adr 0.from.: - 0 ) + 0 ?pairs executable? dup >r + IF [compile] Literal compile (prebuild ELSE drop THEN + compile Theader Ghost gdoes> , + r> IF compile tpfa, THEN 0 ; immediate restrict + + + + +\ *** Block No. 19 Hexblock 13 +\ code portion of def.words bp11sep86we + +: dummy 0 ; + +: DO> ( - adr.of.jmp.dodoes> 0 ) + [compile] Does> here 4- compile @ 0 ] ; + + + + + + + + + + +\ *** Block No. 20 Hexblock 14 +\ the 68000 Assembler 11sep86we + +Forth definitions +| Create relocate ] T c, , c@ here allot ! c! H [ + +Transient definitions + +: Assembler H [ Tassembler ] relocate >codes ! + Tassembler ; +: >label ( 16b -) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; +: Label T .( here 1 and allot ) here >label Assembler H ; +: Code H Theader there 2+ T , Assembler H ; + + + +\ *** Block No. 21 Hexblock 15 +\ immed. restr. ' \ compile bp05mar86we + +: ?pairs ( n1 n2 -- ) H - abort" unstructured" ; +: >mark ( - addr ) H there T 0 , H ; +: >resolve ( addr - ) H there over - swap T ! H ; +: - cfa ) H g' dup @ - abort" ?" 2+ @ ; +: | H ?thead @ ?exit ?thead on ; +: compile H Ghost , ; immediate restrict + + +\ *** Block No. 22 Hexblock 16 +\ Target tools ks05mar86we + +Onlyforth Ttools also definitions + +| : ttype ( adr n -) bounds ?DO I T c@ H dup + bl > IF emit ELSE drop Ascii . emit THEN LOOP ; +: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype + ELSE ." ??? " THEN space ?cr ; +| : nfa? ( cfa lfa - nfa / cfa ff) + BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ .( even ) = + IF 2+ nip exit THEN + T @ H REPEAT ; +: >name ( cfa - nfa / ff) + Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup + IF nip exit THEN + swap REPEAT nip ; +\ *** Block No. 23 Hexblock 17 +\ Ttools for decompiling ks05mar86we + +| : ?: dup 4 u.r ." :" ; +| : @? dup T @ H 6 u.r ; +| : c? dup T c@ H 3 .r ; + +: s ( addr - addr+ ) ?: space c? 3 spaces + dup 1+ over T c@ H ttype dup T c@ H + 1+ ; + +: n ( addr - addr+2 ) ?: @? 2 spaces + dup T @ H [ Ttools ] >name .name H 2+ ; + +: d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP + 2 spaces -rot ttype ; + + +\ *** Block No. 24 Hexblock 18 +\ Tools for decompiling bp05mar86we + +: l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ; + +: c ( addr -- addr+1 ) 1 d ; + +: b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ; + +: dump ( adr n -) bounds ?DO cr I $10 d drop + stop? IF LEAVE THEN $10 +LOOP ; + +: view T ' H [ Ttools ] >name ?dup + IF 4- T @ H l THEN ; + + + +\ *** Block No. 25 Hexblock 19 +\ reinterpretation def.-words 05mar86we + +Onlyforth + +: redefinition + tdoes> @ IF >in push [ ' >interpret >body ] Literal push + state push context push >in: @ >in ! + name [ ' Transient 2+ ] Literal (find nip 0= + IF cr ." Redefinition: " here .name + >in: @ >in ! : Defining interpret THEN + THEN 0 tdoes> ! ; + + + + + +\ *** Block No. 26 Hexblock 1A +\ Create..does> structure bp05mar86we + +| : (;tcode + Tlast @ dup T c@ .( dup 1 and - ) 1+ + ! H rdrop ; +| : changecfa compile lit tdoes> @ , compile (;tcode ; + +Defining definitions + +: ;code 0 ?pairs changecfa reveal rdrop ; + immediate restrict + +Defining ' ;code Alias does> immediate restrict + +: ; [compile] ; rdrop ; immediate restrict + + +\ *** Block No. 27 Hexblock 1B +\ redefinition conditionals bp27jun85we + +' DO Alias DO immediate restrict +' ?DO Alias ?DO immediate restrict +' LOOP Alias LOOP immediate restrict +' IF Alias IF immediate restrict +' THEN Alias THEN immediate restrict +' ELSE Alias ELSE immediate restrict +' BEGIN Alias BEGIN immediate restrict +' UNTIL Alias UNTIL immediate restrict +' WHILE Alias WHILE immediate restrict +' REPEAT Alias REPEAT immediate restrict + + + + +\ *** Block No. 28 Hexblock 1C +\ clear Liter. Ascii ['] ." bp05mar86we + +Onlyforth Transient definitions + +: clear true abort" There are ghosts" ; + +: Literal ( 16b -- ) + dup $FF00 and IF T compile lit , H exit THEN + T compile clit c, H ; immediate restrict + +: Ascii H bl word 1+ c@ state @ + IF T [compile] Literal H THEN ; immediate +: ['] T ' [compile] Literal H ; immediate restrict +: " T compile (" ," align H ; immediate restrict +: ." T compile (." ," align H ; immediate restrict + +\ *** Block No. 29 Hexblock 1D +\ Target compilation ] [ bp05mar86we + +Forth definitions + +: tcompile + ?stack >in @ name find ?dup + IF 0> IF nip execute >interpret THEN + drop dup >in ! name + THEN gfind IF nip execute >interpret THEN + nullstring? IF drop exit THEN + number? ?dup IF 0> IF swap T [compile] Literal THEN + [compile] Literal H drop >interpret THEN + drop >in ! Word, >interpret ; + +Transient definitions +: ] H state on ['] tcompile is >interpret ; +\ *** Block No. 30 Hexblock 1E +\ Target conditionals bp05mar86we + +: IF T compile ?branch >mark H 1 ; immediate restrict +: THEN abs 1 T ?pairs >resolve H ; immediate restrict +: ELSE T 1 ?pairs compile branch >mark swap >resolve + H -1 ; immediate restrict +: BEGIN T mark -2 H 2swap ; + immediate restrict +| : (repeat T 2 ?pairs resolve H REPEAT ; +: UNTIL T compile ?branch (repeat H ; immediate restrict +: REPEAT T compile branch (repeat H ; immediate restrict + + + +\ *** Block No. 31 Hexblock 1F +\ Target conditionals bp27jun85we + +: DO T compile (do >mark H 3 ; immediate restrict +: ?DO T compile (?do >mark H 3 ; immediate restrict +: LOOP T 3 ?pairs compile (loop compile endloop + >resolve H ; immediate restrict +: +LOOP T 3 ?pairs compile (+loop compile endloop + >resolve H ; immediate restrict + + + + + + + + +\ *** Block No. 32 Hexblock 20 +\ predefinitions bp05mar86we + +: abort" T compile (abort" ," H ; immediate +: error" T compile (error" ," H ; immediate + +Forth definitions + +Variable torigin +Variable tudp 0 Tudp ! + +: >user T c@ H torigin @ + ; + +: >udefer T @ H torigin @ + ; + + + +\ *** Block No. 33 Hexblock 21 +\ Datatypes bp05mar86we + +Transient definitions +: origin! H torigin ! ; +: user' ( -- n ) T ' >body c@ H ; +: uallot ( n -- ) H tudp @ swap tudp +! ; + + DO> >user ; +: User prebuild User 2 T uallot c, ; + + DO> ; +: Create prebuild Create ; + + DO> T @ H ; +: Constant prebuild Constant T , ; +: Variable Create 2 T allot ; +\ *** Block No. 34 Hexblock 22 +\ Datatypes bp05mar86we + +dummy +: Vocabulary + H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , + here H tvoc-link @ T , H tvoc-link ! ; + +: off ( tadr -- ) H false swap T ! H ; + +: on ( tadr -- ) H true swap T ! H ; + +Forth definitions +: Fcbytes ( n1 len -- n2 ) Create over H c, + Does> c@ + ; + + + +\ *** Block No. 35 Hexblock 23 +\ File >file ks 23 m„r 88 + &30 Constant tfnamelen \ default length in FCB +\ first field for file-link +2 1 Fcbytes tf.no \ must be first field + 2 Fcbytes tf.handle + 2 Fcbytes tf.date + 2 Fcbytes tf.time + 4 Fcbytes tf.size + tfnamelen Fcbytes tf.name Constant tb/fcb +Transient definitions +dummy + : File H >in @ >r prebuild File H tfile-link @ + there tfile-link ! T , H + there [ tb/fcb 2 - ] Literal dup T allot erase H + tfile-link @ dup T @ H tf.no T c@ H 1+ over tf.no T c! + H r> >in ! name count $1F and rot tf.name T place ; +\ *** Block No. 36 Hexblock 24 +\ target defining words bp08sep86we +\ Do> ; +\ : Defer prebuild Defer 2 T allot ; +\ : Is T ' H >body state @ IF T compile (is , H +\ ELSE T ! H THEN ; immediate + Do> ; + : Defer prebuild Defer 2 T uallot , ; + : Is T ' H >body state @ IF T compile (is T @ , H + ELSE >udefer T ! H THEN ; immediate +| : dodoes> T compile (;code H Glast' @ + there resdoes> there tdoes> ! ; +: ;code 0 T ?pairs dodoes> Assembler H [compile] [ + redefinition ; immediate restrict + +: does> T dodoes> $E9 C, \ JMP Code + H tdodo @ there 2+ - T , H ; immediate restrict +\ *** Block No. 37 Hexblock 25 +\ : Alias ; bp25mar86we + +: Create: T Create H current @ context ! T ] H 0 ; + +dummy +: : H tdoes> off >in @ >in: ! T prebuild : + H current @ context ! T ] H 0 ; + +: Alias ( n -- ) H Tlast off (theader Ghost over resolve + tlast @ T c@ H $20 or tlast @ T c! , H ; + +: ; T 0 ?pairs compile unnest + [compile] [ H redefinition ; immediate restrict + + + +\ *** Block No. 38 Hexblock 26 +\ predefinitions bp11sep86we + +: compile T compile compile H ; immediate restrict +: Host H Onlyforth Ttools also ; +: Compiler T Host H Transient also definitions ; +: [compile] H Word, ; immediate restrict +: Onlypatch H there 3 - 0 tdoes> ! 0 ; + +Onlyforth +: Target Onlyforth Transient also definitions ; + +Transient definitions +Ghost c, drop + + + +\ *** Block No. 39 Hexblock 27 + + + + + + + + + + + + + + + + diff --git a/sources/AtariST/DEMO.FB.src b/sources/AtariST/DEMO.FB.src deleted file mode 100644 index 8280ffa..0000000 --- a/sources/AtariST/DEMO.FB.src +++ /dev/null @@ -1,255 +0,0 @@ -Screen 0 not modified - 0 \\ *** Graphic - Demonstrationen *** 26may86we - 1 - 2 Dieses File enth„lt einige Graphic-Demos, die von den Line-A - 3 Routinen Gebrauch machen. - 4 - 5 Hier bietet sich auch dem Anf„nger ein weites Feld fr eigene - 6 Versuche. Mit CHECKING ON kann man die gr”bsten Fehler abfan- - 7 gen, alledings auf Kosten der Geschwindigkeit. - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Demo Loadscreen 21sep86we - 1 - 2 \needs Graphics include line_a.scr - 3 - 4 Onlyforth Graphics also definitions - 5 1 &11 +thru - 6 - 7 moire - 8 kaleidos - 9 lines -10 boxes -11 rechtecke -12 rechtecke1 -13 -14 -15 -Screen 2 not modified - 0 \ patterns 18sep86we - 1 - 2 1 ?head ! - 3 : !pattern ( d -- ) Create , , ; - 4 - 5 $C000.C000 !pattern p1 $CCCC.3333 !pattern p2 - 6 $C0C0.3030 !pattern p3 $0303.0C0C !pattern p4 - 7 $C003.300C !pattern p5 $C3C3.3C3C !pattern p6 - 8 $FFFF.8001 !pattern p7 $40A0.8040 !pattern p8 - 9 $4444.0000 !pattern p9 $FFFF.2222 !pattern p10 -10 $4444.8282 !pattern p11 $8080.8888 !pattern p12 -11 $0000.1010 !pattern p13 $0101.8080 !pattern p14 -12 $7777.8888 !pattern p15 $7E7E.8181 !pattern p16 -13 $E640.FFFF !pattern p17 $3838.C6C6 !pattern p18 -14 -15 0 ?head ! -Screen 3 not modified - 0 \ patterns 21may86we - 1 - 2 Create patterns p1 , p2 , p3 , p4 , p5 , p6 , - 3 p7 , p8 , p9 , p10 , p11 , p12 , - 4 p13 , p14 , p15 , p16 , p17 , p18 , - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ diamonds 20sep86we - 1 - 2 | : yscale &400 &640 */ ; - 3 - 4 : diamond ( size -- ) - 5 >r cur_x @ cur_y @ - 6 2dup swap r@ - swap 2swap 2over set - 7 2dup r@ yscale - draw - 8 2dup swap r@ + swap draw - 9 2dup r> yscale + draw -10 2swap draw set ; -11 -12 : big_diamond 2 wr_mode ! -13 &319 0 &639 &200 &319 &399 0 &200 4 polygon ; -14 -15 -Screen 5 not modified - 0 \ some usefull definitions 20sep86we - 1 - 2 : overwrite 0 wr_mode ! ; - 3 : exorwrite 2 wr_mode ! ; - 4 - 5 | : home get_res scr_res ! 0 0 set ; - 6 | : center &320 &200 set ; - 7 - 8 | : wait BEGIN pause key? UNTIL &25 0 at - 9 getkey $FF and #esc = abort" stopped" ; -10 -11 | : logo &117 0 DO ." volksFORTH 83 " LOOP ; -12 -13 | : titel -14 &21 &24 at ." *** v o l k s F O R T H *** " -15 &22 &31 at ." Line-A Graphic " ; -Screen 6 not modified - 0 \ patterns example 18sep86we - 1 - 2 : muster - 3 page overwrite 1 pat_mask ! - 4 $10 0 DO patterns I 2* + @ pattern ! - 5 $10 I $10 * + dup $80 $80 rectangle LOOP - 6 6 pat_mask ! - 7 $10 0 DO patterns I 2* + @ pattern ! - 8 $110 I $10 * dup >r + $110 r> - $80 $80 rectangle LOOP - 9 1 pat_mask ! wait ; -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ kaleidoskop 20sep86we - 1 - 2 | : kaleid exorwrite home center - 3 patterns &30 + @ pattern ! - 4 2 0 DO - 5 $40 1 DO $140 0 DO I diamond J +LOOP LOOP - 6 LOOP ; - 7 - 8 : kaleidos page big_diamond kaleid wait ; - 9 : kaleid1 page logo kaleid wait ; -10 -11 : diamonds 1 pat_mask ! -12 $10 0 DO patterns I 2* + @ pattern ! -13 page big_diamond wait LOOP ; -14 -15 -Screen 8 not modified - 0 \ polygon example 18sep86we - 1 - 2 | : (poly ( x y -- ) - 3 2dup >r &100 + r> &10 + - 4 2dup >r &10 + r> &90 + - 5 2dup >r &30 - r> &20 + - 6 2dup >r &50 - r> &35 - - 7 2dup >r &30 - r> &85 - 6 polygon ; - 8 - 9 : poly page -10 &10 0 DO patterns I 5 + 2* + @ pattern ! -11 I I * &5 * I &30 * (poly LOOP -12 &10 0 DO patterns I 5 + 2* + @ pattern ! -13 &510 I I * &5 * - I &30 * (poly LOOP -14 wait ; -15 -Screen 9 not modified - 0 \ moire - 1 - 2 : moire page curoff exorwrite titel - 3 &400 1 DO - 4 &640 0 DO I &399 &639 I - 0 line J +LOOP - 5 &400 0 DO &639 &398 I - 0 I line J +LOOP - 6 LOOP - 7 1 &399 DO - 8 &640 0 DO I &399 &639 I - 0 line J +LOOP - 9 &400 0 DO &639 &398 I - 0 I line J +LOOP -10 -1 +LOOP wait ; -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ boxes 17sep86we - 1 - 2 : boxes exorwrite page - 3 &162 0 DO I I set I dup box - 4 &639 I 2* - I set I dup box - 5 I &399 I 2* - set I dup box - 6 &639 I 2* - &399 I 2* - set I dup box 2 +LOOP - 7 wait ; - 8 - 9 | Code a>r 4 SP D) D0 move D0 SP ) sub -10 6 SP D) D0 move D0 2 SP D) sub Next end-code -11 -12 : abox ( x1 y1 x2 y2 -- ) a>r 2swap set box ; -13 -14 -15 -Screen 11 not modified - 0 \ Rechtecke 17sep86we - 1 - 2 : rechtecke exorwrite page - 3 0 BEGIN stop? not WHILE - 4 8 + dup >r r@ &640 mod r@ &400 mod - 5 &639 r@ - &640 mod &399 r> - &400 mod - 6 abox REPEAT drop ; - 7 - 8 : rechtecke1 page exorwrite fullpattern pattern ! - 9 BEGIN stop? not WHILE -10 &99 3 DO &300 0 DO -11 I dup dup J + dup a>r rectangle J +LOOP -12 LOOP -13 3 &98 DO &300 0 DO -14 I dup dup J + dup a>r rectangle J +LOOP -15 -1 +LOOP REPEAT ; -Screen 12 not modified - 0 \ linien punkte 18sep86we - 1 - 2 | : (lines ( abstand -- ) exorwrite - 3 &640 0 DO &640 0 DO I &399 J 0 line dup +LOOP - 4 dup +LOOP drop ; - 5 - 6 : lines page home curoff &45 (lines &90 (lines - 7 BEGIN &45 (lines stop? UNTIL &25 0 at ; - 8 - 9 : kreis_moire page &320 0 DO -10 &199 0 DO I dup * J dup * + &300 / 1 and -11 IF &320 J + &200 I + 1 put_pixel -12 &320 J - &200 I + 1 put_pixel -13 &320 J - &200 I - 1 put_pixel -14 &320 J + &200 I - 1 put_pixel -15 THEN 2 +LOOP LOOP wait ; -Screen 13 not modified - 0 \ Sprites 20sep86we - 1 - 2 \needs q : q ; - 3 forget q : q ; - 4 - 5 : Sprite: Create 5 0 DO 4 I - roll , LOOP - 6 $10 0 DO $FFFF , $0F I - roll , LOOP ; - 7 - 8 - 9 Create spritebuf &74 allot -10 -11 -12 -13 -14 -15 --> -Screen 14 not modified - 0 %0000000000000000 \ 20sep86we - 1 %0111111111111100 - 2 %0100000000000000 - 3 %0100000000000000 - 4 %0100000000000000 - 5 %0100000000000000 - 6 %0100000000000000 - 7 %0111111111110000 - 8 %0100000000000000 - 9 %0100000000000000 -10 %0100000000000000 -11 %0100000000000000 -12 %0100000000000000 -13 %0100000000000000 -14 %0100000000000000 -15 %0000000000000000 0 0 1 0 1 Sprite: test diff --git a/sources/AtariST/DEMO.fth b/sources/AtariST/DEMO.fth new file mode 100644 index 0000000..cf8c00a --- /dev/null +++ b/sources/AtariST/DEMO.fth @@ -0,0 +1,255 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Graphic - Demonstrationen *** 26may86we + +Dieses File enth„lt einige Graphic-Demos, die von den Line-A +Routinen Gebrauch machen. + +Hier bietet sich auch dem Anf„nger ein weites Feld fr eigene +Versuche. Mit CHECKING ON kann man die gr”bsten Fehler abfan- +gen, alledings auf Kosten der Geschwindigkeit. + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Demo Loadscreen 21sep86we + +\needs Graphics include line_a.scr + +Onlyforth Graphics also definitions + 1 &11 +thru + +moire +kaleidos +lines +boxes +rechtecke +rechtecke1 + + + +\ *** Block No. 2 Hexblock 2 +\ patterns 18sep86we + +1 ?head ! +: !pattern ( d -- ) Create , , ; + +$C000.C000 !pattern p1 $CCCC.3333 !pattern p2 +$C0C0.3030 !pattern p3 $0303.0C0C !pattern p4 +$C003.300C !pattern p5 $C3C3.3C3C !pattern p6 +$FFFF.8001 !pattern p7 $40A0.8040 !pattern p8 +$4444.0000 !pattern p9 $FFFF.2222 !pattern p10 +$4444.8282 !pattern p11 $8080.8888 !pattern p12 +$0000.1010 !pattern p13 $0101.8080 !pattern p14 +$7777.8888 !pattern p15 $7E7E.8181 !pattern p16 +$E640.FFFF !pattern p17 $3838.C6C6 !pattern p18 + +0 ?head ! +\ *** Block No. 3 Hexblock 3 +\ patterns 21may86we + +Create patterns p1 , p2 , p3 , p4 , p5 , p6 , + p7 , p8 , p9 , p10 , p11 , p12 , + p13 , p14 , p15 , p16 , p17 , p18 , + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 +\ diamonds 20sep86we + +| : yscale &400 &640 */ ; + +: diamond ( size -- ) + >r cur_x @ cur_y @ + 2dup swap r@ - swap 2swap 2over set + 2dup r@ yscale - draw + 2dup swap r@ + swap draw + 2dup r> yscale + draw + 2swap draw set ; + +: big_diamond 2 wr_mode ! + &319 0 &639 &200 &319 &399 0 &200 4 polygon ; + + +\ *** Block No. 5 Hexblock 5 +\ some usefull definitions 20sep86we + +: overwrite 0 wr_mode ! ; +: exorwrite 2 wr_mode ! ; + +| : home get_res scr_res ! 0 0 set ; +| : center &320 &200 set ; + +| : wait BEGIN pause key? UNTIL &25 0 at + getkey $FF and #esc = abort" stopped" ; + +| : logo &117 0 DO ." volksFORTH 83 " LOOP ; + +| : titel + &21 &24 at ." *** v o l k s F O R T H *** " + &22 &31 at ." Line-A Graphic " ; +\ *** Block No. 6 Hexblock 6 +\ patterns example 18sep86we + +: muster + page overwrite 1 pat_mask ! + $10 0 DO patterns I 2* + @ pattern ! + $10 I $10 * + dup $80 $80 rectangle LOOP + 6 pat_mask ! + $10 0 DO patterns I 2* + @ pattern ! + $110 I $10 * dup >r + $110 r> - $80 $80 rectangle LOOP + 1 pat_mask ! wait ; + + + + + + +\ *** Block No. 7 Hexblock 7 +\ kaleidoskop 20sep86we + +| : kaleid exorwrite home center + patterns &30 + @ pattern ! + 2 0 DO + $40 1 DO $140 0 DO I diamond J +LOOP LOOP + LOOP ; + +: kaleidos page big_diamond kaleid wait ; +: kaleid1 page logo kaleid wait ; + +: diamonds 1 pat_mask ! + $10 0 DO patterns I 2* + @ pattern ! + page big_diamond wait LOOP ; + + +\ *** Block No. 8 Hexblock 8 +\ polygon example 18sep86we + +| : (poly ( x y -- ) + 2dup >r &100 + r> &10 + + 2dup >r &10 + r> &90 + + 2dup >r &30 - r> &20 + + 2dup >r &50 - r> &35 - + 2dup >r &30 - r> &85 - 6 polygon ; + +: poly page + &10 0 DO patterns I 5 + 2* + @ pattern ! + I I * &5 * I &30 * (poly LOOP + &10 0 DO patterns I 5 + 2* + @ pattern ! + &510 I I * &5 * - I &30 * (poly LOOP + wait ; + +\ *** Block No. 9 Hexblock 9 +\ moire + +: moire page curoff exorwrite titel + &400 1 DO + &640 0 DO I &399 &639 I - 0 line J +LOOP + &400 0 DO &639 &398 I - 0 I line J +LOOP + LOOP + 1 &399 DO + &640 0 DO I &399 &639 I - 0 line J +LOOP + &400 0 DO &639 &398 I - 0 I line J +LOOP + -1 +LOOP wait ; + + + + + +\ *** Block No. 10 Hexblock A +\ boxes 17sep86we + +: boxes exorwrite page + &162 0 DO I I set I dup box + &639 I 2* - I set I dup box + I &399 I 2* - set I dup box + &639 I 2* - &399 I 2* - set I dup box 2 +LOOP + wait ; + +| Code a>r 4 SP D) D0 move D0 SP ) sub + 6 SP D) D0 move D0 2 SP D) sub Next end-code + +: abox ( x1 y1 x2 y2 -- ) a>r 2swap set box ; + + + +\ *** Block No. 11 Hexblock B +\ Rechtecke 17sep86we + +: rechtecke exorwrite page + 0 BEGIN stop? not WHILE + 8 + dup >r r@ &640 mod r@ &400 mod + &639 r@ - &640 mod &399 r> - &400 mod + abox REPEAT drop ; + +: rechtecke1 page exorwrite fullpattern pattern ! + BEGIN stop? not WHILE + &99 3 DO &300 0 DO + I dup dup J + dup a>r rectangle J +LOOP + LOOP + 3 &98 DO &300 0 DO + I dup dup J + dup a>r rectangle J +LOOP + -1 +LOOP REPEAT ; +\ *** Block No. 12 Hexblock C +\ linien punkte 18sep86we + +| : (lines ( abstand -- ) exorwrite + &640 0 DO &640 0 DO I &399 J 0 line dup +LOOP + dup +LOOP drop ; + +: lines page home curoff &45 (lines &90 (lines + BEGIN &45 (lines stop? UNTIL &25 0 at ; + +: kreis_moire page &320 0 DO + &199 0 DO I dup * J dup * + &300 / 1 and + IF &320 J + &200 I + 1 put_pixel + &320 J - &200 I + 1 put_pixel + &320 J - &200 I - 1 put_pixel + &320 J + &200 I - 1 put_pixel + THEN 2 +LOOP LOOP wait ; +\ *** Block No. 13 Hexblock D +\ Sprites 20sep86we + +\needs q : q ; +forget q : q ; + +: Sprite: Create 5 0 DO 4 I - roll , LOOP + $10 0 DO $FFFF , $0F I - roll , LOOP ; + + +Create spritebuf &74 allot + + + + + +--> +\ *** Block No. 14 Hexblock E +%0000000000000000 \ 20sep86we +%0111111111111100 +%0100000000000000 +%0100000000000000 +%0100000000000000 +%0100000000000000 +%0100000000000000 +%0111111111110000 +%0100000000000000 +%0100000000000000 +%0100000000000000 +%0100000000000000 +%0100000000000000 +%0100000000000000 +%0100000000000000 +%0000000000000000 0 0 1 0 1 Sprite: test diff --git a/sources/AtariST/DISASS.FB.src b/sources/AtariST/DISASS.FB.src deleted file mode 100644 index 075582b..0000000 --- a/sources/AtariST/DISASS.FB.src +++ /dev/null @@ -1,357 +0,0 @@ -Screen 0 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ 68000 Disassembler loadscreen 05dec86we - 1 - 2 Onlyforth - 3 - 4 \needs >absaddr : >absaddr 0 forthstart d+ ; - 5 \needs Code .( Load assemble.scr first) abort - 6 - 7 1 ?head ! \ alle Disassembler-Worte headerless - 8 1 $12 +thru - 9 -10 0 ?head ! -11 $13 +load \ Benutzer-Worte mit Header -12 -13 -14 -15 -Screen 2 not modified - 0 \ long words and presigns 14oct86we - 1 - 2 : l+ ( n -- ) extend d+ ; - 3 : l- ( n -- ) extend d- ; - 4 : l+! ( n addr -- ) >absaddr ln+! ; - 5 - 6 : .# Ascii # emit ; - 7 : .$ Ascii $ emit ; - 8 : ., Ascii , emit ; - 9 : .- Ascii - emit ; -10 : .. Ascii . emit ; -11 -12 : .0r ( n width --) over abs swap -13 <# 0 DO # LOOP swap sign #> type space ; -14 -15 -Screen 3 not modified - 0 \ signed / unsigned byte, word and long output 28jan86ma - 1 - 2 : .lformat ( laddr --) <# #s #> dup 8 swap - spaces type ; - 3 - 4 : .lu ( d -- ) <# #s #> type ; - 5 : .$lu ( d -- ) .$ .lu ; - 6 - 7 : .wo ( n -- ) 0 <# # # # # #> type ; - 8 : .$wu ( n -- ) .$ .wo ; - 9 : .$ws ( n -- ) dup $7FFF u> -10 IF .- 1.0000 rot d- THEN .$ .wo ; -11 : .by ( 8b -- ) 0 <# # # #> type ; -12 : .$bu ( 8b -- ) .$ .by ; -13 : .$bs ( 8b -- ) $FF and dup $7F > -14 IF .- 100 swap - THEN .$ .by ; -15 : .lb ( hi lo len -- ) bounds ?DO I over lc@ .by LOOP ; -Screen 4 not modified - 0 \ Variables and tabs 18jan86ma - 1 - 2 2Variable addr 2Variable dispaddr 2Variable saveaddr - 3 Variable opcode Variable mne Variable mode - 4 Variable reg Variable length Variable sr - 5 Variable predec - 6 - 7 &10 constant bytfld : tab row swap at ; - 8 &32 constant mnefld - 9 &40 constant adrfld : tab1 row adrfld at ; -10 -11 : getword -12 addr 2@ 2 l+ 2dup addr 2! l@ ; -13 : getlong -14 addr 2@ 4 l+ 2dup addr 2! 2dup 2 l- l@ >r l@ r> ; -15 -Screen 5 not modified - 0 \ print registernumber, dump 18jan86ma - 1 - 2 : .reg ( n -- ) 7 and Ascii 0 + emit ; - 3 : .(areg) ( n -- ) Ascii A emit .reg ; - 4 : .(dreg) ( n -- ) Ascii D emit .reg ; - 5 - 6 : .areg reg @ .(areg) ; - 7 : .dreg reg @ .(dreg) ; - 8 - 9 : .aind Ascii ( emit .areg Ascii ) emit ; -10 : .apost .aind Ascii + emit ; -11 : .apre .- .aind ; -12 -13 : dumpws getword .$ws ; -14 : dumpw getword .$wu ; -15 : dumpl getlong .$lu ; -Screen 6 not modified - 0 \ print length , bitmasking 04mar86we - 1 - 2 : len. length @ - 3 0 case? IF ." .b" tab1 exit THEN - 4 1 case? IF ." .w" tab1 exit THEN - 5 2 case? IF ." .l" tab1 exit THEN - 6 tab1 drop ; - 7 - 8 Code shift ( n -- ) SP )+ D0 move SP ) D1 move - 9 D0 D1 lsr D1 SP ) move Next end-code -10 : 4shft 4 shift ; : 8shft 8 shift ; -11 : cshft $0C shift ; -12 : bitce $0C shift 7 and ; : bit5 5 shift 1 and ; -13 : bit6 6 shift 1 and ; : bit7 7 shift 1 and ; -14 : bit10 $0A shift 1 and ; : bit11 $0B shift 1 and ; -15 : bit8b 8 shift $0F and ; -Screen 7 not modified - 0 \ bitmasking 2 28jan86ma - 1 - 2 : bit02 7 and ; : bit8 8 shift 1 and ; - 3 : bit35 3 shift 7 and ; : bit3 3 shift 1 and ; - 4 : bit68 6 shift 7 and ; : bit9b 9 shift 7 and ; - 5 : bit67 6 shift 3 and ; : bit37 3 shift $1F and ; - 6 - 7 : len!. length ! len. ; - 8 : length6 opcode @ bit6 1+ len!. ; - 9 : length67 opcode @ bit67 len!. ; -10 -11 : reg02! opcode @ bit02 reg ! ; -12 : reg9b! opcode @ bit9b reg ! ; -13 -14 : bit9b. .# opcode @ bit9b dup 0= -15 IF drop 8 THEN .$bu ; -Screen 8 not modified - 0 \ list register 26jan86ma - 1 - 2 : reglist - 3 getword 10 0 DO - 4 dup 2/ swap 1 and - 5 IF I predec @ - 6 IF $0F swap - THEN dup 7 > - 7 IF .(areg) ELSE .(dreg) THEN dup - 8 IF ." /" THEN - 9 THEN LOOP drop ; -10 -11 : mnext length6 reg02! .dreg ; -12 -13 -14 -15 -Screen 9 not modified - 0 \ print adressing mode bp 28Aug86 - 1 - 2 : .a/pcreg mode @ 7 = - 3 IF ." PC" ELSE .areg THEN ; - 4 : l? ( ext.word -- ) $800 and IF ." .L" exit THEN ." .W" ; - 5 : i8bit - 6 getword dup .$bs - 7 Ascii ( emit .a/pcreg ., dup $7FFF > - 8 IF Ascii A emit ELSE Ascii D emit THEN - 9 dup bitce .reg l? Ascii ) emit ; -10 -11 : imm -12 .# length @ -13 0 case? IF getword .$bu exit THEN -14 1 case? IF dumpw exit THEN -15 2 case? IF dumpl exit THEN drop ; -Screen 10 not modified - 0 \ print adressing mode 28jan86ma - 1 - 2 : mode7 reg @ - 3 0 case? IF dumpws exit THEN - 4 1 case? IF dumpl exit THEN - 5 2 case? IF dumpws ." (PC)" exit THEN - 6 3 case? IF i8bit exit THEN - 7 4 case? IF sr @ IF ." SR" ELSE imm THEN exit THEN - 8 drop ." ???" ; - 9 -10 : effadr mode @ -11 0 case? IF .dreg exit THEN 1 case? IF .areg exit THEN -12 2 case? IF .aind exit THEN 3 case? IF .apost exit THEN -13 4 case? IF .apre exit THEN 5 case? IF dumpws .aind exit THEN -14 6 case? IF i8bit exit THEN 7 case? IF mode7 exit THEN -15 drop ; -Screen 11 not modified - 0 \ find register and mode 28jan86ma - 1 : .ea opcode @ dup bit02 reg ! bit35 mode ! effadr ; - 2 : .eadest opcode @ dup bit68 mode ! bit9b reg ! effadr ; - 3 : mnabcd - 4 tab1 opcode @ bit3 - 5 IF reg02! .apre ., reg9b! .apre - 6 ELSE reg02! .dreg ., reg9b! .dreg THEN ; - 7 : mnaddx length67 mnabcd ; - 8 : mncmpm length67 reg02! .apost ., reg9b! .apost ; - 9 : mnexg -10 tab1 reg9b! opcode @ bit37 -11 dup 9 = IF .areg ELSE .dreg THEN ., reg02! -12 8 = IF .dreg ELSE .areg THEN ; -13 : mnadd length67 opcode @ -14 bit8 IF reg9b! .dreg ., .ea -15 ELSE .ea ., reg9b! .dreg THEN ; -Screen 12 not modified - 0 \ find register and mode 26jan86ma - 1 : mnadda opcode @ bit8 1+ len!. .ea ., reg9b! .areg ; - 2 : mnaddi length67 imm ., 1 sr ! .ea ; - 3 : mnaddq length67 bit9b. ., .ea ; - 4 : mnmoveq tab1 .# opcode @ .$bs ., reg9b! .dreg ; - 5 : mnswap tab1 reg02! .dreg ; - 6 : mnunlk tab1 reg02! .areg ; - 7 : mnclr length67 .ea ; - 8 : mnjmp tab1 .ea ; - 9 : mnchk mnjmp ., reg9b! .dreg ; -10 : mnlea tab1 .ea ., reg9b! .areg ; -11 : mnbchg tab1 opcode @ bit8 -12 IF reg9b! .dreg ELSE .# dumpw THEN ., .ea ; -13 : mnbchg2 tab1 reg9b! .dreg ., .ea ; -14 : .dir opcode @ bit8 -15 IF Ascii l emit ELSE Ascii r emit THEN ; -Screen 13 not modified - 0 \ find register and mode 23sep86we - 1 - 2 : mnshft - 3 .dir length67 opcode @ bit5 - 4 IF reg9b! .dreg ELSE bit9b. THEN ., reg02! .dreg ; - 5 : mnshft2 .dir mnjmp ; - 6 : reladr2 - 7 getword dup $7FFF > - 8 IF 1.0000 rot d- THEN 2+ dispaddr 2@ rot l+ .$lu ; - 9 : reladr -10 opcode @ $FF and ?dup -11 IF dup $7F > IF 100 - THEN 2+ dispaddr 2@ rot l+ .$lu -12 ELSE reladr2 THEN ; -13 : quote Create $22 word drop $22 allot Does> 1+ ; -14 quote ctbl0 t f hilscccsneeqvcvsplmigeltgtle" -15 quote ctbl1 rasrhilscccsneeqvcvsplmigeltgtle" -Screen 14 not modified - 0 \ find register and mode 18jan86ma - 1 - 2 : .cond ( ctblflag --> ) - 3 IF ctbl1 ELSE ctbl0 THEN - 4 opcode @ bit8b 2* + 2 type tab1 ; - 5 : mnscc 0 .cond .ea ; - 6 : mnbcc 1 .cond reladr ; - 7 : mndbcc 0 .cond reg02! .dreg ., reladr2 ; - 8 : mnlink tab1 reg02! .areg ., .# dumpws ; - 9 : mnmove -10 4 opcode @ bitce - dup 3 = IF drop 0 THEN -11 len!. .ea ., .eadest ; -12 : mnmoveccr mnjmp ." ,ccr" ; -13 : mnmovesr mnjmp ." ,sr" ; -14 : mnmovefsr tab1 ." sr," .ea ; -15 -Screen 15 not modified - 0 \ find register and mode 26jan86ma - 1 - 2 : mnmoveusp tab1 reg02! opcode @ bit3 - 3 IF ." usp," .areg ELSE .areg ." ,usp" THEN ; - 4 : mnmovem - 5 length6 opcode @ dup bit35 4 = predec ! bit10 - 6 IF .ea ., reglist ELSE reglist ., .ea THEN ; - 7 : mnmovep - 8 length6 opcode @ bit7 - 9 IF reg9b! .dreg ., dumpws reg02! .aind -10 ELSE dumpws reg02! .aind ., reg9b! .dreg THEN ; -11 : mnstop tab1 .# dumpw ; -12 : mntrap tab1 .# opcode @ $0F and .$bu ; -13 : mnimp ; -14 -15 : t, swap , , [compile] ' , bl word drop 8 allot ; -Screen 16 not modified - 0 \ mask- and opcode-table 18jan86ma - 1 - 2 Create mntbl base @ hex - 3 ff00 0600 t, mnaddi addi ff00 0200 t, mnaddi andi - 4 ff00 0c00 t, mnaddi cmpi ff00 0a00 t, mnaddi eori - 5 ff00 0000 t, mnaddi ori ff00 0400 t, mnaddi subi - 6 ffc0 0840 t, mnbchg bchg ffc0 0880 t, mnbchg bclr - 7 ffc0 08c0 t, mnbchg bset ffc0 0800 t, mnbchg btst - 8 e1c0 2040 t, mnmove movea c000 0000 t, mnmove move - 9 ffff 4afc t, mnimp illegal ffff 4e71 t, mnimp nop -10 ffff 4e70 t, mnimp reset ffff 4e73 t, mnimp rte -11 ffff 4e77 t, mnimp rtr ffff 4e75 t, mnimp rts -12 ffff 4e76 t, mnimp trapv ffff 4e72 t, mnstop stop -13 fff0 4e40 t, mntrap trap fff8 4840 t, mnswap swap -14 fff8 4e58 t, mnunlk unlk fff8 4e50 t, mnlink link -15 ffb8 4880 t, mnext ext ffc0 44c0 t, mnmoveccr move -Screen 17 not modified - 0 \ mask- and opcode-table 18jan86ma - 1 - 2 ffc0 46c0 t, mnmovesr move ffc0 40c0 t, mnmovefsr move - 3 fff0 4e60 t, mnmoveusp move ffc0 4ac0 t, mnjmp tas - 4 ff00 4200 t, mnclr clr ff00 4400 t, mnclr neg - 5 ff00 4000 t, mnclr negx ff00 4600 t, mnclr not - 6 ff00 4a00 t, mnclr tst ffc0 4ec0 t, mnjmp jmp - 7 ffc0 4e80 t, mnjmp jsr ffc0 4800 t, mnjmp nbcd - 8 ffc0 4840 t, mnjmp pea f1c0 41c0 t, mnlea lea - 9 f1c0 4180 t, mnchk chk fb80 4880 t, mnmovem movem -10 f0f8 50c8 t, mndbcc db f0c0 50c0 t, mnscc s -11 f100 5000 t, mnaddq addq f100 5100 t, mnaddq subq -12 f000 6000 t, mnbcc b f100 7000 t, mnmoveq moveq -13 f1f0 8100 t, mnabcd sbcd f1c0 81c0 t, mnchk divs -14 f1c0 80c0 t, mnchk divu f000 8000 t, mnadd or -15 -Screen 18 not modified - 0 \ mask- and opcode-table 18jan86ma - 1 - 2 f0c0 90c0 t, mnadda suba f130 9100 t, mnaddx subx - 3 f000 9000 t, mnadd sub f000 a000 t, mnimp ?ext0a - 4 f0c0 b0c0 t, mnadda cmpa f138 b108 t, mncmpm cmpm - 5 f100 b100 t, mnadd eor f100 b000 t, mnadd cmp - 6 f1f0 c100 t, mnabcd abcd f1c0 c1c0 t, mnchk muls - 7 f1c0 c0c0 t, mnchk mulu f130 c100 t, mnexg exg - 8 f000 c000 t, mnadd and f0c0 d0c0 t, mnadda adda - 9 f130 d100 t, mnaddx addx f000 d000 t, mnadd add -10 fec0 e0c0 t, mnshft2 as fec0 e2c0 t, mnshft2 ls -11 fec0 e4c0 t, mnshft2 rox fec0 e6c0 t, mnshft2 ro -12 f018 e000 t, mnshft as f018 e008 t, mnshft ls -13 f018 e010 t, mnshft rox f018 e018 t, mnshft ro -14 f000 f000 t, mnimp ?ext0f 0000 0000 t, mnimp ??? -15 base ! -Screen 19 not modified - 0 \ search mne and dis a line 05dec86we - 1 - 2 : searchmne ( -- ) - 3 mntbl 0 sr ! 0 predec ! - 4 BEGIN dup @ opcode @ and over 2+ @ = - 5 IF dup 6 + count type 4+ @ execute exit THEN - 6 $0E + REPEAT ; - 7 - 8 : disline ( -- ) base push hex - 9 cr dispaddr 2@ .lformat mnefld tab -10 addr 2@ 2dup saveaddr 2! l@ opcode ! -11 searchmne 2 addr l+! bytfld tab -12 addr 2@ saveaddr 2@ d- drop dup >r dispaddr l+! -13 saveaddr 2@ swap r> .lb drop ; -14 -15 -Screen 20 not modified - 0 \ addr! dis ldis disw 14oct86we - 1 - 2 : addr! 2dup addr 2! dispaddr 2! ; - 3 - 4 : disassline addr! disline ; - 5 - 6 : ldis addr! BEGIN disline stop? UNTIL cr ; - 7 - 8 : dis >absaddr ldis ; - 9 -10 : disw ' 2+ dup ." Adresse : " u. cr >absaddr addr! -11 BEGIN -12 BEGIN disline opcode @ $4EF3 = stop? or UNTIL -13 key $FF and #esc = UNTIL -14 cr ; -15 diff --git a/sources/AtariST/DISASS.fth b/sources/AtariST/DISASS.fth new file mode 100644 index 0000000..cc1a94e --- /dev/null +++ b/sources/AtariST/DISASS.fth @@ -0,0 +1,357 @@ +\ *** Block No. 0 Hexblock 0 + + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ 68000 Disassembler loadscreen 05dec86we + +Onlyforth + +\needs >absaddr : >absaddr 0 forthstart d+ ; +\needs Code .( Load assemble.scr first) abort + +1 ?head ! \ alle Disassembler-Worte headerless +1 $12 +thru + +0 ?head ! +$13 +load \ Benutzer-Worte mit Header + + + + +\ *** Block No. 2 Hexblock 2 +\ long words and presigns 14oct86we + +: l+ ( n -- ) extend d+ ; +: l- ( n -- ) extend d- ; +: l+! ( n addr -- ) >absaddr ln+! ; + +: .# Ascii # emit ; +: .$ Ascii $ emit ; +: ., Ascii , emit ; +: .- Ascii - emit ; +: .. Ascii . emit ; + +: .0r ( n width --) over abs swap + <# 0 DO # LOOP swap sign #> type space ; + + +\ *** Block No. 3 Hexblock 3 +\ signed / unsigned byte, word and long output 28jan86ma + +: .lformat ( laddr --) <# #s #> dup 8 swap - spaces type ; + +: .lu ( d -- ) <# #s #> type ; +: .$lu ( d -- ) .$ .lu ; + +: .wo ( n -- ) 0 <# # # # # #> type ; +: .$wu ( n -- ) .$ .wo ; +: .$ws ( n -- ) dup $7FFF u> + IF .- 1.0000 rot d- THEN .$ .wo ; +: .by ( 8b -- ) 0 <# # # #> type ; +: .$bu ( 8b -- ) .$ .by ; +: .$bs ( 8b -- ) $FF and dup $7F > + IF .- 100 swap - THEN .$ .by ; +: .lb ( hi lo len -- ) bounds ?DO I over lc@ .by LOOP ; +\ *** Block No. 4 Hexblock 4 +\ Variables and tabs 18jan86ma + +2Variable addr 2Variable dispaddr 2Variable saveaddr +Variable opcode Variable mne Variable mode +Variable reg Variable length Variable sr +Variable predec + + &10 constant bytfld : tab row swap at ; + &32 constant mnefld + &40 constant adrfld : tab1 row adrfld at ; + +: getword + addr 2@ 2 l+ 2dup addr 2! l@ ; +: getlong + addr 2@ 4 l+ 2dup addr 2! 2dup 2 l- l@ >r l@ r> ; + +\ *** Block No. 5 Hexblock 5 +\ print registernumber, dump 18jan86ma + +: .reg ( n -- ) 7 and Ascii 0 + emit ; +: .(areg) ( n -- ) Ascii A emit .reg ; +: .(dreg) ( n -- ) Ascii D emit .reg ; + +: .areg reg @ .(areg) ; +: .dreg reg @ .(dreg) ; + +: .aind Ascii ( emit .areg Ascii ) emit ; +: .apost .aind Ascii + emit ; +: .apre .- .aind ; + +: dumpws getword .$ws ; +: dumpw getword .$wu ; +: dumpl getlong .$lu ; +\ *** Block No. 6 Hexblock 6 +\ print length , bitmasking 04mar86we + +: len. length @ + 0 case? IF ." .b" tab1 exit THEN + 1 case? IF ." .w" tab1 exit THEN + 2 case? IF ." .l" tab1 exit THEN + tab1 drop ; + +Code shift ( n -- ) SP )+ D0 move SP ) D1 move + D0 D1 lsr D1 SP ) move Next end-code +: 4shft 4 shift ; : 8shft 8 shift ; +: cshft $0C shift ; +: bitce $0C shift 7 and ; : bit5 5 shift 1 and ; +: bit6 6 shift 1 and ; : bit7 7 shift 1 and ; +: bit10 $0A shift 1 and ; : bit11 $0B shift 1 and ; +: bit8b 8 shift $0F and ; +\ *** Block No. 7 Hexblock 7 +\ bitmasking 2 28jan86ma + +: bit02 7 and ; : bit8 8 shift 1 and ; +: bit35 3 shift 7 and ; : bit3 3 shift 1 and ; +: bit68 6 shift 7 and ; : bit9b 9 shift 7 and ; +: bit67 6 shift 3 and ; : bit37 3 shift $1F and ; + +: len!. length ! len. ; +: length6 opcode @ bit6 1+ len!. ; +: length67 opcode @ bit67 len!. ; + +: reg02! opcode @ bit02 reg ! ; +: reg9b! opcode @ bit9b reg ! ; + +: bit9b. .# opcode @ bit9b dup 0= + IF drop 8 THEN .$bu ; +\ *** Block No. 8 Hexblock 8 +\ list register 26jan86ma + +: reglist + getword 10 0 DO + dup 2/ swap 1 and + IF I predec @ + IF $0F swap - THEN dup 7 > + IF .(areg) ELSE .(dreg) THEN dup + IF ." /" THEN + THEN LOOP drop ; + +: mnext length6 reg02! .dreg ; + + + + +\ *** Block No. 9 Hexblock 9 +\ print adressing mode bp 28Aug86 + +: .a/pcreg mode @ 7 = + IF ." PC" ELSE .areg THEN ; +: l? ( ext.word -- ) $800 and IF ." .L" exit THEN ." .W" ; +: i8bit + getword dup .$bs + Ascii ( emit .a/pcreg ., dup $7FFF > + IF Ascii A emit ELSE Ascii D emit THEN + dup bitce .reg l? Ascii ) emit ; + +: imm + .# length @ + 0 case? IF getword .$bu exit THEN + 1 case? IF dumpw exit THEN + 2 case? IF dumpl exit THEN drop ; +\ *** Block No. 10 Hexblock A +\ print adressing mode 28jan86ma + +: mode7 reg @ + 0 case? IF dumpws exit THEN + 1 case? IF dumpl exit THEN + 2 case? IF dumpws ." (PC)" exit THEN + 3 case? IF i8bit exit THEN + 4 case? IF sr @ IF ." SR" ELSE imm THEN exit THEN + drop ." ???" ; + +: effadr mode @ + 0 case? IF .dreg exit THEN 1 case? IF .areg exit THEN + 2 case? IF .aind exit THEN 3 case? IF .apost exit THEN + 4 case? IF .apre exit THEN 5 case? IF dumpws .aind exit THEN + 6 case? IF i8bit exit THEN 7 case? IF mode7 exit THEN + drop ; +\ *** Block No. 11 Hexblock B +\ find register and mode 28jan86ma +: .ea opcode @ dup bit02 reg ! bit35 mode ! effadr ; +: .eadest opcode @ dup bit68 mode ! bit9b reg ! effadr ; +: mnabcd + tab1 opcode @ bit3 + IF reg02! .apre ., reg9b! .apre + ELSE reg02! .dreg ., reg9b! .dreg THEN ; +: mnaddx length67 mnabcd ; +: mncmpm length67 reg02! .apost ., reg9b! .apost ; +: mnexg + tab1 reg9b! opcode @ bit37 + dup 9 = IF .areg ELSE .dreg THEN ., reg02! + 8 = IF .dreg ELSE .areg THEN ; +: mnadd length67 opcode @ + bit8 IF reg9b! .dreg ., .ea + ELSE .ea ., reg9b! .dreg THEN ; +\ *** Block No. 12 Hexblock C +\ find register and mode 26jan86ma +: mnadda opcode @ bit8 1+ len!. .ea ., reg9b! .areg ; +: mnaddi length67 imm ., 1 sr ! .ea ; +: mnaddq length67 bit9b. ., .ea ; +: mnmoveq tab1 .# opcode @ .$bs ., reg9b! .dreg ; +: mnswap tab1 reg02! .dreg ; +: mnunlk tab1 reg02! .areg ; +: mnclr length67 .ea ; +: mnjmp tab1 .ea ; +: mnchk mnjmp ., reg9b! .dreg ; +: mnlea tab1 .ea ., reg9b! .areg ; +: mnbchg tab1 opcode @ bit8 + IF reg9b! .dreg ELSE .# dumpw THEN ., .ea ; +: mnbchg2 tab1 reg9b! .dreg ., .ea ; +: .dir opcode @ bit8 + IF Ascii l emit ELSE Ascii r emit THEN ; +\ *** Block No. 13 Hexblock D +\ find register and mode 23sep86we + +: mnshft + .dir length67 opcode @ bit5 + IF reg9b! .dreg ELSE bit9b. THEN ., reg02! .dreg ; +: mnshft2 .dir mnjmp ; +: reladr2 + getword dup $7FFF > + IF 1.0000 rot d- THEN 2+ dispaddr 2@ rot l+ .$lu ; +: reladr + opcode @ $FF and ?dup + IF dup $7F > IF 100 - THEN 2+ dispaddr 2@ rot l+ .$lu + ELSE reladr2 THEN ; +: quote Create $22 word drop $22 allot Does> 1+ ; + quote ctbl0 t f hilscccsneeqvcvsplmigeltgtle" + quote ctbl1 rasrhilscccsneeqvcvsplmigeltgtle" +\ *** Block No. 14 Hexblock E +\ find register and mode 18jan86ma + +: .cond ( ctblflag --> ) + IF ctbl1 ELSE ctbl0 THEN + opcode @ bit8b 2* + 2 type tab1 ; +: mnscc 0 .cond .ea ; +: mnbcc 1 .cond reladr ; +: mndbcc 0 .cond reg02! .dreg ., reladr2 ; +: mnlink tab1 reg02! .areg ., .# dumpws ; +: mnmove + 4 opcode @ bitce - dup 3 = IF drop 0 THEN + len!. .ea ., .eadest ; +: mnmoveccr mnjmp ." ,ccr" ; +: mnmovesr mnjmp ." ,sr" ; +: mnmovefsr tab1 ." sr," .ea ; + +\ *** Block No. 15 Hexblock F +\ find register and mode 26jan86ma + +: mnmoveusp tab1 reg02! opcode @ bit3 + IF ." usp," .areg ELSE .areg ." ,usp" THEN ; +: mnmovem + length6 opcode @ dup bit35 4 = predec ! bit10 + IF .ea ., reglist ELSE reglist ., .ea THEN ; +: mnmovep + length6 opcode @ bit7 + IF reg9b! .dreg ., dumpws reg02! .aind + ELSE dumpws reg02! .aind ., reg9b! .dreg THEN ; +: mnstop tab1 .# dumpw ; +: mntrap tab1 .# opcode @ $0F and .$bu ; +: mnimp ; + +: t, swap , , [compile] ' , bl word drop 8 allot ; +\ *** Block No. 16 Hexblock 10 +\ mask- and opcode-table 18jan86ma + +Create mntbl base @ hex +ff00 0600 t, mnaddi addi ff00 0200 t, mnaddi andi +ff00 0c00 t, mnaddi cmpi ff00 0a00 t, mnaddi eori +ff00 0000 t, mnaddi ori ff00 0400 t, mnaddi subi +ffc0 0840 t, mnbchg bchg ffc0 0880 t, mnbchg bclr +ffc0 08c0 t, mnbchg bset ffc0 0800 t, mnbchg btst +e1c0 2040 t, mnmove movea c000 0000 t, mnmove move +ffff 4afc t, mnimp illegal ffff 4e71 t, mnimp nop +ffff 4e70 t, mnimp reset ffff 4e73 t, mnimp rte +ffff 4e77 t, mnimp rtr ffff 4e75 t, mnimp rts +ffff 4e76 t, mnimp trapv ffff 4e72 t, mnstop stop +fff0 4e40 t, mntrap trap fff8 4840 t, mnswap swap +fff8 4e58 t, mnunlk unlk fff8 4e50 t, mnlink link +ffb8 4880 t, mnext ext ffc0 44c0 t, mnmoveccr move +\ *** Block No. 17 Hexblock 11 +\ mask- and opcode-table 18jan86ma + +ffc0 46c0 t, mnmovesr move ffc0 40c0 t, mnmovefsr move +fff0 4e60 t, mnmoveusp move ffc0 4ac0 t, mnjmp tas +ff00 4200 t, mnclr clr ff00 4400 t, mnclr neg +ff00 4000 t, mnclr negx ff00 4600 t, mnclr not +ff00 4a00 t, mnclr tst ffc0 4ec0 t, mnjmp jmp +ffc0 4e80 t, mnjmp jsr ffc0 4800 t, mnjmp nbcd +ffc0 4840 t, mnjmp pea f1c0 41c0 t, mnlea lea +f1c0 4180 t, mnchk chk fb80 4880 t, mnmovem movem +f0f8 50c8 t, mndbcc db f0c0 50c0 t, mnscc s +f100 5000 t, mnaddq addq f100 5100 t, mnaddq subq +f000 6000 t, mnbcc b f100 7000 t, mnmoveq moveq +f1f0 8100 t, mnabcd sbcd f1c0 81c0 t, mnchk divs +f1c0 80c0 t, mnchk divu f000 8000 t, mnadd or + +\ *** Block No. 18 Hexblock 12 +\ mask- and opcode-table 18jan86ma + +f0c0 90c0 t, mnadda suba f130 9100 t, mnaddx subx +f000 9000 t, mnadd sub f000 a000 t, mnimp ?ext0a +f0c0 b0c0 t, mnadda cmpa f138 b108 t, mncmpm cmpm +f100 b100 t, mnadd eor f100 b000 t, mnadd cmp +f1f0 c100 t, mnabcd abcd f1c0 c1c0 t, mnchk muls +f1c0 c0c0 t, mnchk mulu f130 c100 t, mnexg exg +f000 c000 t, mnadd and f0c0 d0c0 t, mnadda adda +f130 d100 t, mnaddx addx f000 d000 t, mnadd add +fec0 e0c0 t, mnshft2 as fec0 e2c0 t, mnshft2 ls +fec0 e4c0 t, mnshft2 rox fec0 e6c0 t, mnshft2 ro +f018 e000 t, mnshft as f018 e008 t, mnshft ls +f018 e010 t, mnshft rox f018 e018 t, mnshft ro +f000 f000 t, mnimp ?ext0f 0000 0000 t, mnimp ??? +base ! +\ *** Block No. 19 Hexblock 13 +\ search mne and dis a line 05dec86we + +: searchmne ( -- ) + mntbl 0 sr ! 0 predec ! + BEGIN dup @ opcode @ and over 2+ @ = + IF dup 6 + count type 4+ @ execute exit THEN + $0E + REPEAT ; + +: disline ( -- ) base push hex + cr dispaddr 2@ .lformat mnefld tab + addr 2@ 2dup saveaddr 2! l@ opcode ! + searchmne 2 addr l+! bytfld tab + addr 2@ saveaddr 2@ d- drop dup >r dispaddr l+! + saveaddr 2@ swap r> .lb drop ; + + +\ *** Block No. 20 Hexblock 14 +\ addr! dis ldis disw 14oct86we + +: addr! 2dup addr 2! dispaddr 2! ; + +: disassline addr! disline ; + +: ldis addr! BEGIN disline stop? UNTIL cr ; + +: dis >absaddr ldis ; + +: disw ' 2+ dup ." Adresse : " u. cr >absaddr addr! + BEGIN + BEGIN disline opcode @ $4EF3 = stop? or UNTIL + key $FF and #esc = UNTIL + cr ; + diff --git a/sources/AtariST/DRAGON1.FB.src b/sources/AtariST/DRAGON1.FB.src deleted file mode 100644 index 81642e0..0000000 --- a/sources/AtariST/DRAGON1.FB.src +++ /dev/null @@ -1,136 +0,0 @@ -Screen 0 not modified - 0 \\ documentation for dargon demo tcas20130106 - 1 start the dragon with : DRAG - 2 or with : <1 or -1> DRAGON - 3 - 4 DRAG clears the screen, defines the starting point and executes - 5 DRAGON. - 6 The variable STEPSIZE defines the size of steps between 1 and 3 - 7 (larger values will produce grabage) - 8 - 9 odd numbers as input values do not work -10 -11 DDEMO is a loop executing the DRAGON demo which can be stopped -12 with a keypress once the 2nd dragon is fully painted (it is -13 recommended to press a key a little in advance) -14 -15 -Screen 1 not modified - 0 \ dragon-loadscreen cas20130106 - 1 - 2 Onlyforth - 3 - 4 \needs Graphics include line_a.fb - 5 - 6 Onlyforth GEM also Graphics also - 7 - 8 decimal - 9 -10 1 5 +thru -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ dragon s.2 03oct86we - 1 - 2 Variable angle - 3 Variable stepsize 1 stepsize ! - 4 Variable color 1 color ! - 5 Variable xcood Variable ycood - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ set_pixel 03oct86we - 1 - 2 Label ?step - 3 stepsize pcrel) D2 move D1 tst 0<> IF D2 neg THEN rts - 4 - 5 Code set_pixel - 6 xcood pcrel) D3 move ycood pcrel) D4 move - 7 angle pcrel) D0 move 1 # D0 asr D0 D1 move 1 D0 andi - 8 1 # D1 asr 1 D1 andi - 9 D0 tst 0= IF ?step bsr D2 D3 add D3 xcood R#) move THEN -10 D0 tst 0<> IF ?step bsr D2 D4 add D4 ycood R#) move THEN -11 D3 SP -) move D4 SP -) move color pcrel) SP -) move -12 ;c: put_pixel ; -13 -14 -15 -Screen 4 not modified - 0 \ dragon s.3 03oct86we - 1 - 2 Code turn ( n -- ) - 3 angle pcrel) D0 move SP )+ D0 add D0 angle R#) move - 4 Next end-code - 5 - 6 : dragon recursive ( stepw rec_tiefe -- ) - 7 dup 0= IF 2drop set_pixel - 8 ELSE - 9 over turn -10 1 over 1- dragon -11 over 2* negate turn -12 -1 over 1- dragon -13 drop turn -14 THEN ; -15 -Screen 5 not modified - 0 \ dragon s.4 03oct86we - 1 - 2 : drachen - 3 2 stepsize ! - 4 100 xcood ! 200 ycood ! 1 14 dragon - 5 101 xcood ! 200 ycood ! 1 14 dragon - 6 100 xcood ! 201 ycood ! 1 14 dragon - 7 101 xcood ! 201 ycood ! 1 14 dragon - 8 1 stepsize ! ; - 9 -10 : schubs -11 100 0 DO I 112 over - 400 272 2over >r 1+ r> 1- -12 scr>scr LOOP ; -13 -14 -15 -Screen 6 not modified - 0 \ dragon s.5 03oct86we - 1 - 2 : drag ( n -- ) page - 3 angle off 100 xcood ! 200 ycood ! - 4 1 swap dragon ; - 5 - 6 : ddemo - 7 16 drag schubs - 8 0 color ! 199 xcood ! 100 ycood ! 1 16 dragon - 9 1 color ! drachen ; -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ 03oct86we - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/DRAGON1.fth b/sources/AtariST/DRAGON1.fth new file mode 100644 index 0000000..fa20551 --- /dev/null +++ b/sources/AtariST/DRAGON1.fth @@ -0,0 +1,136 @@ +\ *** Block No. 0 Hexblock 0 +\\ documentation for dargon demo tcas20130106 +start the dragon with : DRAG + or with : <1 or -1> DRAGON + +DRAG clears the screen, defines the starting point and executes +DRAGON. +The variable STEPSIZE defines the size of steps between 1 and 3 +(larger values will produce grabage) + +odd numbers as input values do not work + +DDEMO is a loop executing the DRAGON demo which can be stopped +with a keypress once the 2nd dragon is fully painted (it is +recommended to press a key a little in advance) + + +\ *** Block No. 1 Hexblock 1 +\ dragon-loadscreen cas20130106 + +Onlyforth + +\needs Graphics include line_a.fb + +Onlyforth GEM also Graphics also + +decimal + +1 5 +thru + + + + + +\ *** Block No. 2 Hexblock 2 +\ dragon s.2 03oct86we + +Variable angle +Variable stepsize 1 stepsize ! +Variable color 1 color ! +Variable xcood Variable ycood + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ set_pixel 03oct86we + +Label ?step + stepsize pcrel) D2 move D1 tst 0<> IF D2 neg THEN rts + +Code set_pixel + xcood pcrel) D3 move ycood pcrel) D4 move + angle pcrel) D0 move 1 # D0 asr D0 D1 move 1 D0 andi + 1 # D1 asr 1 D1 andi + D0 tst 0= IF ?step bsr D2 D3 add D3 xcood R#) move THEN + D0 tst 0<> IF ?step bsr D2 D4 add D4 ycood R#) move THEN + D3 SP -) move D4 SP -) move color pcrel) SP -) move + ;c: put_pixel ; + + + +\ *** Block No. 4 Hexblock 4 +\ dragon s.3 03oct86we + +Code turn ( n -- ) + angle pcrel) D0 move SP )+ D0 add D0 angle R#) move + Next end-code + +: dragon recursive ( stepw rec_tiefe -- ) + dup 0= IF 2drop set_pixel + ELSE + over turn + 1 over 1- dragon + over 2* negate turn + -1 over 1- dragon + drop turn + THEN ; + +\ *** Block No. 5 Hexblock 5 +\ dragon s.4 03oct86we + +: drachen + 2 stepsize ! + 100 xcood ! 200 ycood ! 1 14 dragon + 101 xcood ! 200 ycood ! 1 14 dragon + 100 xcood ! 201 ycood ! 1 14 dragon + 101 xcood ! 201 ycood ! 1 14 dragon + 1 stepsize ! ; + +: schubs + 100 0 DO I 112 over - 400 272 2over >r 1+ r> 1- + scr>scr LOOP ; + + + +\ *** Block No. 6 Hexblock 6 +\ dragon s.5 03oct86we + +: drag ( n -- ) page + angle off 100 xcood ! 200 ycood ! + 1 swap dragon ; + +: ddemo + 16 drag schubs + 0 color ! 199 xcood ! 100 ycood ! 1 16 dragon + 1 color ! drachen ; + + + + + + +\ *** Block No. 7 Hexblock 7 +\ 03oct86we + + + + + + + + + + + + + + + diff --git a/sources/AtariST/EDIICON.FB.src b/sources/AtariST/EDIICON.FB.src deleted file mode 100644 index e4beaf1..0000000 --- a/sources/AtariST/EDIICON.FB.src +++ /dev/null @@ -1,102 +0,0 @@ -Screen 0 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 --> -Screen 1 not modified - 0 \ Definitionen aus EDIICON.H - 1 - 2 &0 >label :EDIMENU &3 >label :ATARI - 3 &4 >label :EXITS &5 >label :SCREENS - 4 &6 >label :LINES &7 >label :CHARS - 5 &8 >label :CURSOR &9 >label :SPECIALS - 6 &10 >label :HELP &13 >label :VOLKS4TH - 7 &24 >label :UPDATED &25 >label :FLUSHED - 8 &26 >label :LOADING &28 >label :UNDO - 9 &30 >label :NEXT &31 >label :BACK -10 &32 >label :SHADOW &33 >label :ALTERNAT -11 &35 >label :MARK &40 >label :BACKLINE -12 &41 >label :DELLINE &42 >label :INSLINE -13 &44 >label :CUTLINE &45 >label :PASTELIN -14 &47 >label :COPYLINE &48 >label :ERASELIN -15 &49 >label :ERASREST &52 >label :CUTCHAR --> -Screen 2 not modified - 0 \ Definitionen aus EDIICON.H - 1 - 2 &53 >label :PASTECHA &55 >label :COPYCHAR - 3 &58 >label :HOME &59 >label :TOEND - 4 &60 >label :TAB &61 >label :BACKTAB - 5 &64 >label :SEARCH &65 >label :REPEAT - 6 &67 >label :IMODE &68 >label :OMODE - 7 &72 >label :MENUHELP &73 >label :HMOUSE - 8 &74 >label :HFUNCTS &1 >label :COPYR - 9 &70 >label :GETID &2 >label :SFIND -10 &0 >label :HEXCANCL &1 >label :HEXUPDAT -11 &2 >label :HEXSAVE &3 >label :HEXLOAD -12 &4 >label :HEXUNDO &5 >label :HSCNEXT -13 &6 >label :HSCBACK &7 >label :HSCSHADO -14 &8 >label :HSCALTER &9 >label :HSCMARK -15 &10 >label :HLIBACK &11 >label :HLIDEL --> -Screen 3 not modified - 0 \ Definitionen aus EDIICON.H - 1 - 2 &12 >label :HLIINS &14 >label :HLICUT - 3 &15 >label :HLIPASTE &16 >label :HLICOPY - 4 &17 >label :HLIERASE &18 >label :HLIREST - 5 &19 >label :HCHCUT &20 >label :HCHPASTE - 6 &21 >label :HCHCOPY &22 >label :HCUHOME - 7 &23 >label :HCUEND &24 >label :HCUTABR - 8 &25 >label :HCUTABL &26 >label :HSPFIND - 9 &3 >label :FBOX &8 >label :DFMATCH -10 &9 >label :DFIGNORE &2 >label :DF1ST -11 &1 >label :DFLAST &12 >label :DFCANCEL -12 &14 >label :DFFIND &13 >label :DFREPLAC -13 &15 >label :DFFSTRIN &16 >label :DFRSTRIN -14 &27 >label :HSPREPEA &28 >label :HSPINS -15 &29 >label :HSPOVER &30 >label :HSPGETID --> -Screen 4 not modified - 0 \ Definitionen aus EDIICON.H - 1 - 2 &31 >label :HHEMENU &4 >label :SGETID - 3 &13 >label :HLISPLIT &32 >label :HHEMOUSE - 4 &33 >label :HHEF1F10 &2 >label :FBOXYES - 5 &3 >label :FBOXNO &4 >label :FBOXCANC - 6 &1 >label :IDTEXT &5 >label :IDOK - 7 &4 >label :NOID &3 >label :IDCANCEL - 8 &4 >label :DFLEFT &5 >label :DFRIGHT - 9 &5 >label :SGETSCR &1 >label :SCRNR -10 &2 >label :SGOK &3 >label :SGCANCEL -11 &36 >label :JUMP &23 >label :CANCELED -12 &43 >label :SPLIT &37 >label :VIEW -13 &6 >label :SVIEW &2 >label :SVOK -14 &3 >label :SVCANCEL &1 >label :SVWORD -15 &34 >label :HJUMP &35 >label :HVIEW --> -Screen 5 not modified - 0 \ Definitionen aus EDIICON.H - 1 - 2 &4 >label :SVMARK &15 >label :DESKACC1 - 3 &20 >label :DESKACC6 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/EDIICON.fth b/sources/AtariST/EDIICON.fth new file mode 100644 index 0000000..07d26bd --- /dev/null +++ b/sources/AtariST/EDIICON.fth @@ -0,0 +1,102 @@ +\ *** Block No. 0 Hexblock 0 + + + + + + + + + + + + + + + + --> +\ *** Block No. 1 Hexblock 1 +\ Definitionen aus EDIICON.H + + &0 >label :EDIMENU &3 >label :ATARI + &4 >label :EXITS &5 >label :SCREENS + &6 >label :LINES &7 >label :CHARS + &8 >label :CURSOR &9 >label :SPECIALS + &10 >label :HELP &13 >label :VOLKS4TH + &24 >label :UPDATED &25 >label :FLUSHED + &26 >label :LOADING &28 >label :UNDO + &30 >label :NEXT &31 >label :BACK + &32 >label :SHADOW &33 >label :ALTERNAT + &35 >label :MARK &40 >label :BACKLINE + &41 >label :DELLINE &42 >label :INSLINE + &44 >label :CUTLINE &45 >label :PASTELIN + &47 >label :COPYLINE &48 >label :ERASELIN + &49 >label :ERASREST &52 >label :CUTCHAR --> +\ *** Block No. 2 Hexblock 2 +\ Definitionen aus EDIICON.H + + &53 >label :PASTECHA &55 >label :COPYCHAR + &58 >label :HOME &59 >label :TOEND + &60 >label :TAB &61 >label :BACKTAB + &64 >label :SEARCH &65 >label :REPEAT + &67 >label :IMODE &68 >label :OMODE + &72 >label :MENUHELP &73 >label :HMOUSE + &74 >label :HFUNCTS &1 >label :COPYR + &70 >label :GETID &2 >label :SFIND + &0 >label :HEXCANCL &1 >label :HEXUPDAT + &2 >label :HEXSAVE &3 >label :HEXLOAD + &4 >label :HEXUNDO &5 >label :HSCNEXT + &6 >label :HSCBACK &7 >label :HSCSHADO + &8 >label :HSCALTER &9 >label :HSCMARK + &10 >label :HLIBACK &11 >label :HLIDEL --> +\ *** Block No. 3 Hexblock 3 +\ Definitionen aus EDIICON.H + + &12 >label :HLIINS &14 >label :HLICUT + &15 >label :HLIPASTE &16 >label :HLICOPY + &17 >label :HLIERASE &18 >label :HLIREST + &19 >label :HCHCUT &20 >label :HCHPASTE + &21 >label :HCHCOPY &22 >label :HCUHOME + &23 >label :HCUEND &24 >label :HCUTABR + &25 >label :HCUTABL &26 >label :HSPFIND + &3 >label :FBOX &8 >label :DFMATCH + &9 >label :DFIGNORE &2 >label :DF1ST + &1 >label :DFLAST &12 >label :DFCANCEL + &14 >label :DFFIND &13 >label :DFREPLAC + &15 >label :DFFSTRIN &16 >label :DFRSTRIN + &27 >label :HSPREPEA &28 >label :HSPINS + &29 >label :HSPOVER &30 >label :HSPGETID --> +\ *** Block No. 4 Hexblock 4 +\ Definitionen aus EDIICON.H + + &31 >label :HHEMENU &4 >label :SGETID + &13 >label :HLISPLIT &32 >label :HHEMOUSE + &33 >label :HHEF1F10 &2 >label :FBOXYES + &3 >label :FBOXNO &4 >label :FBOXCANC + &1 >label :IDTEXT &5 >label :IDOK + &4 >label :NOID &3 >label :IDCANCEL + &4 >label :DFLEFT &5 >label :DFRIGHT + &5 >label :SGETSCR &1 >label :SCRNR + &2 >label :SGOK &3 >label :SGCANCEL + &36 >label :JUMP &23 >label :CANCELED + &43 >label :SPLIT &37 >label :VIEW + &6 >label :SVIEW &2 >label :SVOK + &3 >label :SVCANCEL &1 >label :SVWORD + &34 >label :HJUMP &35 >label :HVIEW --> +\ *** Block No. 5 Hexblock 5 +\ Definitionen aus EDIICON.H + + &4 >label :SVMARK &15 >label :DESKACC1 + &20 >label :DESKACC6 + + + + + + + + + + + + diff --git a/sources/AtariST/EDITOR.FB.src b/sources/AtariST/EDITOR.FB.src deleted file mode 100644 index a2d9fe0..0000000 --- a/sources/AtariST/EDITOR.FB.src +++ /dev/null @@ -1,1598 +0,0 @@ -Screen 0 not modified - 0 \\ *** Screen-Editor *** 10aug86we - 1 - 2 Dieses File enth„lt den volksFORTH - Editor. - 3 Er basiert auf dem Editor im F83 von Laxen/Perry, besitzt aber - 4 erheblich erweiterte Funktionen (Zeichen- und Zeilenstack) und - 5 ist ein vollst„ndig in GEM integrierter Fullscreen-Editor. - 6 - 7 Obwohl die Steuerung mit Maus und Menuzeile erfolgt, k”nnen - 8 ihn die 'Profis' auch vollst„ndig ber Controltasten bedienen, - 9 -10 Die Dauerhilfe-Funktion macht eine Funktionsbeschreibung ber- -11 flssig. Solange im HILFE-Menu Dauerhilfe gew„hlt ist, erscheint -12 vor der Ausfhrumg jeder Editor-Funktion ein erl„uternder Text -13 mit der M”glichkeit zum Abbruch. Dies gilt jedoch nicht, wenn -14 die Funktion per Tastendruck aufgerufen wurde. -15 -Screen 1 not modified - 0 \ Load Screen for the Editor cas20130105 - 1 - 2 Onlyforth GEM also - 3 include ediicon.fb - 4 - 5 | Variable (dx 2 (dx ! | Variable (dy 4 (dy ! - 6 | : dx (dx @ ; | : dy (dy @ ; - 7 - 8 \needs -text .( strings needed !!) abort - 9 \needs file? .( Filesystem needed !!) abort -10 include gem\supergem.fb -11 include gem\gemdefs.fb -12 include edwindow.fb -13 -14 Forth definitions -15 1 $2C +thru -Screen 2 not modified - 0 \ Editor Variable 10sep86we - 1 - 2 Variable 'scr 1 'scr ! Variable 'r# 'r# off - 3 Variable 'edifile - 4 - 5 ?head @ 1 ?head ! - 6 - 7 Variable changed Variable edistate - 8 Variable edifile - 9 Variable ycur -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ Edi move cursor with position-checking or cyclic 30aug86we - 1 - 2 : c ( n -- ) \ checks the cursor position - 3 r# @ + dup 0 b/blk uwithin 0= abort" Border!" r# ! ; - 4 - 5 \ : c ( n -- ) \ moves cyclic thru the screen - 6 \ r# @ + b/blk mod r# ! ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ Move the Editor's cursor around 08aug86we - 1 - 2 : top ( -- ) r# off ; - 3 : cursor ( -- n ) r# @ ; - 4 : t ( n -- ) c/l * cursor - c ; - 5 : line# ( -- n ) cursor c/l / ; - 6 : col# ( -- n ) cursor c/l mod ; - 7 : +t ( n -- ) line# + t ; - 8 : 'start ( -- addr ) scr @ block ; - 9 : 'cursor ( -- addr ) 'start cursor + ; -10 : 'line ( -- addr ) 'cursor col# - ; -11 : #after ( -- n ) c/l col# - ; -12 : #remaining ( -- n ) b/blk cursor - ; -13 : #end ( -- n ) #remaining col# + ; -14 -15 -Screen 5 not modified - 0 \ Move the Editors cursor 08aug86we - 1 - 2 : curup c/l negate c ; - 3 : curdown c/l c ; - 4 : curleft -1 c ; - 5 : curright 1 c ; - 6 : +tab cursor $10 / 1+ $10 * cursor - c ; - 7 : -tab cursor 8 mod negate dup 0= 8 * + c ; - 8 : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; - 9 : line# t curdown ; -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 \ buffers 14sep86we - 1 - 2 : modified ( -- ) scr @ block drop update - 3 changed @ ?exit edistate off changed on ; - 4 - 5 &84 Constant c/pad - 6 &42 Constant c/buf - 7 - 8 : 'work ( -- work-buf ) pad c/pad + ; - 9 : 'insert ( -- ins-buf ) 'work c/pad + ; -10 : 'find ( -- find-buf ) 'insert c/buf + ; -11 -12 : 'find+ ( n1 -- n2 ) 'find c@ + ; -13 -14 -15 -Screen 7 not modified - 0 \ Errorchecking 09sep86we - 1 - 2 : ?bottom ( -- ) 'start b/blk + c/l - c/l -trailing nip - 3 abort" You would lose a line" ; - 4 - 5 : ?end ( -- ) 'line c/l + 1- c@ bl - - 6 abort" You would lose a char" ; - 7 - 8 : ?range ( n -- n ) dup 0 capacity uwithin not - 9 abort" Out of range!" ; -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ Graphics for display 23aug86we - 1 - 2 : lineclr ( line# -- ) - 3 wi_x swap cheight * wi_y + - 4 over wi_width + over cheight + fbox ; - 5 - 6 : lineinsert ( line# -- ) - 7 wi_x over cheight * wi_y + - 8 wi_width over l/s 1- cheight * wi_y + swap - - 9 2over cheight + scr>scr lineclr ; -10 -11 : linedelete ( line# -- ) -12 wi_x swap 1+ cheight * wi_y + -13 wi_width over l/s cheight * wi_y + swap - -14 2over cheight - scr>scr l/s 1- lineclr ; -15 -Screen 9 not modified - 0 \ Editor-Window Title and Status-Line cas20130105 - 1 - 2 : 'workblank - 3 'work dup $sum ! dup off dup 1+ c/l blank c/l + off ; - 4 - 5 - 6 : update$ ( -- string ) - 7 scr @ updated? not IF " not updated" exit THEN " updated" ; - 8 - 9 : .edistate edistate @ ?exit edistate on 'workblank -10 " Scr # " count $add scr @ extend <# # # # #> $add -11 'work c@ 2+ 'work c! update$ count $add -12 'work 1+ wi_status ; -13 -14 -15 -Screen 10 not modified - 0 \ screen display 30aug86we - 1 - 2 : .edifile 'workblank 1 'work c! - 3 isfile@ ?dup 0= IF " DIRECT" ELSE 2- >name THEN - 4 count $add 'work count + 1+ c/l min off - 5 'work 1+ wi_title ; - 6 - 7 : 'line# ( line# -- addr count ) - 8 dup dy + dx at c/l * 'start + c/l ; - 9 -10 : .line ( line# -- ) dup lineclr 'line# -trailing type ; -11 : redisplay ( line# -- ) 'line# type ; -12 -13 -14 -15 -Screen 11 not modified - 0 \ screen display 14sep86we - 1 - 2 &18 Constant id-len - 3 Create id id-len allot id id-len erase - 4 - 5 : stamp id 1+ count 'start c/l + over - swap cmove ; - 6 : ?stamp changed @ IF stamp THEN ; - 7 - 8 - 9 : edilist edistate off changed off -10 vslide_size scr @ vslide -11 .edifile .edistate l/s 0 DO I .line LOOP ; -12 -13 : undo scr @ block drop prev @ emptybuf edilist ; -14 -15 : do_redraw hide_c wi_clear redraw_screen edilist ; -Screen 12 not modified - 0 \ Edi Variables, 23aug86we - 1 - 2 Variable (pad (pad off - 3 : memtop ( -- addr ) sp@ $100 - ; - 4 - 5 Variable chars Variable #chars - 6 : 'chars ( -- addr ) chars @ #chars @ + ; - 7 - 8 Variable lines Variable #lines - 9 : 'lines ( -- addr ) lines @ #lines @ + ; -10 -11 Variable (key -12 -13 Variable imode imode off -14 -15 -Screen 13 not modified - 0 \ Edi line handling 09aug86we - 1 - 2 : linemodified modified line# redisplay ; - 3 - 4 : clrline 'line c/l blank linemodified ; - 5 : clrright 'cursor #after blank linemodified ; - 6 - 7 : delline 'line #end c/l delete - 8 line# linedelete modified ; - 9 : backline curup delline ; -10 -11 : instline ?bottom 'line c/l over #end insert -12 line# lineinsert clrline ; -13 -14 -15 -Screen 14 not modified - 0 \ Edi line handling 09aug86we - 1 - 2 : @line 'lines memtop u> abort" line buffer full" - 3 'line 'lines c/l cmove c/l #lines +! ; - 4 - 5 : copyline @line curdown ; - 6 : line>buf @line delline ; - 7 - 8 : !line c/l negate #lines +! 'lines 'line c/l cmove - 9 linemodified ; -10 -11 : buf>line #lines @ 0= abort" line buffer empty" -12 ?bottom instline !line ; -13 -14 -15 -Screen 15 not modified - 0 \ Edi char handling 09aug86we - 1 - 2 : delchar 'cursor #after 1 delete linemodified ; - 3 : backspace curleft delchar ; - 4 - 5 : inst1 ?end 'cursor 1 over #after insert ; - 6 : instchar inst1 bl 'cursor c! linemodified ; - 7 - 8 : @char 'chars 1- lines @ u> abort" char buffer full" - 9 'cursor c@ 'chars c! 1 #chars +! ; -10 : copychar @char curright ; -11 : char>buf @char delchar ; -12 -13 : !char -1 #chars +! 'chars c@ 'cursor c! ; -14 : buf>char #chars @ 0= abort" char buffer empty" -15 inst1 !char linemodified ; -Screen 16 not modified - 0 \ from Screen to Screen ... 22oct86we - 1 - 2 : setscreen ( n -- ) ?stamp ?range scr ! edilist ; - 3 : n scr @ 1+ setscreen ; - 4 : b scr @ 1- setscreen ; - 5 - 6 : >shadow ( n1 -- n2 ) capacity 2/ 2dup < IF + ELSE - THEN ; - 7 : w scr @ >shadow setscreen ; - 8 - 9 : (mark scr @ 'scr ! r# @ 'r# ! isfile@ 'edifile ! ; -10 : mark (mark true abort" marked !" ; -11 -12 : a ?stamp 'edifile @ [ Dos ] dup searchfile drop -13 isfile@ 'edifile ! !files -14 'r# @ r# @ 'r# ! r# ! -15 'scr @ scr @ 'scr ! ?range scr ! edilist ; -Screen 17 not modified - 0 \ splitting a line, replace 17aug86we - 1 - 2 : split ?bottom pad c/l 2dup blank - 3 'cursor #remaining insert linemodified - 4 col# line# lineinsert - 5 'start cursor + c/l rot delete linemodified ; - 6 - 7 : ins 'insert count under 'cursor #after insert c ; - 8 - 9 : r -10 c/l 'line over -trailing nip - -11 'insert c@ 'find c@ - < abort" not enough room" -12 'find c@ dup negate c 'cursor #after rot delete ins -13 linemodified ; -14 -15 -Screen 18 not modified - 0 \ find und search 30aug86we - 1 - 2 : >last? ( -- f ) :dfright state_gaddr l@ 1 and ; - 3 : >last :dfright select :dfleft deselect ; - 4 : >1st :dfleft select :dfright deselect ; - 5 - 6 Variable fscreen - 7 - 8 : find? ( - n f ) 'find count 'cursor #remaining search ; - 9 -10 : s BEGIN find? IF 'find+ c edilist exit THEN drop -11 fscreen @ scr @ - ?dup stop? 0= and -12 WHILE 0< IF -1 ELSE 1 THEN scr +! top scr @ vslide -13 REPEAT :sfind tree! -14 >last? IF >1st :df1st ELSE >last :dflast THEN -15 getnumber drop fscreen ! edilist true abort" not found" ; -Screen 19 not modified - 0 \ Search-Findbox auswerten 24aug86we - 1 - 2 : initfind ( -- ) - 3 :dfmatch select :dfignore deselect >last - 4 1 extend :df1st putnumber - 5 capacity 1- extend :dflast putnumber ; - 6 - 7 : getfind ( -- n ) - 8 :dfignore state_gaddr l@ 1 and caps ! - 9 >last? IF :dflast ELSE :df1st THEN getnumber drop -10 capacity 1- min -11 :dffstrin 'find getstring :dfrstrin 'insert getstring ; -12 -13 : do_fbox ( -- button ) :sfind tree! -14 edifile @ isfile@ - IF isfile@ edifile ! initfind THEN -15 show_object :dffstrin form_do dup deselect hide_object ; -Screen 20 not modified - 0 \ Replacing ... 24aug86we - 1 - 2 Variable ?replace - 3 - 4 : show_replace ( -- ) - 5 &320 &200 &10 &10 little 4! - 6 col# dx + 2- cwidth * line# dy + 1+ cheight * - 7 2dup 0 objc_setpos 0 objc_getwh big 4! - 8 big 4@ scr>mem1 1 little 4@ big 4@ form_dial - 9 0 ( install) 3 ( depth) big 4@ objc_draw show_c ; -10 -11 : replace ( -- ) -12 :fbox tree! BEGIN -13 show_replace 0 form_do dup deselect hide_object -14 dup :fboxcanc - WHILE :fboxyes = IF r THEN s -15 REPEAT drop ; -Screen 21 not modified - 0 \ Editor's find and replace 24aug86we - 1 - 2 Variable (findbox (findbox off - 3 - 4 : repfind ( -- ) - 5 (findbox @ 'find c@ and 0= abort" use find first" - 6 ?stamp fscreen @ capacity 1- min fscreen ! - 7 s ?replace @ IF replace THEN ; - 8 - 9 : edifind ( -- ) -10 do_fbox :dfcancel case? ?exit -11 :dfreplac = ?replace swap IF on ELSE off THEN -12 :edimenu tree! :repeat 1 menu_ienable (findbox on -13 :sfind tree! getfind fscreen ! repfind ; -14 -15 -Screen 22 not modified - 0 \ exiting the Editor 30aug86we - 1 - 2 Defer resetmouse - 3 - 4 : done ( ff addr -- tf ) - 5 :edimenu tree! 0 menu_bar resetmouse hide_c - 6 wi_close ycur @ 0 at cr ." Scr #" scr @ 3 .r 2 spaces - 7 count type true ; - 8 - 9 : cdone ( ff -- tf ) prev @ emptybuf " canceled" done ; -10 : sdone ( ff -- tf ) ?stamp save-buffers " saved" done ; -11 : xdone ( ff -- tf ) ?stamp update$ done ; -12 : ldone ( ff -- tf ) drop true -13 ?stamp save-buffers " loading" done ; -14 -15 -Screen 23 not modified - 0 \ get User's ID, jump to screen 24aug86we - 1 - 2 : do_getid - 3 :sgetid tree! id 1+ :idtext putstring - 4 show_object :idtext form_do dup deselect hide_object - 5 :idcancel case? ?exit - 6 :noid = IF id off exit THEN - 7 :idtext id 1+ getstring ; - 8 - 9 : get-id -10 id c@ ?exit 1 id c! do_getid ; -11 -12 : jumpscreen :sgetscr tree! -13 pad dup off :scrnr putstring -14 show_object :scrnr form_do dup deselect hide_object -15 :sgcancel = ?exit :scrnr getnumber drop setscreen ; -Screen 24 not modified - 0 \ insert- and overwrite-mode 24aug86we - 1 - 2 : mark_item ( item# -- ) 1 menu_icheck ; - 3 : clr_item ( item# -- ) 0 menu_icheck ; - 4 - 5 : setimode imode on :edimenu tree! - 6 :imode mark_item :omode clr_item ; - 7 : clrimode imode off :edimenu tree! - 8 :omode mark_item :imode clr_item ; - 9 -10 -11 -12 -13 -14 -15 -Screen 25 not modified - 0 \ viewing words 24aug86we - 1 - 2 : >view ( -- ) - 3 'find count pad place pad capitalize bl pad count + c! - 4 find 0= abort" Haeh?" - 5 >name ?dup 0= abort" no view-field" - 6 4- @ ?dup 0= abort" hand made" - 7 (view scr ! top curdown find? 0= IF drop exit THEN - 8 'find+ c ; - 9 -10 : do_view ( -- ) -11 :sview tree! pad dup off :svword putstring -12 show_object :svword form_do dup deselect hide_object -13 :idcancel case? ?exit -14 :svword 'find getstring :svmark = IF (mark THEN -15 >view edilist ; -Screen 26 not modified - 0 \ Table of keystrokes 10aug86we - 1 - 2 Create keytable - 3 $4800 0 , , $4B00 0 , , $5000 0 , , $4D00 0 , , - 4 $4838 1 , , $4B34 1 , , $5032 1 , , $4D36 1 , , - 5 $5000 2 , , $7400 2 , , - 6 $0E08 0 , , $537F 0 , , $5200 0 , , $240A 2 , , - 7 $0E08 1 , , $537F 1 , , $5230 1 , , $6100 0 , , - 8 $1709 2 , , $180F 2 , , $1205 2 , , $531F 2 , , - 9 $1C0D 0 , , $1C0D 1 , , $0F09 0 , , $0F09 1 , , -10 $4700 0 , , $4737 1 , , $2207 2 , , $2F16 2 , , -11 $2106 2 , , $1312 2 , , $320D 2 , , -12 $011B 0 , , $1F13 2 , , $2D18 2 , , $260C 2 , , -13 $310E 2 , , $3002 2 , , $1E01 2 , , $1117 2 , , -14 -15 here keytable - 2/ 2/ Constant #keys -Screen 27 not modified - 0 \ Table of actions 11aug86we - 1 - 2 Create actiontable ] - 3 curup curleft curdown curright - 4 line>buf char>buf buf>line buf>char - 5 copyline copychar - 6 backspace delchar instchar jumpscreen - 7 backline delline instline undo - 8 setimode clrimode clrline clrright - 9 split +tab -tab -10 top >""end do_getid do_view -11 edifind repfind mark -12 cdone sdone xdone ldone -13 n b a w -14 -15 [ here actiontable - 2/ #keys - abort( # of actions) -Screen 28 not modified - 0 \ Table of Menuevents 24aug86we - 1 - 2 Create menutable - 3 $FF c, $FF c, $FF c, $FF c, - 4 :cutline c, :cutchar c, :pastelin c, :pastecha c, - 5 :copyline c, :copychar c, - 6 $FF c, $FF c, $FF c, :jump c, - 7 :backline c, :delline c, :insline c, :undo c, - 8 :imode c, :omode c, :eraselin c, :erasrest c, - 9 $FF c, :split c, :tab c, :backtab c, -10 :home c, :toend c, :getid c, :view c, -11 :search c, :repeat c, :mark c, -12 :canceled c, :flushed c, :updated c, :loading c, -13 :next c, :back c, :alternat c, :shadow c, -14 -15 here menutable - #keys - abort( # of menuitems) -Screen 29 not modified - 0 \ Table of Help-Boxes 24aug86we - 1 - 2 Create helptable - 3 $FF c, $FF c, $FF c, $FF c, - 4 :hlicut c, :hchcut c, :hlipaste c, :hchpaste c, - 5 :hlicopy c, :hchcopy c, - 6 $FF c, $FF c, $FF c, :hjump c, - 7 :hliback c, :hlidel c, :hliins c, :hexundo c, - 8 :hspins c, :hspover c, :hlierase c, :hlirest c, - 9 $FF c, :hlisplit c, :hcutabr c, :hcutabl c, -10 :hcuhome c, :hcuend c, :hspgetid c, :hview c, -11 :hspfind c, :hsprepea c, :hscmark c, -12 :hexcancl c, :hexsave c, :hexupdat c, :hexload c, -13 :hscnext c, :hscback c, :hscalter c, :hscshado c, -14 -15 here helptable - #keys - abort( # of menuitems) -Screen 30 not modified - 0 \ Prepare multi-event 09sep86we - 1 - 2 Variable mflag mflag off - 3 - 4 : ediprepare - 5 %00110111 - 6 1 1 1 - 7 mflag @ - 8 dx cwidth * dy cheight * c/l cwidth * l/s cheight * - 9 0 0 0 0 0 -10 0 0 -11 intin $10 array! message >absaddr addrin 2! ; -12 -13 ' pause | Alias ev-timer -14 : ev-r1 1 mflag 1+ ctoggle ; -15 -Screen 31 not modified - 0 \ Button Event 24aug86we - 1 - 2 Variable ?cursor ?cursor off - 3 - 4 : curon ?cursor @ ?exit ?cursor on - 5 3 swr_mode 1 sf_color 1 sf_interior 0 sf_perimeter - 6 at? cwidth * swap cheight * - 7 over cwidth 1- + over cheight + 1- bar ; - 8 - 9 : curoff ?cursor off curon ?cursor off ; -10 -11 : ev-button mflag @ 0= ?exit -12 intout 4+ @ cheight / dy - c/l * -13 intout 2+ @ cwidth / dx - + r# ! hide_c curoff ; -14 -15 -Screen 32 not modified - 0 \ Key event 17aug86we - 1 - 2 : visible? ( key -- f ) $FF and ; - 3 - 4 : putchar ( -- ) - 5 (key @ dup visible? 0= abort" What?" - 6 imode @ IF inst1 THEN 'cursor c! linemodified curright ; - 7 - 8 : findkey ( d_key -- addr ) - 9 ['] putchar -rot -10 #keys 0 DO 2dup keytable I 2* 2* + 2@ d= -11 IF rot drop actiontable I 2* + @ -rot LEAVE THEN -12 LOOP 2drop ; -13 -14 -15 -Screen 33 not modified - 0 \ Key event 23aug86we - 1 - 2 Variable jingle jingle on - 3 Variable ?mouse - 4 - 5 : edit-at cursor c/l /mod dy + swap dx + at ; - 6 - 7 : ev-key ?mouse off - 8 intout &10 + dup @ dup (key ! hide_c edit-at curoff - 9 swap 2- @ dup 1 and + 2/ findkey execute -10 jingle on .edistate BEGIN getkey 0= UNTIL ; -11 -12 -13 -14 -15 -Screen 34 not modified - 0 \ Message events for window 30aug86we - 1 - 2 : getmessage ( n -- n' ) 2* message + @ ; - 3 - 4 : wm_arrowed - 5 4 getmessage 1 and IF n exit THEN b ; - 6 - 7 : wm_vslide - 8 4 getmessage capacity 1- &1000 */ setscreen ; - 9 -10 : wm_moved -11 4 getmessage cwidth / 1 max &14 min (dx ! -12 5 getmessage cheight / 1 max 5 min 3 + (dy ! -13 wi_handle @ 5 wi_size wind_set redraw_screen ; -14 -15 -Screen 35 not modified - 0 \ Message events (the menuline) 02sep86we - 1 - 2 Variable ?help ?help on - 3 - 4 : do_help ( n -- ) - 5 helptable + c@ alert 1 = ?exit - 6 true abort" Dann eben nicht !!" ; - 7 - 8 : do_copyr :copyr tree! - 9 show_object 0 form_do deselect hide_object ; -10 -11 : do_menuhelp show_c :hhemenu alert hide_c -12 :edimenu tree! 1 and :menuhelp over menu_icheck -13 ?help ! ; -14 -15 -Screen 36 not modified - 0 \ Message events from menuline 02sep86we - 1 - 2 : do_other ( -- ) 4 getmessage - 3 :menuhelp case? IF do_menuhelp exit THEN - 4 :hmouse case? IF :hhemouse alert drop exit THEN - 5 :hfuncts case? IF :hhef1f10 alert drop exit THEN - 6 drop do_copyr ; - 7 - 8 : menu-message ( -- ) message @ :mn_selected - ?exit - 9 :edimenu tree! 3 getmessage 1 menu_tnormal -10 ['] do_other 4 getmessage -11 #keys 0 DO dup menutable I + c@ = -12 IF ?help @ IF I do_help THEN -13 nip actiontable I 2* + @ swap LEAVE THEN -14 LOOP drop execute jingle on .edistate ; -15 -Screen 37 not modified - 0 \ Handle message-event 24aug86we - 1 - 2 : ev-message hide_c edit-at curoff - 3 message @ :mn_selected case? IF menu-message exit THEN - 4 :wm_arrowed case? IF wm_arrowed exit THEN - 5 :wm_vslid case? IF wm_vslide exit THEN - 6 :wm_moved case? IF wm_moved exit THEN - 7 :wm_redraw case? IF do_redraw exit THEN - 8 drop ; - 9 -10 -11 -12 -13 -14 -15 -Screen 38 not modified - 0 \ Handle all events 30aug86we - 1 - 2 Create ev-flag - 3 :mu_mesag c, :mu_m1 c, :mu_button c, - 4 :mu_keybd c, :mu_timer c, - 5 - 6 Create: event-actions - 7 ev-message ev-r1 ev-button ev-key ev-timer ; - 8 - 9 : handle-events ( which -- ) -10 5 0 DO ev-flag I + c@ over and IF drop I LEAVE THEN LOOP -11 2* event-actions + perform ; -12 -13 -14 -15 -Screen 39 not modified - 0 \ Change mouse-movement Vector 10sep86we - 1 - 2 2Variable savevec - 3 - 4 Create newvector Assembler - 5 ?mouse pcrel) A0 lea true # A0 ) move - 6 .l savevec pcrel) A0 move A0 ) jmp end-code - 7 - 8 Code ?show_c ?mouse R#) tst 0= IF Next THEN ;c: show_c ; - 9 -10 : ex_motv ( pusrcode -- ) -11 contrl &14 + 2! &126 0 0 VDI contrl &18 + 2@ savevec 2! ; -12 -13 : setmousevec newvector >absaddr ex_motv ; -14 : resetmousevec savevec 2@ ex_motv ; -15 ' resetmousevec Is resetmouse -Screen 40 not modified - 0 \ The Editor's LOOP 02sep86we - 1 - 2 : ediloop r0 @ rp! - 3 BEGIN edit-at curon ?show_c false - 4 ediprepare evnt_multi handle-events UNTIL ; - 5 - 6 : alarm bell jingle off ; - 7 - 8 : edierror ( string -- ) - 9 jingle @ 0= IF drop ediloop THEN alarm -10 'workblank c/l 2/ 'work c! count c/l 2/ min $add -11 'work 1+ wi_status edistate off ediloop ; -12 -13 -14 -15 -Screen 41 not modified - 0 \ Installing the Editor 20nov86we - 1 - 2 Create ediresource &12 allot - 3 Variable edihandle - 4 - 5 : setediresource ediresource ap_ptree &12 cmove ; - 6 - 7 : ?clearbuffer - 8 pad (pad @ = ?exit pad (pad ! - 9 'find b/blk + dup chars ! c/l 2* + lines ! -10 #chars off #lines off 'find off 'insert off (findbox off ; -11 -12 -13 -14 -15 -Screen 42 not modified - 0 \ Installing the Editor 20nov86we - 1 - 2 : finstall ( -- ) - 3 pad memtop u> abort" No room for buffers!" - 4 get-id changed off row ycur ! setmousevec - 5 ?clearbuffer ?cursor off - 6 ap_ptree &12 cpush setediresource - 7 grhandle push edihandle @ grhandle ! - 8 wi_open :edimenu tree! 1 menu_bar - 9 errorhandler push ['] edierror errorhandler ! -10 r0 push rp@ r0 ! ediloop ; -11 -12 -13 -14 -15 -Screen 43 not modified - 0 \ Entering the Editor 11sep86we - 1 - 2 Forth definitions ?head ! - 3 - 4 | : ?load 0= ?exit scr @ r# @ (load ; - 5 - 6 : v ( -- ) scr @ ?range drop finstall ?load ; - 7 - 8 : l ( scr -- ) 1 arguments ?range scr ! top v ; - 9 -10 | : >find bl word count 'find place ; -11 -12 : view ( -- ) >find >view v ; -13 -14 -15 -Screen 44 not modified - 0 \ Init the Editor for different resolutions 18sep86we - 1 - 2 | : q_extnd ( info_flag -- ) intin ! &102 0 1 VDI ; - 3 - 4 | : setMFDB ( addr_of_MFDB -- ) >r - 5 0 q_extnd intout 2@ r@ 4+ 2! intout @ $10 / r@ 6 + ! - 6 1 q_extnd intout 8 + @ r> &12 + ! ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 45 not modified - 0 \ save-system for Editor cas20130105 - 1 - 2 | : edistart grinit rsrc_load" ediicon.rsc" 0 graf_mouse - 3 grhandle @ edihandle ! ap_ptree ediresource &12 cmove - 4 memMFDB1 setMFDB memMFDB2 setMFDB - 5 ['] noop [ ' drvinit >body ] Literal ! ; - 6 - 7 : bye grexit bye ; grinit - 8 - 9 : save-system id off r# off 1 scr ! 'r# off 1 'scr ! -10 (findbox off (pad off -11 ['] edistart [ ' drvinit >body ] Literal ! -12 [ ' forth83.fb >body ] Literal 'edifile ! -13 flush save-system bye ; -14 -15 -Screen 46 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 47 not modified - 0 \\ *** Screen-Editor *** 17aug86we - 1 - 2 In den Editor gelangt man mit l ( Screen-Nr. -- ), mit v oder - 3 view. view verlangt als weitere Eingabe ein FORTH-Wort und - 4 sucht dann den Screen, auf dem das Wort definiert wurde. - 5 - 6 Alle Eingaben werden unmittelbar in den Blockbuffer geschrieben, - 7 der den aktuellen Screen enth„lt. - 8 - 9 Die Position des Cursors h„ngt von 2 Variablen ab: -10 scr enth„lt die Nummer des aktuellen Screens; -11 r# bestimmt die Position des Cursors. -12 Beides sind Systemvariable, die auch beim Compilieren benutzt -13 werden. Bei Abbruch wegen eines Fehlers ruft man den Editor mit -14 v auf. Der Cursor steht hinter dem Wort, das den Abbruch -15 ausgel”st hat. -Screen 48 not modified - 0 \ Load Screen for the Editor 24aug86we - 1 - 2 bindet Vocabulary GEM mit in die Suchreihenfolge ein. - 3 Labels fr Editor-Resource - 4 - 5 (dx und (dy sind Variable, die die Lage des Editorfensters - 6 relativ zur linken oberen Ecke des Bildschirms angeben. - 7 Der Editor ben”tigt einige Definitionen aus anderen Files. - 8 - fr die Suchfunktionen. - 9 - falls kein File-Interface vorhanden ist. -10 - fr das Fenster -11 Labels fr Gem-Aufrufe -12 -13 -14 -15 -Screen 49 not modified - 0 \ Editor Variable 26oct86we - 1 - 2 Screen-Nr. und Cursorposition vom markierten Screen - 3 File fr markierten Screen - 4 - 5 Alle folgenden Definitionen werden headerless compiliert. - 6 - 7 Flag fr Žnderungen am Screen; Flag, ob Statuszeile neu ge- - 8 File, das editiert wird schrieben werden muž - 9 ycur ist die Cursorposition beim Aufruf des Editors -10 -11 -12 -13 -14 -15 -Screen 50 not modified - 0 \ Edi move cursor with position-checking or cyclic 30aug86we - 1 - 2 bewegt den Cursor um n Stellen vor- bzw. rckw„rts. - 3 Wird der Cursor ber Anfang oder Ende des Screens hinausbewegt, - 4 stehen zwei M”glichkeiten zur Wahl: - 5 - Kommando wird nicht ausgefhrt. - 6 - Der Screen wird zyklisch durchlaufen. - 7 - 8 W„hlen Sie durch 'Wegkommentieren' und Neucompilieren des - 9 Editors. -10 -11 -12 -13 -14 -15 -Screen 51 not modified - 0 \ Move the Editor's cursor around 05aug86we - 1 - 2 setzt Cursor in die obere linke Ecke (Home). - 3 n ist die aktuelle Position des Cursors (Offset von Home) - 4 setzt Cursor auf Beginn der Zeile n. - 5 n ist die Zeile, in der der Cursor steht. - 6 n ist die Spalte, in der der Cursor steht. - 7 bewegt Cursor um n Zeilen vor- bzw. rckw„rts auf Zeilenanfang. - 8 addr ist die Anfangsadresse des aktuellen Blocks im Speicher. - 9 addr ist die der Cursorposition entsprechende Speicheradresse. -10 addr ist die Speicheradresse des Beginns der Cursorzeile. -11 n ist die Stellenanzahl zwischen Cursorposition und Zeilenende. -12 n ist die Stellenanzahl zwischen Cursorposition und Blockende. -13 n ist die Stellenanzahl zwischen Cursorzeile und Blockende. -14 -15 -Screen 52 not modified - 0 \ Move the Editors cursor 07aug86we - 1 - 2 setzt Cursor um eine Zeile nach oben. - 3 setzt Cursor um eine Zeile nach unten. - 4 setzt Cursor um ein Zeichen nach links. - 5 setzt Cursor um ein Zeichen nach rechts. - 6 setzt Cursor um eine Tabulatorposition nach vorn (s.unten). - 7 setzt Cursor um eine Tabulatorposition zurck (s.unten). - 8 setzt Cursor auf das letzte Zeichen des Screens. - 9 setzt Cursor auf Beginn der n„chsten Zeile. -10 -11 -12 Vorw„rtstabs: -13 + + + + -14 Rckw„rtstabs: -15 - - - - - - - - -Screen 53 not modified - 0 \ buffers 24aug86we - 1 - 2 markiert einen ge„nderten Block zum Zurckschreiben auf Disk - 3 setzt Flag fr ?stamp und l”scht Flag fr .edistate - 4 - 5 Byteanzahl in PAD (min. &84 nach 83-Standard!). - 6 Byteanzahl in einem Buffer (&40 durch Resource vorgegeben). - 7 - 8 'work, 'insert und 'find sind Buffer, die beim Aufruf des - 9 Editors oberhalb von PAD eingerichtet werden. -10 'work dient zur Aufbreitung von Strings fr die Statuszeile -11 'find enth„lt den Suchstring und 'insert den Replacestring. -12 n2 ist n1 zuzglich der L„nge des Findbuffers. -13 -14 -15 -Screen 54 not modified - 0 \ Errorchecking 17aug86we - 1 - 2 bricht ab, wenn beim Einfgen einer Zeile kein Platz mehr ist. - 3 - 4 - 5 bricht ab, wenn beim Einfgen eines Zeichens kein Platz mehr ist - 6 - 7 - 8 bricht ab, wenn ein Screen aužerhalb des aktuellen Files edi- - 9 tiert werden soll. -10 -11 -12 -13 -14 -15 -Screen 55 not modified - 0 \ Graphics for display 23aug86we - 1 - 2 l”scht Zeile n durch šberschreiben mit einem weižen Rechteck - 3 x - und y - Koordinate der linken oberen Ecke - 4 x - und y - Koordinate der rechten unteren Ecke - 5 - 6 fgt auf dem Bildschirm an der Cursorposition eine Leerzeile ein - 7 x - und y - Koordinate des zu verschiebenden Rechtecks - 8 Breite setzen und H”he berechnen - 9 x - und y - Koordinate des Zielrechtecks ( 1 Zeile tiefer ) -10 das ganze mit Pixelmove (schnell) verschieben und Zeile l”schen -11 l”scht auf dem Bildschirm die Cursorzeile -12 x - und y - Koordinate des zu verschiebenden Rechtecks -13 Breite setzen und H”he berechnen -14 x - und y - Koordinate des Zielrechtecks ( 1 Zeile h”her ) -15 das ganze mit Pixelmove verschieben und unterste Zeile l”schen -Screen 56 not modified - 0 \ Editor-Window Title and Status-Line 30aug86we - 1 - 2 setzt 'work als Arbeitsspeicher und l”scht ihn; 0 als Abschluž - 3 - 4 - 5 f ist true, wenn der aktuelle Screen als updated markiert ist. - 6 - 7 bergibt in Abh„ngigkeit vom Updatezustand den richtigen String. - 8 - 9 -10 Statuszeile wird nur beschrieben, wenn sich etwas ver„ndert hat. -11 Screennummer wird in 'work zusammengestellt, -12 2 Leerzeichen und dann die Updatemeldung. -13 das Ganze wird an .wi_state als 0-terminated String bergeben. -14 -15 -Screen 57 not modified - 0 \ screen display 30aug86we - 1 - 2 gibt den Filenamen in der Titelzeile aus; 'work l”schen - 3 Adresse des Strings, der den Filenamen enth„lt, ermitteln - 4 und nach 'work bringen, maximal eine Zeile, Leerzeichen am Ende - 5 als 0-terminated String an wi_title bergeben. - 6 - 7 berechnet die Speicheradresse von Zeile line#, - 8 setzt Cursor und bereitet die Parameter fr type auf. - 9 -10 l”scht Zeile line# und gibt sie dann aus (schnell!!). -11 gibt Zeile line# neu aus (langsam, aber ohne Flackern). -12 -13 -14 -15 -Screen 58 not modified - 0 \ screen display 14sep86we - 1 - 2 maximale L„nge der User-ID, die automatisch in die obere rechte - 3 Ecke des Screens gesetzt wird, wenn dieser ge„ndert wurde. - 4 - 5 setzt ID rechtsbndig (!) in die erste Zeile. - 6 setzt ID, wenn der aktuelle Screen ver„ndert wurde. - 7 - 8 - 9 gibt einen Screen im Editorfenster aus. Flags fr ?stamp und -10 vertikaler Slider wird auf richtige Gr”že und Position gesetzt -11 .edistate werden zurckgesetzt. -12 -13 l”scht den aktuellen Buffer und erzwingt so Neueinlesen von Disk -14 Der Blockzugriff ist fr Multitasking n”tig. -15 zeichnet den gesamten Bildschirm neu (nach Accessory-Aufruf). -Screen 59 not modified - 0 \ Edi Variables, putchar 17aug86we - 1 - 2 Adresse von PAD beim Editieren fr ?clearbuffer. - 3 Obergrenze fr Zeichen- (128 Zeichen) und Zeilenbuffer, der - 4 oberhalb von PAD bis zur Speichergrenze reicht - 5 Adresse des Zeichenbuffers Anzahl der Zeichen im Buffer - 6 liefert die n„chste freie Adresse im Zeichenbuffer. - 7 - 8 Adresse des Zeilenbuffers Anzahl der Zeilen im Buffer - 9 liefert die n„chste freie Adresse im Zeilenbuffer. -10 -11 speichert das zuletzt eingegebene Zeichen. -12 -13 Insertmodus, voreingestellt aus -14 -15 -Screen 60 not modified - 0 \ Edi line handling 17aug86we - 1 - 2 erneuert gerade bearbeitete Zeile auf dem Bildschirm; setzt Flag - 3 fr ?stamp. - 4 l”scht die Cursorzeile. - 5 l”scht vom Cursor bis zum Zeilenende. - 6 - 7 l”scht Cursorzeile und zieht Rest des Bildschirms nach oben. - 8 - 9 l”scht Zeile ber dem Cursor und zieht Rest des Bildschirms nach -10 oben. -11 fgt an der Cursorposition eine Leerzeile ein; Rest des Bild- -12 schirms wird nach unten geschoben. -13 -14 -15 -Screen 61 not modified - 0 \ Edi line handling 17aug86we - 1 - 2 prft, ob Platz im Zeilenbuffer vorhanden ist, und kopiert - 3 eine Zeile in den Zeilenbuffer. - 4 - 5 kopiert eine Zeile in den Buffer, setzt Cursor auf die n„chste. - 6 kopiert eine Zeile in den Buffer und l”scht sie. - 7 - 8 setzt aus dem Zeilenbuffer eine Zeile in der Cursorzeile ein. - 9 -10 -11 benutzt !line, prft vorher, ob Zeilen im Buffer sind. -12 Fr die neue Zeile wird zuerst eine Leerzeile eingefgt. -13 -14 -15 -Screen 62 not modified - 0 \ Edi char handling 17aug86we - 1 - 2 l”scht Zeichen unter dem Cursor. - 3 l”scht Zeichen links neben dem Cursor. - 4 - 5 fgt an der Cursorposition ein Zeichen im Buffer ein. - 6 benutzt inst1, um ein Leerzeichen einzufgen. - 7 - 8 analog zu @line, kopiert ein Zeichen in den Zeichenbuffer. - 9 -10 kopiert ein Zeichen in den Buffer, setzt Cursor auf das n„chste. -11 kopiert ein Zeichen in den Buffer und l”scht es. -12 -13 analog zu !line, setzt ein Zeichen aus dem Buffer bei Cursor ein -14 benutzt !char, prft vorher, ob Zeichen im Buffer sind. -15 Fr das neue Zeichen wird zuerst ein Leerzeichen eingefgt. -Screen 63 not modified - 0 \ from Screen to Screen ... 24aug86we - 1 - 2 prft, ob der angeforderte Screen vorhanden ist und gibt ihn aus - 3 geht auf den n„chsten Screen. - 4 geht auf den vorherigen Screen. - 5 - 6 berechnet zu Screen n1 den Shadow-Screen n2 oder umgekehrt. - 7 schaltet zwischen Original und Shadow hin und her. - 8 - 9 markiert den aktuellen Screen mit File und Cursorposition. -10 s.o., jedoch mit Meldung. -11 -12 vertauscht aktuellen und markierten Screen. Dabei wird auch das -13 File mitbercksichtigt. Dies erlaubt es, nach VIEW einen mar- -14 kierten Screen wieder zu benutzen. -15 -Screen 64 not modified - 0 \ splitting a line, replace 17aug86we - 1 - 2 setzt den Rest der Zeile ab Cursor auf den Anfang einer neu - 3 eingefgten Zeile. Dazu wird erst eine komplette leere Zeile - 4 eingefgt und dann von Cursorspalte bis Anfang der neuen - 5 Zeile gel”scht. - 6 - 7 fgt den Insert-Buffer an der Cursorposition ein. - 8 - 9 ersetzt den gefundenen String durch den Insert-Buffer. -10 berechnet Anzahl der Leerzeichen am Ende der Zeile. -11 Abbruch, wenn weniger als Differenz zwischen Find und Insert, -12 sonst Findstring l”schen und Insert-Buffer einfgen -13 -14 -15 -Screen 65 not modified - 0 \ find und search 30aug86we - 1 - 2 f ist 1, wenn in Richtung last Screen gesucht wird, sonst 1. - 3 schaltet Button in der Findbox auf Suche Richtung last screen. - 4 schaltet Button in der Findbox auf Suche Richtung 1st screen. - 5 - 6 Der Screen, bis zu dem gesucht werden soll - 7 - 8 sucht von Cursor bis Screenende; n ist Offset zu Cursorposition. - 9 -10 sucht von Cursor bis Screen fscreen vorw„rts oder rckw„rts. -11 solange bis fscreen erreicht ist oder Esc oder CTRL-C gedrckt, -12 wird der n„chste Screen aufgerufen. -13 Abbruch, falls nicht gefunden und Umschalten der Suchrichtung -14 in der Box und in fscreen. -15 Screen auflisten und Abbruchmeldung ausgeben. -Screen 66 not modified - 0 \ Search-Findbox auswerten 17aug86we - 1 - 2 Vorbelegung der Buttons und Screennummern in der Find-box: - 3 Grož-Kleinschreibung unterscheiden. - 4 Aufsteigend suchen bis Fileende. - 5 1 fr 1st Screen, letzten Screen im File als Last Screen - 6 - 7 Filebox auswerten: - 8 Variable caps entsprechend setzen. - 9 Suchrichtung bestimmt, ob der erste oder letzte Screen -10 als Endscreen benutzt wird. -11 Strings in die entsprechenden Buffer bernehmen. -12 -13 Falls das File gewechselt wurde, neu initialisieren, geschieht -14 auch automatisch, wenn sich PAD und damit Find- und Insert- -15 buffer ver„ndert haben. -Screen 67 not modified - 0 \ Replacing ... 17aug86we - 1 - 2 Flag fr Ersetzen des Find-Strings durch den Insert-String - 3 - 4 O Schreck und Graus !!! - 5 Die Replace-Box soll natrlich nicht den gefundenen String - 6 verdecken; die von form_center gelieferten Werte sind also - 7 unbrauchbar. X- und Y-Position mssen von Hand berechnet werden - 8 und zwar so, daž die linke obere Ecke der Box auf den Such- - 9 string zeigt; zeichnen des Objects wie in show_object. -10 -11 ersetzt solange den Suchstring durch den Insertstring, bis -12 CANCEL gedrckt oder der Suchstring nicht gefunden wird. -13 Abbruch auch, wenn der Insertstring sich nicht einsetzen l„žt. -14 Sonst wie bei Find Abbruch mit Esc. oder CTRL-C m”glich. -15 -Screen 68 not modified - 0 \ Editor's find and replace 17aug86we - 1 - 2 Flag fr repfind, ob bereits eine Suche stattgefunden hat. - 3 - 4 fhrt erneute Suche (und Ersetzen) durch ohne Find-Box. - 5 Abbruch, wenn noch kein Aufruf der Find-Box oder Findbuffer - 6 leer; sonst sicherstellen, daž fscreen innerhalb des Files - 7 liegt und s bzw replace ausfhren. - 8 - 9 Das ist das aufrufende Wort; im CANCEL-Fall abbrechen, -10 sonst Flag fr replace setzen, wenn :dfreplac gew„hlt wurde -11 Im Menubalken Repeatfind enable'n -12 Screennummer merken; suchen und ggf. ersetzen mit repfind. -13 -14 -15 -Screen 69 not modified - 0 \ exiting the Editor 30aug86we - 1 - 2 Setzt Mausvector zurck, wird erst sp„ter definiert. - 3 - 4 gemeinsame Routine fr alle Exits - 5 l”scht (und restauriert) das Fenster, setzt Mausvector zurck - 6 gibt an der alten Cursorpositione eine Meldung aus - 7 und setzt Flag zum Verlassen von ediloop. - 8 - 9 wirft alle Žnderungen weg, falls man sich 'vereditiert' hat. -10 speichert den Screen auf Disk, falls er ver„ndert wurde. -11 markiert den Screen, ohne ihn direkt zurckzuschreiben. -12 speichert den Screen auf Disk, falls er ver„ndert wurde -13 und compiliert ab Cursorposition. -14 -15 -Screen 70 not modified - 0 \ get User's ID, jump to screen 17aug86we - 1 - 2 User-ID holen - 3 bisherige ID im Fenster ausgeben - 4 das bliche form-handling - 5 bei Cancel nichts wie raus! - 6 bei NO-ID wird sie gel”scht; die Box erscheint dann bei n„ch- - 7 ster Gelegenheit wieder; sonst ID bernehmen (auch Leerstring) - 8 - 9 User-ID nur holen, wenn noch keine vorhanden ist. -10 Wird beim Eintritt in den Editor benutzt. -11 -12 springt auf beliebigen Screen im File. -13 Leerstring in die Box setzen. -14 das bliche form-handling -15 Screen-Nr. fr setscreen bernehmen und Screen ausgeben -Screen 71 not modified - 0 \ insert- and overwrite-mode 11aug86we - 1 - 2 setzt im Pulldownmenu ein H„kchen. - 3 wie oben, nur umgekehrt. - 4 - 5 Insert-Modus setzen und Pulldownmenu entsprechend „ndern. - 6 - 7 Overwrite-Modus setzen und Pulldownmenu entsprechend „ndern. - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 72 not modified - 0 \ viewing words 17aug86we - 1 - 2 Hilfswort fr do_view - 3 Findbuffer wird nach PAD gebracht und fr find aufbereitet. - 4 sucht CFA des Wortes im Findbuffer, um - 5 das zugeh”rige Name- und damit das View-Feld zu finden. - 6 setzt File und Screen-Nr. und sucht auf dem Screen nach dem - 7 Wort; falls gefunden, wird der Cursor dahinter positioniert. - 8 - 9 -10 l”scht den String in der Box; das bliche form-handling -11 String in Findbuffer bernehmen, falls nicht Cancel gew„hlt; -12 aktuellen Screen markieren, wenn MARK -13 angeklickt wurde, und gesuchten Screen aufrufen -14 Danach kann mit CTRL-A wieder auf den anderen Screen gewechselt -15 werden. Sehr ntzlich, um Zeilen aus anderen Files zu 'klauen'. -Screen 73 not modified - 0 \ Table of keystrokes 17aug86we - 1 - 2 Diese Tabelle enth„lt alle Tasten, die irgendwelche Sonder- - 3 funktionen haben. Das jeweils erste Wort ist der Scancode der - 4 Taste, das zweite die zus„tzlich gedrckten Tasten: - 5 1 = linke oder rechte SHIFT-Taste - 6 2 = CONTROL-Taste - 7 4 = ALTERNATE-Taste ( wird nicht benutzt ) - 8 Auf die Funktionstasten wurde bewužt verzichtet, weil man damit - 9 nicht vernnftig umgehen kann. -10 -11 -12 Zusatzvorschlag: -13 Alternate-Shift-Control bei gleichzeitig gedrckter Enter- und -14 F10-Taste ---> l”scht den Bildschirm. -15 -Screen 74 not modified - 0 \ Table of actions 17aug86we - 1 - 2 Tabelle aller Editorfunktionen - 3 Die Position eines Tabelleneintrags stimmt mit der des - 4 zugeh”rigen Tastendrucks berein, um die šbersicht zu behalten. - 5 Dies gilt auch fr die folgenden Screens. - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 prft, ob Anzahl der Funktionen mit Anzahl der Tasten berein- -15 stimmt. Wird nur w„hrend der Compilation gebraucht. -Screen 75 not modified - 0 \ Table of Menuevents 17aug86we - 1 - 2 Tabelle der Menueintr„ge. - 3 Alle Editorfunktionen sind sowohl ber die Menleiste als auch - 4 ber Tastendruck zu erreichen. - 5 Bei allen Worten mit : am Anfang handelt es sich um 'kopflose' - 6 Konstanten aus dem Resource-Definitionen-File (EDIICON.SCR), - 7 das mit dem Programm CONVH.SCR aus EDIICON.H erzeugt wurde. - 8 EDIICON.H wird vom 'Resource Construction Set' ausgegeben. - 9 An dieser Stelle unser herzlicher Dank an Digital Research fr -10 dieses hervorragende Produkt. Nur ca. 80 Systemabstrze gab es -11 bei der Entwicklung, weil Icons bisweilen auf ungeraden Spei- -12 cheradressen abgelegt werden. Aužerdem war bei knapp 10 kByte -13 L„nge der Resource mein Speicher (1024 kByte!!!) grunds„tzlich -14 voll bis absturzvoll. Dann bleibt das Programm stehen, nicht -15 ohne vorher die letzte lauff„hige Resource zu l”schen.... -Screen 76 not modified - 0 \ Table of Help-Boxes 17aug86we - 1 - 2 Tabelle der Help-Boxen. - 3 Zu jeder Editorfunktion gibt es eine Box, die die Funktion - 4 beschreibt. W„hlt man Dauerhilfe, erscheinen solche Boxen - 5 immer, wenn ein Befehl aus der Menuleiste abgerufen wird. - 6 Soll beim Einarbeiten in den Editor Hilfe leisten. Die Idee - 7 dazu stammt aus 1st Word. - 8 Gibt es zu einer Funktion keine Box (z.B. Cursortasten), ist - 9 der entsprechende Eintrag mit $FF gekennzeichnet. -10 -11 -12 -13 -14 -15 -Screen 77 not modified - 0 \ Prepare multi-event 24aug86we - 1 - 2 Flag, ob Maus innerhalb oder aužerhalb von Rechteck1 - 3 - 4 Fr den Multi-Event mssen 17 (!) Parameter bergeben werden. - 5 timer, message, mouse, button + keyboard events zulassen. - 6 1 Tastendruck auf linke Maustaste, event bei gedrckter Taste - 7 1, wenn Maus im Fensterbereich - 8 Rechteck 1 (Žnderung der Mausfunktion) umfažt Editor-Fenster - 9 Rechteck 2 gibts nicht -10 Timer auf 0 Millisekunden (sonst kommt der Multi-Event nicht -11 zurck) -12 -13 Wenn nichts anderes zu tun ist, kann eine andere Task ran. -14 schaltet Flag um. -15 -Screen 78 not modified - 0 \ Button Event 17aug86we - 1 - 2 Flag, das anzeigt, ob der Cursor sichtbar ist (1 = sichtbar) - 3 - 4 schaltet Cursor ein, wenn er noch nicht eingeschaltet ist; - 5 die Funktion arbeitet im EXOR-Modus, daher dieser Aufwand. - 6 baut an der aktuellen Cursorposition ein schwarzes Rechteck - 7 in der Gr”že eines Zeichens. - 8 - 9 kann curon benutzen wegen EXOR-Modus, muž aber das Flag setzen. -10 -11 Mausknopfereignis dann, wenn die Maus im Editorfenster steht. -12 die Position der Maus (in Pixel) wird in Zeile und Spalte umge- -13 rechnet und nach r# gespeichert. Maus abschalten und alten -14 Cursor l”schen (in dieser Reihenfolge!) -15 -Screen 79 not modified - 0 \ Key event 17aug86we - 1 - 2 Steuertasten erzeugen keinen ASCII-Code, sondern eine Null. - 3 - 4 gibt ein Zeichen auf dem Bildschirm aus und schreibt es in den - 5 Blockbuffer. Abbruch, wenn kein druckbares Zeichen vorliegt. - 6 Auf Insert-Modus prfen und Zeichen ausgeben. - 7 - 8 ermittelt die Adresse der zu einer Taste geh”renden Funktion. - 9 d_key enth„lt im oberen Wort den Status von Shift, Control usw. -10 putchar ist voreingestellt, keytable wird auf d_key abgesucht -11 wenn gefunden, wird die Adresse von putchar entfernt und statt- -12 dessen die zugeh”rige Adresse aus actiontable hinterlegt. -13 -14 -15 -Screen 80 not modified - 0 \ Key event 17aug86we - 1 - 2 Flag fr Fehlerpiep - 3 Flag, ob die Maus sichtbar ist - 4 - 5 positioniert den Cursor auf die Position in r#. - 6 - 7 Tasten-Event schaltet Mausflag ab - 8 Tastencode holen und Maus und Cursor abschalten. - 9 Status der Sondertasten aufbereiten und Tastenfunktion ausfh- -10 ren, Fehlerpiep erm”glichen, Status ausgeben -11 und - darauf bin ich ganz stolz - alle weiteren Tastendrcke -12 l”schen!! Dadurch l„uft auch bei schnellem Tastenrepeat keine -13 Funktion 'nach', wird aber trotzdem schnellstm”lich ausgefhrt. -14 Funktioniert allerdings dann nicht, wenn das lahme GEM was zu -15 tun hat, also beim Screenwechsel (CTRL-B und CTRL-N) -Screen 81 not modified - 0 \ Message events for window 30aug86we - 1 - 2 holt Wort n aus dem AES-message Buffer. - 3 - 4 bei Anklicken des Sliders oder der Pfeile - 5 wird der n„chste oder vorherige Screen aufgerufen. - 6 - 7 beim Verschieben des Sliders - 8 wird aus der Position die Screennummer berechnet. - 9 -10 beim Verschieben des ganzen Fensters -11 wird die vom User gewnschte Position berechnet -12 und in ganze Zeile bzw. Spalten umgewandelt; aužerhalb des -13 Screens kann nicht positioniert werden, sonst k”nnte man -14 ohne Sichtkontrolle weiter editieren. šber den Sinn dieser -15 Funktion kann man streiten, aber ich wollte zeigen, daž es geht -Screen 82 not modified - 0 \ Message events (the menuline) 17aug86we - 1 - 2 Flag fr Dauerhilfe bei jeder Menfunktion - 3 - 4 Hilfsbox Nr. n ausgeben - 5 passende Hilfsbox aus Tabelle suchen und anzeigen, bei OK Ende. - 6 sonst Funktion abbrechen. - 7 Es folgen die Funktionen, die nicht in der helptable auftauchen. - 8 Info-, Werbe- und Prunk-Box - 9 braucht nur angezeigt zu werden, spricht fr sich selbst. -10 -11 Dauerhilfe-Box anzeigen; je nach gew„hltem Knopf -12 H„kchen bei Menu Help setzen oder l”schen -13 dito fr Flag -14 -15 -Screen 83 not modified - 0 \ Message events from menuline 24aug86we - 1 - 2 Funktion, die nicht in actiontable steht, ausfhren - 3 mit case? die passende Funktion ausw„hlen - 4 Tabelle lohnt hier nicht. - 5 - 6 - 7 - 8 Menauswahl verarbeiten - 9 Mentitel von revers auf normal schalten -10 voreingestellt ist do_other, Nummer des angeklickten Items -11 holen, menutable wird auf Item-Nr. abgesucht -12 wenn gefunden, wird die Adresse von do_other entfernt und -13 stattdessen die zugeh”rige Adresse aus actiontable hinterlegt. -14 Funktion ausfhren, Fehlerpiep erm”glichen und Status ausgeben. -15 -Screen 84 not modified - 0 \ Handle message-event 24aug86we - 1 - 2 hier werden die Messages ausgewertet, die AES zurckgibt. - 3 wenn ein Menpunkt angeklickt wird, menu-message ausfhren. - 4 alle anderen Messages betreffen die Window-Attribute und - 5 werden entsprechend ausgefhrt. - 6 - 7 Wenn ein Desk-Accessory ausgefhrt wurde, erh„lt man lediglich - 8 die Meldung, daž neu gezeichnet werden muž, und dies auch nur - 9 dann, wenn ein Fenster aktiv ist. -10 -11 -12 -13 -14 -15 -Screen 85 not modified - 0 \ Handle all events 24aug86we - 1 - 2 Tabelle der m”glichen Events (werden als gesetztes Bit gemeldet) - 3 in der Reihenfolge ihrer Priorit„t, sonst kommt z.B. der Timer - 4 immer - 5 - 6 und der zugeh”rigen Funktionen - 7 - 8 - 9 Das ist der Event-Handler -10 gemeldeter Event wird mit Liste verglichen (Priorit„t !!) -11 und die entsprechende Event-Aktion ausgefhrt. -12 -13 -14 -15 -Screen 86 not modified - 0 \ Change mouse-movement Vector 17aug86we - 1 - 2 Variable, um den alten Mausvektor zu speichern. - 3 - 4 Die neue Mausroutine soll zus„tzlich das Flag ?mouse setzen, - 5 wenn die Maus bewegt wurde. So wird die Maus bei jedem Tasten- - 6 druck ausgeschaltet und erst wieder eingeschaltet bei Bewegung. - 7 Schick, gell?! - 8 Aus Geschwindigkeitsgrnden in Assembler - 9 -10 „ndert den Mausvektor. -11 -12 Mausvektor auf neuen Wert, alter Wert nach savevec. -13 Mausvektor auf alten Wert (muž unbedingt ausgefhrt werden, das -14 Betriebssystem erledigt das beim Verlassen von FORTH nicht !! -15 resetmousevec l”st das deffered word in done auf. -Screen 87 not modified - 0 \ The Editor's LOOP 30aug86we - 1 - 2 ediloop r„umt den Returnstack auf, falls mit abort" abgebrochen. - 3 Das ist die Endlos-Schleife, die erst verlassen wird, wenn - 4 das Flag fr UNTIL durch done gesetzt wird. - 5 - 6 Fehlerpiep, nur einmal ausfhren, sonst klingelts dauernd. - 7 - 8 Errorhandler fr Editor - 9 falls Fehlermeldung bereits erfolgt, sofort nach ediloop -10 piepen, 'work vorbereiten -11 in der Statuszeile rechts Fehlertext ausgeben, soweit Platz ist -12 und Rcksprung in ediloop ; -13 -14 -15 -Screen 88 not modified - 0 \ Installing the Editor 26oct86we - 1 - 2 Alle Routinen in der GEM-Library sind so geschrieben, daž sie - 3 implizit auf eine Variable grhandle zurckgreifen. Dies - 4 vereinfacht die Parameterbergabe erheblich. - 5 Sollen verschiedene Grafik-Applikationen aktiviert werden, darf - 6 trotzdem nur eine Appliktion angemeldet werden. Dies geschieht - 7 bereits beim Laden des FORTH-Systems. - 8 Beim Laden eines Resource-Files mit rsrc_load wird die Adresse - 9 der zugeh”rigen Baumstruktur im Global-Array unter ap_ptree -10 abgelegt. Diese Adresse kann man zum Umschalten auf verschie- -11 dene Resources benutzen. -12 Wenn PAD sich ver„ndert hat (durch neue Worte oder forget) -13 sind Find- und Insert-Buffer verschoben und mssen neu initia- -14 lisiert werden. Ebenso Zeichen und Zeilenbuffer. -15 (findbox wird gel”scht, damit die Findbox initialisiert wird. -Screen 89 not modified - 0 \ Installing the Editor 26oct86we - 1 - 2 initialisiert den Editor beim Aufruf. - 3 Abbruch, wenn kein Platz fr die Editor-Buffer ist (s.u...) - 4 aktuelle Cursorposition merken, Mausvector initialisieren - 5 Buffer bei Bedarf initialisieren - 6 Editor-Resource und Grafik-Handle installieren. - 7 Fenster ”ffnen und Menzeile ausgeben - 8 Errorhandler auf Editor umschalten, alten merken. - 9 -10 -11 ...das Dictionary ist zu voll. Entweder man 'vergižt' einige -12 Worte oder schafft mit z.B. 'save 4 buffers' mehr Raum. Mit -13 BUFFERS l„žt sich die Anzahl der Diskbuffer festlegen. Dabei -14 steht mehr Platz im Dictionary gegen Arbeitskomfort beim Edi- -15 tieren. Beachten Sie auch, daž BUFFERS ein COLD ausfhrt. -Screen 90 not modified - 0 \ Entering the Editor 17aug86we - 1 - 2 Es folgen die Forth-Worte zum Aufruf des Editors. - 3 - 4 Flag entscheidet, ob compiliert werden soll (ldone). - 5 - 6 Screen mit Nummer in scr und Cursor in r# wird aufgerufen. - 7 Diese Systemvariablen werden auch bei Fehlern gesetzt, also - 8 kann man bei einem Compilationsfehler auf den richtigen Screen - 9 gelangen; Cursor steht dann hinter dem Wort, das den Fehler -10 ausgel”st hat. -11 l editiert Screen-Nr. n -12 view erwartet ein Wort und editiert den Screen, auf dem das -13 Wort definiert wurde (s.a. >view) -14 -15 -Screen 91 not modified - 0 \ savesystem for Editor 17aug86we - 1 - 2 Damit der Editor auf Schwarz-Weiž und Farbmonitoren l„uft, - 3 mssen die entsprechenden Parameter ermittelt und in die - 4 beiden Arrays, die fr die Zwischenspeicherung des Bildschirms - 5 verantwortlich sind, gepatched werden. - 6 Fr die Zwischenspeicherung werden 2 Buffer benutzt, die ober- - 7 halb des Systems liegen. Nur dadurch kann der Bildschirminhalt - 8 so schnell restauriert werden, wenn Alertboxen oder andere - 9 aufgerufen wurden. -10 -11 -12 -13 -14 -15 -Screen 92 not modified - 0 \ savesystem for Editor 30aug86we - 1 - 2 Diese Routine muž beim Start des Systems (!) ausgefhrt werden, - 3 setzt die Variablen fr die GEM-Routinen des Editors - 4 und fr die beiden Speicherdefinitions-Arrays - 5 wird daher nach drvinit gepatched, klinkt sich selbst aus. - 6 - 7 savesystem muž eine Reihe von Variablen zurcksetzen, damit - 8 das System mit 'vernnftigen' Werten hochkommt. - 9 drvinit wird mit edistart gepatched. -10 FORTH-83.SCR als File fr markierten Screen. -11 ge„nderte Bl”cke auf Diskette zurckschreiben -12 und altes savesystem ausfhren. -13 Neues bye muž zus„tzlich ein GREXIT ausfhren. GRINIT bei -14 Neukompilation n”tig wegen GREXIT in BYE . -15 -Screen 93 not modified - 0 \ savesystem for Editor 17aug86we - 1 - 2 Damit der Editor auf Schwarz-Weiž und Farbmonitoren l„uft, - 3 mssen die entsprechenden Parameter ermittelt und in die - 4 beiden Arrays, die fr die Zwischenspeicherung des Bildschirms - 5 verantwortlich sind, gepatched werden. - 6 Fr die Zwischenspeicherung werden 2 Buffer benutzt, die ober- - 7 halb des Systems liegen. Nur dadurch kann der Bildschirminhalt - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/EDITOR.fth b/sources/AtariST/EDITOR.fth new file mode 100644 index 0000000..e2fd4ef --- /dev/null +++ b/sources/AtariST/EDITOR.fth @@ -0,0 +1,1598 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Screen-Editor *** 10aug86we + +Dieses File enth„lt den volksFORTH - Editor. +Er basiert auf dem Editor im F83 von Laxen/Perry, besitzt aber +erheblich erweiterte Funktionen (Zeichen- und Zeilenstack) und +ist ein vollst„ndig in GEM integrierter Fullscreen-Editor. + +Obwohl die Steuerung mit Maus und Menuzeile erfolgt, k”nnen +ihn die 'Profis' auch vollst„ndig ber Controltasten bedienen, + +Die Dauerhilfe-Funktion macht eine Funktionsbeschreibung ber- +flssig. Solange im HILFE-Menu Dauerhilfe gew„hlt ist, erscheint +vor der Ausfhrumg jeder Editor-Funktion ein erl„uternder Text +mit der M”glichkeit zum Abbruch. Dies gilt jedoch nicht, wenn +die Funktion per Tastendruck aufgerufen wurde. + +\ *** Block No. 1 Hexblock 1 +\ Load Screen for the Editor cas20130105 + +Onlyforth GEM also +include ediicon.fb + +| Variable (dx 2 (dx ! | Variable (dy 4 (dy ! +| : dx (dx @ ; | : dy (dy @ ; + +\needs -text .( strings needed !!) abort +\needs file? .( Filesystem needed !!) abort +include gem\supergem.fb +include gem\gemdefs.fb +include edwindow.fb + +Forth definitions + 1 $2C +thru +\ *** Block No. 2 Hexblock 2 +\ Editor Variable 10sep86we + +Variable 'scr 1 'scr ! Variable 'r# 'r# off +Variable 'edifile + +?head @ 1 ?head ! + +Variable changed Variable edistate +Variable edifile +Variable ycur + + + + + + +\ *** Block No. 3 Hexblock 3 +\ Edi move cursor with position-checking or cyclic 30aug86we + +: c ( n -- ) \ checks the cursor position + r# @ + dup 0 b/blk uwithin 0= abort" Border!" r# ! ; + +\ : c ( n -- ) \ moves cyclic thru the screen +\ r# @ + b/blk mod r# ! ; + + + + + + + + + +\ *** Block No. 4 Hexblock 4 +\ Move the Editor's cursor around 08aug86we + +: top ( -- ) r# off ; +: cursor ( -- n ) r# @ ; +: t ( n -- ) c/l * cursor - c ; +: line# ( -- n ) cursor c/l / ; +: col# ( -- n ) cursor c/l mod ; +: +t ( n -- ) line# + t ; +: 'start ( -- addr ) scr @ block ; +: 'cursor ( -- addr ) 'start cursor + ; +: 'line ( -- addr ) 'cursor col# - ; +: #after ( -- n ) c/l col# - ; +: #remaining ( -- n ) b/blk cursor - ; +: #end ( -- n ) #remaining col# + ; + + +\ *** Block No. 5 Hexblock 5 +\ Move the Editors cursor 08aug86we + +: curup c/l negate c ; +: curdown c/l c ; +: curleft -1 c ; +: curright 1 c ; +: +tab cursor $10 / 1+ $10 * cursor - c ; +: -tab cursor 8 mod negate dup 0= 8 * + c ; +: >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; +: line# t curdown ; + + + + + + +\ *** Block No. 6 Hexblock 6 +\ buffers 14sep86we + +: modified ( -- ) scr @ block drop update + changed @ ?exit edistate off changed on ; + +&84 Constant c/pad +&42 Constant c/buf + +: 'work ( -- work-buf ) pad c/pad + ; +: 'insert ( -- ins-buf ) 'work c/pad + ; +: 'find ( -- find-buf ) 'insert c/buf + ; + +: 'find+ ( n1 -- n2 ) 'find c@ + ; + + + +\ *** Block No. 7 Hexblock 7 +\ Errorchecking 09sep86we + +: ?bottom ( -- ) 'start b/blk + c/l - c/l -trailing nip + abort" You would lose a line" ; + +: ?end ( -- ) 'line c/l + 1- c@ bl - + abort" You would lose a char" ; + +: ?range ( n -- n ) dup 0 capacity uwithin not + abort" Out of range!" ; + + + + + + +\ *** Block No. 8 Hexblock 8 +\ Graphics for display 23aug86we + +: lineclr ( line# -- ) + wi_x swap cheight * wi_y + + over wi_width + over cheight + fbox ; + +: lineinsert ( line# -- ) + wi_x over cheight * wi_y + + wi_width over l/s 1- cheight * wi_y + swap - + 2over cheight + scr>scr lineclr ; + +: linedelete ( line# -- ) + wi_x swap 1+ cheight * wi_y + + wi_width over l/s cheight * wi_y + swap - + 2over cheight - scr>scr l/s 1- lineclr ; + +\ *** Block No. 9 Hexblock 9 +\ Editor-Window Title and Status-Line cas20130105 + +: 'workblank + 'work dup $sum ! dup off dup 1+ c/l blank c/l + off ; + + +: update$ ( -- string ) + scr @ updated? not IF " not updated" exit THEN " updated" ; + +: .edistate edistate @ ?exit edistate on 'workblank + " Scr # " count $add scr @ extend <# # # # #> $add + 'work c@ 2+ 'work c! update$ count $add + 'work 1+ wi_status ; + + + +\ *** Block No. 10 Hexblock A +\ screen display 30aug86we + +: .edifile 'workblank 1 'work c! + isfile@ ?dup 0= IF " DIRECT" ELSE 2- >name THEN + count $add 'work count + 1+ c/l min off + 'work 1+ wi_title ; + +: 'line# ( line# -- addr count ) + dup dy + dx at c/l * 'start + c/l ; + +: .line ( line# -- ) dup lineclr 'line# -trailing type ; +: redisplay ( line# -- ) 'line# type ; + + + + +\ *** Block No. 11 Hexblock B +\ screen display 14sep86we + +&18 Constant id-len +Create id id-len allot id id-len erase + +: stamp id 1+ count 'start c/l + over - swap cmove ; +: ?stamp changed @ IF stamp THEN ; + + +: edilist edistate off changed off + vslide_size scr @ vslide + .edifile .edistate l/s 0 DO I .line LOOP ; + +: undo scr @ block drop prev @ emptybuf edilist ; + +: do_redraw hide_c wi_clear redraw_screen edilist ; +\ *** Block No. 12 Hexblock C +\ Edi Variables, 23aug86we + +Variable (pad (pad off +: memtop ( -- addr ) sp@ $100 - ; + +Variable chars Variable #chars +: 'chars ( -- addr ) chars @ #chars @ + ; + +Variable lines Variable #lines +: 'lines ( -- addr ) lines @ #lines @ + ; + +Variable (key + +Variable imode imode off + + +\ *** Block No. 13 Hexblock D +\ Edi line handling 09aug86we + +: linemodified modified line# redisplay ; + +: clrline 'line c/l blank linemodified ; +: clrright 'cursor #after blank linemodified ; + +: delline 'line #end c/l delete + line# linedelete modified ; +: backline curup delline ; + +: instline ?bottom 'line c/l over #end insert + line# lineinsert clrline ; + + + +\ *** Block No. 14 Hexblock E +\ Edi line handling 09aug86we + +: @line 'lines memtop u> abort" line buffer full" + 'line 'lines c/l cmove c/l #lines +! ; + +: copyline @line curdown ; +: line>buf @line delline ; + +: !line c/l negate #lines +! 'lines 'line c/l cmove + linemodified ; + +: buf>line #lines @ 0= abort" line buffer empty" + ?bottom instline !line ; + + + +\ *** Block No. 15 Hexblock F +\ Edi char handling 09aug86we + +: delchar 'cursor #after 1 delete linemodified ; +: backspace curleft delchar ; + +: inst1 ?end 'cursor 1 over #after insert ; +: instchar inst1 bl 'cursor c! linemodified ; + +: @char 'chars 1- lines @ u> abort" char buffer full" + 'cursor c@ 'chars c! 1 #chars +! ; +: copychar @char curright ; +: char>buf @char delchar ; + +: !char -1 #chars +! 'chars c@ 'cursor c! ; +: buf>char #chars @ 0= abort" char buffer empty" + inst1 !char linemodified ; +\ *** Block No. 16 Hexblock 10 +\ from Screen to Screen ... 22oct86we + +: setscreen ( n -- ) ?stamp ?range scr ! edilist ; +: n scr @ 1+ setscreen ; +: b scr @ 1- setscreen ; + +: >shadow ( n1 -- n2 ) capacity 2/ 2dup < IF + ELSE - THEN ; +: w scr @ >shadow setscreen ; + +: (mark scr @ 'scr ! r# @ 'r# ! isfile@ 'edifile ! ; +: mark (mark true abort" marked !" ; + +: a ?stamp 'edifile @ [ Dos ] dup searchfile drop + isfile@ 'edifile ! !files + 'r# @ r# @ 'r# ! r# ! + 'scr @ scr @ 'scr ! ?range scr ! edilist ; +\ *** Block No. 17 Hexblock 11 +\ splitting a line, replace 17aug86we + +: split ?bottom pad c/l 2dup blank + 'cursor #remaining insert linemodified + col# line# lineinsert + 'start cursor + c/l rot delete linemodified ; + +: ins 'insert count under 'cursor #after insert c ; + +: r + c/l 'line over -trailing nip - + 'insert c@ 'find c@ - < abort" not enough room" + 'find c@ dup negate c 'cursor #after rot delete ins + linemodified ; + + +\ *** Block No. 18 Hexblock 12 +\ find und search 30aug86we + +: >last? ( -- f ) :dfright state_gaddr l@ 1 and ; +: >last :dfright select :dfleft deselect ; +: >1st :dfleft select :dfright deselect ; + +Variable fscreen + +: find? ( - n f ) 'find count 'cursor #remaining search ; + +: s BEGIN find? IF 'find+ c edilist exit THEN drop + fscreen @ scr @ - ?dup stop? 0= and + WHILE 0< IF -1 ELSE 1 THEN scr +! top scr @ vslide + REPEAT :sfind tree! + >last? IF >1st :df1st ELSE >last :dflast THEN + getnumber drop fscreen ! edilist true abort" not found" ; +\ *** Block No. 19 Hexblock 13 +\ Search-Findbox auswerten 24aug86we + +: initfind ( -- ) + :dfmatch select :dfignore deselect >last + 1 extend :df1st putnumber + capacity 1- extend :dflast putnumber ; + +: getfind ( -- n ) + :dfignore state_gaddr l@ 1 and caps ! + >last? IF :dflast ELSE :df1st THEN getnumber drop + capacity 1- min + :dffstrin 'find getstring :dfrstrin 'insert getstring ; + +: do_fbox ( -- button ) :sfind tree! + edifile @ isfile@ - IF isfile@ edifile ! initfind THEN + show_object :dffstrin form_do dup deselect hide_object ; +\ *** Block No. 20 Hexblock 14 +\ Replacing ... 24aug86we + +Variable ?replace + +: show_replace ( -- ) + &320 &200 &10 &10 little 4! + col# dx + 2- cwidth * line# dy + 1+ cheight * + 2dup 0 objc_setpos 0 objc_getwh big 4! + big 4@ scr>mem1 1 little 4@ big 4@ form_dial + 0 ( install) 3 ( depth) big 4@ objc_draw show_c ; + +: replace ( -- ) + :fbox tree! BEGIN + show_replace 0 form_do dup deselect hide_object + dup :fboxcanc - WHILE :fboxyes = IF r THEN s + REPEAT drop ; +\ *** Block No. 21 Hexblock 15 +\ Editor's find and replace 24aug86we + +Variable (findbox (findbox off + +: repfind ( -- ) + (findbox @ 'find c@ and 0= abort" use find first" + ?stamp fscreen @ capacity 1- min fscreen ! + s ?replace @ IF replace THEN ; + +: edifind ( -- ) + do_fbox :dfcancel case? ?exit + :dfreplac = ?replace swap IF on ELSE off THEN + :edimenu tree! :repeat 1 menu_ienable (findbox on + :sfind tree! getfind fscreen ! repfind ; + + +\ *** Block No. 22 Hexblock 16 +\ exiting the Editor 30aug86we + +Defer resetmouse + +: done ( ff addr -- tf ) + :edimenu tree! 0 menu_bar resetmouse hide_c + wi_close ycur @ 0 at cr ." Scr #" scr @ 3 .r 2 spaces + count type true ; + +: cdone ( ff -- tf ) prev @ emptybuf " canceled" done ; +: sdone ( ff -- tf ) ?stamp save-buffers " saved" done ; +: xdone ( ff -- tf ) ?stamp update$ done ; +: ldone ( ff -- tf ) drop true + ?stamp save-buffers " loading" done ; + + +\ *** Block No. 23 Hexblock 17 +\ get User's ID, jump to screen 24aug86we + +: do_getid + :sgetid tree! id 1+ :idtext putstring + show_object :idtext form_do dup deselect hide_object + :idcancel case? ?exit + :noid = IF id off exit THEN + :idtext id 1+ getstring ; + +: get-id + id c@ ?exit 1 id c! do_getid ; + +: jumpscreen :sgetscr tree! + pad dup off :scrnr putstring + show_object :scrnr form_do dup deselect hide_object + :sgcancel = ?exit :scrnr getnumber drop setscreen ; +\ *** Block No. 24 Hexblock 18 +\ insert- and overwrite-mode 24aug86we + +: mark_item ( item# -- ) 1 menu_icheck ; +: clr_item ( item# -- ) 0 menu_icheck ; + +: setimode imode on :edimenu tree! + :imode mark_item :omode clr_item ; +: clrimode imode off :edimenu tree! + :omode mark_item :imode clr_item ; + + + + + + + +\ *** Block No. 25 Hexblock 19 +\ viewing words 24aug86we + +: >view ( -- ) + 'find count pad place pad capitalize bl pad count + c! + find 0= abort" Haeh?" + >name ?dup 0= abort" no view-field" + 4- @ ?dup 0= abort" hand made" + (view scr ! top curdown find? 0= IF drop exit THEN + 'find+ c ; + +: do_view ( -- ) + :sview tree! pad dup off :svword putstring + show_object :svword form_do dup deselect hide_object + :idcancel case? ?exit + :svword 'find getstring :svmark = IF (mark THEN + >view edilist ; +\ *** Block No. 26 Hexblock 1A +\ Table of keystrokes 10aug86we + +Create keytable +$4800 0 , , $4B00 0 , , $5000 0 , , $4D00 0 , , +$4838 1 , , $4B34 1 , , $5032 1 , , $4D36 1 , , + $5000 2 , , $7400 2 , , +$0E08 0 , , $537F 0 , , $5200 0 , , $240A 2 , , +$0E08 1 , , $537F 1 , , $5230 1 , , $6100 0 , , +$1709 2 , , $180F 2 , , $1205 2 , , $531F 2 , , +$1C0D 0 , , $1C0D 1 , , $0F09 0 , , $0F09 1 , , +$4700 0 , , $4737 1 , , $2207 2 , , $2F16 2 , , +$2106 2 , , $1312 2 , , $320D 2 , , +$011B 0 , , $1F13 2 , , $2D18 2 , , $260C 2 , , +$310E 2 , , $3002 2 , , $1E01 2 , , $1117 2 , , + +here keytable - 2/ 2/ Constant #keys +\ *** Block No. 27 Hexblock 1B +\ Table of actions 11aug86we + +Create actiontable ] +curup curleft curdown curright +line>buf char>buf buf>line buf>char + copyline copychar +backspace delchar instchar jumpscreen +backline delline instline undo +setimode clrimode clrline clrright + split +tab -tab +top >""end do_getid do_view +edifind repfind mark +cdone sdone xdone ldone +n b a w + +[ here actiontable - 2/ #keys - abort( # of actions) +\ *** Block No. 28 Hexblock 1C +\ Table of Menuevents 24aug86we + +Create menutable +$FF c, $FF c, $FF c, $FF c, +:cutline c, :cutchar c, :pastelin c, :pastecha c, + :copyline c, :copychar c, +$FF c, $FF c, $FF c, :jump c, +:backline c, :delline c, :insline c, :undo c, +:imode c, :omode c, :eraselin c, :erasrest c, +$FF c, :split c, :tab c, :backtab c, +:home c, :toend c, :getid c, :view c, +:search c, :repeat c, :mark c, +:canceled c, :flushed c, :updated c, :loading c, +:next c, :back c, :alternat c, :shadow c, + +here menutable - #keys - abort( # of menuitems) +\ *** Block No. 29 Hexblock 1D +\ Table of Help-Boxes 24aug86we + +Create helptable +$FF c, $FF c, $FF c, $FF c, +:hlicut c, :hchcut c, :hlipaste c, :hchpaste c, + :hlicopy c, :hchcopy c, +$FF c, $FF c, $FF c, :hjump c, +:hliback c, :hlidel c, :hliins c, :hexundo c, +:hspins c, :hspover c, :hlierase c, :hlirest c, +$FF c, :hlisplit c, :hcutabr c, :hcutabl c, +:hcuhome c, :hcuend c, :hspgetid c, :hview c, +:hspfind c, :hsprepea c, :hscmark c, +:hexcancl c, :hexsave c, :hexupdat c, :hexload c, +:hscnext c, :hscback c, :hscalter c, :hscshado c, + +here helptable - #keys - abort( # of menuitems) +\ *** Block No. 30 Hexblock 1E +\ Prepare multi-event 09sep86we + +Variable mflag mflag off + +: ediprepare + %00110111 + 1 1 1 + mflag @ + dx cwidth * dy cheight * c/l cwidth * l/s cheight * + 0 0 0 0 0 + 0 0 + intin $10 array! message >absaddr addrin 2! ; + +' pause | Alias ev-timer +: ev-r1 1 mflag 1+ ctoggle ; + +\ *** Block No. 31 Hexblock 1F +\ Button Event 24aug86we + +Variable ?cursor ?cursor off + +: curon ?cursor @ ?exit ?cursor on + 3 swr_mode 1 sf_color 1 sf_interior 0 sf_perimeter + at? cwidth * swap cheight * + over cwidth 1- + over cheight + 1- bar ; + +: curoff ?cursor off curon ?cursor off ; + +: ev-button mflag @ 0= ?exit + intout 4+ @ cheight / dy - c/l * + intout 2+ @ cwidth / dx - + r# ! hide_c curoff ; + + +\ *** Block No. 32 Hexblock 20 +\ Key event 17aug86we + +: visible? ( key -- f ) $FF and ; + +: putchar ( -- ) + (key @ dup visible? 0= abort" What?" + imode @ IF inst1 THEN 'cursor c! linemodified curright ; + +: findkey ( d_key -- addr ) + ['] putchar -rot + #keys 0 DO 2dup keytable I 2* 2* + 2@ d= + IF rot drop actiontable I 2* + @ -rot LEAVE THEN + LOOP 2drop ; + + + +\ *** Block No. 33 Hexblock 21 +\ Key event 23aug86we + +Variable jingle jingle on +Variable ?mouse + +: edit-at cursor c/l /mod dy + swap dx + at ; + +: ev-key ?mouse off + intout &10 + dup @ dup (key ! hide_c edit-at curoff + swap 2- @ dup 1 and + 2/ findkey execute + jingle on .edistate BEGIN getkey 0= UNTIL ; + + + + + +\ *** Block No. 34 Hexblock 22 +\ Message events for window 30aug86we + +: getmessage ( n -- n' ) 2* message + @ ; + +: wm_arrowed + 4 getmessage 1 and IF n exit THEN b ; + +: wm_vslide + 4 getmessage capacity 1- &1000 */ setscreen ; + +: wm_moved + 4 getmessage cwidth / 1 max &14 min (dx ! + 5 getmessage cheight / 1 max 5 min 3 + (dy ! + wi_handle @ 5 wi_size wind_set redraw_screen ; + + +\ *** Block No. 35 Hexblock 23 +\ Message events (the menuline) 02sep86we + +Variable ?help ?help on + +: do_help ( n -- ) + helptable + c@ alert 1 = ?exit + true abort" Dann eben nicht !!" ; + +: do_copyr :copyr tree! + show_object 0 form_do deselect hide_object ; + +: do_menuhelp show_c :hhemenu alert hide_c + :edimenu tree! 1 and :menuhelp over menu_icheck + ?help ! ; + + +\ *** Block No. 36 Hexblock 24 +\ Message events from menuline 02sep86we + +: do_other ( -- ) 4 getmessage + :menuhelp case? IF do_menuhelp exit THEN + :hmouse case? IF :hhemouse alert drop exit THEN + :hfuncts case? IF :hhef1f10 alert drop exit THEN + drop do_copyr ; + +: menu-message ( -- ) message @ :mn_selected - ?exit + :edimenu tree! 3 getmessage 1 menu_tnormal + ['] do_other 4 getmessage + #keys 0 DO dup menutable I + c@ = + IF ?help @ IF I do_help THEN + nip actiontable I 2* + @ swap LEAVE THEN + LOOP drop execute jingle on .edistate ; + +\ *** Block No. 37 Hexblock 25 +\ Handle message-event 24aug86we + +: ev-message hide_c edit-at curoff + message @ :mn_selected case? IF menu-message exit THEN + :wm_arrowed case? IF wm_arrowed exit THEN + :wm_vslid case? IF wm_vslide exit THEN + :wm_moved case? IF wm_moved exit THEN + :wm_redraw case? IF do_redraw exit THEN + drop ; + + + + + + + +\ *** Block No. 38 Hexblock 26 +\ Handle all events 30aug86we + +Create ev-flag + :mu_mesag c, :mu_m1 c, :mu_button c, + :mu_keybd c, :mu_timer c, + +Create: event-actions + ev-message ev-r1 ev-button ev-key ev-timer ; + +: handle-events ( which -- ) + 5 0 DO ev-flag I + c@ over and IF drop I LEAVE THEN LOOP + 2* event-actions + perform ; + + + + +\ *** Block No. 39 Hexblock 27 +\ Change mouse-movement Vector 10sep86we + +2Variable savevec + +Create newvector Assembler + ?mouse pcrel) A0 lea true # A0 ) move + .l savevec pcrel) A0 move A0 ) jmp end-code + +Code ?show_c ?mouse R#) tst 0= IF Next THEN ;c: show_c ; + +: ex_motv ( pusrcode -- ) + contrl &14 + 2! &126 0 0 VDI contrl &18 + 2@ savevec 2! ; + +: setmousevec newvector >absaddr ex_motv ; +: resetmousevec savevec 2@ ex_motv ; +' resetmousevec Is resetmouse +\ *** Block No. 40 Hexblock 28 +\ The Editor's LOOP 02sep86we + +: ediloop r0 @ rp! + BEGIN edit-at curon ?show_c false + ediprepare evnt_multi handle-events UNTIL ; + +: alarm bell jingle off ; + +: edierror ( string -- ) + jingle @ 0= IF drop ediloop THEN alarm + 'workblank c/l 2/ 'work c! count c/l 2/ min $add + 'work 1+ wi_status edistate off ediloop ; + + + + +\ *** Block No. 41 Hexblock 29 +\ Installing the Editor 20nov86we + +Create ediresource &12 allot +Variable edihandle + +: setediresource ediresource ap_ptree &12 cmove ; + +: ?clearbuffer + pad (pad @ = ?exit pad (pad ! + 'find b/blk + dup chars ! c/l 2* + lines ! + #chars off #lines off 'find off 'insert off (findbox off ; + + + + + +\ *** Block No. 42 Hexblock 2A +\ Installing the Editor 20nov86we + +: finstall ( -- ) + pad memtop u> abort" No room for buffers!" + get-id changed off row ycur ! setmousevec + ?clearbuffer ?cursor off + ap_ptree &12 cpush setediresource + grhandle push edihandle @ grhandle ! + wi_open :edimenu tree! 1 menu_bar + errorhandler push ['] edierror errorhandler ! + r0 push rp@ r0 ! ediloop ; + + + + + +\ *** Block No. 43 Hexblock 2B +\ Entering the Editor 11sep86we + +Forth definitions ?head ! + +| : ?load 0= ?exit scr @ r# @ (load ; + +: v ( -- ) scr @ ?range drop finstall ?load ; + +: l ( scr -- ) 1 arguments ?range scr ! top v ; + +| : >find bl word count 'find place ; + +: view ( -- ) >find >view v ; + + + +\ *** Block No. 44 Hexblock 2C +\ Init the Editor for different resolutions 18sep86we + +| : q_extnd ( info_flag -- ) intin ! &102 0 1 VDI ; + +| : setMFDB ( addr_of_MFDB -- ) >r + 0 q_extnd intout 2@ r@ 4+ 2! intout @ $10 / r@ 6 + ! + 1 q_extnd intout 8 + @ r> &12 + ! ; + + + + + + + + + +\ *** Block No. 45 Hexblock 2D +\ save-system for Editor cas20130105 + +| : edistart grinit rsrc_load" ediicon.rsc" 0 graf_mouse + grhandle @ edihandle ! ap_ptree ediresource &12 cmove + memMFDB1 setMFDB memMFDB2 setMFDB + ['] noop [ ' drvinit >body ] Literal ! ; + +: bye grexit bye ; grinit + +: save-system id off r# off 1 scr ! 'r# off 1 'scr ! + (findbox off (pad off + ['] edistart [ ' drvinit >body ] Literal ! + [ ' forth83.fb >body ] Literal 'edifile ! + flush save-system bye ; + + +\ *** Block No. 46 Hexblock 2E + + + + + + + + + + + + + + + + +\ *** Block No. 47 Hexblock 2F +\\ *** Screen-Editor *** 17aug86we + +In den Editor gelangt man mit l ( Screen-Nr. -- ), mit v oder +view. view verlangt als weitere Eingabe ein FORTH-Wort und +sucht dann den Screen, auf dem das Wort definiert wurde. + +Alle Eingaben werden unmittelbar in den Blockbuffer geschrieben, +der den aktuellen Screen enth„lt. + +Die Position des Cursors h„ngt von 2 Variablen ab: +scr enth„lt die Nummer des aktuellen Screens; +r# bestimmt die Position des Cursors. +Beides sind Systemvariable, die auch beim Compilieren benutzt +werden. Bei Abbruch wegen eines Fehlers ruft man den Editor mit +v auf. Der Cursor steht hinter dem Wort, das den Abbruch +ausgel”st hat. +\ *** Block No. 48 Hexblock 30 +\ Load Screen for the Editor 24aug86we + +bindet Vocabulary GEM mit in die Suchreihenfolge ein. +Labels fr Editor-Resource + +(dx und (dy sind Variable, die die Lage des Editorfensters +relativ zur linken oberen Ecke des Bildschirms angeben. +Der Editor ben”tigt einige Definitionen aus anderen Files. +- fr die Suchfunktionen. +- falls kein File-Interface vorhanden ist. +- fr das Fenster +Labels fr Gem-Aufrufe + + + + +\ *** Block No. 49 Hexblock 31 +\ Editor Variable 26oct86we + +Screen-Nr. und Cursorposition vom markierten Screen +File fr markierten Screen + +Alle folgenden Definitionen werden headerless compiliert. + +Flag fr Žnderungen am Screen; Flag, ob Statuszeile neu ge- +File, das editiert wird schrieben werden muž +ycur ist die Cursorposition beim Aufruf des Editors + + + + + + +\ *** Block No. 50 Hexblock 32 +\ Edi move cursor with position-checking or cyclic 30aug86we + +bewegt den Cursor um n Stellen vor- bzw. rckw„rts. + Wird der Cursor ber Anfang oder Ende des Screens hinausbewegt, + stehen zwei M”glichkeiten zur Wahl: + - Kommando wird nicht ausgefhrt. + - Der Screen wird zyklisch durchlaufen. + +W„hlen Sie durch 'Wegkommentieren' und Neucompilieren des + Editors. + + + + + + +\ *** Block No. 51 Hexblock 33 +\ Move the Editor's cursor around 05aug86we + +setzt Cursor in die obere linke Ecke (Home). +n ist die aktuelle Position des Cursors (Offset von Home) +setzt Cursor auf Beginn der Zeile n. +n ist die Zeile, in der der Cursor steht. +n ist die Spalte, in der der Cursor steht. +bewegt Cursor um n Zeilen vor- bzw. rckw„rts auf Zeilenanfang. +addr ist die Anfangsadresse des aktuellen Blocks im Speicher. +addr ist die der Cursorposition entsprechende Speicheradresse. +addr ist die Speicheradresse des Beginns der Cursorzeile. +n ist die Stellenanzahl zwischen Cursorposition und Zeilenende. +n ist die Stellenanzahl zwischen Cursorposition und Blockende. +n ist die Stellenanzahl zwischen Cursorzeile und Blockende. + + +\ *** Block No. 52 Hexblock 34 +\ Move the Editors cursor 07aug86we + +setzt Cursor um eine Zeile nach oben. +setzt Cursor um eine Zeile nach unten. +setzt Cursor um ein Zeichen nach links. +setzt Cursor um ein Zeichen nach rechts. +setzt Cursor um eine Tabulatorposition nach vorn (s.unten). +setzt Cursor um eine Tabulatorposition zurck (s.unten). +setzt Cursor auf das letzte Zeichen des Screens. +setzt Cursor auf Beginn der n„chsten Zeile. + + +Vorw„rtstabs: ++ + + + +Rckw„rtstabs: +- - - - - - - - +\ *** Block No. 53 Hexblock 35 +\ buffers 24aug86we + +markiert einen ge„nderten Block zum Zurckschreiben auf Disk + setzt Flag fr ?stamp und l”scht Flag fr .edistate + +Byteanzahl in PAD (min. &84 nach 83-Standard!). +Byteanzahl in einem Buffer (&40 durch Resource vorgegeben). + +'work, 'insert und 'find sind Buffer, die beim Aufruf des + Editors oberhalb von PAD eingerichtet werden. + 'work dient zur Aufbreitung von Strings fr die Statuszeile + 'find enth„lt den Suchstring und 'insert den Replacestring. +n2 ist n1 zuzglich der L„nge des Findbuffers. + + + +\ *** Block No. 54 Hexblock 36 +\ Errorchecking 17aug86we + +bricht ab, wenn beim Einfgen einer Zeile kein Platz mehr ist. + + +bricht ab, wenn beim Einfgen eines Zeichens kein Platz mehr ist + + +bricht ab, wenn ein Screen aužerhalb des aktuellen Files edi- + tiert werden soll. + + + + + + +\ *** Block No. 55 Hexblock 37 +\ Graphics for display 23aug86we + +l”scht Zeile n durch šberschreiben mit einem weižen Rechteck + x - und y - Koordinate der linken oberen Ecke + x - und y - Koordinate der rechten unteren Ecke + +fgt auf dem Bildschirm an der Cursorposition eine Leerzeile ein + x - und y - Koordinate des zu verschiebenden Rechtecks + Breite setzen und H”he berechnen + x - und y - Koordinate des Zielrechtecks ( 1 Zeile tiefer ) + das ganze mit Pixelmove (schnell) verschieben und Zeile l”schen +l”scht auf dem Bildschirm die Cursorzeile + x - und y - Koordinate des zu verschiebenden Rechtecks + Breite setzen und H”he berechnen + x - und y - Koordinate des Zielrechtecks ( 1 Zeile h”her ) + das ganze mit Pixelmove verschieben und unterste Zeile l”schen +\ *** Block No. 56 Hexblock 38 +\ Editor-Window Title and Status-Line 30aug86we + +setzt 'work als Arbeitsspeicher und l”scht ihn; 0 als Abschluž + + +f ist true, wenn der aktuelle Screen als updated markiert ist. + +bergibt in Abh„ngigkeit vom Updatezustand den richtigen String. + + +Statuszeile wird nur beschrieben, wenn sich etwas ver„ndert hat. + Screennummer wird in 'work zusammengestellt, + 2 Leerzeichen und dann die Updatemeldung. + das Ganze wird an .wi_state als 0-terminated String bergeben. + + +\ *** Block No. 57 Hexblock 39 +\ screen display 30aug86we + +gibt den Filenamen in der Titelzeile aus; 'work l”schen + Adresse des Strings, der den Filenamen enth„lt, ermitteln + und nach 'work bringen, maximal eine Zeile, Leerzeichen am Ende + als 0-terminated String an wi_title bergeben. + +berechnet die Speicheradresse von Zeile line#, + setzt Cursor und bereitet die Parameter fr type auf. + +l”scht Zeile line# und gibt sie dann aus (schnell!!). +gibt Zeile line# neu aus (langsam, aber ohne Flackern). + + + + +\ *** Block No. 58 Hexblock 3A +\ screen display 14sep86we + +maximale L„nge der User-ID, die automatisch in die obere rechte +Ecke des Screens gesetzt wird, wenn dieser ge„ndert wurde. + +setzt ID rechtsbndig (!) in die erste Zeile. +setzt ID, wenn der aktuelle Screen ver„ndert wurde. + + +gibt einen Screen im Editorfenster aus. Flags fr ?stamp und + vertikaler Slider wird auf richtige Gr”že und Position gesetzt + .edistate werden zurckgesetzt. + +l”scht den aktuellen Buffer und erzwingt so Neueinlesen von Disk + Der Blockzugriff ist fr Multitasking n”tig. +zeichnet den gesamten Bildschirm neu (nach Accessory-Aufruf). +\ *** Block No. 59 Hexblock 3B +\ Edi Variables, putchar 17aug86we + +Adresse von PAD beim Editieren fr ?clearbuffer. +Obergrenze fr Zeichen- (128 Zeichen) und Zeilenbuffer, der + oberhalb von PAD bis zur Speichergrenze reicht +Adresse des Zeichenbuffers Anzahl der Zeichen im Buffer +liefert die n„chste freie Adresse im Zeichenbuffer. + +Adresse des Zeilenbuffers Anzahl der Zeilen im Buffer +liefert die n„chste freie Adresse im Zeilenbuffer. + +speichert das zuletzt eingegebene Zeichen. + +Insertmodus, voreingestellt aus + + +\ *** Block No. 60 Hexblock 3C +\ Edi line handling 17aug86we + +erneuert gerade bearbeitete Zeile auf dem Bildschirm; setzt Flag + fr ?stamp. +l”scht die Cursorzeile. +l”scht vom Cursor bis zum Zeilenende. + +l”scht Cursorzeile und zieht Rest des Bildschirms nach oben. + +l”scht Zeile ber dem Cursor und zieht Rest des Bildschirms nach + oben. +fgt an der Cursorposition eine Leerzeile ein; Rest des Bild- + schirms wird nach unten geschoben. + + + +\ *** Block No. 61 Hexblock 3D +\ Edi line handling 17aug86we + +prft, ob Platz im Zeilenbuffer vorhanden ist, und kopiert + eine Zeile in den Zeilenbuffer. + +kopiert eine Zeile in den Buffer, setzt Cursor auf die n„chste. +kopiert eine Zeile in den Buffer und l”scht sie. + +setzt aus dem Zeilenbuffer eine Zeile in der Cursorzeile ein. + + +benutzt !line, prft vorher, ob Zeilen im Buffer sind. + Fr die neue Zeile wird zuerst eine Leerzeile eingefgt. + + + +\ *** Block No. 62 Hexblock 3E +\ Edi char handling 17aug86we + +l”scht Zeichen unter dem Cursor. +l”scht Zeichen links neben dem Cursor. + +fgt an der Cursorposition ein Zeichen im Buffer ein. +benutzt inst1, um ein Leerzeichen einzufgen. + +analog zu @line, kopiert ein Zeichen in den Zeichenbuffer. + +kopiert ein Zeichen in den Buffer, setzt Cursor auf das n„chste. +kopiert ein Zeichen in den Buffer und l”scht es. + +analog zu !line, setzt ein Zeichen aus dem Buffer bei Cursor ein +benutzt !char, prft vorher, ob Zeichen im Buffer sind. + Fr das neue Zeichen wird zuerst ein Leerzeichen eingefgt. +\ *** Block No. 63 Hexblock 3F +\ from Screen to Screen ... 24aug86we + +prft, ob der angeforderte Screen vorhanden ist und gibt ihn aus +geht auf den n„chsten Screen. +geht auf den vorherigen Screen. + +berechnet zu Screen n1 den Shadow-Screen n2 oder umgekehrt. +schaltet zwischen Original und Shadow hin und her. + +markiert den aktuellen Screen mit File und Cursorposition. +s.o., jedoch mit Meldung. + +vertauscht aktuellen und markierten Screen. Dabei wird auch das + File mitbercksichtigt. Dies erlaubt es, nach VIEW einen mar- + kierten Screen wieder zu benutzen. + +\ *** Block No. 64 Hexblock 40 +\ splitting a line, replace 17aug86we + +setzt den Rest der Zeile ab Cursor auf den Anfang einer neu + eingefgten Zeile. Dazu wird erst eine komplette leere Zeile + eingefgt und dann von Cursorspalte bis Anfang der neuen + Zeile gel”scht. + +fgt den Insert-Buffer an der Cursorposition ein. + +ersetzt den gefundenen String durch den Insert-Buffer. + berechnet Anzahl der Leerzeichen am Ende der Zeile. + Abbruch, wenn weniger als Differenz zwischen Find und Insert, + sonst Findstring l”schen und Insert-Buffer einfgen + + + +\ *** Block No. 65 Hexblock 41 +\ find und search 30aug86we + +f ist 1, wenn in Richtung last Screen gesucht wird, sonst 1. +schaltet Button in der Findbox auf Suche Richtung last screen. +schaltet Button in der Findbox auf Suche Richtung 1st screen. + +Der Screen, bis zu dem gesucht werden soll + +sucht von Cursor bis Screenende; n ist Offset zu Cursorposition. + +sucht von Cursor bis Screen fscreen vorw„rts oder rckw„rts. + solange bis fscreen erreicht ist oder Esc oder CTRL-C gedrckt, + wird der n„chste Screen aufgerufen. + Abbruch, falls nicht gefunden und Umschalten der Suchrichtung + in der Box und in fscreen. + Screen auflisten und Abbruchmeldung ausgeben. +\ *** Block No. 66 Hexblock 42 +\ Search-Findbox auswerten 17aug86we + +Vorbelegung der Buttons und Screennummern in der Find-box: + Grož-Kleinschreibung unterscheiden. + Aufsteigend suchen bis Fileende. + 1 fr 1st Screen, letzten Screen im File als Last Screen + +Filebox auswerten: + Variable caps entsprechend setzen. + Suchrichtung bestimmt, ob der erste oder letzte Screen + als Endscreen benutzt wird. + Strings in die entsprechenden Buffer bernehmen. + +Falls das File gewechselt wurde, neu initialisieren, geschieht + auch automatisch, wenn sich PAD und damit Find- und Insert- + buffer ver„ndert haben. +\ *** Block No. 67 Hexblock 43 +\ Replacing ... 17aug86we + +Flag fr Ersetzen des Find-Strings durch den Insert-String + +O Schreck und Graus !!! + Die Replace-Box soll natrlich nicht den gefundenen String + verdecken; die von form_center gelieferten Werte sind also + unbrauchbar. X- und Y-Position mssen von Hand berechnet werden + und zwar so, daž die linke obere Ecke der Box auf den Such- + string zeigt; zeichnen des Objects wie in show_object. + +ersetzt solange den Suchstring durch den Insertstring, bis + CANCEL gedrckt oder der Suchstring nicht gefunden wird. + Abbruch auch, wenn der Insertstring sich nicht einsetzen l„žt. + Sonst wie bei Find Abbruch mit Esc. oder CTRL-C m”glich. + +\ *** Block No. 68 Hexblock 44 +\ Editor's find and replace 17aug86we + +Flag fr repfind, ob bereits eine Suche stattgefunden hat. + +fhrt erneute Suche (und Ersetzen) durch ohne Find-Box. + Abbruch, wenn noch kein Aufruf der Find-Box oder Findbuffer + leer; sonst sicherstellen, daž fscreen innerhalb des Files + liegt und s bzw replace ausfhren. + +Das ist das aufrufende Wort; im CANCEL-Fall abbrechen, + sonst Flag fr replace setzen, wenn :dfreplac gew„hlt wurde + Im Menubalken Repeatfind enable'n + Screennummer merken; suchen und ggf. ersetzen mit repfind. + + + +\ *** Block No. 69 Hexblock 45 +\ exiting the Editor 30aug86we + +Setzt Mausvector zurck, wird erst sp„ter definiert. + +gemeinsame Routine fr alle Exits +l”scht (und restauriert) das Fenster, setzt Mausvector zurck + gibt an der alten Cursorpositione eine Meldung aus + und setzt Flag zum Verlassen von ediloop. + +wirft alle Žnderungen weg, falls man sich 'vereditiert' hat. +speichert den Screen auf Disk, falls er ver„ndert wurde. +markiert den Screen, ohne ihn direkt zurckzuschreiben. +speichert den Screen auf Disk, falls er ver„ndert wurde + und compiliert ab Cursorposition. + + +\ *** Block No. 70 Hexblock 46 +\ get User's ID, jump to screen 17aug86we + +User-ID holen + bisherige ID im Fenster ausgeben + das bliche form-handling + bei Cancel nichts wie raus! + bei NO-ID wird sie gel”scht; die Box erscheint dann bei n„ch- + ster Gelegenheit wieder; sonst ID bernehmen (auch Leerstring) + +User-ID nur holen, wenn noch keine vorhanden ist. + Wird beim Eintritt in den Editor benutzt. + +springt auf beliebigen Screen im File. + Leerstring in die Box setzen. + das bliche form-handling + Screen-Nr. fr setscreen bernehmen und Screen ausgeben +\ *** Block No. 71 Hexblock 47 +\ insert- and overwrite-mode 11aug86we + +setzt im Pulldownmenu ein H„kchen. +wie oben, nur umgekehrt. + +Insert-Modus setzen und Pulldownmenu entsprechend „ndern. + +Overwrite-Modus setzen und Pulldownmenu entsprechend „ndern. + + + + + + + + +\ *** Block No. 72 Hexblock 48 +\ viewing words 17aug86we + +Hilfswort fr do_view + Findbuffer wird nach PAD gebracht und fr find aufbereitet. + sucht CFA des Wortes im Findbuffer, um + das zugeh”rige Name- und damit das View-Feld zu finden. + setzt File und Screen-Nr. und sucht auf dem Screen nach dem + Wort; falls gefunden, wird der Cursor dahinter positioniert. + + +l”scht den String in der Box; das bliche form-handling + String in Findbuffer bernehmen, falls nicht Cancel gew„hlt; + aktuellen Screen markieren, wenn MARK + angeklickt wurde, und gesuchten Screen aufrufen + Danach kann mit CTRL-A wieder auf den anderen Screen gewechselt + werden. Sehr ntzlich, um Zeilen aus anderen Files zu 'klauen'. +\ *** Block No. 73 Hexblock 49 +\ Table of keystrokes 17aug86we + +Diese Tabelle enth„lt alle Tasten, die irgendwelche Sonder- + funktionen haben. Das jeweils erste Wort ist der Scancode der + Taste, das zweite die zus„tzlich gedrckten Tasten: + 1 = linke oder rechte SHIFT-Taste + 2 = CONTROL-Taste + 4 = ALTERNATE-Taste ( wird nicht benutzt ) + Auf die Funktionstasten wurde bewužt verzichtet, weil man damit + nicht vernnftig umgehen kann. + + +Zusatzvorschlag: + Alternate-Shift-Control bei gleichzeitig gedrckter Enter- und + F10-Taste ---> l”scht den Bildschirm. + +\ *** Block No. 74 Hexblock 4A +\ Table of actions 17aug86we + +Tabelle aller Editorfunktionen + Die Position eines Tabelleneintrags stimmt mit der des + zugeh”rigen Tastendrucks berein, um die šbersicht zu behalten. + Dies gilt auch fr die folgenden Screens. + + + + + + + + +prft, ob Anzahl der Funktionen mit Anzahl der Tasten berein- + stimmt. Wird nur w„hrend der Compilation gebraucht. +\ *** Block No. 75 Hexblock 4B +\ Table of Menuevents 17aug86we + +Tabelle der Menueintr„ge. + Alle Editorfunktionen sind sowohl ber die Menleiste als auch + ber Tastendruck zu erreichen. + Bei allen Worten mit : am Anfang handelt es sich um 'kopflose' + Konstanten aus dem Resource-Definitionen-File (EDIICON.SCR), + das mit dem Programm CONVH.SCR aus EDIICON.H erzeugt wurde. + EDIICON.H wird vom 'Resource Construction Set' ausgegeben. + An dieser Stelle unser herzlicher Dank an Digital Research fr + dieses hervorragende Produkt. Nur ca. 80 Systemabstrze gab es + bei der Entwicklung, weil Icons bisweilen auf ungeraden Spei- + cheradressen abgelegt werden. Aužerdem war bei knapp 10 kByte + L„nge der Resource mein Speicher (1024 kByte!!!) grunds„tzlich + voll bis absturzvoll. Dann bleibt das Programm stehen, nicht + ohne vorher die letzte lauff„hige Resource zu l”schen.... +\ *** Block No. 76 Hexblock 4C +\ Table of Help-Boxes 17aug86we + +Tabelle der Help-Boxen. + Zu jeder Editorfunktion gibt es eine Box, die die Funktion + beschreibt. W„hlt man Dauerhilfe, erscheinen solche Boxen + immer, wenn ein Befehl aus der Menuleiste abgerufen wird. + Soll beim Einarbeiten in den Editor Hilfe leisten. Die Idee + dazu stammt aus 1st Word. + Gibt es zu einer Funktion keine Box (z.B. Cursortasten), ist + der entsprechende Eintrag mit $FF gekennzeichnet. + + + + + + +\ *** Block No. 77 Hexblock 4D +\ Prepare multi-event 24aug86we + +Flag, ob Maus innerhalb oder aužerhalb von Rechteck1 + +Fr den Multi-Event mssen 17 (!) Parameter bergeben werden. + timer, message, mouse, button + keyboard events zulassen. + 1 Tastendruck auf linke Maustaste, event bei gedrckter Taste + 1, wenn Maus im Fensterbereich + Rechteck 1 (Žnderung der Mausfunktion) umfažt Editor-Fenster + Rechteck 2 gibts nicht + Timer auf 0 Millisekunden (sonst kommt der Multi-Event nicht + zurck) + +Wenn nichts anderes zu tun ist, kann eine andere Task ran. +schaltet Flag um. + +\ *** Block No. 78 Hexblock 4E +\ Button Event 17aug86we + +Flag, das anzeigt, ob der Cursor sichtbar ist (1 = sichtbar) + +schaltet Cursor ein, wenn er noch nicht eingeschaltet ist; + die Funktion arbeitet im EXOR-Modus, daher dieser Aufwand. + baut an der aktuellen Cursorposition ein schwarzes Rechteck + in der Gr”že eines Zeichens. + +kann curon benutzen wegen EXOR-Modus, muž aber das Flag setzen. + +Mausknopfereignis dann, wenn die Maus im Editorfenster steht. + die Position der Maus (in Pixel) wird in Zeile und Spalte umge- + rechnet und nach r# gespeichert. Maus abschalten und alten + Cursor l”schen (in dieser Reihenfolge!) + +\ *** Block No. 79 Hexblock 4F +\ Key event 17aug86we + +Steuertasten erzeugen keinen ASCII-Code, sondern eine Null. + +gibt ein Zeichen auf dem Bildschirm aus und schreibt es in den + Blockbuffer. Abbruch, wenn kein druckbares Zeichen vorliegt. + Auf Insert-Modus prfen und Zeichen ausgeben. + +ermittelt die Adresse der zu einer Taste geh”renden Funktion. + d_key enth„lt im oberen Wort den Status von Shift, Control usw. + putchar ist voreingestellt, keytable wird auf d_key abgesucht + wenn gefunden, wird die Adresse von putchar entfernt und statt- + dessen die zugeh”rige Adresse aus actiontable hinterlegt. + + + +\ *** Block No. 80 Hexblock 50 +\ Key event 17aug86we + +Flag fr Fehlerpiep +Flag, ob die Maus sichtbar ist + +positioniert den Cursor auf die Position in r#. + +Tasten-Event schaltet Mausflag ab + Tastencode holen und Maus und Cursor abschalten. + Status der Sondertasten aufbereiten und Tastenfunktion ausfh- + ren, Fehlerpiep erm”glichen, Status ausgeben + und - darauf bin ich ganz stolz - alle weiteren Tastendrcke + l”schen!! Dadurch l„uft auch bei schnellem Tastenrepeat keine + Funktion 'nach', wird aber trotzdem schnellstm”lich ausgefhrt. + Funktioniert allerdings dann nicht, wenn das lahme GEM was zu + tun hat, also beim Screenwechsel (CTRL-B und CTRL-N) +\ *** Block No. 81 Hexblock 51 +\ Message events for window 30aug86we + +holt Wort n aus dem AES-message Buffer. + +bei Anklicken des Sliders oder der Pfeile + wird der n„chste oder vorherige Screen aufgerufen. + +beim Verschieben des Sliders + wird aus der Position die Screennummer berechnet. + +beim Verschieben des ganzen Fensters + wird die vom User gewnschte Position berechnet + und in ganze Zeile bzw. Spalten umgewandelt; aužerhalb des + Screens kann nicht positioniert werden, sonst k”nnte man + ohne Sichtkontrolle weiter editieren. šber den Sinn dieser + Funktion kann man streiten, aber ich wollte zeigen, daž es geht +\ *** Block No. 82 Hexblock 52 +\ Message events (the menuline) 17aug86we + +Flag fr Dauerhilfe bei jeder Menfunktion + +Hilfsbox Nr. n ausgeben + passende Hilfsbox aus Tabelle suchen und anzeigen, bei OK Ende. + sonst Funktion abbrechen. +Es folgen die Funktionen, die nicht in der helptable auftauchen. +Info-, Werbe- und Prunk-Box + braucht nur angezeigt zu werden, spricht fr sich selbst. + +Dauerhilfe-Box anzeigen; je nach gew„hltem Knopf + H„kchen bei Menu Help setzen oder l”schen + dito fr Flag + + +\ *** Block No. 83 Hexblock 53 +\ Message events from menuline 24aug86we + +Funktion, die nicht in actiontable steht, ausfhren + mit case? die passende Funktion ausw„hlen + Tabelle lohnt hier nicht. + + + +Menauswahl verarbeiten + Mentitel von revers auf normal schalten + voreingestellt ist do_other, Nummer des angeklickten Items + holen, menutable wird auf Item-Nr. abgesucht + wenn gefunden, wird die Adresse von do_other entfernt und + stattdessen die zugeh”rige Adresse aus actiontable hinterlegt. + Funktion ausfhren, Fehlerpiep erm”glichen und Status ausgeben. + +\ *** Block No. 84 Hexblock 54 +\ Handle message-event 24aug86we + +hier werden die Messages ausgewertet, die AES zurckgibt. + wenn ein Menpunkt angeklickt wird, menu-message ausfhren. + alle anderen Messages betreffen die Window-Attribute und + werden entsprechend ausgefhrt. + + Wenn ein Desk-Accessory ausgefhrt wurde, erh„lt man lediglich + die Meldung, daž neu gezeichnet werden muž, und dies auch nur + dann, wenn ein Fenster aktiv ist. + + + + + + +\ *** Block No. 85 Hexblock 55 +\ Handle all events 24aug86we + +Tabelle der m”glichen Events (werden als gesetztes Bit gemeldet) + in der Reihenfolge ihrer Priorit„t, sonst kommt z.B. der Timer + immer + +und der zugeh”rigen Funktionen + + +Das ist der Event-Handler + gemeldeter Event wird mit Liste verglichen (Priorit„t !!) + und die entsprechende Event-Aktion ausgefhrt. + + + + +\ *** Block No. 86 Hexblock 56 +\ Change mouse-movement Vector 17aug86we + +Variable, um den alten Mausvektor zu speichern. + +Die neue Mausroutine soll zus„tzlich das Flag ?mouse setzen, + wenn die Maus bewegt wurde. So wird die Maus bei jedem Tasten- + druck ausgeschaltet und erst wieder eingeschaltet bei Bewegung. + Schick, gell?! +Aus Geschwindigkeitsgrnden in Assembler + +„ndert den Mausvektor. + +Mausvektor auf neuen Wert, alter Wert nach savevec. +Mausvektor auf alten Wert (muž unbedingt ausgefhrt werden, das + Betriebssystem erledigt das beim Verlassen von FORTH nicht !! +resetmousevec l”st das deffered word in done auf. +\ *** Block No. 87 Hexblock 57 +\ The Editor's LOOP 30aug86we + +ediloop r„umt den Returnstack auf, falls mit abort" abgebrochen. + Das ist die Endlos-Schleife, die erst verlassen wird, wenn + das Flag fr UNTIL durch done gesetzt wird. + +Fehlerpiep, nur einmal ausfhren, sonst klingelts dauernd. + +Errorhandler fr Editor + falls Fehlermeldung bereits erfolgt, sofort nach ediloop + piepen, 'work vorbereiten + in der Statuszeile rechts Fehlertext ausgeben, soweit Platz ist + und Rcksprung in ediloop ; + + + +\ *** Block No. 88 Hexblock 58 +\ Installing the Editor 26oct86we + +Alle Routinen in der GEM-Library sind so geschrieben, daž sie + implizit auf eine Variable grhandle zurckgreifen. Dies + vereinfacht die Parameterbergabe erheblich. + Sollen verschiedene Grafik-Applikationen aktiviert werden, darf + trotzdem nur eine Appliktion angemeldet werden. Dies geschieht + bereits beim Laden des FORTH-Systems. +Beim Laden eines Resource-Files mit rsrc_load wird die Adresse + der zugeh”rigen Baumstruktur im Global-Array unter ap_ptree + abgelegt. Diese Adresse kann man zum Umschalten auf verschie- + dene Resources benutzen. +Wenn PAD sich ver„ndert hat (durch neue Worte oder forget) + sind Find- und Insert-Buffer verschoben und mssen neu initia- + lisiert werden. Ebenso Zeichen und Zeilenbuffer. + (findbox wird gel”scht, damit die Findbox initialisiert wird. +\ *** Block No. 89 Hexblock 59 +\ Installing the Editor 26oct86we + +initialisiert den Editor beim Aufruf. + Abbruch, wenn kein Platz fr die Editor-Buffer ist (s.u...) + aktuelle Cursorposition merken, Mausvector initialisieren + Buffer bei Bedarf initialisieren + Editor-Resource und Grafik-Handle installieren. + Fenster ”ffnen und Menzeile ausgeben + Errorhandler auf Editor umschalten, alten merken. + + +...das Dictionary ist zu voll. Entweder man 'vergižt' einige + Worte oder schafft mit z.B. 'save 4 buffers' mehr Raum. Mit + BUFFERS l„žt sich die Anzahl der Diskbuffer festlegen. Dabei + steht mehr Platz im Dictionary gegen Arbeitskomfort beim Edi- + tieren. Beachten Sie auch, daž BUFFERS ein COLD ausfhrt. +\ *** Block No. 90 Hexblock 5A +\ Entering the Editor 17aug86we + +Es folgen die Forth-Worte zum Aufruf des Editors. + +Flag entscheidet, ob compiliert werden soll (ldone). + +Screen mit Nummer in scr und Cursor in r# wird aufgerufen. + Diese Systemvariablen werden auch bei Fehlern gesetzt, also + kann man bei einem Compilationsfehler auf den richtigen Screen + gelangen; Cursor steht dann hinter dem Wort, das den Fehler + ausgel”st hat. +l editiert Screen-Nr. n +view erwartet ein Wort und editiert den Screen, auf dem das + Wort definiert wurde (s.a. >view) + + +\ *** Block No. 91 Hexblock 5B +\ savesystem for Editor 17aug86we + +Damit der Editor auf Schwarz-Weiž und Farbmonitoren l„uft, + mssen die entsprechenden Parameter ermittelt und in die + beiden Arrays, die fr die Zwischenspeicherung des Bildschirms + verantwortlich sind, gepatched werden. + Fr die Zwischenspeicherung werden 2 Buffer benutzt, die ober- + halb des Systems liegen. Nur dadurch kann der Bildschirminhalt + so schnell restauriert werden, wenn Alertboxen oder andere + aufgerufen wurden. + + + + + + +\ *** Block No. 92 Hexblock 5C +\ savesystem for Editor 30aug86we + +Diese Routine muž beim Start des Systems (!) ausgefhrt werden, + setzt die Variablen fr die GEM-Routinen des Editors + und fr die beiden Speicherdefinitions-Arrays + wird daher nach drvinit gepatched, klinkt sich selbst aus. + +savesystem muž eine Reihe von Variablen zurcksetzen, damit + das System mit 'vernnftigen' Werten hochkommt. + drvinit wird mit edistart gepatched. + FORTH-83.SCR als File fr markierten Screen. + ge„nderte Bl”cke auf Diskette zurckschreiben + und altes savesystem ausfhren. +Neues bye muž zus„tzlich ein GREXIT ausfhren. GRINIT bei + Neukompilation n”tig wegen GREXIT in BYE . + +\ *** Block No. 93 Hexblock 5D +\ savesystem for Editor 17aug86we + +Damit der Editor auf Schwarz-Weiž und Farbmonitoren l„uft, + mssen die entsprechenden Parameter ermittelt und in die + beiden Arrays, die fr die Zwischenspeicherung des Bildschirms + verantwortlich sind, gepatched werden. + Fr die Zwischenspeicherung werden 2 Buffer benutzt, die ober- + halb des Systems liegen. Nur dadurch kann der Bildschirminhalt + + + + + + + + diff --git a/sources/AtariST/EDWINDOW.FB.src b/sources/AtariST/EDWINDOW.FB.src deleted file mode 100644 index cacb8d9..0000000 --- a/sources/AtariST/EDWINDOW.FB.src +++ /dev/null @@ -1,306 +0,0 @@ -Screen 0 not modified - 0 \\ *** EDWINDOW.SCR *** 14sep86we - 1 - 2 Dieses File enth„lt das Editorfenster. Es kann als Beispiel fr - 3 die Programmierung eines eigenen Fensters benutzt werden. - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Window-Handling Loadscreen 30oct86we - 1 - 2 Onlyforth Gem also definitions - 3 - 4 1 7 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ VDI-Functions for window 24aug86we - 1 - 2 : bar ( x1 y1 x2 y2 -- ) - 3 ptsin 4 array! 1 function ! &11 2 0 VDI ; - 4 - 5 : swr_mode ( mode -- ) intin ! &32 0 1 VDI ; - 6 - 7 : sf_interior ( style -- ) intin ! &23 0 1 VDI ; - 8 : sf_style ( styleindex -- ) intin ! &24 0 1 VDI ; - 9 : sf_color ( color -- ) intin ! &25 0 1 VDI ; -10 : sf_perimeter ( pervis -- ) intin ! &104 0 1 VDI ; -11 -12 : fbox ( x1 y1 x2 y2 -- ) -13 1 swr_mode 1 sf_interior 0 sf_color 0 sf_perimeter bar ; -14 -15 -Screen 3 not modified - 0 \ save and restore the screen 10sep86we - 1 - 2 ?head @ 1 ?head ! - 3 - 4 Create memMFDB2 7 , 0 , &640 , &400 , &40 , 0 , 1 , - 5 0 , 0 , 0 , - 6 - 7 memMFDB2 scr>mem scr>mem2 ( Xleft Ytop Width Heigth -- ) - 8 memMFDB2 mem>scr mem2>scr ( Xleft Ytop Width Heigth -- ) - 9 -10 : save_screen 0 0 cwidth &80 * cheight &25 * -11 scr>mem2 ; -12 : restore_screen 0 0 cwidth &80 * cheight &25 * -13 mem2>scr ; -14 -15 -Screen 4 not modified - 0 \ Windowcomponents and Windowsize 30aug86we - 1 - 2 :name :move + :info + :uparrow + :dnarrow + :vslide + - 3 Constant wi_components - 4 - 5 : wi_x ( -- n ) dx cwidth * ; - 6 : wi_y ( -- n ) dy cheight * ; - 7 : wi_width ( -- n ) c/l cwidth * ; - 8 : wi_height ( -- n ) l/s cheight * ; - 9 -10 : wi_size ( -- wx wy wwidth wheight ) -11 0 wi_components -12 wi_x 1- wi_y 1- wi_width 2+ wi_height 2+ wind_calc -13 intout 2+ 4@ ; -14 -15 -Screen 5 not modified - 0 \ Window's title and sliders 25sep86we - 1 - 2 Variable wi_handle - 3 - 4 : wi_string ( 0string function# -- ) swap >r - 5 wi_handle @ swap r> >absaddr swap 0 0 wind_set ; - 6 - 7 : wi_title ( 0string -- ) :wf_name wi_string ; - 8 : wi_status ( 0string -- ) :wf_info wi_string ; - 9 -10 : vslide_size -11 wi_handle @ :wf_vslize &1000 capacity / 0 0 0 wind_set ; -12 -13 : vslide ( scr# -- ) wi_handle @ :wf_vslide -14 rot &1000 capacity dup 1- IF 1- THEN */ -15 0 0 0 wind_set ; -Screen 6 not modified - 0 \ Draw window on screen 30aug86we - 1 - 2 : small_big ( -- sx sy sw sh bx by bw bh ) - 3 little 4@ wi_size ; - 4 - 5 : growbox small_big graf_growbox ; - 6 : shrinkbox small_big graf_shrinkbox ; - 7 - 8 : wi_clear wi_x 1- wi_y 1- - 9 over wi_width 1+ + over wi_height 1+ + fbox ; -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ Open and close window 30aug86we - 1 - 2 : wi_open ( -- ) save_screen growbox - 3 wi_components wi_size wind_create dup wi_handle ! - 4 pad dup off dup wi_title wi_status - 5 wi_size wind_open wi_clear ; - 6 - 7 : wi_close ( -- ) - 8 wi_handle @ dup wind_close wind_delete - 9 shrinkbox restore_screen ; -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ redrawing the rest of screen 10sep86we - 1 - 2 : restore_rect ( x y w h -- ) 1- >r 1- r> mem2>scr ; - 3 - 4 : rect_update ( function# -- x y w h ) - 5 0 swap wind_get intout 2+ 4@ ; - 6 - 7 : redraw_screen :wf_firstxywh rect_update - 8 BEGIN 2dup or - 9 WHILE restore_rect :wf_nextxywh rect_update REPEAT -10 2drop 2drop ; -11 -12 ?head ! -13 -14 -15 -Screen 9 not modified - 0 14sep86we - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ Window-Handling Loadscreen 14sep86we - 1 - 2 Suchreihenfolge: Zuerst GEM, dann FORTH - 3 - 4 Gebraucht werden die Definitionen aus GEMDEFS.SCR - 5 - 6 Dieses Vokabular wird als erstes durchsucht. - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 11 not modified - 0 \ VDI-Functions for window 14sep86we - 1 - 2 Fr das Fenster werden einige Funktionen aus VDI gebraucht, - 3 die auf diesem Screen zusammengestellt sind. Beschreibung siehe - 4 Beschreibung VDI (hoffentlich haben wir die schon!) - 5 - 6 Im Grunde wird nur eine Routine benutzt, mit der man ein weižes - 7 Rechteck zum L”schen des Fensterinhaltes erzeugen kann. Dies - 8 erledigt fbox - 9 -10 -11 -12 -13 -14 -15 -Screen 12 not modified - 0 \ save and restore the screen 14sep86we - 1 - 2 alle folgenden Funktionen sollen headerless kompiliert werden. - 3 - 4 Ein zweiter Speicherbereich wird gebraucht, um den Bildschirm - 5 beim Verlassen des Editors zu restaurieren. Dieses Verfahren - 6 ren ist erheblich schneller als die Neuausgabe des Bildschirms, - 7 braucht aber Speicherplatz (Wir hams ja!) - 8 - 9 -10 Der gesamte Bildschirm wird in den dafr vorgesehenen Speicher- -11 bereich gerettet (aužerhalb des FORTH-Systems, versteht sich) -12 Das Ganze umgekehrt stellt den Bildschirm wieder her. Diese -13 Funktionen sind recht ntzlich, weil man Werte noch sehen kann, -14 die z.B. bei LIST weggescrollt wrden. -15 -Screen 13 not modified - 0 \ Windowcomponents and Windowsize 14sep86we - 1 - 2 Die Bestandteile des Fensters werden einfach aufaddiert und - 3 als Konstante zur Verfgung gestellt. - 4 - 5 linke obere Ecke des Fensters in Bildschirmkoordinaten - 6 - 7 Breite des Fensters in Bildschirmkoordinaten - 8 H”he des Fensters in Bildschirmkoordinaten - 9 -10 berechnet die Ausmaže des Fensters fr alle weiteren Funktionen -11 unter Zuhilfenahme von WIND-CALC. Leider liefert diese Funktion -12 bei Breite und H”he ein Pixel zu wenig. Digital Research allein -13 mag wissen, warum ... -14 -15 -Screen 14 not modified - 0 \ Window's title and sliders 14sep86we - 1 - 2 Window-Handle des Fensters - 3 - 4 zur Ausgabe eines Textes in Titel- oder Infozeile - 5 Der String muž mit einer Null abgeschlossen sein. - 6 - 7 gibt 0string in der Titelzeile aus. - 8 gibt 0string in der Infozeile aus. - 9 -10 Die Gr”že des vertikalen Sliders wird aus der Gesamtgr”že des -11 Files, das editiert wird, berechnet. -12 -13 Die Position des vertikalen Sliders wird relativ zur Gesamtgr”že -14 des Files eingestellt. -15 -Screen 15 not modified - 0 \ Draw window on screen 14sep86we - 1 - 2 gibt die Gr”že eines kleinen Rechtecks sowie des ganzen Fensters - 3 - 4 - 5 zeichnet ein wachsendes Rechteck (nur frs Auge ...) - 6 zeichnet ein schrumpfendes Rechteck ( s.o.) - 7 - 8 l”scht den Innenraum des Fenster durch šberschreiben mit einem - 9 weižen Rechteck. -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \ Open and close window 14sep86we - 1 - 2 ”ffnet das Editorfenster: Bildschirminhalt merken - 3 Fenster erzeugen mit entsprechender Gr”že und Attributen - 4 Titel- und Infozeile l”schen - 5 Fenster auf dem Bildschirm ausgeben und Inhalt l”schen - 6 - 7 schliežt das Editorfenster: - 8 Fenster vom Bildschirm und berhaupt entfernen - 9 Bildschirm restaurieren. -10 -11 -12 -13 -14 -15 -Screen 17 not modified - 0 \ redrawing the rest of screen 14sep86we - 1 - 2 Rechteck per Pixelmove restaurieren - 3 - 4 liefert die Koordinaten eines neu zu zeichnenden Rechtecks. - 5 - 6 Der Screenmanager stellt eine Liste von Rechtecken zurVerfgung, - 7 die nach einer Aktion ge„ndert worden sind. - 8 Durch diese Liste hangelt sich die Routine hindurch und - 9 erzeugt die Rechtecke per Pixelmove (schnell) neu. -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/EDWINDOW.fth b/sources/AtariST/EDWINDOW.fth new file mode 100644 index 0000000..27fbe8d --- /dev/null +++ b/sources/AtariST/EDWINDOW.fth @@ -0,0 +1,306 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** EDWINDOW.SCR *** 14sep86we + +Dieses File enth„lt das Editorfenster. Es kann als Beispiel fr +die Programmierung eines eigenen Fensters benutzt werden. + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Window-Handling Loadscreen 30oct86we + +Onlyforth Gem also definitions + +1 7 +thru + + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ VDI-Functions for window 24aug86we + +: bar ( x1 y1 x2 y2 -- ) + ptsin 4 array! 1 function ! &11 2 0 VDI ; + +: swr_mode ( mode -- ) intin ! &32 0 1 VDI ; + +: sf_interior ( style -- ) intin ! &23 0 1 VDI ; +: sf_style ( styleindex -- ) intin ! &24 0 1 VDI ; +: sf_color ( color -- ) intin ! &25 0 1 VDI ; +: sf_perimeter ( pervis -- ) intin ! &104 0 1 VDI ; + +: fbox ( x1 y1 x2 y2 -- ) + 1 swr_mode 1 sf_interior 0 sf_color 0 sf_perimeter bar ; + + +\ *** Block No. 3 Hexblock 3 +\ save and restore the screen 10sep86we + +?head @ 1 ?head ! + +Create memMFDB2 7 , 0 , &640 , &400 , &40 , 0 , 1 , + 0 , 0 , 0 , + +memMFDB2 scr>mem scr>mem2 ( Xleft Ytop Width Heigth -- ) +memMFDB2 mem>scr mem2>scr ( Xleft Ytop Width Heigth -- ) + +: save_screen 0 0 cwidth &80 * cheight &25 * + scr>mem2 ; +: restore_screen 0 0 cwidth &80 * cheight &25 * + mem2>scr ; + + +\ *** Block No. 4 Hexblock 4 +\ Windowcomponents and Windowsize 30aug86we + +:name :move + :info + :uparrow + :dnarrow + :vslide + +Constant wi_components + +: wi_x ( -- n ) dx cwidth * ; +: wi_y ( -- n ) dy cheight * ; +: wi_width ( -- n ) c/l cwidth * ; +: wi_height ( -- n ) l/s cheight * ; + +: wi_size ( -- wx wy wwidth wheight ) + 0 wi_components + wi_x 1- wi_y 1- wi_width 2+ wi_height 2+ wind_calc + intout 2+ 4@ ; + + +\ *** Block No. 5 Hexblock 5 +\ Window's title and sliders 25sep86we + +Variable wi_handle + +: wi_string ( 0string function# -- ) swap >r + wi_handle @ swap r> >absaddr swap 0 0 wind_set ; + +: wi_title ( 0string -- ) :wf_name wi_string ; +: wi_status ( 0string -- ) :wf_info wi_string ; + +: vslide_size + wi_handle @ :wf_vslize &1000 capacity / 0 0 0 wind_set ; + +: vslide ( scr# -- ) wi_handle @ :wf_vslide + rot &1000 capacity dup 1- IF 1- THEN */ + 0 0 0 wind_set ; +\ *** Block No. 6 Hexblock 6 +\ Draw window on screen 30aug86we + +: small_big ( -- sx sy sw sh bx by bw bh ) + little 4@ wi_size ; + +: growbox small_big graf_growbox ; +: shrinkbox small_big graf_shrinkbox ; + +: wi_clear wi_x 1- wi_y 1- + over wi_width 1+ + over wi_height 1+ + fbox ; + + + + + + +\ *** Block No. 7 Hexblock 7 +\ Open and close window 30aug86we + +: wi_open ( -- ) save_screen growbox + wi_components wi_size wind_create dup wi_handle ! + pad dup off dup wi_title wi_status + wi_size wind_open wi_clear ; + +: wi_close ( -- ) + wi_handle @ dup wind_close wind_delete + shrinkbox restore_screen ; + + + + + + +\ *** Block No. 8 Hexblock 8 +\ redrawing the rest of screen 10sep86we + +: restore_rect ( x y w h -- ) 1- >r 1- r> mem2>scr ; + +: rect_update ( function# -- x y w h ) + 0 swap wind_get intout 2+ 4@ ; + +: redraw_screen :wf_firstxywh rect_update + BEGIN 2dup or + WHILE restore_rect :wf_nextxywh rect_update REPEAT + 2drop 2drop ; + +?head ! + + + +\ *** Block No. 9 Hexblock 9 + 14sep86we + + + + + + + + + + + + + + + +\ *** Block No. 10 Hexblock A +\ Window-Handling Loadscreen 14sep86we + +Suchreihenfolge: Zuerst GEM, dann FORTH + +Gebraucht werden die Definitionen aus GEMDEFS.SCR + +Dieses Vokabular wird als erstes durchsucht. + + + + + + + + + +\ *** Block No. 11 Hexblock B +\ VDI-Functions for window 14sep86we + +Fr das Fenster werden einige Funktionen aus VDI gebraucht, + die auf diesem Screen zusammengestellt sind. Beschreibung siehe + Beschreibung VDI (hoffentlich haben wir die schon!) + +Im Grunde wird nur eine Routine benutzt, mit der man ein weižes + Rechteck zum L”schen des Fensterinhaltes erzeugen kann. Dies + erledigt fbox + + + + + + + +\ *** Block No. 12 Hexblock C +\ save and restore the screen 14sep86we + +alle folgenden Funktionen sollen headerless kompiliert werden. + +Ein zweiter Speicherbereich wird gebraucht, um den Bildschirm + beim Verlassen des Editors zu restaurieren. Dieses Verfahren + ren ist erheblich schneller als die Neuausgabe des Bildschirms, + braucht aber Speicherplatz (Wir hams ja!) + + +Der gesamte Bildschirm wird in den dafr vorgesehenen Speicher- + bereich gerettet (aužerhalb des FORTH-Systems, versteht sich) +Das Ganze umgekehrt stellt den Bildschirm wieder her. Diese + Funktionen sind recht ntzlich, weil man Werte noch sehen kann, + die z.B. bei LIST weggescrollt wrden. + +\ *** Block No. 13 Hexblock D +\ Windowcomponents and Windowsize 14sep86we + +Die Bestandteile des Fensters werden einfach aufaddiert und +als Konstante zur Verfgung gestellt. + +linke obere Ecke des Fensters in Bildschirmkoordinaten + +Breite des Fensters in Bildschirmkoordinaten +H”he des Fensters in Bildschirmkoordinaten + +berechnet die Ausmaže des Fensters fr alle weiteren Funktionen + unter Zuhilfenahme von WIND-CALC. Leider liefert diese Funktion + bei Breite und H”he ein Pixel zu wenig. Digital Research allein + mag wissen, warum ... + + +\ *** Block No. 14 Hexblock E +\ Window's title and sliders 14sep86we + +Window-Handle des Fensters + +zur Ausgabe eines Textes in Titel- oder Infozeile + Der String muž mit einer Null abgeschlossen sein. + +gibt 0string in der Titelzeile aus. +gibt 0string in der Infozeile aus. + +Die Gr”že des vertikalen Sliders wird aus der Gesamtgr”že des + Files, das editiert wird, berechnet. + +Die Position des vertikalen Sliders wird relativ zur Gesamtgr”že + des Files eingestellt. + +\ *** Block No. 15 Hexblock F +\ Draw window on screen 14sep86we + +gibt die Gr”že eines kleinen Rechtecks sowie des ganzen Fensters + + +zeichnet ein wachsendes Rechteck (nur frs Auge ...) +zeichnet ein schrumpfendes Rechteck ( s.o.) + +l”scht den Innenraum des Fenster durch šberschreiben mit einem + weižen Rechteck. + + + + + + +\ *** Block No. 16 Hexblock 10 +\ Open and close window 14sep86we + +”ffnet das Editorfenster: Bildschirminhalt merken + Fenster erzeugen mit entsprechender Gr”že und Attributen + Titel- und Infozeile l”schen + Fenster auf dem Bildschirm ausgeben und Inhalt l”schen + +schliežt das Editorfenster: + Fenster vom Bildschirm und berhaupt entfernen + Bildschirm restaurieren. + + + + + + +\ *** Block No. 17 Hexblock 11 +\ redrawing the rest of screen 14sep86we + +Rechteck per Pixelmove restaurieren + +liefert die Koordinaten eines neu zu zeichnenden Rechtecks. + +Der Screenmanager stellt eine Liste von Rechtecken zurVerfgung, + die nach einer Aktion ge„ndert worden sind. + Durch diese Liste hangelt sich die Routine hindurch und + erzeugt die Rechtecke per Pixelmove (schnell) neu. + + + + + + diff --git a/sources/AtariST/ERRORBOX.FB.src b/sources/AtariST/ERRORBOX.FB.src deleted file mode 100644 index fb89892..0000000 --- a/sources/AtariST/ERRORBOX.FB.src +++ /dev/null @@ -1,102 +0,0 @@ -Screen 0 not modified - 0 ERRORBOX.SCR 26oct86we - 1 - 2 Dieses File gibt ABORT"-Fehlermeldungen in ALERT-Boxen aus. - 3 - 4 Diese Box enth„lt die Buttons "Cancel" und "Editor", falls der - 5 Fehler beim Laden eines Files auftrat. Der Button "Editor" - 6 verzweigt in den Editor, "Cancel" zum Kommandointerpreter. - 7 "Editor" ist der Defaultwert, der bei Drcken von - 8 ausgel”st wird. - 9 Trat der Fehler bei Ausfhrung von Tastatureingaben auf, gibt -10 es nur den OK-Button. -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Loadscreen for errorbox 26oct86we - 1 - 2 Onlyforth Gem also definitions - 3 - 4 0 list - 5 - 6 1 +load - 7 - 8 ' boxhandler errorhandler ! - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ Display all errors in an ALERT-Box 26oct86we - 1 - 2 | : addstring ( string -- ) \ add a string to pad - 3 count $add ; - 4 - 5 : boxhandler ( string -- ) - 6 show_c pad dup off $sum ! - 7 " [3][" addstring - 8 here addstring - 9 " |" addstring addstring -10 blk @ ?dup IF scr ! >in @ r# ! -11 2 " ][Cancel|Editor]" -12 ELSE 1 " ][Ok]" THEN addstring -13 pad c>0" pad form_alert hide_c -14 2 = IF v THEN quit ; -15 -Screen 3 not modified - 0 ERRORBOX.SCR 26oct86we - 1 - 2 Zugleich wollen wir zeigen, wie einfach unter volksFORTH Alert- - 3 Boxen programmiert werden k”nnen. Bei unserem Beispiel handelt - 4 es sich sogar um einen komplizierten Fall, weil der auszu- - 5 gebende String erst in PAD zusammengestellt werden muž. - 6 - 7 Ansonsten k”nnte eine Alert-Box z.B. so programmiert werden. - 8 (Das folgende Beispiel k”nnen Sie ausprobieren, indem Sie den - 9 Cursor in die n„chste Zeile setzen und CTRL-L eingeben. -10 -11 Create boxtext ," [3][Dies ist eine Alert-Box][Seh ich selbst]" -12 boxtext c>0" -13 -14 : test 1 boxtext form_alert drop ; -15 -Screen 4 not modified - 0 \ Loadscreen for errorbox 26oct86we - 1 - 2 setzt Searchorder auf GEM GEM FORTH ONLY GEM - 3 - 4 gibt Screen 0 mit der Anleitung aus. - 5 - 6 kompiliert den folgenden Screen. - 7 - 8 setzt BOXHANDLER als neuen errorhandler. Alle Fehlermeldungen, - 9 die ber abort" laufen, erscheinen jetzt in Boxen. -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ Display all errors in an ALERT-Box 26oct86we - 1 - 2 ADDSTRING h„ngt den String bei Adresse string an den String - 3 bei $SUM an. Benutzt $ADD aus dem File STRINGS.SCR - 4 - 5 BOXHANDLER gibt den String von ABORT" in einer Alert-Box aus. - 6 Maus einschalten und PAD als Ziel fr ADDSTRING vorbereiten. - 7 Die 3 sorgt fr das STOP-Icon in der Box. - 8 Bei HERE steht das Wort, das den Fehler verursacht hat. - 9 In die n„chste Zeile kommt die Fehlermeldung von ABORT" -10 Wenn der Fehler beim Kompilieren auftrat, werden Screen und -11 Cursorposition gemerkt und zwei Buttons ausgegeben. -12 Sonst kann man den Fehler nur quittieren. -13 Bei PAD ist jetzt der gesamte Boxtext zusammengestellt. -14 Falls 'EDITOR' angeklickt wurde, wird der Editor mit dem -15 fehlerhaften Screen aufgerufen. diff --git a/sources/AtariST/ERRORBOX.fth b/sources/AtariST/ERRORBOX.fth new file mode 100644 index 0000000..0b1d236 --- /dev/null +++ b/sources/AtariST/ERRORBOX.fth @@ -0,0 +1,102 @@ +\ *** Block No. 0 Hexblock 0 + ERRORBOX.SCR 26oct86we + +Dieses File gibt ABORT"-Fehlermeldungen in ALERT-Boxen aus. + +Diese Box enth„lt die Buttons "Cancel" und "Editor", falls der + Fehler beim Laden eines Files auftrat. Der Button "Editor" + verzweigt in den Editor, "Cancel" zum Kommandointerpreter. + "Editor" ist der Defaultwert, der bei Drcken von + ausgel”st wird. +Trat der Fehler bei Ausfhrung von Tastatureingaben auf, gibt + es nur den OK-Button. + + + + + +\ *** Block No. 1 Hexblock 1 +\ Loadscreen for errorbox 26oct86we + +Onlyforth Gem also definitions + +0 list + +1 +load + +' boxhandler errorhandler ! + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ Display all errors in an ALERT-Box 26oct86we + +| : addstring ( string -- ) \ add a string to pad + count $add ; + +: boxhandler ( string -- ) + show_c pad dup off $sum ! + " [3][" addstring + here addstring + " |" addstring addstring + blk @ ?dup IF scr ! >in @ r# ! + 2 " ][Cancel|Editor]" + ELSE 1 " ][Ok]" THEN addstring + pad c>0" pad form_alert hide_c + 2 = IF v THEN quit ; + +\ *** Block No. 3 Hexblock 3 + ERRORBOX.SCR 26oct86we + +Zugleich wollen wir zeigen, wie einfach unter volksFORTH Alert- + Boxen programmiert werden k”nnen. Bei unserem Beispiel handelt + es sich sogar um einen komplizierten Fall, weil der auszu- + gebende String erst in PAD zusammengestellt werden muž. + +Ansonsten k”nnte eine Alert-Box z.B. so programmiert werden. + (Das folgende Beispiel k”nnen Sie ausprobieren, indem Sie den + Cursor in die n„chste Zeile setzen und CTRL-L eingeben. + + Create boxtext ," [3][Dies ist eine Alert-Box][Seh ich selbst]" + boxtext c>0" + + : test 1 boxtext form_alert drop ; + +\ *** Block No. 4 Hexblock 4 +\ Loadscreen for errorbox 26oct86we + +setzt Searchorder auf GEM GEM FORTH ONLY GEM + +gibt Screen 0 mit der Anleitung aus. + +kompiliert den folgenden Screen. + +setzt BOXHANDLER als neuen errorhandler. Alle Fehlermeldungen, + die ber abort" laufen, erscheinen jetzt in Boxen. + + + + + + +\ *** Block No. 5 Hexblock 5 +\ Display all errors in an ALERT-Box 26oct86we + +ADDSTRING h„ngt den String bei Adresse string an den String + bei $SUM an. Benutzt $ADD aus dem File STRINGS.SCR + +BOXHANDLER gibt den String von ABORT" in einer Alert-Box aus. + Maus einschalten und PAD als Ziel fr ADDSTRING vorbereiten. + Die 3 sorgt fr das STOP-Icon in der Box. + Bei HERE steht das Wort, das den Fehler verursacht hat. + In die n„chste Zeile kommt die Fehlermeldung von ABORT" + Wenn der Fehler beim Kompilieren auftrat, werden Screen und + Cursorposition gemerkt und zwei Buttons ausgegeben. + Sonst kann man den Fehler nur quittieren. + Bei PAD ist jetzt der gesamte Boxtext zusammengestellt. + Falls 'EDITOR' angeklickt wurde, wird der Editor mit dem + fehlerhaften Screen aufgerufen. diff --git a/sources/AtariST/FILEINT.FB.src b/sources/AtariST/FILEINT.FB.src deleted file mode 100644 index 23c0828..0000000 --- a/sources/AtariST/FILEINT.FB.src +++ /dev/null @@ -1,1258 +0,0 @@ -Screen 0 not modified - 0 \\ *** File-Interface *** 25may86we - 1 - 2 Dieses File enth„lt das File-Interface. - 3 Damit wird der Zugriff auf normale GEM-Dos Files m”glich. Wenn - 4 ein File mit USE benutzt wird, beziehen sich alle Worte, die - 5 mit dem Massenspeicher arbeiten, auf dieses File. Ebenfalls un- - 6 tersttzt das File-Interface Subdirectories, sogar mit mehr - 7 M”glichkeiten als unter GEM-Dos. - 8 - 9 Da es normalerweise im Direktzugriff geladen wird, mssen die -10 View-Felder der Worte anschliežend gepatched werden -11 (s. STARTUP.SCR) -12 -13 -14 -15 -Screen 1 not modified - 0 \ File interface load and patch block 13oct86we - 1 - 2 Onlyforth - 3 - 4 1 3 +thru \ savesystem, always needed - 5 4 $21 +thru \ Fileinterface - 6 - 7 ' (makeview Is makeview - 8 ' remove-files Is custom-remove - 9 ' filer/w Is r/w -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ File functions for save-system cas20130105 - 1 - 2 : arguments ( n -- ) - 3 depth 1- > abort" not enough Parameters" ; - 4 - 5 | Code (createfile ( C$ -- handle ) - 6 0 # A7 -) move \ normal file, no protection - 7 SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move - 8 .w $3C # A7 -) move 1 trap 8 A7 addq - 9 D0 SP -) move Next end-code -10 -11 | Code (closefile ( handle -- f ) -12 SP )+ A7 -) move -13 $3E # A7 -) move 1 trap 4 A7 addq -14 D0 SP -) move Next end-code -15 -Screen 3 not modified - 0 \ write into file cas20130105 - 1 - 2 | Code (filewrite ( buff len handle -- n ) - 3 SP )+ D0 move .l D2 clr .w SP )+ D2 move - 4 SP )+ D6 move D6 reg) A0 lea - 5 .l A0 A7 -) move \ buffer adress - 6 D2 A7 -) move \ buffer length - 7 .w D0 A7 -) move \ handle - 8 $40 # A7 -) move \ call WRITE - 9 1 trap $0C # A7 adda -10 D0 SP -) move \ errorflag, num written Bytes -11 Next end-code -12 -13 -14 -15 -Screen 4 not modified - 0 \ save-system cas20130105 - 1 - 2 : save-system save flush \ Filename follows - 3 bl word count dup 0= abort" missing filename" - 4 over + off (createfile dup >r 0< abort" no device " - 5 $601A 0 ! align here $1C - $04 ! 0 , 0 , - 6 0 here r@ (filewrite here - abort" write error" - 7 r> (closefile 0< abort" close error" ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ disk errors 13oct86we - 1 - 2 Vocabulary Dos Dos also definitions - 3 - 4 | ' 2- Alias body> \ just for style - 5 - 6 - 7 - 8 - 9 -10 | : 2digits ( n -- adr len ) -11 base push decimal extend <# # # #> ; -12 -13 | 0 Constant #adr -14 \ will hold the adr of "00" in following abort" ..." -15 -Screen 6 not modified - 0 \ disk errors cas20130105 - 1 - 2 : .diskerror ( -n -- ) negate - 3 &13 case? abort" disk is proteced" - 4 &33 case? abort" file not found" - 5 &34 case? abort" path not found" - 6 &36 case? abort" access denied" - 7 &37 case? abort" illegal handle#" - 8 &46 case? abort" illegal drive num" - 9 2digits #adr swap cmove -10 true [ here 2+ ( adress of counted string ) ] -11 abort" Dos-Error #00" -12 [ count + 2- ' #adr >body ! ( adr of "00") ] ; -13 -14 : ?diskabort ( -n -- ) dup 0< IF .diskerror THEN drop ; -15 -Screen 7 not modified - 0 \ File control block structure 09sep86we - 1 - 2 | : Fcbyte ( n len -- n' ) \ defining word for fcb contents - 3 Create over c, + does> c@ + ; - 4 - 5 &25 Constant filenamelen \ only SHORT pathes will fit ! - 6 | 0 2 Fcbyte nextfile \ link to next file - 7 filenamelen Fcbyte filename \ name of file - 8 4 Fcbyte filesize \ size in Bytes , low..high - 9 2 Fcbyte filehandle \ handle from GEMdos -10 2 Fcbyte fileno \ fileno. for VIEW -11 Constant b/fcb \ bytes per file -12 -13 : handle ( -- n ) isfile@ filehandle @ ; -14 -15 \ *** nextfile must be the first field ! -Screen 8 not modified - 0 \ position into block 13oct86we - 1 - 2 Code lseek ( d handle n -- d' ) - 3 SP )+ A7 -) move SP )+ A7 -) move .l SP )+ A7 -) move - 4 .w $42 # A7 -) move 1 trap $0A # A7 adda - 5 .l D0 SP -) move Next end-code - 6 - 7 : position ( d handle -- f ) - 8 0 lseek 0< ?exit drop false ; - 9 -10 : position? ( handle -- d ) -11 0 0 rot 1 lseek dup 0< IF ?diskabort THEN ; -12 -13 -14 -15 -Screen 9 not modified - 0 \ read and write a memory area cas20130105 - 1 - 2 Code (fileread ( buff len handle -- n ) - 3 SP )+ D0 move .l D2 clr .w SP )+ D2 move - 4 SP )+ D6 move D6 reg) A0 lea - 5 .l A0 A7 -) move \ buffer adress - 6 D2 A7 -) move \ buffer length - 7 .w D0 A7 -) move \ handle - 8 $3F # A7 -) move \ call READ - 9 1 trap $0C # A7 adda -10 D0 SP -) move \ errorflag or bytes read -11 Next end-code -12 -13 ' (filewrite Alias (filewrite -14 -15 -Screen 10 not modified - 0 \ (open-file setdta 26oct86we - 1 - 2 Code (openfile ( C$ -- handle ) - 3 2 # A7 -) move - 4 SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move - 5 .w $3D # A7 -) move 1 trap 8 A7 addq - 6 D0 SP -) move Next end-code - 7 - 8 Create dta &44 allot - 9 -10 Code setdta ( addr -- ) -11 SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move -12 .w $1A # A7 -) move 1 trap 6 A7 addq Next end-code -13 -14 ' (closefile Alias (closefile -15 ' (createfile Alias (createfile -Screen 11 not modified - 0 \ search for files 03oct86we - 1 - 2 Code search0 ( C$ attr -- f ) \ search for first file - 3 SP )+ A7 -) move SP )+ D6 move D6 reg) A0 lea - 4 .l A0 A7 -) move .w $4E # A7 -) move 1 trap 8 A7 addq - 5 D0 SP -) move Next end-code - 6 - 7 Code searchnext ( -- f ) \ search for next file - 8 $4F # A7 -) move 1 trap 2 A7 addq - 9 D0 SP -) move Next end-code -10 -11 -12 -13 -14 -15 -Screen 12 not modified - 0 \ Create a subdir bp 11 oct 86 - 1 - 2 Code (makedir ( C$ -- f ) \ Create a subdir - 3 $39 # D1 move - 4 Label long-adr - 5 SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move - 6 .w D1 A7 -) move 1 trap 6 A7 addq - 7 D0 SP -) move Next end-code - 8 - 9 Code (setdir ( C$ -- f ) -10 $3B # D1 move long-adr bra end-code -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ select drive 09sep86we - 1 - 2 Code setdrive ( n -- ) - 3 SP )+ A7 -) move - 4 $0E # A7 -) move 1 trap 4 A7 addq Next end-code - 5 - 6 Code getdrive ( -- n ) - 7 $19 # A7 -) move 1 trap 2 A7 addq - 8 D0 SP -) move Next end-code - 9 -10 Code getdir ( addr n -- f ) \ n is drive, string in addr -11 SP )+ A7 -) move SP )+ D6 move D6 reg) A0 lea -12 .l A0 A7 -) move .w $47 # A7 -) move 1 trap 8 A7 addq -13 D0 SP -) move Next end-code -14 -15 -Screen 14 not modified - 0 \ file sizes b30aug86we - 1 - 2 : (capacity ( fcb -- n) \ calculates size in blocks - 3 filesize 2@ 2dup or 0= IF drop exit THEN - 4 b/blk um/mod swap IF 1+ THEN ; \ add 1 block for rest - 5 - 6 | : in-range ( block fcb -- f) \ makes sure, block is in file - 7 (capacity u< not &36 * ; \ Errorcode -&36 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ read and write into files bp 11 oct 86 - 1 - 2 | : set-pos ( block handle -- f) - 3 >r b/blk um* r> position ; - 4 - 5 | : fileaccess ( buff block fcb -- buff len handle/ errorcode) - 6 2dup in-range ?dup IF >r 2drop drop r> rdrop exit THEN - 7 filehandle @ under set-pos - 8 ?dup IF >r 2drop r> rdrop exit THEN - 9 b/blk swap ; -10 -11 | : fileread ( buff block fcb -- ff / errorcode ) -12 fileaccess (fileread dup 0> IF drop false THEN ; -13 -14 | : filewrite ( buff block fcb -- ff / errorcode ) -15 fileaccess (filewrite dup 0> IF drop false THEN ; -Screen 16 not modified - 0 \ twiggling the file variables bp 11 oct 86 - 1 - 2 : scan-name ( C$ -- adr len') \ length of "C"-string - 3 $1000 over swap 0 scan drop over - ; - 4 - 5 : .file ( fcb --) \ print only filename - 6 ?dup 0= IF ." DIRECT ! " exit THEN body> >name .name ; - 7 - 8 : .fcb ( fcb -- ) \ print filename - 9 dup filehandle @ 2 .r dup filesize 2@ 6 d.r 3 spaces -10 dup .file 2 spaces filename scan-name type ; -11 -12 : !files ( fcb -- ) \ set file and isfile -13 dup isfile ! fromfile ! ; -14 -15 -Screen 17 not modified - 0 \ PATHes bp 11 oct 86 - 1 - 2 | &30 Constant pathlen \ max. len of all pathes - 3 - 4 Variable pathes pathlen allot \ counted string of pathes - 5 pathes off - 6 - 7 : pathes? ( -- ) \ print a list of the pathes - 8 cr 3 spaces pathes count type ; - 9 -10 : setpath ( adr len --) \ set's the list of pathes -11 pathlen min pathes place -12 Ascii ; pathes count + c! pathes c@ 1+ pathes c! ; -13 -14 \\ PATH : see elsewhere in this file -15 -Screen 18 not modified - 0 \ search for files bp 11 oct 86 - 1 - 2 Variable workspace &64 allot \ place for c$ - 3 - 4 | : try.path ( adr len fcb attr -- f ) - 5 2swap workspace swap 2dup + >r move - 6 swap filename r> filenamelen cmove - 7 workspace swap search0 0= ; - 8 - 9 | : makec$ ( adr len -- c$ ) \ make adr len to a c$ -10 workspace swap 2dup + >r move -11 r> off ( make a c$ ) workspace ; -12 -13 -14 -15 -Screen 19 not modified - 0 \ " bp 11 oct 86 - 1 - 2 | Variable sfile \ "dirty" variable - 3 | 7 Constant defaultattr \ find all filetypes - 4 - 5 | : path@ ( adr len -- adr len1 adr len2) \ isolate a path - 6 Ascii ; skip 2dup 2dup Ascii ; scan nip - ; - 7 - 8 : (searchfile ( fcb -- ff/ C$ f) \ search for file in path - 9 sfile ! pathes count \ and in act. directory -10 BEGIN path@ sfile @ defaultattr try.path -11 IF 2drop workspace true exit THEN -12 Ascii ; scan dup 0= UNTIL nip ; -13 -14 : searchfile ( fcb -- C$ ) \ file was found in path -15 (searchfile ?exit -&33 ?diskabort ; -Screen 20 not modified - 0 \ open a file, filer/w b26oct86we - 1 - 2 | : @length ( -- d) dta &26 + 2@ ; - 3 | : copylength ( fcb --) @length rot filesize 2! ; - 4 - 5 : (open ( fcb --) \ open file - 6 dup filehandle @ IF drop exit THEN - 7 dta setdta dup searchfile over copylength (openfile - 8 dup ?diskabort swap filehandle ! ; - 9 -10 Forth definitions -11 -12 : capacity ( -- n) -13 isfile@ ?dup IF dup (open (capacity exit THEN blk/drv ; -14 -15 Dos definitions -Screen 21 not modified - 0 \ filer/w, Create a file bp 11 oct 86 - 1 - 2 : filer/w ( buff block fcb f -- f) - 3 over 0= IF STr/w exit THEN - 4 over (open - 5 IF fileread ELSE filewrite THEN dup ?diskabort ; - 6 - 7 : createfile ( fcb --) \ create a file in fcb - 8 dup filename (createfile dup ?diskabort - 9 over filehandle ! 0 0 rot filesize 2! -10 offset off ; -11 -12 -13 -14 -15 -Screen 22 not modified - 0 \ store names for files bp 11 oct 86 - 1 - 2 | : !name ( adr len --) \ store name in record - 3 2dup erase >r name count - 4 dup r> < not abort" string too long" - 5 >r swap r> cmove ; - 6 - 7 : !fcb ( fcb --) \ next word is filename - 8 dup filehandle off filename filenamelen !name ; - 9 -10 -11 -12 -13 -14 -15 -Screen 23 not modified - 0 \ print dta and directory 26oct86we - 1 - 2 | : .dtaname ( addr --) \ addr is addr of name - 3 dup BEGIN dup c@ ?dup WHILE emit 1+ REPEAT - 4 - &15 + spaces ; - 5 - 6 : .dta ( --) \ print contents of dta - 7 cr dta &21 + c@ $10 and - 8 IF Ascii D ELSE bl THEN emit space - 9 dta &30 + .dtaname @length &10 d.r ; -10 -11 : (dir ( attr adr len --) \ given a match string -12 makec$ swap dta setdta search0 -13 BEGIN 0= WHILE stop? 0= WHILE .dta searchnext REPEAT ; -14 -15 -Screen 24 not modified - 0 \ primitives for fcb's bp 18May86 - 1 - 2 User file-link file-link off \ list thru files - 3 - 4 | : #file ( -- n) \ View number of next file - 5 file-link @ dup IF fileno @ THEN 1+ ; - 6 - 7 - 8 : forthfiles ( --) \ print a list of : - 9 file-link @ \ forthword,filename,handle,len -10 BEGIN dup WHILE -11 cr dup .fcb @ stop? UNTIL drop ; -12 -13 -14 -15 -Screen 25 not modified - 0 \ Close a file bp 18May86 - 1 - 2 | ' save-buffers >body $C + @ Alias backup - 3 - 4 | : filebuffer? ( fcb -- fcb bufaddr/flag) - 5 prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; - 6 - 7 | : flushfile ( fcb -- ) \ flush file buffers - 8 BEGIN filebuffer? ?dup WHILE - 9 dup backup emptybuf REPEAT drop ; -10 -11 : (close ( fcb --) \ close file in fcb -12 dup flushfile -13 filehandle dup @ ?dup 0= IF drop exit THEN swap off -14 (closefile -$41 case? ?exit ?diskabort ; -15 -Screen 26 not modified - 0 \ Create fcb's bp 11 oct 86 - 1 - 2 Forth definitions - 3 - 4 - 5 : File ( -- ) \ Create a fcb - 6 Create here b/fcb allot dup b/fcb erase - 7 #file over fileno ! - 8 file-link @ over file-link ! swap ! - 9 does> !files ; -10 -11 : direct 0 !files ; \ switch to direct access -12 -13 -14 -15 -Screen 27 not modified - 0 \ flush buffers & misc. bp 8jun86 - 1 - 2 : flush ( --) flush file-link - 3 BEGIN @ ?dup WHILE dup (close REPEAT ; - 4 - 5 : file? isfile@ .file ; \ print current file - 6 - 7 : list ( n --) - 8 3 spaces file? list ; - 9 -10 : path ( -- ) \ this is a smart word ! -11 name count -12 dup 0= IF 2drop pathes? exit THEN -13 dup 1 = IF over c@ Ascii ; = -14 IF 2drop pathes off exit THEN THEN -15 setpath ; -Screen 28 not modified - 0 \ File Interface User words 26oct86we - 1 - 2 | : isfile? ( adr -- adr f) \ is adr a fcb ? - 3 file-link BEGIN @ dup 0= ?exit 2dup 2- = UNTIL drop true ; - 4 - 5 | : ?isfile@ isfile@ body> - 6 isfile? 0= abort" not in direct mode" >body ; - 7 - 8 : open ?isfile@ (open offset off ; - 9 : close ?isfile@ (close ; -10 : assign close isfile@ !fcb open ; -11 : make ?isfile@ dup !fcb createfile ; -12 -13 : use >in @ name find \ create a fcb if not present ! -14 IF isfile? IF execute drop exit THEN THEN drop -15 dup >in ! File dup >in ! ' execute >in ! assign ; -Screen 29 not modified - 0 \ File Interface User words bp 11 oct 86 - 1 - 2 : makefile >in @ file dup >in ! ' execute >in ! make ; - 3 - 4 : from isfile push use ; \ sets only fromfile - 5 : loadfrom ( n --) \ load 1 scr from file - 6 isfile push fromfile push use load close ; - 7 : include 1 loadfrom ; - 8 - 9 : eof ( -- f) \ end of file ? -10 isfile@ dup filehandle @ position? -11 rot filesize 2@ d= ; -12 -13 : files $10 " *.*" count (dir ; -14 : files" $10 Ascii " word count (dir ; -15 -Screen 30 not modified - 0 \ extend files bp 11 oct 86 - 1 - 2 | : >fileend isfile@ filesize 2@ handle position - 3 ?diskabort ; - 4 - 5 | : addsize isfile@ filesize dup 2@ b/blk 0 d+ rot 2! ; - 6 - 7 | : addblock ( n --) \ add block n to file - 8 buffer b/blk 2dup bl fill >fileend handle (filewrite - 9 dup ?diskabort b/blk - -10 IF close abort" Disk voll" THEN addsize ; -11 -12 : (more ( n --) -13 capacity swap bounds ?DO I addblock LOOP ; -14 -15 : more ( n --) ?isfile@ (open (more close ; -Screen 31 not modified - 0 \ make,kill and set directories bp 11 oct 86 - 1 - 2 | : dir$ ( -- adr ) name count makec$ ; - 3 - 4 : makedir dir$ (makedir ?diskabort ; - 5 - 6 : dir name count - 7 0 case? IF getdrive 2dup 1+ getdir ?diskabort - 8 cr 3 spaces Ascii A + emit ." :" - 9 scan-name type exit THEN -10 makec$ (setdir ?diskabort ; -11 -12 | : driveset Create c, Does> c@ setdrive ; -13 0 driveset A: 1 driveset B: 2 driveset C: 3 driveset D: -14 -15 -Screen 32 not modified - 0 \ words for VIEWing bcas20130105 - 1 - 2 | $200 Constant viewoffset \ max. &512 kbyte long files - 3 - 4 | : (makeview ( -- n) \ calc. view field for a name - 5 blk @ dup 0= ?exit - 6 loadfile @ ?dup IF fileno @ viewoffset * + THEN ; - 7 - 8 : (view ( blk -- blk') \ select file and leave block - 9 dup 0= ?exit -10 viewoffset u/mod file-link -11 BEGIN @ dup WHILE 2dup fileno @ = UNTIL -12 dup searchfile drop \ file not found : abort -13 !files drop ; -14 -15 -Screen 33 not modified - 0 \ ugly FORGETing of files bp 11 oct 86 - 1 - 2 : remove? ( dic symb addr -- dic symb addr f) - 3 dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; - 4 - 5 | : remove-files ( dic symb -- dic symb) \ flush files ! - 6 isfile @ remove? nip IF 0 !files THEN - 7 fromfile @ remove? nip IF fromfile off THEN - 8 file-link - 9 BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT -10 file-link remove ; -11 -12 -13 -14 -15 -Screen 34 not modified - 0 \ convey for files bp 11 oct 86 - 1 - 2 | : togglefiles ( -- ) \ changes isfile and fromfile - 3 isfile@ fromfile @ isfile ! fromfile ! ; - 4 - 5 : convey ( [blk1 blk2] [to.blk --) - 6 3 arguments >r 2dup swap - >r - 7 togglefiles dup capacity 1- > - 8 togglefiles r> r@ + capacity 1- > - 9 or abort" wrong range!" -10 r> convey ; -11 -12 -13 -14 -15 -Screen 35 not modified - 0 \ print a list of all blocks bp 9Apr86 - 1 - 2 : .blocks - 3 prev BEGIN @ ?dup WHILE stop? abort" stopped" - 4 cr dup u. dup 2+ @ dup 1+ - 5 IF ." Block :" over 4+ @ 5 .r - 6 ." File : " [ Dos ] .file - 7 dup 6 + @ 0< IF ." updated" THEN - 8 ELSE ." Block empty" drop THEN REPEAT ; - 9 -10 -11 -12 -13 -14 -15 -Screen 36 not modified - 0 \ create a file of direct blocks bcas20130105 - 1 - 2 Dos also - 3 - 4 | File outfile - 5 - 6 : blocks>file ( from to -- ) \ name of file follows - 7 ?isfile@ -rot outfile make - 8 1+ swap ?DO I over (block b/blk handle (filewrite - 9 b/blk - abort" write error" -10 LOOP close isfile ! ; -11 -12 -13 -14 -15 -Screen 37 not modified - 0 bp 4oct86 - 1 - 2 - 3 - 4 - 5 - 6 MAKEVIEW erzeugt aus ISFILE und BLK das Viewfeld - 7 CUSTOM-REMOVE erlaubt das FORGETten von eig. Datenstrukturen - 8 R/W setzt Forthbl”cke in Disksektoren um .... - 9 -10 -11 -12 -13 -14 -15 -Screen 38 not modified - 0 13oct86we - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 39 not modified - 0 13oct86we - 1 - 2 ARGUMENTS liefert etwas Sicherheit ... - 3 - 4 - 5 (CREATEFILE erzeugt ein File, dessen Namen in C$ steht, im - 6 aktuellen oder im durch den Pfadnamen angegebenen Directory. - 7 HANDLE ist die Handle des Files oder ein Fehlerflag. - 8 Es wird immer ein "ganz normales" File erzeugt. - 9 -10 (CLOSEFILE Schliežt das File mit der Handle HANDLE. Dabei -11 sollten alle TOS-Buffer zurckgeschrieben und das Directory -12 gesichert werden. F ist ein Fehlerflag. Die Handle ist -13 anschliežend ungltig. -14 -15 -Screen 40 not modified - 0 13oct86we - 1 - 2 (FILEWRITE schreibtLEN Bytes in das File HANDLE. Die Bytes - 3 werden ab Adresse BUFF im Speicher geholt. - 4 N ist die Zahl der geschriebenen Bytes oder eine - 5 Fehlernummer, wenn N zwischen -66 und -1 liegt. - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 41 not modified - 0 cas20130105 - 1 - 2 SAVE-SYSTEM speichert ein FORTH-System im aktuellen Zustand auf - 3 Diskette ab. - 4 - 5 Voodoo-Code fr den GEMDOS-Fileheader; keine Relokatinsinfos - 6 - 7 Mit SAVE-SYSTEM lassen sich eigene Arbeitssysteme oder auch - 8 Applikationen erstellen, denen man ihre FORTH-Herkunft nicht - 9 mehr ansieht. -10 Stellen Sie ein System nach Ihren Wnschen zusammen, und spei- -11 chern Sie es dann mit SAVE-SYSTEM MYPROG.PRG ab. -12 -13 -14 -15 -Screen 42 not modified - 0 13oct86we - 1 - 2 DOS enth„lt die "unwichtigen" Worte des - 3 Fileinterfaces - 4 - 5 BODY> ( cfa -- pfa ) Kompilationsadresse in - 6 Parameterfeldadresse umwandeln ... - 7 - 8 - 9 -10 Diese Worte werden fr die ble Patcherei in .diskabort benutzt. -11 Nur so kann die Dos-Fehlernummer in der abort" -Meldung unter- -12 gebracht werden. Bei einer Ausgabe mit . w„re keine Umleitung -13 ber ERRORHANDLER m”glich. -14 -15 -Screen 43 not modified - 0 13oct86we - 1 - 2 -n ist die Fehlernummer; es wird der zugeh”rige Text ausgedruckt - 3 - 4 - 5 - 6 - 7 - 8 - 9 Ist die Fehlernummer nicht in den CASE-Anweisungen zu finden, -10 wird Dos-Error # ausgegeben. Die Fehlernummer wird dann in -11 den abort" String gepatched. Dieses Verfahren ist zwar „užerst -12 h„žlich, nichtsdestoweniger aber sehr effektiv. -13 -14 Prft, ob ein Fehler vorliegt und druckt ggf. den Text aus und -15 ABORTed anschliežend. -Screen 44 not modified - 0 bp 4oct86 - 1 - 2 Definierendes Wort fr die Benamsung der Felder eines - 3 File control blocks ( FCB bzw. FILE in den Stackkommentaren) - 4 - 5 - 6 Zeiger auf den n„chsten FCB - 7 Platz fr max. 24 Zeichen fr den TOS-Filenamen - 8 L„nge des Files in Bytes - 9 Handlenummer, die das TOS beim ™ffnen eines Files liefert. -10 Eine eigene Nummer, die in das VIEW-Feld eingetragen wird. -11 L„nge eines FCB wird auch berechnet... -12 -13 Liefert die Handle des aktuellen Files. Null, falls das -14 File nicht offen . -15 -Screen 45 not modified - 0 bp 4oct86 - 1 - 2 LSEEK N ist ein Flag, das angibt, ob relativ zum - 3 Fileanfang, zum Fileende oder zur aktuellen Position im File - 4 positioniert werden soll. HANDLE ist die Handle des Files, in - 5 dem positioniert wird und D die neue Position im File. - 6 D' ist die neue Position. - 7 POSITION positioniert auf das Byte d, gez„hlt vom Anfang - 8 des Files mit der Handle HANDLE . - 9 -10 POSITION? liefert die Position des zuletzt gelesenen, -11 geschriebenen oder mit POSITION bzw. LSEEK angew„hlten Bytes. -12 -13 -14 -15 -Screen 46 not modified - 0 13oct86we - 1 - 2 FILEREAD liest LEN Bytes aus dem File HANDLE. Die Bytes - 3 werden ab Adresse BUFF im Speicher abgelegt. - 4 N ist die Zahl der gelesenen Bytes oder eine Fehlernummer, - 5 wenn N zwischen -66 und -1 liegt. - 6 - 7 - 8 - 9 -10 -11 -12 -13 Das headerlose (FILEWRITE bekommt nun einen Header im Vocabulary -14 Dos. -15 -Screen 47 not modified - 0 26oct86we - 1 - 2 OPENFILE ™ffnet ein File. Der Name steht im String C$. - 3 C$ ist durch ein $00-Byte begrenzt. HANDLE ist die diesem - 4 File zugeordnete Handle oder eine Fehlernummer. - 5 - 6 - 7 - 8 DTA ist ein 44 Byte grožer Buffer, in dem einige - 9 Fileinformationen vom GEMDOS gehalten werden. -10 SETDTA ADDR ist die Adresse der 'disk transfer area'. -11 -12 -13 -14 (CLOSEFILE und (CREATEFILE erhalten Header im Vocabulary Dos. -15 -Screen 48 not modified - 0 13oct86we - 1 - 2 SEARCH0 SEARCH0 sucht ein File. C$ ist der Name des File - 3 mit Pfad usw. . C$ wird, wie immer, durch ein $00-Byte - 4 begrenzt. ATTR ist ein Attributwort, das z.B. bestimmt, ob - 5 auch Subdirectories gefunden werden. F ist ein Fehlerflag. - 6 Die DTA enth„lt anschliežend Filenamen, -l„nge usw. - 7 SEARCHNEXT sucht das n„chste File mit dem bei SEARCH0 - 8 angegeben Namen... - 9 -10 -11 -12 -13 -14 -15 -Screen 49 not modified - 0 13oct86we - 1 - 2 (MAKEDIR erzeugt „hnlich (CREATEFILE ein Subdirectory. - 3 C$ ist der Name des Directories, F ist ein Fehlerflag. - 4 - 5 - 6 - 7 - 8 - 9 (SETDIR setzt das durch C$ angegeben Subdirectory als -10 das "Aktuelle", auf das sich alle Such- und "Erzeugungs-" -11 operationen ohne eigenen Pfadnamen beziehen. -12 -13 -14 -15 -Screen 50 not modified - 0 bp 4oct86 - 1 - 2 SETDRIVE N ist die Nummer des aktuellen Laufwerkes, auf - 3 das sich alle Operationen ohne eigenen Pfadnamen beziehen. - 4 Vergleiche (SETDIR. Laufwerk A: hat die Nummer 0 ! - 5 - 6 GETDRIVE N ist die Nummer des bei SETDRIVE genannten - 7 Laufwerks. - 8 - 9 -10 GETDIR Das durch (SETDIR gesetzte Subdirectory wird -11 ab Adresse ADDR als C$ im Speicher abgelegt. N ist die Nummer -12 des Laufwerkes ( Laufwerk A: hat die Nummer 1 !!!! ), denn -13 verschiedene Laufwerke k”nnen verschiedene aktuelle Sub- -14 directories haben. -15 -Screen 51 not modified - 0 bp 4oct86 - 1 - 2 (CAPACITY FCB ist die Adresse des FCB des Files, von - 3 dem die L„nge in Blocks bestimmt werden soll. N ist dann - 4 die Zahl der Bl”cke in diesem File. - 5 - 6 IN-RANGE prft, ob sich ein Block mit der Nummer BLOCK - 7 im File FCB befindet. Ist das nicht der Fall, wird als - 8 Fehlernummer -36 geliefert. Siehe auch ?DISKABORT - 9 -10 -11 -12 -13 -14 -15 -Screen 52 not modified - 0 13oct86we - 1 - 2 SET-POS positioniert im File mit der Handle HANDLE auf - 3 den Anfangs des Blocks BLOCK. F ist ein Fehlerflag. - 4 - 5 FILEACCESS wird in FILEREAD und FILEWRITE ben”tigt. - 6 - 7 - 8 - 9 -10 -11 FILEREAD liest den Block BLOCK an die Adresse BUFF aus -12 dem File FCB. Hinterl„žt eine Fehlernummer. -13 -14 FILEWRITE berschreibt den Block BLOCK mit den Daten ab -15 Adresse BUFF im File FCB. Hinterl„žt eine Fehlernummer. -Screen 53 not modified - 0 bp 4oct86 - 1 - 2 SCAN-NAME 'LEN ist die L„nge eines durch ein $00-Byte - 3 begrenzten C$. - 4 - 5 .FILE druckt den Forthnamen des Files mit der Adresse - 6 FCB. - 7 - 8 .FCB druckt Forthnamen, TOS-Namen, Handle und L„nge - 9 des Files mit der Adresse FCB aus. -10 -11 !FILES setzt die Variable ISFILE und FROMFILE (darin -12 steht das File, aus dem bei COPY und CONVEY gelesen wird) -13 auf das File mit der Adresse FCB. -14 -15 -Screen 54 not modified - 0 bp 4oct86 - 1 - 2 PATHES Hier ist Platz fr den durch SETPATH angegeben - 3 String, der die Namen der zu durchsuchenden Laufwerke und - 4 Directories enth„lt. - 5 PATHES? Druckt den Inhalt von PATHES aus. - 6 - 7 SETPATH Setzt PATHES auf den String ab der Adresse ADR, - 8 dessen L„nge LEN ist. Anschliežend wird noch ein ; angefgt, - 9 um auch den letzten Path korrekt zu beenden. -10 -11 -12 -13 -14 -15 -Screen 55 not modified - 0 bp 4oct86 - 1 - 2 WORKSPACE Hier wird aus File- und Pathnamen ein C$ - 3 zusammengebastelt. - 4 - 5 TRY.PATH ADR und LEN enthalten den Pfadnamen (aus - 6 PATHES mit PATH@ extrahiert), FCB ist die Adresse des Files - 7 und ATTR ein Attribut (siehe SEARCH0). Aus Pfadnamen und FCB - 8 wird in WORKSPACE ein String zusammengebastelt, der dann mit - 9 SEARCH0 gesucht wird. F gibt an, ob wir erfolgreich waren. -10 -11 MAKEC$ konvertiert einen durch ADR und LEN definierten -12 String in einen C$ (durch ein $00-Byte begrenzt) und -13 hinterl„žt dessen Adresse. -14 -15 -Screen 56 not modified - 0 bp 4oct86 - 1 - 2 SFILE enth„lt die Adresse des FCB des gesuchten Files. - 3 DEFAULTATTR enstpricht "Suche alle Files, egal welches ATTR" - 4 - 5 PATH@ extrahiere aus dem noch nicht zum Suchen verwen- - 6 deten Teil von PATHES, der durch ADR und LEN angegeben wird, - 7 den n„chsten zu durchsuchenden Pfad ADR LEN1. - 8 (SEARCHFILE durchsucht alle in PATHES stehenden Pfade nach - 9 dem in FCB stehenden Filenamen. Aufgeh”rt wird, wenn das File -10 gefunden wurde oder alle Pfade durchsucht wurden. -11 Am Schluž wird auch der leere Pfad (L„nge Null) durchsucht, -12 der dem aktuellen Directory (siehe SETDIR) entspricht. -13 -14 SEARCHFILE Sucht das File FCB in allen Pfaden und im akt. -15 Directory. Hinterlassen wird der vollst„ndige Pfad des Files. -Screen 57 not modified - 0 bp 4oct86 - 1 - 2 @LENGTH holt die L„nge des zuletzt gefundenen Files - 3 COPYLENGTH kopiert die L„nge des zuletzt gefundenen Files - 4 in den Fcb FCB. - 5 (OPEN ”ffnet das durch FCB angegebene File - 6 und speichert LEN dort die Handle und L„nge. Dazu muž es - 7 natrlich erst gesucht werden, denn nur dann steht die L„nge - 8 in der DTA. - 9 -10 -11 -12 CAPACITY N ist die Zahl der Bl”cke im aktuellen (durch -13 ISFILE angegeben) File. Ist ISFILE Null, so wird die Kapazit„t -14 der Diskette im Direktzugriff angegeben. -15 -Screen 58 not modified - 0 bp 4oct86 - 1 - 2 FILER/W ist das zentrale Wort fr den Zugriff auf Files. - 3 BUFF ist die Adresse des Blocks BLOCK im Speicher, FCB die - 4 Nummer des Files (0 heižt Direktzugriff) und R/W gibt an, in - 5 welcher Richtung die Daten zu transportieren sind. - 6 F ist true, falls ein Fehler auftrat. - 7 - 8 CREATEFILE erzeugt ein File, dessen Name im Fcb FCB steht. - 9 Handle und Filel„nge werden korrigiert. -10 -11 -12 -13 -14 -15 -Screen 59 not modified - 0 bp 4oct86 - 1 - 2 !NAME speichert einen auf !NAME folgenden String - 3 ab Adresse ADR mit maximaler L„nge LEN im Speicher ab. - 4 Der String wird durch $00-Bytes begrenzt. - 5 - 6 - 7 !FCB speichert einen auf !FCB folgenden String im - 8 Fcb FCB ab. Die Handle wird gel”scht, weil das - 9 so zugewiesene File noch nicht ge”ffnet worden ist. -10 -11 -12 -13 -14 -15 -Screen 60 not modified - 0 13oct86we - 1 - 2 .DTANAME druckt den Filenamen, er ab Adresse d in der DTA - 3 steht, linksbndig in einem Feld der Breite 15 aus. - 4 - 5 - 6 .DTA druckt den Inhalt der DTA formattiert aus. - 7 Zun„chst wird ein "D" ausgegeben, das anzeigt, ob es sich - 8 um ein Subdirectory handelt, anschliežend der Name gefolgt - 9 von der L„nge des Files. -10 -11 (DIR druckt alle Files aus, auf die der String ADR -12 LEN und das Attribut ATTR "passt". Die Ausgabe kann wie -13 blich angehalten und abgebrochen werden. -14 -15 -Screen 61 not modified - 0 bp 4oct86 - 1 - 2 FILE-LINK enth„lt einen Zeiger auf den FCB des - 3 zuletzt definierten Files. - 4 #FILE N ist die Nummer, die in das Viewfeld des - 5 n„chsten zu definierenden Files eingetragen werden soll. - 6 - 7 - 8 FORTHFILES druckt die Forth- und TOS-Namen mit Handle und - 9 L„nge aller definierten Files aus. Dazu wird FILE-LINK -10 benutzt. Die Ausgabe kann wie blich angehalten oder beendet -11 werden. -12 -13 -14 -15 -Screen 62 not modified - 0 bp 4oct86 - 1 - 2 FILEBUFFER? guckt nach, ob zu dem File FCB noch ein Block- - 3 puffer exisitiert. Liefert false, falls keiner vorhanden ist. - 4 - 5 FLUSHFILE sichert alle zum File FCB geh”renden Blockpuffer - 6 auf dem Massenspeicher und l”scht sie anschliežend. - 7 - 8 - 9 (CLOSE sichert alle Blockpuffer, schliežt anschliežend -10 das File, falls es nicht schon geschlossen war und ignoriert -11 den Fehler mit der Nummer -65, weil der so oft auftritt... -12 -13 -14 -15 -Screen 63 not modified - 0 bp 4oct86 - 1 - 2 FILE ist ein definierendes Wort, daž einen FCB - 3 erzeugt. Wird der FCB sp„ter ausgefhrt, so tr„gt er sich - 4 als aktuelles File und als FROMFILE ein. - 5 - 6 - 7 - 8 DIRECT ein "spezieller FCB" fr den Direktzugriff. - 9 Der Direktzugriff ist immer dann interessant, wenn man -10 einen Diskmonitor braucht, ihn aber gerade verliehen hat... -11 -12 -13 -14 -15 -Screen 64 not modified - 0 bp 4oct86 - 1 - 2 FLUSH schliežt zus„tzlich alle Files.. - 3 - 4 - 5 FILE? druckt den Namen des aktuellen Files aus. - 6 - 7 LIST druckt zus„tzlich den Filenamen aus... - 8 - 9 -10 PATH druckt PATHES aus oder -11 l”scht PATHES oder -12 setzt PATHES auf einen anderen String. -13 -14 -15 -Screen 65 not modified - 0 13oct86we - 1 - 2 ISFILE? F ist wahr, falls ADR die Kompilationsadresse - 3 eines FCB ist (also durch FILE erzeugt wurde...). - 4 - 5 ?ISFILE@ steht in ISFILE berhaupt ein File ? - 6 - 7 OPEN ”ffnet das aktuelle File. - 8 CLOSE schliežt es. - 9 ASSIGN Anderer Filename in aktuellen FCB eintragen. -10 MAKE Neu erzeugter Filename in aktuellen FCB.. -11 -12 USE Erzeuge FCB (mit Filenamen !), falls Name nicht -13 schon vorhanden. Wenn Name vorhanden, prfe ob es File ist. -14 Trage dann FCB in ISFILE ein. -15 -Screen 66 not modified - 0 13oct86we - 1 - 2 MAKEFILE erzeugt FCB und File gleichen Namens. - 3 - 4 FROM setzt FROMFILE fr COPY und CONVEY - 5 LOADFROM l„dt den Screen N vom File, dessen Name auf - 6 LOADFROM folgt. z.B. 1 loadfrom forth_83.scr - 7 INCLUDE l„dt den Loadscreen des Files... - 8 - 9 EOF F ist wahr, falls wir am Ende des Files -10 angekommen sind. -11 -12 -13 FILES liefert Inhaltsverzeichnis des akt. Directories. -14 FILES" erlaubt Pfad- und Filenamen -15 -Screen 67 not modified - 0 bp 4oct86 - 1 - 2 >FILEEND springe ans Ende des aktuellen Files - 3 - 4 - 5 ADDSIZE erh”ht die L„ngenangabe im aktuellen FCB um - 6 1024 Bytes. - 7 ADDBLOCK fgt den Block N am Fileende an. - 8 Aužerdem wird ein leerer Buffer mit dieser Nummer angelegt. - 9 -10 -11 -12 (MORE fgt n Bl”cke am Fileende an. -13 -14 MORE Wie (MORE, jedoch etwas Sicherheit.. -15 -Screen 68 not modified - 0 13oct86we - 1 - 2 DIR$ ADR ist die Adresse eines auf DIR$ folgenden C$. - 3 - 4 MAKEDIR erzeugt ein Directory mit dem folgenden Namen.. - 5 - 6 DIR gibt, falls kein Name folgt, das aktuelle Lauf- - 7 werk und Subdirectory aus. Folgt ein Name, so wird er als - 8 das neue aktuelle Directory an das TOS bergeben. - 9 -10 -11 -12 A: B: C: D: Kurzformen fr SETDRIVE. -13 -14 -15 -Screen 69 not modified - 0 13oct86we - 1 - 2 VIEWOFFSET teilt das 16-Bit Viewfeld in ein Feld mit der - 3 Filenummer und ein Feld mit der Blocknummer. Die unteren 9 - 4 Bits sind fr die Blocknummer reserviert. - 5 (MAKEVIEW macht aus BLK und der Nummer des geladenen Files - 6 LOADFILE eine 16-Bit Zahl, die von CREATE dann als Viewfeld - 7 hinterlegt wird. - 8 (VIEW zerlegt den Inhalt BLK eines Viewfeldes in - 9 Filenummer und Blocknummer BLK' . Der zur Filenummer -10 geh”rende FCB wird gesucht, und falls gefunden, in ISFILE -11 und FROMFILE eingetragen. Kann kein FCB gefunden werden, -12 so wird eine Fehlermeldung ausgegeben. -13 -14 -15 -Screen 70 not modified - 0 bp 4oct86 - 1 - 2 REMOVE? DIC (SYMB) ist die Adresse im Dictionary (HEAP), - 3 oberhalb (unterhalb, der Heap w„chst von oben nach unten !) - 4 derer alle Worte vergessen werden mssen. F gibt an, ob - 5 ADDR innerhalb des zu vergessenden Intervalls liegt. - 6 - 7 REMOVE-FILES guckt nach, ob ISFILE oder FROMFILE vergessen - 8 werden. Ist das der Fall, so werden sie auf den Direktzugriff - 9 umgeschaltet. -10 Anschliežend werden alle zu vergessenden Files geschlossen -11 und aus der Liste aller Files FILE-LINK entfernt. -12 -13 -14 -15 -Screen 71 not modified - 0 bp 4oct86 - 1 - 2 TOGGLEFILES vertauscht ISFILE und FROMFILE. - 3 - 4 - 5 CONVEY prft, ob die zu bewegenden Bl”cke vorhanden - 6 sind und bewegt sie ggf. - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 72 not modified - 0 13oct86we - 1 - 2 .BLOCKS listet den Inhalt der Blockpuffer auf. - 3 Angegeben werden Adresse, Blocknummer und Filename sowie, - 4 ob der Block geUPDATEd wurde. - 5 - 6 Bei der Entwicklung des Fileinterfaces war das ein ntzliches - 7 Hilfsmittel. - 8 - 9 -10 Dieser und der n„chste Screen werden normalerweise vom Load- -11 screen nicht mitkompiliert. -12 -13 -14 -15 -Screen 73 not modified - 0 13oct86we - 1 - 2 - 3 - 4 - 5 - 6 Mit BLOCKS>FILE l„žt sich eine Folge von Diskettenbl”cken in - 7 einem File ablegen. Damit k”nnen Disketten, die bisher im - 8 Direktzugriff benutzt worden sind, auf das Fileinterface um- - 9 gestellt werden. -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/FILEINT.fth b/sources/AtariST/FILEINT.fth new file mode 100644 index 0000000..98133d6 --- /dev/null +++ b/sources/AtariST/FILEINT.fth @@ -0,0 +1,1258 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** File-Interface *** 25may86we + +Dieses File enth„lt das File-Interface. +Damit wird der Zugriff auf normale GEM-Dos Files m”glich. Wenn +ein File mit USE benutzt wird, beziehen sich alle Worte, die +mit dem Massenspeicher arbeiten, auf dieses File. Ebenfalls un- +tersttzt das File-Interface Subdirectories, sogar mit mehr +M”glichkeiten als unter GEM-Dos. + +Da es normalerweise im Direktzugriff geladen wird, mssen die +View-Felder der Worte anschliežend gepatched werden +(s. STARTUP.SCR) + + + + +\ *** Block No. 1 Hexblock 1 +\ File interface load and patch block 13oct86we + +Onlyforth + +1 3 +thru \ savesystem, always needed +4 $21 +thru \ Fileinterface + +' (makeview Is makeview +' remove-files Is custom-remove +' filer/w Is r/w + + + + + + +\ *** Block No. 2 Hexblock 2 +\ File functions for save-system cas20130105 + +: arguments ( n -- ) + depth 1- > abort" not enough Parameters" ; + +| Code (createfile ( C$ -- handle ) + 0 # A7 -) move \ normal file, no protection + SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move + .w $3C # A7 -) move 1 trap 8 A7 addq + D0 SP -) move Next end-code + +| Code (closefile ( handle -- f ) + SP )+ A7 -) move + $3E # A7 -) move 1 trap 4 A7 addq + D0 SP -) move Next end-code + +\ *** Block No. 3 Hexblock 3 +\ write into file cas20130105 + +| Code (filewrite ( buff len handle -- n ) + SP )+ D0 move .l D2 clr .w SP )+ D2 move + SP )+ D6 move D6 reg) A0 lea + .l A0 A7 -) move \ buffer adress + D2 A7 -) move \ buffer length + .w D0 A7 -) move \ handle + $40 # A7 -) move \ call WRITE + 1 trap $0C # A7 adda + D0 SP -) move \ errorflag, num written Bytes + Next end-code + + + + +\ *** Block No. 4 Hexblock 4 +\ save-system cas20130105 + +: save-system save flush \ Filename follows + bl word count dup 0= abort" missing filename" + over + off (createfile dup >r 0< abort" no device " + $601A 0 ! align here $1C - $04 ! 0 , 0 , + 0 here r@ (filewrite here - abort" write error" + r> (closefile 0< abort" close error" ; + + + + + + + + +\ *** Block No. 5 Hexblock 5 +\ disk errors 13oct86we + +Vocabulary Dos Dos also definitions + +| ' 2- Alias body> \ just for style + + + + + +| : 2digits ( n -- adr len ) + base push decimal extend <# # # #> ; + +| 0 Constant #adr + \ will hold the adr of "00" in following abort" ..." + +\ *** Block No. 6 Hexblock 6 +\ disk errors cas20130105 + +: .diskerror ( -n -- ) negate + &13 case? abort" disk is proteced" + &33 case? abort" file not found" + &34 case? abort" path not found" + &36 case? abort" access denied" + &37 case? abort" illegal handle#" + &46 case? abort" illegal drive num" + 2digits #adr swap cmove + true [ here 2+ ( adress of counted string ) ] + abort" Dos-Error #00" + [ count + 2- ' #adr >body ! ( adr of "00") ] ; + +: ?diskabort ( -n -- ) dup 0< IF .diskerror THEN drop ; + +\ *** Block No. 7 Hexblock 7 +\ File control block structure 09sep86we + +| : Fcbyte ( n len -- n' ) \ defining word for fcb contents + Create over c, + does> c@ + ; + +&25 Constant filenamelen \ only SHORT pathes will fit ! +| 0 2 Fcbyte nextfile \ link to next file +filenamelen Fcbyte filename \ name of file + 4 Fcbyte filesize \ size in Bytes , low..high + 2 Fcbyte filehandle \ handle from GEMdos + 2 Fcbyte fileno \ fileno. for VIEW + Constant b/fcb \ bytes per file + +: handle ( -- n ) isfile@ filehandle @ ; + +\ *** nextfile must be the first field ! +\ *** Block No. 8 Hexblock 8 +\ position into block 13oct86we + +Code lseek ( d handle n -- d' ) + SP )+ A7 -) move SP )+ A7 -) move .l SP )+ A7 -) move + .w $42 # A7 -) move 1 trap $0A # A7 adda + .l D0 SP -) move Next end-code + +: position ( d handle -- f ) + 0 lseek 0< ?exit drop false ; + +: position? ( handle -- d ) + 0 0 rot 1 lseek dup 0< IF ?diskabort THEN ; + + + + +\ *** Block No. 9 Hexblock 9 +\ read and write a memory area cas20130105 + +Code (fileread ( buff len handle -- n ) + SP )+ D0 move .l D2 clr .w SP )+ D2 move + SP )+ D6 move D6 reg) A0 lea + .l A0 A7 -) move \ buffer adress + D2 A7 -) move \ buffer length + .w D0 A7 -) move \ handle + $3F # A7 -) move \ call READ + 1 trap $0C # A7 adda + D0 SP -) move \ errorflag or bytes read + Next end-code + +' (filewrite Alias (filewrite + + +\ *** Block No. 10 Hexblock A +\ (open-file setdta 26oct86we + +Code (openfile ( C$ -- handle ) + 2 # A7 -) move + SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move + .w $3D # A7 -) move 1 trap 8 A7 addq + D0 SP -) move Next end-code + +Create dta &44 allot + +Code setdta ( addr -- ) + SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move + .w $1A # A7 -) move 1 trap 6 A7 addq Next end-code + +' (closefile Alias (closefile +' (createfile Alias (createfile +\ *** Block No. 11 Hexblock B +\ search for files 03oct86we + +Code search0 ( C$ attr -- f ) \ search for first file + SP )+ A7 -) move SP )+ D6 move D6 reg) A0 lea + .l A0 A7 -) move .w $4E # A7 -) move 1 trap 8 A7 addq + D0 SP -) move Next end-code + +Code searchnext ( -- f ) \ search for next file + $4F # A7 -) move 1 trap 2 A7 addq + D0 SP -) move Next end-code + + + + + + +\ *** Block No. 12 Hexblock C +\ Create a subdir bp 11 oct 86 + +Code (makedir ( C$ -- f ) \ Create a subdir + $39 # D1 move +Label long-adr + SP )+ D6 move D6 reg) A0 lea .l A0 A7 -) move + .w D1 A7 -) move 1 trap 6 A7 addq + D0 SP -) move Next end-code + +Code (setdir ( C$ -- f ) + $3B # D1 move long-adr bra end-code + + + + + +\ *** Block No. 13 Hexblock D +\ select drive 09sep86we + +Code setdrive ( n -- ) + SP )+ A7 -) move + $0E # A7 -) move 1 trap 4 A7 addq Next end-code + +Code getdrive ( -- n ) + $19 # A7 -) move 1 trap 2 A7 addq + D0 SP -) move Next end-code + +Code getdir ( addr n -- f ) \ n is drive, string in addr + SP )+ A7 -) move SP )+ D6 move D6 reg) A0 lea + .l A0 A7 -) move .w $47 # A7 -) move 1 trap 8 A7 addq + D0 SP -) move Next end-code + + +\ *** Block No. 14 Hexblock E +\ file sizes b30aug86we + +: (capacity ( fcb -- n) \ calculates size in blocks + filesize 2@ 2dup or 0= IF drop exit THEN + b/blk um/mod swap IF 1+ THEN ; \ add 1 block for rest + +| : in-range ( block fcb -- f) \ makes sure, block is in file + (capacity u< not &36 * ; \ Errorcode -&36 + + + + + + + + +\ *** Block No. 15 Hexblock F +\ read and write into files bp 11 oct 86 + +| : set-pos ( block handle -- f) + >r b/blk um* r> position ; + +| : fileaccess ( buff block fcb -- buff len handle/ errorcode) + 2dup in-range ?dup IF >r 2drop drop r> rdrop exit THEN + filehandle @ under set-pos + ?dup IF >r 2drop r> rdrop exit THEN + b/blk swap ; + +| : fileread ( buff block fcb -- ff / errorcode ) + fileaccess (fileread dup 0> IF drop false THEN ; + +| : filewrite ( buff block fcb -- ff / errorcode ) + fileaccess (filewrite dup 0> IF drop false THEN ; +\ *** Block No. 16 Hexblock 10 +\ twiggling the file variables bp 11 oct 86 + +: scan-name ( C$ -- adr len') \ length of "C"-string + $1000 over swap 0 scan drop over - ; + +: .file ( fcb --) \ print only filename + ?dup 0= IF ." DIRECT ! " exit THEN body> >name .name ; + +: .fcb ( fcb -- ) \ print filename + dup filehandle @ 2 .r dup filesize 2@ 6 d.r 3 spaces + dup .file 2 spaces filename scan-name type ; + +: !files ( fcb -- ) \ set file and isfile + dup isfile ! fromfile ! ; + + +\ *** Block No. 17 Hexblock 11 +\ PATHes bp 11 oct 86 + +| &30 Constant pathlen \ max. len of all pathes + +Variable pathes pathlen allot \ counted string of pathes + pathes off + +: pathes? ( -- ) \ print a list of the pathes + cr 3 spaces pathes count type ; + +: setpath ( adr len --) \ set's the list of pathes + pathlen min pathes place + Ascii ; pathes count + c! pathes c@ 1+ pathes c! ; + +\\ PATH : see elsewhere in this file + +\ *** Block No. 18 Hexblock 12 +\ search for files bp 11 oct 86 + +Variable workspace &64 allot \ place for c$ + +| : try.path ( adr len fcb attr -- f ) + 2swap workspace swap 2dup + >r move + swap filename r> filenamelen cmove + workspace swap search0 0= ; + +| : makec$ ( adr len -- c$ ) \ make adr len to a c$ + workspace swap 2dup + >r move + r> off ( make a c$ ) workspace ; + + + + +\ *** Block No. 19 Hexblock 13 +\ " bp 11 oct 86 + +| Variable sfile \ "dirty" variable +| 7 Constant defaultattr \ find all filetypes + +| : path@ ( adr len -- adr len1 adr len2) \ isolate a path + Ascii ; skip 2dup 2dup Ascii ; scan nip - ; + +: (searchfile ( fcb -- ff/ C$ f) \ search for file in path + sfile ! pathes count \ and in act. directory + BEGIN path@ sfile @ defaultattr try.path + IF 2drop workspace true exit THEN + Ascii ; scan dup 0= UNTIL nip ; + +: searchfile ( fcb -- C$ ) \ file was found in path + (searchfile ?exit -&33 ?diskabort ; +\ *** Block No. 20 Hexblock 14 +\ open a file, filer/w b26oct86we + +| : @length ( -- d) dta &26 + 2@ ; +| : copylength ( fcb --) @length rot filesize 2! ; + +: (open ( fcb --) \ open file + dup filehandle @ IF drop exit THEN + dta setdta dup searchfile over copylength (openfile + dup ?diskabort swap filehandle ! ; + +Forth definitions + +: capacity ( -- n) + isfile@ ?dup IF dup (open (capacity exit THEN blk/drv ; + +Dos definitions +\ *** Block No. 21 Hexblock 15 +\ filer/w, Create a file bp 11 oct 86 + +: filer/w ( buff block fcb f -- f) + over 0= IF STr/w exit THEN + over (open + IF fileread ELSE filewrite THEN dup ?diskabort ; + +: createfile ( fcb --) \ create a file in fcb + dup filename (createfile dup ?diskabort + over filehandle ! 0 0 rot filesize 2! + offset off ; + + + + + +\ *** Block No. 22 Hexblock 16 +\ store names for files bp 11 oct 86 + +| : !name ( adr len --) \ store name in record + 2dup erase >r name count + dup r> < not abort" string too long" + >r swap r> cmove ; + +: !fcb ( fcb --) \ next word is filename + dup filehandle off filename filenamelen !name ; + + + + + + + +\ *** Block No. 23 Hexblock 17 +\ print dta and directory 26oct86we + +| : .dtaname ( addr --) \ addr is addr of name + dup BEGIN dup c@ ?dup WHILE emit 1+ REPEAT + - &15 + spaces ; + +: .dta ( --) \ print contents of dta + cr dta &21 + c@ $10 and + IF Ascii D ELSE bl THEN emit space + dta &30 + .dtaname @length &10 d.r ; + +: (dir ( attr adr len --) \ given a match string + makec$ swap dta setdta search0 + BEGIN 0= WHILE stop? 0= WHILE .dta searchnext REPEAT ; + + +\ *** Block No. 24 Hexblock 18 +\ primitives for fcb's bp 18May86 + +User file-link file-link off \ list thru files + +| : #file ( -- n) \ View number of next file + file-link @ dup IF fileno @ THEN 1+ ; + + +: forthfiles ( --) \ print a list of : + file-link @ \ forthword,filename,handle,len + BEGIN dup WHILE + cr dup .fcb @ stop? UNTIL drop ; + + + + +\ *** Block No. 25 Hexblock 19 +\ Close a file bp 18May86 + +| ' save-buffers >body $C + @ Alias backup + +| : filebuffer? ( fcb -- fcb bufaddr/flag) + prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + +| : flushfile ( fcb -- ) \ flush file buffers + BEGIN filebuffer? ?dup WHILE + dup backup emptybuf REPEAT drop ; + +: (close ( fcb --) \ close file in fcb + dup flushfile + filehandle dup @ ?dup 0= IF drop exit THEN swap off + (closefile -$41 case? ?exit ?diskabort ; + +\ *** Block No. 26 Hexblock 1A +\ Create fcb's bp 11 oct 86 + +Forth definitions + + +: File ( -- ) \ Create a fcb + Create here b/fcb allot dup b/fcb erase + #file over fileno ! + file-link @ over file-link ! swap ! + does> !files ; + +: direct 0 !files ; \ switch to direct access + + + + +\ *** Block No. 27 Hexblock 1B +\ flush buffers & misc. bp 8jun86 + +: flush ( --) flush file-link + BEGIN @ ?dup WHILE dup (close REPEAT ; + +: file? isfile@ .file ; \ print current file + +: list ( n --) + 3 spaces file? list ; + +: path ( -- ) \ this is a smart word ! + name count + dup 0= IF 2drop pathes? exit THEN + dup 1 = IF over c@ Ascii ; = + IF 2drop pathes off exit THEN THEN + setpath ; +\ *** Block No. 28 Hexblock 1C +\ File Interface User words 26oct86we + +| : isfile? ( adr -- adr f) \ is adr a fcb ? + file-link BEGIN @ dup 0= ?exit 2dup 2- = UNTIL drop true ; + +| : ?isfile@ isfile@ body> + isfile? 0= abort" not in direct mode" >body ; + +: open ?isfile@ (open offset off ; +: close ?isfile@ (close ; +: assign close isfile@ !fcb open ; +: make ?isfile@ dup !fcb createfile ; + +: use >in @ name find \ create a fcb if not present ! + IF isfile? IF execute drop exit THEN THEN drop + dup >in ! File dup >in ! ' execute >in ! assign ; +\ *** Block No. 29 Hexblock 1D +\ File Interface User words bp 11 oct 86 + +: makefile >in @ file dup >in ! ' execute >in ! make ; + +: from isfile push use ; \ sets only fromfile +: loadfrom ( n --) \ load 1 scr from file + isfile push fromfile push use load close ; +: include 1 loadfrom ; + +: eof ( -- f) \ end of file ? + isfile@ dup filehandle @ position? + rot filesize 2@ d= ; + +: files $10 " *.*" count (dir ; +: files" $10 Ascii " word count (dir ; + +\ *** Block No. 30 Hexblock 1E +\ extend files bp 11 oct 86 + +| : >fileend isfile@ filesize 2@ handle position + ?diskabort ; + +| : addsize isfile@ filesize dup 2@ b/blk 0 d+ rot 2! ; + +| : addblock ( n --) \ add block n to file + buffer b/blk 2dup bl fill >fileend handle (filewrite + dup ?diskabort b/blk - + IF close abort" Disk voll" THEN addsize ; + +: (more ( n --) + capacity swap bounds ?DO I addblock LOOP ; + +: more ( n --) ?isfile@ (open (more close ; +\ *** Block No. 31 Hexblock 1F +\ make,kill and set directories bp 11 oct 86 + +| : dir$ ( -- adr ) name count makec$ ; + +: makedir dir$ (makedir ?diskabort ; + +: dir name count + 0 case? IF getdrive 2dup 1+ getdir ?diskabort + cr 3 spaces Ascii A + emit ." :" + scan-name type exit THEN + makec$ (setdir ?diskabort ; + +| : driveset Create c, Does> c@ setdrive ; +0 driveset A: 1 driveset B: 2 driveset C: 3 driveset D: + + +\ *** Block No. 32 Hexblock 20 +\ words for VIEWing bcas20130105 + +| $200 Constant viewoffset \ max. &512 kbyte long files + +| : (makeview ( -- n) \ calc. view field for a name + blk @ dup 0= ?exit + loadfile @ ?dup IF fileno @ viewoffset * + THEN ; + +: (view ( blk -- blk') \ select file and leave block + dup 0= ?exit + viewoffset u/mod file-link + BEGIN @ dup WHILE 2dup fileno @ = UNTIL + dup searchfile drop \ file not found : abort + !files drop ; + + +\ *** Block No. 33 Hexblock 21 +\ ugly FORGETing of files bp 11 oct 86 + +: remove? ( dic symb addr -- dic symb addr f) + dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; + +| : remove-files ( dic symb -- dic symb) \ flush files ! + isfile @ remove? nip IF 0 !files THEN + fromfile @ remove? nip IF fromfile off THEN + file-link + BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT + file-link remove ; + + + + + +\ *** Block No. 34 Hexblock 22 +\ convey for files bp 11 oct 86 + +| : togglefiles ( -- ) \ changes isfile and fromfile + isfile@ fromfile @ isfile ! fromfile ! ; + +: convey ( [blk1 blk2] [to.blk --) + 3 arguments >r 2dup swap - >r + togglefiles dup capacity 1- > + togglefiles r> r@ + capacity 1- > + or abort" wrong range!" + r> convey ; + + + + + +\ *** Block No. 35 Hexblock 23 +\ print a list of all blocks bp 9Apr86 + +: .blocks + prev BEGIN @ ?dup WHILE stop? abort" stopped" + cr dup u. dup 2+ @ dup 1+ + IF ." Block :" over 4+ @ 5 .r + ." File : " [ Dos ] .file + dup 6 + @ 0< IF ." updated" THEN + ELSE ." Block empty" drop THEN REPEAT ; + + + + + + + +\ *** Block No. 36 Hexblock 24 +\ create a file of direct blocks bcas20130105 + +Dos also + +| File outfile + +: blocks>file ( from to -- ) \ name of file follows + ?isfile@ -rot outfile make + 1+ swap ?DO I over (block b/blk handle (filewrite + b/blk - abort" write error" + LOOP close isfile ! ; + + + + + +\ *** Block No. 37 Hexblock 25 + bp 4oct86 + + + + + +MAKEVIEW erzeugt aus ISFILE und BLK das Viewfeld +CUSTOM-REMOVE erlaubt das FORGETten von eig. Datenstrukturen +R/W setzt Forthbl”cke in Disksektoren um .... + + + + + + + +\ *** Block No. 38 Hexblock 26 + 13oct86we + + + + + + + + + + + + + + + +\ *** Block No. 39 Hexblock 27 + 13oct86we + +ARGUMENTS liefert etwas Sicherheit ... + + +(CREATEFILE erzeugt ein File, dessen Namen in C$ steht, im + aktuellen oder im durch den Pfadnamen angegebenen Directory. + HANDLE ist die Handle des Files oder ein Fehlerflag. + Es wird immer ein "ganz normales" File erzeugt. + +(CLOSEFILE Schliežt das File mit der Handle HANDLE. Dabei + sollten alle TOS-Buffer zurckgeschrieben und das Directory + gesichert werden. F ist ein Fehlerflag. Die Handle ist + anschliežend ungltig. + + +\ *** Block No. 40 Hexblock 28 + 13oct86we + +(FILEWRITE schreibtLEN Bytes in das File HANDLE. Die Bytes + werden ab Adresse BUFF im Speicher geholt. + N ist die Zahl der geschriebenen Bytes oder eine + Fehlernummer, wenn N zwischen -66 und -1 liegt. + + + + + + + + + + +\ *** Block No. 41 Hexblock 29 + cas20130105 + +SAVE-SYSTEM speichert ein FORTH-System im aktuellen Zustand auf + Diskette ab. + +Voodoo-Code fr den GEMDOS-Fileheader; keine Relokatinsinfos + +Mit SAVE-SYSTEM lassen sich eigene Arbeitssysteme oder auch + Applikationen erstellen, denen man ihre FORTH-Herkunft nicht + mehr ansieht. + Stellen Sie ein System nach Ihren Wnschen zusammen, und spei- + chern Sie es dann mit SAVE-SYSTEM MYPROG.PRG ab. + + + + +\ *** Block No. 42 Hexblock 2A + 13oct86we + +DOS enth„lt die "unwichtigen" Worte des + Fileinterfaces + +BODY> ( cfa -- pfa ) Kompilationsadresse in + Parameterfeldadresse umwandeln ... + + + +Diese Worte werden fr die ble Patcherei in .diskabort benutzt. + Nur so kann die Dos-Fehlernummer in der abort" -Meldung unter- + gebracht werden. Bei einer Ausgabe mit . w„re keine Umleitung + ber ERRORHANDLER m”glich. + + +\ *** Block No. 43 Hexblock 2B + 13oct86we + +-n ist die Fehlernummer; es wird der zugeh”rige Text ausgedruckt + + + + + + + Ist die Fehlernummer nicht in den CASE-Anweisungen zu finden, + wird Dos-Error # ausgegeben. Die Fehlernummer wird dann in + den abort" String gepatched. Dieses Verfahren ist zwar „užerst + h„žlich, nichtsdestoweniger aber sehr effektiv. + +Prft, ob ein Fehler vorliegt und druckt ggf. den Text aus und + ABORTed anschliežend. +\ *** Block No. 44 Hexblock 2C + bp 4oct86 + +Definierendes Wort fr die Benamsung der Felder eines + File control blocks ( FCB bzw. FILE in den Stackkommentaren) + + +Zeiger auf den n„chsten FCB +Platz fr max. 24 Zeichen fr den TOS-Filenamen +L„nge des Files in Bytes +Handlenummer, die das TOS beim ™ffnen eines Files liefert. +Eine eigene Nummer, die in das VIEW-Feld eingetragen wird. +L„nge eines FCB wird auch berechnet... + +Liefert die Handle des aktuellen Files. Null, falls das + File nicht offen . + +\ *** Block No. 45 Hexblock 2D + bp 4oct86 + +LSEEK N ist ein Flag, das angibt, ob relativ zum + Fileanfang, zum Fileende oder zur aktuellen Position im File + positioniert werden soll. HANDLE ist die Handle des Files, in + dem positioniert wird und D die neue Position im File. + D' ist die neue Position. +POSITION positioniert auf das Byte d, gez„hlt vom Anfang + des Files mit der Handle HANDLE . + +POSITION? liefert die Position des zuletzt gelesenen, + geschriebenen oder mit POSITION bzw. LSEEK angew„hlten Bytes. + + + + +\ *** Block No. 46 Hexblock 2E + 13oct86we + +FILEREAD liest LEN Bytes aus dem File HANDLE. Die Bytes + werden ab Adresse BUFF im Speicher abgelegt. + N ist die Zahl der gelesenen Bytes oder eine Fehlernummer, + wenn N zwischen -66 und -1 liegt. + + + + + + + +Das headerlose (FILEWRITE bekommt nun einen Header im Vocabulary + Dos. + +\ *** Block No. 47 Hexblock 2F + 26oct86we + +OPENFILE ™ffnet ein File. Der Name steht im String C$. + C$ ist durch ein $00-Byte begrenzt. HANDLE ist die diesem + File zugeordnete Handle oder eine Fehlernummer. + + + +DTA ist ein 44 Byte grožer Buffer, in dem einige + Fileinformationen vom GEMDOS gehalten werden. +SETDTA ADDR ist die Adresse der 'disk transfer area'. + + + +(CLOSEFILE und (CREATEFILE erhalten Header im Vocabulary Dos. + +\ *** Block No. 48 Hexblock 30 + 13oct86we + +SEARCH0 SEARCH0 sucht ein File. C$ ist der Name des File + mit Pfad usw. . C$ wird, wie immer, durch ein $00-Byte + begrenzt. ATTR ist ein Attributwort, das z.B. bestimmt, ob + auch Subdirectories gefunden werden. F ist ein Fehlerflag. + Die DTA enth„lt anschliežend Filenamen, -l„nge usw. +SEARCHNEXT sucht das n„chste File mit dem bei SEARCH0 + angegeben Namen... + + + + + + + +\ *** Block No. 49 Hexblock 31 + 13oct86we + +(MAKEDIR erzeugt „hnlich (CREATEFILE ein Subdirectory. + C$ ist der Name des Directories, F ist ein Fehlerflag. + + + + + +(SETDIR setzt das durch C$ angegeben Subdirectory als + das "Aktuelle", auf das sich alle Such- und "Erzeugungs-" + operationen ohne eigenen Pfadnamen beziehen. + + + + +\ *** Block No. 50 Hexblock 32 + bp 4oct86 + +SETDRIVE N ist die Nummer des aktuellen Laufwerkes, auf + das sich alle Operationen ohne eigenen Pfadnamen beziehen. + Vergleiche (SETDIR. Laufwerk A: hat die Nummer 0 ! + +GETDRIVE N ist die Nummer des bei SETDRIVE genannten + Laufwerks. + + +GETDIR Das durch (SETDIR gesetzte Subdirectory wird + ab Adresse ADDR als C$ im Speicher abgelegt. N ist die Nummer + des Laufwerkes ( Laufwerk A: hat die Nummer 1 !!!! ), denn + verschiedene Laufwerke k”nnen verschiedene aktuelle Sub- + directories haben. + +\ *** Block No. 51 Hexblock 33 + bp 4oct86 + +(CAPACITY FCB ist die Adresse des FCB des Files, von + dem die L„nge in Blocks bestimmt werden soll. N ist dann + die Zahl der Bl”cke in diesem File. + +IN-RANGE prft, ob sich ein Block mit der Nummer BLOCK + im File FCB befindet. Ist das nicht der Fall, wird als + Fehlernummer -36 geliefert. Siehe auch ?DISKABORT + + + + + + + +\ *** Block No. 52 Hexblock 34 + 13oct86we + +SET-POS positioniert im File mit der Handle HANDLE auf + den Anfangs des Blocks BLOCK. F ist ein Fehlerflag. + +FILEACCESS wird in FILEREAD und FILEWRITE ben”tigt. + + + + + +FILEREAD liest den Block BLOCK an die Adresse BUFF aus + dem File FCB. Hinterl„žt eine Fehlernummer. + +FILEWRITE berschreibt den Block BLOCK mit den Daten ab + Adresse BUFF im File FCB. Hinterl„žt eine Fehlernummer. +\ *** Block No. 53 Hexblock 35 + bp 4oct86 + +SCAN-NAME 'LEN ist die L„nge eines durch ein $00-Byte + begrenzten C$. + +.FILE druckt den Forthnamen des Files mit der Adresse + FCB. + +.FCB druckt Forthnamen, TOS-Namen, Handle und L„nge + des Files mit der Adresse FCB aus. + +!FILES setzt die Variable ISFILE und FROMFILE (darin + steht das File, aus dem bei COPY und CONVEY gelesen wird) + auf das File mit der Adresse FCB. + + +\ *** Block No. 54 Hexblock 36 + bp 4oct86 + +PATHES Hier ist Platz fr den durch SETPATH angegeben + String, der die Namen der zu durchsuchenden Laufwerke und + Directories enth„lt. +PATHES? Druckt den Inhalt von PATHES aus. + +SETPATH Setzt PATHES auf den String ab der Adresse ADR, + dessen L„nge LEN ist. Anschliežend wird noch ein ; angefgt, + um auch den letzten Path korrekt zu beenden. + + + + + + +\ *** Block No. 55 Hexblock 37 + bp 4oct86 + +WORKSPACE Hier wird aus File- und Pathnamen ein C$ + zusammengebastelt. + +TRY.PATH ADR und LEN enthalten den Pfadnamen (aus + PATHES mit PATH@ extrahiert), FCB ist die Adresse des Files + und ATTR ein Attribut (siehe SEARCH0). Aus Pfadnamen und FCB + wird in WORKSPACE ein String zusammengebastelt, der dann mit + SEARCH0 gesucht wird. F gibt an, ob wir erfolgreich waren. + +MAKEC$ konvertiert einen durch ADR und LEN definierten + String in einen C$ (durch ein $00-Byte begrenzt) und + hinterl„žt dessen Adresse. + + +\ *** Block No. 56 Hexblock 38 + bp 4oct86 + +SFILE enth„lt die Adresse des FCB des gesuchten Files. +DEFAULTATTR enstpricht "Suche alle Files, egal welches ATTR" + +PATH@ extrahiere aus dem noch nicht zum Suchen verwen- + deten Teil von PATHES, der durch ADR und LEN angegeben wird, + den n„chsten zu durchsuchenden Pfad ADR LEN1. +(SEARCHFILE durchsucht alle in PATHES stehenden Pfade nach + dem in FCB stehenden Filenamen. Aufgeh”rt wird, wenn das File + gefunden wurde oder alle Pfade durchsucht wurden. + Am Schluž wird auch der leere Pfad (L„nge Null) durchsucht, + der dem aktuellen Directory (siehe SETDIR) entspricht. + +SEARCHFILE Sucht das File FCB in allen Pfaden und im akt. + Directory. Hinterlassen wird der vollst„ndige Pfad des Files. +\ *** Block No. 57 Hexblock 39 + bp 4oct86 + +@LENGTH holt die L„nge des zuletzt gefundenen Files +COPYLENGTH kopiert die L„nge des zuletzt gefundenen Files + in den Fcb FCB. +(OPEN ”ffnet das durch FCB angegebene File + und speichert LEN dort die Handle und L„nge. Dazu muž es + natrlich erst gesucht werden, denn nur dann steht die L„nge + in der DTA. + + + +CAPACITY N ist die Zahl der Bl”cke im aktuellen (durch + ISFILE angegeben) File. Ist ISFILE Null, so wird die Kapazit„t + der Diskette im Direktzugriff angegeben. + +\ *** Block No. 58 Hexblock 3A + bp 4oct86 + +FILER/W ist das zentrale Wort fr den Zugriff auf Files. + BUFF ist die Adresse des Blocks BLOCK im Speicher, FCB die + Nummer des Files (0 heižt Direktzugriff) und R/W gibt an, in + welcher Richtung die Daten zu transportieren sind. + F ist true, falls ein Fehler auftrat. + +CREATEFILE erzeugt ein File, dessen Name im Fcb FCB steht. + Handle und Filel„nge werden korrigiert. + + + + + + +\ *** Block No. 59 Hexblock 3B + bp 4oct86 + +!NAME speichert einen auf !NAME folgenden String + ab Adresse ADR mit maximaler L„nge LEN im Speicher ab. + Der String wird durch $00-Bytes begrenzt. + + +!FCB speichert einen auf !FCB folgenden String im + Fcb FCB ab. Die Handle wird gel”scht, weil das + so zugewiesene File noch nicht ge”ffnet worden ist. + + + + + + +\ *** Block No. 60 Hexblock 3C + 13oct86we + +.DTANAME druckt den Filenamen, er ab Adresse d in der DTA + steht, linksbndig in einem Feld der Breite 15 aus. + + +.DTA druckt den Inhalt der DTA formattiert aus. + Zun„chst wird ein "D" ausgegeben, das anzeigt, ob es sich + um ein Subdirectory handelt, anschliežend der Name gefolgt + von der L„nge des Files. + +(DIR druckt alle Files aus, auf die der String ADR + LEN und das Attribut ATTR "passt". Die Ausgabe kann wie + blich angehalten und abgebrochen werden. + + +\ *** Block No. 61 Hexblock 3D + bp 4oct86 + +FILE-LINK enth„lt einen Zeiger auf den FCB des + zuletzt definierten Files. +#FILE N ist die Nummer, die in das Viewfeld des + n„chsten zu definierenden Files eingetragen werden soll. + + +FORTHFILES druckt die Forth- und TOS-Namen mit Handle und + L„nge aller definierten Files aus. Dazu wird FILE-LINK + benutzt. Die Ausgabe kann wie blich angehalten oder beendet + werden. + + + + +\ *** Block No. 62 Hexblock 3E + bp 4oct86 + +FILEBUFFER? guckt nach, ob zu dem File FCB noch ein Block- + puffer exisitiert. Liefert false, falls keiner vorhanden ist. + +FLUSHFILE sichert alle zum File FCB geh”renden Blockpuffer + auf dem Massenspeicher und l”scht sie anschliežend. + + +(CLOSE sichert alle Blockpuffer, schliežt anschliežend + das File, falls es nicht schon geschlossen war und ignoriert + den Fehler mit der Nummer -65, weil der so oft auftritt... + + + + +\ *** Block No. 63 Hexblock 3F + bp 4oct86 + +FILE ist ein definierendes Wort, daž einen FCB + erzeugt. Wird der FCB sp„ter ausgefhrt, so tr„gt er sich + als aktuelles File und als FROMFILE ein. + + + +DIRECT ein "spezieller FCB" fr den Direktzugriff. + Der Direktzugriff ist immer dann interessant, wenn man + einen Diskmonitor braucht, ihn aber gerade verliehen hat... + + + + + +\ *** Block No. 64 Hexblock 40 + bp 4oct86 + +FLUSH schliežt zus„tzlich alle Files.. + + +FILE? druckt den Namen des aktuellen Files aus. + +LIST druckt zus„tzlich den Filenamen aus... + + +PATH druckt PATHES aus oder + l”scht PATHES oder + setzt PATHES auf einen anderen String. + + + +\ *** Block No. 65 Hexblock 41 + 13oct86we + +ISFILE? F ist wahr, falls ADR die Kompilationsadresse + eines FCB ist (also durch FILE erzeugt wurde...). + +?ISFILE@ steht in ISFILE berhaupt ein File ? + +OPEN ”ffnet das aktuelle File. +CLOSE schliežt es. +ASSIGN Anderer Filename in aktuellen FCB eintragen. +MAKE Neu erzeugter Filename in aktuellen FCB.. + +USE Erzeuge FCB (mit Filenamen !), falls Name nicht + schon vorhanden. Wenn Name vorhanden, prfe ob es File ist. + Trage dann FCB in ISFILE ein. + +\ *** Block No. 66 Hexblock 42 + 13oct86we + +MAKEFILE erzeugt FCB und File gleichen Namens. + +FROM setzt FROMFILE fr COPY und CONVEY +LOADFROM l„dt den Screen N vom File, dessen Name auf + LOADFROM folgt. z.B. 1 loadfrom forth_83.scr +INCLUDE l„dt den Loadscreen des Files... + +EOF F ist wahr, falls wir am Ende des Files + angekommen sind. + + +FILES liefert Inhaltsverzeichnis des akt. Directories. +FILES" erlaubt Pfad- und Filenamen + +\ *** Block No. 67 Hexblock 43 + bp 4oct86 + +>FILEEND springe ans Ende des aktuellen Files + + +ADDSIZE erh”ht die L„ngenangabe im aktuellen FCB um + 1024 Bytes. +ADDBLOCK fgt den Block N am Fileende an. + Aužerdem wird ein leerer Buffer mit dieser Nummer angelegt. + + + +(MORE fgt n Bl”cke am Fileende an. + +MORE Wie (MORE, jedoch etwas Sicherheit.. + +\ *** Block No. 68 Hexblock 44 + 13oct86we + +DIR$ ADR ist die Adresse eines auf DIR$ folgenden C$. + +MAKEDIR erzeugt ein Directory mit dem folgenden Namen.. + +DIR gibt, falls kein Name folgt, das aktuelle Lauf- + werk und Subdirectory aus. Folgt ein Name, so wird er als + das neue aktuelle Directory an das TOS bergeben. + + + +A: B: C: D: Kurzformen fr SETDRIVE. + + + +\ *** Block No. 69 Hexblock 45 + 13oct86we + +VIEWOFFSET teilt das 16-Bit Viewfeld in ein Feld mit der + Filenummer und ein Feld mit der Blocknummer. Die unteren 9 + Bits sind fr die Blocknummer reserviert. +(MAKEVIEW macht aus BLK und der Nummer des geladenen Files + LOADFILE eine 16-Bit Zahl, die von CREATE dann als Viewfeld + hinterlegt wird. +(VIEW zerlegt den Inhalt BLK eines Viewfeldes in + Filenummer und Blocknummer BLK' . Der zur Filenummer + geh”rende FCB wird gesucht, und falls gefunden, in ISFILE + und FROMFILE eingetragen. Kann kein FCB gefunden werden, + so wird eine Fehlermeldung ausgegeben. + + + +\ *** Block No. 70 Hexblock 46 + bp 4oct86 + +REMOVE? DIC (SYMB) ist die Adresse im Dictionary (HEAP), + oberhalb (unterhalb, der Heap w„chst von oben nach unten !) + derer alle Worte vergessen werden mssen. F gibt an, ob + ADDR innerhalb des zu vergessenden Intervalls liegt. + +REMOVE-FILES guckt nach, ob ISFILE oder FROMFILE vergessen + werden. Ist das der Fall, so werden sie auf den Direktzugriff + umgeschaltet. + Anschliežend werden alle zu vergessenden Files geschlossen + und aus der Liste aller Files FILE-LINK entfernt. + + + + +\ *** Block No. 71 Hexblock 47 + bp 4oct86 + +TOGGLEFILES vertauscht ISFILE und FROMFILE. + + +CONVEY prft, ob die zu bewegenden Bl”cke vorhanden + sind und bewegt sie ggf. + + + + + + + + + +\ *** Block No. 72 Hexblock 48 + 13oct86we + +.BLOCKS listet den Inhalt der Blockpuffer auf. + Angegeben werden Adresse, Blocknummer und Filename sowie, + ob der Block geUPDATEd wurde. + +Bei der Entwicklung des Fileinterfaces war das ein ntzliches + Hilfsmittel. + + +Dieser und der n„chste Screen werden normalerweise vom Load- + screen nicht mitkompiliert. + + + + +\ *** Block No. 73 Hexblock 49 + 13oct86we + + + + + +Mit BLOCKS>FILE l„žt sich eine Folge von Diskettenbl”cken in + einem File ablegen. Damit k”nnen Disketten, die bisher im + Direktzugriff benutzt worden sind, auf das Fileinterface um- + gestellt werden. + + + + + + diff --git a/sources/AtariST/FORTH83.FB.src b/sources/AtariST/FORTH83.FB.src deleted file mode 100644 index d680041..0000000 --- a/sources/AtariST/FORTH83.FB.src +++ /dev/null @@ -1,2261 +0,0 @@ -Screen 0 not modified - 0 \\ *** Volksforth System - Sourcecode *** cas201301 - 1 - 2 This file contains the full sourcecode for the volksFORTH-83 - 3 kernal. - 4 - 5 The source is compiled using the volksForth target compiler. The - 6 source contains instructions for the target compiler that will - 7 not end up in the final Forth system. - 8 - 9 -10 See the documentation on http://fossil.forth-ev.de/volksforth -11 for information on how to compile a new Forth kernel from -12 the source. -13 -14 -15 -Screen 1 not modified - 0 \ Atari 520 ST Forth loadscreen cas201301 - 1 \ volksFORTH-83 was developed by K. Schleisiek, B. Pennemann - 2 \ G. Rehfeld & D. Weineck - 3 \ Atari ST - Version by D. Weineck - 4 \ Atari ST/STE/TT/Falcon/FireBee Version by C. Strotmann - 5 - 6 Onlyforth - 7 - 8 0 dup displace ! - 9 Target definitions here! -10 -11 $82 +load -12 1 $76 +thru -13 -14 cr .unresolved ' .blk is .status -15 -Screen 2 not modified - 0 \ FORTH Preamble and ID cas201301 - 1 - 2 Assembler - 3 0 FP D) jmp here 2- >label >cold - 4 0 FP D) jmp here 2- >label >restart - 5 here dup origin! - 6 \ Initial cold-start values for user variables - 7 - 8 0 # D6 move D6 reg) jmp \ Fr multitasker - 9 $100 allot -10 -11 | Create logo ," volksFORTH-83 rev. 3.85.1" -12 -13 -14 -15 -Screen 3 not modified - 0 \ Assembler Labels & Macros Next cas201301 - 1 - 2 Compiler Assembler also definitions - 3 - 4 H : Next .w IP )+ D7 move \ D7 contains cfa - 5 D7 reg) D6 move \ D6 contains cfa@ - 6 D6 reg) jmp .w \ jump to cfa@ - 7 there Tnext-link H @ T , H Tnext-link ! ; - 8 - 9 Target -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ recover noop 06sep86we - 1 - 2 Create recover Assembler - 3 .l A7 )+ D7 move FP IP suba .w IP RP -) move - 4 .l D7 IP move 0 D7 moveq Next end-code - 5 - 6 Compiler Assembler also definitions - 7 - 8 H : ;c: 0 T recover R#) jsr end-code ] H ; - 9 -10 Target -11 -12 Code noop Next end-code -13 -14 -15 -Screen 5 not modified - 0 \ User Variables 14sep86we - 1 - 2 Constant origin &10 uallot drop \ For multitasker - 3 User s0 - 4 User r0 - 5 User dp - 6 User offset 0 offset ! - 7 User base $10 base ! - 8 User output - 9 User input -10 User errorhandler \ pointer for abort" -code -11 User voc-link -12 User udp \ points to next free addr in User -13 User next-link \ points to next Next -14 -15 -Screen 6 not modified - 0 \ end-trace 11sep86we - 1 - 2 Variable UP - 3 - 4 Label fnext IP )+ D7 move D7 reg) D6 move D6 reg) jmp - 5 - 6 Code end-trace - 7 fnext # D6 move .l D6 reg) A0 lea A0 D5 move - 8 .w UP R#) D6 move .l user' next-link D6 FP DI) D6 .w move - 9 BEGIN .l D6 reg) A1 lea .w D6 tst 0<> -10 WHILE .w &10 # A1 suba .l D5 A0 move -11 A0 )+ A1 )+ move A0 )+ A1 )+ move -12 .w 2 A1 addq A1 ) D6 move -13 REPEAT fnext bra end-code -14 -15 -Screen 7 not modified - 0 \ manipulate system pointers 09sep86we - 1 - 2 Code sp@ ( -- addr ) .l SP D6 move FP D6 sub - 3 .w D6 SP -) move Next end-code - 4 - 5 Code sp! ( addr -- ) SP )+ D6 move $FFFE D6 andi - 6 D6 reg) SP lea Next end-code - 7 - 8 Code up@ ( -- addr ) UP R#) SP -) move Next end-code - 9 -10 Code up! ( addr -- ) SP )+ D0 move $FFFE D0 andi -11 D6 UP R#) move Next end-code -12 -13 Code forthstart ( -- laddr ) .l FP SP -) move Next end-code -14 -15 -Screen 8 not modified - 0 \ manipulate returnstack 05sep86we - 1 - 2 Code rp@ ( -- addr ) .l RP D6 move FP D6 sub - 3 .w D6 SP -) move Next end-code - 4 - 5 Code rp! ( addr -- ) SP )+ D6 move $FFFE D6 andi - 6 D6 reg) RP lea Next end-code - 7 - 8 Code >r ( 16b -- ) SP )+ RP -) move - 9 Next end-code restrict -10 -11 Code r> ( -- 16b ) RP )+ SP -) move -12 Next end-code restrict -13 -14 -15 -Screen 9 not modified - 0 \ r@ rdrop exit unnest ?exit 04sep86we - 1 - 2 Code r@ ( -- 16b ) RP ) SP -) move Next end-code - 3 - 4 Code rdrop 2 RP addq Next end-code restrict - 5 - 6 Code exit RP )+ D7 move .l D7 IP move - 7 FP IP adda Next end-code - 8 - 9 Code unnest RP )+ D7 move .l D7 IP move -10 FP IP adda Next end-code -11 -12 Code ?exit ( flag -- ) SP )+ tst 0<> IF RP )+ D7 move -13 .l D7 IP move FP IP adda THEN -14 Next end-code -15 \\ : ?exit ( flag -- ) IF rdrop THEN ; -Screen 10 not modified - 0 \ execute perform 04sep86we - 1 - 2 Code execute ( cfa -- ) - 3 SP )+ D7 move D7 reg) D6 move .l D6 reg) jmp end-code - 4 - 5 : perform ( addr -- ) @ execute ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 11 not modified - 0 \ c@ c! ctoggle 04sep86we - 1 - 2 Code c@ ( addr -- 8b ) - 3 SP )+ D6 move D6 reg) A0 lea 0 D0 moveq - 4 .b A0 ) D0 move .w D0 SP -) move Next end-code - 5 - 6 Code c! ( 16b addr -- ) - 7 SP )+ D6 move D6 reg) A0 lea - 8 SP )+ D0 move .b D0 A0 ) move Next end-code - 9 -10 : ctoggle ( 8b addr --) under c@ xor swap c! ; -11 -12 -13 -14 -15 -Screen 12 not modified - 0 \ @ ! 2@ 2! 04sep86we - 1 - 2 Code @ ( addr -- 16b ) - 3 SP )+ D6 move D6 reg) A0 lea - 4 .b 1 A0 D) SP -) move A0 ) SP -) move - 5 Next end-code - 6 - 7 Code ! ( 16b addr -- ) - 8 SP )+ D6 move D6 reg) A0 lea - 9 .b SP )+ A0 )+ move SP )+ A0 )+ move -10 Next end-code -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ 2@ 2! 04sep86we - 1 - 2 Code 2@ ( addr -- 32b ) - 3 SP )+ D6 move D6 reg) A0 lea - 4 .b 3 A0 D) SP -) move 2 A0 D) SP -) move - 5 1 A0 D) SP -) move A0 ) SP -) move Next end-code - 6 - 7 Code 2! ( 32b addr -- ) - 8 SP )+ D6 move D6 reg) A0 lea - 9 .b SP )+ A0 )+ move SP )+ A0 )+ move -10 SP )+ A0 )+ move SP )+ A0 )+ move Next end-code -11 -12 \\ -13 : 2@ ( adr -- 32b) dup 2+ @ swap @ ; -14 : 2! ( 32b adr --) rot over 2+ ! ! ; -15 -Screen 14 not modified - 0 \ lc@ lc! l@ l! 24may86we - 1 - 2 Code lc@ ( laddr -- 8b ) - 3 .l SP )+ A0 move 0 D0 moveq .b A0 ) D0 move - 4 .w D0 SP -) move Next end-code - 5 Code lc! ( 8b laddr -- ) - 6 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move - 7 Next end-code - 8 - 9 Code l@ ( laddr -- n ) -10 .l SP )+ A0 move .b A0 )+ D0 move .w 8 # D0 lsl -11 .b A0 ) D0 move .w D0 SP -) move Next end-code -12 Code l! ( n laddr -- ) -13 .l SP )+ A0 move .w SP )+ D0 move .b D0 1 A0 D) move -14 .w 8 # D0 lsr .b D0 A0 ) move Next end-code -15 -Screen 15 not modified - 0 \ lcmove 10sep86we - 1 - 2 Code lcmove ( fromladdr toladdr count -- ) - 3 SP )+ D0 move .l SP )+ A0 move SP )+ A1 move - 4 .w D0 tst 0<> IF 1 D0 subq - 5 D0 DO .b A1 )+ A0 )+ move LOOP THEN Next end-code - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \ l2@ l2! cas201301 - 1 - 2 Code l2@ ( laddr -- 32bit ) - 3 .l SP )+ A0 move .b A0 )+ D0 move .l 8 # D0 lsl - 4 .b A0 )+ D0 move .l 8 # D0 lsl .b A0 )+ D0 move .l 8 # D0 lsl - 5 .b A0 ) D0 move .l D0 SP -) move Next end-code - 6 - 7 Code l2! ( 32bit laddr -- ) - 8 .l SP )+ A0 move SP )+ D0 move - 9 .l 8 # D0 rol .b D0 A0 )+ move .l 8 # D0 rol .b D0 A0 )+ move -10 .l 8 # D0 rol .b D0 A0 )+ move .l 8 # D0 rol .b D0 A0 )+ move -11 Next end-code -12 -13 Code ln+! ( n laddr -- ) \ only even addresses allowed -14 .l SP )+ A0 move A0 ) A1 move .w SP )+ A1 adda -15 .l A1 A0 ) move Next end-code -Screen 17 not modified - 0 \ +! drop swap 05sep86we - 1 - 2 Code +! ( n addr -- ) - 3 SP )+ D6 move D6 reg) A0 lea 2 A0 addq 2 SP addq - 4 4 # move>ccr .b SP -) A0 -) addx SP -) A0 -) addx - 5 .w 2 SP addq Next end-code - 6 - 7 - 8 Code drop ( 16b -- ) 2 SP addq Next end-code - 9 -10 Code swap ( 16b1 16b2 -- 16b2 16b1 ) -11 .l SP ) D0 move D0 swap D0 SP ) move Next end-code -12 -13 -14 -15 -Screen 18 not modified - 0 \ dup ?dup 20mar86we - 1 - 2 Code dup ( 16b -- 16b 16b ) SP ) SP -) move Next end-code - 3 - 4 Code ?dup ( 16b -- 16b 16b / false ) - 5 SP ) tst 0<> IF SP ) SP -) move THEN Next end-code - 6 - 7 - 8 - 9 \\ -10 : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; -11 -12 -13 -14 -15 -Screen 19 not modified - 0 \ over rot nip under bp 11 oct 86 - 1 - 2 Code over ( 16b1 16b2 - 16b1 16b3 16b1 ) - 3 2 SP D) SP -) move Next end-code - 4 Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) - 5 SP )+ D1 move SP )+ D2 move SP ) D0 move - 6 D2 SP ) move D1 SP -) move D0 SP -) move - 7 Next end-code - 8 Code nip ( 16b1 16b2 -- 16b2 ) - 9 SP )+ SP ) move Next end-code -10 Code under ( 16b1 16b2 - 16b2 16b1 16b2 ) -11 .l SP ) D0 move D0 swap D0 SP ) move .w D0 SP -) move -12 Next end-code -13 \\ -14 : nip ( 16b1 16b2 -- 16b2) swap drop ; -15 : under ( 16b1 16b2 -- 16b2 16b1 16b2) swap over ; -Screen 20 not modified - 0 \ -rot nip pick roll bp 11 oct 86 - 1 - 2 Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) - 3 SP )+ D2 move SP )+ D0 move SP ) D1 move - 4 D2 SP ) move D1 SP -) move D0 SP -) move - 5 Next end-code - 6 Code pick ( n -- 16b.n ) - 7 .l D0 clr .w SP )+ D0 move D0 D0 add - 8 0 D0 SP DI) SP -) move Next end-code - 9 : roll ( n -- ) -10 dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; -11 : -roll ( n -- ) >r dup sp@ dup 2+ -12 dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; -13 \\ -14 : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; -15 : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; -Screen 21 not modified - 0 \ double word stack manip. bp 12oct86 - 1 - 2 Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) - 3 .l SP )+ D0 move SP ) D1 move D0 SP ) move - 4 D1 SP -) move Next end-code - 5 Code 2dup ( 32b -- 32b 32b ) - 6 .l SP ) SP -) move Next end-code - 7 Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) - 8 .l 4 SP D) SP -) move Next end-code - 9 -10 Code 2drop ( 32b -- ) 4 SP addq Next end-code -11 -12 \\ : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; -13 : 2drop ( 32b -- ) drop drop ; -14 : 2dup ( 32b -- 32b 32b) over over ; -15 -Screen 22 not modified - 0 \ + and or xor not 19mar86we - 1 - 2 Code + ( n1 n2 -- n3 ) - 3 SP )+ D0 move D0 SP ) add Next end-code - 4 - 5 Code or ( 16b1 16b2 -- 16b3 ) - 6 SP )+ D0 move D0 SP ) or Next end-code - 7 - 8 Code and ( 16b1 16b2 -- 16b3 ) - 9 SP )+ D0 move D0 SP ) and Next end-code -10 -11 Code xor ( 16b1 16b2 -- 16b3 ) -12 SP )+ D0 move D0 SP ) eor Next end-code -13 -14 Code not ( 16b1 -- 16b2 ) SP ) not Next end-code -15 -Screen 23 not modified - 0 \ - negate 19mar86we - 1 - 2 Code - ( n1 n2 -- n3 ) - 3 SP )+ D0 move D0 SP ) sub Next end-code - 4 - 5 Code negate ( n1 -- n2 ) SP ) neg Next end-code - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 \ double arithmetic cas201301 - 1 - 2 Code dnegate ( d1 -- -d1 ) .l SP ) neg Next end-code - 3 - 4 Code d+ ( d1 d2 -- d3 ) - 5 .l SP )+ D0 move D0 SP ) add Next end-code - 6 - 7 Code d- ( d1 d2 -- d1-d2 ) - 8 .l SP )+ D0 move D0 SP ) sub Next end-code - 9 -10 Code d* ( d1 d2 -- d1*d2 ) -11 .l SP )+ D0 move SP )+ D1 move -12 D0 D2 move D0 D3 move D3 swap D1 D4 move D4 swap -13 D1 D0 mulu D3 D1 mulu D4 D2 mulu -14 D0 swap .w D1 D0 add .w D2 D0 add .l D0 swap -15 D0 SP -) move Next end-code -Screen 25 not modified - 0 \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 18nov86we - 1 - 2 Code 1+ ( n1 -- n2 ) 1 SP ) addq Next end-code - 3 Code 2+ ( n1 -- n2 ) 2 SP ) addq Next end-code - 4 Code 3+ ( n1 -- n2 ) 3 SP ) addq Next end-code - 5 Code 4+ ( n1 -- n2 ) 4 SP ) addq Next end-code - 6 | Code 6+ ( n1 -- n2 ) 6 SP ) addq Next end-code - 7 Code 1- ( n1 -- n2 ) 1 SP ) subq Next end-code - 8 Code 2- ( n1 -- n2 ) 2 SP ) subq Next end-code - 9 Code 4- ( n1 -- n2 ) 4 SP ) subq Next end-code -10 -11 -12 : on ( addr -- ) true swap ! ; -13 : off ( addr -- ) false swap ! ; -14 -15 -Screen 26 not modified - 0 \ number Constants bp 18nov86we - 1 - 2 Code true ( -- -1 ) -1 # SP -) move Next end-code - 3 Code false ( -- 0 ) 0 # SP -) move Next end-code - 4 Code 1 ( -- 1 ) 1 # SP -) move Next end-code - 5 Code 2 ( -- 2 ) 2 # SP -) move Next end-code - 6 Code 3 ( -- 3 ) 3 # SP -) move Next end-code - 7 Code 4 ( -- 4 ) 4 # SP -) move Next end-code - 8 - 9 ' true Alias -1 ' false Alias 0 -10 -11 -12 -13 -14 -15 -Screen 27 not modified - 0 \ words for number literals 19mar86we - 1 - 2 Code lit ( -- 16b ) IP )+ SP -) move Next end-code - 3 - 4 : Literal ( 16b -- ) compile lit , ; immediate restrict - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 28 not modified - 0 \ comparision code words 19mar86we - 1 - 2 Label yes true # SP ) move Next Label no SP ) clr Next - 3 - 4 Code 0< ( n -- flag ) SP ) tst yes bmi no bra end-code - 5 - 6 Code 0= ( 16b -- flag ) SP ) tst yes beq no bra end-code - 7 - 8 Code < ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp - 9 yes bgt no bra end-code -10 -11 Code u< ( u1 u2 -- flag ) SP )+ D0 move SP ) D0 cmp -12 yes bhi no bra end-code -13 -14 : uwithin ( u1 [low up[ -- flag ) -15 rot under u> -rot u> not and ; -Screen 29 not modified - 0 \ comparision code words 25mar86we - 1 - 2 Code > ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp - 3 yes blt no bra end-code - 4 - 5 Code 0> ( n -- flag ) SP ) tst yes bgt no bra - 6 end-code - 7 - 8 Code 0<> ( n -- flag ) SP ) tst yes bne no bra - 9 end-code -10 -11 Code u> ( u1 u2 -- flag ) SP )+ D0 move SP ) D1 move -12 D0 D1 cmp yes bhi no bra -13 end-code -14 Code = ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp -15 yes beq no bra end-code -Screen 30 not modified - 0 \ comparision words 20mar86we - 1 - 2 : d0= ( d -- flag ) or 0= ; - 3 : d= ( d1 d2 -- flag ) dnegate d+ d0= ; - 4 : d< ( d1 d2 -- flag ) rot 2dup - IF > nip nip - 5 ELSE 2drop u< THEN ; - 6 - 7 - 8 \\ - 9 : 0< 8000 and 0<> ; -10 : > ( n1 n2 -- flag ) swap < ; -11 : 0> ( n -- flag ) negate 0< ; -12 : 0<> ( n -- flag ) 0= not ; -13 : u> ( u1 u2 -- flag ) swap u< ; -14 : = ( n1 n2 -- flag ) - 0= ; -15 -Screen 31 not modified - 0 \ min max umax umin extend dabs abs 18nov86we - 1 - 2 | Code minimax ( n1 n2 f -- n ) - 3 SP )+ tst 0<> IF SP ) 2 SP D) move THEN 2 SP addq - 4 Next end-code - 5 - 6 : min ( n1 n2 -- n3 ) 2dup > minimax ; - 7 : max ( n1 n2 -- n3 ) 2dup < minimax ; - 8 : umax ( u1 u2 -- u3 ) 2dup u< minimax ; - 9 : umin ( u1 u2 -- u3 ) 2dup u> minimax ; -10 : extend ( n -- d ) dup 0< ; -11 : dabs ( d -- ud ) extend IF dnegate THEN ; -12 : abs ( n -- u) extend IF negate THEN ; -13 \\ -14 : minimax ( n1 n2 flag -- n3 ) -15 rdrop IF swap THEN drop ; -Screen 32 not modified - 0 \ loop primitives 19mar86we - 1 - 2 | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; - 3 - 4 : (do ( limit start -- ) over - dodo ; restrict - 5 : (?do ( limit start -- ) over - ?dup IF dodo THEN - 6 r> dup @ + >r drop ; restrict - 7 - 8 : bounds ( start count -- limit start ) over + swap ; - 9 -10 Code endloop 6 RP addq Next end-code restrict -11 -12 -13 -14 \\ dodo puts "index | limit | adr.of.DO" on return-stack -15 -Screen 33 not modified - 0 \ (loop (+loop 04sep86we - 1 - 2 Code (loop - 3 1 RP ) addq - 4 CC IF 4 RP D) D6 move D6 reg) IP lea THEN - 5 Next end-code restrict - 6 - 7 Code (+loop - 8 SP )+ D0 move D0 D1 move D0 RP ) add - 9 1 # D1 roxr D0 D1 eor -10 0>= IF 4 RP D) D6 move D6 reg) IP lea THEN -11 Next end-code restrict -12 -13 -14 -15 -Screen 34 not modified - 0 \ loop indices 20mar86we - 1 - 2 Code I ( -- n ) - 3 RP ) D0 move 2 RP D) D0 add D0 SP -) move - 4 Next end-code - 5 - 6 Code J ( -- n ) - 7 6 RP D) D0 move 8 RP D) D0 add D0 SP -) move - 8 Next end-code - 9 -10 -11 -12 -13 -14 -15 -Screen 35 not modified - 0 \ branch ?branch 06sep86we - 1 - 2 Code branch - 3 Label bran1 IP ) IP adda Next end-code - 4 - 5 Code ?branch ( fl -- ) SP )+ tst bran1 beq 2 IP addq - 6 Next end-code - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 36 not modified - 0 \ resolve loops and branches 19mar86we - 1 - 2 : >mark ( -- addr ) here 0 , ; - 3 : >resolve ( addr -- ) here over - swap ! ; - 4 : mark 1 ; immediate restrict - 3 : THEN abs 1 ?pairs >resolve ; immediate restrict - 4 : ELSE 1 ?pairs compile branch >mark swap - 5 >resolve -1 ; immediate restrict - 6 : BEGIN mark - 8 -2 2swap ; immediate restrict - 9 | : (reptil resolve REPEAT ; -11 : REPEAT 2 ?pairs compile branch (reptil ; -12 immediate restrict -13 : UNTIL 2 ?pairs compile ?branch (reptil ; -14 immediate restrict -15 -Screen 39 not modified - 0 \ Loops 24nov85we - 1 - 2 : DO compile (do >mark 3 ; immediate restrict - 3 : ?DO compile (?do >mark 3 ; immediate restrict - 4 : LOOP 3 ?pairs compile (loop compile endloop >resolve ; - 5 immediate restrict - 6 : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; - 7 immediate restrict - 8 : LEAVE endloop r> 2- dup @ + >r ; restrict - 9 -10 -11 \\ Returnstack: calladr | index limit | adr of DO -12 -13 -14 -15 -Screen 40 not modified - 0 \ Multiplication 18nov86we - 1 - 2 Code um* ( u1 u2 -- ud ) - 3 SP )+ D0 move SP )+ D0 mulu .l D0 SP -) move - 4 Next end-code - 5 - 6 Code * ( n1 n2 -- n ) - 7 SP )+ D0 move SP )+ D0 mulu D0 SP -) move - 8 Next end-code - 9 -10 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN -11 swap dup 0< IF negate r> not >r THEN -12 um* r> IF dnegate THEN ; -13 -14 Code 2* ( n -- 2*n ) SP ) asl Next end-code -15 Code 2/ ( n -- n/2 ) SP ) asr Next end-code -Screen 41 not modified - 0 \ Division cas201301 - 1 - 2 label divovl ;c: true abort" division overflow" ; - 3 - 4 Label (m/mod \ d(D2) n(D0) -- mod quot - 5 .l A7 )+ A0 move \ get addr from stack - 6 .w D0 D1 move D0 D3 move - 7 .l D1 ext - 8 D2 D1 eor 0< IF D2 neg .w D0 neg THEN - 9 D0 D2 divs divovl bvs -10 .w D2 D0 move D2 swap .l D1 tst -11 0< IF .w D2 tst 0<> IF 1 D0 subq \ quot = quot - 1 -12 D3 D2 sub D2 neg \ rem = n - rem -13 THEN THEN -14 .w D2 SP -) move D0 SP -) move -15 .l A0 ) jmp \ adr. from /0-TRAPS leads to a GEM crash -Screen 42 not modified - 0 \ um/mod m/mod /mod 18nov86we - 1 - 2 Code um/mod ( d1 n1 -- rem quot ) - 3 SP )+ D0 move .l SP )+ D1 move D0 D1 divu - 4 divovl bvs - 5 D1 swap D1 SP -) move Next end-code - 6 - 7 Code m/mod ( d n -- mod quot ) - 8 SP )+ D0 move .l SP )+ D2 move (m/mod bsr Next end-code - 9 -10 Code /mod ( n1 n2 -- mod quot ) -11 SP )+ D0 move SP )+ D2 move .l D2 ext -12 (m/mod bsr Next end-code -13 -14 -15 -Screen 43 not modified - 0 \ / mod 18nov86we - 1 - 2 Code / ( n1 n2 -- quot ) - 3 SP )+ D0 move SP )+ D2 move .l D2 ext - 4 .w D0 D1 move D2 D1 eor \ SHORT way ! - 5 0< IF (m/mod bsr SP )+ SP ) move Next THEN - 6 D0 D2 divs divovl bvs D2 SP -) move Next end-code - 7 - 8 Code mod ( n1 n2 -- mod ) - 9 SP )+ D0 move SP )+ D2 move .l D2 ext -10 .w D0 D1 move D2 D1 eor \ SHORT way ! -11 0< IF (m/mod bsr 2 SP addq Next THEN -12 D0 D2 divs divovl bvs -13 D2 swap D2 SP -) move Next end-code -14 -15 -Screen 44 not modified - 0 \ */mod */ u/mod ud/mod 18nov86we - 1 - 2 : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; - 3 : */ ( n1 n2 n3 -- quot ) */mod nip ; - 4 : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; - 5 : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r - 6 um/mod r> ; - 7 - 8 \\ - 9 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; -10 : / ( n1 n2 -- quot ) /mod nip ; -11 : mod ( n1 n2 -- rem ) /mod drop ; -12 : m/mod ( d n -- mod quot ) -13 dup >r abs over 0< IF under + swap THEN um/mod r@ 0< -14 IF negate over IF swap r@ + swap 1- THEN THEN -15 rdrop ; -Screen 45 not modified - 0 \ cmove cmove> 04sep86we - 1 - 2 Code cmove ( from to count -- ) - 3 SP )+ D0 move SP )+ D6 move D6 reg) A0 lea - 4 SP )+ D6 move D6 reg) A1 lea - 5 D0 tst 0<> IF 1 D0 subq - 6 D0 DO .b A1 )+ A0 )+ move LOOP THEN - 7 Next end-code - 8 - 9 Code cmove> ( from to count -- ) -10 SP )+ D0 move -11 SP )+ D6 move D0 D6 add D6 reg) A0 lea -12 SP )+ D6 move D0 D6 add D6 reg) A1 lea -13 D0 tst 0<> IF 1 D0 subq -14 D0 DO .b A1 -) A0 -) move LOOP THEN -15 Next end-code -Screen 46 not modified - 0 \ move place count bp 11 oct 86 - 1 - 2 : move ( from to quan -- ) - 3 >r 2dup u< IF r> cmove> exit THEN r> cmove ; - 4 - 5 : place ( addr len to --) - 6 over >r rot over 1+ r> move c! ; - 7 - 8 Code count ( adr -- adr+1 len ) - 9 SP ) D6 move D6 reg) A0 lea -10 D0 clr .b A0 )+ D0 move .w 1 SP ) addq D0 SP -) move -11 Next end-code -12 -13 -14 \\ -15 : count ( adr -- adr+1 len ) dup 1+ swap c@ ; -Screen 47 not modified - 0 \ fill erase bp 11 oct 86 - 1 - 2 Code fill ( addr quan 8b -- ) - 3 SP )+ D0 move SP )+ D1 move - 4 SP )+ D6 move D6 reg) A0 lea - 5 D1 tst 0<> IF - 6 1 D1 subq D1 DO .b D0 A0 )+ move LOOP THEN - 7 Next end-code - 8 - 9 : erase ( addr quan --) 0 fill ; -10 -11 -12 \\ -13 : fill ( addr quan 8b -- ) -14 swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN -15 2drop ; -Screen 48 not modified - 0 \ , c, 08sep86we - 1 - 2 Code , ( 8b -- ) UP R#) D6 move - 3 .l user' dp D6 FP DI) D6 .w move D6 reg) A0 lea - 4 .b SP )+ A0 )+ move SP )+ A0 )+ move - 5 .w UP R#) D6 move .l 2 user' dp D6 FP DI) .w addq - 6 Next end-code - 7 - 8 Code c, ( 8b -- ) UP R#) D6 move - 9 .l user' dp D6 FP DI) D6 .w move D6 reg) A0 lea -10 SP )+ D0 move .b D0 A0 )+ move -11 .w UP R#) D6 move .l 1 user' dp D6 FP DI) .w addq -12 Next end-code -13 \\ -14 : , ( 16b -- ) here ! 2 allot ; -15 : c, ( 8b -- ) here c! 1 allot ; -Screen 49 not modified - 0 \ allot pad compile 08sep86we - 1 - 2 Code here ( -- addr ) - 3 UP R#) D6 move .l user' dp D6 FP DI) SP -) .w move - 4 Next end-code - 5 - 6 Code allot ( n -- ) UP R#) D6 move SP )+ D0 move - 7 D0 .l user' dp D6 FP DI) .w add Next end-code - 8 - 9 : pad ( -- addr ) here $42 + ; -10 -11 : compile r> dup 2+ >r @ , ; restrict -12 \\ -13 : here ( -- addr ) dp @ ; -14 : allot ( n -- ) -15 dup here + up@ u> abort" Dictionary full" dp +! ; -Screen 50 not modified - 0 \ input strings 25mar86we - 1 - 2 Variable #tib 0 #tib ! - 3 Variable >tib here >tib ! &80 allot - 4 Variable >in 0 >in ! - 5 Variable blk 0 blk ! - 6 Variable span 0 span ! - 7 - 8 : tib ( -- addr ) >tib @ ; - 9 -10 : query tib &80 expect span @ #tib ! -11 >in off blk off ; -12 -13 -14 -15 -Screen 51 not modified - 0 \ scan skip /string 16nov85we - 1 - 2 : /string ( addr0 len0 +n - addr1 len1 ) - 3 over umin rot over + -rot - ; - 4 - 5 - 6 - 7 - 8 \\ - 9 : scan ( addr0 len0 char -- addr1 len1 ) >r -10 BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap -11 REPEAT rdrop ; -12 -13 : skip ( addr len del -- addr1 len1 ) >r -14 BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap -15 REPEAT rdrop ; -Screen 52 not modified - 0 \ skip scan 04sep86we - 1 - 2 Label done .l FP A0 suba .w A0 SP -) move D1 SP -) move Next - 3 Code skip ( addr len del -- addr1 len1 ) - 4 SP )+ D0 move SP )+ D1 move 1 D1 addq - 5 SP )+ D6 move D6 reg) A0 lea - 6 BEGIN 1 D1 subq 0<> - 7 WHILE .b A0 ) D2 move D2 D0 cmp done bne .w 1 A0 addq - 8 REPEAT done bra end-code - 9 -10 Code scan ( addr len chr -- addr1 len1 ) -11 SP )+ D0 move SP )+ D1 move 1 D1 addq -12 SP )+ D6 move D6 reg) A0 lea -13 BEGIN 1 D1 subq 0<> -14 WHILE .b A0 ) D2 move D2 D0 cmp done beq .w 1 A0 addq -15 REPEAT done bra end-code -Screen 53 not modified - 0 \ convert to upper case 04sep86we - 1 - 2 Label umlaut - 3 Ascii „ c, Ascii ” c, Ascii c, - 4 Ascii Ž c, Ascii ™ c, Ascii š c, - 5 - 6 Label (capital ( D1 -> D1 ) - 7 D1 7 # btst 0= IF - 8 .b Ascii a D1 cmpi >= IF Ascii z D1 cmpi - 9 <= IF bl D1 subi THEN THEN rts -10 THEN umlaut R#) A1 lea -11 2 D2 moveq D2 DO .b A1 ) D1 cmp -12 0= IF .w 3 A1 addq .b A1 ) D1 move rts THEN -13 .w 1 A1 addq LOOP rts end-code -14 -15 -Screen 54 not modified - 0 \ capital capitalize bp 11 oct 86 - 1 - 2 Code capital ( char -- char' ) - 3 SP ) D1 move (capital bsr D1 SP ) move Next end-code - 4 - 5 Code capitalize ( string -- string ) - 6 SP ) D6 move D6 reg) A0 lea - 7 D0 clr .b A0 )+ D0 move - 8 0<> IF 1 D0 subq D0 DO - 9 A0 ) D1 move (capital bsr D1 A0 )+ move -10 LOOP THEN Next end-code -11 -12 -13 \\ -14 : capitalize ( string -- string) -15 dup count bounds ?DO I c@ capital I c! LOOP ; -Screen 55 not modified - 0 \ (word bp 11 oct 86 - 1 - 2 Code (word ( char adr0 len0 -- addr ) - 3 D1 clr SP )+ D0 move D0 D4 move - 4 SP )+ D6 move D6 reg) A0 lea SP ) D2 move - 5 >in R#) D3 move D3 A0 adda D3 D0 sub - 6 <= IF D4 >in R#) move - 7 ELSE 1 D0 addq BEGIN 1 D0 subq 0<> - 8 WHILE .b A0 ) D2 cmp 0= - 9 WHILE .l 1 A0 addq REPEAT THEN -10 A0 A1 move .w 1 D0 addq -11 BEGIN .w 1 D0 subq 0<> -12 WHILE .b A0 ) D2 cmp 0<> -13 WHILE .w 1 A0 addq 1 D1 addq REPEAT THEN -14 .w D1 tst 0<> IF 1 A0 addq THEN -15 .l FP A0 suba D6 A0 suba .w A0 >in R#) move THEN -Screen 56 not modified - 0 \ (word Part2 bp 11 oct 86 - 1 - 2 UP R#) D6 move .l user' dp D6 FP DI) D6 .w move - 3 D6 reg) A0 lea D6 SP ) move - 4 .b D1 A0 )+ move .w 1 D1 subq - 5 0>= IF D1 DO .b A1 )+ A0 )+ move LOOP THEN - 6 bl # A0 ) move Next end-code - 7 - 8 - 9 \\ -10 : word ( char -- addr) -11 >r source over swap >in @ /string -12 r@ skip over swap r> scan >r -13 rot over swap - r> 0<> - -14 >in ! over - here dup >r place -15 bl r@ count + c! r> ; -Screen 57 not modified - 0 \ even source word parse name bp 11oct86 - 1 - 2 : even ( addr -- addr1 ) dup 1 and + ; - 3 - 4 Variable loadfile 0 loadfile ! - 5 - 6 : source ( -- addr len ) blk @ ?dup - 7 IF loadfile @ (block b/blk exit THEN tib #tib @ ; - 8 - 9 : word ( char -- addr ) source (word ; -10 -11 : parse ( char -- addr len ) -12 >r source >in @ /string over swap r> scan >r -13 over - dup r> 0<> - >in +! ; -14 -15 : name ( -- addr ) bl word capitalize exit ; -Screen 58 not modified - 0 \ state Ascii ," (" " 15jun86we - 1 - 2 Variable state 0 state ! - 3 - 4 : Ascii ( char -- n ) - 5 bl word 1+ c@ state @ IF [compile] Literal THEN ; - 6 immediate - 7 - 8 : ," Ascii " parse here over 1+ allot place ; - 9 : "lit r> r> under count + even >r >r ; restrict -10 : (" "lit ; restrict -11 : " compile (" ," align ; immediate restrict -12 -13 -14 -15 -Screen 59 not modified - 0 \ ." ( .( \ \\ hex decimal 25mar86we - 1 - 2 : (." "lit count type ; restrict - 3 : ." compile (." ," align ; immediate restrict - 4 : ( ascii ) parse 2drop ; immediate - 5 : .( ascii ) parse type ; immediate - 6 : \ >in @ c/l / 1+ c/l * >in ! ; immediate - 7 : \\ b/blk >in ! ; immediate - 8 : \needs name find nip IF [compile] \ THEN ; - 9 -10 : hex $10 base ! ; -11 : decimal &10 base ! ; -12 -13 -14 -15 -Screen 60 not modified - 0 \ number conversion: digit? cas201301 - 1 - 2 | Variable ptr \ points into string - 3 - 4 Label fail SP ) clr Next - 5 Code digit? ( char -- n true : false ) - 6 UP R#) D6 move .l user' base D6 FP DI) D0 .w move - 7 SP ) D1 move .b Ascii 0 D1 subi fail bmi &10 D1 cmpi - 8 0>= IF $11 D1 cmpi fail bmi 7 D1 subq THEN - 9 D0 D1 cmp fail bpl .w D1 SP ) move true # SP -) move -10 Next end-code -11 \\ -12 : digit? ( char -- digit true/ false ) -13 Ascii 0 - dup 9 u> IF [ Ascii A Ascii 9 - 1- ] Literal - -14 dup 9 u> IF [ 2swap ( unstructured ) ] THEN -15 base @ over u> ?dup ?exit THEN drop false ; -Screen 61 not modified - 0 \ number conversion: accumulate convert 11sep86we - 1 - 2 Code accumulate ( +d0 addr digit -- +d1 addr ) - 3 0 D0 moveq SP )+ D0 move - 4 2 SP D) D1 move 4 SP D) D2 move - 5 UP R#) D6 move .l user' base D6 FP DI) D3 .w move - 6 D3 D2 mulu D3 D1 mulu .l D1 swap .w D1 clr - 7 .l D2 D1 add D0 D1 add D1 2 SP D) move Next end-code - 8 - 9 : convert ( +d1 addr0 -- +d2 addr2 ) -10 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; -11 -12 -13 \\ -14 : accumulate ( +d0 adr digit - +d1 adr ) -15 swap >r swap base @ um* drop rot base @ um* d+ r> ; -Screen 62 not modified - 0 \ number conversion: end? char previous 25mar86we - 1 - 2 | : end? ( -- flag ) ptr @ 0= ; - 3 | : char ( addr0 -- addr1 char ) count -1 ptr +! ; - 4 | : previous ( addr0 -- addr0 char ) 1- count ; - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 63 not modified - 0 \ number conversion: ?nonum punctuation? 25mar86we - 1 - 2 | : ?nonum ( flag -- exit if true ) - 3 IF rdrop 2drop drop rdrop false THEN ; - 4 - 5 | : punctuation? ( char -- flag ) - 6 Ascii , over = swap Ascii . = or ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 64 not modified - 0 \ number conversion: fixbase? 25mar86we - 1 - 2 | : fixbase? ( char - char false / newbase true ) - 3 Ascii & case? IF &10 true exit THEN - 4 Ascii $ case? IF $10 true exit THEN - 5 Ascii H case? IF $10 true exit THEN - 6 Ascii % case? IF 2 true exit THEN false ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 65 not modified - 0 \ number conversion: ?num ?dpl 25mar86we - 1 - 2 Variable dpl -1 dpl ! - 3 - 4 | : ?num ( flag -- exit if true ) - 5 IF rdrop drop r> IF dnegate THEN - 6 rot drop dpl @ 1+ ?dup ?exit drop true THEN ; - 7 - 8 | : ?dpl dpl @ -1 = ?exit 1 dpl +! ; - 9 -10 -11 -12 -13 -14 -15 -Screen 66 not modified - 0 \ (number number 11sep86we - 1 - 2 : number? ( string - string false / n 0< / d 0> ) - 3 base push dup count ptr ! dpl on - 4 0 >r ( +sign) 0 0 rot end? ?nonum char - 5 Ascii - case? IF rdrop true >r end? ?nonum char THEN - 6 fixbase? IF base ! end? ?nonum char THEN - 7 BEGIN digit? 0= ?nonum - 8 BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL - 9 previous punctuation? 0= ?nonum dpl off end? ?num char -10 REPEAT ; -11 -12 : number ( string -- d ) -13 number? ?dup 0= abort" ?" 0< IF extend THEN ; -14 -15 -Screen 67 not modified - 0 \ hide reveal immediate restrict 24nov85we - 1 - 2 Variable last 0 last ! - 3 | : last? ( -- false / acf true) last @ ?dup ; - 4 : hide last? IF 2- @ current @ ! THEN ; - 5 : reveal last? IF 2- current @ ! THEN ; - 6 : Recursive reveal ; immediate restrict - 7 - 8 | : flag! ( 8b --) - 9 last? IF under c@ or over c! THEN drop ; -10 -11 : immediate $40 flag! ; -12 : restrict $80 flag! ; -13 -14 -15 -Screen 68 not modified - 0 \ clearstack hallot heap heap? bp 11 oct 86 - 1 - 2 Code clearstack - 3 UP R#) D6 move .l user' s0 D6 FP DI) D6 .w move - 4 $FFFE D6 andi D6 reg) SP lea Next end-code \ muž Code - 5 - 6 : hallot ( quan -- ) s0 @ over - swap sp@ 2+ dup rot - 7 dup 1 and ?dup IF over 0< IF negate THEN + THEN - 8 - dup s0 ! 2 pick over - move clearstack s0 ! ; - 9 -10 : heap ( -- addr ) s0 @ 6 + ; -11 : heap? ( addr -- flag ) heap up@ uwithin ; -12 -13 | : heapmove ( from -- from ) -14 dup here over - dup hallot -15 heap swap cmove heap over - last +! reveal ; -Screen 69 not modified - 0 \ Does> ; 24sep86we - 1 - 2 Label (dodoes> - 3 .l FP IP suba .w IP RP -) move A7 )+ IP lmove - 4 2 D7 addq D7 SP -) move Next end-code - 5 - 6 | : (;code r> last @ name> ! ; - 7 - 8 : Does> - 9 compile (;code $4EAB , compile (dodoes> ; -10 immediate restrict -11 -12 \ Does> compiles (;code and JSR (doedoes> FP D) -13 -14 -15 -Screen 70 not modified - 0 \ ?head | alignments warning exists? 15jun86we - 1 - 2 Variable ?head 0 ?head ! - 3 - 4 : | ?head @ ?exit -1 ?head ! ; - 5 - 6 - 7 : align here 1 and allot ; - 8 : halign heap 1 and hallot ; - 9 -10 Variable warning 0 warning ! -11 | : exists? warning @ ?exit last @ current @ -12 (find nip IF space last @ .name ." exists " ?cr THEN ; -13 -14 -15 -Screen 71 not modified - 0 \ Create 06sep86we - 1 - 2 : blk@ blk @ ; - 3 Defer makeview ' blk@ Is makeview - 4 - 5 : Create - 6 align here makeview , current @ @ , - 7 name c@ dup 1 $20 uwithin not abort" invalid name" - 8 here last ! 1+ allot align - 9 exists? ?head @ -10 IF 1 ?head +! dup , \ Pointer to Code -11 halign heapmove $20 flag! dp ! -12 ELSE drop THEN reveal 0 , -13 ;Code 2 D7 addq D7 SP -) move Next end-code -14 -15 -Screen 72 not modified - 0 \ nfa? 04sep86we - 1 - 2 Code nfa? ( thread cfa -- nfa | false ) - 3 SP )+ D2 move SP )+ D6 move D6 reg) A0 lea .w - 4 BEGIN A0 ) D6 move 0= IF SP -) clr Next THEN - 5 .l D6 reg) A0 lea 2 D6 addq D6 reg) A1 lea - 6 .b A1 ) D0 move .w $1F D0 andi 1 D0 addq - 7 D0 D1 move 1 D1 andi D1 D0 add D0 D6 add - 8 .b A1 ) D0 move .w $20 D0 andi 0<> - 9 IF D6 reg) D6 move THEN -10 D2 D6 cmp 0= UNTIL -11 .l FP A1 suba .w A1 SP -) move Next end-code -12 -13 \\ : nfa? ( thread cfa -- nfa / false) -14 >r BEGIN @ dup 0= IF rdrop exit THEN -15 dup 2+ name> r@ = UNTIL 2+ rdrop ; -Screen 73 not modified - 0 \ >name name> >body .name 14sep86we - 1 - 2 : >name ( cfa -- nfa / false ) voc-link - 3 BEGIN @ dup WHILE 2dup 4- swap nfa? - 4 ?dup IF -rot 2drop exit THEN REPEAT nip ; - 5 - 6 | : (name> ( nfa -- cfa ) count $1F and + even ; - 7 - 8 : name> ( nfa -- cfa ) - 9 dup (name> swap c@ $20 and IF @ THEN ; -10 -11 : >body ( cfa -- pfa ) 2+ ; -12 -13 : .name ( nfa -- ) -14 ?dup IF dup heap? IF ." |" THEN -15 count $1F and type ELSE ." ???" THEN space ; -Screen 74 not modified - 0 \ : ; Constant Variable bp 12oct86 - 1 - 2 : Create: Create hide current @ context ! ] 0 ; - 3 - 4 : : Create: - 5 ;Code .l FP IP suba .w IP RP -) move - 6 .l 2 D7 FP DI) IP lea Next end-code - 7 - 8 : ; 0 ?pairs compile unnest [compile] [ reveal ; - 9 immediate restrict -10 -11 : Constant Create , -12 ;Code .l 2 D7 FP DI) .w SP -) move Next end-code -13 -14 : 2Constant Create , , does> 2@ ; -15 -Screen 75 not modified - 0 \ uallot User Alias bp 12oct86 - 1 - 2 : Variable Create 2 allot ; - 3 : 2Variable Create 4 allot ; - 4 - 5 : uallot ( quan -- offset ) - 6 dup udp @ + $FF u> abort" Userarea full" - 7 udp @ swap udp +! ; - 8 - 9 : User Create udp @ 1 and udp +! 2 uallot c, -10 ;Code UP R#) D0 move 0 D1 moveq .l 2 D7 FP DI) .b D1 move -11 .w D1 D0 add D0 SP -) move Next end-code -12 -13 : Alias ( cfa -- ) -14 Create last @ dup c@ $20 and -15 IF -2 allot ELSE $20 flag! THEN (name> ! ; -Screen 76 not modified - 0 \ vp current context also toss 19mar86we - 1 - 2 Create vp $10 allot Variable current - 3 - 4 : context ( -- addr ) vp dup @ + 2+ ; - 5 - 6 | : thru.vocstack ( -- from to ) vp 2+ context ; - 7 \ "Only Forth also Assembler" gives - 8 \ vp: countword = 6 | Only | Forth | Assembler | - 9 -10 : also vp @ &10 > error" Vocabulary stack full" -11 context @ 2 vp +! context ! ; -12 -13 : toss vp @ IF -2 vp +! THEN ; -14 -15 -Screen 77 not modified - 0 \ Vocabulary Forth Only Onlyforth 24nov85we - 1 - 2 : Vocabulary - 3 Create 0 , 0 , here voc-link @ , voc-link ! - 4 Does> context ! ; - 5 \ | Name | Code | Thread | Coldthread | Voc-link | - 6 - 7 Vocabulary Forth - 8 Vocabulary Only - 9 ] Does> [ Onlypatch ] 0 vp ! context ! also ; ' Only ! -10 -11 : Onlyforth Only Forth also definitions ; -12 -13 -14 -15 -Screen 78 not modified - 0 \ definitions order words 24nov85we - 1 - 2 : definitions context @ current ! ; - 3 | : .voc ( adr -- ) @ 2- >name .name ; - 4 : order thru.vocstack DO I .voc -2 +LOOP - 5 2 spaces current .voc ; - 6 - 7 : words context @ - 8 BEGIN @ dup stop? 0= and - 9 WHILE ?cr dup 2+ .name space REPEAT drop ; -10 -11 -12 -13 -14 -15 -Screen 79 not modified - 0 \ found -text bp 11 oct 86 - 1 - 2 | : found ( nfa -- cfa n ) - 3 dup c@ >r (name> r@ $20 and IF @ THEN - 4 -1 r@ $80 and IF 1- THEN - 5 r> $40 and IF negate THEN ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 80 not modified - 0 \ (find bp 11 oct 86 - 1 \ A0: thread A1: string A2: nfa in thread D0: count - 2 \ D1: act. char D3: act. nfa D4: string - 3 Label notfound SP -) clr Next - 4 - 5 Code (find ( str thr - str false/ NFA true ) - 6 .w SP )+ D6 move D6 reg) A0 lea - 7 SP ) D6 move D6 reg) A1 lea - 8 .b A1 ) D0 move .w $1F D0 andi A1 D4 lmove - 9 D4 0 # btst 0= IF 1 D0 addq -10 Label findloop D4 A1 lmove -11 BEGIN A0 ) D6 move notfound beq D6 reg) A0 lea -12 .w A1 ) D1 move -13 .l 2 D6 FP DI) D1 .w sub $1FFF D1 andi 0= UNTIL -14 .l 2 D6 FP DI) A2 lea A2 D3 move -15 2 A1 addq 2 A2 addq -Screen 81 not modified - 0 \ (find part 2 09sep86we - 1 - 2 .w 0 D2 moveq BEGIN 2 D2 addq D2 D0 cmp > - 3 WHILE A1 )+ A2 )+ cmpm findloop bne REPEAT - 4 ELSE - 5 Label findloop1 A0 ) D6 move notfound beq - 6 .l D6 reg) A0 lea 2 D6 FP DI) A2 lea - 7 A2 D3 move D4 A1 move - 8 .b A1 )+ D1 move A2 )+ D1 sub $1F D1 andi findloop1 bne - 9 D0 D1 move BEGIN 1 D1 subq 0>= -10 WHILE A1 )+ A2 )+ cmpm findloop1 bne REPEAT -11 THEN -12 .l FP D3 sub .w D3 SP ) move -13 true # SP -) move Next end-code -14 -15 -Screen 82 not modified - 0 \ find ' ['] cas201301 - 1 - 2 : find ( string -- cfa n / string false ) - 3 context dup @ over 2- @ = IF 2- THEN - 4 BEGIN under @ (find IF nip found exit THEN - 5 over vp 2+ u> WHILE swap 2- REPEAT nip false ; - 6 - 7 : ' ( -- cfa ) name find 0= abort" ?" ; - 8 - 9 : [compile] ' , ; immediate restrict -10 -11 : ['] ' [compile] Literal ; immediate restrict -12 -13 : nullstring? ( string -- string false / true ) -14 dup c@ 0= dup IF nip THEN ; -15 -Screen 83 not modified - 0 \ >interpret 24sep86we - 1 - 2 Label jump - 3 .l 2 D7 FP DI) .w D6 move D6 reg) IP lea 2 IP addq - 4 Next end-code - 5 - 6 Create >interpret 2 allot jump ' >interpret ! - 7 - 8 \ make >interpret to special Defer - 9 -10 -11 -12 -13 -14 -15 -Screen 84 not modified - 0 \ interpret interactive cas201301 - 1 - 2 Defer notfound - 3 : no.extensions ( string -- ) error" ?" ; \ string not 0 - 4 ' no.extensions Is notfound - 5 - 6 : interpret >interpret ; - 7 - 8 | : interpreter ?stack name find ?dup - 9 IF 1 and IF execute >interpret THEN -10 abort" compile only" THEN -11 nullstring? ?exit -12 number? 0= IF notfound THEN >interpret ; -13 -14 ' interpreter >interpret ! -15 -Screen 85 not modified - 0 \ compiling [ ] 22mar86we - 1 - 2 | : compiler ?stack name find ?dup - 3 IF 0> IF execute >interpret THEN , >interpret THEN - 4 nullstring? ?exit - 5 number? ?dup - 6 IF 0> IF swap [compile] Literal THEN [compile] Literal - 7 >interpret THEN - 8 notfound >interpret ; - 9 -10 : [ ['] interpreter Is >interpret state off ; immediate -11 : ] ['] compiler Is >interpret state on ; -12 -13 -14 -15 -Screen 86 not modified - 0 \ Defer Is 24sep86we - 1 - 2 | : crash true abort" crash" ; - 3 - 4 : Defer Create ['] crash , - 5 ;Code .l 2 D7 FP DI) .w D7 move - 6 D7 reg) D6 move .l D6 reg) jmp end-code - 7 - 8 : (is r> dup 2+ >r @ ! ; - 9 -10 | : def? ( cfa -- ) @ ['] notfound @ over = -11 swap ['] >interpret @ = or -12 not abort" not deferred" ; -13 -14 : Is ( adr -- ) ' dup def? >body -15 state @ IF compile (is , exit THEN ! ; immediate -Screen 87 not modified - 0 \ ?stack 08sep86we - 1 - 2 | : stackfull ( -- ) - 3 depth $20 > abort" tight stack" reveal last? - 4 IF dup heap? IF name> ELSE 4- THEN (forget THEN - 5 true abort" Dictionary full" ; - 6 - 7 Code ?stack - 8 UP R#) D6 move .l user' dp D6 FP DI) D0 .w move - 9 .l SP D1 move FP D1 sub .w D0 D1 sub $100 D1 cmpi -10 $6200 ( u<= ) IF ;c: stackfull ; Assembler THEN -11 .l user' s0 D6 FP DI) D0 .w move .l SP D1 move FP D1 sub -12 .w D1 D0 cmp 0>= IF Next THEN ;c: true abort" Stack empty" ; -13 -14 \\ : ?stack sp@ here - $100 u< IF stackfull THEN -15 sp@ s0 @ u> abort" Stack empty" ; -Screen 88 not modified - 0 \ .status push load 28aug86we - 1 - 2 Defer .status ' noop Is .status - 3 - 4 | Create: pull r> r> ! ; - 5 - 6 : push ( addr -- ) r> swap dup >r @ >r pull >r >r ; - 7 restrict - 8 - 9 -10 : (load ( blk offset -- ) over 0= IF 2drop exit THEN -11 isfile push loadfile push fromfile push blk push >in push -12 >in ! blk ! isfile @ loadfile ! .status interpret ; -13 -14 : load ( blk -- ) 0 (load ; -15 -Screen 89 not modified - 0 \ +load thru +thru --> rdepth depth 19mar86we - 1 - 2 : +load ( offset -- ) blk @ + load ; - 3 - 4 : thru ( from to -- ) 1+ swap DO I load LOOP ; - 5 - 6 : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; - 7 - 8 : --> 1 blk +! >in off .status ; - 9 immediate -10 -11 : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; -12 : depth ( -- +n ) sp@ s0 @ swap - 2/ ; -13 -14 -15 -Screen 90 not modified - 0 \ quit (quit abort cas201301 - 1 - 2 | : prompt state @ IF ." [ " exit THEN ." ok" ; - 3 - 4 : (quit BEGIN .status cr query interpret prompt - 5 REPEAT ; - 6 - 7 Defer 'quit ' (quit Is 'quit - 8 : quit r0 @ rp! [compile] [ 'quit ; - 9 -10 : standardi/o [ output ] Literal output 4 cmove ; -11 -12 Defer 'abort ' noop Is 'abort -13 : abort clearstack end-trace -14 'abort standardi/o quit ; -15 -Screen 91 not modified - 0 \ (error abort" error" 29mar86we - 1 - 2 Variable scr 1 scr ! Variable r# 0 r# ! - 3 - 4 : (error ( string -- ) - 5 standardi/o space here .name count type space ?cr - 6 blk @ ?dup IF scr ! >in @ r# ! THEN quit ; - 7 ' (error errorhandler ! - 8 - 9 : (abort" "lit swap IF >r clearstack r> -10 errorhandler perform exit THEN drop ; restrict -11 -12 | : (err" "lit swap IF errorhandler perform exit THEN -13 drop ; restrict -14 : abort" compile (abort" ," align ; immediate restrict -15 : error" compile (err" ," align ; immediate restrict -Screen 92 not modified - 0 \ -trailing bp 11 oct 86 - 1 - 2 Code -trailing ( addr n1 -- addr n2 ) - 3 SP )+ D0 move 0<> IF - 4 SP ) D6 move D6 reg) A0 lea D0 A0 adda - 5 Label -trail .b A0 -) D1 move $20 D1 cmpi -trail D0 dbne - 6 .w -1 D0 cmpi 0= IF D0 clr THEN - 7 THEN D0 SP -) move Next end-code - 8 - 9 -10 -11 -12 \\ -13 : -trailing ( addr n1 -- addr n2) 2dup bounds -14 ?DO 2dup + 1- c@ bl - -15 IF LEAVE THEN 1- LOOP ; -Screen 93 not modified - 0 \ space spaces bp 11 oct 86 - 1 - 2 $20 Constant bl - 3 - 4 : space bl emit ; - 5 - 6 : spaces ( u -- ) 0 ?DO space LOOP ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 94 not modified - 0 \ hold <# #> sign # #s 02may86we - 1 - 2 | : hld ( -- addr ) pad 2- ; - 3 - 4 : hold ( char -- ) -1 hld +! hld @ c! ; - 5 - 6 : <# hld hld ! ; - 7 - 8 : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; - 9 -10 : sign ( n -- ) 0< IF Ascii - hold THEN ; -11 -12 : # ( +d1 -- +d2 ) base @ ud/mod rot 9 over < -13 IF [ ascii A ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; -14 -15 : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; -Screen 95 not modified - 0 \ print numbers 24dec83ks - 1 - 2 : d.r -rot under dabs <# #s rot sign #> - 3 rot over max over - spaces type ; - 4 - 5 : .r swap extend rot d.r ; - 6 - 7 : u.r 0 swap d.r ; - 8 - 9 : d. 0 d.r space ; -10 -11 : . extend d. ; -12 -13 : u. 0 d. ; -14 -15 -Screen 96 not modified - 0 \ .s list c/l l/s bp 18May86 - 1 - 2 : .s - 3 sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; - 4 - 5 $40 Constant c/l \ Screen line length - 6 $10 Constant l/s \ lines per screen - 7 - 8 : list ( blk -- ) - 9 scr ! ." Scr " scr @ dup u. ." Dr " drv? . -10 l/s 0 DO -11 cr I 2 .r space scr @ block I c/l * + c/l -trailing type -12 LOOP cr ; -13 -14 -15 -Screen 97 not modified - 0 \ multitasker primitives 14sep86we - 1 - 2 Code pause Next end-code - 3 - 4 : lock ( addr -- ) - 5 dup @ up@ = IF drop exit THEN - 6 BEGIN dup @ WHILE pause REPEAT up@ swap ! ; - 7 - 8 : unlock ( addr -- ) dup lock off ; - 9 -10 Label wake .l 2 A7 addq A7 )+ A0 move 2 A0 subq -11 A0 A1 move FP A1 suba .w A1 UP R#) move -12 $3C3C ( # D6 move ) # A0 ) move -13 8 A0 D) D6 move D6 reg) SP lea -14 SP )+ D6 move D6 reg) RP lea -15 SP )+ D6 move D6 reg) IP lea Next end-code -Screen 98 not modified - 0 \ buffer mechanism cas201301 - 1 - 2 User isfile 0 isfile ! \ addr of file control block - 3 Variable fromfile 0 fromfile ! - 4 Variable prev 0 prev ! \ Listhead - 5 | Variable buffers 0 buffers ! \ Semaphore - 6 $408 Constant b/buf \ physical size - 7 - 8 \\ Structure of buffer: 0 : link - 9 2 : file -10 4 : blocknumber -11 6 : statusflags -12 8 : Data ... 1 Kb ... -13 Statusflag bits : 15 1 -> updated -14 file : -1 -> empty buffer, 0 -> no fcb, direct acces -15 else addr of fcb ( system dependent ) -Screen 99 not modified - 0 \ search for blocks in memory with (CORE? cas201301 - 1 \ D0:blk D1:file A0:bufadr A1:previous - 2 Label thisbuffer? - 3 2 A0 D) D1 cmp 0= IF 4 A0 D) D0 cmp THEN rts - 4 Code (core? ( blk file -- adr\blk file ) - 5 2 SP D) D0 move SP ) D1 move - 6 UP R#) D6 move .l user' offset D6 FP DI) D0 .w add - 7 prev R#) D6 move D6 reg) A0 lea - 8 thisbuffer? bsr 0= IF .l FP A0 suba - 9 Label blockfound 2 SP addq 8 A0 addq .w A0 SP ) move -10 .l ' exit @ R#) jmp .w THEN -11 BEGIN A0 A1 lmove A1 ) D6 move 0= IF Next THEN -12 D6 reg) A0 lea thisbuffer? bsr 0= UNTIL -13 A0 ) A1 ) move prev R#) A0 ) move -14 .l FP A0 suba .w A0 prev R#) move -15 blockfound bra end-code -Screen 100 not modified - 0 \ (core? 17nov85we - 1 - 2 \\ - 3 | : this? ( blk file bufadr -- flag ) - 4 dup 4+ @ swap 2+ @ d= ; - 5 - 6 | : (core? ( blk file -- dataaddr / blk file ) - 7 BEGIN over offset @ + over prev @ this? - 8 IF rdrop 2drop prev @ 8 + exit THEN - 9 2dup >r offset @ + >r prev @ -10 BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN -11 dup r> r> 2dup >r >r rot this? 0= -12 WHILE nip REPEAT -13 dup @ rot ! prev @ over ! prev ! rdrop rdrop -14 REPEAT ; -15 -Screen 101 not modified - 0 \ r/w 11sep86we - 1 - 2 Defer r/w - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 102 not modified - 0 \ backup emptybuf readblk 11sep86we - 1 - 2 : backup ( bufaddr -- ) dup 6+ @ 0< - 3 IF 2+ dup @ 1+ \ buffer empty if file = -1 - 4 IF input push output push standardi/o - 5 dup 6+ over 2+ @ 2 pick @ 0 r/w - 6 abort" write error" - 7 THEN 4+ dup @ $7FFF and over ! THEN drop ; - 8 - 9 : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; -10 -11 | : readblk ( blk file addr -- blk file addr ) -12 dup emptybuf -13 input push output push standardi/o >r -14 over offset @ + over r@ 8 + -rot 1 r/w -15 abort" read error" r> ; -Screen 103 not modified - 0 \ take mark updated? full? core? cas20130105 - 1 - 2 | : take ( -- bufaddr) prev - 3 BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL - 4 buffers lock dup backup ; - 5 - 6 | : mark ( blk file bufaddr -- blk file ) - 7 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off - 8 buffers unlock ; - 9 -10 | : updates? ( -- bufaddr / flag ) -11 prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; -12 : updated? ( blk -- flg ) block 2- @ 0< ; -13 : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6+ @ 0< ; -14 -15 : core? ( blk file -- addr /false ) (core? 2drop false ; -Screen 104 not modified - 0 \ block & buffer manipulation b08sep86we - 1 - 2 : (buffer ( blk file -- addr ) - 3 BEGIN (core? take mark REPEAT ; - 4 - 5 : (block ( blk file -- addr ) - 6 BEGIN (core? take readblk mark REPEAT ; - 7 - 8 Code isfile@ ( -- addr ) - 9 UP R#) D6 move .l user' isfile D6 FP DI) SP -) .w move -10 Next end-code -11 -12 : buffer ( blk -- addr ) isfile@ (buffer ; -13 -14 : block ( blk -- addr ) isfile@ (block ; -15 -Screen 105 not modified - 0 \ block & buffer manipulation cas20130501 - 1 - 2 : update $80 prev @ 6+ c! ; - 3 - 4 : save-buffers buffers lock - 5 BEGIN updates? ?dup WHILE backup REPEAT - 6 buffers unlock ; - 7 - 8 : empty-buffers buffers lock prev - 9 BEGIN @ ?dup WHILE dup emptybuf REPEAT -10 buffers unlock ; -11 -12 : flush save-buffers empty-buffers ; -13 -14 -15 -Screen 106 not modified - 0 \ moving blocks cas201301 - 1 | : fromblock ( blk -- adr ) fromfile @ (block ; - 2 | : (copy ( from to -- ) - 3 dup isfile@ core? IF prev @ emptybuf THEN - 4 full? IF save-buffers THEN - 5 offset @ + isfile@ rot fromblock 6 - 2! update ; - 6 - 7 | : blkmove ( from to quan --) save-buffers >r - 8 over r@ + over u> >r 2dup u< r> and - 9 IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP -10 ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP -11 THEN save-buffers 2drop ; -12 -13 : copy ( from to --) 1 blkmove ; -14 : convey ( [blk1 blk2] [to.blk --) -15 swap 1+ 2 pick - dup 0> not abort" No!" blkmove ; -Screen 107 not modified - 0 \ Allocating buffers bp 18May86 - 1 - 2 $FFFE Constant limit Variable first - 3 - 4 : allotbuffer ( -- ) - 5 first @ r0 @ - b/buf 2+ u< ?exit - 6 b/buf negate first +! first @ dup emptybuf - 7 prev @ over ! prev ! ; - 8 - 9 : freebuffer ( -- ) -10 first @ limit b/buf - u< -11 IF first @ backup prev -12 BEGIN dup @ first @ - WHILE @ REPEAT -13 first @ @ swap ! b/buf first +! THEN ; -14 -15 : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; -Screen 108 not modified - 0 \ endpoints of forget 14sep86we - 1 - 2 | : |? ( nfa -- flag ) c@ $20 and ; - 3 | : forget? ( adr nfa -- flag ) \ code in heap or above adr ? - 4 name> under 1+ u< swap heap? or ; - 5 - 6 | : endpoints ( addr -- addr symb ) - 7 heap voc-link >r - 8 BEGIN r> @ ?dup \ through all Vocabs - 9 WHILE dup >r 4- >r \ link on returnstack -10 BEGIN r> @ >r over 1- dup r@ u< \ until link or -11 swap r@ 2+ name> u< and \ code under adr -12 WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap -13 r@ 2+ |? IF over r@ 2+ forget? -14 IF r@ 2+ (name> 2+ umax THEN \ then update symb -15 THEN REPEAT rdrop REPEAT ; -Screen 109 not modified - 0 \ remove, -words, -tasks bp/ks14sep86we - 1 - 2 : remove ( dic sym thread - dic sym ) - 3 BEGIN dup @ ?dup \ unlink forg. words - 4 WHILE dup heap? - 5 IF 2 pick over u> ELSE 3 pick over 1+ u< THEN - 6 IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; - 7 - 8 | : remove-words ( dic sym -- dic sym ) - 9 voc-link BEGIN @ ?dup -10 WHILE dup >r 4- remove r> REPEAT ; -11 -12 | : remove-tasks ( dic -- ) up@ -13 BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin -14 IF dup @ 2+ @ over ! 2- -15 ELSE @ THEN REPEAT 2drop ; -Screen 110 not modified - 0 \ remove-vocs forget-words bp 11oct86 - 1 - 2 | : remove-vocs ( dic symb -- dic symb ) - 3 voc-link remove thru.vocstack - 4 DO 2dup I @ -rot uwithin - 5 IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP - 6 2dup current @ -rot uwithin - 7 IF [ ' Forth 2+ ] Literal current ! THEN ; - 8 - 9 | : remove-codes ( dic symb -- dic symb ) -10 next-link remove ; -11 -12 Defer custom-remove ' noop Is custom-remove -13 | : forget-words ( dic symb -- ) -14 over remove-tasks remove-vocs remove-words remove-codes -15 custom-remove heap swap - hallot dp ! last off ; -Screen 111 not modified - 0 \ deleting words from dict. bp 11oct86 - 1 - 2 : clear here dup up@ forget-words dp ! ; - 3 - 4 : (forget ( adr -- ) dup heap? abort" is symbol" - 5 endpoints forget-words ; - 6 - 7 : forget ' dup [ dp ] Literal @ u< abort" protected" - 8 >name dup heap? - 9 IF name> ELSE 4- THEN (forget ; -10 -11 : empty [ dp ] Literal @ up@ forget-words -12 [ udp ] Literal @ udp ! ; -13 -14 -15 -Screen 112 not modified - 0 \ save bye stop? ?cr cas201301 - 1 - 2 : save here up@ forget-words - 3 voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL - 4 up@ origin $100 cmove ; - 5 - 6 : bye flush empty (bye ; - 7 - 8 | : end? key $FF and dup 3 = \ Stop key - 9 swap $1B = or \ Escape key -10 IF true rdrop THEN ; -11 -12 : stop? ( -- flag ) key? IF end? end? THEN false ; -13 -14 : ?cr col c/l u> IF cr THEN ; -15 -Screen 113 not modified - 0 \ in/output structure 25mar86we - 1 - 2 | : Out: Create dup c, 2+ Does> c@ output @ + perform ; - 3 - 4 : Output: Create: Does> output ! ; - 5 0 Out: emit Out: cr Out: type Out: del - 6 Out: page Out: at Out: at? drop - 7 - 8 : row ( -- row ) at? drop ; - 9 : col ( -- col ) at? nip ; -10 -11 | : In: Create dup c, 2+ Does> c@ input @ + perform ; -12 -13 : Input: Create: Does> input ! ; -14 0 In: key In: key? In: decode In: expect drop -15 -Screen 114 not modified - 0 \ Alias only definitionen 29jan85bp - 1 - 2 Only definitions Forth - 3 - 4 : seal 0 ['] Only >body ! ; \ kill all words in Only - 5 - 6 ' Only Alias Only - 7 ' Forth Alias Forth - 8 ' words Alias words - 9 ' also Alias also -10 ' definitions Alias definitions -11 -12 Host Target -13 -14 -15 -Screen 115 not modified - 0 \ 'cold 'restart 19mar86we - 1 - 2 | : init-vocabularys voc-link @ - 3 BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; - 4 | : init-buffers 0 prev ! limit first ! all-buffers ; - 5 - 6 Defer 'cold ' noop Is 'cold - 7 | : (cold origin up@ $100 cmove - 8 init-vocabularys init-buffers 'cold page wrap - 9 Onlyforth cr &27 spaces logo count type cr (restart ; -10 -11 Defer 'restart ' noop Is 'restart -12 | : (restart ['] (quit Is 'quit drvinit 'restart -13 [ errorhandler ] Literal @ errorhandler ! -14 ['] noop Is 'abort abort ; -15 -Screen 116 not modified - 0 \ cold bootsystem restart 16oct86we - 1 - 2 Label buserror &14 # A7 adda ;c: true abort" Bus Error !" ; - 3 Label adrerror &14 # A7 adda ;c: true abort" Adress Error !" ; - 4 Label illegal 6 A7 addq - 5 ;c: true abort" Illegal Instruction !" ; - 6 Label div0 6 A7 addq ;c: true abort" Division by 0 !" ; - 7 - 8 - 9 -10 | Create save_ssp 4 allot -11 -12 Code cold here >cold ! -13 $A00A , \ hide mouse -14 ' (cold >body FP D) IP lea -15 -Screen 117 not modified - 0 \ restart 16oct86we - 1 - 2 Label bootsystem .l 0 D7 moveq - 3 .w user' s0 # D7 move origin D7 FP DI) D6 move - 4 .l D6 reg) SP lea .w 6 D6 addq D6 UP R#) move - 5 .w user' r0 # D7 move origin D7 FP DI) D6 move - 6 .l D6 reg) RP lea RP ) clr 0 D6 moveq - 7 .w D0 movedst) 0= IF - 8 .l A7 -) clr .w $20 # A7 -) move 1 trap - 9 .l D0 save_ssp R#) move 6 A7 addq THEN -10 .w buserror # D6 move .l D6 reg) A0 lea A0 8 #) move -11 .w adrerror # D6 move .l D6 reg) A0 lea A0 $0C #) move -12 .w illegal # D6 move .l D6 reg) A0 lea A0 $10 #) move -13 .w div0 # D6 move .l D6 reg) A0 lea A0 $14 #) move -14 .w wake # D6 move .l D6 reg) A0 lea A0 $8C #) move -15 Next end-code -Screen 118 not modified - 0 \ System dependent load screen bp 11oct86 - 1 - 2 Code restart here >restart ! - 3 ' (restart >body FP D) IP lea bootsystem bra end-code - 4 - 5 2 $0C +thru \ Atari 520 ST Interface - 6 - 7 Host ' Transient 8 + @ Transient Forth context @ 6 + ! - 8 \ Tlatest aus Transient wird Tlatest in Forth - 9 -10 Target Forth also definitions -11 : forth-83 ; \ last word in Dictionary -12 -13 -14 -15 -Screen 119 not modified - 0 \ System patchup 14sep86we - 1 - 2 Forth definitions - 3 - 4 $D3AA s0 ! $D7AA r0 ! \ gives &10 Buffers - 5 s0 @ dup s0 2- ! 6 + s0 8 - ! - 6 here dp ! - 7 - 8 Host Tudp @ Target udp ! - 9 Host Tvoc-link @ Target voc-link ! -10 Host Tnext-link @ Target next-link ! -11 Host move-threads -12 -13 -14 -15 -Screen 120 not modified - 0 \ BIOS - Calls 09sep86we - 1 - 2 Code bconstat ( dev -- fl ) - 3 SP )+ D0 move D0 A7 -) move 1 # A7 -) move $0D trap - 4 4 A7 addq D0 SP -) move Next end-code - 5 Code bcostat ( dev -- fl ) - 6 SP )+ D0 move D0 A7 -) move 8 # A7 -) move $0D trap - 7 4 A7 addq D0 SP -) move Next end-code - 8 - 9 Code bconin ( dev -- char ) -10 SP )+ D0 move D0 A7 -) move 2 # A7 -) move $0D trap -11 4 A7 addq .w D0 D1 move .l 8 # D0 lsr .b D1 D0 move -12 .w D0 SP -) move Next end-code -13 Code bconout ( char dev -- ) -14 SP )+ D0 move SP )+ A7 -) move D0 A7 -) move -15 3 # A7 -) move $0D trap 6 A7 addq Next end-code -Screen 121 not modified - 0 \ STkey? getkey cas201301 - 1 - 2 $08 Constant #bs $0D Constant #cr - 3 $0A Constant #lf $1B Constant #esc - 4 - 5 : con! ( 8b -- ) 2 bconout ; - 6 : curon #esc con! Ascii e con! ; - 7 : curoff #esc con! Ascii f con! ; - 8 : wrap #esc con! Ascii v con! ; - 9 : cur< #esc con! Ascii D con! -1 out +! ; -10 : cur> #esc con! Ascii C con! 1 out +! ; -11 -12 : STkey? ( -- fl ) 2 bconstat ; -13 : getkey ( -- char ) STkey? IF 2 bconin ELSE 0 THEN ; -14 : STkey ( -- char ) curon -15 BEGIN pause STkey? UNTIL curoff getkey ; -Screen 122 not modified - 0 \ (ins (del cas201301 - 1 - 2 | Variable maxchars - 3 - 4 | : (del ( addr pos1 -- addr pos2 ) 2dup cur< - 5 at? >r >r 2dup + over span @ - negate under type space - 6 r> r> at - 7 >r + dup 1- r> cmove -1 span +! 1- ; - 8 - 9 | : (ins ( addr pos1 -- addr pos2 ) 2dup -10 + over span @ - negate >r dup dup 1+ r@ cmove> -11 bl over c! r> 1+ at? >r >r type r> r> at -12 1 span +! ; -13 -14 -15 -Screen 123 not modified - 0 \ decode cas201301 - 1 - 2 : STdecode ( addr pos1 key -- addr pos2 ) - 3 $4D00 case? IF dup span @ < IF cur> 1+ THEN exit THEN - 4 $4B00 case? IF dup IF cur< 1- THEN exit THEN - 5 $5200 case? IF dup span @ - IF (ins THEN exit THEN - 6 $FF and dup 0= IF drop exit THEN - 7 #bs case? IF dup IF (del THEN exit THEN - 8 $7F case? IF span @ 2dup < and - 9 IF cur> 1+ (del THEN exit THEN -10 #cr case? IF span @ maxchars ! -11 dup at? rot span @ - - at exit THEN -12 >r 2dup + r@ swap c! r> emit -13 dup span @ = IF 1 span +! THEN 1+ ; -14 -15 -Screen 124 not modified - 0 \ expect keyboard 25mar86we - 1 - 2 : STexpect ( addr len -- ) maxchars ! - 3 span off 0 - 4 BEGIN span @ maxchars @ u< WHILE key decode REPEAT - 5 2drop space ; - 6 - 7 - 8 Input: keyboard [ here input ! ] - 9 STkey STkey? STdecode STexpect ; -10 -11 -12 -13 -14 -15 -Screen 125 not modified - 0 \ emit cr del page at at? type cas201301 - 1 - 2 | Variable out 0 out ! | &80 Constant c/row - 3 - 4 : STemit ( 8b -- ) 5 bconout 1 out +! pause ; - 5 : STcr #cr con! #lf con! - 6 out @ c/row / 1+ c/row * out ! ; - 7 : STdel #bs con! space #bs con! -2 out +! ; - 8 : STpage #esc con! Ascii E con! out off ; - 9 : STat ( row col -- ) #esc con! Ascii Y con! -10 over $20 + con! dup $20 + con! -11 swap c/row * + out ! ; -12 : STat? ( -- row col ) out @ c/row /mod swap ; -13 -14 \\ -15 : STtype ( addr len --) 0 ?DO count emit LOOP drop ; -Screen 126 not modified - 0 \ Output 16oct86we - 1 - 2 Code STtype ( addr len -- ) - 3 SP )+ D3 move SP )+ D6 move D3 tst 0<> - 4 IF D3 out R#) add 1 D3 subq - 5 D3 DO D6 reg) A0 lea .b A0 ) D1 move FP A7 -) lmove - 6 .w D1 A7 -) move 5 # A7 -) move 3 # A7 -) move - 7 $0D trap 6 A7 addq 1 D6 addq A7 )+ FP lmove LOOP - 8 THEN ;c: pause ; - 9 -10 Output: display [ here output ! ] -11 STemit STcr STtype STdel STpage STat STat? ; -12 -13 | Code term .l save_ssp R#) A7 -) move .w $20 # A7 -) move -14 1 trap 6 A7 addq A7 -) clr 1 trap end-code -15 | : (bye curoff term ; -Screen 127 not modified - 0 \ b/blk drive >drive drvinit 10sep86we - 1 - 2 $400 Constant b/blk - 3 | Variable (drv 0 (drv ! - 4 Create (blk/drv - 5 4 allot $15F (blk/drv ! $15F (blk/drv 2+ ! - 6 - 7 : blk/drv ( -- n ) (blk/drv (drv @ 2* + @ ; - 8 - 9 : drive ( drv# -- ) $1000 * offset ! ; -10 : >drive ( block drv# -- block' ) $1000 * + offset @ - ; -11 : drv? ( block -- drv# ) offset @ + $1000 / ; -12 -13 : drvinit noop ; -14 : drv0 0 drive ; : drv1 1 drive ; -15 -Screen 128 not modified - 0 \ readsector writesector cas201301 - 1 - 2 Code rwabs ( r/wf adr rec# -- flag ) - 3 .l FP A7 -) move - 4 .w SP )+ D0 move SP )+ D6 move D6 reg) A0 lea - 5 SP )+ D1 move 2 D1 addq - 6 (drv R#) A7 -) move \ Drivenumber - 7 D0 A7 -) move \ rec# - 8 2 # A7 -) move \ number sectors - 9 .l A0 A7 -) move \ Address -10 .w D1 A7 -) move \ r/w flag -11 4 # A7 -) move \ function number -12 $0D trap $0E # A7 adda .l A7 )+ FP move -13 .w D0 SP -) move \ error flag -14 Next end-code -15 -Screen 129 not modified - 0 \ diskchange? 09nov86we - 1 - 2 | Code mediach? ( -- flag ) - 3 .w (drv R#) A7 -) move 9 # A7 -) move $0D trap 4 A7 addq - 4 D0 SP -) move Next end-code - 5 - 6 | Code getblocks ( -- n ) - 7 .w (drv R#) A7 -) move 7 # A7 -) move $0D trap 4 A7 addq - 8 D0 A0 move .w $0E # A0 adda A0 ) D0 move D0 SP -) move - 9 Next end-code -10 -11 -12 -13 -14 -15 -Screen 130 not modified - 0 \ STr/w 10sep86we - 1 - 2 : STr/w ( adr blk file r/wf -- flag ) - 3 swap abort" no file" - 4 1 xor -rot $1000 /mod dup (drv ! - 5 1 u> IF . ." beyond capacity" nip exit THEN - 6 mediach? IF getblocks (blk/drv (drv @ 2* + ! THEN - 7 dup blk/drv > IF drop 2drop true - 8 ELSE 9 + 2* rwabs THEN ; - 9 -10 ' STr/w Is r/w -11 -12 -13 -14 -15 -Screen 131 not modified - 0 \ Basepage (TOS PRG Header) cas201301 - 1 - 2 $601A , \ BRA to start of PGM - 3 - 4 here $1A allot $1A erase \ clear basepage info - 5 - 6 Assembler - 7 - 8 .l A7 A5 move 4 A5 D) A5 move \ start basepage - 9 $1.0600 # D0 move D0 D1 move \ store size of forth and -10 A5 D1 add .w $FFFE D1 andi .l D1 A7 move \ stack -11 D0 A7 -) move A5 A7 -) move .w A7 -) clr -12 $4A # A7 -) move 1 trap $0C # A7 adda \ mshrink -13 $100 $1C - # A5 adda A5 FP lmove \ FP to start of Forth -14 -15 -Screen 132 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/FORTH83.fth b/sources/AtariST/FORTH83.fth new file mode 100644 index 0000000..eee511b --- /dev/null +++ b/sources/AtariST/FORTH83.fth @@ -0,0 +1,2261 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Volksforth System - Sourcecode *** cas201301 + +This file contains the full sourcecode for the volksFORTH-83 +kernal. + +The source is compiled using the volksForth target compiler. The +source contains instructions for the target compiler that will +not end up in the final Forth system. + + +See the documentation on http://fossil.forth-ev.de/volksforth +for information on how to compile a new Forth kernel from +the source. + + + +\ *** Block No. 1 Hexblock 1 +\ Atari 520 ST Forth loadscreen cas201301 +\ volksFORTH-83 was developed by K. Schleisiek, B. Pennemann +\ G. Rehfeld & D. Weineck +\ Atari ST - Version by D. Weineck +\ Atari ST/STE/TT/Falcon/FireBee Version by C. Strotmann + +Onlyforth + + 0 dup displace ! +Target definitions here! + + $82 +load + 1 $76 +thru + +cr .unresolved ' .blk is .status + +\ *** Block No. 2 Hexblock 2 +\ FORTH Preamble and ID cas201301 + +Assembler +0 FP D) jmp here 2- >label >cold +0 FP D) jmp here 2- >label >restart +here dup origin! +\ Initial cold-start values for user variables + +0 # D6 move D6 reg) jmp \ Fr multitasker +$100 allot + +| Create logo ," volksFORTH-83 rev. 3.85.1" + + + + +\ *** Block No. 3 Hexblock 3 +\ Assembler Labels & Macros Next cas201301 + +Compiler Assembler also definitions + +H : Next .w IP )+ D7 move \ D7 contains cfa + D7 reg) D6 move \ D6 contains cfa@ + D6 reg) jmp .w \ jump to cfa@ + there Tnext-link H @ T , H Tnext-link ! ; + +Target + + + + + + +\ *** Block No. 4 Hexblock 4 +\ recover noop 06sep86we + +Create recover Assembler + .l A7 )+ D7 move FP IP suba .w IP RP -) move + .l D7 IP move 0 D7 moveq Next end-code + +Compiler Assembler also definitions + +H : ;c: 0 T recover R#) jsr end-code ] H ; + +Target + +Code noop Next end-code + + + +\ *** Block No. 5 Hexblock 5 +\ User Variables 14sep86we + +Constant origin &10 uallot drop \ For multitasker +User s0 +User r0 +User dp +User offset 0 offset ! +User base $10 base ! +User output +User input +User errorhandler \ pointer for abort" -code +User voc-link +User udp \ points to next free addr in User +User next-link \ points to next Next + + +\ *** Block No. 6 Hexblock 6 +\ end-trace 11sep86we + +Variable UP + +Label fnext IP )+ D7 move D7 reg) D6 move D6 reg) jmp + +Code end-trace + fnext # D6 move .l D6 reg) A0 lea A0 D5 move + .w UP R#) D6 move .l user' next-link D6 FP DI) D6 .w move + BEGIN .l D6 reg) A1 lea .w D6 tst 0<> + WHILE .w &10 # A1 suba .l D5 A0 move + A0 )+ A1 )+ move A0 )+ A1 )+ move + .w 2 A1 addq A1 ) D6 move + REPEAT fnext bra end-code + + +\ *** Block No. 7 Hexblock 7 +\ manipulate system pointers 09sep86we + +Code sp@ ( -- addr ) .l SP D6 move FP D6 sub + .w D6 SP -) move Next end-code + +Code sp! ( addr -- ) SP )+ D6 move $FFFE D6 andi + D6 reg) SP lea Next end-code + +Code up@ ( -- addr ) UP R#) SP -) move Next end-code + +Code up! ( addr -- ) SP )+ D0 move $FFFE D0 andi + D6 UP R#) move Next end-code + +Code forthstart ( -- laddr ) .l FP SP -) move Next end-code + + +\ *** Block No. 8 Hexblock 8 +\ manipulate returnstack 05sep86we + +Code rp@ ( -- addr ) .l RP D6 move FP D6 sub + .w D6 SP -) move Next end-code + +Code rp! ( addr -- ) SP )+ D6 move $FFFE D6 andi + D6 reg) RP lea Next end-code + +Code >r ( 16b -- ) SP )+ RP -) move + Next end-code restrict + +Code r> ( -- 16b ) RP )+ SP -) move + Next end-code restrict + + + +\ *** Block No. 9 Hexblock 9 +\ r@ rdrop exit unnest ?exit 04sep86we + +Code r@ ( -- 16b ) RP ) SP -) move Next end-code + +Code rdrop 2 RP addq Next end-code restrict + +Code exit RP )+ D7 move .l D7 IP move + FP IP adda Next end-code + +Code unnest RP )+ D7 move .l D7 IP move + FP IP adda Next end-code + +Code ?exit ( flag -- ) SP )+ tst 0<> IF RP )+ D7 move + .l D7 IP move FP IP adda THEN + Next end-code +\\ : ?exit ( flag -- ) IF rdrop THEN ; +\ *** Block No. 10 Hexblock A +\ execute perform 04sep86we + +Code execute ( cfa -- ) + SP )+ D7 move D7 reg) D6 move .l D6 reg) jmp end-code + +: perform ( addr -- ) @ execute ; + + + + + + + + + + +\ *** Block No. 11 Hexblock B +\ c@ c! ctoggle 04sep86we + +Code c@ ( addr -- 8b ) + SP )+ D6 move D6 reg) A0 lea 0 D0 moveq + .b A0 ) D0 move .w D0 SP -) move Next end-code + +Code c! ( 16b addr -- ) + SP )+ D6 move D6 reg) A0 lea + SP )+ D0 move .b D0 A0 ) move Next end-code + +: ctoggle ( 8b addr --) under c@ xor swap c! ; + + + + + +\ *** Block No. 12 Hexblock C +\ @ ! 2@ 2! 04sep86we + +Code @ ( addr -- 16b ) + SP )+ D6 move D6 reg) A0 lea + .b 1 A0 D) SP -) move A0 ) SP -) move + Next end-code + +Code ! ( 16b addr -- ) + SP )+ D6 move D6 reg) A0 lea + .b SP )+ A0 )+ move SP )+ A0 )+ move + Next end-code + + + + + +\ *** Block No. 13 Hexblock D +\ 2@ 2! 04sep86we + +Code 2@ ( addr -- 32b ) + SP )+ D6 move D6 reg) A0 lea + .b 3 A0 D) SP -) move 2 A0 D) SP -) move + 1 A0 D) SP -) move A0 ) SP -) move Next end-code + +Code 2! ( 32b addr -- ) + SP )+ D6 move D6 reg) A0 lea + .b SP )+ A0 )+ move SP )+ A0 )+ move + SP )+ A0 )+ move SP )+ A0 )+ move Next end-code + +\\ +: 2@ ( adr -- 32b) dup 2+ @ swap @ ; +: 2! ( 32b adr --) rot over 2+ ! ! ; + +\ *** Block No. 14 Hexblock E +\ lc@ lc! l@ l! 24may86we + +Code lc@ ( laddr -- 8b ) + .l SP )+ A0 move 0 D0 moveq .b A0 ) D0 move + .w D0 SP -) move Next end-code +Code lc! ( 8b laddr -- ) + .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move + Next end-code + +Code l@ ( laddr -- n ) + .l SP )+ A0 move .b A0 )+ D0 move .w 8 # D0 lsl + .b A0 ) D0 move .w D0 SP -) move Next end-code +Code l! ( n laddr -- ) + .l SP )+ A0 move .w SP )+ D0 move .b D0 1 A0 D) move + .w 8 # D0 lsr .b D0 A0 ) move Next end-code + +\ *** Block No. 15 Hexblock F +\ lcmove 10sep86we + +Code lcmove ( fromladdr toladdr count -- ) + SP )+ D0 move .l SP )+ A0 move SP )+ A1 move + .w D0 tst 0<> IF 1 D0 subq + D0 DO .b A1 )+ A0 )+ move LOOP THEN Next end-code + + + + + + + + + + +\ *** Block No. 16 Hexblock 10 +\ l2@ l2! cas201301 + +Code l2@ ( laddr -- 32bit ) + .l SP )+ A0 move .b A0 )+ D0 move .l 8 # D0 lsl + .b A0 )+ D0 move .l 8 # D0 lsl .b A0 )+ D0 move .l 8 # D0 lsl + .b A0 ) D0 move .l D0 SP -) move Next end-code + +Code l2! ( 32bit laddr -- ) + .l SP )+ A0 move SP )+ D0 move + .l 8 # D0 rol .b D0 A0 )+ move .l 8 # D0 rol .b D0 A0 )+ move + .l 8 # D0 rol .b D0 A0 )+ move .l 8 # D0 rol .b D0 A0 )+ move + Next end-code + +Code ln+! ( n laddr -- ) \ only even addresses allowed + .l SP )+ A0 move A0 ) A1 move .w SP )+ A1 adda + .l A1 A0 ) move Next end-code +\ *** Block No. 17 Hexblock 11 +\ +! drop swap 05sep86we + +Code +! ( n addr -- ) + SP )+ D6 move D6 reg) A0 lea 2 A0 addq 2 SP addq + 4 # move>ccr .b SP -) A0 -) addx SP -) A0 -) addx + .w 2 SP addq Next end-code + + +Code drop ( 16b -- ) 2 SP addq Next end-code + +Code swap ( 16b1 16b2 -- 16b2 16b1 ) + .l SP ) D0 move D0 swap D0 SP ) move Next end-code + + + + +\ *** Block No. 18 Hexblock 12 +\ dup ?dup 20mar86we + +Code dup ( 16b -- 16b 16b ) SP ) SP -) move Next end-code + +Code ?dup ( 16b -- 16b 16b / false ) + SP ) tst 0<> IF SP ) SP -) move THEN Next end-code + + + +\\ +: ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; + + + + + +\ *** Block No. 19 Hexblock 13 +\ over rot nip under bp 11 oct 86 + +Code over ( 16b1 16b2 - 16b1 16b3 16b1 ) + 2 SP D) SP -) move Next end-code +Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) + SP )+ D1 move SP )+ D2 move SP ) D0 move + D2 SP ) move D1 SP -) move D0 SP -) move + Next end-code +Code nip ( 16b1 16b2 -- 16b2 ) + SP )+ SP ) move Next end-code +Code under ( 16b1 16b2 - 16b2 16b1 16b2 ) + .l SP ) D0 move D0 swap D0 SP ) move .w D0 SP -) move + Next end-code +\\ +: nip ( 16b1 16b2 -- 16b2) swap drop ; +: under ( 16b1 16b2 -- 16b2 16b1 16b2) swap over ; +\ *** Block No. 20 Hexblock 14 +\ -rot nip pick roll bp 11 oct 86 + +Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + SP )+ D2 move SP )+ D0 move SP ) D1 move + D2 SP ) move D1 SP -) move D0 SP -) move + Next end-code +Code pick ( n -- 16b.n ) + .l D0 clr .w SP )+ D0 move D0 D0 add + 0 D0 SP DI) SP -) move Next end-code +: roll ( n -- ) + dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; +: -roll ( n -- ) >r dup sp@ dup 2+ + dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; +\\ +: pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; +: -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; +\ *** Block No. 21 Hexblock 15 +\ double word stack manip. bp 12oct86 + +Code 2swap ( 32b1 32b2 -- 32b2 32b1 ) + .l SP )+ D0 move SP ) D1 move D0 SP ) move + D1 SP -) move Next end-code +Code 2dup ( 32b -- 32b 32b ) + .l SP ) SP -) move Next end-code +Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) + .l 4 SP D) SP -) move Next end-code + +Code 2drop ( 32b -- ) 4 SP addq Next end-code + +\\ : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; + : 2drop ( 32b -- ) drop drop ; + : 2dup ( 32b -- 32b 32b) over over ; + +\ *** Block No. 22 Hexblock 16 +\ + and or xor not 19mar86we + +Code + ( n1 n2 -- n3 ) + SP )+ D0 move D0 SP ) add Next end-code + +Code or ( 16b1 16b2 -- 16b3 ) + SP )+ D0 move D0 SP ) or Next end-code + +Code and ( 16b1 16b2 -- 16b3 ) + SP )+ D0 move D0 SP ) and Next end-code + +Code xor ( 16b1 16b2 -- 16b3 ) + SP )+ D0 move D0 SP ) eor Next end-code + +Code not ( 16b1 -- 16b2 ) SP ) not Next end-code + +\ *** Block No. 23 Hexblock 17 +\ - negate 19mar86we + +Code - ( n1 n2 -- n3 ) + SP )+ D0 move D0 SP ) sub Next end-code + +Code negate ( n1 -- n2 ) SP ) neg Next end-code + + + + + + + + + + +\ *** Block No. 24 Hexblock 18 +\ double arithmetic cas201301 + +Code dnegate ( d1 -- -d1 ) .l SP ) neg Next end-code + +Code d+ ( d1 d2 -- d3 ) + .l SP )+ D0 move D0 SP ) add Next end-code + +Code d- ( d1 d2 -- d1-d2 ) + .l SP )+ D0 move D0 SP ) sub Next end-code + +Code d* ( d1 d2 -- d1*d2 ) + .l SP )+ D0 move SP )+ D1 move + D0 D2 move D0 D3 move D3 swap D1 D4 move D4 swap + D1 D0 mulu D3 D1 mulu D4 D2 mulu + D0 swap .w D1 D0 add .w D2 D0 add .l D0 swap + D0 SP -) move Next end-code +\ *** Block No. 25 Hexblock 19 +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 18nov86we + +Code 1+ ( n1 -- n2 ) 1 SP ) addq Next end-code +Code 2+ ( n1 -- n2 ) 2 SP ) addq Next end-code +Code 3+ ( n1 -- n2 ) 3 SP ) addq Next end-code +Code 4+ ( n1 -- n2 ) 4 SP ) addq Next end-code +| Code 6+ ( n1 -- n2 ) 6 SP ) addq Next end-code +Code 1- ( n1 -- n2 ) 1 SP ) subq Next end-code +Code 2- ( n1 -- n2 ) 2 SP ) subq Next end-code +Code 4- ( n1 -- n2 ) 4 SP ) subq Next end-code + + +: on ( addr -- ) true swap ! ; +: off ( addr -- ) false swap ! ; + + +\ *** Block No. 26 Hexblock 1A +\ number Constants bp 18nov86we + +Code true ( -- -1 ) -1 # SP -) move Next end-code +Code false ( -- 0 ) 0 # SP -) move Next end-code +Code 1 ( -- 1 ) 1 # SP -) move Next end-code +Code 2 ( -- 2 ) 2 # SP -) move Next end-code +Code 3 ( -- 3 ) 3 # SP -) move Next end-code +Code 4 ( -- 4 ) 4 # SP -) move Next end-code + +' true Alias -1 ' false Alias 0 + + + + + + +\ *** Block No. 27 Hexblock 1B +\ words for number literals 19mar86we + +Code lit ( -- 16b ) IP )+ SP -) move Next end-code + +: Literal ( 16b -- ) compile lit , ; immediate restrict + + + + + + + + + + + +\ *** Block No. 28 Hexblock 1C +\ comparision code words 19mar86we + +Label yes true # SP ) move Next Label no SP ) clr Next + +Code 0< ( n -- flag ) SP ) tst yes bmi no bra end-code + +Code 0= ( 16b -- flag ) SP ) tst yes beq no bra end-code + +Code < ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp + yes bgt no bra end-code + +Code u< ( u1 u2 -- flag ) SP )+ D0 move SP ) D0 cmp + yes bhi no bra end-code + +: uwithin ( u1 [low up[ -- flag ) + rot under u> -rot u> not and ; +\ *** Block No. 29 Hexblock 1D +\ comparision code words 25mar86we + +Code > ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp + yes blt no bra end-code + +Code 0> ( n -- flag ) SP ) tst yes bgt no bra + end-code + +Code 0<> ( n -- flag ) SP ) tst yes bne no bra + end-code + +Code u> ( u1 u2 -- flag ) SP )+ D0 move SP ) D1 move + D0 D1 cmp yes bhi no bra + end-code +Code = ( n1 n2 -- flag ) SP )+ D0 move SP ) D0 cmp + yes beq no bra end-code +\ *** Block No. 30 Hexblock 1E +\ comparision words 20mar86we + +: d0= ( d -- flag ) or 0= ; +: d= ( d1 d2 -- flag ) dnegate d+ d0= ; +: d< ( d1 d2 -- flag ) rot 2dup - IF > nip nip + ELSE 2drop u< THEN ; + + +\\ +: 0< 8000 and 0<> ; +: > ( n1 n2 -- flag ) swap < ; +: 0> ( n -- flag ) negate 0< ; +: 0<> ( n -- flag ) 0= not ; +: u> ( u1 u2 -- flag ) swap u< ; +: = ( n1 n2 -- flag ) - 0= ; + +\ *** Block No. 31 Hexblock 1F +\ min max umax umin extend dabs abs 18nov86we + +| Code minimax ( n1 n2 f -- n ) + SP )+ tst 0<> IF SP ) 2 SP D) move THEN 2 SP addq + Next end-code + +: min ( n1 n2 -- n3 ) 2dup > minimax ; +: max ( n1 n2 -- n3 ) 2dup < minimax ; +: umax ( u1 u2 -- u3 ) 2dup u< minimax ; +: umin ( u1 u2 -- u3 ) 2dup u> minimax ; +: extend ( n -- d ) dup 0< ; +: dabs ( d -- ud ) extend IF dnegate THEN ; +: abs ( n -- u) extend IF negate THEN ; +\\ +: minimax ( n1 n2 flag -- n3 ) + rdrop IF swap THEN drop ; +\ *** Block No. 32 Hexblock 20 +\ loop primitives 19mar86we + +| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; + +: (do ( limit start -- ) over - dodo ; restrict +: (?do ( limit start -- ) over - ?dup IF dodo THEN + r> dup @ + >r drop ; restrict + +: bounds ( start count -- limit start ) over + swap ; + +Code endloop 6 RP addq Next end-code restrict + + + +\\ dodo puts "index | limit | adr.of.DO" on return-stack + +\ *** Block No. 33 Hexblock 21 +\ (loop (+loop 04sep86we + +Code (loop + 1 RP ) addq + CC IF 4 RP D) D6 move D6 reg) IP lea THEN + Next end-code restrict + +Code (+loop + SP )+ D0 move D0 D1 move D0 RP ) add + 1 # D1 roxr D0 D1 eor + 0>= IF 4 RP D) D6 move D6 reg) IP lea THEN + Next end-code restrict + + + + +\ *** Block No. 34 Hexblock 22 +\ loop indices 20mar86we + +Code I ( -- n ) + RP ) D0 move 2 RP D) D0 add D0 SP -) move + Next end-code + +Code J ( -- n ) + 6 RP D) D0 move 8 RP D) D0 add D0 SP -) move + Next end-code + + + + + + + +\ *** Block No. 35 Hexblock 23 +\ branch ?branch 06sep86we + +Code branch +Label bran1 IP ) IP adda Next end-code + +Code ?branch ( fl -- ) SP )+ tst bran1 beq 2 IP addq + Next end-code + + + + + + + + + +\ *** Block No. 36 Hexblock 24 +\ resolve loops and branches 19mar86we + +: >mark ( -- addr ) here 0 , ; +: >resolve ( addr -- ) here over - swap ! ; +: mark 1 ; immediate restrict +: THEN abs 1 ?pairs >resolve ; immediate restrict +: ELSE 1 ?pairs compile branch >mark swap + >resolve -1 ; immediate restrict +: BEGIN mark + -2 2swap ; immediate restrict +| : (reptil resolve REPEAT ; +: REPEAT 2 ?pairs compile branch (reptil ; + immediate restrict +: UNTIL 2 ?pairs compile ?branch (reptil ; + immediate restrict + +\ *** Block No. 39 Hexblock 27 +\ Loops 24nov85we + +: DO compile (do >mark 3 ; immediate restrict +: ?DO compile (?do >mark 3 ; immediate restrict +: LOOP 3 ?pairs compile (loop compile endloop >resolve ; + immediate restrict +: +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; + immediate restrict +: LEAVE endloop r> 2- dup @ + >r ; restrict + + +\\ Returnstack: calladr | index limit | adr of DO + + + + +\ *** Block No. 40 Hexblock 28 +\ Multiplication 18nov86we + +Code um* ( u1 u2 -- ud ) + SP )+ D0 move SP )+ D0 mulu .l D0 SP -) move + Next end-code + +Code * ( n1 n2 -- n ) + SP )+ D0 move SP )+ D0 mulu D0 SP -) move + Next end-code + +: m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN + swap dup 0< IF negate r> not >r THEN + um* r> IF dnegate THEN ; + +Code 2* ( n -- 2*n ) SP ) asl Next end-code +Code 2/ ( n -- n/2 ) SP ) asr Next end-code +\ *** Block No. 41 Hexblock 29 +\ Division cas201301 + +label divovl ;c: true abort" division overflow" ; + +Label (m/mod \ d(D2) n(D0) -- mod quot + .l A7 )+ A0 move \ get addr from stack + .w D0 D1 move D0 D3 move + .l D1 ext + D2 D1 eor 0< IF D2 neg .w D0 neg THEN + D0 D2 divs divovl bvs + .w D2 D0 move D2 swap .l D1 tst + 0< IF .w D2 tst 0<> IF 1 D0 subq \ quot = quot - 1 + D3 D2 sub D2 neg \ rem = n - rem + THEN THEN + .w D2 SP -) move D0 SP -) move + .l A0 ) jmp \ adr. from /0-TRAPS leads to a GEM crash +\ *** Block No. 42 Hexblock 2A +\ um/mod m/mod /mod 18nov86we + +Code um/mod ( d1 n1 -- rem quot ) + SP )+ D0 move .l SP )+ D1 move D0 D1 divu + divovl bvs + D1 swap D1 SP -) move Next end-code + +Code m/mod ( d n -- mod quot ) + SP )+ D0 move .l SP )+ D2 move (m/mod bsr Next end-code + +Code /mod ( n1 n2 -- mod quot ) + SP )+ D0 move SP )+ D2 move .l D2 ext + (m/mod bsr Next end-code + + + +\ *** Block No. 43 Hexblock 2B +\ / mod 18nov86we + +Code / ( n1 n2 -- quot ) + SP )+ D0 move SP )+ D2 move .l D2 ext + .w D0 D1 move D2 D1 eor \ SHORT way ! + 0< IF (m/mod bsr SP )+ SP ) move Next THEN + D0 D2 divs divovl bvs D2 SP -) move Next end-code + +Code mod ( n1 n2 -- mod ) + SP )+ D0 move SP )+ D2 move .l D2 ext + .w D0 D1 move D2 D1 eor \ SHORT way ! + 0< IF (m/mod bsr 2 SP addq Next THEN + D0 D2 divs divovl bvs + D2 swap D2 SP -) move Next end-code + + +\ *** Block No. 44 Hexblock 2C +\ */mod */ u/mod ud/mod 18nov86we + +: */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; +: */ ( n1 n2 n3 -- quot ) */mod nip ; +: u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; +: ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r + um/mod r> ; + +\\ +: /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; +: / ( n1 n2 -- quot ) /mod nip ; +: mod ( n1 n2 -- rem ) /mod drop ; +: m/mod ( d n -- mod quot ) + dup >r abs over 0< IF under + swap THEN um/mod r@ 0< + IF negate over IF swap r@ + swap 1- THEN THEN + rdrop ; +\ *** Block No. 45 Hexblock 2D +\ cmove cmove> 04sep86we + +Code cmove ( from to count -- ) + SP )+ D0 move SP )+ D6 move D6 reg) A0 lea + SP )+ D6 move D6 reg) A1 lea + D0 tst 0<> IF 1 D0 subq + D0 DO .b A1 )+ A0 )+ move LOOP THEN + Next end-code + +Code cmove> ( from to count -- ) + SP )+ D0 move + SP )+ D6 move D0 D6 add D6 reg) A0 lea + SP )+ D6 move D0 D6 add D6 reg) A1 lea + D0 tst 0<> IF 1 D0 subq + D0 DO .b A1 -) A0 -) move LOOP THEN + Next end-code +\ *** Block No. 46 Hexblock 2E +\ move place count bp 11 oct 86 + +: move ( from to quan -- ) + >r 2dup u< IF r> cmove> exit THEN r> cmove ; + +: place ( addr len to --) + over >r rot over 1+ r> move c! ; + +Code count ( adr -- adr+1 len ) + SP ) D6 move D6 reg) A0 lea + D0 clr .b A0 )+ D0 move .w 1 SP ) addq D0 SP -) move + Next end-code + + +\\ +: count ( adr -- adr+1 len ) dup 1+ swap c@ ; +\ *** Block No. 47 Hexblock 2F +\ fill erase bp 11 oct 86 + +Code fill ( addr quan 8b -- ) + SP )+ D0 move SP )+ D1 move + SP )+ D6 move D6 reg) A0 lea + D1 tst 0<> IF + 1 D1 subq D1 DO .b D0 A0 )+ move LOOP THEN + Next end-code + +: erase ( addr quan --) 0 fill ; + + +\\ +: fill ( addr quan 8b -- ) + swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN + 2drop ; +\ *** Block No. 48 Hexblock 30 +\ , c, 08sep86we + +Code , ( 8b -- ) UP R#) D6 move + .l user' dp D6 FP DI) D6 .w move D6 reg) A0 lea + .b SP )+ A0 )+ move SP )+ A0 )+ move + .w UP R#) D6 move .l 2 user' dp D6 FP DI) .w addq + Next end-code + +Code c, ( 8b -- ) UP R#) D6 move + .l user' dp D6 FP DI) D6 .w move D6 reg) A0 lea + SP )+ D0 move .b D0 A0 )+ move + .w UP R#) D6 move .l 1 user' dp D6 FP DI) .w addq + Next end-code +\\ +: , ( 16b -- ) here ! 2 allot ; +: c, ( 8b -- ) here c! 1 allot ; +\ *** Block No. 49 Hexblock 31 +\ allot pad compile 08sep86we + +Code here ( -- addr ) + UP R#) D6 move .l user' dp D6 FP DI) SP -) .w move + Next end-code + +Code allot ( n -- ) UP R#) D6 move SP )+ D0 move + D0 .l user' dp D6 FP DI) .w add Next end-code + +: pad ( -- addr ) here $42 + ; + +: compile r> dup 2+ >r @ , ; restrict +\\ +: here ( -- addr ) dp @ ; +: allot ( n -- ) + dup here + up@ u> abort" Dictionary full" dp +! ; +\ *** Block No. 50 Hexblock 32 +\ input strings 25mar86we + +Variable #tib 0 #tib ! +Variable >tib here >tib ! &80 allot +Variable >in 0 >in ! +Variable blk 0 blk ! +Variable span 0 span ! + +: tib ( -- addr ) >tib @ ; + +: query tib &80 expect span @ #tib ! + >in off blk off ; + + + + +\ *** Block No. 51 Hexblock 33 +\ scan skip /string 16nov85we + +: /string ( addr0 len0 +n - addr1 len1 ) + over umin rot over + -rot - ; + + + + +\\ +: scan ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap + REPEAT rdrop ; + +: skip ( addr len del -- addr1 len1 ) >r + BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap + REPEAT rdrop ; +\ *** Block No. 52 Hexblock 34 +\ skip scan 04sep86we + +Label done .l FP A0 suba .w A0 SP -) move D1 SP -) move Next +Code skip ( addr len del -- addr1 len1 ) + SP )+ D0 move SP )+ D1 move 1 D1 addq + SP )+ D6 move D6 reg) A0 lea + BEGIN 1 D1 subq 0<> + WHILE .b A0 ) D2 move D2 D0 cmp done bne .w 1 A0 addq + REPEAT done bra end-code + +Code scan ( addr len chr -- addr1 len1 ) + SP )+ D0 move SP )+ D1 move 1 D1 addq + SP )+ D6 move D6 reg) A0 lea + BEGIN 1 D1 subq 0<> + WHILE .b A0 ) D2 move D2 D0 cmp done beq .w 1 A0 addq + REPEAT done bra end-code +\ *** Block No. 53 Hexblock 35 +\ convert to upper case 04sep86we + +Label umlaut + Ascii „ c, Ascii ” c, Ascii c, + Ascii Ž c, Ascii ™ c, Ascii š c, + +Label (capital ( D1 -> D1 ) + D1 7 # btst 0= IF + .b Ascii a D1 cmpi >= IF Ascii z D1 cmpi + <= IF bl D1 subi THEN THEN rts + THEN umlaut R#) A1 lea + 2 D2 moveq D2 DO .b A1 ) D1 cmp + 0= IF .w 3 A1 addq .b A1 ) D1 move rts THEN + .w 1 A1 addq LOOP rts end-code + + +\ *** Block No. 54 Hexblock 36 +\ capital capitalize bp 11 oct 86 + +Code capital ( char -- char' ) + SP ) D1 move (capital bsr D1 SP ) move Next end-code + +Code capitalize ( string -- string ) + SP ) D6 move D6 reg) A0 lea + D0 clr .b A0 )+ D0 move + 0<> IF 1 D0 subq D0 DO + A0 ) D1 move (capital bsr D1 A0 )+ move + LOOP THEN Next end-code + + +\\ +: capitalize ( string -- string) + dup count bounds ?DO I c@ capital I c! LOOP ; +\ *** Block No. 55 Hexblock 37 +\ (word bp 11 oct 86 + +Code (word ( char adr0 len0 -- addr ) + D1 clr SP )+ D0 move D0 D4 move + SP )+ D6 move D6 reg) A0 lea SP ) D2 move + >in R#) D3 move D3 A0 adda D3 D0 sub + <= IF D4 >in R#) move + ELSE 1 D0 addq BEGIN 1 D0 subq 0<> + WHILE .b A0 ) D2 cmp 0= + WHILE .l 1 A0 addq REPEAT THEN + A0 A1 move .w 1 D0 addq + BEGIN .w 1 D0 subq 0<> + WHILE .b A0 ) D2 cmp 0<> + WHILE .w 1 A0 addq 1 D1 addq REPEAT THEN + .w D1 tst 0<> IF 1 A0 addq THEN + .l FP A0 suba D6 A0 suba .w A0 >in R#) move THEN +\ *** Block No. 56 Hexblock 38 +\ (word Part2 bp 11 oct 86 + + UP R#) D6 move .l user' dp D6 FP DI) D6 .w move + D6 reg) A0 lea D6 SP ) move + .b D1 A0 )+ move .w 1 D1 subq + 0>= IF D1 DO .b A1 )+ A0 )+ move LOOP THEN + bl # A0 ) move Next end-code + + +\\ +: word ( char -- addr) + >r source over swap >in @ /string + r@ skip over swap r> scan >r + rot over swap - r> 0<> - + >in ! over - here dup >r place + bl r@ count + c! r> ; +\ *** Block No. 57 Hexblock 39 +\ even source word parse name bp 11oct86 + +: even ( addr -- addr1 ) dup 1 and + ; + +Variable loadfile 0 loadfile ! + +: source ( -- addr len ) blk @ ?dup + IF loadfile @ (block b/blk exit THEN tib #tib @ ; + +: word ( char -- addr ) source (word ; + +: parse ( char -- addr len ) + >r source >in @ /string over swap r> scan >r + over - dup r> 0<> - >in +! ; + +: name ( -- addr ) bl word capitalize exit ; +\ *** Block No. 58 Hexblock 3A +\ state Ascii ," (" " 15jun86we + +Variable state 0 state ! + +: Ascii ( char -- n ) + bl word 1+ c@ state @ IF [compile] Literal THEN ; + immediate + +: ," Ascii " parse here over 1+ allot place ; +: "lit r> r> under count + even >r >r ; restrict +: (" "lit ; restrict +: " compile (" ," align ; immediate restrict + + + + +\ *** Block No. 59 Hexblock 3B +\ ." ( .( \ \\ hex decimal 25mar86we + +: (." "lit count type ; restrict +: ." compile (." ," align ; immediate restrict +: ( ascii ) parse 2drop ; immediate +: .( ascii ) parse type ; immediate +: \ >in @ c/l / 1+ c/l * >in ! ; immediate +: \\ b/blk >in ! ; immediate +: \needs name find nip IF [compile] \ THEN ; + +: hex $10 base ! ; +: decimal &10 base ! ; + + + + +\ *** Block No. 60 Hexblock 3C +\ number conversion: digit? cas201301 + +| Variable ptr \ points into string + +Label fail SP ) clr Next +Code digit? ( char -- n true : false ) + UP R#) D6 move .l user' base D6 FP DI) D0 .w move + SP ) D1 move .b Ascii 0 D1 subi fail bmi &10 D1 cmpi + 0>= IF $11 D1 cmpi fail bmi 7 D1 subq THEN + D0 D1 cmp fail bpl .w D1 SP ) move true # SP -) move + Next end-code +\\ +: digit? ( char -- digit true/ false ) + Ascii 0 - dup 9 u> IF [ Ascii A Ascii 9 - 1- ] Literal - + dup 9 u> IF [ 2swap ( unstructured ) ] THEN + base @ over u> ?dup ?exit THEN drop false ; +\ *** Block No. 61 Hexblock 3D +\ number conversion: accumulate convert 11sep86we + +Code accumulate ( +d0 addr digit -- +d1 addr ) + 0 D0 moveq SP )+ D0 move + 2 SP D) D1 move 4 SP D) D2 move + UP R#) D6 move .l user' base D6 FP DI) D3 .w move + D3 D2 mulu D3 D1 mulu .l D1 swap .w D1 clr + .l D2 D1 add D0 D1 add D1 2 SP D) move Next end-code + +: convert ( +d1 addr0 -- +d2 addr2 ) + 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; + + +\\ +: accumulate ( +d0 adr digit - +d1 adr ) + swap >r swap base @ um* drop rot base @ um* d+ r> ; +\ *** Block No. 62 Hexblock 3E +\ number conversion: end? char previous 25mar86we + +| : end? ( -- flag ) ptr @ 0= ; +| : char ( addr0 -- addr1 char ) count -1 ptr +! ; +| : previous ( addr0 -- addr0 char ) 1- count ; + + + + + + + + + + + +\ *** Block No. 63 Hexblock 3F +\ number conversion: ?nonum punctuation? 25mar86we + +| : ?nonum ( flag -- exit if true ) + IF rdrop 2drop drop rdrop false THEN ; + +| : punctuation? ( char -- flag ) + Ascii , over = swap Ascii . = or ; + + + + + + + + + +\ *** Block No. 64 Hexblock 40 +\ number conversion: fixbase? 25mar86we + +| : fixbase? ( char - char false / newbase true ) + Ascii & case? IF &10 true exit THEN + Ascii $ case? IF $10 true exit THEN + Ascii H case? IF $10 true exit THEN + Ascii % case? IF 2 true exit THEN false ; + + + + + + + + + +\ *** Block No. 65 Hexblock 41 +\ number conversion: ?num ?dpl 25mar86we + +Variable dpl -1 dpl ! + +| : ?num ( flag -- exit if true ) + IF rdrop drop r> IF dnegate THEN + rot drop dpl @ 1+ ?dup ?exit drop true THEN ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + + + + + + + +\ *** Block No. 66 Hexblock 42 +\ (number number 11sep86we + +: number? ( string - string false / n 0< / d 0> ) + base push dup count ptr ! dpl on + 0 >r ( +sign) 0 0 rot end? ?nonum char + Ascii - case? IF rdrop true >r end? ?nonum char THEN + fixbase? IF base ! end? ?nonum char THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL + previous punctuation? 0= ?nonum dpl off end? ?num char + REPEAT ; + +: number ( string -- d ) + number? ?dup 0= abort" ?" 0< IF extend THEN ; + + +\ *** Block No. 67 Hexblock 43 +\ hide reveal immediate restrict 24nov85we + +Variable last 0 last ! +| : last? ( -- false / acf true) last @ ?dup ; +: hide last? IF 2- @ current @ ! THEN ; +: reveal last? IF 2- current @ ! THEN ; +: Recursive reveal ; immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN drop ; + +: immediate $40 flag! ; +: restrict $80 flag! ; + + + +\ *** Block No. 68 Hexblock 44 +\ clearstack hallot heap heap? bp 11 oct 86 + +Code clearstack + UP R#) D6 move .l user' s0 D6 FP DI) D6 .w move + $FFFE D6 andi D6 reg) SP lea Next end-code \ muž Code + +: hallot ( quan -- ) s0 @ over - swap sp@ 2+ dup rot + dup 1 and ?dup IF over 0< IF negate THEN + THEN + - dup s0 ! 2 pick over - move clearstack s0 ! ; + +: heap ( -- addr ) s0 @ 6 + ; +: heap? ( addr -- flag ) heap up@ uwithin ; + +| : heapmove ( from -- from ) + dup here over - dup hallot + heap swap cmove heap over - last +! reveal ; +\ *** Block No. 69 Hexblock 45 +\ Does> ; 24sep86we + +Label (dodoes> + .l FP IP suba .w IP RP -) move A7 )+ IP lmove + 2 D7 addq D7 SP -) move Next end-code + +| : (;code r> last @ name> ! ; + +: Does> + compile (;code $4EAB , compile (dodoes> ; + immediate restrict + +\ Does> compiles (;code and JSR (doedoes> FP D) + + + +\ *** Block No. 70 Hexblock 46 +\ ?head | alignments warning exists? 15jun86we + +Variable ?head 0 ?head ! + +: | ?head @ ?exit -1 ?head ! ; + + +: align here 1 and allot ; +: halign heap 1 and hallot ; + +Variable warning 0 warning ! +| : exists? warning @ ?exit last @ current @ + (find nip IF space last @ .name ." exists " ?cr THEN ; + + + +\ *** Block No. 71 Hexblock 47 +\ Create 06sep86we + +: blk@ blk @ ; +Defer makeview ' blk@ Is makeview + +: Create + align here makeview , current @ @ , + name c@ dup 1 $20 uwithin not abort" invalid name" + here last ! 1+ allot align + exists? ?head @ + IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dp ! + ELSE drop THEN reveal 0 , + ;Code 2 D7 addq D7 SP -) move Next end-code + + +\ *** Block No. 72 Hexblock 48 +\ nfa? 04sep86we + +Code nfa? ( thread cfa -- nfa | false ) + SP )+ D2 move SP )+ D6 move D6 reg) A0 lea .w + BEGIN A0 ) D6 move 0= IF SP -) clr Next THEN + .l D6 reg) A0 lea 2 D6 addq D6 reg) A1 lea + .b A1 ) D0 move .w $1F D0 andi 1 D0 addq + D0 D1 move 1 D1 andi D1 D0 add D0 D6 add + .b A1 ) D0 move .w $20 D0 andi 0<> + IF D6 reg) D6 move THEN + D2 D6 cmp 0= UNTIL + .l FP A1 suba .w A1 SP -) move Next end-code + +\\ : nfa? ( thread cfa -- nfa / false) + >r BEGIN @ dup 0= IF rdrop exit THEN + dup 2+ name> r@ = UNTIL 2+ rdrop ; +\ *** Block No. 73 Hexblock 49 +\ >name name> >body .name 14sep86we + +: >name ( cfa -- nfa / false ) voc-link + BEGIN @ dup WHILE 2dup 4- swap nfa? + ?dup IF -rot 2drop exit THEN REPEAT nip ; + +| : (name> ( nfa -- cfa ) count $1F and + even ; + +: name> ( nfa -- cfa ) + dup (name> swap c@ $20 and IF @ THEN ; + +: >body ( cfa -- pfa ) 2+ ; + +: .name ( nfa -- ) + ?dup IF dup heap? IF ." |" THEN + count $1F and type ELSE ." ???" THEN space ; +\ *** Block No. 74 Hexblock 4A +\ : ; Constant Variable bp 12oct86 + +: Create: Create hide current @ context ! ] 0 ; + +: : Create: + ;Code .l FP IP suba .w IP RP -) move + .l 2 D7 FP DI) IP lea Next end-code + +: ; 0 ?pairs compile unnest [compile] [ reveal ; + immediate restrict + +: Constant Create , + ;Code .l 2 D7 FP DI) .w SP -) move Next end-code + +: 2Constant Create , , does> 2@ ; + +\ *** Block No. 75 Hexblock 4B +\ uallot User Alias bp 12oct86 + +: Variable Create 2 allot ; +: 2Variable Create 4 allot ; + +: uallot ( quan -- offset ) + dup udp @ + $FF u> abort" Userarea full" + udp @ swap udp +! ; + +: User Create udp @ 1 and udp +! 2 uallot c, + ;Code UP R#) D0 move 0 D1 moveq .l 2 D7 FP DI) .b D1 move + .w D1 D0 add D0 SP -) move Next end-code + +: Alias ( cfa -- ) + Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN (name> ! ; +\ *** Block No. 76 Hexblock 4C +\ vp current context also toss 19mar86we + +Create vp $10 allot Variable current + +: context ( -- addr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) vp 2+ context ; +\ "Only Forth also Assembler" gives +\ vp: countword = 6 | Only | Forth | Assembler | + +: also vp @ &10 > error" Vocabulary stack full" + context @ 2 vp +! context ! ; + +: toss vp @ IF -2 vp +! THEN ; + + +\ *** Block No. 77 Hexblock 4D +\ Vocabulary Forth Only Onlyforth 24nov85we + +: Vocabulary + Create 0 , 0 , here voc-link @ , voc-link ! + Does> context ! ; +\ | Name | Code | Thread | Coldthread | Voc-link | + +Vocabulary Forth +Vocabulary Only +] Does> [ Onlypatch ] 0 vp ! context ! also ; ' Only ! + +: Onlyforth Only Forth also definitions ; + + + + +\ *** Block No. 78 Hexblock 4E +\ definitions order words 24nov85we + +: definitions context @ current ! ; +| : .voc ( adr -- ) @ 2- >name .name ; +: order thru.vocstack DO I .voc -2 +LOOP + 2 spaces current .voc ; + +: words context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ .name space REPEAT drop ; + + + + + + +\ *** Block No. 79 Hexblock 4F +\ found -text bp 11 oct 86 + +| : found ( nfa -- cfa n ) + dup c@ >r (name> r@ $20 and IF @ THEN + -1 r@ $80 and IF 1- THEN + r> $40 and IF negate THEN ; + + + + + + + + + + +\ *** Block No. 80 Hexblock 50 +\ (find bp 11 oct 86 + \ A0: thread A1: string A2: nfa in thread D0: count + \ D1: act. char D3: act. nfa D4: string +Label notfound SP -) clr Next + +Code (find ( str thr - str false/ NFA true ) + .w SP )+ D6 move D6 reg) A0 lea + SP ) D6 move D6 reg) A1 lea + .b A1 ) D0 move .w $1F D0 andi A1 D4 lmove + D4 0 # btst 0= IF 1 D0 addq +Label findloop D4 A1 lmove + BEGIN A0 ) D6 move notfound beq D6 reg) A0 lea + .w A1 ) D1 move + .l 2 D6 FP DI) D1 .w sub $1FFF D1 andi 0= UNTIL + .l 2 D6 FP DI) A2 lea A2 D3 move + 2 A1 addq 2 A2 addq +\ *** Block No. 81 Hexblock 51 +\ (find part 2 09sep86we + + .w 0 D2 moveq BEGIN 2 D2 addq D2 D0 cmp > + WHILE A1 )+ A2 )+ cmpm findloop bne REPEAT + ELSE +Label findloop1 A0 ) D6 move notfound beq + .l D6 reg) A0 lea 2 D6 FP DI) A2 lea + A2 D3 move D4 A1 move + .b A1 )+ D1 move A2 )+ D1 sub $1F D1 andi findloop1 bne + D0 D1 move BEGIN 1 D1 subq 0>= + WHILE A1 )+ A2 )+ cmpm findloop1 bne REPEAT + THEN + .l FP D3 sub .w D3 SP ) move + true # SP -) move Next end-code + + +\ *** Block No. 82 Hexblock 52 +\ find ' ['] cas201301 + +: find ( string -- cfa n / string false ) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find IF nip found exit THEN + over vp 2+ u> WHILE swap 2- REPEAT nip false ; + +: ' ( -- cfa ) name find 0= abort" ?" ; + +: [compile] ' , ; immediate restrict + +: ['] ' [compile] Literal ; immediate restrict + +: nullstring? ( string -- string false / true ) + dup c@ 0= dup IF nip THEN ; + +\ *** Block No. 83 Hexblock 53 +\ >interpret 24sep86we + +Label jump + .l 2 D7 FP DI) .w D6 move D6 reg) IP lea 2 IP addq + Next end-code + +Create >interpret 2 allot jump ' >interpret ! + +\ make >interpret to special Defer + + + + + + + +\ *** Block No. 84 Hexblock 54 +\ interpret interactive cas201301 + +Defer notfound +: no.extensions ( string -- ) error" ?" ; \ string not 0 +' no.extensions Is notfound + +: interpret >interpret ; + +| : interpreter ?stack name find ?dup + IF 1 and IF execute >interpret THEN + abort" compile only" THEN + nullstring? ?exit + number? 0= IF notfound THEN >interpret ; + +' interpreter >interpret ! + +\ *** Block No. 85 Hexblock 55 +\ compiling [ ] 22mar86we + +| : compiler ?stack name find ?dup + IF 0> IF execute >interpret THEN , >interpret THEN + nullstring? ?exit + number? ?dup + IF 0> IF swap [compile] Literal THEN [compile] Literal + >interpret THEN + notfound >interpret ; + +: [ ['] interpreter Is >interpret state off ; immediate +: ] ['] compiler Is >interpret state on ; + + + + +\ *** Block No. 86 Hexblock 56 +\ Defer Is 24sep86we + +| : crash true abort" crash" ; + +: Defer Create ['] crash , + ;Code .l 2 D7 FP DI) .w D7 move + D7 reg) D6 move .l D6 reg) jmp end-code + +: (is r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) @ ['] notfound @ over = + swap ['] >interpret @ = or + not abort" not deferred" ; + +: Is ( adr -- ) ' dup def? >body + state @ IF compile (is , exit THEN ! ; immediate +\ *** Block No. 87 Hexblock 57 +\ ?stack 08sep86we + +| : stackfull ( -- ) + depth $20 > abort" tight stack" reveal last? + IF dup heap? IF name> ELSE 4- THEN (forget THEN + true abort" Dictionary full" ; + +Code ?stack + UP R#) D6 move .l user' dp D6 FP DI) D0 .w move + .l SP D1 move FP D1 sub .w D0 D1 sub $100 D1 cmpi + $6200 ( u<= ) IF ;c: stackfull ; Assembler THEN + .l user' s0 D6 FP DI) D0 .w move .l SP D1 move FP D1 sub + .w D1 D0 cmp 0>= IF Next THEN ;c: true abort" Stack empty" ; + +\\ : ?stack sp@ here - $100 u< IF stackfull THEN + sp@ s0 @ u> abort" Stack empty" ; +\ *** Block No. 88 Hexblock 58 +\ .status push load 28aug86we + +Defer .status ' noop Is .status + +| Create: pull r> r> ! ; + +: push ( addr -- ) r> swap dup >r @ >r pull >r >r ; + restrict + + +: (load ( blk offset -- ) over 0= IF 2drop exit THEN + isfile push loadfile push fromfile push blk push >in push + >in ! blk ! isfile @ loadfile ! .status interpret ; + +: load ( blk -- ) 0 (load ; + +\ *** Block No. 89 Hexblock 59 +\ +load thru +thru --> rdepth depth 19mar86we + +: +load ( offset -- ) blk @ + load ; + +: thru ( from to -- ) 1+ swap DO I load LOOP ; + +: +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; + +: --> 1 blk +! >in off .status ; + immediate + +: rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; +: depth ( -- +n ) sp@ s0 @ swap - 2/ ; + + + +\ *** Block No. 90 Hexblock 5A +\ quit (quit abort cas201301 + +| : prompt state @ IF ." [ " exit THEN ." ok" ; + +: (quit BEGIN .status cr query interpret prompt + REPEAT ; + +Defer 'quit ' (quit Is 'quit +: quit r0 @ rp! [compile] [ 'quit ; + +: standardi/o [ output ] Literal output 4 cmove ; + +Defer 'abort ' noop Is 'abort +: abort clearstack end-trace + 'abort standardi/o quit ; + +\ *** Block No. 91 Hexblock 5B +\ (error abort" error" 29mar86we + +Variable scr 1 scr ! Variable r# 0 r# ! + +: (error ( string -- ) + standardi/o space here .name count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; +' (error errorhandler ! + +: (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (err" "lit swap IF errorhandler perform exit THEN + drop ; restrict +: abort" compile (abort" ," align ; immediate restrict +: error" compile (err" ," align ; immediate restrict +\ *** Block No. 92 Hexblock 5C +\ -trailing bp 11 oct 86 + +Code -trailing ( addr n1 -- addr n2 ) + SP )+ D0 move 0<> IF + SP ) D6 move D6 reg) A0 lea D0 A0 adda +Label -trail .b A0 -) D1 move $20 D1 cmpi -trail D0 dbne + .w -1 D0 cmpi 0= IF D0 clr THEN + THEN D0 SP -) move Next end-code + + + + +\\ +: -trailing ( addr n1 -- addr n2) 2dup bounds + ?DO 2dup + 1- c@ bl - + IF LEAVE THEN 1- LOOP ; +\ *** Block No. 93 Hexblock 5D +\ space spaces bp 11 oct 86 + +$20 Constant bl + +: space bl emit ; + +: spaces ( u -- ) 0 ?DO space LOOP ; + + + + + + + + + +\ *** Block No. 94 Hexblock 5E +\ hold <# #> sign # #s 02may86we + +| : hld ( -- addr ) pad 2- ; + +: hold ( char -- ) -1 hld +! hld @ c! ; + +: <# hld hld ! ; + +: #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + +: sign ( n -- ) 0< IF Ascii - hold THEN ; + +: # ( +d1 -- +d2 ) base @ ud/mod rot 9 over < + IF [ ascii A ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; + +: #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; +\ *** Block No. 95 Hexblock 5F +\ print numbers 24dec83ks + +: d.r -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + +: .r swap extend rot d.r ; + +: u.r 0 swap d.r ; + +: d. 0 d.r space ; + +: . extend d. ; + +: u. 0 d. ; + + +\ *** Block No. 96 Hexblock 60 +\ .s list c/l l/s bp 18May86 + +: .s + sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + +$40 Constant c/l \ Screen line length +$10 Constant l/s \ lines per screen + +: list ( blk -- ) + scr ! ." Scr " scr @ dup u. ." Dr " drv? . + l/s 0 DO + cr I 2 .r space scr @ block I c/l * + c/l -trailing type + LOOP cr ; + + + +\ *** Block No. 97 Hexblock 61 +\ multitasker primitives 14sep86we + +Code pause Next end-code + +: lock ( addr -- ) + dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + +: unlock ( addr -- ) dup lock off ; + +Label wake .l 2 A7 addq A7 )+ A0 move 2 A0 subq + A0 A1 move FP A1 suba .w A1 UP R#) move + $3C3C ( # D6 move ) # A0 ) move + 8 A0 D) D6 move D6 reg) SP lea + SP )+ D6 move D6 reg) RP lea + SP )+ D6 move D6 reg) IP lea Next end-code +\ *** Block No. 98 Hexblock 62 +\ buffer mechanism cas201301 + +User isfile 0 isfile ! \ addr of file control block +Variable fromfile 0 fromfile ! +Variable prev 0 prev ! \ Listhead +| Variable buffers 0 buffers ! \ Semaphore +$408 Constant b/buf \ physical size + +\\ Structure of buffer: 0 : link + 2 : file + 4 : blocknumber + 6 : statusflags + 8 : Data ... 1 Kb ... +Statusflag bits : 15 1 -> updated +file : -1 -> empty buffer, 0 -> no fcb, direct acces + else addr of fcb ( system dependent ) +\ *** Block No. 99 Hexblock 63 +\ search for blocks in memory with (CORE? cas201301 +\ D0:blk D1:file A0:bufadr A1:previous +Label thisbuffer? + 2 A0 D) D1 cmp 0= IF 4 A0 D) D0 cmp THEN rts +Code (core? ( blk file -- adr\blk file ) + 2 SP D) D0 move SP ) D1 move + UP R#) D6 move .l user' offset D6 FP DI) D0 .w add + prev R#) D6 move D6 reg) A0 lea + thisbuffer? bsr 0= IF .l FP A0 suba +Label blockfound 2 SP addq 8 A0 addq .w A0 SP ) move + .l ' exit @ R#) jmp .w THEN + BEGIN A0 A1 lmove A1 ) D6 move 0= IF Next THEN + D6 reg) A0 lea thisbuffer? bsr 0= UNTIL + A0 ) A1 ) move prev R#) A0 ) move + .l FP A0 suba .w A0 prev R#) move + blockfound bra end-code +\ *** Block No. 100 Hexblock 64 +\ (core? 17nov85we + +\\ +| : this? ( blk file bufadr -- flag ) + dup 4+ @ swap 2+ @ d= ; + +| : (core? ( blk file -- dataaddr / blk file ) + BEGIN over offset @ + over prev @ this? + IF rdrop 2drop prev @ 8 + exit THEN + 2dup >r offset @ + >r prev @ + BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN + dup r> r> 2dup >r >r rot this? 0= + WHILE nip REPEAT + dup @ rot ! prev @ over ! prev ! rdrop rdrop + REPEAT ; + +\ *** Block No. 101 Hexblock 65 +\ r/w 11sep86we + +Defer r/w + + + + + + + + + + + + + +\ *** Block No. 102 Hexblock 66 +\ backup emptybuf readblk 11sep86we + +: backup ( bufaddr -- ) dup 6+ @ 0< + IF 2+ dup @ 1+ \ buffer empty if file = -1 + IF input push output push standardi/o + dup 6+ over 2+ @ 2 pick @ 0 r/w + abort" write error" + THEN 4+ dup @ $7FFF and over ! THEN drop ; + +: emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; + +| : readblk ( blk file addr -- blk file addr ) + dup emptybuf + input push output push standardi/o >r + over offset @ + over r@ 8 + -rot 1 r/w + abort" read error" r> ; +\ *** Block No. 103 Hexblock 67 +\ take mark updated? full? core? cas20130105 + +| : take ( -- bufaddr) prev + BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + buffers lock dup backup ; + +| : mark ( blk file bufaddr -- blk file ) + 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off + buffers unlock ; + +| : updates? ( -- bufaddr / flag ) + prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; +: updated? ( blk -- flg ) block 2- @ 0< ; +: full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6+ @ 0< ; + +: core? ( blk file -- addr /false ) (core? 2drop false ; +\ *** Block No. 104 Hexblock 68 +\ block & buffer manipulation b08sep86we + +: (buffer ( blk file -- addr ) + BEGIN (core? take mark REPEAT ; + +: (block ( blk file -- addr ) + BEGIN (core? take readblk mark REPEAT ; + +Code isfile@ ( -- addr ) + UP R#) D6 move .l user' isfile D6 FP DI) SP -) .w move + Next end-code + +: buffer ( blk -- addr ) isfile@ (buffer ; + +: block ( blk -- addr ) isfile@ (block ; + +\ *** Block No. 105 Hexblock 69 +\ block & buffer manipulation cas20130501 + +: update $80 prev @ 6+ c! ; + +: save-buffers buffers lock + BEGIN updates? ?dup WHILE backup REPEAT + buffers unlock ; + +: empty-buffers buffers lock prev + BEGIN @ ?dup WHILE dup emptybuf REPEAT + buffers unlock ; + +: flush save-buffers empty-buffers ; + + + +\ *** Block No. 106 Hexblock 6A +\ moving blocks cas201301 +| : fromblock ( blk -- adr ) fromfile @ (block ; +| : (copy ( from to -- ) + dup isfile@ core? IF prev @ emptybuf THEN + full? IF save-buffers THEN + offset @ + isfile@ rot fromblock 6 - 2! update ; + +| : blkmove ( from to quan --) save-buffers >r + over r@ + over u> >r 2dup u< r> and + IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP + ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP + THEN save-buffers 2drop ; + +: copy ( from to --) 1 blkmove ; +: convey ( [blk1 blk2] [to.blk --) + swap 1+ 2 pick - dup 0> not abort" No!" blkmove ; +\ *** Block No. 107 Hexblock 6B +\ Allocating buffers bp 18May86 + +$FFFE Constant limit Variable first + +: allotbuffer ( -- ) + first @ r0 @ - b/buf 2+ u< ?exit + b/buf negate first +! first @ dup emptybuf + prev @ over ! prev ! ; + +: freebuffer ( -- ) + first @ limit b/buf - u< + IF first @ backup prev + BEGIN dup @ first @ - WHILE @ REPEAT + first @ @ swap ! b/buf first +! THEN ; + +: all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; +\ *** Block No. 108 Hexblock 6C +\ endpoints of forget 14sep86we + +| : |? ( nfa -- flag ) c@ $20 and ; +| : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoints ( addr -- addr symb ) + heap voc-link >r + BEGIN r> @ ?dup \ through all Vocabs + WHILE dup >r 4- >r \ link on returnstack + BEGIN r> @ >r over 1- dup r@ u< \ until link or + swap r@ 2+ name> u< and \ code under adr + WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap + r@ 2+ |? IF over r@ 2+ forget? + IF r@ 2+ (name> 2+ umax THEN \ then update symb + THEN REPEAT rdrop REPEAT ; +\ *** Block No. 109 Hexblock 6D +\ remove, -words, -tasks bp/ks14sep86we + +: remove ( dic sym thread - dic sym ) + BEGIN dup @ ?dup \ unlink forg. words + WHILE dup heap? + IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + +| : remove-words ( dic sym -- dic sym ) + voc-link BEGIN @ ?dup + WHILE dup >r 4- remove r> REPEAT ; + +| : remove-tasks ( dic -- ) up@ + BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin + IF dup @ 2+ @ over ! 2- + ELSE @ THEN REPEAT 2drop ; +\ *** Block No. 110 Hexblock 6E +\ remove-vocs forget-words bp 11oct86 + +| : remove-vocs ( dic symb -- dic symb ) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 2dup current @ -rot uwithin + IF [ ' Forth 2+ ] Literal current ! THEN ; + +| : remove-codes ( dic symb -- dic symb ) + next-link remove ; + +Defer custom-remove ' noop Is custom-remove +| : forget-words ( dic symb -- ) + over remove-tasks remove-vocs remove-words remove-codes + custom-remove heap swap - hallot dp ! last off ; +\ *** Block No. 111 Hexblock 6F +\ deleting words from dict. bp 11oct86 + +: clear here dup up@ forget-words dp ! ; + +: (forget ( adr -- ) dup heap? abort" is symbol" + endpoints forget-words ; + +: forget ' dup [ dp ] Literal @ u< abort" protected" + >name dup heap? + IF name> ELSE 4- THEN (forget ; + +: empty [ dp ] Literal @ up@ forget-words + [ udp ] Literal @ udp ! ; + + + +\ *** Block No. 112 Hexblock 70 +\ save bye stop? ?cr cas201301 + +: save here up@ forget-words + voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL + up@ origin $100 cmove ; + +: bye flush empty (bye ; + +| : end? key $FF and dup 3 = \ Stop key + swap $1B = or \ Escape key + IF true rdrop THEN ; + +: stop? ( -- flag ) key? IF end? end? THEN false ; + +: ?cr col c/l u> IF cr THEN ; + +\ *** Block No. 113 Hexblock 71 +\ in/output structure 25mar86we + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + +: Output: Create: Does> output ! ; +0 Out: emit Out: cr Out: type Out: del + Out: page Out: at Out: at? drop + +: row ( -- row ) at? drop ; +: col ( -- col ) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + +: Input: Create: Does> input ! ; +0 In: key In: key? In: decode In: expect drop + +\ *** Block No. 114 Hexblock 72 +\ Alias only definitionen 29jan85bp + +Only definitions Forth + +: seal 0 ['] Only >body ! ; \ kill all words in Only + +' Only Alias Only +' Forth Alias Forth +' words Alias words +' also Alias also +' definitions Alias definitions + +Host Target + + + +\ *** Block No. 115 Hexblock 73 +\ 'cold 'restart 19mar86we + +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; +| : init-buffers 0 prev ! limit first ! all-buffers ; + +Defer 'cold ' noop Is 'cold +| : (cold origin up@ $100 cmove + init-vocabularys init-buffers 'cold page wrap + Onlyforth cr &27 spaces logo count type cr (restart ; + +Defer 'restart ' noop Is 'restart +| : (restart ['] (quit Is 'quit drvinit 'restart + [ errorhandler ] Literal @ errorhandler ! + ['] noop Is 'abort abort ; + +\ *** Block No. 116 Hexblock 74 +\ cold bootsystem restart 16oct86we + +Label buserror &14 # A7 adda ;c: true abort" Bus Error !" ; +Label adrerror &14 # A7 adda ;c: true abort" Adress Error !" ; +Label illegal 6 A7 addq + ;c: true abort" Illegal Instruction !" ; +Label div0 6 A7 addq ;c: true abort" Division by 0 !" ; + + + +| Create save_ssp 4 allot + +Code cold here >cold ! + $A00A , \ hide mouse + ' (cold >body FP D) IP lea + +\ *** Block No. 117 Hexblock 75 +\ restart 16oct86we + +Label bootsystem .l 0 D7 moveq + .w user' s0 # D7 move origin D7 FP DI) D6 move + .l D6 reg) SP lea .w 6 D6 addq D6 UP R#) move + .w user' r0 # D7 move origin D7 FP DI) D6 move + .l D6 reg) RP lea RP ) clr 0 D6 moveq + .w D0 movedst) 0= IF + .l A7 -) clr .w $20 # A7 -) move 1 trap + .l D0 save_ssp R#) move 6 A7 addq THEN + .w buserror # D6 move .l D6 reg) A0 lea A0 8 #) move + .w adrerror # D6 move .l D6 reg) A0 lea A0 $0C #) move + .w illegal # D6 move .l D6 reg) A0 lea A0 $10 #) move + .w div0 # D6 move .l D6 reg) A0 lea A0 $14 #) move + .w wake # D6 move .l D6 reg) A0 lea A0 $8C #) move + Next end-code +\ *** Block No. 118 Hexblock 76 +\ System dependent load screen bp 11oct86 + +Code restart here >restart ! + ' (restart >body FP D) IP lea bootsystem bra end-code + +2 $0C +thru \ Atari 520 ST Interface + +Host ' Transient 8 + @ Transient Forth context @ 6 + ! +\ Tlatest aus Transient wird Tlatest in Forth + +Target Forth also definitions +: forth-83 ; \ last word in Dictionary + + + + +\ *** Block No. 119 Hexblock 77 +\ System patchup 14sep86we + +Forth definitions + +$D3AA s0 ! $D7AA r0 ! \ gives &10 Buffers +s0 @ dup s0 2- ! 6 + s0 8 - ! +here dp ! + +Host Tudp @ Target udp ! +Host Tvoc-link @ Target voc-link ! +Host Tnext-link @ Target next-link ! +Host move-threads + + + + +\ *** Block No. 120 Hexblock 78 +\ BIOS - Calls 09sep86we + +Code bconstat ( dev -- fl ) + SP )+ D0 move D0 A7 -) move 1 # A7 -) move $0D trap + 4 A7 addq D0 SP -) move Next end-code +Code bcostat ( dev -- fl ) + SP )+ D0 move D0 A7 -) move 8 # A7 -) move $0D trap + 4 A7 addq D0 SP -) move Next end-code + +Code bconin ( dev -- char ) + SP )+ D0 move D0 A7 -) move 2 # A7 -) move $0D trap + 4 A7 addq .w D0 D1 move .l 8 # D0 lsr .b D1 D0 move + .w D0 SP -) move Next end-code +Code bconout ( char dev -- ) + SP )+ D0 move SP )+ A7 -) move D0 A7 -) move + 3 # A7 -) move $0D trap 6 A7 addq Next end-code +\ *** Block No. 121 Hexblock 79 +\ STkey? getkey cas201301 + +$08 Constant #bs $0D Constant #cr +$0A Constant #lf $1B Constant #esc + +: con! ( 8b -- ) 2 bconout ; +: curon #esc con! Ascii e con! ; +: curoff #esc con! Ascii f con! ; +: wrap #esc con! Ascii v con! ; +: cur< #esc con! Ascii D con! -1 out +! ; +: cur> #esc con! Ascii C con! 1 out +! ; + +: STkey? ( -- fl ) 2 bconstat ; +: getkey ( -- char ) STkey? IF 2 bconin ELSE 0 THEN ; +: STkey ( -- char ) curon + BEGIN pause STkey? UNTIL curoff getkey ; +\ *** Block No. 122 Hexblock 7A +\ (ins (del cas201301 + +| Variable maxchars + +| : (del ( addr pos1 -- addr pos2 ) 2dup cur< + at? >r >r 2dup + over span @ - negate under type space + r> r> at + >r + dup 1- r> cmove -1 span +! 1- ; + +| : (ins ( addr pos1 -- addr pos2 ) 2dup + + over span @ - negate >r dup dup 1+ r@ cmove> + bl over c! r> 1+ at? >r >r type r> r> at + 1 span +! ; + + + +\ *** Block No. 123 Hexblock 7B +\ decode cas201301 + +: STdecode ( addr pos1 key -- addr pos2 ) + $4D00 case? IF dup span @ < IF cur> 1+ THEN exit THEN + $4B00 case? IF dup IF cur< 1- THEN exit THEN + $5200 case? IF dup span @ - IF (ins THEN exit THEN + $FF and dup 0= IF drop exit THEN + #bs case? IF dup IF (del THEN exit THEN + $7F case? IF span @ 2dup < and + IF cur> 1+ (del THEN exit THEN + #cr case? IF span @ maxchars ! + dup at? rot span @ - - at exit THEN + >r 2dup + r@ swap c! r> emit + dup span @ = IF 1 span +! THEN 1+ ; + + +\ *** Block No. 124 Hexblock 7C +\ expect keyboard 25mar86we + +: STexpect ( addr len -- ) maxchars ! + span off 0 + BEGIN span @ maxchars @ u< WHILE key decode REPEAT + 2drop space ; + + +Input: keyboard [ here input ! ] + STkey STkey? STdecode STexpect ; + + + + + + +\ *** Block No. 125 Hexblock 7D +\ emit cr del page at at? type cas201301 + +| Variable out 0 out ! | &80 Constant c/row + +: STemit ( 8b -- ) 5 bconout 1 out +! pause ; +: STcr #cr con! #lf con! + out @ c/row / 1+ c/row * out ! ; +: STdel #bs con! space #bs con! -2 out +! ; +: STpage #esc con! Ascii E con! out off ; +: STat ( row col -- ) #esc con! Ascii Y con! + over $20 + con! dup $20 + con! + swap c/row * + out ! ; +: STat? ( -- row col ) out @ c/row /mod swap ; + +\\ +: STtype ( addr len --) 0 ?DO count emit LOOP drop ; +\ *** Block No. 126 Hexblock 7E +\ Output 16oct86we + +Code STtype ( addr len -- ) + SP )+ D3 move SP )+ D6 move D3 tst 0<> + IF D3 out R#) add 1 D3 subq + D3 DO D6 reg) A0 lea .b A0 ) D1 move FP A7 -) lmove + .w D1 A7 -) move 5 # A7 -) move 3 # A7 -) move + $0D trap 6 A7 addq 1 D6 addq A7 )+ FP lmove LOOP + THEN ;c: pause ; + +Output: display [ here output ! ] + STemit STcr STtype STdel STpage STat STat? ; + +| Code term .l save_ssp R#) A7 -) move .w $20 # A7 -) move + 1 trap 6 A7 addq A7 -) clr 1 trap end-code +| : (bye curoff term ; +\ *** Block No. 127 Hexblock 7F +\ b/blk drive >drive drvinit 10sep86we + +$400 Constant b/blk +| Variable (drv 0 (drv ! +Create (blk/drv + 4 allot $15F (blk/drv ! $15F (blk/drv 2+ ! + +: blk/drv ( -- n ) (blk/drv (drv @ 2* + @ ; + +: drive ( drv# -- ) $1000 * offset ! ; +: >drive ( block drv# -- block' ) $1000 * + offset @ - ; +: drv? ( block -- drv# ) offset @ + $1000 / ; + +: drvinit noop ; +: drv0 0 drive ; : drv1 1 drive ; + +\ *** Block No. 128 Hexblock 80 +\ readsector writesector cas201301 + +Code rwabs ( r/wf adr rec# -- flag ) + .l FP A7 -) move + .w SP )+ D0 move SP )+ D6 move D6 reg) A0 lea + SP )+ D1 move 2 D1 addq + (drv R#) A7 -) move \ Drivenumber + D0 A7 -) move \ rec# + 2 # A7 -) move \ number sectors + .l A0 A7 -) move \ Address + .w D1 A7 -) move \ r/w flag + 4 # A7 -) move \ function number + $0D trap $0E # A7 adda .l A7 )+ FP move + .w D0 SP -) move \ error flag + Next end-code + +\ *** Block No. 129 Hexblock 81 +\ diskchange? 09nov86we + +| Code mediach? ( -- flag ) + .w (drv R#) A7 -) move 9 # A7 -) move $0D trap 4 A7 addq + D0 SP -) move Next end-code + +| Code getblocks ( -- n ) + .w (drv R#) A7 -) move 7 # A7 -) move $0D trap 4 A7 addq + D0 A0 move .w $0E # A0 adda A0 ) D0 move D0 SP -) move + Next end-code + + + + + + +\ *** Block No. 130 Hexblock 82 +\ STr/w 10sep86we + +: STr/w ( adr blk file r/wf -- flag ) + swap abort" no file" + 1 xor -rot $1000 /mod dup (drv ! + 1 u> IF . ." beyond capacity" nip exit THEN + mediach? IF getblocks (blk/drv (drv @ 2* + ! THEN + dup blk/drv > IF drop 2drop true + ELSE 9 + 2* rwabs THEN ; + +' STr/w Is r/w + + + + + +\ *** Block No. 131 Hexblock 83 +\ Basepage (TOS PRG Header) cas201301 + +$601A , \ BRA to start of PGM + +here $1A allot $1A erase \ clear basepage info + +Assembler + +.l A7 A5 move 4 A5 D) A5 move \ start basepage + $1.0600 # D0 move D0 D1 move \ store size of forth and + A5 D1 add .w $FFFE D1 andi .l D1 A7 move \ stack + D0 A7 -) move A5 A7 -) move .w A7 -) clr + $4A # A7 -) move 1 trap $0C # A7 adda \ mshrink + $100 $1C - # A5 adda A5 FP lmove \ FP to start of Forth + + +\ *** Block No. 132 Hexblock 84 + + + + + + + + + + + + + + + + diff --git a/sources/AtariST/GEM/AES.FB.src b/sources/AtariST/GEM/AES.FB.src deleted file mode 100644 index 3d07562..0000000 --- a/sources/AtariST/GEM/AES.FB.src +++ /dev/null @@ -1,680 +0,0 @@ -Screen 0 not modified - 0 \\ *** AES -Funktionen *** 26may86we - 1 - 2 Dieses File enth„lt alle AES-Funktionen. - 3 - 4 Zur genauren Beschreibung verweisen wir auf die Dokumentation - 5 von Digital Research. - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ AES Loadscreen cas20130105 - 1 - 2 \needs GEM include gem\basics.fb - 3 Onlyforth - 4 \needs 2over include double.fb - 5 Onlyforth GEM also definitions - 6 1 +load cr .( Eventwords loaded) cr - 7 7 +load cr .( Menuwords loaded) cr - 8 $0C +load cr .( Objectwords loaded) cr - 9 $10 +load cr .( Formwords loaded) cr -10 $14 +load cr .( Graphicswords loaded) cr -11 $19 +load cr .( Fileselect loaded) cr -12 $1C +load cr .( Windowwords loaded) cr -13 $22 +load cr .( RSRCwords loaded) cr -14 -15 -Screen 2 not modified - 0 \ Event Loadscreen 01feb86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 1 5 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ event_keybd event_button 06aug86we - 1 - 2 : evnt_keybd ( -- key ) &20 0 1 0 AES ; - 3 - 4 : evnt_button ( #clicks0 bmask bstate -- #clicks1 ) - 5 intin 3 array! &21 3 5 0 AES ; - 6 - 7 \\ #clicks0 is awaitet # of clicks - 8 bmask is a button mask - 9 bstate is the awaitet state of mouse-button(s) -10 #clicks1 is the actually entered # of clicks -11 bmask + bstate use the convention: -12 lowest bit is leftmost button etc. -13 bit = 0 is button up -14 bit = 1 is button down -15 more return parameters are in intout-array -Screen 4 not modified - 0 \ event_mouse event_mesag 02nov86we - 1 - 2 : evnt_mouse ( f leftX topY widht heigth -- ) - 3 intin 5 array! &22 5 5 0 AES drop ; - 4 - 5 \ f = 0 is return on entry of mouse in rectangle - 6 \ f = 1 is return on exit ... - 7 \ more parameters are in intout - 8 - 9 Create message $10 allot -10 -11 : evnt_mesag ( -- ) -12 message >absaddr addrin 2! &23 0 1 1 AES drop ; -13 -14 \ see description of messages in AES documentation -15 -Screen 5 not modified - 0 \ event_timer 06aug86we - 1 - 2 : evnt_timer ( dtime -- ) - 3 intin 2 array! &24 2 1 0 AES drop ; - 4 - 5 \ dtime is a double number for timer count down in milliseconds - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 \ evnt_multi bp 12oct86 - 1 - 2 \ because there are too much parameters: - 3 - 4 Create events - 5 %00110011 , \ timer, message, button + keyboard events on - 6 2 , 1 , 1 , \ 2 clicks down on left mouse-button - 7 here $14 allot $14 erase \ rectangles unspecified - 8 0 , 0 , \ 0 millisecond timer-delay - 9 -10 : prepare events intin $20 cmove -11 message >absaddr addrin 2! ; -12 -13 : evnt_multi ( -- which ) &25 &16 7 1 AES ; -14 -15 -Screen 7 not modified - 0 \ evnt_dclick 06aug86we - 1 - 2 : evnt_dclick ( dnew dgetset -- dspeed ) - 3 intin 2 array! &26 2 1 0 AES ; - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ Menu Loadscreen 12aug86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 1 4 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ objc_tree menuAES bp 12oct86 - 1 - 2 | : ?menuerror ( flag -- ) 0= abort" Menu-Error" ; - 3 - 4 | : menuAES ( opcode #intin #intout #addrin -- intout@ ) - 5 objc_tree 2@ addrin 2! AES ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ menu_bar menu_icheck 09aug86we - 1 - 2 : menu_bar ( showflag -- ) - 3 intin ! &30 1 1 1 menuAES ?menuerror ; - 4 - 5 \ showflag = 0 is menubar off, = 1 is menubar on - 6 - 7 - 8 : menu_icheck ( item showflag -- ) - 9 intin 2 array! &31 2 1 1 menuAES ?menuerror ; -10 -11 \ item is the menu item -12 \ showflag = 0 is checkmark off, = 1 is checkmark on -13 -14 -15 -Screen 11 not modified - 0 \ menu_ienable menu_tnormal 09aug86we - 1 - 2 : menu_ienable ( item enableflag -- ) - 3 intin 2 array! &32 2 1 1 menuAES ?menuerror ; - 4 - 5 \ item is the menuitem# - 6 \ enableflag = 0 is disable item, = 1 is enable item - 7 - 8 - 9 : menu_tnormal ( title normalflag -- ) -10 intin 2 array! &33 2 1 1 menuAES ?menuerror ; -11 -12 \ title is the title# -13 \ normalflag = 0 is title reverse, = 1 is title normal -14 -15 -Screen 12 not modified - 0 \ menu_text menu_register 02nov86we - 1 - 2 : menu_text ( item laddr -- ) - 3 addrin 4+ 2! intin ! &34 1 1 2 menuAES ?menuerror ; - 4 - 5 \ item is the menuitem# - 6 \ laddr is the address of a 0-terminated replace-string - 7 - 8 - 9 : menu_register ( apid laddr -- menuid ) -10 addrin 2! intin ! &35 1 1 1 AES dup 0< not ?menuerror ; -11 -12 \ apid is the application-ID from ACC's applinit -13 \ laddr is the address of a 0-terminated string for menutext -14 \ menuid is ACC's menu-identifier (0-5) -15 -Screen 13 not modified - 0 \ Object Loadscreen 01feb86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 1 3 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 14 not modified - 0 \ objc_tree objcAES objc_add objc_delete 06aug86we - 1 - 2 | : ?objcerror ( flag -- ) 0= abort" Object-Error" ; - 3 - 4 | : objcAES ( opcode #intin #intout #addrin -- intout@ ) - 5 objc_tree 2@ addrin 2! 1 AES ; - 6 - 7 : objc_add ( parent child -- ) - 8 intin 2 array! &40 2 1 objcAES ?objcerror ; - 9 -10 : objc_delete ( object -- ) -11 intin ! &41 1 1 objcAES ?objcerror ; -12 -13 -14 -15 -Screen 15 not modified - 0 \ objc_draw objc_find objc_offset bp 12oct86 - 1 - 2 : objc_draw ( startob depth x y width height -- ) - 3 intin 6 array! &42 6 1 objcAES ?objcerror ; - 4 - 5 : objc_find ( startob depth x y -- obnum ) - 6 intin 4 array! &43 4 1 objcAES ; - 7 - 8 : objc_offset ( object -- x y ) - 9 intin ! &44 1 3 objcAES ?objcerror -10 intout 2+ @ intout 4+ @ ; -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \ objc_order objc_edit objc_change 02feb86we - 1 - 2 : objc_order ( object newpos -- ) - 3 intin 2 array! &45 2 1 objcAES ?objcerror ; - 4 - 5 : objc_edit ( object char index kind -- newindex ) - 6 intin 4 array! &46 4 2 objcAES ?objcerror intout 2+ @ ; - 7 - 8 : objc_change ( object x y width height newstate redraw -- ) - 9 intin 4+ 6 array! intin ! intin 2+ off -10 &47 8 1 objcAES ?objcerror ; -11 -12 -13 -14 -15 -Screen 17 not modified - 0 \ Object Loadscreen 09aug86we - 1 - 2 Onlyforth GEM also definitions - 3 1 2 +thru - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 18 not modified - 0 \ form_do form_dial bp 12oct86 - 1 - 2 : form_do ( startobj -- objectno ) - 3 intin ! objc_tree 2@ addrin 2! &50 1 1 1 AES ; - 4 - 5 : form_dial ( diflag lix liy liw lih bix biy biw bih ) - 6 intin 9 array! &51 9 1 0 AES drop ; - 7 \ li means little bi means big - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 19 not modified - 0 \ form_alert form_error form_center 07a09sep86we - 1 - 2 : form_alert ( defbttn 0string -- exbttn ) - 3 >absaddr addrin 2! intin ! &52 1 1 1 AES ; - 4 - 5 : form_error ( enum -- exbttn ) - 6 intin ! &53 1 1 0 AES ; - 7 - 8 : form_center ( -- x y width height ) - 9 objc_tree 2@ addrin 2! &54 0 5 1 AES drop intout 2+ 4@ ; -10 -11 -12 -13 -14 -15 -Screen 20 not modified - 0 \ form_alert tests bp 12oct86 - 1 - 2 : test ( -- button ) - 3 2 0" [1][Dies ist ein Test!|2.Zeile][OK|JA|NEIN]" - 4 form_alert ; - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 21 not modified - 0 \ Graphics Loadscreen 02feb86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 1 4 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 \ graf_dragbox graf_movebox 06aug86we - 1 - 2 | : ?graferror ( flag -- ) 0= abort" Graphic-Error" ; - 3 - 4 : graf_dragbox - 5 ( startx starty width height boundx boundy boundw boundh -- - 6 finishx finishy ) - 7 intin 8 + 4 array! intin 2 array! intin 4+ 2 array! - 8 &71 8 3 0 AES ?graferror intout 2+ @ intout 4+ @ ; - 9 -10 : graf_movebox -11 ( sourcex sourcey width height destx desty -- ) -12 intin 8 + 2 array! intin 2 array! intin 4+ 2 array! -13 &72 6 1 0 AES ?graferror ; -14 -15 -Screen 23 not modified - 0 \ graf_growbox graf_shrinkbox 06aug86we - 1 - 2 : graf_growbox ( stx sty stw sth fix fiy fiw fih -- ) - 3 intin 8 array! &73 8 1 0 AES ?graferror ; - 4 - 5 : graf_shrinkbox ( fix fiy fiw fih stx sty stw sth -- ) - 6 intin 8 array! &74 8 1 0 AES ?graferror ; - 7 - 8 \ st means start fi means finish - 9 -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 \ graf_watchbox graf_slidebox bp 12oct86 - 1 - 2 : graf_watchbox ( object instate outstate -- inside/outside ) - 3 objc_tree 2@ addrin 2! intin 2+ 3 array! - 4 &75 4 1 1 AES ; - 5 - 6 : graf_slidebox ( parent object vhflag -- vhpos ) - 7 objc_tree 2@ addrin 2! intin 3 array! - 8 &76 3 1 1 AES ; - 9 -10 -11 \\ graf_handle is defined in BASICS.SCR ! -12 -13 -14 -15 -Screen 25 not modified - 0 \ graf_mouse graf_mkstate bp 12oct86 - 1 - 2 2Variable mofaddr 0. mofaddr 2! - 3 - 4 : graf_mouse ( mouseform -- ) - 5 intin ! mofaddr 2@ addrin 2! &78 1 1 1 AES ?graferror ; - 6 - 7 : graf_mkstate ( -- ) &79 0 5 0 AES drop ; - 8 - 9 \ Werte in intout -10 -11 -12 -13 -14 -15 -Screen 26 not modified - 0 \ File Selection Loadscreen bp 11oct86 - 1 - 2 Onlyforth - 3 GEM also definitions - 4 - 5 1 +load - 6 - 7 \\ - 8 - 9 : test ( -- button ) -10 show_c inpath &30 erase name count inpath place -11 insel $10 erase name count insel place -12 fs_label &30 erase name count fs_label place -13 fsel_exinput hide_c ; -14 -15 test A:\GEM\*.SCR AES.SCR Dies_ist_eine_Textbox! -Screen 27 not modified - 0 \ File Selection bp 11oct86 - 1 - 2 Create inpath ," \*.SCR" here &30 allot &30 erase - 3 Create insel here $10 allot $10 erase - 4 - 5 | : count? ( addr -- ) - 6 dup 1+ BEGIN count 0= UNTIL over - 2- swap c! ; - 7 - 8 : fsel_input ( -- button ) - 9 inpath 1+ >absaddr addrin 2! insel 1+ >absaddr addrin 4+ 2! -10 &90 0 2 2 AES 0= abort" File Error" -11 inpath count? insel count? intout 2+ @ ; -12 --> -13 \\ button = 0 is ABBRUCH, = 1 is OK; the returned strings -14 are in inpath and insel (counted and 0-terminated) -15 -Screen 28 not modified - 0 \ File selection mit FSEL_EXINPUT 13jan90 m.bitter - 1 - 2 Create fs_label ," May the volks4TH be with you!" 0 c, - 3 - 4 : fsel_exinput ( -- button ) - 5 inpath 1+ >absaddr addrin 2! insel 1+ >absaddr addrin 4+ 2! - 6 fs_label 1+ >absaddr addrin 8 + 2! - 7 &91 0 2 3 AES 0= abort" File Error" - 8 inpath count? insel count? intout 2+ @ ; - 9 -10 -11 -12 -13 \\ button = 0 is ABBRUCH, = 1 is OK; the returned strings -14 are in inpath and insel (counted and 0-terminated) -15 -Screen 29 not modified - 0 \ Windows Loadscreen 28jan86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 1 4 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 30 not modified - 0 \ windows 21aug86we - 1 - 2 | : ?winderror ( flag -- ) 0= abort" Window-Error" ; - 3 - 4 : wind_create - 5 ( components leftX topY maxWidth maxHeight -- handle ) - 6 intin 5 array! &100 5 1 0 AES dup 0> ?winderror ; - 7 - 8 \\ component bits set mean: - 9 -10 $0001 title bar $0002 close box -11 $0004 full box $0008 move bar -12 $0010 info line $0020 size box -13 $0040 up arrow $0080 down arrow -14 $0100 vertical slider $0200 left arrow -15 $0400 right arrow $0800 horizontal slider -Screen 31 not modified - 0 \ windows 06aug86we - 1 - 2 : wind_open ( W-handle leftX topY width heigth -- ) - 3 intin 5 array! &101 5 1 0 AES ?winderror ; - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 32 not modified - 0 \ windows 06aug86we - 1 - 2 : wind_close ( Whandle -- ) - 3 intin ! &102 1 1 0 AES ?winderror ; - 4 - 5 : wind_delete ( Whandle -- ) - 6 intin ! &103 1 1 0 AES ?winderror ; - 7 - 8 : wind_get ( Whandle funktion# -- ) - 9 intin 2 array! &104 2 5 0 AES ?winderror ; -10 -11 : wind_set ( Whandle funktion# par0 par1 par2 par3 -- ) -12 intin 6 array! &105 6 1 0 AES ?winderror ; -13 -14 : wind_find ( mouseX mouseY -- Whandle ) -15 intin 2 array! &106 2 1 0 AES ; -Screen 33 not modified - 0 \ windows 06aug86we - 1 - 2 : wind_update ( funktion# -- ) - 3 intin ! &107 1 1 0 AES ?winderror ; - 4 - 5 : wind_calc ( 0/1 components leftX topY width heigth -- ) - 6 intin 6 array! &108 6 5 0 AES ?winderror ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 34 not modified - 0 \ window test 02feb86we - 1 - 2 $0FEF &0 &20 &600 &300 wind_create Constant wtesthandle - 3 - 4 : windowtest page - 5 wtesthandle 1 &20 &500 &300 wind_open - 6 $20 0 DO wtesthandle 5 1 &20 &500 I - &300 I - wind_set - 7 2 +LOOP - 8 ." Hit any key to continue " key drop - 9 wtesthandle wind_close ; -10 -11 : end wtesthandle wind_delete ; -12 -13 -14 -15 -Screen 35 not modified - 0 \ RSRC Loadscreen 21nov86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 \needs 0" include strings.scr - 5 - 6 - 7 1 4 +thru - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 36 not modified - 0 \ RSRC words bp 12oct86 - 1 - 2 | : ?rsrcerror ( f -- ) 0= abort" Resource-Error" ; - 3 - 4 : rsrc_load ( 0$ -- ) \ needs address of 0-terminated $ - 5 >absaddr addrin 2! &110 0 1 1 AES ?rsrcerror ; - 6 - 7 : rsrc_load" [compile] 0" compile rsrc_load ; - 8 immediate restrict - 9 -10 -11 -12 -13 -14 -15 -Screen 37 not modified - 0 \ rsrc_gaddr 20aug86mawe - 1 - 2 : rsrc_free ( -- ) &111 0 1 0 AES ?rsrcerror ; - 3 - 4 : rsrc_gaddr ( type index -- laddr ) - 5 intin 2 array! &112 2 1 0 AES ?rsrcerror addrout 2@ ; - 6 - 7 \\ type is one of the following: - 8 0 tree 1 object 2 tedinfo 3 iconblk - 9 4 bitblk 5 string 6 imagedata 7 obspec -10 8 te_ptext 9 te_ptmplt $A te_pvalid $B ib_pmask -11 $C ib_pdata $D ib_ptext $E bi_pdata $F ad_frstr -12 $10 ad_frimg -13 index is the index of the data structure -14 laddr is the long (double) address of the data structure -15 specified by type and index -Screen 38 not modified - 0 \ rsrc_saddr 06aug86we - 1 - 2 : rsrc_saddr ( type index laddr --) - 3 addrin 2! intin 2 array! &113 2 1 1 AES ?rsrcerror ; - 4 - 5 \\ for type index and f see rsrc_gaddr - 6 laddr is the address of a data structure - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 39 not modified - 0 \ rsrc_obfix 06aug86we - 1 - 2 : rsrc_obfix ( index laddr --) - 3 addrin 2! intin ! &114 1 1 1 AES drop ; - 4 - 5 \ index is index of object - 6 \ laddr is addr of tree that contains object - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/GEM/AES.fth b/sources/AtariST/GEM/AES.fth new file mode 100644 index 0000000..3f7a4e3 --- /dev/null +++ b/sources/AtariST/GEM/AES.fth @@ -0,0 +1,680 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** AES -Funktionen *** 26may86we + +Dieses File enth„lt alle AES-Funktionen. + +Zur genauren Beschreibung verweisen wir auf die Dokumentation +von Digital Research. + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ AES Loadscreen cas20130105 + +\needs GEM include gem\basics.fb +Onlyforth +\needs 2over include double.fb +Onlyforth GEM also definitions + 1 +load cr .( Eventwords loaded) cr + 7 +load cr .( Menuwords loaded) cr +$0C +load cr .( Objectwords loaded) cr +$10 +load cr .( Formwords loaded) cr +$14 +load cr .( Graphicswords loaded) cr +$19 +load cr .( Fileselect loaded) cr +$1C +load cr .( Windowwords loaded) cr +$22 +load cr .( RSRCwords loaded) cr + + +\ *** Block No. 2 Hexblock 2 +\ Event Loadscreen 01feb86we + +Onlyforth GEM also definitions + + 1 5 +thru + + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ event_keybd event_button 06aug86we + +: evnt_keybd ( -- key ) &20 0 1 0 AES ; + +: evnt_button ( #clicks0 bmask bstate -- #clicks1 ) + intin 3 array! &21 3 5 0 AES ; + +\\ #clicks0 is awaitet # of clicks + bmask is a button mask + bstate is the awaitet state of mouse-button(s) + #clicks1 is the actually entered # of clicks + bmask + bstate use the convention: + lowest bit is leftmost button etc. + bit = 0 is button up + bit = 1 is button down +more return parameters are in intout-array +\ *** Block No. 4 Hexblock 4 +\ event_mouse event_mesag 02nov86we + +: evnt_mouse ( f leftX topY widht heigth -- ) + intin 5 array! &22 5 5 0 AES drop ; + +\ f = 0 is return on entry of mouse in rectangle +\ f = 1 is return on exit ... +\ more parameters are in intout + +Create message $10 allot + +: evnt_mesag ( -- ) + message >absaddr addrin 2! &23 0 1 1 AES drop ; + +\ see description of messages in AES documentation + +\ *** Block No. 5 Hexblock 5 +\ event_timer 06aug86we + +: evnt_timer ( dtime -- ) + intin 2 array! &24 2 1 0 AES drop ; + +\ dtime is a double number for timer count down in milliseconds + + + + + + + + + + +\ *** Block No. 6 Hexblock 6 +\ evnt_multi bp 12oct86 + +\ because there are too much parameters: + +Create events + %00110011 , \ timer, message, button + keyboard events on + 2 , 1 , 1 , \ 2 clicks down on left mouse-button + here $14 allot $14 erase \ rectangles unspecified + 0 , 0 , \ 0 millisecond timer-delay + +: prepare events intin $20 cmove + message >absaddr addrin 2! ; + +: evnt_multi ( -- which ) &25 &16 7 1 AES ; + + +\ *** Block No. 7 Hexblock 7 +\ evnt_dclick 06aug86we + +: evnt_dclick ( dnew dgetset -- dspeed ) + intin 2 array! &26 2 1 0 AES ; + + + + + + + + + + + + +\ *** Block No. 8 Hexblock 8 +\ Menu Loadscreen 12aug86we + +Onlyforth GEM also definitions + + 1 4 +thru + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ objc_tree menuAES bp 12oct86 + +| : ?menuerror ( flag -- ) 0= abort" Menu-Error" ; + +| : menuAES ( opcode #intin #intout #addrin -- intout@ ) + objc_tree 2@ addrin 2! AES ; + + + + + + + + + + +\ *** Block No. 10 Hexblock A +\ menu_bar menu_icheck 09aug86we + +: menu_bar ( showflag -- ) + intin ! &30 1 1 1 menuAES ?menuerror ; + +\ showflag = 0 is menubar off, = 1 is menubar on + + +: menu_icheck ( item showflag -- ) + intin 2 array! &31 2 1 1 menuAES ?menuerror ; + +\ item is the menu item +\ showflag = 0 is checkmark off, = 1 is checkmark on + + + +\ *** Block No. 11 Hexblock B +\ menu_ienable menu_tnormal 09aug86we + +: menu_ienable ( item enableflag -- ) + intin 2 array! &32 2 1 1 menuAES ?menuerror ; + +\ item is the menuitem# +\ enableflag = 0 is disable item, = 1 is enable item + + +: menu_tnormal ( title normalflag -- ) + intin 2 array! &33 2 1 1 menuAES ?menuerror ; + +\ title is the title# +\ normalflag = 0 is title reverse, = 1 is title normal + + +\ *** Block No. 12 Hexblock C +\ menu_text menu_register 02nov86we + +: menu_text ( item laddr -- ) + addrin 4+ 2! intin ! &34 1 1 2 menuAES ?menuerror ; + +\ item is the menuitem# +\ laddr is the address of a 0-terminated replace-string + + +: menu_register ( apid laddr -- menuid ) + addrin 2! intin ! &35 1 1 1 AES dup 0< not ?menuerror ; + +\ apid is the application-ID from ACC's applinit +\ laddr is the address of a 0-terminated string for menutext +\ menuid is ACC's menu-identifier (0-5) + +\ *** Block No. 13 Hexblock D +\ Object Loadscreen 01feb86we + +Onlyforth GEM also definitions + + 1 3 +thru + + + + + + + + + + + +\ *** Block No. 14 Hexblock E +\ objc_tree objcAES objc_add objc_delete 06aug86we + +| : ?objcerror ( flag -- ) 0= abort" Object-Error" ; + +| : objcAES ( opcode #intin #intout #addrin -- intout@ ) + objc_tree 2@ addrin 2! 1 AES ; + +: objc_add ( parent child -- ) + intin 2 array! &40 2 1 objcAES ?objcerror ; + +: objc_delete ( object -- ) + intin ! &41 1 1 objcAES ?objcerror ; + + + + +\ *** Block No. 15 Hexblock F +\ objc_draw objc_find objc_offset bp 12oct86 + +: objc_draw ( startob depth x y width height -- ) + intin 6 array! &42 6 1 objcAES ?objcerror ; + +: objc_find ( startob depth x y -- obnum ) + intin 4 array! &43 4 1 objcAES ; + +: objc_offset ( object -- x y ) + intin ! &44 1 3 objcAES ?objcerror + intout 2+ @ intout 4+ @ ; + + + + + +\ *** Block No. 16 Hexblock 10 +\ objc_order objc_edit objc_change 02feb86we + +: objc_order ( object newpos -- ) + intin 2 array! &45 2 1 objcAES ?objcerror ; + +: objc_edit ( object char index kind -- newindex ) + intin 4 array! &46 4 2 objcAES ?objcerror intout 2+ @ ; + +: objc_change ( object x y width height newstate redraw -- ) + intin 4+ 6 array! intin ! intin 2+ off + &47 8 1 objcAES ?objcerror ; + + + + + +\ *** Block No. 17 Hexblock 11 +\ Object Loadscreen 09aug86we + +Onlyforth GEM also definitions + 1 2 +thru + + + + + + + + + + + + +\ *** Block No. 18 Hexblock 12 +\ form_do form_dial bp 12oct86 + +: form_do ( startobj -- objectno ) + intin ! objc_tree 2@ addrin 2! &50 1 1 1 AES ; + +: form_dial ( diflag lix liy liw lih bix biy biw bih ) + intin 9 array! &51 9 1 0 AES drop ; +\ li means little bi means big + + + + + + + + +\ *** Block No. 19 Hexblock 13 +\ form_alert form_error form_center 07a09sep86we + +: form_alert ( defbttn 0string -- exbttn ) + >absaddr addrin 2! intin ! &52 1 1 1 AES ; + +: form_error ( enum -- exbttn ) + intin ! &53 1 1 0 AES ; + +: form_center ( -- x y width height ) + objc_tree 2@ addrin 2! &54 0 5 1 AES drop intout 2+ 4@ ; + + + + + + +\ *** Block No. 20 Hexblock 14 +\ form_alert tests bp 12oct86 + +: test ( -- button ) + 2 0" [1][Dies ist ein Test!|2.Zeile][OK|JA|NEIN]" + form_alert ; + + + + + + + + + + + +\ *** Block No. 21 Hexblock 15 +\ Graphics Loadscreen 02feb86we + +Onlyforth GEM also definitions + + 1 4 +thru + + + + + + + + + + + +\ *** Block No. 22 Hexblock 16 +\ graf_dragbox graf_movebox 06aug86we + +| : ?graferror ( flag -- ) 0= abort" Graphic-Error" ; + +: graf_dragbox + ( startx starty width height boundx boundy boundw boundh -- + finishx finishy ) + intin 8 + 4 array! intin 2 array! intin 4+ 2 array! + &71 8 3 0 AES ?graferror intout 2+ @ intout 4+ @ ; + +: graf_movebox + ( sourcex sourcey width height destx desty -- ) + intin 8 + 2 array! intin 2 array! intin 4+ 2 array! + &72 6 1 0 AES ?graferror ; + + +\ *** Block No. 23 Hexblock 17 +\ graf_growbox graf_shrinkbox 06aug86we + +: graf_growbox ( stx sty stw sth fix fiy fiw fih -- ) + intin 8 array! &73 8 1 0 AES ?graferror ; + +: graf_shrinkbox ( fix fiy fiw fih stx sty stw sth -- ) + intin 8 array! &74 8 1 0 AES ?graferror ; + +\ st means start fi means finish + + + + + + + +\ *** Block No. 24 Hexblock 18 +\ graf_watchbox graf_slidebox bp 12oct86 + +: graf_watchbox ( object instate outstate -- inside/outside ) + objc_tree 2@ addrin 2! intin 2+ 3 array! + &75 4 1 1 AES ; + +: graf_slidebox ( parent object vhflag -- vhpos ) + objc_tree 2@ addrin 2! intin 3 array! + &76 3 1 1 AES ; + + +\\ graf_handle is defined in BASICS.SCR ! + + + + +\ *** Block No. 25 Hexblock 19 +\ graf_mouse graf_mkstate bp 12oct86 + +2Variable mofaddr 0. mofaddr 2! + +: graf_mouse ( mouseform -- ) + intin ! mofaddr 2@ addrin 2! &78 1 1 1 AES ?graferror ; + +: graf_mkstate ( -- ) &79 0 5 0 AES drop ; + +\ Werte in intout + + + + + + +\ *** Block No. 26 Hexblock 1A +\ File Selection Loadscreen bp 11oct86 + +Onlyforth +GEM also definitions + +1 +load + +\\ + +: test ( -- button ) + show_c inpath &30 erase name count inpath place + insel $10 erase name count insel place + fs_label &30 erase name count fs_label place + fsel_exinput hide_c ; + +test A:\GEM\*.SCR AES.SCR Dies_ist_eine_Textbox! +\ *** Block No. 27 Hexblock 1B +\ File Selection bp 11oct86 + +Create inpath ," \*.SCR" here &30 allot &30 erase +Create insel here $10 allot $10 erase + +| : count? ( addr -- ) + dup 1+ BEGIN count 0= UNTIL over - 2- swap c! ; + +: fsel_input ( -- button ) + inpath 1+ >absaddr addrin 2! insel 1+ >absaddr addrin 4+ 2! + &90 0 2 2 AES 0= abort" File Error" + inpath count? insel count? intout 2+ @ ; + --> +\\ button = 0 is ABBRUCH, = 1 is OK; the returned strings + are in inpath and insel (counted and 0-terminated) + +\ *** Block No. 28 Hexblock 1C +\ File selection mit FSEL_EXINPUT 13jan90 m.bitter + +Create fs_label ," May the volks4TH be with you!" 0 c, + +: fsel_exinput ( -- button ) + inpath 1+ >absaddr addrin 2! insel 1+ >absaddr addrin 4+ 2! + fs_label 1+ >absaddr addrin 8 + 2! + &91 0 2 3 AES 0= abort" File Error" + inpath count? insel count? intout 2+ @ ; + + + + +\\ button = 0 is ABBRUCH, = 1 is OK; the returned strings + are in inpath and insel (counted and 0-terminated) + +\ *** Block No. 29 Hexblock 1D +\ Windows Loadscreen 28jan86we + +Onlyforth GEM also definitions + + 1 4 +thru + + + + + + + + + + + +\ *** Block No. 30 Hexblock 1E +\ windows 21aug86we + +| : ?winderror ( flag -- ) 0= abort" Window-Error" ; + +: wind_create + ( components leftX topY maxWidth maxHeight -- handle ) + intin 5 array! &100 5 1 0 AES dup 0> ?winderror ; + +\\ component bits set mean: + + $0001 title bar $0002 close box + $0004 full box $0008 move bar + $0010 info line $0020 size box + $0040 up arrow $0080 down arrow + $0100 vertical slider $0200 left arrow + $0400 right arrow $0800 horizontal slider +\ *** Block No. 31 Hexblock 1F +\ windows 06aug86we + +: wind_open ( W-handle leftX topY width heigth -- ) + intin 5 array! &101 5 1 0 AES ?winderror ; + + + + + + + + + + + + +\ *** Block No. 32 Hexblock 20 +\ windows 06aug86we + +: wind_close ( Whandle -- ) + intin ! &102 1 1 0 AES ?winderror ; + +: wind_delete ( Whandle -- ) + intin ! &103 1 1 0 AES ?winderror ; + +: wind_get ( Whandle funktion# -- ) + intin 2 array! &104 2 5 0 AES ?winderror ; + +: wind_set ( Whandle funktion# par0 par1 par2 par3 -- ) + intin 6 array! &105 6 1 0 AES ?winderror ; + +: wind_find ( mouseX mouseY -- Whandle ) + intin 2 array! &106 2 1 0 AES ; +\ *** Block No. 33 Hexblock 21 +\ windows 06aug86we + +: wind_update ( funktion# -- ) + intin ! &107 1 1 0 AES ?winderror ; + +: wind_calc ( 0/1 components leftX topY width heigth -- ) + intin 6 array! &108 6 5 0 AES ?winderror ; + + + + + + + + + +\ *** Block No. 34 Hexblock 22 +\ window test 02feb86we + + $0FEF &0 &20 &600 &300 wind_create Constant wtesthandle + +: windowtest page + wtesthandle 1 &20 &500 &300 wind_open + $20 0 DO wtesthandle 5 1 &20 &500 I - &300 I - wind_set + 2 +LOOP + ." Hit any key to continue " key drop + wtesthandle wind_close ; + +: end wtesthandle wind_delete ; + + + + +\ *** Block No. 35 Hexblock 23 +\ RSRC Loadscreen 21nov86we + +Onlyforth GEM also definitions + +\needs 0" include strings.scr + + +1 4 +thru + + + + + + + + +\ *** Block No. 36 Hexblock 24 +\ RSRC words bp 12oct86 + +| : ?rsrcerror ( f -- ) 0= abort" Resource-Error" ; + +: rsrc_load ( 0$ -- ) \ needs address of 0-terminated $ + >absaddr addrin 2! &110 0 1 1 AES ?rsrcerror ; + +: rsrc_load" [compile] 0" compile rsrc_load ; + immediate restrict + + + + + + + +\ *** Block No. 37 Hexblock 25 +\ rsrc_gaddr 20aug86mawe + +: rsrc_free ( -- ) &111 0 1 0 AES ?rsrcerror ; + +: rsrc_gaddr ( type index -- laddr ) + intin 2 array! &112 2 1 0 AES ?rsrcerror addrout 2@ ; + +\\ type is one of the following: + 0 tree 1 object 2 tedinfo 3 iconblk + 4 bitblk 5 string 6 imagedata 7 obspec + 8 te_ptext 9 te_ptmplt $A te_pvalid $B ib_pmask +$C ib_pdata $D ib_ptext $E bi_pdata $F ad_frstr +$10 ad_frimg +index is the index of the data structure +laddr is the long (double) address of the data structure + specified by type and index +\ *** Block No. 38 Hexblock 26 +\ rsrc_saddr 06aug86we + +: rsrc_saddr ( type index laddr --) + addrin 2! intin 2 array! &113 2 1 1 AES ?rsrcerror ; + +\\ for type index and f see rsrc_gaddr + laddr is the address of a data structure + + + + + + + + + +\ *** Block No. 39 Hexblock 27 +\ rsrc_obfix 06aug86we + +: rsrc_obfix ( index laddr --) + addrin 2! intin ! &114 1 1 1 AES drop ; + +\ index is index of object +\ laddr is addr of tree that contains object + + + + + + + + + diff --git a/sources/AtariST/GEM/BASICS.FB.src b/sources/AtariST/GEM/BASICS.FB.src deleted file mode 100644 index cbccfee..0000000 --- a/sources/AtariST/GEM/BASICS.FB.src +++ /dev/null @@ -1,170 +0,0 @@ -Screen 0 not modified - 0 \\ *** GEM - Basics *** 26may86we - 1 - 2 Die Routinen in dieser Library entsprechen dem, was auch dem - 3 Pascal-, C- oder Modula-Programmierer zur Verfgung steht. - 4 Fr eine genaue Beschreibung der einzelnen Routinen verweisen - 5 wir auf die GEM-Dokumentation des ST-Entwicklungspaketes bzw. - 6 entsprechende Literatur. - 7 - 8 Aus diesem Grunde wurden die - teilweise kryptischen - Namen - 9 von Digital Research beibehalten; auch die šbergabeparameter -10 der einzelnen Funktionen sind unver„ndert geblieben. -11 Der Aufbau einer FORTH-Library mit 'Super-Befehlen' ist in -12 Arbeit. -13 -14 Die Worte in diesem File werden sowohl fr VDI- als auch fr -15 AES-Funktionen ben”tigt. -Screen 1 not modified - 0 \ VDI GEM Arrays and Controls Loadscreen 02nov86we - 1 - 2 Onlyforth - 3 - 4 \needs >absaddr : >absaddr 0 forthstart d+ ; - 5 \needs Code 2 loadfrom assemble.scr - 6 - 7 Vocabulary GEM GEM definitions also - 8 - 9 1 8 +thru -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ VDI GEM Arrays 05aug86we - 1 - 2 Create intin &60 allot Create ptsin &256 allot - 3 Create intout &90 allot Create ptsout &24 allot - 4 Create addrin 8 allot Create addrout 4 allot - 5 Variable grhandle - 6 - 7 | : gemconstant ( addr n -- addr+n) over Constant + ; - 8 - 9 Create contrl $16 allot -10 contrl 2 gemconstant opcode -11 2 gemconstant #intin -12 2 gemconstant #intout ' #intout Alias #ptsout -13 2 gemconstant #addrin -14 2 gemconstant #addrout -15 2 gemconstant function drop -Screen 3 not modified - 0 \ global array, Parameter blocks 02nov86we - 1 - 2 Create global $20 allot - 3 global &10 + Constant ap_ptree - 4 - 5 | : gemarray ( n0 ... nk-1 k --) Create 0 ?DO , LOOP ; - 6 - 7 addrout addrin intout intin global contrl 6 gemarray (AESpb - 8 ptsout intout ptsin intin contrl 5 gemarray (VDIpb - 9 -10 Create AESpb &24 allot Create VDIpb &20 allot -11 -12 : setarrays -13 6 0 DO (AESpb I 2* + @ >absaddr AESpb I 2* 2* + 2! LOOP -14 5 0 DO (VDIpb I 2* + @ >absaddr VDIpb I 2* 2* + 2! LOOP ; -15 -Screen 4 not modified - 0 \ Array-Handling 09sep86we - 1 - 2 Code array! ( n0 ... nk-1 adr k --) - 3 SP )+ D0 move SP )+ D6 move D6 reg) A0 lea - 4 D0 A0 adda D0 A0 adda 1 D0 subq - 5 D0 DO SP )+ A0 -) move LOOP Next end-code - 6 - 7 Code 4! ( n1 .. n4 addr -- ) - 8 SP )+ D6 move 8 D6 addq D6 reg) A0 lea 3 # D0 move - 9 D0 DO SP )+ A0 -) move LOOP Next end-code -10 -11 Code 4@ ( addr -- n1 .. n4 ) -12 SP )+ D6 move D6 reg) A0 lea 3 # D0 move -13 D0 DO A0 )+ SP -) move LOOP Next end-code -14 -15 -Screen 5 not modified - 0 \ AES-Aufruf 09sep86we - 1 - 2 Code AES ( opcode #intin #intout #addrin -- intout@ ) - 3 SP )+ contrl 6 + R#) move \ #addrin - 4 SP )+ contrl 4 + R#) move \ #intout - 5 SP )+ contrl 2+ R#) move \ #intin - 6 SP ) D0 move SP )+ contrl R#) move \ opcode - 7 contrl 8 + R#) clr \ #addrout - 8 &112 D0 cmpi \ Funktions-Nr. von rsrc_gaddr - 9 0= IF 1 # contrl 8 + R#) move THEN -10 AESpb # D6 move D6 reg) A0 lea A0 D1 lmove -11 .w $C8 # D0 move 2 trap -12 intout R#) SP -) move Next end-code -13 -14 -15 -Screen 6 not modified - 0 \ VDI-Aufruf 09sep86we - 1 - 2 Code VDI ( opcode #ptsin #intin --) - 3 SP )+ contrl 6 + R#) move - 4 SP )+ contrl 2+ R#) move SP )+ contrl R#) move - 5 grhandle R#) contrl &12 + R#) move - 6 VDIpb # D6 move D6 reg) A0 lea A0 D1 lmove - 7 $73 D0 moveq 2 trap - 8 Next end-code - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ appl_init appl_exit graf_handle bp 12oct86 - 1 - 2 : appl_init global &14 + $10 erase &10 0 1 0 AES drop ; - 3 : appl_exit &19 0 1 0 AES drop ; - 4 - 5 - 6 | : sizeconstant ( addr n -- addr+n@ ) - 7 over Create , + Does> @ @ ; - 8 - 9 Create sizes 8 allot $08 $10 $13 $13 sizes 4! -10 sizes 2 sizeconstant cwidth 2 sizeconstant cheight -11 2 sizeconstant bwidth 2 sizeconstant bheight drop -12 -13 : graf_handle &77 0 5 0 AES grhandle ! -14 intout 2+ sizes 8 cmove ; -15 -Screen 8 not modified - 0 \ opnvwk clrwk clsvwk updwk 02nov86we - 1 - 2 : opnvwk - 3 intin &10 0 DO 1 over I 2* + ! LOOP drop - 4 2 intin &20 + ! &100 0 &11 VDI - 5 contrl &12 + @ grhandle ! ; - 6 - 7 : clrwk 3 0 0 VDI ; - 8 : clsvwk &101 0 0 VDI ; - 9 -10 : updwk 4 0 0 VDI ; -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ s_clip grinit grexit show_c hide_c 02nov86we - 1 - 2 : s_clip ( x1 y1 x2 y2 clipflag -- ) - 3 intin ! ptsin 4 array! &129 2 1 VDI ; - 4 - 5 : grinit setarrays appl_init graf_handle opnvwk ; - 6 : grexit clsvwk appl_exit ; - 7 - 8 2Variable objc_tree 0. objc_tree 2! - 9 -10 Variable c_flag c_flag off -11 : show_c ( -- ) c_flag @ intin ! &122 0 1 VDI ; -12 : hide_c ( -- ) &123 0 0 VDI ; -13 -14 \\ st_load_fonts st_unload_fonts -15 w„r auch ganz hbsch, hamse aber nich! diff --git a/sources/AtariST/GEM/BASICS.fth b/sources/AtariST/GEM/BASICS.fth new file mode 100644 index 0000000..4b304d4 --- /dev/null +++ b/sources/AtariST/GEM/BASICS.fth @@ -0,0 +1,170 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** GEM - Basics *** 26may86we + +Die Routinen in dieser Library entsprechen dem, was auch dem +Pascal-, C- oder Modula-Programmierer zur Verfgung steht. +Fr eine genaue Beschreibung der einzelnen Routinen verweisen +wir auf die GEM-Dokumentation des ST-Entwicklungspaketes bzw. +entsprechende Literatur. + +Aus diesem Grunde wurden die - teilweise kryptischen - Namen +von Digital Research beibehalten; auch die šbergabeparameter +der einzelnen Funktionen sind unver„ndert geblieben. +Der Aufbau einer FORTH-Library mit 'Super-Befehlen' ist in +Arbeit. + +Die Worte in diesem File werden sowohl fr VDI- als auch fr +AES-Funktionen ben”tigt. +\ *** Block No. 1 Hexblock 1 +\ VDI GEM Arrays and Controls Loadscreen 02nov86we + +Onlyforth + +\needs >absaddr : >absaddr 0 forthstart d+ ; +\needs Code 2 loadfrom assemble.scr + +Vocabulary GEM GEM definitions also + + 1 8 +thru + + + + + + +\ *** Block No. 2 Hexblock 2 +\ VDI GEM Arrays 05aug86we + +Create intin &60 allot Create ptsin &256 allot +Create intout &90 allot Create ptsout &24 allot +Create addrin 8 allot Create addrout 4 allot +Variable grhandle + +| : gemconstant ( addr n -- addr+n) over Constant + ; + +Create contrl $16 allot +contrl 2 gemconstant opcode + 2 gemconstant #intin + 2 gemconstant #intout ' #intout Alias #ptsout + 2 gemconstant #addrin + 2 gemconstant #addrout + 2 gemconstant function drop +\ *** Block No. 3 Hexblock 3 +\ global array, Parameter blocks 02nov86we + +Create global $20 allot +global &10 + Constant ap_ptree + +| : gemarray ( n0 ... nk-1 k --) Create 0 ?DO , LOOP ; + +addrout addrin intout intin global contrl 6 gemarray (AESpb + ptsout intout ptsin intin contrl 5 gemarray (VDIpb + +Create AESpb &24 allot Create VDIpb &20 allot + +: setarrays + 6 0 DO (AESpb I 2* + @ >absaddr AESpb I 2* 2* + 2! LOOP + 5 0 DO (VDIpb I 2* + @ >absaddr VDIpb I 2* 2* + 2! LOOP ; + +\ *** Block No. 4 Hexblock 4 +\ Array-Handling 09sep86we + +Code array! ( n0 ... nk-1 adr k --) + SP )+ D0 move SP )+ D6 move D6 reg) A0 lea + D0 A0 adda D0 A0 adda 1 D0 subq + D0 DO SP )+ A0 -) move LOOP Next end-code + +Code 4! ( n1 .. n4 addr -- ) + SP )+ D6 move 8 D6 addq D6 reg) A0 lea 3 # D0 move + D0 DO SP )+ A0 -) move LOOP Next end-code + +Code 4@ ( addr -- n1 .. n4 ) + SP )+ D6 move D6 reg) A0 lea 3 # D0 move + D0 DO A0 )+ SP -) move LOOP Next end-code + + +\ *** Block No. 5 Hexblock 5 +\ AES-Aufruf 09sep86we + +Code AES ( opcode #intin #intout #addrin -- intout@ ) + SP )+ contrl 6 + R#) move \ #addrin + SP )+ contrl 4 + R#) move \ #intout + SP )+ contrl 2+ R#) move \ #intin + SP ) D0 move SP )+ contrl R#) move \ opcode + contrl 8 + R#) clr \ #addrout + &112 D0 cmpi \ Funktions-Nr. von rsrc_gaddr + 0= IF 1 # contrl 8 + R#) move THEN + AESpb # D6 move D6 reg) A0 lea A0 D1 lmove + .w $C8 # D0 move 2 trap + intout R#) SP -) move Next end-code + + + +\ *** Block No. 6 Hexblock 6 +\ VDI-Aufruf 09sep86we + +Code VDI ( opcode #ptsin #intin --) + SP )+ contrl 6 + R#) move + SP )+ contrl 2+ R#) move SP )+ contrl R#) move + grhandle R#) contrl &12 + R#) move + VDIpb # D6 move D6 reg) A0 lea A0 D1 lmove + $73 D0 moveq 2 trap + Next end-code + + + + + + + +\ *** Block No. 7 Hexblock 7 +\ appl_init appl_exit graf_handle bp 12oct86 + +: appl_init global &14 + $10 erase &10 0 1 0 AES drop ; +: appl_exit &19 0 1 0 AES drop ; + + +| : sizeconstant ( addr n -- addr+n@ ) + over Create , + Does> @ @ ; + +Create sizes 8 allot $08 $10 $13 $13 sizes 4! +sizes 2 sizeconstant cwidth 2 sizeconstant cheight + 2 sizeconstant bwidth 2 sizeconstant bheight drop + +: graf_handle &77 0 5 0 AES grhandle ! + intout 2+ sizes 8 cmove ; + +\ *** Block No. 8 Hexblock 8 +\ opnvwk clrwk clsvwk updwk 02nov86we + +: opnvwk + intin &10 0 DO 1 over I 2* + ! LOOP drop + 2 intin &20 + ! &100 0 &11 VDI + contrl &12 + @ grhandle ! ; + +: clrwk 3 0 0 VDI ; +: clsvwk &101 0 0 VDI ; + +: updwk 4 0 0 VDI ; + + + + + +\ *** Block No. 9 Hexblock 9 +\ s_clip grinit grexit show_c hide_c 02nov86we + +: s_clip ( x1 y1 x2 y2 clipflag -- ) + intin ! ptsin 4 array! &129 2 1 VDI ; + +: grinit setarrays appl_init graf_handle opnvwk ; +: grexit clsvwk appl_exit ; + +2Variable objc_tree 0. objc_tree 2! + +Variable c_flag c_flag off +: show_c ( -- ) c_flag @ intin ! &122 0 1 VDI ; +: hide_c ( -- ) &123 0 0 VDI ; + +\\ st_load_fonts st_unload_fonts + w„r auch ganz hbsch, hamse aber nich! diff --git a/sources/AtariST/GEM/GEMDEFS.FB.src b/sources/AtariST/GEM/GEMDEFS.FB.src deleted file mode 100644 index b4ad7fb48f4c93a155d26c7835ad7d2c3a15a5f2..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6690 zcmeHLZExE)5Z-6~iW_DGE4CJv^HNs>wib!IWys60X6uJ#5M+stiAbbJQE{_h-#dx4 zDN8|9h5c53F^@+ckH@=55B)Axj0qTnkQxe^@dalYPz!KySevgPeD!;kPmcl!hna9z z1u$`>Vch`shb?qg1#sX}`gb19%mQYFi8Y};N=tG7Rv zsh%FKnJ;L$6#4x^D!puN^LW7*v@DrokKeUB(?ZMWXgr2xlIMu$*p@6=LAHW#yDPdQ zKA|Oo@9=V)J&vU)bs{wIqF@z;qsat)Xrm>&S|8-Eh56`xlc{Xocp_oo*p@$sLtH&?TIB2Bi9{Hvj5G!C0I zi9}NLAjD`qG5R!@WoJUoT1MjoGiOodSS-73G@crLA@4dS&=33?jPNsCS9HY1Lhf2X z{lw}^{(qkhWG$luJEy{{QFue`Hkw*}CVKS5TF?zU=dR3ow!0I$VfFc<*T$6GuyYjF zamNpI!|IoPd-#HuYjf*h(sh#_z{P(R$M3-+Pi~rAX_DpF*_B;`kt1jcVK01HUrc{) zN9#p=i`i!bO|qLv1T8e?UMk6Jsct{quj{WO$!VpOE3Xv0vvPo}h2~Il*)fvc;F0WJ z7|B|$tXp`NgT@9|r8Y)rj$j|GSnCxl@9be3{W@diZEc63g~n)Kn}Q_MzOGz0#ALI# z+X)P7*?$OHHb_FS!tR(rg!xqa63|iu1#aAc$eXiclPnG9SQzR1C2t8@OpdS9crI1O zRJ3ypgFC3FWZ2b`4G%;Up~aQ~0_C}Z=^vqF7~c849cdyB=tTQO%~_7H2yDd`A}(3Z zQf;2GJBNBe^z|UxLlm^Wd^#_>&JeUj>mpVxQ;C5`lCe})_CO@pSa0fpWGX$Yrw0*@ z)yQTBNv_M$Y)Numj*d*YZA*)wh33%rz>bkD*xIey?g5+;pRC0(``KNBmZvtKtmWWA zXyIl0;xj${V$ec$hQ6Htb#`?c&;FiWTv>o=SD+&`t`oFuNlQ`1x9omybI6=-OIlEm zgh=E2&us)PThfAaithW|AuXuyzP*XHY)K2*U`PSoU0l+Fdd&-_+In9Pq7B4ROy5dX zzEN=vucZ}_b6Fv8MM7NkhrouS{x$JH)-uMJJSiT;T6Wl9q>*mKsVYq#L`x~y zeLQD|W=1Q?g^ri>?Wb0=79?rT5JY;(1=^5hb5kUzx7&e8Ryubk5VY(~4iB+xHphuD zA}ZdzpCKw@xiF7u+LvUvVk~Pp?1vUw@|5Q5zm})?Kx=*d*Yb2fJp4WO^>5tPHTZ&- OmeB#iSJu)FTJRBx7l|?uQGVf?e;!`{ zs4o(AcDiKU@!j(LX(FVWdhTD+?T%o|BzwtbN zaFr=0;~e1b{pbdM^gL`h@O01WY6oTu@7>kOh=;h~& zTYyU&maE&_-_{^EeRvL63=73_0F6=Hb^0Gxwq+XB1DQ*){=Ay;Vt8ULrskkBW2{9tmzB*m|zJDU*{tY82KgYWe*w5M*k zoJ2EBF&9~q{e%fC1D;7EaaFAr<-IQ+@9Kf}u+V7xb7|-#O8!@590-!;8dJ6|Dwkdd2vYaJ~xr}J+rd8~IR}YZS z9E#7M|0W2`(*hGYm9Zr{lJO?Y-9AXxWNr6FGTkhv*A6sI*%30(SIsU)vc77bOx)|@ zq#Y2Oy8)WO+0ws`o4CD^?m_gNZPooBAZW71am^OTnk}+2dHur8{ReD8_YF~8|8aG9 z8IArN-P}3OXrl=|WNUw@*6sEr3D%k17D~6UTJ~) z;f9{R?5_4e1BR8^x=meL-~uWum|WL)&yxF^g8<$MS-^G7u|SmGBNIuWC6opUQm%=? zHcUY-f^br#k$E?0ms)y%vd83`_~R zeGD2!S*Wlsh!R=a^A4wiv!`gxZ0Q%yMaES$rSCK~3}PO8GK6ZHadaR`gNfv1Ru6=t zQn_ak91KrR@F_%3QavNYD9C8_K!vb~#KgW|?Oc19OXlPqa^4XaE2J literal 0 HcmV?d00001 diff --git a/sources/AtariST/GEM/SUPERGEM.FB.src b/sources/AtariST/GEM/SUPERGEM.FB.src deleted file mode 100644 index 6f3bc8b..0000000 --- a/sources/AtariST/GEM/SUPERGEM.FB.src +++ /dev/null @@ -1,272 +0,0 @@ -Screen 0 not modified - 0 \\ *** SUPERGEM.SCR *** 16sep86we - 1 - 2 In diesem File soll eine GEM-Library aufgebaut werden, die - 3 komfortablere Routinen als die Standardbefehle mit Ihren un- - 4 bersehbaren Parametern zur Verfgung stellt. - 5 - 6 Bei der Entwicklung des Editors sind bereits einige solche - 7 Routinen entstanden. - 8 - 9 Fr Anregungen gerade in diesem Bereich sind wir dankbar.... -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ GEM-Library Loadscreen cas20130105 - 1 - 2 Onlyforth GEM also - 3 - 4 \needs scr>mem $10 loadfrom gem\vdi.fb - 5 - 6 Onlyforth GEM also definitions - 7 - 8 1 4 +thru - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ Resource Trees and objects 02sep86we - 1 - 2 : tree! ( tree -- ) - 3 0 swap rsrc_gaddr objc_tree 2! ; - 4 - 5 : objc_gaddr ( object# -- laddr ) - 6 &24 * extend objc_tree 2@ d+ ; - 7 - 8 : text_gaddr ( object# -- laddr ) - 9 objc_gaddr &12 extend d+ l2@ l2@ ; -10 -11 : alert ( n -- button ) -12 show_c -13 5 swap rsrc_gaddr addrin 2! 1 intin ! &52 1 1 1 AES -14 hide_c ; -15 -Screen 3 not modified - 0 \ Move text to Objects and back 02nov86we - 1 - 2 : putstring ( addr object# -- ) >r - 3 count under >r >absaddr r> r@ text_gaddr rot lcmove - 4 0 swap extend r> text_gaddr d+ lc! ; - 5 - 6 : getstring ( object# addr -- ) >r text_gaddr - 7 0 BEGIN >r 2dup r@ extend d+ lc@ WHILE r> 1+ REPEAT r> - 8 r> 2dup c! 1+ >absaddr rot lcmove ; - 9 -10 : getnumber ( object# -- d ) -11 pad getstring pad count bl skip swap 1- dup >r c! -12 r@ capitalize c@ IF r> number ELSE rdrop 0 0 THEN ; -13 -14 : putnumber ( d object# -- ) >r -15 <# #s #> over 1- c! 1- r> putstring ; -Screen 4 not modified - 0 \ init_object select deselect 02nov86we - 1 - 2 Create little &320 , &200 , &10 , &10 , - 3 Create big 8 allot - 4 - 5 : init_object ( -- ) - 6 &320 &200 &10 &10 little 4! form_center big 4! ; - 7 - 8 : state_gaddr ( object -- laddr ) objc_gaddr &10. d+ ; - 9 -10 : select ( object -- ) 1 swap state_gaddr l! ; -11 : deselect ( object -- ) 0 swap state_gaddr l! ; -12 -13 -14 -15 -Screen 5 not modified - 0 \ show_object hide_object objc_setpos objc_getwh 12aug86we - 1 - 2 : show_object ( -- ) init_object - 3 big 4@ scr>mem1 1 little 4@ big 4@ form_dial - 4 0 ( install) 3 ( depth) big 4@ objc_draw show_c ; - 5 - 6 : hide_object ( -- ) hide_c - 7 2 little 4@ big 4@ form_dial big 4@ mem1>scr ; - 8 - 9 : objc_setpos ( x y object# -- ) -10 dup >r objc_gaddr $0.12 d+ l! r> objc_gaddr $0.10 d+ l! ; -11 -12 : objc_getwh ( object# -- width height ) -13 dup objc_gaddr $0.14 d+ l@ swap objc_gaddr $0.16 d+ l@ ; -14 -15 -Screen 6 not modified - 0 \ - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ GEM-Library Loadscreen 16sep86we - 1 - 2 nimmt GEM in die Suchordnung auf (Fehlermeldung, falls nicht - 3 vorhanden) - 4 wird fr die Rasteroperationen gebraucht, die den Bildschirm- - 5 inhalt schnell restaurieren. - 6 Alle folgenden Definitionen werden Bestandteil des Vokabulars - 7 GEM - 8 falls die Mausroutinen noch nicht vorhanden sind. - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ Resource Trees and objects 16sep86we - 1 - 2 speichert die Kennummer eines Trees in der FORTH-internen - 3 Variablen objc_tree ab. Muž immer vor der weiteren Arbeit mit - 4 Objekten geschehen. - 5 liefert die 32-Bit-Adresse des Objekts mit der Nummer object#. - 6 tree! muž vorher aufgerufen worden sein. - 7 - 8 laddr ist die 32-Bit-Adresse des 0-terminated Strings mit der - 9 Objektnummer object#. -10 -11 n ist die Objektnummer der Alertbox, button ist der vom Benutzer -12 bet„tigte Knopf. Die Maus wird vorher eingeschaltet und hinter- -13 her gl”scht. -14 -15 -Screen 11 not modified - 0 \ Move text to Objects and back 16sep86we - 1 - 2 addr ist die Adresse eines 0-terminated Strings innerhalb des - 3 FORTH-Systems. Dieser wird in das Objekt object# transportiert. - 4 - 5 - 6 Der Text im Objekt object# wird nach addr transportiert. - 7 - 8 - 9 -10 wie oben, jedoch wir der String in eine doppelt genaue Zahl -11 gewandelt. Ist der String leer wird 0.0 zurckgegeben. Ein -12 Abbruch erfolgt, wenn der String nicht gewandelt werden kann. -13 -14 wandelt die doppelt genaue Zahl d in einen 0-terminated String -15 und transportiert ihn in das Objekt object#. -Screen 12 not modified - 0 \ init_object select deselect 16sep86we - 1 - 2 little beschreibt ein kleines Rechteck in Bildschirmmitte. - 3 big beschreibt ein Rechteck in der Gr”že des Objekts. - 4 - 5 initialisiert little und big auf die Gr”žen des darzustellenden - 6 Objekts. Die Koordinaten des Objekts werden in der Resource (!) - 7 so ge„ndert, daž es auf dem Bildschirm zentriert erscheint. - 8 laddr ist die Langadresse des Statuswortes des Objekts object#. - 9 setzt den Status des Objekts object# auf selected (revers). -10 setzt den Status des Objekts object# auf deselected (normal). -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ show_object hide_object objc_setpos objc_getwh 16sep86we - 1 - 2 zeichnet das Objekt auf dem Bildschirm und rettet den Hinter- - 3 grund. Die Treenummer des Objekts muž mit tree! gesetzt sein. - 4 Das Objekt wird mit (bis zu) drei Unterebenen gezeichnet. - 5 Die Maus wird eingeschaltet. - 6 entfernt das Objekt vom Bildschirm und restauriert den Hinter- - 7 grund. - 8 - 9 x und y sind die Koordinaten der oberen rechten Ecke, an der -10 das Objekt object# auf dem Bildschirm erscheinen soll. -11 -12 width und height sind Breite und H”he des Objekts object#. -13 -14 -15 -Screen 14 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/GEM/SUPERGEM.fth b/sources/AtariST/GEM/SUPERGEM.fth new file mode 100644 index 0000000..b40c328 --- /dev/null +++ b/sources/AtariST/GEM/SUPERGEM.fth @@ -0,0 +1,272 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** SUPERGEM.SCR *** 16sep86we + +In diesem File soll eine GEM-Library aufgebaut werden, die +komfortablere Routinen als die Standardbefehle mit Ihren un- +bersehbaren Parametern zur Verfgung stellt. + +Bei der Entwicklung des Editors sind bereits einige solche +Routinen entstanden. + +Fr Anregungen gerade in diesem Bereich sind wir dankbar.... + + + + + + +\ *** Block No. 1 Hexblock 1 +\ GEM-Library Loadscreen cas20130105 + +Onlyforth GEM also + +\needs scr>mem $10 loadfrom gem\vdi.fb + +Onlyforth GEM also definitions + +1 4 +thru + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ Resource Trees and objects 02sep86we + +: tree! ( tree -- ) + 0 swap rsrc_gaddr objc_tree 2! ; + +: objc_gaddr ( object# -- laddr ) + &24 * extend objc_tree 2@ d+ ; + +: text_gaddr ( object# -- laddr ) + objc_gaddr &12 extend d+ l2@ l2@ ; + +: alert ( n -- button ) + show_c + 5 swap rsrc_gaddr addrin 2! 1 intin ! &52 1 1 1 AES + hide_c ; + +\ *** Block No. 3 Hexblock 3 +\ Move text to Objects and back 02nov86we + +: putstring ( addr object# -- ) >r + count under >r >absaddr r> r@ text_gaddr rot lcmove + 0 swap extend r> text_gaddr d+ lc! ; + +: getstring ( object# addr -- ) >r text_gaddr + 0 BEGIN >r 2dup r@ extend d+ lc@ WHILE r> 1+ REPEAT r> + r> 2dup c! 1+ >absaddr rot lcmove ; + +: getnumber ( object# -- d ) + pad getstring pad count bl skip swap 1- dup >r c! + r@ capitalize c@ IF r> number ELSE rdrop 0 0 THEN ; + +: putnumber ( d object# -- ) >r + <# #s #> over 1- c! 1- r> putstring ; +\ *** Block No. 4 Hexblock 4 +\ init_object select deselect 02nov86we + +Create little &320 , &200 , &10 , &10 , +Create big 8 allot + +: init_object ( -- ) + &320 &200 &10 &10 little 4! form_center big 4! ; + +: state_gaddr ( object -- laddr ) objc_gaddr &10. d+ ; + +: select ( object -- ) 1 swap state_gaddr l! ; +: deselect ( object -- ) 0 swap state_gaddr l! ; + + + + +\ *** Block No. 5 Hexblock 5 +\ show_object hide_object objc_setpos objc_getwh 12aug86we + +: show_object ( -- ) init_object + big 4@ scr>mem1 1 little 4@ big 4@ form_dial + 0 ( install) 3 ( depth) big 4@ objc_draw show_c ; + +: hide_object ( -- ) hide_c + 2 little 4@ big 4@ form_dial big 4@ mem1>scr ; + +: objc_setpos ( x y object# -- ) + dup >r objc_gaddr $0.12 d+ l! r> objc_gaddr $0.10 d+ l! ; + +: objc_getwh ( object# -- width height ) + dup objc_gaddr $0.14 d+ l@ swap objc_gaddr $0.16 d+ l@ ; + + +\ *** Block No. 6 Hexblock 6 +\ + + + + + + + + + + + + + + + +\ *** Block No. 7 Hexblock 7 +\ + + + + + + + + + + + + + + + +\ *** Block No. 8 Hexblock 8 + + + + + + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ GEM-Library Loadscreen 16sep86we + +nimmt GEM in die Suchordnung auf (Fehlermeldung, falls nicht + vorhanden) +wird fr die Rasteroperationen gebraucht, die den Bildschirm- + inhalt schnell restaurieren. +Alle folgenden Definitionen werden Bestandteil des Vokabulars + GEM +falls die Mausroutinen noch nicht vorhanden sind. + + + + + + + +\ *** Block No. 10 Hexblock A +\ Resource Trees and objects 16sep86we + +speichert die Kennummer eines Trees in der FORTH-internen + Variablen objc_tree ab. Muž immer vor der weiteren Arbeit mit + Objekten geschehen. +liefert die 32-Bit-Adresse des Objekts mit der Nummer object#. + tree! muž vorher aufgerufen worden sein. + +laddr ist die 32-Bit-Adresse des 0-terminated Strings mit der + Objektnummer object#. + +n ist die Objektnummer der Alertbox, button ist der vom Benutzer + bet„tigte Knopf. Die Maus wird vorher eingeschaltet und hinter- + her gl”scht. + + +\ *** Block No. 11 Hexblock B +\ Move text to Objects and back 16sep86we + +addr ist die Adresse eines 0-terminated Strings innerhalb des + FORTH-Systems. Dieser wird in das Objekt object# transportiert. + + +Der Text im Objekt object# wird nach addr transportiert. + + + +wie oben, jedoch wir der String in eine doppelt genaue Zahl + gewandelt. Ist der String leer wird 0.0 zurckgegeben. Ein + Abbruch erfolgt, wenn der String nicht gewandelt werden kann. + +wandelt die doppelt genaue Zahl d in einen 0-terminated String + und transportiert ihn in das Objekt object#. +\ *** Block No. 12 Hexblock C +\ init_object select deselect 16sep86we + +little beschreibt ein kleines Rechteck in Bildschirmmitte. +big beschreibt ein Rechteck in der Gr”že des Objekts. + +initialisiert little und big auf die Gr”žen des darzustellenden + Objekts. Die Koordinaten des Objekts werden in der Resource (!) + so ge„ndert, daž es auf dem Bildschirm zentriert erscheint. +laddr ist die Langadresse des Statuswortes des Objekts object#. +setzt den Status des Objekts object# auf selected (revers). +setzt den Status des Objekts object# auf deselected (normal). + + + + + +\ *** Block No. 13 Hexblock D +\ show_object hide_object objc_setpos objc_getwh 16sep86we + +zeichnet das Objekt auf dem Bildschirm und rettet den Hinter- + grund. Die Treenummer des Objekts muž mit tree! gesetzt sein. + Das Objekt wird mit (bis zu) drei Unterebenen gezeichnet. + Die Maus wird eingeschaltet. +entfernt das Objekt vom Bildschirm und restauriert den Hinter- + grund. + +x und y sind die Koordinaten der oberen rechten Ecke, an der + das Objekt object# auf dem Bildschirm erscheinen soll. + +width und height sind Breite und H”he des Objekts object#. + + + +\ *** Block No. 14 Hexblock E + + + + + + + + + + + + + + + + +\ *** Block No. 15 Hexblock F + + + + + + + + + + + + + + + + diff --git a/sources/AtariST/GEM/VDI.FB.src b/sources/AtariST/GEM/VDI.FB.src deleted file mode 100644 index a152e76..0000000 --- a/sources/AtariST/GEM/VDI.FB.src +++ /dev/null @@ -1,714 +0,0 @@ -Screen 0 not modified - 0 \\ *** VDI -Funktionen *** 12aug86we - 1 - 2 Dieses File enth„lt alle VDI-Funktionen. - 3 - 4 Zur genaueren Beschreibung verweisen wir auf die Dokumentation - 5 von Digital Research. - 6 Dieser Hinweis ist nicht zynisch gemeint, aber wir sind nicht - 7 in der Lage, das, was ATARI nicht zu leisten vermag, hier - 8 nachzuholen. Mit geeigneten Unterlagen (wo gibts die ??) sollte - 9 es aber m”glich sein, die Funktionen zu nutzen. -10 Beispiele findet man im Editor. -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ VDI Loadscreen 09sep86we - 1 - 2 Onlyforth - 3 \needs GEM include gem\basics.scr - 4 Onlyforth - 5 \needs 2over include double.scr - 6 - 7 Onlyforth GEM also definitions - 8 - 9 1 +load cr .( Output Functions loaded) cr -10 7 +load cr .( Attribute Functions loaded) cr -11 $0F +load cr .( Raster Operations loaded) cr -12 $15 +load cr .( Input Functions loaded) cr -13 $1B +load cr .( Inquire Functions loaded) cr -14 $1F +load cr .( Escapes loaded) cr -15 -Screen 2 not modified - 0 \ Output Functions Loadscreen 27jan86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 01 05 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ pline pmarker gtext 26f09sep86we - 1 - 2 : pline ( x1 y1 x2 y2 ... xn yn count -- ) - 3 >r ptsin r@ 2* array! 6 r> 0 VDI ; - 4 - 5 : pmarker ( x1 y1 x2 y2 ... xn yn count -- ) - 6 >r ptsin r@ 2* array! 7 r> 0 VDI ; - 7 - 8 | Code 1:2move ( from to count -- ) SP )+ D0 move - 9 SP )+ D6 move D6 reg) A0 lea -10 SP )+ D6 move D6 reg) A1 lea -11 D0 tst 0<> IF 1 D0 subq D1 clr D0 DO -12 .b A1 )+ D1 move .w D1 A0 )+ move LOOP THEN Next end-code -13 -14 : gtext ( addr count x y -- ) -15 ptsin 2 array! >r intin r@ 1:2move 8 1 r> VDI ; -Screen 4 not modified - 0 \ fillarea contourfill 01feb86we - 1 - 2 : fillarea ( x1 y1 x2 y2 ... xn yn count -- ) - 3 >r ptsin r@ 2* array! 9 r> 0 VDI ; - 4 - 5 : contourfill ( color x y -- ) - 6 ptsin 2 array! intin ! &103 1 1 VDI ; - 7 - 8 : r_recfl ( x1 y1 x2 y2 -- ) - 9 ptsin 4 array! &114 2 0 VDI ; -10 -11 -12 \\ cellarray -13 -14 -15 -Screen 5 not modified - 0 \ GDP bar arc pie 03aug86we - 1 - 2 : GDP ( #ptsin #intin functionno -- ) - 3 function ! &11 -rot VDI ; - 4 - 5 : bar ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 1 GDP ; - 6 - 7 : arc ( startwinkel endwinkel x y radius -- ) - 8 ptsin under &12 + ! 2 array! intin 2 array! 4 2 2 GDP ; - 9 -10 : pie ( startwinkel endwinkel x y radius -- ) -11 ptsin under &12 + ! 2 array! intin 2 array! 4 2 3 GDP ; -12 -13 -14 -15 -Screen 6 not modified - 0 \ circle ellpie ellarc ellipse 01feb86we - 1 - 2 : circle ( x y radius -- ) - 3 ptsin under 8 + ! 2 array! 3 0 4 GDP ; - 4 - 5 : ellarc ( startwinkel endwinkel x y xradius yradius -- ) - 6 ptsin 4 array! intin 2 array! 2 2 6 GDP ; - 7 - 8 : ellpie ( startwinkel endwinkel x y xradius yradius -- ) - 9 ptsin 4 array! intin 2 array! 2 2 7 GDP ; -10 -11 : ellipse ( x y xradius yradius -- ) -12 ptsin 4 array! 2 0 5 GDP ; -13 -14 -15 -Screen 7 not modified - 0 \ rbox rfbox justified 01feb86we - 1 - 2 : rbox ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 8 GDP ; - 3 - 4 : rfbox ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 9 GDP ; - 5 - 6 : justified ( string x y length wordspace charspace -- ) - 7 intin 2 array! ptsin 3 array! 4 swap count dup >r - 8 bounds DO I c@ over intin + ! 2+ LOOP drop - 9 2 r> 2+ &10 GDP ; -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ Attribute Functions Loadscreen 27jan86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 01 07 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ swr_mode Setmode 12aug86we - 1 - 2 : swr_mode ( mode -- ) intin ! &32 0 1 VDI ; - 3 - 4 - 5 | : Setmode ( n -- ) Create , Does> @ swr_mode ; - 6 - 7 1 Setmode overwrite 2 Setmode transparent - 8 3 Setmode exor 4 Setmode revtransparent - 9 -10 -11 \\ -12 : scolor -13 -14 -15 -Screen 10 not modified - 0 \ sl_type Settype sl_udsty 31jan86we - 1 - 2 : sl_type ( style -- ) intin ! &15 0 1 VDI ; - 3 - 4 | : Settype ( n -- ) Create , Does> @ sl_type ; - 5 - 6 1 Settype solid 2 Settype longdash - 7 3 Settype dot 4 Settype dashdot - 8 5 Settype dash 6 Settype dashdotdot - 9 7 Settype userdef -10 -11 : sl_udsty ( pattern -- ) intin ! &113 0 1 VDI ; -12 -13 -14 -15 -Screen 11 not modified - 0 \ sl_width sl_color sl_ends 01feb86we - 1 - 2 : sl_width ( width -- ) ptsin ! &16 1 0 VDI ; - 3 - 4 : sl_color ( color -- ) intin ! &17 0 1 VDI ; - 5 - 6 : sl_ends ( begstyle endstyle -- ) - 7 intin 2 array! &108 0 2 VDI ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 12 not modified - 0 \ sm_type sm_height sm_color 01feb86we - 1 - 2 : sm_type ( symbol -- ) intin ! &18 0 1 VDI ; - 3 - 4 | : Setmtype ( n -- ) Create , Does> @ sm_type ; - 5 - 6 1 Setmtype point 2 Setmtype plus - 7 3 Setmtype asterisk 4 Setmtype square - 8 5 Setmtype cross 6 Setmtype diamond - 9 -10 : sm_height ( height -- ) -11 0 ptsin 2! &19 1 0 VDI ; -12 -13 : sm_color ( color -- ) intin ! &20 0 1 VDI ; -14 -15 -Screen 13 not modified - 0 \ st_height st_point st_rotation st_color 01feb86we - 1 - 2 : st_height ( height -- ) - 3 0 ptsin 2! &12 1 0 VDI ; - 4 - 5 : st_point ( point -- ) intin ! &107 0 1 VDI ; - 6 - 7 : st_rotation ( winkel -- ) intin ! &13 0 1 VDI ; - 8 - 9 : st_font ( font -- ) intin ! &21 0 1 VDI ; -10 -11 : st_color ( color -- ) intin ! &22 0 1 VDI ; -12 -13 -14 -15 -Screen 14 not modified - 0 \ st_effects st_alignement 01feb86we - 1 - 2 : st_effects ( effect -- ) intin ! &106 0 1 VDI ; - 3 - 4 : st_alignement ( horin vertin -- ) - 5 intin 2 array! &39 0 2 VDI ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ sf_interior sf_style sf_color sf_perimeter 31jan86we - 1 - 2 : sf_interior ( style -- ) intin ! &23 0 1 VDI ; - 3 - 4 : sf_style ( styleindex -- ) intin ! &24 0 1 VDI ; - 5 - 6 : sf_color ( color -- ) intin ! &25 0 1 VDI ; - 7 - 8 : sf_perimeter ( pervis -- ) intin ! &104 0 1 VDI ; - 9 -10 -11 \\ sf_udpat -12 -13 -14 -15 -Screen 16 not modified - 0 \ Raster Operations Loadscreen 21nov86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 \needs malloc include allocate.scr - 5 - 6 - 7 Create scrMFDB 0 , 0 , - 8 - 9 Variable >memMFDB -10 -11 | $4711 Constant magic -12 -13 1 5 +thru -14 -15 -Screen 17 not modified - 0 \ ?allocate onscreen 11sep86we - 1 - 2 | Code ?allocate >memMFDB R#) D6 move D6 reg) A0 lea - 3 .l A0 ) A0 move .w magic A0 -) cmpi - 4 0= IF Next Assembler THEN ;c: - 5 $0.8004 malloc swap even swap - 6 2dup magic -rot l! 2 extend d+ >memMFDB @ 2! ; - 7 - 8 | Code onscreen - 9 scrMFDB # D6 move D6 reg) A0 lea -10 .l A0 contrl &14 + R#) move A0 contrl &18 + R#) move -11 Next end-code -12 -13 -14 -15 -Screen 18 not modified - 0 \ onscreen >screen screen> 09sep86we - 1 - 2 | Code >screen - 3 >memMFDB R#) D6 move D6 reg) A0 lea - 4 .l A0 contrl &14 + R#) move - 5 .w scrMFDB # D6 move D6 reg) A0 lea - 6 .l A0 contrl &18 + R#) move ;c: ?allocate ; - 7 - 8 | Code screen> - 9 >memMFDB R#) D6 move D6 reg) A0 lea -10 .l A0 contrl &18 + R#) move -11 .w scrMFDB # D6 move D6 reg) A0 lea -12 .l A0 contrl &14 + R#) move ;c: ?allocate ; -13 -14 -15 -Screen 19 not modified - 0 \ copyraster 23aug86we - 1 - 2 : copyopaque ( Xfr Yfr width height Xto Yto mode --) - 3 intin ! 2over 2over d+ ptsin 8 + 4 array! - 4 2over d+ ptsin 4 array! &109 4 1 VDI ; - 5 - 6 : scr>mem ( addr_of_memMFDB -- ) - 7 Create , Does> @ >memMFDB ! screen> 2over 3 copyopaque ; - 8 - 9 : mem>scr ( addr_of_memMFDB -- ) -10 Create , Does> @ >memMFDB ! >screen 2over 3 copyopaque ; -11 -12 -13 \\ scr>mem und mem>scr sind Defining-Words fr Rasteroperationen -14 Um mit verschiedenen memMDFBs arbeiten zu k”nnen, mssen jeweils -15 eigene Worte definiert werden. Beispiel: s. n„chster Screen -Screen 20 not modified - 0 \ r_trnfm get_pixel 09sep86we - 1 - 2 : scr>scr ( Xfr Yfr width heigth Xto Yto --) - 3 onscreen 3 copyopaque ; - 4 - 5 Create memMFDB1 7 , 0 , &640 , &400 , &40 , 0 , 1 , - 6 0 , 0 , 0 , - 7 - 8 memMFDB1 scr>mem scr>mem1 ( Xleft Ytop Width Heigth -- ) - 9 -10 memMFDB1 mem>scr mem1>scr ( Xleft Ytop Width Heigth -- ) -11 -12 -13 -14 -15 -Screen 21 not modified - 0 \ r_trnfm get_pixel 26feb86re - 1 - 2 : r_trnfm ( -- ) >screen &110 0 0 VDI ; - 3 - 4 : get_pixel ( x y -- color flag ) - 5 ptsin 2 array! &105 1 0 VDI intout 2@ swap ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 \ Input Functions Loadscreen 12aug86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 1 5 +thru - 5 - 6 \\ - 7 Alle Input-Funktionen sollten von FORTH aus grunds„tzlich im - 8 Sample-Mode arbeiten, da sonst kein Multitasking m”glich ist. - 9 Daher sind nur die Sample-Funktionen implementiert. Die Opcodes -10 der Request-Funktionen sind aber dieselben, sodaž durch Aufruf -11 von sin_mode auch Request-Funktionen erreichbar sind. -12 Zu Beginn eines Programms sollten ansonsten alle Device-Typen -13 einmal mit sin_mode auf Sample geschaltet werden. -14 Werden mehrere Werte zurckgegeben, mssen dies aus den diversen -15 Arrays geholt werden. -Screen 23 not modified - 0 \ sm_locater sm_valuator sm_choice 12aug86we - 1 - 2 : sin_mode ( devtype mode -- ) intin 2 array! &33 0 2 VDI ; - 3 - 4 : sm_locater ( x y -- status ) - 5 ptsin 2 array! &28 1 0 VDI #ptsout @ #addrout @ 2* + ; - 6 \ status: 0 -> no input 1 -> pos changed - 7 \ 2 -> key pressed 3 -> key pressed and pos changed - 8 - 9 : sm_valuator ( val_in -- status ) -10 intin ! &29 0 1 VDI #addrout @ ; -11 \ status: 0 -> no action;1 -> valuator changed;2 -> key pressed -12 -13 : sm_choice ( -- status ) -14 &30 0 0 VDI #addrout @ ; -15 \ status: 0 -> no action 1 -> key pressed -Screen 24 not modified - 0 \ sm_string sc_form 01feb86we - 1 - 2 : sm_string ( addr max_len echomode x y -- status ) - 3 ptsin 2 array! intin 2 array! &31 1 2 VDI - 4 #addrout @ over c! - 5 #addrout @ 0 ?DO intout I 2* + 1+ c@ over I + 1+ c! LOOP - 6 drop #addrout @ ; - 7 \ status: 0 -> function aborted n -> count of string - 8 \ string wird als counted string bei addr abgelegt - 9 -10 : sc_form ( addr -- ) -11 intin &74 cmove &111 0 &37 VDI ; -12 \ addr is the adress of a data structure. -13 \ See description in VDI-Manual. -14 -15 -Screen 25 not modified - 0 \ ex_time show_c hide_c 02nov86we - 1 - 2 | : exchange_vecs ( pusrcode functionno -- long_psavcode ) - 3 swap >absaddr contrl &14 + 2! 0 0 VDI - 4 contrl &18 + 2@ ; - 5 - 6 : ex_time ( tim_addr -- long_otim_addr ) - 7 &118 exchange_vecs ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 26 not modified - 0 \ q_mouse ex_butv ex_motv ex_curv 09sep86we - 1 - 2 : q_mouse ( -- x y status ) - 3 &124 0 0 VDI ptsout 2@ intout @ ; - 4 - 5 : ex_butv ( pusrcode -- long_psavcode ) - 6 &125 exchange_vecs ; - 7 - 8 : ex_motv ( pusrcode -- long_psavcode ) - 9 &126 exchange_vecs ; -10 -11 : ex_curv ( pusrcode -- long_psavcode ) -12 &127 exchange_vecs ; -13 -14 -15 -Screen 27 not modified - 0 \ q_key_s 31jan86we - 1 - 2 : q_key_s ( -- status ) - 3 &128 0 0 VDI intout @ ; - 4 \ status: Bit 0 -> Right Shift Key Bit 1 -> Left Shift Key - 5 \ Bit 2 -> Control Key Bit 3 -> Alt Key - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 28 not modified - 0 \ Inquire Functions Loadscreen 31jan86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 01 03 +thru - 5 - 6 \\ - 7 Die Werte, die die Inquire-Funktionen zurckliefern, mssen aus - 8 den entsprechenden Arrays ausgelesen werden. - 9 -10 -11 -12 -13 -14 -15 -Screen 29 not modified - 0 \ q_extnd q_color q_attributes 01feb86we - 1 - 2 : q_extnd ( info_flag -- ) intin ! &102 0 1 VDI ; - 3 - 4 : q_color ( color_index info_flag ) - 5 intin 2 array! &26 0 2 VDI ; - 6 - 7 - 8 | : q_attributes ( n -- ) 0 0 VDI ; - 9 -10 : ql_attributes ( -- ) &35 q_attributes ; -11 : qm_attributes ( -- ) &36 q_attributes ; -12 : qf_attributes ( -- ) &37 q_attributes ; -13 : qt_attributes ( -- ) &38 q_attributes ; -14 -15 -Screen 30 not modified - 0 \ qt_extent qt_width qt_name 31jan86we - 1 - 2 : qt_extent ( string -- ) - 3 0 swap count dup >r bounds - 4 DO I c@ over intin + ! 2+ LOOP drop - 5 &116 0 r> VDI ; - 6 - 7 : qt_width ( char -- status ) - 8 intin ! &117 0 1 VDI intout @ ; - 9 \ status: -1 -> char invalid n -> ADE-Value of char -10 -11 : qt_name ( element_num -- ) -12 intin ! &130 0 1 VDI ; -13 -14 -15 -Screen 31 not modified - 0 \ q_cellarray qin_mode qt_fontinfo 01feb86we - 1 - 2 : q_cellarray ( cols rows x1 y1 x2 y2 -- ) - 3 ptsin 4 array! contrl &14 + 2 array! &27 2 0 VDI ; - 4 - 5 : qin_mode ( dev_type -- mode ) - 6 intin ! &115 0 1 VDI intout @ ; - 7 - 8 : qt_fontinfo ( -- ) &131 0 0 VDI ; - 9 -10 -11 -12 -13 -14 -15 -Screen 32 not modified - 0 \ Escapes Loadscreen 31jan86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 01 07 +thru - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 33 not modified - 0 \ ESC normal_ESC 31jan86we - 1 - 2 | : ESC ( #intin #ptsin functionno -- ) - 3 function ! 5 -rot VDI ; - 4 - 5 | : normal_ESC ( functionno -- ) - 6 0 0 rot ESC ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 34 not modified - 0 \ q_chcells exit_cur enter_cur cur_primitives 31jan86we - 1 - 2 : q_chcells ( -- rows cols ) 1 normal_ESC intout 2@ ; - 3 - 4 : exit_cur ( -- ) 2 normal_ESC ; - 5 : enter_cur ( -- ) 3 normal_ESC ; - 6 - 7 : curup ( -- ) 4 normal_ESC ; - 8 : curdown ( -- ) 5 normal_ESC ; - 9 : curright ( -- ) 6 normal_ESC ; -10 : curleft ( -- ) 7 normal_ESC ; -11 : curhome ( -- ) 8 normal_ESC ; -12 -13 : eeos ( -- ) 9 normal_ESC ; -14 : eeol ( -- ) &10 normal_ESC ; -15 -Screen 35 not modified - 0 \ s_curaddress curtext rvon rvoff 26feb86we/re - 1 - 2 : s_curaddress ( row col -- ) - 3 intin 2 array! 0 2 &11 ESC ; - 4 - 5 : curtext ( addr count -- ) - 6 >r intin r@ 1:2move 0 r> &12 ESC ; - 7 - 8 : rvon ( -- ) &13 normal_ESC ; - 9 -10 : rvoff ( -- ) &14 normal_ESC ; -11 -12 : q_curaddress ( -- row col ) -13 &15 normal_ESC intout 2@ ; -14 -15 -Screen 36 not modified - 0 \ q_tabstatus hardcopy dspcur rmcur form_adv 01feb86we - 1 - 2 : q_tabstatus ( -- status ) &16 normal_ESC intout @ ; - 3 - 4 : hardcopy ( -- ) &17 normal_ESC ; - 5 - 6 : dspcur ( x y -- ) ptsin 2 array! 1 0 &18 ESC ; - 7 - 8 : rmcur ( -- ) &19 normal_ESC ; - 9 -10 : form_adv ( -- ) &20 normal_ESC ; -11 -12 -13 -14 -15 -Screen 37 not modified - 0 \ output_window clear_disp_list bit_image s_palette 01feb86we - 1 - 2 : output_window ( x1 y1 x2 y2 -- ) - 3 ptsin 4 array! 2 0 &21 ESC ; - 4 - 5 : clear_disp_list ( -- ) &22 normal_ESC ; - 6 - 7 : bit_image ( string aspect scaling num_pts x1 y1 x2 y2 -- ) - 8 ptsin 4 array! >r intin 2 array! 4 swap count dup >r - 9 bounds DO I c@ over intin + ! 2+ LOOP drop -10 r> r> 2+ &23 VDI ; -11 -12 : s_palette ( palette -- selected ) -13 intin ! 0 1 &60 ESC intout @ ; -14 -15 -Screen 38 not modified - 0 \ s_palette qp_films qp_state sp_state sp_save etc. 31jan86we - 1 - 2 : qp_films ( -- ) &91 normal_ESC ; - 3 : qp_state ( -- ) &92 normal_ESC ; - 4 - 5 : sp_state ( addr -- ) - 6 intin &40 cmove 0 &20 &93 ESC ; - 7 \ adr is the adress of a data structure - 8 - 9 : sp_save ( -- ) &94 normal_ESC ; -10 -11 : sp_message ( -- ) &95 normal_ESC ; -12 -13 : qp_error ( -- ) &96 normal_ESC ; -14 -15 -Screen 39 not modified - 0 \ meta_extents write_meta m_filename 31jan86we - 1 - 2 : meta_extents ( x1 y1 x2 y2 -- ) - 3 ptsin 4 array! 2 0 &98 ESC ; - 4 - 5 : write_meta ( intin num_intin ptsin num_ptsin -- ) - 6 dup 2/ >r ptsin swap cmove dup >r intin swap cmove - 7 r> r> swap &99 ESC ; - 8 - 9 : m_filename ( string -- ) -10 0 swap count dup >r -11 bounds DO I c@ over intin + ! 2+ LOOP 0 swap intin + ! -12 0 r> &100 ESC ; -13 -14 -15 -Screen 40 not modified - 0 \ Demo fuer VDI 02feb86we - 1 - 2 Onlyforth GEM also definitions - 3 - 4 Create logo ," volksFORTH 83" - 5 - 6 : textdemo clrwk exor 1 st_font 1 st_color - 7 &0 st_rotation &13 st_effects - 8 80 0 DO 2 0 DO J 4 / st_height - 9 logo $80 20 J + 80 J 2* + 1 1 justified LOOP -10 4 +LOOP logo $80 $A0 180 1 1 justified ; -11 -12 : rahmen 0 0 sl_ends 10 sl_width -13 60 70 210 70 210 $C0 60 $C0 60 70 5 pline ; -14 --> -15 -Screen 41 not modified - 0 \ Kreis mit Mustern 02feb86we - 1 - 2 : torte - 3 2 sf_interior 1 sf_perimeter 1 sf_color - 4 9 sf_style 0 &450 &100 &300 &80 pie - 5 &07 sf_style &450 &1000 &100 &300 &80 pie - 6 &12 sf_style &1000 &2400 &100 &300 &80 pie - 7 &19 sf_style &2400 &3600 &100 &300 &80 pie ; - 8 - 9 -10 -11 -12 -13 -14 : tdemo grinit page textdemo rahmen torte grexit ; -15 diff --git a/sources/AtariST/GEM/VDI.fth b/sources/AtariST/GEM/VDI.fth new file mode 100644 index 0000000..8b2ac8e --- /dev/null +++ b/sources/AtariST/GEM/VDI.fth @@ -0,0 +1,714 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** VDI -Funktionen *** 12aug86we + +Dieses File enth„lt alle VDI-Funktionen. + +Zur genaueren Beschreibung verweisen wir auf die Dokumentation +von Digital Research. +Dieser Hinweis ist nicht zynisch gemeint, aber wir sind nicht +in der Lage, das, was ATARI nicht zu leisten vermag, hier +nachzuholen. Mit geeigneten Unterlagen (wo gibts die ??) sollte +es aber m”glich sein, die Funktionen zu nutzen. +Beispiele findet man im Editor. + + + + + +\ *** Block No. 1 Hexblock 1 +\ VDI Loadscreen 09sep86we + +Onlyforth +\needs GEM include gem\basics.scr +Onlyforth +\needs 2over include double.scr + +Onlyforth GEM also definitions + + 1 +load cr .( Output Functions loaded) cr + 7 +load cr .( Attribute Functions loaded) cr +$0F +load cr .( Raster Operations loaded) cr +$15 +load cr .( Input Functions loaded) cr +$1B +load cr .( Inquire Functions loaded) cr +$1F +load cr .( Escapes loaded) cr + +\ *** Block No. 2 Hexblock 2 +\ Output Functions Loadscreen 27jan86we + +Onlyforth GEM also definitions + +01 05 +thru + + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ pline pmarker gtext 26f09sep86we + +: pline ( x1 y1 x2 y2 ... xn yn count -- ) + >r ptsin r@ 2* array! 6 r> 0 VDI ; + +: pmarker ( x1 y1 x2 y2 ... xn yn count -- ) + >r ptsin r@ 2* array! 7 r> 0 VDI ; + +| Code 1:2move ( from to count -- ) SP )+ D0 move + SP )+ D6 move D6 reg) A0 lea + SP )+ D6 move D6 reg) A1 lea + D0 tst 0<> IF 1 D0 subq D1 clr D0 DO + .b A1 )+ D1 move .w D1 A0 )+ move LOOP THEN Next end-code + +: gtext ( addr count x y -- ) + ptsin 2 array! >r intin r@ 1:2move 8 1 r> VDI ; +\ *** Block No. 4 Hexblock 4 +\ fillarea contourfill 01feb86we + +: fillarea ( x1 y1 x2 y2 ... xn yn count -- ) + >r ptsin r@ 2* array! 9 r> 0 VDI ; + +: contourfill ( color x y -- ) + ptsin 2 array! intin ! &103 1 1 VDI ; + +: r_recfl ( x1 y1 x2 y2 -- ) + ptsin 4 array! &114 2 0 VDI ; + + +\\ cellarray + + + +\ *** Block No. 5 Hexblock 5 +\ GDP bar arc pie 03aug86we + +: GDP ( #ptsin #intin functionno -- ) + function ! &11 -rot VDI ; + +: bar ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 1 GDP ; + +: arc ( startwinkel endwinkel x y radius -- ) + ptsin under &12 + ! 2 array! intin 2 array! 4 2 2 GDP ; + +: pie ( startwinkel endwinkel x y radius -- ) + ptsin under &12 + ! 2 array! intin 2 array! 4 2 3 GDP ; + + + + +\ *** Block No. 6 Hexblock 6 +\ circle ellpie ellarc ellipse 01feb86we + +: circle ( x y radius -- ) + ptsin under 8 + ! 2 array! 3 0 4 GDP ; + +: ellarc ( startwinkel endwinkel x y xradius yradius -- ) + ptsin 4 array! intin 2 array! 2 2 6 GDP ; + +: ellpie ( startwinkel endwinkel x y xradius yradius -- ) + ptsin 4 array! intin 2 array! 2 2 7 GDP ; + +: ellipse ( x y xradius yradius -- ) + ptsin 4 array! 2 0 5 GDP ; + + + +\ *** Block No. 7 Hexblock 7 +\ rbox rfbox justified 01feb86we + +: rbox ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 8 GDP ; + +: rfbox ( x1 y1 x2 y2 -- ) ptsin 4 array! 2 0 9 GDP ; + +: justified ( string x y length wordspace charspace -- ) + intin 2 array! ptsin 3 array! 4 swap count dup >r + bounds DO I c@ over intin + ! 2+ LOOP drop + 2 r> 2+ &10 GDP ; + + + + + + +\ *** Block No. 8 Hexblock 8 +\ Attribute Functions Loadscreen 27jan86we + +Onlyforth GEM also definitions + +01 07 +thru + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ swr_mode Setmode 12aug86we + +: swr_mode ( mode -- ) intin ! &32 0 1 VDI ; + + +| : Setmode ( n -- ) Create , Does> @ swr_mode ; + +1 Setmode overwrite 2 Setmode transparent +3 Setmode exor 4 Setmode revtransparent + + +\\ +: scolor + + + +\ *** Block No. 10 Hexblock A +\ sl_type Settype sl_udsty 31jan86we + +: sl_type ( style -- ) intin ! &15 0 1 VDI ; + +| : Settype ( n -- ) Create , Does> @ sl_type ; + +1 Settype solid 2 Settype longdash +3 Settype dot 4 Settype dashdot +5 Settype dash 6 Settype dashdotdot +7 Settype userdef + +: sl_udsty ( pattern -- ) intin ! &113 0 1 VDI ; + + + + +\ *** Block No. 11 Hexblock B +\ sl_width sl_color sl_ends 01feb86we + +: sl_width ( width -- ) ptsin ! &16 1 0 VDI ; + +: sl_color ( color -- ) intin ! &17 0 1 VDI ; + +: sl_ends ( begstyle endstyle -- ) + intin 2 array! &108 0 2 VDI ; + + + + + + + + +\ *** Block No. 12 Hexblock C +\ sm_type sm_height sm_color 01feb86we + +: sm_type ( symbol -- ) intin ! &18 0 1 VDI ; + +| : Setmtype ( n -- ) Create , Does> @ sm_type ; + +1 Setmtype point 2 Setmtype plus +3 Setmtype asterisk 4 Setmtype square +5 Setmtype cross 6 Setmtype diamond + +: sm_height ( height -- ) + 0 ptsin 2! &19 1 0 VDI ; + +: sm_color ( color -- ) intin ! &20 0 1 VDI ; + + +\ *** Block No. 13 Hexblock D +\ st_height st_point st_rotation st_color 01feb86we + +: st_height ( height -- ) + 0 ptsin 2! &12 1 0 VDI ; + +: st_point ( point -- ) intin ! &107 0 1 VDI ; + +: st_rotation ( winkel -- ) intin ! &13 0 1 VDI ; + +: st_font ( font -- ) intin ! &21 0 1 VDI ; + +: st_color ( color -- ) intin ! &22 0 1 VDI ; + + + + +\ *** Block No. 14 Hexblock E +\ st_effects st_alignement 01feb86we + +: st_effects ( effect -- ) intin ! &106 0 1 VDI ; + +: st_alignement ( horin vertin -- ) + intin 2 array! &39 0 2 VDI ; + + + + + + + + + + +\ *** Block No. 15 Hexblock F +\ sf_interior sf_style sf_color sf_perimeter 31jan86we + +: sf_interior ( style -- ) intin ! &23 0 1 VDI ; + +: sf_style ( styleindex -- ) intin ! &24 0 1 VDI ; + +: sf_color ( color -- ) intin ! &25 0 1 VDI ; + +: sf_perimeter ( pervis -- ) intin ! &104 0 1 VDI ; + + +\\ sf_udpat + + + + +\ *** Block No. 16 Hexblock 10 +\ Raster Operations Loadscreen 21nov86we + +Onlyforth GEM also definitions + +\needs malloc include allocate.scr + + +Create scrMFDB 0 , 0 , + +Variable >memMFDB + +| $4711 Constant magic + +1 5 +thru + + +\ *** Block No. 17 Hexblock 11 +\ ?allocate onscreen 11sep86we + +| Code ?allocate >memMFDB R#) D6 move D6 reg) A0 lea + .l A0 ) A0 move .w magic A0 -) cmpi + 0= IF Next Assembler THEN ;c: + $0.8004 malloc swap even swap + 2dup magic -rot l! 2 extend d+ >memMFDB @ 2! ; + +| Code onscreen + scrMFDB # D6 move D6 reg) A0 lea + .l A0 contrl &14 + R#) move A0 contrl &18 + R#) move + Next end-code + + + + +\ *** Block No. 18 Hexblock 12 +\ onscreen >screen screen> 09sep86we + +| Code >screen + >memMFDB R#) D6 move D6 reg) A0 lea + .l A0 contrl &14 + R#) move + .w scrMFDB # D6 move D6 reg) A0 lea + .l A0 contrl &18 + R#) move ;c: ?allocate ; + +| Code screen> + >memMFDB R#) D6 move D6 reg) A0 lea + .l A0 contrl &18 + R#) move + .w scrMFDB # D6 move D6 reg) A0 lea + .l A0 contrl &14 + R#) move ;c: ?allocate ; + + + +\ *** Block No. 19 Hexblock 13 +\ copyraster 23aug86we + +: copyopaque ( Xfr Yfr width height Xto Yto mode --) + intin ! 2over 2over d+ ptsin 8 + 4 array! + 2over d+ ptsin 4 array! &109 4 1 VDI ; + +: scr>mem ( addr_of_memMFDB -- ) + Create , Does> @ >memMFDB ! screen> 2over 3 copyopaque ; + +: mem>scr ( addr_of_memMFDB -- ) + Create , Does> @ >memMFDB ! >screen 2over 3 copyopaque ; + + +\\ scr>mem und mem>scr sind Defining-Words fr Rasteroperationen +Um mit verschiedenen memMDFBs arbeiten zu k”nnen, mssen jeweils +eigene Worte definiert werden. Beispiel: s. n„chster Screen +\ *** Block No. 20 Hexblock 14 +\ r_trnfm get_pixel 09sep86we + +: scr>scr ( Xfr Yfr width heigth Xto Yto --) + onscreen 3 copyopaque ; + +Create memMFDB1 7 , 0 , &640 , &400 , &40 , 0 , 1 , + 0 , 0 , 0 , + +memMFDB1 scr>mem scr>mem1 ( Xleft Ytop Width Heigth -- ) + +memMFDB1 mem>scr mem1>scr ( Xleft Ytop Width Heigth -- ) + + + + + +\ *** Block No. 21 Hexblock 15 +\ r_trnfm get_pixel 26feb86re + +: r_trnfm ( -- ) >screen &110 0 0 VDI ; + +: get_pixel ( x y -- color flag ) + ptsin 2 array! &105 1 0 VDI intout 2@ swap ; + + + + + + + + + + +\ *** Block No. 22 Hexblock 16 +\ Input Functions Loadscreen 12aug86we + +Onlyforth GEM also definitions + + 1 5 +thru + +\\ +Alle Input-Funktionen sollten von FORTH aus grunds„tzlich im +Sample-Mode arbeiten, da sonst kein Multitasking m”glich ist. +Daher sind nur die Sample-Funktionen implementiert. Die Opcodes +der Request-Funktionen sind aber dieselben, sodaž durch Aufruf +von sin_mode auch Request-Funktionen erreichbar sind. +Zu Beginn eines Programms sollten ansonsten alle Device-Typen +einmal mit sin_mode auf Sample geschaltet werden. +Werden mehrere Werte zurckgegeben, mssen dies aus den diversen +Arrays geholt werden. +\ *** Block No. 23 Hexblock 17 +\ sm_locater sm_valuator sm_choice 12aug86we + +: sin_mode ( devtype mode -- ) intin 2 array! &33 0 2 VDI ; + +: sm_locater ( x y -- status ) + ptsin 2 array! &28 1 0 VDI #ptsout @ #addrout @ 2* + ; +\ status: 0 -> no input 1 -> pos changed +\ 2 -> key pressed 3 -> key pressed and pos changed + +: sm_valuator ( val_in -- status ) + intin ! &29 0 1 VDI #addrout @ ; +\ status: 0 -> no action;1 -> valuator changed;2 -> key pressed + +: sm_choice ( -- status ) + &30 0 0 VDI #addrout @ ; +\ status: 0 -> no action 1 -> key pressed +\ *** Block No. 24 Hexblock 18 +\ sm_string sc_form 01feb86we + +: sm_string ( addr max_len echomode x y -- status ) + ptsin 2 array! intin 2 array! &31 1 2 VDI + #addrout @ over c! + #addrout @ 0 ?DO intout I 2* + 1+ c@ over I + 1+ c! LOOP + drop #addrout @ ; +\ status: 0 -> function aborted n -> count of string +\ string wird als counted string bei addr abgelegt + +: sc_form ( addr -- ) + intin &74 cmove &111 0 &37 VDI ; +\ addr is the adress of a data structure. +\ See description in VDI-Manual. + + +\ *** Block No. 25 Hexblock 19 +\ ex_time show_c hide_c 02nov86we + +| : exchange_vecs ( pusrcode functionno -- long_psavcode ) + swap >absaddr contrl &14 + 2! 0 0 VDI + contrl &18 + 2@ ; + +: ex_time ( tim_addr -- long_otim_addr ) + &118 exchange_vecs ; + + + + + + + + +\ *** Block No. 26 Hexblock 1A +\ q_mouse ex_butv ex_motv ex_curv 09sep86we + +: q_mouse ( -- x y status ) + &124 0 0 VDI ptsout 2@ intout @ ; + +: ex_butv ( pusrcode -- long_psavcode ) + &125 exchange_vecs ; + +: ex_motv ( pusrcode -- long_psavcode ) + &126 exchange_vecs ; + +: ex_curv ( pusrcode -- long_psavcode ) + &127 exchange_vecs ; + + + +\ *** Block No. 27 Hexblock 1B +\ q_key_s 31jan86we + +: q_key_s ( -- status ) + &128 0 0 VDI intout @ ; +\ status: Bit 0 -> Right Shift Key Bit 1 -> Left Shift Key +\ Bit 2 -> Control Key Bit 3 -> Alt Key + + + + + + + + + + +\ *** Block No. 28 Hexblock 1C +\ Inquire Functions Loadscreen 31jan86we + +Onlyforth GEM also definitions + +01 03 +thru + +\\ +Die Werte, die die Inquire-Funktionen zurckliefern, mssen aus +den entsprechenden Arrays ausgelesen werden. + + + + + + + +\ *** Block No. 29 Hexblock 1D +\ q_extnd q_color q_attributes 01feb86we + +: q_extnd ( info_flag -- ) intin ! &102 0 1 VDI ; + +: q_color ( color_index info_flag ) + intin 2 array! &26 0 2 VDI ; + + +| : q_attributes ( n -- ) 0 0 VDI ; + +: ql_attributes ( -- ) &35 q_attributes ; +: qm_attributes ( -- ) &36 q_attributes ; +: qf_attributes ( -- ) &37 q_attributes ; +: qt_attributes ( -- ) &38 q_attributes ; + + +\ *** Block No. 30 Hexblock 1E +\ qt_extent qt_width qt_name 31jan86we + +: qt_extent ( string -- ) + 0 swap count dup >r bounds + DO I c@ over intin + ! 2+ LOOP drop + &116 0 r> VDI ; + +: qt_width ( char -- status ) + intin ! &117 0 1 VDI intout @ ; +\ status: -1 -> char invalid n -> ADE-Value of char + +: qt_name ( element_num -- ) + intin ! &130 0 1 VDI ; + + + +\ *** Block No. 31 Hexblock 1F +\ q_cellarray qin_mode qt_fontinfo 01feb86we + +: q_cellarray ( cols rows x1 y1 x2 y2 -- ) + ptsin 4 array! contrl &14 + 2 array! &27 2 0 VDI ; + +: qin_mode ( dev_type -- mode ) + intin ! &115 0 1 VDI intout @ ; + +: qt_fontinfo ( -- ) &131 0 0 VDI ; + + + + + + + +\ *** Block No. 32 Hexblock 20 +\ Escapes Loadscreen 31jan86we + +Onlyforth GEM also definitions + +01 07 +thru + + + + + + + + + + + +\ *** Block No. 33 Hexblock 21 +\ ESC normal_ESC 31jan86we + +| : ESC ( #intin #ptsin functionno -- ) + function ! 5 -rot VDI ; + +| : normal_ESC ( functionno -- ) + 0 0 rot ESC ; + + + + + + + + + +\ *** Block No. 34 Hexblock 22 +\ q_chcells exit_cur enter_cur cur_primitives 31jan86we + +: q_chcells ( -- rows cols ) 1 normal_ESC intout 2@ ; + +: exit_cur ( -- ) 2 normal_ESC ; +: enter_cur ( -- ) 3 normal_ESC ; + +: curup ( -- ) 4 normal_ESC ; +: curdown ( -- ) 5 normal_ESC ; +: curright ( -- ) 6 normal_ESC ; +: curleft ( -- ) 7 normal_ESC ; +: curhome ( -- ) 8 normal_ESC ; + +: eeos ( -- ) 9 normal_ESC ; +: eeol ( -- ) &10 normal_ESC ; + +\ *** Block No. 35 Hexblock 23 +\ s_curaddress curtext rvon rvoff 26feb86we/re + +: s_curaddress ( row col -- ) + intin 2 array! 0 2 &11 ESC ; + +: curtext ( addr count -- ) + >r intin r@ 1:2move 0 r> &12 ESC ; + +: rvon ( -- ) &13 normal_ESC ; + +: rvoff ( -- ) &14 normal_ESC ; + +: q_curaddress ( -- row col ) + &15 normal_ESC intout 2@ ; + + +\ *** Block No. 36 Hexblock 24 +\ q_tabstatus hardcopy dspcur rmcur form_adv 01feb86we + +: q_tabstatus ( -- status ) &16 normal_ESC intout @ ; + +: hardcopy ( -- ) &17 normal_ESC ; + +: dspcur ( x y -- ) ptsin 2 array! 1 0 &18 ESC ; + +: rmcur ( -- ) &19 normal_ESC ; + +: form_adv ( -- ) &20 normal_ESC ; + + + + + +\ *** Block No. 37 Hexblock 25 +\ output_window clear_disp_list bit_image s_palette 01feb86we + +: output_window ( x1 y1 x2 y2 -- ) + ptsin 4 array! 2 0 &21 ESC ; + +: clear_disp_list ( -- ) &22 normal_ESC ; + +: bit_image ( string aspect scaling num_pts x1 y1 x2 y2 -- ) + ptsin 4 array! >r intin 2 array! 4 swap count dup >r + bounds DO I c@ over intin + ! 2+ LOOP drop + r> r> 2+ &23 VDI ; + +: s_palette ( palette -- selected ) + intin ! 0 1 &60 ESC intout @ ; + + +\ *** Block No. 38 Hexblock 26 +\ s_palette qp_films qp_state sp_state sp_save etc. 31jan86we + +: qp_films ( -- ) &91 normal_ESC ; +: qp_state ( -- ) &92 normal_ESC ; + +: sp_state ( addr -- ) + intin &40 cmove 0 &20 &93 ESC ; +\ adr is the adress of a data structure + +: sp_save ( -- ) &94 normal_ESC ; + +: sp_message ( -- ) &95 normal_ESC ; + +: qp_error ( -- ) &96 normal_ESC ; + + +\ *** Block No. 39 Hexblock 27 +\ meta_extents write_meta m_filename 31jan86we + +: meta_extents ( x1 y1 x2 y2 -- ) + ptsin 4 array! 2 0 &98 ESC ; + +: write_meta ( intin num_intin ptsin num_ptsin -- ) + dup 2/ >r ptsin swap cmove dup >r intin swap cmove + r> r> swap &99 ESC ; + +: m_filename ( string -- ) + 0 swap count dup >r + bounds DO I c@ over intin + ! 2+ LOOP 0 swap intin + ! + 0 r> &100 ESC ; + + + +\ *** Block No. 40 Hexblock 28 +\ Demo fuer VDI 02feb86we + +Onlyforth GEM also definitions + +Create logo ," volksFORTH 83" + +: textdemo clrwk exor 1 st_font 1 st_color + &0 st_rotation &13 st_effects + 80 0 DO 2 0 DO J 4 / st_height + logo $80 20 J + 80 J 2* + 1 1 justified LOOP + 4 +LOOP logo $80 $A0 180 1 1 justified ; + +: rahmen 0 0 sl_ends 10 sl_width + 60 70 210 70 210 $C0 60 $C0 60 70 5 pline ; + --> + +\ *** Block No. 41 Hexblock 29 +\ Kreis mit Mustern 02feb86we + +: torte + 2 sf_interior 1 sf_perimeter 1 sf_color + 9 sf_style 0 &450 &100 &300 &80 pie + &07 sf_style &450 &1000 &100 &300 &80 pie + &12 sf_style &1000 &2400 &100 &300 &80 pie + &19 sf_style &2400 &3600 &100 &300 &80 pie ; + + + + + + +: tdemo grinit page textdemo rahmen torte grexit ; + diff --git a/sources/AtariST/INDEX.FB.src b/sources/AtariST/INDEX.FB.src deleted file mode 100644 index 1cbff56..0000000 --- a/sources/AtariST/INDEX.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \\ *** Index *** 26may86we - 1 - 2 Diese File enth„lt nur das Wort INDEX , das frher zum System- - 3 kern geh”rt hat. INDEX arbeitet aber jetzt auch auf Files - 4 und mužte deshalb 'nach hinten' verlegt werden. - 5 - 6 INDEX ( from to -- ) - 7 liest die BLOCKs from bis to einschliesslich und gibt deren - 8 erste Zeilen aus. INDEX kann mit einer beliebigen Taste unter- - 9 brochen und mit ESC oder CTRL-C abgebrochen werden. -10 Die ersten Zeilen von Screens enthalten typisch Kommentare, die -11 den Inhalt charakterisieren. -12 -13 -14 -15 -Screen 1 not modified - 0 \ index findex 05dec85we - 1 - 2 \needs capacity ' blk/drv Alias capacity - 3 - 4 | : range ( from to -- to+1 from ) - 5 capacity 1- umin swap capacity 1- umin - 6 2dup > IF swap THEN 1+ swap ; - 7 - 8 : index ( from to --) - 9 range DO cr I 4 .r I space block c/l type -10 stop? IF LEAVE THEN LOOP ; -11 -12 -13 -14 -15 diff --git a/sources/AtariST/INDEX.fth b/sources/AtariST/INDEX.fth new file mode 100644 index 0000000..c15ab28 --- /dev/null +++ b/sources/AtariST/INDEX.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Index *** 26may86we + +Diese File enth„lt nur das Wort INDEX , das frher zum System- +kern geh”rt hat. INDEX arbeitet aber jetzt auch auf Files +und mužte deshalb 'nach hinten' verlegt werden. + + INDEX ( from to -- ) +liest die BLOCKs from bis to einschliesslich und gibt deren +erste Zeilen aus. INDEX kann mit einer beliebigen Taste unter- +brochen und mit ESC oder CTRL-C abgebrochen werden. +Die ersten Zeilen von Screens enthalten typisch Kommentare, die +den Inhalt charakterisieren. + + + + +\ *** Block No. 1 Hexblock 1 +\ index findex 05dec85we + +\needs capacity ' blk/drv Alias capacity + +| : range ( from to -- to+1 from ) + capacity 1- umin swap capacity 1- umin + 2dup > IF swap THEN 1+ swap ; + +: index ( from to --) + range DO cr I 4 .r I space block c/l type + stop? IF LEAVE THEN LOOP ; + + + + + diff --git a/sources/AtariST/LINE_A.FB.src b/sources/AtariST/LINE_A.FB.src deleted file mode 100644 index d4d4683..0000000 --- a/sources/AtariST/LINE_A.FB.src +++ /dev/null @@ -1,629 +0,0 @@ -Screen 0 not modified - 0 \\ *** Line-A Graphic *** cas20130106 - 1 - 2 This file contains the LINE-A graphic routines. While being - 3 sometimes faster than VDI Routines, LINE-A Functions are not - 4 supported on some newer Atari ST machines. - 5 - 6 It is recommended to only use VDI functions in new programs. - 7 This library is provided for compatibility reasons to be able - 8 to compile old source code. the programs will probablt not work - 9 on newer Atari machines. -10 -11 -12 Examples for the use of LINE-A routines can be found in the file -13 DEMO.FB -14 -15 -Screen 1 not modified - 0 \ Line A - Graphics Loadscreen cas20130106 - 1 - 2 Onlyforth - 3 \needs Code include assemble.fb - 4 - 5 .( use of LINE-A is deprecated and will not work on newer ) - 6 .( Atari machines. Please use VDI routines instead! ) - 7 - 8 Vocabulary Graphics Graphics also definitions - 9 -10 1 $10 +thru -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ Table offsets 26oct86we - 1 - 2 base @ decimal - 3 0 >label v_planes 2 >label v_lin_wr - 4 4 >label _cntrl - 5 8 >label _intin 12 >label _ptsin - 6 16 >label _intout 20 >label _ptsout - 7 24 >label _fg_bp_1 26 >label _fg_bp_2 - 8 28 >label _fg_bp_3 30 >label _fg_bp_4 - 9 32 >label _lstlin 34 >label _ln_mask -10 36 >label _wrt_mode 38 >label _x1 -11 40 >label _y1 42 >label _x2 -12 44 >label _y2 46 >label _patptr -13 50 >label _patmsk 52 >label _multifill -14 54 >label _clip 56 >label _xmn_clip -15 58 >label _ymn_clip 60 >label _xmx_clip -Screen 3 not modified - 0 \ Table offsets 26oct86we - 1 - 2 62 >label _ymx_clip 64 >label _xacc_dda - 3 66 >label _dda_inc 68 >label _t_sclsts - 4 70 >label _mono_status 72 >label _sourcex - 5 74 >label _sourcey 76 >label _destx - 6 78 >label _desty 80 >label _delx - 7 82 >label _dely 84 >label _fbase - 8 86 >label _fwidth 90 >label _style - 9 92 >label _litemask 94 >label _skewmask -10 96 >label _weight 98 >label _r_off -11 100 >label _l_off 102 >label _scale -12 104 >label _chup 106 >label _text_fg -13 108 >label _scrtchp 112 >label _scrpt2 -14 114 >label _text_bg 116 >label _copytran -15 base ! -Screen 4 not modified - 0 \ Variable cas20130106 - 1 - 2 Variable xmin_clip Variable xmax_clip - 3 Variable ymin_clip Variable ymax_clip - 4 Variable multi_fill 0 multi_fill ! - 5 Variable linemask $FFFF linemask ! \ solid line - 6 Variable plane1 1 plane1 ! \ black - 7 Variable plane2 1 plane2 ! \ on - 8 Variable plane3 0 plane3 ! \ white - 9 Variable plane4 0 plane4 ! -10 Variable cur_x 0 cur_x ! -11 Variable cur_y 0 cur_y ! -12 Variable wr_mode 0 wr_mode ! \ overwrite -13 Variable scr_res 2 scr_res ! \ Hires -14 -15 -Screen 5 not modified - 0 \ arrays 17sep86we - 1 - 2 Variable pat_mask 1 pat_mask ! - 3 Variable pattern - 4 - 5 Create nopattern 0 , 0 , - 6 Create fullpattern $FFFF , $FFFF , fullpattern pattern ! - 7 - 8 Variable checking checking on - 9 Variable clipping clipping off -10 -11 Create a_fonts 4 allot -12 Create a_base 4 allot -13 -14 -15 -Screen 6 not modified - 0 \ Initialization 17sep86we - 1 - 2 Create a_setup Assembler - 3 $A000 , .l A0 a_base R#) move A1 a_fonts R#) move - 4 .w wr_mode R#) _wrt_mode A0 D) move - 5 plane1 R#) _fg_bp_1 A0 D) move - 6 plane2 R#) _fg_bp_2 A0 D) move - 7 plane3 R#) _fg_bp_2 A0 D) move - 8 plane4 R#) _fg_bp_4 A0 D) move - 9 rts end-code -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ line 17sep86we - 1 - 2 Code line ( x1 y1 x2 y2 -- ) - 3 a_setup bsr - 4 -1 # _lstlin A0 D) move linemask R#) _ln_mask A0 D) move - 5 SP ) _y2 A0 D) move SP )+ cur_y R#) move - 6 SP ) _x2 A0 D) move SP )+ cur_x R#) move - 7 SP )+ _y1 A0 D) move - 8 SP )+ _x1 A0 D) move - 9 $A003 , Next end-code -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ rectangle 17sep86we - 1 - 2 Code rectangle ( x1 y1 width heigth -- ) - 3 a_setup bsr clipping R#) _clip A0 D) move - 4 SP )+ D0 move 2 SP D) D0 add D0 _y2 A0 D) move - 5 SP )+ D0 move 2 SP D) D0 add D0 _x2 A0 D) move - 6 SP )+ _y1 A0 D) move SP )+ _x1 A0 D) move - 7 pattern R#) D6 move D6 reg) A1 lea - 8 .l A1 _patptr A0 D) move .w - 9 pat_mask R#) _patmsk A0 D) move -10 multi_fill R#) _multifill A0 D) move -11 xmin_clip R#) _xmn_clip A0 D) move -12 ymin_clip R#) _ymn_clip A0 D) move -13 xmax_clip R#) _xmx_clip A0 D) move -14 ymax_clip R#) _ymx_clip A0 D) move -15 $A005 , Next end-code -Screen 9 not modified - 0 \ Maus-Functions 17sep86we - 1 - 2 Code show_mouse - 3 a_setup bsr .l _cntrl A0 D) A1 move - 4 .w 2 A1 D) clr 1 # 6 A1 D) move - 5 .l _intin A0 D) A1 move A1 ) clr $A009 , Next end-code - 6 - 7 Code hide_mouse $A00A , Next end-code - 8 - 9 Code form_mouse ( addr -- ) -10 a_setup bsr .l _intin A0 D) A1 move -11 .w SP )+ D6 move D6 reg) A0 lea -12 A0 )+ A1 )+ move A0 )+ A1 )+ move 1 # A1 )+ move -13 0 # A1 )+ move 1 # A1 )+ move -14 $10 D0 moveq D0 DO .l A0 )+ A1 )+ move LOOP -15 $A00B , Next end-code -Screen 10 not modified - 0 \ copyraster bp 12oct86 - 1 - 2 cr .( For copyraster use VDI-Functions !!) cr - 3 - 4 - 5 - 6 - 7 - 8 - 9 \\ -10 -11 $10 loadfrom gem\vdi.scr -12 -13 -14 -15 -Screen 11 not modified - 0 \ Checking cas20130106 - 1 - 2 | Create g_limits &320 , &200 , &640 , &200 , &640 , &400 , - 3 - 4 Code get_res ( -- flag ) - 5 4 # A7 -) move $0E trap 2 A7 addq D0 SP -) move - 6 Next end-code - 7 - 8 | : (check \ checking @ 0= ?exit - 9 dup g_limits scr_res @ 4 * 2+ + @ > abort" Y-Value too big" -10 over g_limits scr_res @ 4 * + @ > abort" X-Value too big" ; -11 -12 Code check ( x y -- x y ) -13 checking R#) tst 0= IF NEXT THEN ;c: (check ; -14 -15 -Screen 12 not modified - 0 \ relative set draw clipping 18sep86we - 1 - 2 Code relative ( dx dy -- x y ) - 3 SP )+ D0 move cur_y R#) D0 add - 4 SP )+ D1 move cur_x R#) D1 add - 5 D1 SP -) move D0 SP -) move Next end-code - 6 - 7 : set ( x y -- ) check cur_y ! cur_x ! ; - 8 : draw ( x y -- ) check cur_x @ cur_y @ 2swap line ; - 9 -10 : clip_window ( x1 y1 x2 y2 -- ) -11 clipping on -12 ymax_clip ! xmax_clip ! ymin_clip ! xmin_clip ! ; -13 -14 -15 -Screen 13 not modified - 0 \ box 18sep86we - 1 - 2 Code box ( width heigth -- ) - 3 cur_y R#) D4 move D4 D7 move SP )+ D7 add - 4 cur_x R#) D3 move D3 D5 move SP )+ D5 add - 5 a_setup bsr D3 _x1 A0 D) move D4 _y1 A0 D) move - 6 D5 _x2 A0 D) move D4 _y2 A0 D) move $A003 , - 7 a_setup bsr D5 _x1 A0 D) move D4 _y1 A0 D) move - 8 D5 _x2 A0 D) move D7 _y2 A0 D) move $A003 , - 9 a_setup bsr D3 _x1 A0 D) move D7 _y1 A0 D) move -10 D5 _x2 A0 D) move D7 _y2 A0 D) move $A003 , -11 a_setup bsr D3 _x1 A0 D) move D4 _y1 A0 D) move -12 D3 _x2 A0 D) move D7 _y2 A0 D) move $A003 , -13 Next end-code -14 -15 -Screen 14 not modified - 0 \ +sprite -sprite 11dec86we - 1 - 2 Code +sprite ( sprt_def_blk sprt_sav_blk x y -- ) - 3 SP )+ D1 move SP )+ D0 move - 4 SP )+ D6 move D6 reg) A2 lea - 5 SP )+ D6 move D6 reg) A0 lea - 6 .l $1E A7 -) movem> $A00D , $7800 A7 )+ movem< - 7 Next end-code - 8 - 9 Code -sprite ( sprt_sav_blk -- ) -10 SP )+ D6 move D6 reg) A2 lea -11 .l $1E A7 -) movem> $A00C , $7800 A7 )+ movem< -12 Next end-code -13 -14 -15 -Screen 15 not modified - 0 \ put_pixel get_pixel 17sep86we - 1 - 2 Code put_pixel ( x y color -- ) - 3 a_setup bsr .l a_base R#) A0 move - 4 _intin A0 D) A1 move .w SP )+ A1 ) move - 5 .l _ptsin A0 D) A1 move .w SP )+ 2 A1 D) move - 6 SP )+ A1 ) move - 7 $A001 , Next end-code - 8 - 9 Code get_pixel ( x y -- color ) -10 a_setup bsr -11 .l a_base R#) A0 move _ptsin A0 D) A1 move -12 .w SP )+ 2 A1 D) move SP )+ A1 ) move -13 $A002 , D0 SP -) move Next end-code -14 -15 -Screen 16 not modified - 0 \ polygon 17sep86we - 1 - 2 Code polygon ( x1 y1 ... xn yn n ) - 3 a_setup bsr - 4 clipping R#) _clip A0 D) move - 5 pattern R#) D6 move D6 reg) A1 lea - 6 .l A1 _patptr A0 D) move .w - 7 pat_mask R#) _patmsk A0 D) move - 8 multi_fill R#) _multifill A0 D) move - 9 xmin_clip R#) _xmn_clip A0 D) move -10 ymin_clip R#) _ymn_clip A0 D) move -11 xmax_clip R#) _xmx_clip A0 D) move -12 ymax_clip R#) _ymx_clip A0 D) move -13 .l _cntrl A0 D) A1 move .w SP ) 2 A1 D) move -14 SP )+ D0 move 2 # D0 asl 2 D0 subq D0 D5 move -15 $7FFF # D3 move 0 D4 moveq -Screen 17 not modified - 0 \ polygon forts. 17sep86we - 1 - 2 .l _ptsin A0 D) A1 move - 3 BEGIN .w 0 D0 SP DI) D1 move D1 A1 )+ move D0 1 # btst - 4 0= IF D1 D3 cmp CC IF D1 D3 move THEN - 5 D1 D4 cmp CS IF D1 D4 move THEN THEN - 6 D0 tst 0<> WHILE 2 D0 subq REPEAT - 7 0 D5 SP DI) A1 )+ move 2 D5 subq 0 D5 SP DI) A1 ) move - 8 4 D5 addq D5 SP adda - 9 .l A0 D5 move -10 BEGIN D5 A0 move .w D3 _y1 A0 D) move $A006 , -11 1 D3 addq D3 D4 cmp 0= UNTIL -12 Next end-code -13 -14 -15 -Screen 18 not modified - 0 \ - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 19 not modified - 0 \ Line A - Graphics Loadscreen - 1 - 2 - 3 Line-A Routinen erhalten ein eigenes Vocabular. - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 20 not modified - 0 \ Table offsets 01jan86we - 1 - 2 Die Definitionen auf diesem Screen enthalten die sogenannten - 3 Line_A Variablen. Der Aufruf ber $A000 liefert unter anderem - 4 die Basisadresse dieser Variablen zurck. - 5 - 6 Wenn diese Definitionen in anderen Programmen mitgenutzt werden - 7 sollen, mssen diese beiden Screens mit - 8 - 9 2 LOADFROM LINE_A.SCR -10 und 3 LOADFROM LINE_A.SCR -11 -12 eingebunden werden. -13 -14 -15 -Screen 21 not modified - 0 \ Table offsets 01jan86we - 1 - 2 Die Beschreibung der Line_A Variablen findet man in der ent- - 3 sprechenden Literatur (hoffentlich bald!!). - 4 - 5 Bei jeder Line_A Routine l„žt sich am Quelltext sehen, welche - 6 Variablen gerade benutzt werden. Allerdings sind unsere Unter- - 7 lagen (ATARI-Entwicklungspaket) auch nicht besonders aussage- - 8 f„hig.... - 9 -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 \ Variable bp 12oct86 - 1 - 2 Diese vier Variablen beschreiben das 'Clipping-Window'. Damit - 3 lassen sich alle Ausgaben auf dieses Window beschr„nken. - 4 Anzahl der Planes fr Fllmuster - 5 Bitmuster fr Linien ($FFFF = durchgezogen) - 6 Mit diesen vier Variablen werden die Farben der Planes fest- - 7 gelegt. - 8 - 9 -10 Hilfsvariable zur Vereinfachung bei Draw. Enth„lt die Endkoordi- -11 naten der zuletzt gezeichneten Linie. -12 Schreibmodus: 0=over, 1= trans, 2=exor, 3=invtrans -13 Bildschirmaufl”sung: 0=320x200, 1=320x400, 2=640x400 -14 -15 -Screen 23 not modified - 0 \ arrays 17sep86we - 1 - 2 Enth„lt die Anzahl - 1 der Worte in Arrays fr Fllmuster. - 3 Enth„lt die Adresse des aktuellen Fllmusters. - 4 - 5 Zwei wichtige Fllmuster: Leer - 6 und voll - 7 - 8 Flag, ob die Koordinaten berprft werden sollen (Geschwindigk.) - 9 Flag, ob mit Clipping gearbeitet wird. -10 -11 speichert die lange Adresse der Zeichs„tze. -12 speichert die lange Basis-Adresse der Line_A Variablen -13 -14 -15 -Screen 24 not modified - 0 \ Initialization 17sep86we - 1 - 2 Wird bei vielen Routinen zu Beginn benutzt. - 3 $A000 bergibt in A0 a_base, in A1 a_fonts - 4 Schreibmodus - 5 und die Farben der Planes bergeben - 6 Alle diese Werte werden aus den FORTH-Variablen in die ent- - 7 sprechenden Line_A Variablen geschrieben. - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 25 not modified - 0 \ line 17sep86we - 1 - 2 zeichnet eine Gerade von (x1,y1) nach (x2,y2). - 3 Initialisierung - 4 Original-Ton ATARI: Set it to -1 and forget it ! - 5 Die Werte fr x2,y2 werden auch in cur_x und cur_y gemerkt. - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 26 not modified - 0 \ rectangle 17sep86we - 1 - 2 zeichnet ein geflltes Rechteck mit x1,y1 als oberer linker Ecke - 3 und width und height als Breite und H”he. - 4 Umrechnung von Breite und H”he in Koordinaten - 5 - 6 - 7 Adresse des Fllmusters bergeben. - 8 - 9 Anzahl der Worte im Fllmuster -10 Anzahl der Planes fr Fllmuster -11 Koordinaten des Clipping-Rechtecks -12 -13 -14 -15 -Screen 27 not modified - 0 \ Maus-Functions 17sep86we - 1 - 2 schaltet Maus-Cursor ein - 3 CONTRL(1) wird gel”scht und CONTRL(3) auf 1 gesetzt (???) - 4 INTIN(0) wird gel”scht, sonst wird die Anzahl der hide-Aufrufe - 5 bercksichtigt (s.a. c-flag beim entsprechenden VDI-Aufruf) - 6 - 7 schaltet Maus-Cursor aus. - 8 - 9 Damit kann eine eigene Mausform entwickelt werden. -10 Adresse enth„lt ein Array mit folgendem Aufbau: -11 Maskenfarbe, Datenfarbe -12 16 Worte Maske -13 16 Worte Daten -14 -15 -Screen 28 not modified - 0 \ copyraster bp 12oct86 - 1 - 2 Die Copyrasterfunktionen verlangen eine sehr komplexe Parameter- - 3 bergabe. Diese ist im File VDI.SCR an der entsprechenden - 4 Stelle enthalten. Da diese Funktion gegenber der VDI-Funktion - 5 kaum Geschwindigkeitsvorteile bringt, wurde auf die nochmalige - 6 Definition hier verzichtet. - 7 - 8 Wen's interessiert, m”ge im File VDI.SCR unter Rasterfunctions - 9 nachlesen. -10 -11 So l„dt man den entsprechenden Teil der VDI-Bibliothek ! -12 Dieser Teil wird schon vom Editor ben”tigt und ist daher im -13 System normalerweise schon vorhanden. -14 -15 -Screen 29 not modified - 0 \ Checking 18sep86we - 1 - 2 Array mit den Grenzen fr die drei Aufl”sungsstufen. - 3 - 4 flag=0 bei 320x200, flag=1 bei 320x400, flag=2 bei 640x400 - 5 - 6 - 7 - 8 berprft, ob x und y innerhalb des Bildschirms liegen. - 9 Ansonsten erfolgt Abbruch. Diese Prfung kostet Zeit, erspart -10 aber Systemabstrze bei falschen Parametern. -11 -12 prft x und y, wenn checking eingeschaltet ist. -13 -14 -15 -Screen 30 not modified - 0 \ relative set draw clipping 18sep86we - 1 - 2 berechnet aus den Offsets dx und dy und den in cur_y und cur_y - 3 gespeicherten Werten die neuen Koordinaten x und y. - 4 - 5 - 6 - 7 setzt cur_x und cur_y - 8 zeichnet eine Linie von (cur_x,cur_y) nach (x,y). - 9 -10 setzt das Clipping-Window und schaltet clipping ein. -11 -12 -13 -14 -15 -Screen 31 not modified - 0 \ box 18sep86we - 1 - 2 zeichnet ein ungeflltes Rechteck mit der Breite width und H”he - 3 height. Die Koordinaten der linken oberen Ecke werden aus - 4 cur_x und cur_y entnommen. - 5 Das ganze besteht aus vier einzelnen Geraden. - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 32 not modified - 0 \ +sprite -sprite 17sep86we - 1 - 2 zeichnet ein Sprite und speichert den Bildschirm - 3 sprt_def_blk enth„lt die Sprite-Daten - 4 sprt_sav_blk ist die Adresse des Zwischenspeichers fr den Bild- - 5 schirm. Es werden pro Plane 64 Byte ben”tigt. - 6 (x,y) ist der 'Hotspot' des Sprites. - 7 - 8 l”scht das Sprite und restauriert den Bildschirm. - 9 -10 Der sprt_def_blk hat folgenden Aufbau: -11 x-offset zum Hotspot, y-offset zum Hotspot -12 Format-Flag, Hintergrundfarbe, Zeichenfarbe -13 32 Worte mit Muster: -14 Hintergrund 1.Zeile, Vordergrund 1.Zeile -15 Hintergrund 2.Zeile, Vordergrund 2.Zeile usw. -Screen 33 not modified - 0 \ put_pixel get_pixel 17sep86we - 1 - 2 zeichnet ein Pixel am Punkt (x,y) mit Farbe color. - 3 - 4 Man kann definieren: - 5 : plot ( x y -- ) 1 putpixel ; - 6 : unplot ( x y -- ) 0 putpixel ; - 7 - 8 - 9 color ist die Farbe des Punktes (x,y). -10 -11 -12 -13 -14 -15 -Screen 34 not modified - 0 \ polygon 17sep86we - 1 - 2 zeichnet ein n-Eck mit den Eckpunkten (x1,y1) ... (xn,yn). - 3 - 4 Clipping auswerten - 5 Fllmuster bergeben - 6 - 7 Fllmustermaske - 8 und Anzahl der Planes bergeben - 9 Clipping-Window setzen -10 -11 -12 -13 Anzahl der Ecken -14 Eckpunkte ins ptsin-Array bernehmen -15 D3 und D4 enthalten die Koordianten des gr”žten Punktes -Screen 35 not modified - 0 \ polygon forts. 17sep86we - 1 - 2 fr die Fllfunktion - 3 Werte bergeben und D3,D4 ggf updaten. - 4 - 5 - 6 - 7 ersten Punkt wiederholen, vereinfacht die šbergabe - 8 - 9 $A006 so oft aufrufen, bis das n-Eck vollst„ndig gefllt ist. -10 -11 -12 -13 -14 -15 -Screen 36 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/LINE_A.fth b/sources/AtariST/LINE_A.fth new file mode 100644 index 0000000..00bc17c --- /dev/null +++ b/sources/AtariST/LINE_A.fth @@ -0,0 +1,629 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Line-A Graphic *** cas20130106 + +This file contains the LINE-A graphic routines. While being +sometimes faster than VDI Routines, LINE-A Functions are not +supported on some newer Atari ST machines. + +It is recommended to only use VDI functions in new programs. +This library is provided for compatibility reasons to be able +to compile old source code. the programs will probablt not work +on newer Atari machines. + + +Examples for the use of LINE-A routines can be found in the file +DEMO.FB + + +\ *** Block No. 1 Hexblock 1 +\ Line A - Graphics Loadscreen cas20130106 + +Onlyforth +\needs Code include assemble.fb + +.( use of LINE-A is deprecated and will not work on newer ) +.( Atari machines. Please use VDI routines instead! ) + +Vocabulary Graphics Graphics also definitions + +1 $10 +thru + + + + + +\ *** Block No. 2 Hexblock 2 +\ Table offsets 26oct86we + +base @ decimal + 0 >label v_planes 2 >label v_lin_wr + 4 >label _cntrl + 8 >label _intin 12 >label _ptsin +16 >label _intout 20 >label _ptsout +24 >label _fg_bp_1 26 >label _fg_bp_2 +28 >label _fg_bp_3 30 >label _fg_bp_4 +32 >label _lstlin 34 >label _ln_mask +36 >label _wrt_mode 38 >label _x1 +40 >label _y1 42 >label _x2 +44 >label _y2 46 >label _patptr +50 >label _patmsk 52 >label _multifill +54 >label _clip 56 >label _xmn_clip +58 >label _ymn_clip 60 >label _xmx_clip +\ *** Block No. 3 Hexblock 3 +\ Table offsets 26oct86we + + 62 >label _ymx_clip 64 >label _xacc_dda + 66 >label _dda_inc 68 >label _t_sclsts + 70 >label _mono_status 72 >label _sourcex + 74 >label _sourcey 76 >label _destx + 78 >label _desty 80 >label _delx + 82 >label _dely 84 >label _fbase + 86 >label _fwidth 90 >label _style + 92 >label _litemask 94 >label _skewmask + 96 >label _weight 98 >label _r_off +100 >label _l_off 102 >label _scale +104 >label _chup 106 >label _text_fg +108 >label _scrtchp 112 >label _scrpt2 +114 >label _text_bg 116 >label _copytran +base ! +\ *** Block No. 4 Hexblock 4 +\ Variable cas20130106 + +Variable xmin_clip Variable xmax_clip +Variable ymin_clip Variable ymax_clip +Variable multi_fill 0 multi_fill ! +Variable linemask $FFFF linemask ! \ solid line +Variable plane1 1 plane1 ! \ black +Variable plane2 1 plane2 ! \ on +Variable plane3 0 plane3 ! \ white +Variable plane4 0 plane4 ! +Variable cur_x 0 cur_x ! +Variable cur_y 0 cur_y ! +Variable wr_mode 0 wr_mode ! \ overwrite +Variable scr_res 2 scr_res ! \ Hires + + +\ *** Block No. 5 Hexblock 5 +\ arrays 17sep86we + +Variable pat_mask 1 pat_mask ! +Variable pattern + +Create nopattern 0 , 0 , +Create fullpattern $FFFF , $FFFF , fullpattern pattern ! + +Variable checking checking on +Variable clipping clipping off + +Create a_fonts 4 allot +Create a_base 4 allot + + + +\ *** Block No. 6 Hexblock 6 +\ Initialization 17sep86we + +Create a_setup Assembler + $A000 , .l A0 a_base R#) move A1 a_fonts R#) move + .w wr_mode R#) _wrt_mode A0 D) move + plane1 R#) _fg_bp_1 A0 D) move + plane2 R#) _fg_bp_2 A0 D) move + plane3 R#) _fg_bp_2 A0 D) move + plane4 R#) _fg_bp_4 A0 D) move + rts end-code + + + + + + +\ *** Block No. 7 Hexblock 7 +\ line 17sep86we + +Code line ( x1 y1 x2 y2 -- ) + a_setup bsr + -1 # _lstlin A0 D) move linemask R#) _ln_mask A0 D) move + SP ) _y2 A0 D) move SP )+ cur_y R#) move + SP ) _x2 A0 D) move SP )+ cur_x R#) move + SP )+ _y1 A0 D) move + SP )+ _x1 A0 D) move + $A003 , Next end-code + + + + + + +\ *** Block No. 8 Hexblock 8 +\ rectangle 17sep86we + +Code rectangle ( x1 y1 width heigth -- ) + a_setup bsr clipping R#) _clip A0 D) move + SP )+ D0 move 2 SP D) D0 add D0 _y2 A0 D) move + SP )+ D0 move 2 SP D) D0 add D0 _x2 A0 D) move + SP )+ _y1 A0 D) move SP )+ _x1 A0 D) move + pattern R#) D6 move D6 reg) A1 lea + .l A1 _patptr A0 D) move .w + pat_mask R#) _patmsk A0 D) move + multi_fill R#) _multifill A0 D) move + xmin_clip R#) _xmn_clip A0 D) move + ymin_clip R#) _ymn_clip A0 D) move + xmax_clip R#) _xmx_clip A0 D) move + ymax_clip R#) _ymx_clip A0 D) move + $A005 , Next end-code +\ *** Block No. 9 Hexblock 9 +\ Maus-Functions 17sep86we + +Code show_mouse + a_setup bsr .l _cntrl A0 D) A1 move + .w 2 A1 D) clr 1 # 6 A1 D) move + .l _intin A0 D) A1 move A1 ) clr $A009 , Next end-code + +Code hide_mouse $A00A , Next end-code + +Code form_mouse ( addr -- ) + a_setup bsr .l _intin A0 D) A1 move + .w SP )+ D6 move D6 reg) A0 lea + A0 )+ A1 )+ move A0 )+ A1 )+ move 1 # A1 )+ move + 0 # A1 )+ move 1 # A1 )+ move + $10 D0 moveq D0 DO .l A0 )+ A1 )+ move LOOP + $A00B , Next end-code +\ *** Block No. 10 Hexblock A +\ copyraster bp 12oct86 + +cr .( For copyraster use VDI-Functions !!) cr + + + + + + +\\ + +$10 loadfrom gem\vdi.scr + + + + +\ *** Block No. 11 Hexblock B +\ Checking cas20130106 + +| Create g_limits &320 , &200 , &640 , &200 , &640 , &400 , + +Code get_res ( -- flag ) + 4 # A7 -) move $0E trap 2 A7 addq D0 SP -) move + Next end-code + +| : (check \ checking @ 0= ?exit + dup g_limits scr_res @ 4 * 2+ + @ > abort" Y-Value too big" + over g_limits scr_res @ 4 * + @ > abort" X-Value too big" ; + +Code check ( x y -- x y ) + checking R#) tst 0= IF NEXT THEN ;c: (check ; + + +\ *** Block No. 12 Hexblock C +\ relative set draw clipping 18sep86we + +Code relative ( dx dy -- x y ) + SP )+ D0 move cur_y R#) D0 add + SP )+ D1 move cur_x R#) D1 add + D1 SP -) move D0 SP -) move Next end-code + +: set ( x y -- ) check cur_y ! cur_x ! ; +: draw ( x y -- ) check cur_x @ cur_y @ 2swap line ; + +: clip_window ( x1 y1 x2 y2 -- ) + clipping on + ymax_clip ! xmax_clip ! ymin_clip ! xmin_clip ! ; + + + +\ *** Block No. 13 Hexblock D +\ box 18sep86we + +Code box ( width heigth -- ) + cur_y R#) D4 move D4 D7 move SP )+ D7 add + cur_x R#) D3 move D3 D5 move SP )+ D5 add + a_setup bsr D3 _x1 A0 D) move D4 _y1 A0 D) move + D5 _x2 A0 D) move D4 _y2 A0 D) move $A003 , + a_setup bsr D5 _x1 A0 D) move D4 _y1 A0 D) move + D5 _x2 A0 D) move D7 _y2 A0 D) move $A003 , + a_setup bsr D3 _x1 A0 D) move D7 _y1 A0 D) move + D5 _x2 A0 D) move D7 _y2 A0 D) move $A003 , + a_setup bsr D3 _x1 A0 D) move D4 _y1 A0 D) move + D3 _x2 A0 D) move D7 _y2 A0 D) move $A003 , + Next end-code + + +\ *** Block No. 14 Hexblock E +\ +sprite -sprite 11dec86we + +Code +sprite ( sprt_def_blk sprt_sav_blk x y -- ) + SP )+ D1 move SP )+ D0 move + SP )+ D6 move D6 reg) A2 lea + SP )+ D6 move D6 reg) A0 lea + .l $1E A7 -) movem> $A00D , $7800 A7 )+ movem< + Next end-code + +Code -sprite ( sprt_sav_blk -- ) + SP )+ D6 move D6 reg) A2 lea + .l $1E A7 -) movem> $A00C , $7800 A7 )+ movem< + Next end-code + + + +\ *** Block No. 15 Hexblock F +\ put_pixel get_pixel 17sep86we + +Code put_pixel ( x y color -- ) + a_setup bsr .l a_base R#) A0 move + _intin A0 D) A1 move .w SP )+ A1 ) move + .l _ptsin A0 D) A1 move .w SP )+ 2 A1 D) move + SP )+ A1 ) move + $A001 , Next end-code + +Code get_pixel ( x y -- color ) + a_setup bsr + .l a_base R#) A0 move _ptsin A0 D) A1 move + .w SP )+ 2 A1 D) move SP )+ A1 ) move + $A002 , D0 SP -) move Next end-code + + +\ *** Block No. 16 Hexblock 10 +\ polygon 17sep86we + +Code polygon ( x1 y1 ... xn yn n ) + a_setup bsr + clipping R#) _clip A0 D) move + pattern R#) D6 move D6 reg) A1 lea + .l A1 _patptr A0 D) move .w + pat_mask R#) _patmsk A0 D) move + multi_fill R#) _multifill A0 D) move + xmin_clip R#) _xmn_clip A0 D) move + ymin_clip R#) _ymn_clip A0 D) move + xmax_clip R#) _xmx_clip A0 D) move + ymax_clip R#) _ymx_clip A0 D) move + .l _cntrl A0 D) A1 move .w SP ) 2 A1 D) move + SP )+ D0 move 2 # D0 asl 2 D0 subq D0 D5 move + $7FFF # D3 move 0 D4 moveq +\ *** Block No. 17 Hexblock 11 +\ polygon forts. 17sep86we + + .l _ptsin A0 D) A1 move + BEGIN .w 0 D0 SP DI) D1 move D1 A1 )+ move D0 1 # btst + 0= IF D1 D3 cmp CC IF D1 D3 move THEN + D1 D4 cmp CS IF D1 D4 move THEN THEN + D0 tst 0<> WHILE 2 D0 subq REPEAT + 0 D5 SP DI) A1 )+ move 2 D5 subq 0 D5 SP DI) A1 ) move + 4 D5 addq D5 SP adda + .l A0 D5 move + BEGIN D5 A0 move .w D3 _y1 A0 D) move $A006 , + 1 D3 addq D3 D4 cmp 0= UNTIL + Next end-code + + + +\ *** Block No. 18 Hexblock 12 +\ + + + + + + + + + + + + + + + +\ *** Block No. 19 Hexblock 13 +\ Line A - Graphics Loadscreen + + +Line-A Routinen erhalten ein eigenes Vocabular. + + + + + + + + + + + + +\ *** Block No. 20 Hexblock 14 +\ Table offsets 01jan86we + +Die Definitionen auf diesem Screen enthalten die sogenannten +Line_A Variablen. Der Aufruf ber $A000 liefert unter anderem +die Basisadresse dieser Variablen zurck. + +Wenn diese Definitionen in anderen Programmen mitgenutzt werden +sollen, mssen diese beiden Screens mit + + 2 LOADFROM LINE_A.SCR +und 3 LOADFROM LINE_A.SCR + +eingebunden werden. + + + +\ *** Block No. 21 Hexblock 15 +\ Table offsets 01jan86we + +Die Beschreibung der Line_A Variablen findet man in der ent- +sprechenden Literatur (hoffentlich bald!!). + +Bei jeder Line_A Routine l„žt sich am Quelltext sehen, welche +Variablen gerade benutzt werden. Allerdings sind unsere Unter- +lagen (ATARI-Entwicklungspaket) auch nicht besonders aussage- +f„hig.... + + + + + + + +\ *** Block No. 22 Hexblock 16 +\ Variable bp 12oct86 + +Diese vier Variablen beschreiben das 'Clipping-Window'. Damit + lassen sich alle Ausgaben auf dieses Window beschr„nken. +Anzahl der Planes fr Fllmuster +Bitmuster fr Linien ($FFFF = durchgezogen) +Mit diesen vier Variablen werden die Farben der Planes fest- + gelegt. + + +Hilfsvariable zur Vereinfachung bei Draw. Enth„lt die Endkoordi- + naten der zuletzt gezeichneten Linie. +Schreibmodus: 0=over, 1= trans, 2=exor, 3=invtrans +Bildschirmaufl”sung: 0=320x200, 1=320x400, 2=640x400 + + +\ *** Block No. 23 Hexblock 17 +\ arrays 17sep86we + +Enth„lt die Anzahl - 1 der Worte in Arrays fr Fllmuster. +Enth„lt die Adresse des aktuellen Fllmusters. + +Zwei wichtige Fllmuster: Leer +und voll + +Flag, ob die Koordinaten berprft werden sollen (Geschwindigk.) +Flag, ob mit Clipping gearbeitet wird. + +speichert die lange Adresse der Zeichs„tze. +speichert die lange Basis-Adresse der Line_A Variablen + + + +\ *** Block No. 24 Hexblock 18 +\ Initialization 17sep86we + +Wird bei vielen Routinen zu Beginn benutzt. + $A000 bergibt in A0 a_base, in A1 a_fonts + Schreibmodus + und die Farben der Planes bergeben + Alle diese Werte werden aus den FORTH-Variablen in die ent- + sprechenden Line_A Variablen geschrieben. + + + + + + + + +\ *** Block No. 25 Hexblock 19 +\ line 17sep86we + +zeichnet eine Gerade von (x1,y1) nach (x2,y2). + Initialisierung + Original-Ton ATARI: Set it to -1 and forget it ! + Die Werte fr x2,y2 werden auch in cur_x und cur_y gemerkt. + + + + + + + + + + +\ *** Block No. 26 Hexblock 1A +\ rectangle 17sep86we + +zeichnet ein geflltes Rechteck mit x1,y1 als oberer linker Ecke + und width und height als Breite und H”he. + Umrechnung von Breite und H”he in Koordinaten + + + Adresse des Fllmusters bergeben. + + Anzahl der Worte im Fllmuster + Anzahl der Planes fr Fllmuster + Koordinaten des Clipping-Rechtecks + + + + +\ *** Block No. 27 Hexblock 1B +\ Maus-Functions 17sep86we + +schaltet Maus-Cursor ein + CONTRL(1) wird gel”scht und CONTRL(3) auf 1 gesetzt (???) + INTIN(0) wird gel”scht, sonst wird die Anzahl der hide-Aufrufe + bercksichtigt (s.a. c-flag beim entsprechenden VDI-Aufruf) + +schaltet Maus-Cursor aus. + +Damit kann eine eigene Mausform entwickelt werden. + Adresse enth„lt ein Array mit folgendem Aufbau: + Maskenfarbe, Datenfarbe + 16 Worte Maske + 16 Worte Daten + + +\ *** Block No. 28 Hexblock 1C +\ copyraster bp 12oct86 + +Die Copyrasterfunktionen verlangen eine sehr komplexe Parameter- + bergabe. Diese ist im File VDI.SCR an der entsprechenden + Stelle enthalten. Da diese Funktion gegenber der VDI-Funktion + kaum Geschwindigkeitsvorteile bringt, wurde auf die nochmalige + Definition hier verzichtet. + +Wen's interessiert, m”ge im File VDI.SCR unter Rasterfunctions + nachlesen. + +So l„dt man den entsprechenden Teil der VDI-Bibliothek ! + Dieser Teil wird schon vom Editor ben”tigt und ist daher im + System normalerweise schon vorhanden. + + +\ *** Block No. 29 Hexblock 1D +\ Checking 18sep86we + +Array mit den Grenzen fr die drei Aufl”sungsstufen. + +flag=0 bei 320x200, flag=1 bei 320x400, flag=2 bei 640x400 + + + +berprft, ob x und y innerhalb des Bildschirms liegen. + Ansonsten erfolgt Abbruch. Diese Prfung kostet Zeit, erspart + aber Systemabstrze bei falschen Parametern. + +prft x und y, wenn checking eingeschaltet ist. + + + +\ *** Block No. 30 Hexblock 1E +\ relative set draw clipping 18sep86we + +berechnet aus den Offsets dx und dy und den in cur_y und cur_y + gespeicherten Werten die neuen Koordinaten x und y. + + + +setzt cur_x und cur_y +zeichnet eine Linie von (cur_x,cur_y) nach (x,y). + +setzt das Clipping-Window und schaltet clipping ein. + + + + + +\ *** Block No. 31 Hexblock 1F +\ box 18sep86we + +zeichnet ein ungeflltes Rechteck mit der Breite width und H”he + height. Die Koordinaten der linken oberen Ecke werden aus + cur_x und cur_y entnommen. + Das ganze besteht aus vier einzelnen Geraden. + + + + + + + + + + +\ *** Block No. 32 Hexblock 20 +\ +sprite -sprite 17sep86we + +zeichnet ein Sprite und speichert den Bildschirm +sprt_def_blk enth„lt die Sprite-Daten +sprt_sav_blk ist die Adresse des Zwischenspeichers fr den Bild- + schirm. Es werden pro Plane 64 Byte ben”tigt. +(x,y) ist der 'Hotspot' des Sprites. + +l”scht das Sprite und restauriert den Bildschirm. + +Der sprt_def_blk hat folgenden Aufbau: + x-offset zum Hotspot, y-offset zum Hotspot + Format-Flag, Hintergrundfarbe, Zeichenfarbe + 32 Worte mit Muster: + Hintergrund 1.Zeile, Vordergrund 1.Zeile + Hintergrund 2.Zeile, Vordergrund 2.Zeile usw. +\ *** Block No. 33 Hexblock 21 +\ put_pixel get_pixel 17sep86we + +zeichnet ein Pixel am Punkt (x,y) mit Farbe color. + +Man kann definieren: + : plot ( x y -- ) 1 putpixel ; + : unplot ( x y -- ) 0 putpixel ; + + +color ist die Farbe des Punktes (x,y). + + + + + + +\ *** Block No. 34 Hexblock 22 +\ polygon 17sep86we + +zeichnet ein n-Eck mit den Eckpunkten (x1,y1) ... (xn,yn). + + Clipping auswerten + Fllmuster bergeben + + Fllmustermaske + und Anzahl der Planes bergeben + Clipping-Window setzen + + + + Anzahl der Ecken + Eckpunkte ins ptsin-Array bernehmen + D3 und D4 enthalten die Koordianten des gr”žten Punktes +\ *** Block No. 35 Hexblock 23 +\ polygon forts. 17sep86we + + fr die Fllfunktion + Werte bergeben und D3,D4 ggf updaten. + + + + ersten Punkt wiederholen, vereinfacht die šbergabe + + $A006 so oft aufrufen, bis das n-Eck vollst„ndig gefllt ist. + + + + + + +\ *** Block No. 36 Hexblock 24 + + + + + + + + + + + + + + + + diff --git a/sources/AtariST/MISC.FB.src b/sources/AtariST/MISC.FB.src deleted file mode 100644 index c9751d5..0000000 --- a/sources/AtariST/MISC.FB.src +++ /dev/null @@ -1,170 +0,0 @@ -Screen 0 not modified - 0 \\ *** Diverses *** 26oct86we - 1 - 2 In diesem File haben wir Worte untergebracht, die zwar h„ufig - 3 gebraucht werden, aber nicht bestimmten Files zugeordnet werden - 4 k”nnen. - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Loadscreen fr Diverses 26oct86we - 1 - 2 Onlyforth - 3 - 4 1 2 +thru - 5 - 6 ' .blk Is .status - 7 - 8 - 9 \ 3 +load setvec -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ H„ufig benutzte Definitionen 26oct86we - 1 - 2 : >absaddr ( addr -- abs_laddr ) 0 forthstart d+ ; - 3 - 4 : .blk ( -- ) blk @ ?dup 0= ?exit - 5 dup 1 = IF cr file? THEN ." Blk " . ?cr ; - 6 - 7 : abort( ( f -- ) - 8 IF [compile] .( true abort" !" THEN [compile] ( ; - 9 -10 \needs arguments abort( use definition in FILEINT.SCR) -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ H„ufig benutzte Definitionen II 26oct86we - 1 - 2 | Create: cpull - 3 rp@ count 2dup + even rp! r> swap cmove ; - 4 - 5 : cpush ( addr len --) r> -rot over >r - 6 rp@ over 2+ - even dup rp! place cpull >r >r ; - 7 - 8 - 9 : bell 7 con! ; -10 : blank ( addr count -- ) bl fill ; -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ TOS-Alerts abschalten 16oct86we - 1 - 2 Create oldvec 4 allot - 3 - 4 Label newvector - 5 -8 D1 cmpi 0<> IF -&13 D1 cmpi 0<> IF - 6 .l oldvec pcrel) A2 move A2 ) jmp THEN THEN - 7 .l D1 D0 move rts end-code - 8 - 9 : setvec $0.0404 l2@ oldvec 2! -10 newvector >absaddr $0.0404 l2! ; -11 -12 : restvec oldvec 2@ $0.0404 l2! ; -13 -14 : bye restvec bye ; -15 -Screen 5 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 \ Loadscreen fr Diverses 26oct86we - 1 - 2 setzt Searchorder auf FORTH FORTH ONLY FORTH - 3 - 4 kompiliert die n„chsten 2 Screens. - 5 - 6 .STATUS ist ein 'deferred word', das jeweils beim Kompilieren - 7 eines Quelltextscreens aufgerufen wird. - 8 - 9 Screen 4 wird nicht mitkompiliert, denn SETVEC muž nach jedem -10 Neustart wieder aufgerufen werden. Falls Sie diese Funktion -11 nutzen wollen, mssen Sie nach jedem Laden SETVEC eingeben. -12 (Dazu muž natrlich Screen 4 kompiliert worden sein.) -13 -14 -15 -Screen 7 not modified - 0 \ H„ufig benutzte Definitionen 26oct86we - 1 - 2 >ABSADDR rechnet eine - relative- Adresse im FORTH-System in - 3 eine absolute 32-Bit-Adresse um. - 4 .BLK gibt die Nummer des gerade kompilierten Screens aus, - 5 bei Screen 1 auch den Filenamen. - 6 - 7 ABORT( bewirkt das gleiche wie ABORT", ist aber im Direkt- - 8 modus zul„ssig. - 9 -10 ARGUMENTS prft, ob eine bestimmte (Mindest-)Anzahl von Werten -11 auf dem Stack liegt. Dieses Wort ist bereits im -12 FORTHKER.PRG vorhanden, da es vom File-Interface -13 gebraucht wird. -14 -15 -Screen 8 not modified - 0 \ H„ufig benutzte Definitionen II 26oct86we - 1 - 2 CPUSH sorgt im Zusammenspiel mit CPULL dafr, daž ein - 3 String (bzw. ein beliebiger Speicherbereich, z.B. - 4 ein Array) nach dem Aufruf einer Funktion wieder - 5 die alten Werte erh„lt. Entspricht dem Wort PUSH, - 6 aber fr Strings anstelle von Variablen. - 7 - 8 - 9 BELL Dieses Wort ist selbsterkl„rend !!! -10 BLANK fllt ab addr count Speicherstellen mit Leerzeichen. -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ TOS-Alerts abschalten 26oct86we - 1 - 2 Vielleicht haben Sie es schon einmal bemerkt. Wenn Sie auf eine - 3 Diskette schreiben wollen, bei der der Schreibschutz gesetzt - 4 ist, erscheint eine Alert-Box, aber ohne Maus, sodaž Sie den - 5 ABBRUCH-Knopf nur durch geduldiges Experimentieren mit der Maus - 6 erreichen k”nnen. Diese Box wird vom Betriebssystem ohne unser - 7 Zutun und ohne Einwirkungsm”glichkeit erzeugt. - 8 NEWVECTOR „ndert den zugeh”rigen Vector (critical error handler) - 9 so, daž diese Boxen nicht mehr erscheinen, wohl aber die, in -10 denen z.B. zum Diskettenwechsel aufgefordert wird. -11 SETVEC und RESTVEC dienen zum Umschalten zwischen altem und -12 neuen Vector. -13 Insbesondere muž BYE den alten Vector wiederherstellen, sonst -14 strzt das System gnadenlos ab. -15 Noch keine besonders elegante L”sung, aber besser als keine !! diff --git a/sources/AtariST/MISC.fth b/sources/AtariST/MISC.fth new file mode 100644 index 0000000..7a9b0d2 --- /dev/null +++ b/sources/AtariST/MISC.fth @@ -0,0 +1,170 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Diverses *** 26oct86we + +In diesem File haben wir Worte untergebracht, die zwar h„ufig + gebraucht werden, aber nicht bestimmten Files zugeordnet werden + k”nnen. + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Loadscreen fr Diverses 26oct86we + +Onlyforth + +1 2 +thru + +' .blk Is .status + + +\ 3 +load setvec + + + + + + +\ *** Block No. 2 Hexblock 2 +\ H„ufig benutzte Definitionen 26oct86we + +: >absaddr ( addr -- abs_laddr ) 0 forthstart d+ ; + +: .blk ( -- ) blk @ ?dup 0= ?exit + dup 1 = IF cr file? THEN ." Blk " . ?cr ; + +: abort( ( f -- ) + IF [compile] .( true abort" !" THEN [compile] ( ; + +\needs arguments abort( use definition in FILEINT.SCR) + + + + + +\ *** Block No. 3 Hexblock 3 +\ H„ufig benutzte Definitionen II 26oct86we + +| Create: cpull + rp@ count 2dup + even rp! r> swap cmove ; + +: cpush ( addr len --) r> -rot over >r + rp@ over 2+ - even dup rp! place cpull >r >r ; + + +: bell 7 con! ; +: blank ( addr count -- ) bl fill ; + + + + + +\ *** Block No. 4 Hexblock 4 +\ TOS-Alerts abschalten 16oct86we + +Create oldvec 4 allot + +Label newvector + -8 D1 cmpi 0<> IF -&13 D1 cmpi 0<> IF + .l oldvec pcrel) A2 move A2 ) jmp THEN THEN + .l D1 D0 move rts end-code + +: setvec $0.0404 l2@ oldvec 2! + newvector >absaddr $0.0404 l2! ; + +: restvec oldvec 2@ $0.0404 l2! ; + +: bye restvec bye ; + +\ *** Block No. 5 Hexblock 5 + + + + + + + + + + + + + + + + +\ *** Block No. 6 Hexblock 6 +\ Loadscreen fr Diverses 26oct86we + +setzt Searchorder auf FORTH FORTH ONLY FORTH + +kompiliert die n„chsten 2 Screens. + +.STATUS ist ein 'deferred word', das jeweils beim Kompilieren + eines Quelltextscreens aufgerufen wird. + +Screen 4 wird nicht mitkompiliert, denn SETVEC muž nach jedem + Neustart wieder aufgerufen werden. Falls Sie diese Funktion + nutzen wollen, mssen Sie nach jedem Laden SETVEC eingeben. + (Dazu muž natrlich Screen 4 kompiliert worden sein.) + + + +\ *** Block No. 7 Hexblock 7 +\ H„ufig benutzte Definitionen 26oct86we + +>ABSADDR rechnet eine - relative- Adresse im FORTH-System in + eine absolute 32-Bit-Adresse um. +.BLK gibt die Nummer des gerade kompilierten Screens aus, + bei Screen 1 auch den Filenamen. + +ABORT( bewirkt das gleiche wie ABORT", ist aber im Direkt- + modus zul„ssig. + +ARGUMENTS prft, ob eine bestimmte (Mindest-)Anzahl von Werten + auf dem Stack liegt. Dieses Wort ist bereits im + FORTHKER.PRG vorhanden, da es vom File-Interface + gebraucht wird. + + +\ *** Block No. 8 Hexblock 8 +\ H„ufig benutzte Definitionen II 26oct86we + +CPUSH sorgt im Zusammenspiel mit CPULL dafr, daž ein + String (bzw. ein beliebiger Speicherbereich, z.B. + ein Array) nach dem Aufruf einer Funktion wieder + die alten Werte erh„lt. Entspricht dem Wort PUSH, + aber fr Strings anstelle von Variablen. + + +BELL Dieses Wort ist selbsterkl„rend !!! +BLANK fllt ab addr count Speicherstellen mit Leerzeichen. + + + + + +\ *** Block No. 9 Hexblock 9 +\ TOS-Alerts abschalten 26oct86we + +Vielleicht haben Sie es schon einmal bemerkt. Wenn Sie auf eine + Diskette schreiben wollen, bei der der Schreibschutz gesetzt + ist, erscheint eine Alert-Box, aber ohne Maus, sodaž Sie den + ABBRUCH-Knopf nur durch geduldiges Experimentieren mit der Maus + erreichen k”nnen. Diese Box wird vom Betriebssystem ohne unser + Zutun und ohne Einwirkungsm”glichkeit erzeugt. +NEWVECTOR „ndert den zugeh”rigen Vector (critical error handler) + so, daž diese Boxen nicht mehr erscheinen, wohl aber die, in + denen z.B. zum Diskettenwechsel aufgefordert wird. +SETVEC und RESTVEC dienen zum Umschalten zwischen altem und + neuen Vector. +Insbesondere muž BYE den alten Vector wiederherstellen, sonst + strzt das System gnadenlos ab. +Noch keine besonders elegante L”sung, aber besser als keine !! diff --git a/sources/AtariST/PATCH.FB.src b/sources/AtariST/PATCH.FB.src deleted file mode 100644 index b3556fb..0000000 --- a/sources/AtariST/PATCH.FB.src +++ /dev/null @@ -1,68 +0,0 @@ -Screen 0 not modified - 0 \\ *** Loadscreen fr Arbeitssystem *** 03oct86we - 1 - 2 Die folgenden Screens werden benutzt, um von FORTHKER.PRG aus - 3 ein Arbeitssystem hochzuziehen. - 4 - 5 Da der Kernal noch kein Filesystem enth„lt, muž dieses zun„chst - 6 im Direktzugriff geladen werden. Assembler und Fileinterface - 7 mssen daher unbedingt am Anfang auf der Diskette liegen, damit - 8 die absoluten Blocknummern stimmen ($16 und $18). - 9 -10 Anschliežend werden die Files FORTH_83.SCR und FILEINT.SCR er- -11 zeugt und die View-Felder der Worte auf diese Files gepatched. -12 Dazu mssen diese Files auf Diskette vorhanden sein. -13 -14 Schliežlich werden mit INCLUDE die Files geladen, die man in -15 seinem System haben m”chte. -Screen 1 not modified - 0 - 1 - 2 6 load cr .( Internal Assembler loaded ) cr - 3 $18 load cr .( File-Interface loaded) cr - 4 1 +load cr .( now patch that stuff ... ) cr - 5 - 6 path A:\;B:\ - 7 - 8 use forth83.fb 0 0 patchviewfields - 9 use fileint.fb ' arguments >name 4- -$17 patchviewfields -10 -11 flush save -12 -13 -14 -15 -Screen 2 not modified - 0 \ patch view-fields bp 25May86 - 1 - 2 here 300 hallot heap dp ! - 3 Variable blockoffset - 4 : patch ( viewadr -- ) \ patch view field - 5 viewoffset blockoffset @ + swap +! ; - 6 - 7 : patchthread ( thread adr -- ) - 8 >r BEGIN @ dup WHILE dup 1- r@ u> - 9 WHILE dup 2- patch REPEAT drop rdrop ; -10 -11 : patchviewfields ( n adr -- ) \ adr is bottom of patch area -12 blockoffset ! voc-link -13 BEGIN @ ?dup WHILE 2dup 4- swap patchthread REPEAT -14 drop ; -15 dp ! -Screen 3 not modified - 0 \ 05oct86we - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/PATCH.fth b/sources/AtariST/PATCH.fth new file mode 100644 index 0000000..d7cda1f --- /dev/null +++ b/sources/AtariST/PATCH.fth @@ -0,0 +1,68 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Loadscreen fr Arbeitssystem *** 03oct86we + +Die folgenden Screens werden benutzt, um von FORTHKER.PRG aus +ein Arbeitssystem hochzuziehen. + +Da der Kernal noch kein Filesystem enth„lt, muž dieses zun„chst +im Direktzugriff geladen werden. Assembler und Fileinterface +mssen daher unbedingt am Anfang auf der Diskette liegen, damit +die absoluten Blocknummern stimmen ($16 und $18). + +Anschliežend werden die Files FORTH_83.SCR und FILEINT.SCR er- +zeugt und die View-Felder der Worte auf diese Files gepatched. +Dazu mssen diese Files auf Diskette vorhanden sein. + +Schliežlich werden mit INCLUDE die Files geladen, die man in +seinem System haben m”chte. +\ *** Block No. 1 Hexblock 1 + + + 6 load cr .( Internal Assembler loaded ) cr +$18 load cr .( File-Interface loaded) cr + 1 +load cr .( now patch that stuff ... ) cr + +path A:\;B:\ + +use forth83.fb 0 0 patchviewfields +use fileint.fb ' arguments >name 4- -$17 patchviewfields + +flush save + + + + +\ *** Block No. 2 Hexblock 2 +\ patch view-fields bp 25May86 + +here 300 hallot heap dp ! +Variable blockoffset +: patch ( viewadr -- ) \ patch view field + viewoffset blockoffset @ + swap +! ; + +: patchthread ( thread adr -- ) + >r BEGIN @ dup WHILE dup 1- r@ u> + WHILE dup 2- patch REPEAT drop rdrop ; + +: patchviewfields ( n adr -- ) \ adr is bottom of patch area + blockoffset ! voc-link + BEGIN @ ?dup WHILE 2dup 4- swap patchthread REPEAT + drop ; +dp ! +\ *** Block No. 3 Hexblock 3 +\ 05oct86we + + + + + + + + + + + + + + + diff --git a/sources/AtariST/PRINTER.FB.src b/sources/AtariST/PRINTER.FB.src deleted file mode 100644 index a6c89a0..0000000 --- a/sources/AtariST/PRINTER.FB.src +++ /dev/null @@ -1,510 +0,0 @@ -Screen 0 not modified - 0 \\ *** Printer-Interface *** 10oct86we - 1 - 2 Dieses File enth„lt das Printer-Interface. Die Definitionen fr - 3 die Druckersteuerung mssen ggf. an Ihren Drucker angepažt wer- - 4 den. - 5 - 6 PRINT lenkt alle Ausgabeworte auf den Drucker um, mit DISPLAY - 7 wird wieder auf dem Bildschirm ausgegeben. - 8 - 9 Zum Ausdrucken der Quelltexte gibt es die Worte -10 -11 pthru ( from to -- ) druckt Screen from bis to -12 document ( from to -- ) wie pthru, aber mit Shadow-Screens -13 printall ( -- ) wie pthru, aber druckt das ganze File -14 listing ( -- ) wie document, aber fr das ganze File -15 -Screen 1 not modified - 0 \ Printer Interface Epson RX80\FX80 21oct86we - 1 - 2 Onlyforth - 3 - 4 \needs file? ' noop | Alias file? - 5 \needs capacity ' blk/drv Alias capacity - 6 - 7 Vocabulary Printer Printer definitions also - 8 - 9 1 &13 +thru -10 -11 Onlyforth \ clear -12 -13 -14 -15 -Screen 2 not modified - 0 \ Printer p! and controls 18nov86we - 1 - 2 ' bcostat | Alias ready? ' 0 | Alias printer - 3 - 4 : p! ( n -- ) - 5 BEGIN pause printer ready? UNTIL printer bconout ; - 6 - 7 - 8 | : ctrl: ( 8b -- ) Create c, does> ( -- ) c@ p! ; - 9 -10 07 ctrl: BEL $7F | ctrl: DEL $0D | ctrl: RET -11 $1B | ctrl: ESC $0A ctrl: LF $0C ctrl: FF -12 -13 -14 -15 -Screen 3 not modified - 0 \ Printer controls 09sep86re - 1 - 2 | : esc: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! ; - 3 - 4 | : esc2 ( 8b0 8b1 -- ) ESC p! p! ; - 5 - 6 | : on: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! 1 p! ; - 7 - 8 | : off: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! 0 p! ; - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ Printer Escapes Epson RX-80/FX-80 12sep86re - 1 - 2 $0F | ctrl: (+17cpi $12 | ctrl: (-17cpi - 3 - 4 Ascii P | esc: (+10cpi Ascii M | esc: (+12cpi - 5 Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" - 6 Ascii 2 esc: 1/6" Ascii T esc: suoff - 7 Ascii N esc: +jump Ascii O esc: -jump - 8 Ascii G esc: +dark Ascii H esc: -dark - 9 \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive -10 -11 Ascii W on: +wide Ascii W off: -wide -12 Ascii - on: +under Ascii - off: -under -13 Ascii S on: sub Ascii S off: super -14 -15 -Screen 5 not modified - 0 \ Printer Escapes Epson RX-80/FX-80 12sep86re - 1 - 2 : 10cpi (-17cpi (+10cpi ; ' 10cpi Alias pica - 3 : 12cpi (-17cpi (+12cpi ; ' 12cpi Alias elite - 4 : 17cpi (+10cpi (+17cpi ; ' 17cpi Alias small - 5 - 6 : lines ( #.of.lines -- ) Ascii C esc2 ; - 7 - 8 : "long ( inches -- ) 0 lines p! ; - 9 -10 : american 0 Ascii R esc2 ; -11 -12 : german 2 Ascii R esc2 ; -13 -14 : normal 10cpi american suoff 1/6" &12 "long RET ; -15 -Screen 6 not modified - 0 \ Umlaute 14oct86we - 1 - 2 | Create DIN - 3 Ascii „ c, Ascii ” c, Ascii c, Ascii ž c, - 4 Ascii Ž c, Ascii ™ c, Ascii š c, Ascii Ý c, - 5 - 6 | Create AMI - 7 Ascii { c, Ascii | c, Ascii } c, Ascii ~ c, - 8 Ascii [ c, Ascii \ c, Ascii ] c, Ascii @ c, - 9 -10 here AMI - | Constant tablen -11 -12 | : p! ( char -- ) dup $80 < IF p! exit THEN -13 tablen 0 DO dup I DIN + c@ = -14 IF drop I AMI + c@ LEAVE THEN LOOP -15 german p! american ; -Screen 7 not modified - 0 \ Printer Output 12sep86re - 1 - 2 | Variable pcol pcol off | Variable prow prow off - 3 - 4 | : pemit ( 8b -- ) p! 1 pcol +! ; - 5 | : pcr ( -- ) RET LF 1 prow +! pcol off ; - 6 | : pdel ( -- ) DEL pcol @ 1- 0 max pcol ! ; - 7 | : ppage ( -- ) FF prow off pcol off ; - 8 | : pat ( row col -- ) over prow @ < IF ppage THEN - 9 swap prow @ - 0 ?DO pcr LOOP -10 dup pcol @ < IF RET pcol off THEN pcol @ - spaces ; -11 | : pat? ( -- row col ) prow @ pcol @ ; -12 | : ptype ( adr len -- ) -13 dup pcol +! bounds ?DO I c@ p! LOOP ; -14 -15 -Screen 8 not modified - 0 \ Printer output 18nov86we - 1 - 2 Output: >printer pemit pcr ptype pdel ppage pat pat? ; - 3 - 4 Forth definitions - 5 - 6 : print >printer normal ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ Variables and Setup bp 12oct86 - 1 - 2 Printer definitions - 3 - 4 ' 0 | Alias logo - 5 - 6 | : header ( pageno -- ) - 7 12cpi +dark ." volksFORTH-83 FORTH-Gesellschaft eV " - 8 -dark 17cpi ." (c) 1985/86 we/bp/re/ks " 12cpi +dark - 9 file? -dark 17cpi ." Seite " . ; -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ Print 2 screens across on a page 26oct86we - 1 - 2 | : 2lines ( scr#1 scr#2 line# -- ) - 3 cr dup 2 .r space c/l * >r - 4 pad c/l 2* 1+ bl fill swap - 5 block r@ + pad c/l cmove - 6 block r> + pad c/l + 1+ c/l cmove - 7 pad c/l 2* 1+ -trailing type ; - 8 - 9 | : 2screens ( scr#1 scr#2 -- ) -10 cr cr &30 spaces -11 +wide +dark over 4 .r &28 spaces dup 4 .r -wide -dark -12 cr l/s 0 DO 2dup I 2lines LOOP 2drop ; -13 -14 -15 -Screen 11 not modified - 0 \ print 6 screens on a page 18sep86we - 1 - 2 | : pageprint ( last+1 first pageno -- ) - 3 header 2dup - 1+ 2/ dup 0 - 4 ?DO >r 2dup under r@ + > - 5 IF dup r@ + ELSE logo THEN 2screens 1+ r> LOOP - 6 drop 2drop page ; - 7 - 8 | : >shadow ( n1 -- n2 ) - 9 capacity 2/ 2dup < IF + ELSE - THEN ; -10 -11 | : shadowprint ( last+1 first pageno -- ) -12 header 2dup - 0 -13 ?DO dup dup >shadow 2screens 1+ LOOP -14 2drop page ; -15 -Screen 12 not modified - 0 \ Printing without Shadows b11nov86we - 1 - 2 Forth definitions also - 3 - 4 | Variable printersem 0 printersem ! \ for multitasking - 5 - 6 : pthru ( first last -- ) 2 arguments - 7 printersem lock output push print - 8 1+ capacity umin swap 2dup - 6 /mod swap 0<> - 0 - 9 ?DO 2dup 6 + min over I 1+ pageprint 6 + LOOP -10 2drop printersem unlock ; -11 -12 : printall ( -- ) 0 capacity 1- pthru ; -13 -14 -15 -Screen 13 not modified - 0 \ Printing with Shadows bp 12oct86 - 1 - 2 : document ( first last -- ) - 3 printersem lock output push print - 4 1+ capacity 2/ umin swap 2dup - 3 /mod swap 0<> - 0 - 5 ?DO 2dup 3+ min over I 1+ shadowprint 3+ LOOP - 6 2drop printersem unlock ; - 7 - 8 : listing ( -- ) 0 capacity 2/ 1- document ; - 9 -10 -11 -12 -13 -14 -15 -Screen 14 not modified - 0 \ Printerspool 14oct86we - 1 - 2 \needs Task \\ - 3 - 4 $100 $200 Task spooler - 5 - 6 : spool' ( -- ) \ reads word - 7 ' isfile@ offset @ base @ spooler depth 1- 6 min pass - 8 base ! offset ! isfile ! execute - 9 true abort" SPOOL' ready for next job!" stop ; -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \\ *** Printer-Interface *** 13oct86we - 1 - 2 Eingestellt ist das Druckerinterface auf Epson und kompatible - 3 Drucker. Die Steuersequenzen auf den Screens 2, 4 und 5 mssen - 4 gegebenenfalls auf Ihren Drucker angepažt werden. Bei uns gab - 5 es mit verschiedenen Druckern allerdings keine Probleme, da - 6 sich inzwischen die meisten Druckerhersteller an die Epson- - 7 Steuercodes halten. - 8 - 9 Arbeiten Sie mit einem IBM-kompatiblen Drucker, muž die Umlaut- -10 wandlung auf Screen 6 wegkommentiert werden. -11 -12 Zus„tzliche 'exotische' Steuersequenzen k”nnen nach dem Muster -13 auf den Screens 4 und 5 jederzeit eingebaut werden. -14 -15 -Screen 16 not modified - 0 \ Printer Interface Epson RX80 13oct86we - 1 - 2 setzt order auf FORTH FORTH ONLY FORTH - 3 - 4 falls das Fileinterface nicht im System ist, werden die ent- - 5 sprechenden Worte ersetzt. - 6 - 7 Printer-Worte erhalten ein eigenes Vocabulary. - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 17 not modified - 0 \ Printer p! and controls 10oct86we - 1 - 2 nur aus stilistischen Grnden. Das Folgende liest sich besser. - 3 - 4 Hauptausgabewort; gibt ein Zeichen auf den Drucker aus. Es wird - 5 gewartet, bis der Drucker bereit ist. (PAUSE fr Multitasking) - 6 - 7 - 8 gibt Steuerzeichen an Drucker - 9 -10 Steuerzeichen fr Drucker. Gegebenenfalls anpassen! -11 -12 -13 -14 -15 -Screen 18 not modified - 0 \ Printer controls 10oct86we - 1 - 2 gibt Escape-Sequenzen an den Drucker aus. - 3 - 4 gibt Escape und zwei Zeichen aus. - 5 - 6 gibt Escape, ein Zeichen und eine 1 an den Drucker aus. - 7 - 8 gibt Escape, ein Zeichen und eine 0 an den Drucker aus. - 9 -10 -11 -12 -13 -14 -15 -Screen 19 not modified - 0 \ Printer Escapes Epson RX-80/FX-80 10oct86we - 1 - 2 setzt bzw. l”scht Ausgabe komprimierter Schrift. - 3 - 4 setzt Zeichenbreite auf 10 bzw. 12 cpi. - 5 Zeilenabstand in Zoll. - 6 schaltet Super- und Subscript ab - 7 Perforation berspringen ein- und ausschalten. - 8 Es folgen die Steuercodes fr Fettdruck, Kursivschrift, Breit- - 9 schrift, Unterstreichen, Subscript und Superscript. -10 Diese mssen ggf. an Ihren Drucker angepažt werden. -11 Selbstverst„ndlich k”nnen auch weitere F„higkeiten Ihres Druk- -12 kers genutzt werden wie Proportionalschrift, NLQ etc. -13 -14 -15 -Screen 20 not modified - 0 \ Printer Escapes Epson RX-80/FX-80 13oct86we - 1 - 2 Hier wird die Zeichenbreite eingestellt. Dazu kann man sowohl - 3 Worte mit der Anzahl der characters per inch (cpi) als auch - 4 pica, elite und small benutzen. - 5 - 6 setzt Anzahl der Zeilen pro Seite; Einstellung: - 7 &66 lines oder &12 "long - 8 - 9 -10 schaltet auf amerikanischen Zeichensatz. -11 -12 schaltet auf deutschen Zeichensatz. -13 -14 Voreinstellung des Druckers auf 'normale' Werte; wird beim -15 Einschalten mit PRINT ausgefhrt. -Screen 21 not modified - 0 \ Umlaute bp 12oct86 - 1 - 2 Auf diesem Screen werden die Umlaute aus dem IBM-(ATARI)-Zeichen - 3 satz in DIN-Umlaute aus dem deutschen Zeichensatz gewandelt. - 4 - 5 Wenn Sie einen IBM-kompatiblen Drucker benutzen, kann dieser - 6 Screen mit \\ in der ersten Zeile wegkommentiert werden. - 7 - 8 - 9 -10 -11 -12 p! wird neu definiert. Daher brauchen die folgenden Worte p! -13 nicht zu „ndern, egal, ob mit oder ohne Umlautwandlung gearbei- -14 tet wird. -15 -Screen 22 not modified - 0 \ Printer Output 10oct86we - 1 - 2 aktuelle Druckerzeile und -spalte. - 3 Routinen zur Druckerausgabe entspricht Befehl - 4 ein Zeichen auf Drucker emit - 5 CR und LF auf Drucker cr - 6 ein Zeichen l”schen (?!) del - 7 neue Seite page - 8 Drucker auf Zeile und Spalte at - 9 positionieren; wenn n”tig, -10 neue Seite. -11 Position feststellen at? -12 Zeichenkette ausgeben type -13 -14 Damit sind die Worte fr eine eigene Output-Struktur vorhanden. -15 -Screen 23 not modified - 0 \ Printer output 10oct86we - 1 - 2 erzeugt die Output-Tabelle >printer. - 3 - 4 Die folgenden Worte sind von FORTH aus zug„nglich. - 5 - 6 schaltet Ausgabe auf Printer um. (Zurckschalten mit DISPLAY) - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 \ Variables and Setup 10oct86we - 1 - 2 Diese Worte sind nur im Printer-Vokabular enthalten. - 3 - 4 Dieser Screen wird gedruckt, wenn es nichts besseres gibt. - 5 - 6 Druckt die šberschrift der Seite pageno. - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 25 not modified - 0 \ Print 2 screens across on a page 10oct86we - 1 - 2 druckt nebeneinander die Zeilen line# der beiden Screens. - 3 Die komplette Druck-Zeile wird erst in PAD aufbereitet. - 4 - 5 - 6 - 7 - 8 - 9 formatierte Ausgabe der beiden Screens nebeneinander -10 mit fettgedruckten Screennummern. Druck erfolgt mit 17cpi, also -11 in komprimierter Schrift. -12 -13 -14 -15 -Screen 26 not modified - 0 \ print 6 screens on a page 10oct86we - 1 - 2 gibt eine Seite aus. Anordnung der Screens auf der Seite: 1 4 - 3 Wenn weniger als 6 Screens vorhanden sind, werden 2 5 - 4 Lcken auf der rechten Seite mit dem Logo-Screen (0) 3 6 - 5 aufgefllt. - 6 - 7 - 8 berechnet zu Screen n1 den Shadowscreen n2 (Kommentarscreen wie - 9 dieser hier). -10 -11 wie pageprint, aber anstelle der Screens 4, 5 und 6 werden die -12 Shadowscreens zu 1, 2 und 3 gedruckt. -13 -14 -15 -Screen 27 not modified - 0 \ Printing without Shadows b22oct86we - 1 - 2 Die folgenden Definitionen stellen das Benutzer-Interface dar. - 3 Daher sollen sie in FORTH gefunden werden. - 4 - 5 PRINTERSEM ist ein Semaphor fr das Multitasking, der den Zugang - 6 auf den Drucker fr die einzelnen Tasks regelt. - 7 - 8 PTHRU gibt die Screens von from bis to aus. - 9 Ausgabeger„t merken und Drucker einschalten. Multitasking wird, -10 sofern es den Drucker betrifft, gesperrt. -11 Die Screens werden mit pageprint ausgegeben. -12 -13 -14 wie oben, jedoch wird das komplette File gedruckt. -15 -Screen 28 not modified - 0 \ Printing with Shadows 10oct86we - 1 - 2 wie pthru, aber mit Shadowscreens. - 3 - 4 - 5 - 6 - 7 - 8 wie printall, aber mit Shadowscreens. - 9 -10 -11 -12 -13 -14 -15 -Screen 29 not modified - 0 \ Printerspool 10oct86we - 1 - 2 Falls der Multitasker nicht vorhanden ist, wird abgebrochen. - 3 - 4 Der Arbeitsbereich der Task wird erzeugt. - 5 - 6 Mit diesem Wort wird das Drucken im Hintergrund gestartet. - 7 Aufruf mit : - 8 spool' listing - 9 spool' printall -10 from to spool' pthru -11 from to spool' document -12 Vor (oder auch nach) dem Aufruf von spool' muž der Multitasker -13 mit multitask eingeschaltet werden. -14 -15 diff --git a/sources/AtariST/PRINTER.fth b/sources/AtariST/PRINTER.fth new file mode 100644 index 0000000..fc990e8 --- /dev/null +++ b/sources/AtariST/PRINTER.fth @@ -0,0 +1,510 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Printer-Interface *** 10oct86we + +Dieses File enth„lt das Printer-Interface. Die Definitionen fr +die Druckersteuerung mssen ggf. an Ihren Drucker angepažt wer- +den. + +PRINT lenkt alle Ausgabeworte auf den Drucker um, mit DISPLAY +wird wieder auf dem Bildschirm ausgegeben. + +Zum Ausdrucken der Quelltexte gibt es die Worte + + pthru ( from to -- ) druckt Screen from bis to + document ( from to -- ) wie pthru, aber mit Shadow-Screens + printall ( -- ) wie pthru, aber druckt das ganze File + listing ( -- ) wie document, aber fr das ganze File + +\ *** Block No. 1 Hexblock 1 +\ Printer Interface Epson RX80\FX80 21oct86we + +Onlyforth + +\needs file? ' noop | Alias file? +\needs capacity ' blk/drv Alias capacity + +Vocabulary Printer Printer definitions also + + 1 &13 +thru + +Onlyforth \ clear + + + + +\ *** Block No. 2 Hexblock 2 +\ Printer p! and controls 18nov86we + +' bcostat | Alias ready? ' 0 | Alias printer + +: p! ( n -- ) + BEGIN pause printer ready? UNTIL printer bconout ; + + +| : ctrl: ( 8b -- ) Create c, does> ( -- ) c@ p! ; + + 07 ctrl: BEL $7F | ctrl: DEL $0D | ctrl: RET +$1B | ctrl: ESC $0A ctrl: LF $0C ctrl: FF + + + + +\ *** Block No. 3 Hexblock 3 +\ Printer controls 09sep86re + +| : esc: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! ; + +| : esc2 ( 8b0 8b1 -- ) ESC p! p! ; + +| : on: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! 1 p! ; + +| : off: ( 8b -- ) Create c, does> ( -- ) ESC c@ p! 0 p! ; + + + + + + + +\ *** Block No. 4 Hexblock 4 +\ Printer Escapes Epson RX-80/FX-80 12sep86re + +$0F | ctrl: (+17cpi $12 | ctrl: (-17cpi + +Ascii P | esc: (+10cpi Ascii M | esc: (+12cpi +Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" +Ascii 2 esc: 1/6" Ascii T esc: suoff +Ascii N esc: +jump Ascii O esc: -jump +Ascii G esc: +dark Ascii H esc: -dark +\ Ascii 4 esc: +cursive Ascii 5 esc: -cursive + +Ascii W on: +wide Ascii W off: -wide +Ascii - on: +under Ascii - off: -under +Ascii S on: sub Ascii S off: super + + +\ *** Block No. 5 Hexblock 5 +\ Printer Escapes Epson RX-80/FX-80 12sep86re + +: 10cpi (-17cpi (+10cpi ; ' 10cpi Alias pica +: 12cpi (-17cpi (+12cpi ; ' 12cpi Alias elite +: 17cpi (+10cpi (+17cpi ; ' 17cpi Alias small + +: lines ( #.of.lines -- ) Ascii C esc2 ; + +: "long ( inches -- ) 0 lines p! ; + +: american 0 Ascii R esc2 ; + +: german 2 Ascii R esc2 ; + +: normal 10cpi american suoff 1/6" &12 "long RET ; + +\ *** Block No. 6 Hexblock 6 +\ Umlaute 14oct86we + +| Create DIN +Ascii „ c, Ascii ” c, Ascii c, Ascii ž c, +Ascii Ž c, Ascii ™ c, Ascii š c, Ascii Ý c, + +| Create AMI +Ascii { c, Ascii | c, Ascii } c, Ascii ~ c, +Ascii [ c, Ascii \ c, Ascii ] c, Ascii @ c, + +here AMI - | Constant tablen + +| : p! ( char -- ) dup $80 < IF p! exit THEN + tablen 0 DO dup I DIN + c@ = + IF drop I AMI + c@ LEAVE THEN LOOP + german p! american ; +\ *** Block No. 7 Hexblock 7 +\ Printer Output 12sep86re + +| Variable pcol pcol off | Variable prow prow off + +| : pemit ( 8b -- ) p! 1 pcol +! ; +| : pcr ( -- ) RET LF 1 prow +! pcol off ; +| : pdel ( -- ) DEL pcol @ 1- 0 max pcol ! ; +| : ppage ( -- ) FF prow off pcol off ; +| : pat ( row col -- ) over prow @ < IF ppage THEN + swap prow @ - 0 ?DO pcr LOOP + dup pcol @ < IF RET pcol off THEN pcol @ - spaces ; +| : pat? ( -- row col ) prow @ pcol @ ; +| : ptype ( adr len -- ) + dup pcol +! bounds ?DO I c@ p! LOOP ; + + +\ *** Block No. 8 Hexblock 8 +\ Printer output 18nov86we + +Output: >printer pemit pcr ptype pdel ppage pat pat? ; + +Forth definitions + +: print >printer normal ; + + + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ Variables and Setup bp 12oct86 + +Printer definitions + +' 0 | Alias logo + +| : header ( pageno -- ) + 12cpi +dark ." volksFORTH-83 FORTH-Gesellschaft eV " + -dark 17cpi ." (c) 1985/86 we/bp/re/ks " 12cpi +dark + file? -dark 17cpi ." Seite " . ; + + + + + + +\ *** Block No. 10 Hexblock A +\ Print 2 screens across on a page 26oct86we + +| : 2lines ( scr#1 scr#2 line# -- ) + cr dup 2 .r space c/l * >r + pad c/l 2* 1+ bl fill swap + block r@ + pad c/l cmove + block r> + pad c/l + 1+ c/l cmove + pad c/l 2* 1+ -trailing type ; + +| : 2screens ( scr#1 scr#2 -- ) + cr cr &30 spaces + +wide +dark over 4 .r &28 spaces dup 4 .r -wide -dark + cr l/s 0 DO 2dup I 2lines LOOP 2drop ; + + + +\ *** Block No. 11 Hexblock B +\ print 6 screens on a page 18sep86we + +| : pageprint ( last+1 first pageno -- ) + header 2dup - 1+ 2/ dup 0 + ?DO >r 2dup under r@ + > + IF dup r@ + ELSE logo THEN 2screens 1+ r> LOOP + drop 2drop page ; + +| : >shadow ( n1 -- n2 ) + capacity 2/ 2dup < IF + ELSE - THEN ; + +| : shadowprint ( last+1 first pageno -- ) + header 2dup - 0 + ?DO dup dup >shadow 2screens 1+ LOOP + 2drop page ; + +\ *** Block No. 12 Hexblock C +\ Printing without Shadows b11nov86we + +Forth definitions also + +| Variable printersem 0 printersem ! \ for multitasking + +: pthru ( first last -- ) 2 arguments + printersem lock output push print + 1+ capacity umin swap 2dup - 6 /mod swap 0<> - 0 + ?DO 2dup 6 + min over I 1+ pageprint 6 + LOOP + 2drop printersem unlock ; + +: printall ( -- ) 0 capacity 1- pthru ; + + + +\ *** Block No. 13 Hexblock D +\ Printing with Shadows bp 12oct86 + +: document ( first last -- ) + printersem lock output push print + 1+ capacity 2/ umin swap 2dup - 3 /mod swap 0<> - 0 + ?DO 2dup 3+ min over I 1+ shadowprint 3+ LOOP + 2drop printersem unlock ; + +: listing ( -- ) 0 capacity 2/ 1- document ; + + + + + + + +\ *** Block No. 14 Hexblock E +\ Printerspool 14oct86we + +\needs Task \\ + +$100 $200 Task spooler + +: spool' ( -- ) \ reads word + ' isfile@ offset @ base @ spooler depth 1- 6 min pass + base ! offset ! isfile ! execute + true abort" SPOOL' ready for next job!" stop ; + + + + + + +\ *** Block No. 15 Hexblock F +\\ *** Printer-Interface *** 13oct86we + +Eingestellt ist das Druckerinterface auf Epson und kompatible + Drucker. Die Steuersequenzen auf den Screens 2, 4 und 5 mssen + gegebenenfalls auf Ihren Drucker angepažt werden. Bei uns gab + es mit verschiedenen Druckern allerdings keine Probleme, da + sich inzwischen die meisten Druckerhersteller an die Epson- + Steuercodes halten. + +Arbeiten Sie mit einem IBM-kompatiblen Drucker, muž die Umlaut- + wandlung auf Screen 6 wegkommentiert werden. + +Zus„tzliche 'exotische' Steuersequenzen k”nnen nach dem Muster + auf den Screens 4 und 5 jederzeit eingebaut werden. + + +\ *** Block No. 16 Hexblock 10 +\ Printer Interface Epson RX80 13oct86we + +setzt order auf FORTH FORTH ONLY FORTH + +falls das Fileinterface nicht im System ist, werden die ent- + sprechenden Worte ersetzt. + +Printer-Worte erhalten ein eigenes Vocabulary. + + + + + + + + +\ *** Block No. 17 Hexblock 11 +\ Printer p! and controls 10oct86we + +nur aus stilistischen Grnden. Das Folgende liest sich besser. + +Hauptausgabewort; gibt ein Zeichen auf den Drucker aus. Es wird + gewartet, bis der Drucker bereit ist. (PAUSE fr Multitasking) + + +gibt Steuerzeichen an Drucker + +Steuerzeichen fr Drucker. Gegebenenfalls anpassen! + + + + + +\ *** Block No. 18 Hexblock 12 +\ Printer controls 10oct86we + +gibt Escape-Sequenzen an den Drucker aus. + +gibt Escape und zwei Zeichen aus. + +gibt Escape, ein Zeichen und eine 1 an den Drucker aus. + +gibt Escape, ein Zeichen und eine 0 an den Drucker aus. + + + + + + + +\ *** Block No. 19 Hexblock 13 +\ Printer Escapes Epson RX-80/FX-80 10oct86we + +setzt bzw. l”scht Ausgabe komprimierter Schrift. + +setzt Zeichenbreite auf 10 bzw. 12 cpi. +Zeilenabstand in Zoll. + schaltet Super- und Subscript ab +Perforation berspringen ein- und ausschalten. +Es folgen die Steuercodes fr Fettdruck, Kursivschrift, Breit- + schrift, Unterstreichen, Subscript und Superscript. + Diese mssen ggf. an Ihren Drucker angepažt werden. + Selbstverst„ndlich k”nnen auch weitere F„higkeiten Ihres Druk- + kers genutzt werden wie Proportionalschrift, NLQ etc. + + + +\ *** Block No. 20 Hexblock 14 +\ Printer Escapes Epson RX-80/FX-80 13oct86we + +Hier wird die Zeichenbreite eingestellt. Dazu kann man sowohl + Worte mit der Anzahl der characters per inch (cpi) als auch + pica, elite und small benutzen. + +setzt Anzahl der Zeilen pro Seite; Einstellung: + &66 lines oder &12 "long + + +schaltet auf amerikanischen Zeichensatz. + +schaltet auf deutschen Zeichensatz. + +Voreinstellung des Druckers auf 'normale' Werte; wird beim + Einschalten mit PRINT ausgefhrt. +\ *** Block No. 21 Hexblock 15 +\ Umlaute bp 12oct86 + +Auf diesem Screen werden die Umlaute aus dem IBM-(ATARI)-Zeichen + satz in DIN-Umlaute aus dem deutschen Zeichensatz gewandelt. + +Wenn Sie einen IBM-kompatiblen Drucker benutzen, kann dieser + Screen mit \\ in der ersten Zeile wegkommentiert werden. + + + + + +p! wird neu definiert. Daher brauchen die folgenden Worte p! + nicht zu „ndern, egal, ob mit oder ohne Umlautwandlung gearbei- + tet wird. + +\ *** Block No. 22 Hexblock 16 +\ Printer Output 10oct86we + +aktuelle Druckerzeile und -spalte. +Routinen zur Druckerausgabe entspricht Befehl +ein Zeichen auf Drucker emit +CR und LF auf Drucker cr +ein Zeichen l”schen (?!) del +neue Seite page +Drucker auf Zeile und Spalte at + positionieren; wenn n”tig, + neue Seite. +Position feststellen at? +Zeichenkette ausgeben type + +Damit sind die Worte fr eine eigene Output-Struktur vorhanden. + +\ *** Block No. 23 Hexblock 17 +\ Printer output 10oct86we + +erzeugt die Output-Tabelle >printer. + +Die folgenden Worte sind von FORTH aus zug„nglich. + +schaltet Ausgabe auf Printer um. (Zurckschalten mit DISPLAY) + + + + + + + + + +\ *** Block No. 24 Hexblock 18 +\ Variables and Setup 10oct86we + +Diese Worte sind nur im Printer-Vokabular enthalten. + +Dieser Screen wird gedruckt, wenn es nichts besseres gibt. + +Druckt die šberschrift der Seite pageno. + + + + + + + + + +\ *** Block No. 25 Hexblock 19 +\ Print 2 screens across on a page 10oct86we + +druckt nebeneinander die Zeilen line# der beiden Screens. + Die komplette Druck-Zeile wird erst in PAD aufbereitet. + + + + + +formatierte Ausgabe der beiden Screens nebeneinander + mit fettgedruckten Screennummern. Druck erfolgt mit 17cpi, also + in komprimierter Schrift. + + + + +\ *** Block No. 26 Hexblock 1A +\ print 6 screens on a page 10oct86we + +gibt eine Seite aus. Anordnung der Screens auf der Seite: 1 4 + Wenn weniger als 6 Screens vorhanden sind, werden 2 5 + Lcken auf der rechten Seite mit dem Logo-Screen (0) 3 6 + aufgefllt. + + +berechnet zu Screen n1 den Shadowscreen n2 (Kommentarscreen wie + dieser hier). + +wie pageprint, aber anstelle der Screens 4, 5 und 6 werden die + Shadowscreens zu 1, 2 und 3 gedruckt. + + + +\ *** Block No. 27 Hexblock 1B +\ Printing without Shadows b22oct86we + +Die folgenden Definitionen stellen das Benutzer-Interface dar. + Daher sollen sie in FORTH gefunden werden. + +PRINTERSEM ist ein Semaphor fr das Multitasking, der den Zugang + auf den Drucker fr die einzelnen Tasks regelt. + +PTHRU gibt die Screens von from bis to aus. + Ausgabeger„t merken und Drucker einschalten. Multitasking wird, + sofern es den Drucker betrifft, gesperrt. + Die Screens werden mit pageprint ausgegeben. + + +wie oben, jedoch wird das komplette File gedruckt. + +\ *** Block No. 28 Hexblock 1C +\ Printing with Shadows 10oct86we + +wie pthru, aber mit Shadowscreens. + + + + + +wie printall, aber mit Shadowscreens. + + + + + + + +\ *** Block No. 29 Hexblock 1D +\ Printerspool 10oct86we + +Falls der Multitasker nicht vorhanden ist, wird abgebrochen. + +Der Arbeitsbereich der Task wird erzeugt. + +Mit diesem Wort wird das Drucken im Hintergrund gestartet. +Aufruf mit : + spool' listing + spool' printall + from to spool' pthru + from to spool' document +Vor (oder auch nach) dem Aufruf von spool' muž der Multitasker + mit multitask eingeschaltet werden. + + diff --git a/sources/AtariST/RAMDISK.FB.src b/sources/AtariST/RAMDISK.FB.src deleted file mode 100644 index f6c0677..0000000 --- a/sources/AtariST/RAMDISK.FB.src +++ /dev/null @@ -1,442 +0,0 @@ -Screen 0 not modified - 0 HOW TO USE THE RAMDISK bp 17Aug86 - 1 - 2 Die Ramdisk ist im Prinzip ein erweiterter Buffermechanismus, - 3 der Buffer aužerhalb des Forth-Systems verwaltet. Die Organi- - 4 sation ist analog, mit der Ausnahme, daž es kein Updateflag - 5 gibt, ge„nderte Bl”cke also sofort auf die Diskette zurckge- - 6 schrieben werden. Die Benutzung ist v”llig transparent, am - 7 Anfang muž nur einmal INITRAMDISK aufgerufen werden. - 8 - 9 Die Struktur der Buffer wird auf Screen 3 dargestellt. -10 -11 Die Ramdisk allokiert ihren Speicher mit MALLOC. -12 -13 -14 -15 -Screen 1 not modified - 0 \ loadscreen for more buffers bp 17Aug86 - 1 - 2 \needs 2over include double.scr - 3 - 4 Onlyforth - 5 - 6 \needs 4dup : 4dup 2over 2over ; - 7 \needs 4drop : 4drop 2drop 2drop ; - 8 \needs user' : user' ' >body c@ ; - 9 \needs d> : d> 2swap d< ; -10 -11 2 $B +thru -12 -13 1 +load \ patch ramdisk into system -14 -15 -Screen 2 not modified - 0 \ patch ramdisk into System bp 17Aug86 - 1 - 2 | : ((close ( fcb -- fcb ...) \ word for patch (CLOSE !! - 3 dup flushramfile [ Dos ' (close >body @ , ] ; - 4 - 5 | : (empty-buffers ( -- ...) \ word for patching EMPTY-BUFFE - 6 emptyramdisk [ ' empty-buffers >body @ , ] ; - 7 - 8 - 9 ' ramdiskr/w is r/w -10 ' ((close Dos ' (close >body ! -11 ' (empty-buffers ' empty-buffers >body ! -12 -13 save -14 initramdisk -15 -Screen 3 not modified - 0 \ Variables and Constants bp 10Aug86 - 1 - 2 2Variable ramprev 0. ramprev 2! \ points to first buffer - 3 2Variable ramfirst 0. ramfirst 2! \ start of buffer area - 4 2Variable ramsize 0. ramsize 2! \ length of buffer area - 5 - 6 $408 Constant b/rambuf - 7 - 8 | Code link>file ( d1 -- d2 ) .l 4 SP ) addq - 9 Label >next Next end-code -10 | Code link>block .l 6 SP ) addq >next bra end-code -11 | Code link>data .l 8 SP ) addq >next bra end-code -12 \\ -13 structure of a buffer: -14 | link to next buffer | file | block | data .... | -15 +0 +4 +6 +8 +1032 -Screen 4 not modified - 0 \ search for a buffer bp 24Aug86 - 1 \ D0:blk D1:file A0:bufadr A1:Vorgaenger - 2 Label thisbuffer? - 3 4 A0 D) D1 cmp 0= IF 6 A0 D) D0 cmp THEN rts - 4 - 5 Code rambuf? ( blk file -- dadr tf \ blk file ) - 6 2 SP D) D0 move SP ) D1 move - 7 .l ramprev r#) A0 move .w thisbuffer? bsr - 8 0= IF Label blockfound .l 8. # A0 adda A0 SP ) move .w - 9 true # SP -) move Next THEN -10 BEGIN .l A0 A1 move A1 ) A0 move 0. # A0 cmpa .w -11 0= IF false # SP -) move Next THEN -12 thisbuffer? bsr 0= UNTIL -13 .l A0 ) A1 ) move -14 ramprev r#) A0 ) move A0 ramprev r#) move .w -15 blockfound bra end-code -Screen 5 not modified - 0 \ read and write buffers b28sep86we - 1 - 2 | : readrambuf ( adr daddr -- ) \ copy from daddr to adr - 3 rot >absaddr b/blk lcmove ; - 4 - 5 | : writerambuf ( adr daddr --) \ copy from adr to daddr - 6 rot >absaddr 2swap b/blk lcmove ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 \ search for empty buffer bp 10Aug86 - 1 - 2 \ : takerambuf ( -- daddr ) \ get last buffer - 3 \ ramprev 2@ - 4 \ BEGIN 2dup link>file l@ 1+ ( empty buffer ? ) - 5 \ WHILE 2dup l2@ or ( last buffer ? ) - 6 \ WHILE l2@ REPEAT ; - 7 - 8 | Code takerambuf ( -- daddr ) - 9 .l ramprev r#) A0 move -10 Label takeloop .w -1 4 A0 D) cmpi -11 0<> IF .l A0 ) tst 0<> -12 IF A0 ) A0 move takeloop bra THEN THEN -13 A0 SP -) move Next end-code -14 -15 -Screen 7 not modified - 0 \ allocate a buffer bp 24Aug86 - 1 - 2 | 2Variable (daddr - 3 - 4 \ | : markrambuf ( blk file daddr -- daddr ) - 5 \ 2dup (daddr 2! link>file l! (daddr 2@ link>block l! - 6 \ (daddr 2@ ; - 7 - 8 | Code markrambuf ( blk file daddr -- daddr ) .l - 9 SP )+ A0 move .w SP )+ 4 A0 D) move -10 SP )+ 6 A0 D) move .l A0 SP -) move Next end-code -11 -12 | : makerambuf ( adr blk file -- ) \ create a buffer -13 BEGIN rambuf? 0= WHILE 2dup takerambuf markrambuf -14 2drop REPEAT writerambuf ; -15 -Screen 8 not modified - 0 \ clear buffers bp 10Aug86 - 1 - 2 : clearrambuf ( laddr -- ) \ clear a buffer - 3 link>file -1 -rot l! ; - 4 - 5 : flushramfile ( fcb -- ) \ clear all buffers of a file - 6 >r ramprev 2@ - 7 BEGIN 2dup or - 8 WHILE 2dup link>file l@ r@ = IF 2dup clearrambuf THEN - 9 l2@ REPEAT 2drop rdrop ; -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ allocate all buffers bp 10Aug86 - 1 - 2 | : nextbuf ( d1 -- d2) \ adr of next buffer - 3 b/rambuf extend d+ ; - 4 - 5 | : ramfull? ( daddr -- f) \ true if more buffers - 6 nextbuf ramsize 2@ ramfirst 2@ d+ d> 0= ; - 7 - 8 : emptyramdisk ( -- ) \ initialize ramdisk - 9 0. ramprev 2! ramfirst 2@ -10 BEGIN 2dup ramfull? -11 WHILE 2dup clearrambuf ( clear buffer ) -12 ramprev 2@ 2over l2! ( chain to list ) -13 2dup ramprev 2! ( store last buffer ) -14 nextbuf REPEAT 2drop ; -15 -Screen 10 not modified - 0 \ Interactive memory allocation bp 17Aug86 - 1 - 2 : #in ( -- n) query name number drop ; - 3 - 4 : initramdisk ( -- ) - 5 [ Dos ] 0. ramprev 2! - 6 ramfirst 2@ or IF ramfirst 2@ mfree - 7 drop ?diskabort 0. ramfirst 2! THEN - 8 cr ." Wie viele Kilos sollen es sein ? " #in - 9 b/rambuf um* 2. d+ 2dup malloc ( 2 Angstbytes zus.) -10 dup 0< IF drop ?diskabort THEN ( Fehler !) -11 dup 0= abort" Speicher voll !!" ( DR sei Dank gesagt !) -12 ramfirst 2! ramsize 2! -13 emptyramdisk ; -14 -15 -Screen 11 not modified - 0 \ new r/w bp 10Aug86 - 1 - 2 ' r/w >body @ Alias oldr/w - 3 - 4 : ramdiskr/w ( adr blk file rw/f -- f ) - 5 ramprev 2@ or 0= IF oldr/w exit THEN - 6 dup >r - 7 IF rambuf? IF readrambuf rdrop false exit THEN THEN - 8 r> 4dup oldr/w - 9 IF 4drop true exit THEN \ disk error ! -10 drop makerambuf false ; \ create or overwrite buffer -11 -12 -13 -14 -15 -Screen 12 not modified - 0 \ print a list of ram buffers bp 10Aug86 - 1 - 2 : .rambufs ( -- ) - 3 ramprev 2@ - 4 BEGIN 2dup or - 5 WHILE cr 2dup 8 d.r 5 spaces \ adress - 6 2dup link>file l@ - 7 dup 1+ IF [ Dos ] .file 4 spaces - 8 2dup link>block l@ 5 .r - 9 ELSE drop ." empty" THEN -10 l2@ stop? UNTIL 2drop ; -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ Wichtige Worte sind bp 17Aug86 - 1 - 2 INITRAMDISK ( -- ) fragt nach der Zahl der Anzahl der - 3 anzulegenden Buffer und erzeugt sie. - 4 - 5 EMPTYRAMDISK ( -- ) l”scht den Inhalt aller Buffer. - 6 - 7 RAMBUF? ( blk file -- dadr tf \ blk file ff ) - 8 sucht den Buffer blk im File file in der Ramdisk. - 9 -10 CLEARRAMBUF? ( laddr -- ) -11 markiert den Ramdiskbuffer bei Adr. laddr als leer. -12 -13 -14 .. -15 -Screen 14 not modified - 0 bp 17Aug86 - 1 - 2 - 3 - 4 - 5 - 6 Wird in RAMDISKR\W benutzt - 7 - 8 Gibt Offset einer Uservariablen in der Userarea. Dieses - 9 Wort geh”rt eigentlich in den Assembler ! -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 bp 17Aug86 - 1 - 2 Dieses Wort wird in (CLOSE gepatched. FCB ist die Adresse des - 3 zu schlieženden Files. Alle Blockpuffer dieses Files werden - 4 gel”scht. - 5 Dieses Wort wird in EMPTY-BUFFERS gepatched. Es l”scht alle - 6 Ramdiskpuffer - 7 - 8 - 9 Neues R/W -10 Patche (CLOSE -11 Patche EMPTY-BUFFERS -12 -13 -14 Frage nach der Gr”že der Ramdisk -15 -Screen 16 not modified - 0 bp 17Aug86 - 1 - 2 Zeiger auf den ersten Buffer in der Ramdisk. - 3 Beginn des fr die Ramdisk allokierten Speicherbereichs - 4 L„nge " " " " " " - 5 - 6 L„nge eines Buffers der Ramdisk - 7 - 8 Diese Worte erlauben den Zugriff auf die Felder eines - 9 Ramdiskbuffers. -10 -11 -12 -13 Dies ist die Struktur eines Ramdiskbuffers. Alle Buffer befinden -14 sich in einer gelinkten Liste, analog zum volksFORTH83-Block= -15 =buffermechanismus. -Screen 17 not modified - 0 bp 17Aug86 - 1 - 2 - 3 - 4 - 5 Sucht einen Buffer in der Ramdisk. Gesucht wird der Buffer - 6 mit der Nummer BLK aus dem File mit der Nummer FCB. - 7 Zun„chst wird der erste Eintrag untersucht (weniger Rechenzeit). - 8 Ist es nicht der oberste, so werden die restlichen Buffer - 9 verglichen. Wurde er gefunden, so wird der betreffende Buffer -10 an den Anfang der Liste geh„ngt, so daž die Buffer immer in -11 der Reihenfolge des Zugriffs geordnet sind. Dadurch wird die -12 Zugriffsgeschwindigkeit erh”ht. -13 -14 -15 -Screen 18 not modified - 0 bp 17Aug86 - 1 - 2 Kopiert den Inhalt des Ramdiskbuffers in den Blockbuffer des - 3 volksFORTH-Systems - 4 - 5 Kopiert den Inhalt des Blockbuffers im System in den Ramdisk= - 6 =buffer. - 7 - 8 Diese beiden Worte k”nnen noch optimiert werden, da LCMOVE - 9 byteweise bertr„gt, aber auch langwortweise bertragen -10 werden kann. -11 -12 -13 -14 -15 -Screen 19 not modified - 0 bp 17Aug86 - 1 - 2 Dieses Wort sucht einen leeren Ramdiskbuffer. Ist keiner leer, - 3 so wird der letzte Buffer in der Liste genommen. - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 20 not modified - 0 bp 24Aug86 - 1 - 2 Hilfsvariable - 3 - 4 Markiert den Ramdiskbuffer DADDR als Buffer fr den Block BLK - 5 im File FILE. - 6 - 7 - 8 - 9 -10 -11 -12 Erzeugt einen Buffer fr den Blockl BLK des Files FILE in der -13 Ramdisk. Der Inhalt des Buffers steht ab Adresse ADR im System. -14 RAMBUF? wird benutzt, um den allokierten Buffer an die erste -15 Stelle zu h„ngen. Der WHILE-Teil wird max. einmal durchlaufen ! -Screen 21 not modified - 0 bp 17Aug86 - 1 - 2 L”scht den Buffer LADDR. - 3 - 4 - 5 L”scht alle Ramdiskbuffer, die zum File FCB geh”ren. - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 bp 17Aug86 - 1 - 2 Berechnet die Adresse D2 des Ramdiskbuffers, der auf den Buffer - 3 mit der Adresse D1 folgt. - 4 - 5 F ist wahr, falls noch weitere Buffer in der Ramdisk allokiert - 6 werden k”nnen. - 7 - 8 Initialisiert die Ramdisk. Es werden soviele Buffer angelegt, - 9 wie in den durch RAMFIRST und RAMSIZE angegebenen Speicher= -10 =bereich passen. Alle allokierten Buffer werden als leer -11 markiert. -12 -13 -14 -15 -Screen 23 not modified - 0 bp 17Aug86 - 1 - 2 Liest eine Zahl von der Tastatur ein - 3 - 4 Erzeugt die Ramdisk. Zun„chst wird der alte Speicherbereich - 5 freigegeben, falls einer allokiert war. Dann wird nach der - 6 gewnschten Zahl von Buffern gefragt. Es wird ein Speicher= - 7 =bereich vom GEM-Dos angeordert und mit leeren Buffern - 8 gefllt. - 9 -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 bp 17Aug86 - 1 - 2 Die alte R/W-Routine wird natrlich auch ben”tigt. - 3 - 4 Kommuniziert mit den Massenspeichern. - 5 RW/F ist wahr, falls ein Lesezugriff erfolgen soll. - 6 Ist die Ramdisk leer, so darf sie nicht angesprochen werden ! - 7 Sonst wird geprft, ob es sich um einen Lesezugriff handelt - 8 und ob der Buffer in der Ramdisk vorliegt. Ist das der Fall, - 9 so wird einfach dessen Inhalt kopiert. Andernfalls muž, falls -10 noch nicht vorhanden, ein Buffer allokiert werden. Der Inhalt -11 des Systembuffers wird dann in die Ramdisk kopiert und steht -12 beim n„chsten Lesezugriff zur Verfgung. -13 -14 -15 -Screen 25 not modified - 0 bp 17Aug86 - 1 - 2 Es wird eine Liste mit dem Inhalt aller Ramdiskbuffer ausgegeben - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/RAMDISK.fth b/sources/AtariST/RAMDISK.fth new file mode 100644 index 0000000..a2efd2f --- /dev/null +++ b/sources/AtariST/RAMDISK.fth @@ -0,0 +1,442 @@ +\ *** Block No. 0 Hexblock 0 + HOW TO USE THE RAMDISK bp 17Aug86 + +Die Ramdisk ist im Prinzip ein erweiterter Buffermechanismus, +der Buffer aužerhalb des Forth-Systems verwaltet. Die Organi- +sation ist analog, mit der Ausnahme, daž es kein Updateflag +gibt, ge„nderte Bl”cke also sofort auf die Diskette zurckge- +schrieben werden. Die Benutzung ist v”llig transparent, am +Anfang muž nur einmal INITRAMDISK aufgerufen werden. + +Die Struktur der Buffer wird auf Screen 3 dargestellt. + +Die Ramdisk allokiert ihren Speicher mit MALLOC. + + + + +\ *** Block No. 1 Hexblock 1 +\ loadscreen for more buffers bp 17Aug86 + +\needs 2over include double.scr + +Onlyforth + +\needs 4dup : 4dup 2over 2over ; +\needs 4drop : 4drop 2drop 2drop ; +\needs user' : user' ' >body c@ ; +\needs d> : d> 2swap d< ; + +2 $B +thru + + 1 +load \ patch ramdisk into system + + +\ *** Block No. 2 Hexblock 2 +\ patch ramdisk into System bp 17Aug86 + +| : ((close ( fcb -- fcb ...) \ word for patch (CLOSE !! + dup flushramfile [ Dos ' (close >body @ , ] ; + +| : (empty-buffers ( -- ...) \ word for patching EMPTY-BUFFE + emptyramdisk [ ' empty-buffers >body @ , ] ; + + +' ramdiskr/w is r/w +' ((close Dos ' (close >body ! +' (empty-buffers ' empty-buffers >body ! + +save +initramdisk + +\ *** Block No. 3 Hexblock 3 +\ Variables and Constants bp 10Aug86 + +2Variable ramprev 0. ramprev 2! \ points to first buffer +2Variable ramfirst 0. ramfirst 2! \ start of buffer area +2Variable ramsize 0. ramsize 2! \ length of buffer area + +$408 Constant b/rambuf + +| Code link>file ( d1 -- d2 ) .l 4 SP ) addq + Label >next Next end-code +| Code link>block .l 6 SP ) addq >next bra end-code +| Code link>data .l 8 SP ) addq >next bra end-code + \\ +structure of a buffer: +| link to next buffer | file | block | data .... | ++0 +4 +6 +8 +1032 +\ *** Block No. 4 Hexblock 4 +\ search for a buffer bp 24Aug86 +\ D0:blk D1:file A0:bufadr A1:Vorgaenger +Label thisbuffer? + 4 A0 D) D1 cmp 0= IF 6 A0 D) D0 cmp THEN rts + +Code rambuf? ( blk file -- dadr tf \ blk file ) + 2 SP D) D0 move SP ) D1 move + .l ramprev r#) A0 move .w thisbuffer? bsr + 0= IF Label blockfound .l 8. # A0 adda A0 SP ) move .w + true # SP -) move Next THEN + BEGIN .l A0 A1 move A1 ) A0 move 0. # A0 cmpa .w + 0= IF false # SP -) move Next THEN + thisbuffer? bsr 0= UNTIL + .l A0 ) A1 ) move + ramprev r#) A0 ) move A0 ramprev r#) move .w + blockfound bra end-code +\ *** Block No. 5 Hexblock 5 +\ read and write buffers b28sep86we + +| : readrambuf ( adr daddr -- ) \ copy from daddr to adr + rot >absaddr b/blk lcmove ; + +| : writerambuf ( adr daddr --) \ copy from adr to daddr + rot >absaddr 2swap b/blk lcmove ; + + + + + + + + + +\ *** Block No. 6 Hexblock 6 +\ search for empty buffer bp 10Aug86 + +\ : takerambuf ( -- daddr ) \ get last buffer +\ ramprev 2@ +\ BEGIN 2dup link>file l@ 1+ ( empty buffer ? ) +\ WHILE 2dup l2@ or ( last buffer ? ) +\ WHILE l2@ REPEAT ; + +| Code takerambuf ( -- daddr ) + .l ramprev r#) A0 move + Label takeloop .w -1 4 A0 D) cmpi + 0<> IF .l A0 ) tst 0<> + IF A0 ) A0 move takeloop bra THEN THEN + A0 SP -) move Next end-code + + +\ *** Block No. 7 Hexblock 7 +\ allocate a buffer bp 24Aug86 + +| 2Variable (daddr + +\ | : markrambuf ( blk file daddr -- daddr ) +\ 2dup (daddr 2! link>file l! (daddr 2@ link>block l! +\ (daddr 2@ ; + +| Code markrambuf ( blk file daddr -- daddr ) .l + SP )+ A0 move .w SP )+ 4 A0 D) move + SP )+ 6 A0 D) move .l A0 SP -) move Next end-code + +| : makerambuf ( adr blk file -- ) \ create a buffer + BEGIN rambuf? 0= WHILE 2dup takerambuf markrambuf + 2drop REPEAT writerambuf ; + +\ *** Block No. 8 Hexblock 8 +\ clear buffers bp 10Aug86 + +: clearrambuf ( laddr -- ) \ clear a buffer + link>file -1 -rot l! ; + +: flushramfile ( fcb -- ) \ clear all buffers of a file + >r ramprev 2@ + BEGIN 2dup or + WHILE 2dup link>file l@ r@ = IF 2dup clearrambuf THEN + l2@ REPEAT 2drop rdrop ; + + + + + + +\ *** Block No. 9 Hexblock 9 +\ allocate all buffers bp 10Aug86 + +| : nextbuf ( d1 -- d2) \ adr of next buffer + b/rambuf extend d+ ; + +| : ramfull? ( daddr -- f) \ true if more buffers + nextbuf ramsize 2@ ramfirst 2@ d+ d> 0= ; + +: emptyramdisk ( -- ) \ initialize ramdisk + 0. ramprev 2! ramfirst 2@ + BEGIN 2dup ramfull? + WHILE 2dup clearrambuf ( clear buffer ) + ramprev 2@ 2over l2! ( chain to list ) + 2dup ramprev 2! ( store last buffer ) + nextbuf REPEAT 2drop ; + +\ *** Block No. 10 Hexblock A +\ Interactive memory allocation bp 17Aug86 + +: #in ( -- n) query name number drop ; + +: initramdisk ( -- ) + [ Dos ] 0. ramprev 2! + ramfirst 2@ or IF ramfirst 2@ mfree + drop ?diskabort 0. ramfirst 2! THEN + cr ." Wie viele Kilos sollen es sein ? " #in + b/rambuf um* 2. d+ 2dup malloc ( 2 Angstbytes zus.) + dup 0< IF drop ?diskabort THEN ( Fehler !) + dup 0= abort" Speicher voll !!" ( DR sei Dank gesagt !) + ramfirst 2! ramsize 2! + emptyramdisk ; + + +\ *** Block No. 11 Hexblock B +\ new r/w bp 10Aug86 + +' r/w >body @ Alias oldr/w + +: ramdiskr/w ( adr blk file rw/f -- f ) + ramprev 2@ or 0= IF oldr/w exit THEN + dup >r + IF rambuf? IF readrambuf rdrop false exit THEN THEN + r> 4dup oldr/w + IF 4drop true exit THEN \ disk error ! + drop makerambuf false ; \ create or overwrite buffer + + + + + +\ *** Block No. 12 Hexblock C +\ print a list of ram buffers bp 10Aug86 + +: .rambufs ( -- ) + ramprev 2@ + BEGIN 2dup or + WHILE cr 2dup 8 d.r 5 spaces \ adress + 2dup link>file l@ + dup 1+ IF [ Dos ] .file 4 spaces + 2dup link>block l@ 5 .r + ELSE drop ." empty" THEN + l2@ stop? UNTIL 2drop ; + + + + + +\ *** Block No. 13 Hexblock D +\ Wichtige Worte sind bp 17Aug86 + +INITRAMDISK ( -- ) fragt nach der Zahl der Anzahl der + anzulegenden Buffer und erzeugt sie. + +EMPTYRAMDISK ( -- ) l”scht den Inhalt aller Buffer. + +RAMBUF? ( blk file -- dadr tf \ blk file ff ) + sucht den Buffer blk im File file in der Ramdisk. + +CLEARRAMBUF? ( laddr -- ) + markiert den Ramdiskbuffer bei Adr. laddr als leer. + + +.. + +\ *** Block No. 14 Hexblock E + bp 17Aug86 + + + + + +Wird in RAMDISKR\W benutzt + +Gibt Offset einer Uservariablen in der Userarea. Dieses + Wort geh”rt eigentlich in den Assembler ! + + + + + + +\ *** Block No. 15 Hexblock F + bp 17Aug86 + +Dieses Wort wird in (CLOSE gepatched. FCB ist die Adresse des + zu schlieženden Files. Alle Blockpuffer dieses Files werden + gel”scht. +Dieses Wort wird in EMPTY-BUFFERS gepatched. Es l”scht alle + Ramdiskpuffer + + +Neues R/W +Patche (CLOSE +Patche EMPTY-BUFFERS + + +Frage nach der Gr”že der Ramdisk + +\ *** Block No. 16 Hexblock 10 + bp 17Aug86 + +Zeiger auf den ersten Buffer in der Ramdisk. +Beginn des fr die Ramdisk allokierten Speicherbereichs +L„nge " " " " " " + +L„nge eines Buffers der Ramdisk + +Diese Worte erlauben den Zugriff auf die Felder eines + Ramdiskbuffers. + + + +Dies ist die Struktur eines Ramdiskbuffers. Alle Buffer befinden + sich in einer gelinkten Liste, analog zum volksFORTH83-Block= + =buffermechanismus. +\ *** Block No. 17 Hexblock 11 + bp 17Aug86 + + + + +Sucht einen Buffer in der Ramdisk. Gesucht wird der Buffer + mit der Nummer BLK aus dem File mit der Nummer FCB. +Zun„chst wird der erste Eintrag untersucht (weniger Rechenzeit). + Ist es nicht der oberste, so werden die restlichen Buffer + verglichen. Wurde er gefunden, so wird der betreffende Buffer + an den Anfang der Liste geh„ngt, so daž die Buffer immer in + der Reihenfolge des Zugriffs geordnet sind. Dadurch wird die + Zugriffsgeschwindigkeit erh”ht. + + + +\ *** Block No. 18 Hexblock 12 + bp 17Aug86 + +Kopiert den Inhalt des Ramdiskbuffers in den Blockbuffer des + volksFORTH-Systems + +Kopiert den Inhalt des Blockbuffers im System in den Ramdisk= + =buffer. + +Diese beiden Worte k”nnen noch optimiert werden, da LCMOVE + byteweise bertr„gt, aber auch langwortweise bertragen + werden kann. + + + + + +\ *** Block No. 19 Hexblock 13 + bp 17Aug86 + +Dieses Wort sucht einen leeren Ramdiskbuffer. Ist keiner leer, + so wird der letzte Buffer in der Liste genommen. + + + + + + + + + + + + +\ *** Block No. 20 Hexblock 14 + bp 24Aug86 + +Hilfsvariable + +Markiert den Ramdiskbuffer DADDR als Buffer fr den Block BLK + im File FILE. + + + + + + +Erzeugt einen Buffer fr den Blockl BLK des Files FILE in der + Ramdisk. Der Inhalt des Buffers steht ab Adresse ADR im System. + RAMBUF? wird benutzt, um den allokierten Buffer an die erste + Stelle zu h„ngen. Der WHILE-Teil wird max. einmal durchlaufen ! +\ *** Block No. 21 Hexblock 15 + bp 17Aug86 + +L”scht den Buffer LADDR. + + +L”scht alle Ramdiskbuffer, die zum File FCB geh”ren. + + + + + + + + + + +\ *** Block No. 22 Hexblock 16 + bp 17Aug86 + +Berechnet die Adresse D2 des Ramdiskbuffers, der auf den Buffer + mit der Adresse D1 folgt. + +F ist wahr, falls noch weitere Buffer in der Ramdisk allokiert + werden k”nnen. + +Initialisiert die Ramdisk. Es werden soviele Buffer angelegt, + wie in den durch RAMFIRST und RAMSIZE angegebenen Speicher= + =bereich passen. Alle allokierten Buffer werden als leer + markiert. + + + + +\ *** Block No. 23 Hexblock 17 + bp 17Aug86 + +Liest eine Zahl von der Tastatur ein + +Erzeugt die Ramdisk. Zun„chst wird der alte Speicherbereich + freigegeben, falls einer allokiert war. Dann wird nach der + gewnschten Zahl von Buffern gefragt. Es wird ein Speicher= + =bereich vom GEM-Dos angeordert und mit leeren Buffern + gefllt. + + + + + + + +\ *** Block No. 24 Hexblock 18 + bp 17Aug86 + +Die alte R/W-Routine wird natrlich auch ben”tigt. + +Kommuniziert mit den Massenspeichern. + RW/F ist wahr, falls ein Lesezugriff erfolgen soll. + Ist die Ramdisk leer, so darf sie nicht angesprochen werden ! + Sonst wird geprft, ob es sich um einen Lesezugriff handelt + und ob der Buffer in der Ramdisk vorliegt. Ist das der Fall, + so wird einfach dessen Inhalt kopiert. Andernfalls muž, falls + noch nicht vorhanden, ein Buffer allokiert werden. Der Inhalt + des Systembuffers wird dann in die Ramdisk kopiert und steht + beim n„chsten Lesezugriff zur Verfgung. + + + +\ *** Block No. 25 Hexblock 19 + bp 17Aug86 + +Es wird eine Liste mit dem Inhalt aller Ramdiskbuffer ausgegeben + + + + + + + + + + + + + diff --git a/sources/AtariST/RELOCATE.FB.src b/sources/AtariST/RELOCATE.FB.src deleted file mode 100644 index 3257a94..0000000 --- a/sources/AtariST/RELOCATE.FB.src +++ /dev/null @@ -1,51 +0,0 @@ -Screen 0 not modified - 0 \\ 26oct86we - 1 - 2 Diese File enth„lt Worte, mit denen die Speicheraufteilung - 3 des volksFORTH ver„ndert werden kann. - 4 - 5 RELOCATE setzt R0 und S0 neu, beachten Sie dazu auch die - 6 Ausfhrungen im Handbuch. - 7 - 8 Mit BUFFERS kann man die Anzahl der Diskbuffer ver„ndern. - 9 Standardm„žig ist das System auf &10 Buffer eingestellt. Reicht -10 der Platz im Dictionary bei sehr grožen Programmen nicht aus, -11 kann man hier am ehesten Speicherplatz einsparen. -12 Umgekehrt erh”ht sich der Arbeitskomfort beim Editieren, wenn -13 m”glichst viele Diskbuffer vorhanden sind, um Diskettenzugriffe -14 zu minimieren. -15 -Screen 1 not modified - 0 \ Relocate a system 26oct86we - 1 - 2 | : relocate-tasks ( mainup -- ) up@ dup - 3 BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! - 4 up@ 2+ @ origin 2+ ! ; - 5 - 6 : relocate ( stacklen rstacklen -- ) - 7 2dup + limit origin - b/buf - 2- - 8 u> abort" kills all buffers" - 9 over pad $100 + origin - u< abort" cuts the dictionary" -10 dup udp @ $40 + -11 u< abort" kills returnstack" -12 flush empty over + origin + origin &12 + ! \ r0 -13 origin + dup relocate-tasks \ multitasking -14 6 - origin &10 + ! \ s0 -15 cold ; --> -Screen 2 not modified - 0 \ bytes.more buffers 15sep86we - 1 - 2 | : bytes.more ( n+- -- ) - 3 up@ origin - + r0 @ up@ - relocate ; - 4 - 5 : buffers ( +n -- ) - 6 b/buf * 4+ limit r0 @ - swap - bytes.more ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/RELOCATE.fth b/sources/AtariST/RELOCATE.fth new file mode 100644 index 0000000..6b37e1c --- /dev/null +++ b/sources/AtariST/RELOCATE.fth @@ -0,0 +1,51 @@ +\ *** Block No. 0 Hexblock 0 +\\ 26oct86we + +Diese File enth„lt Worte, mit denen die Speicheraufteilung +des volksFORTH ver„ndert werden kann. + +RELOCATE setzt R0 und S0 neu, beachten Sie dazu auch die +Ausfhrungen im Handbuch. + +Mit BUFFERS kann man die Anzahl der Diskbuffer ver„ndern. +Standardm„žig ist das System auf &10 Buffer eingestellt. Reicht +der Platz im Dictionary bei sehr grožen Programmen nicht aus, +kann man hier am ehesten Speicherplatz einsparen. +Umgekehrt erh”ht sich der Arbeitskomfort beim Editieren, wenn +m”glichst viele Diskbuffer vorhanden sind, um Diskettenzugriffe +zu minimieren. + +\ *** Block No. 1 Hexblock 1 +\ Relocate a system 26oct86we + +| : relocate-tasks ( mainup -- ) up@ dup + BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! + up@ 2+ @ origin 2+ ! ; + +: relocate ( stacklen rstacklen -- ) + 2dup + limit origin - b/buf - 2- + u> abort" kills all buffers" + over pad $100 + origin - u< abort" cuts the dictionary" + dup udp @ $40 + + u< abort" kills returnstack" + flush empty over + origin + origin &12 + ! \ r0 + origin + dup relocate-tasks \ multitasking + 6 - origin &10 + ! \ s0 + cold ; --> +\ *** Block No. 2 Hexblock 2 +\ bytes.more buffers 15sep86we + +| : bytes.more ( n+- -- ) + up@ origin - + r0 @ up@ - relocate ; + +: buffers ( +n -- ) + b/buf * 4+ limit r0 @ - swap - bytes.more ; + + + + + + + + + diff --git a/sources/AtariST/RFEDIT.FB.src b/sources/AtariST/RFEDIT.FB.src deleted file mode 100644 index 86b9c54..0000000 --- a/sources/AtariST/RFEDIT.FB.src +++ /dev/null @@ -1,51 +0,0 @@ -Screen 0 not modified - 0 \\ Retro Forth Editor cas20130106 - 1 - 2 This is a port of the Retro Forth Editor from - 3 http://retroforth.org - 4 - 5 Functions: - 6 s Select a new block - 7 p Previous block - 8 n Next block - 9 i ... Insert ... into line -10 ia ... Insert ... into line at column -11 x Clear (erase) the current block -12 Clear line -13 v Display current block -14 e Evaluate (load) current block -15 -Screen 1 not modified - 0 .( Retro Forth block editor volksForth Atari ST) \ cas20130106 - 1 $10 constant l/b cr - 2 : (block) scr @ block ; : (line) c/l * (block) + ; - 3 : row dup c/l type c/l + cr ; : .rows l/b 0 do i . row loop ; - 4 : .block ." Block: " scr @ dup . updated? abs $2A + emit space ; - 5 : +--- ." +---" ; : :--- ." :---" ; - 6 : x--- +--- :--- +--- :--- ; - 7 : --- space space x--- x--- x--- x--- cr ; - 8 : vb --- scr @ block .rows drop --- ; - 9 : .stack ." Stack: " .s ; : status .block .stack ; -10 : v cr vb status ; : v* update v ; : s dup scr ! block drop v ; -11 : ia (line) + >r &10 parse r> swap move v* ; -12 : i 0 swap ia ; : d (line) c/l bl fill v* ; -13 : x (block) l/b c/l * bl fill v* ; : p -1 scr +! v ; -14 : n 1 scr +! v ; : e scr @ load ; -15 cr .( editor loaded ) cr -Screen 2 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/RFEDIT.fth b/sources/AtariST/RFEDIT.fth new file mode 100644 index 0000000..bb1cd9d --- /dev/null +++ b/sources/AtariST/RFEDIT.fth @@ -0,0 +1,51 @@ +\ *** Block No. 0 Hexblock 0 +\\ Retro Forth Editor cas20130106 + +This is a port of the Retro Forth Editor from +http://retroforth.org + +Functions: + s Select a new block +p Previous block +n Next block + i ... Insert ... into line + ia ... Insert ... into line at column +x Clear (erase) the current block + Clear line +v Display current block +e Evaluate (load) current block + +\ *** Block No. 1 Hexblock 1 +.( Retro Forth block editor volksForth Atari ST) \ cas20130106 +$10 constant l/b cr +: (block) scr @ block ; : (line) c/l * (block) + ; +: row dup c/l type c/l + cr ; : .rows l/b 0 do i . row loop ; +: .block ." Block: " scr @ dup . updated? abs $2A + emit space ; + : +--- ." +---" ; : :--- ." :---" ; +: x--- +--- :--- +--- :--- ; +: --- space space x--- x--- x--- x--- cr ; +: vb --- scr @ block .rows drop --- ; +: .stack ." Stack: " .s ; : status .block .stack ; +: v cr vb status ; : v* update v ; : s dup scr ! block drop v ; +: ia (line) + >r &10 parse r> swap move v* ; +: i 0 swap ia ; : d (line) c/l bl fill v* ; +: x (block) l/b c/l * bl fill v* ; : p -1 scr +! v ; +: n 1 scr +! v ; : e scr @ load ; +cr .( editor loaded ) cr +\ *** Block No. 2 Hexblock 2 + + + + + + + + + + + + + + + + diff --git a/sources/AtariST/STARTUP.FB.src b/sources/AtariST/STARTUP.FB.src deleted file mode 100644 index 5bac239..0000000 --- a/sources/AtariST/STARTUP.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \\ *** Loadscreen fr Arbeitssystem *** bp 12oct86 - 1 - 2 Der folgenden Screens wird benutzt, um aus FORTHKER.PRG - 3 ein Arbeitssystem zusammenzustellen. - 4 - 5 Alle Files, die zum Standardsystem geh”ren sollen, werden mit - 6 INCLUDE dazugeladen. Nicht ben”tigte Teile k”nnen mit \ - 7 weggelassen werden. Natrlich kann man auch die entsprechenden - 8 Zeilen ganz l”schen. Beachten Sie aber, daž bestimmte Files - 9 Grundlage fr andere sind. So wird zum Beispiel der Assembler -10 sehr h„ufig gebraucht, der hier "Intern" geladen wird. -11 -12 Fr eigene Applikationen erstellen Sie sich einen Loadscreen -13 nach dem Muster, der dann das oder die Files beinhaltet, die -14 zu Ihrer Applikation geh”ren. -15 -Screen 1 not modified - 0 \ Loadscreen for Standard System cas20130105 - 1 - 2 Onlyforth include misc.fb - 3 Onlyforth 2 loadfrom assemble.fb - 4 \ Onlyforth include assemble.fb - 5 Onlyforth include strings.fb - 6 Onlyforth include allocate.fb - 7 Onlyforth include gem\aes.fb - 8 Onlyforth include editor.fb - 9 Onlyforth include index.fb -10 Onlyforth include tools.fb -11 Onlyforth include relocate.fb -12 \ Onlyforth include printer.fb -13 \ Onlyforth include line_a.fb -14 \ Onlyforth include demo.fb -15 Onlyforth cr cr .( May the volksFORTH be with you ...) cr diff --git a/sources/AtariST/STARTUP.fth b/sources/AtariST/STARTUP.fth new file mode 100644 index 0000000..0c07b88 --- /dev/null +++ b/sources/AtariST/STARTUP.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Loadscreen fr Arbeitssystem *** bp 12oct86 + +Der folgenden Screens wird benutzt, um aus FORTHKER.PRG + ein Arbeitssystem zusammenzustellen. + +Alle Files, die zum Standardsystem geh”ren sollen, werden mit + INCLUDE dazugeladen. Nicht ben”tigte Teile k”nnen mit \ + weggelassen werden. Natrlich kann man auch die entsprechenden + Zeilen ganz l”schen. Beachten Sie aber, daž bestimmte Files + Grundlage fr andere sind. So wird zum Beispiel der Assembler + sehr h„ufig gebraucht, der hier "Intern" geladen wird. + +Fr eigene Applikationen erstellen Sie sich einen Loadscreen + nach dem Muster, der dann das oder die Files beinhaltet, die + zu Ihrer Applikation geh”ren. + +\ *** Block No. 1 Hexblock 1 +\ Loadscreen for Standard System cas20130105 + +Onlyforth include misc.fb +Onlyforth 2 loadfrom assemble.fb +\ Onlyforth include assemble.fb +Onlyforth include strings.fb +Onlyforth include allocate.fb +Onlyforth include gem\aes.fb +Onlyforth include editor.fb +Onlyforth include index.fb +Onlyforth include tools.fb +Onlyforth include relocate.fb +\ Onlyforth include printer.fb +\ Onlyforth include line_a.fb +\ Onlyforth include demo.fb +Onlyforth cr cr .( May the volksFORTH be with you ...) cr diff --git a/sources/AtariST/STRINGS.FB.src b/sources/AtariST/STRINGS.FB.src deleted file mode 100644 index e2e6ced..0000000 --- a/sources/AtariST/STRINGS.FB.src +++ /dev/null @@ -1,204 +0,0 @@ -Screen 0 not modified - 0 \\ *** Strings *** 13oct86we - 1 - 2 Dieses File enth„lt einige Grundworte zur Stringverarbeitung, - 3 vor allem ein SEARCH fr den Editor. Ebenfalls sind Worte - 4 zur Umwandlung von counted Strings (Forth) in 0-terminated - 5 Strings, wie sie z.B. vom Betriebssystem oft benutzt werden, - 6 vorhanden. - 7 - 8 Beim SEARCH entscheidet die Variable CAPS , ob Grož- und - 9 Kleinschreibung unterschieden wird oder nicht. Ist CAPS ON, -10 so werden grože und kleine Buchstaben gefunden, die Suche dau- -11 ert allerdings l„nger. -12 -13 c>0" wandelt einen String mit fhrendem Countbyte in einen -14 mit 0 abgschlossenen, wie er vom Betriebssystem oft gebraucht -15 wird. 0>c" arbeitet umgekehrt. -Screen 1 not modified - 0 \ String Functions Loadscreen 25may86we - 1 - 2 1 4 +thru - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ -text 13oct86we - 1 - 2 Variable caps caps off - 3 - 4 Code -text ( addr0 len addr1 -- n ) - 5 SP )+ D6 move D6 reg) A1 lea - 6 SP )+ D0 move 0= IF SP ) clr Next THEN 1 D0 subq - 7 SP )+ D6 move D6 reg) A0 lea - 8 Label comp - 9 .b A0 )+ A1 )+ cmpm comp D0 dbne -10 .w D0 clr .b A0 -) D0 move A1 -) D0 sub .w D0 ext -11 D0 SP -) move Next end-code -12 -13 Label >upper ( D3 -> D3 ) .b Ascii a D3 cmpi -14 >= IF Ascii z D3 cmpi <= IF bl D3 subi THEN THEN rts -15 -Screen 3 not modified - 0 \ -capstext compare 13oct86we - 1 - 2 | Code -capstext ( addr0 len addr1 -- n ) - 3 SP )+ D6 move D6 reg) A1 lea - 4 SP )+ D0 move 0= IF SP ) clr Next THEN 1 D0 subq - 5 SP )+ D6 move D6 reg) A0 lea - 6 Label capscomp - 7 .b A0 )+ D3 move >upper bsr D3 D1 move - 8 A1 )+ D3 move >upper bsr D3 D2 move - 9 D1 D2 cmp capscomp D0 dbne .w D1 clr -10 .b A0 -) D3 move >upper bsr D3 D1 move -11 A1 -) D3 move >upper bsr D3 D2 move -12 .b D2 D1 sub .w D1 SP -) move Next end-code -13 -14 : compare ( addr0 len addr1 -- n ) -15 caps @ IF -capstext ELSE -text THEN ; -Screen 4 not modified - 0 \ search delete insert 10aug86we - 1 - 2 : search ( text textlen buf buflen -- offset flag ) - 3 over >r 2 pick - 3 pick c@ >r - 4 BEGIN caps @ 0= IF r@ scan THEN ?dup - 5 WHILE >r >r 2dup r@ compare - 6 0= IF 2drop r> rdrop rdrop r> - true exit THEN - 7 r> r> 1 /string REPEAT -rot 2drop rdrop r> - false ; - 8 - 9 : delete ( buffer size count -- ) -10 over min >r r@ - ( left over ) dup 0> -11 IF 2dup swap dup r@ + -rot swap cmove THEN -12 + r> bl fill ; -13 -14 : insert ( string length buffer size -- ) -15 rot over min >r r@ - over dup r@ + rot cmove> r> cmove ; -Screen 5 not modified - 0 \ String operators 13oct86we - 1 - 2 Variable $sum \ pointer to stringsum - 3 : $add ( addr len -- ) dup >r - 4 $sum @ count + swap move $sum @ dup c@ r> + swap c! ; - 5 - 6 : c>0" ( addr -- ) - 7 count >r dup 1- under r@ cmove r> + 0 swap c! ; - 8 : 0>c" ( addr -- ) - 9 dup >r true false scan nip negate 1- -10 r@ dup 1+ 2 pick cmove> r> c! ; -11 -12 : ,0" Ascii " parse 1+ here over allot place -13 0 c, align ; restrict -14 : 0" state @ IF compile (" ,0" compile 1+ exit THEN -15 here 1+ ,0" ; immediate -Screen 6 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ -text 13oct86we - 1 - 2 ist CAPS on, wird beim Suchen nicht auf Grož- Kleinschreibung - 3 geachtet. - 4 addr0 und addr1 sind die Adressen von zwei counted strings, len - 5 die Anzahl der Zeichen, die verglichen werden sollen. n liefert - 6 die Differenz der beiden ersten nicht bereinstimmenden Zeichen - 7 Ist n=0, sind beide Strings gleich. - 8 - 9 -10 -11 -12 -13 wandelt das Zeichen im Register D3 in den entsprechenden Grož- -14 buchstaben. -15 -Screen 9 not modified - 0 \ -capstext compare 13oct86we - 1 - 2 wie -text, jedoch wird beim Vergleich nicht nach Grož- und Klein - 3 schreibung unterschieden. Dieser Vergleich erfordert erheblich - 4 mehr Zeit und sollte daher nur in Sonderf„llen benutzt werden. - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 wie -text, in Abh„ngigkeit von der Variablen caps wird -text -15 oder -capstext ausgefhrt. -Screen 10 not modified - 0 \ search delete insert 13oct86we - 1 - 2 Im Text ab Adresse text wird in der L„nge textlen nach dem - 3 String buf mit L„nge buflen gesucht. - 4 Zurckgeliefert wird ein Offset in den durchsuchten Text an die - 5 Stelle, an der der String gefunden wurde sowie ein Flag. Ist - 6 flag wahr, wurde der String gefunden, sonst nicht. - 7 search bercksichtigt die Variable caps bei der Suche. - 8 - 9 Im Buffer der L„nge size werden count Zeichen entfernt. Der Rest -10 des Buffers wird 'heruntergezogen'. -11 -12 -13 -14 Der string ab Adresse string und der L„nge length wird in den -15 Buffer mit der Gr”že size eingefgt. -Screen 11 not modified - 0 \ String operators 13oct86we - 1 - 2 Ein pointer auf die Adresse des Strings, zu dem ein anderer - 3 hinzugefgt werden soll. - 4 $ADD h„ngt den String ab addr und der L„nge len an den String - 5 in $sum an. Der Count wird dabei addiert. - 6 wandelt den counted String ab addr in einen 0-terminated String. - 7 - 8 wandelt den 0-terminated String ab addr in einen counted String. - 9 Die L„nge der Strings bleibt gleich (Countbyte statt 0). -10 -11 -12 legt einen counted und mit 0 abgeschlossenen String im -13 Dictionary ab. -14 aufrufendes Wort fr ,0"; kompiliert zus„tzlich (". -15 0" ist statesmart. diff --git a/sources/AtariST/STRINGS.fth b/sources/AtariST/STRINGS.fth new file mode 100644 index 0000000..8d9e30a --- /dev/null +++ b/sources/AtariST/STRINGS.fth @@ -0,0 +1,204 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Strings *** 13oct86we + +Dieses File enth„lt einige Grundworte zur Stringverarbeitung, +vor allem ein SEARCH fr den Editor. Ebenfalls sind Worte +zur Umwandlung von counted Strings (Forth) in 0-terminated +Strings, wie sie z.B. vom Betriebssystem oft benutzt werden, +vorhanden. + +Beim SEARCH entscheidet die Variable CAPS , ob Grož- und +Kleinschreibung unterschieden wird oder nicht. Ist CAPS ON, +so werden grože und kleine Buchstaben gefunden, die Suche dau- +ert allerdings l„nger. + +c>0" wandelt einen String mit fhrendem Countbyte in einen +mit 0 abgschlossenen, wie er vom Betriebssystem oft gebraucht +wird. 0>c" arbeitet umgekehrt. +\ *** Block No. 1 Hexblock 1 +\ String Functions Loadscreen 25may86we + +1 4 +thru + + + + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ -text 13oct86we + +Variable caps caps off + +Code -text ( addr0 len addr1 -- n ) + SP )+ D6 move D6 reg) A1 lea + SP )+ D0 move 0= IF SP ) clr Next THEN 1 D0 subq + SP )+ D6 move D6 reg) A0 lea +Label comp + .b A0 )+ A1 )+ cmpm comp D0 dbne + .w D0 clr .b A0 -) D0 move A1 -) D0 sub .w D0 ext + D0 SP -) move Next end-code + +Label >upper ( D3 -> D3 ) .b Ascii a D3 cmpi + >= IF Ascii z D3 cmpi <= IF bl D3 subi THEN THEN rts + +\ *** Block No. 3 Hexblock 3 +\ -capstext compare 13oct86we + +| Code -capstext ( addr0 len addr1 -- n ) + SP )+ D6 move D6 reg) A1 lea + SP )+ D0 move 0= IF SP ) clr Next THEN 1 D0 subq + SP )+ D6 move D6 reg) A0 lea +Label capscomp + .b A0 )+ D3 move >upper bsr D3 D1 move + A1 )+ D3 move >upper bsr D3 D2 move + D1 D2 cmp capscomp D0 dbne .w D1 clr + .b A0 -) D3 move >upper bsr D3 D1 move + A1 -) D3 move >upper bsr D3 D2 move + .b D2 D1 sub .w D1 SP -) move Next end-code + +: compare ( addr0 len addr1 -- n ) + caps @ IF -capstext ELSE -text THEN ; +\ *** Block No. 4 Hexblock 4 +\ search delete insert 10aug86we + +: search ( text textlen buf buflen -- offset flag ) + over >r 2 pick - 3 pick c@ >r + BEGIN caps @ 0= IF r@ scan THEN ?dup + WHILE >r >r 2dup r@ compare + 0= IF 2drop r> rdrop rdrop r> - true exit THEN + r> r> 1 /string REPEAT -rot 2drop rdrop r> - false ; + +: delete ( buffer size count -- ) + over min >r r@ - ( left over ) dup 0> + IF 2dup swap dup r@ + -rot swap cmove THEN + + r> bl fill ; + +: insert ( string length buffer size -- ) + rot over min >r r@ - over dup r@ + rot cmove> r> cmove ; +\ *** Block No. 5 Hexblock 5 +\ String operators 13oct86we + +Variable $sum \ pointer to stringsum +: $add ( addr len -- ) dup >r + $sum @ count + swap move $sum @ dup c@ r> + swap c! ; + +: c>0" ( addr -- ) + count >r dup 1- under r@ cmove r> + 0 swap c! ; +: 0>c" ( addr -- ) + dup >r true false scan nip negate 1- + r@ dup 1+ 2 pick cmove> r> c! ; + +: ,0" Ascii " parse 1+ here over allot place + 0 c, align ; restrict +: 0" state @ IF compile (" ,0" compile 1+ exit THEN + here 1+ ,0" ; immediate +\ *** Block No. 6 Hexblock 6 + + + + + + + + + + + + + + + + +\ *** Block No. 7 Hexblock 7 + + + + + + + + + + + + + + + + +\ *** Block No. 8 Hexblock 8 +\ -text 13oct86we + +ist CAPS on, wird beim Suchen nicht auf Grož- Kleinschreibung + geachtet. +addr0 und addr1 sind die Adressen von zwei counted strings, len + die Anzahl der Zeichen, die verglichen werden sollen. n liefert + die Differenz der beiden ersten nicht bereinstimmenden Zeichen + Ist n=0, sind beide Strings gleich. + + + + + +wandelt das Zeichen im Register D3 in den entsprechenden Grož- + buchstaben. + +\ *** Block No. 9 Hexblock 9 +\ -capstext compare 13oct86we + +wie -text, jedoch wird beim Vergleich nicht nach Grož- und Klein + schreibung unterschieden. Dieser Vergleich erfordert erheblich + mehr Zeit und sollte daher nur in Sonderf„llen benutzt werden. + + + + + + + + + +wie -text, in Abh„ngigkeit von der Variablen caps wird -text + oder -capstext ausgefhrt. +\ *** Block No. 10 Hexblock A +\ search delete insert 13oct86we + +Im Text ab Adresse text wird in der L„nge textlen nach dem + String buf mit L„nge buflen gesucht. + Zurckgeliefert wird ein Offset in den durchsuchten Text an die + Stelle, an der der String gefunden wurde sowie ein Flag. Ist + flag wahr, wurde der String gefunden, sonst nicht. + search bercksichtigt die Variable caps bei der Suche. + +Im Buffer der L„nge size werden count Zeichen entfernt. Der Rest + des Buffers wird 'heruntergezogen'. + + + +Der string ab Adresse string und der L„nge length wird in den + Buffer mit der Gr”že size eingefgt. +\ *** Block No. 11 Hexblock B +\ String operators 13oct86we + +Ein pointer auf die Adresse des Strings, zu dem ein anderer + hinzugefgt werden soll. +$ADD h„ngt den String ab addr und der L„nge len an den String + in $sum an. Der Count wird dabei addiert. +wandelt den counted String ab addr in einen 0-terminated String. + +wandelt den 0-terminated String ab addr in einen counted String. + Die L„nge der Strings bleibt gleich (Countbyte statt 0). + + +legt einen counted und mit 0 abgeschlossenen String im + Dictionary ab. +aufrufendes Wort fr ,0"; kompiliert zus„tzlich (". + 0" ist statesmart. diff --git a/sources/AtariST/TARGET.FB.src b/sources/AtariST/TARGET.FB.src deleted file mode 100644 index 3acdc36..0000000 --- a/sources/AtariST/TARGET.FB.src +++ /dev/null @@ -1,680 +0,0 @@ -Screen 0 not modified - 0 \\ *** volksFORTH-84 Target-Compiler *** - 1 - 2 Mit dem Target-Compiler l„žt sich ein neues System aus dem - 3 Quelltext FORTH_83.SCR 'hochziehen'. - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Target compiler loadscr 09sep86we - 1 \ Idea and first Implementation by ks/bp - 2 \ Implemented on 6502 by ks/bp - 3 \ ultraFORTH83-Version by bp/we - 4 \ Atari 520 ST - Version by we - 5 - 6 Onlyforth Assembler nonrelocate - 7 07 Constant imagepage \ Virtual memory bank - 8 Vocabulary Ttools - 9 Vocabulary Defining -10 : .stat .blk .s ; ' .stat Is .status -11 -12 1 $12 +thru \ Target compiler -13 $13 $15 +thru \ Target Tools -14 $16 $18 +thru \ Redefinitions -15 save $19 $22 +thru \ Predefinitions -Screen 2 not modified - 0 \ Target header pointers bp05mar86we - 1 - 2 Variable tdp : there tdp @ ; - 3 Variable displace - 4 Variable ?thead 0 ?thead ! - 5 Variable tlast 0 tlast ! - 6 Variable glast' 0 glast' ! - 7 Variable tdoes> - 8 Variable >in: - 9 Variable tvoc 0 tvoc ! -10 Variable tvoc-link 0 tvoc-link ! -11 Variable tnext-link 0 tnext-link ! -12 -13 : c+! ( 8b addr -- ) dup c@ rot + swap c! ; -14 -15 -Screen 3 not modified - 0 \ Image and byteorder 15sep86we - 1 - 2 : >image ( addr1 - addr2 ) displace @ - ; - 3 - 4 : >heap ( from quan - ) - 5 heap over - 1 and + \ 68000-align - 6 dup hallot heap swap cmove ; - 7 \\ - 8 : >ascii 2drop ; ' noop Alias C64>ascii - 9 -10 Code Lc@ ( laddr -- 8b ) -11 .l SP )+ A0 move .w D0 clr .b A0 ) D0 move -12 .w D0 SP -) move Next end-code -13 Code Lc! ( 8b addr -- ) -14 .l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move -15 Next end-code -Screen 4 not modified - 0 \ Ghost-creating 05mar86we - 1 - 2 0 | Constant 0 | Constant - 3 - 4 | : Make.ghost ( - cfa.ghost ) - 5 here dup 1 and allot here - 6 state @ IF context @ ELSE current THEN @ - 7 dup @ , name - 8 dup c@ 1 $1F uwithin not abort" inval.Gname" - 9 dup c@ 1+ over c! -10 c@ dup 1+ allot 1 and 0= IF bl c, THEN -11 here 2 pick - -rot -12 , 0 , 0 , -13 swap here over - >heap -14 heap swap ! swap dp ! -15 heap + ; -Screen 5 not modified - 0 \ ghost words 05mar86we - 1 - 2 : gfind ( string - cfa tf / string ff ) - 3 dup count + 1+ bl swap c! - 4 dup >r 1 over c+! find -1 r> c+! ; - 5 - 6 : ghost ( - cfa ) - 7 >in @ name gfind IF nip exit THEN - 8 drop >in ! Make.ghost ; - 9 -10 : Word, ghost execute ; -11 -12 : gdoes> ( cfa.ghost - cfa.does ) -13 4+ dup @ IF @ exit THEN -14 here dup , 0 , 4 >heap -15 dp ! heap dup rot ! ; -Screen 6 not modified - 0 \ ghost utilities 04dec85we - 1 - 2 : g' name gfind 0= abort" ?" ; - 3 - 4 : '. - 5 g' dup @ case? - 6 IF ." forw" ELSE - abort" ??" ." res" THEN - 7 2+ dup @ 5 u.r - 8 2+ @ ?dup - 9 IF dup @ case? -10 IF ." fdef" ELSE - abort" ??" ." rdef" THEN -11 2+ @ 5 u.r THEN ; -12 -13 ' ' Alias h' -14 -15 -Screen 7 not modified - 0 \ .unresolved 05mar86we - 1 - 2 | : forward? ( cfa - cfa / exit&true ) - 3 dup @ = over 2+ @ and IF drop true rdrop exit THEN ; - 4 - 5 | : unresolved? ( addr - f ) - 6 2+ dup c@ $1F and over + c@ BL = - 7 IF name> forward? 4+ @ dup IF forward? THEN - 8 THEN drop false ; - 9 -10 | : unresolved-words -11 BEGIN @ ?dup WHILE dup unresolved? -12 IF dup 2+ .name ?cr THEN REPEAT ; -13 -14 : .unresolved voc-link @ -15 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; -Screen 8 not modified - 0 \ Extending Vocabularys for Target-Compilation 05mar86we - 1 - 2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; - 3 - 4 Vocabulary Transient 0 tvoc ! - 5 - 6 Only definitions Forth also - 7 - 8 : T Transient ; immediate - 9 : H Forth ; immediate -10 -11 definitions -12 -13 -14 -15 -Screen 9 not modified - 0 \ Transient primitives 05mar86we - 1 - 2 Code byte> ( 8bh 8bl -- 16b ) - 3 SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move - 4 .w D0 SP ) move Next end-code - 5 Code >byte ( 16b -- 8bl 8bh ) - 6 SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr - 7 D0 SP -) move D1 SP -) move Next end-code - 8 - 9 Transient definitions -10 : c@ H >image imagepage lc@ ; -11 : c! H >image imagepage lc! ; -12 : @ T dup c@ swap 1+ c@ byte> ; -13 : ! >r >byte r@ T c! r> 1+ c! ; -14 : cmove ( from.mem to.target quan -) -15 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; -Screen 10 not modified - 0 \ Transient primitives bp05mar86we - 1 - 2 : here there ; - 3 : allot Tdp +! ; - 4 : c, T here c! 1 allot H ; - 5 : , T here ! 2 allot H ; - 6 - 7 : ," Ascii " parse dup T c, - 8 under there swap cmove - 9 dup 1 and 0= IF 1+ THEN allot H ; -10 -11 : fill ( addr quan 8b -) -12 -rot bounds ?DO dup I T c! H LOOP drop ; -13 : erase 0 T fill ; -14 : blank bl T fill ; -15 : here! H Tdp ! ; -Screen 11 not modified - 0 \ Resolving 08dec85we - 1 Forth definitions - 2 : resolve ( cfa.ghost cfa.target -) - 3 over dup @ = - 4 IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN - 5 >r >r 2+ @ ?dup - 6 IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! - 7 H ?dup 0= UNTIL - 8 THEN r> r> over ! 2+ ! ; - 9 -10 : resdoes> ( cfa.ghost cfa.target -) -11 swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; -12 ] Does> [ here 4- 0 ] dup @ there rot ! T , H ; -13 ' >body ! -14 ] Does> [ here 4- 0 ] @ T , H ; -15 ' >body ! -Screen 12 not modified - 0 \ move-threads 68000-align 13jun86we - 1 - 2 : move-threads Tvoc @ Tvoc-link @ - 3 BEGIN over ?dup - 4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT - 5 error" some undef. Target-Vocs left" drop ; - 6 - 7 | : tlatest ( - addr) current @ 6 + ; - 8 | : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ; - 9 -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ save-target 09sep86we - 1 - 2 Dos definitions - 3 - 4 Code (filewrite ( buff len handle -- n) - 5 SP )+ D0 move .l D2 clr .w SP )+ D2 move - 6 .l 0 imagepage # D1 move .w SP )+ D1 move - 7 .l D1 A7 -) move \ buffer adress - 8 .l D2 A7 -) move \ buffer length - 9 .w D0 A7 -) move \ handle -10 $40 # A7 -) move \ call WRITE -11 1 trap $0C # A7 adda -12 .w D0 SP -) move Next end-code Forth definitions -13 -14 -15 -Screen 14 not modified - 0 \ save Target-System 09sep86we - 1 - 2 : save-target [ Dos ] - 3 bl word count dup 0= abort" missing filename" - 4 over + off (createfile dup >r 0< abort" no device " - 5 T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header - 6 0 there r@ (filewrite there - abort" write error" - 7 r> (closefile 0< abort" close error" ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ compiling names into targ. 05mar86we - 1 - 2 : (theader - 3 there 68000-talign - 4 ?thead @ IF 1 ?thead +! exit THEN - 5 >in @ name swap >in ! - 6 dup c@ 1 $20 uwithin not - 7 abort" inval. Tname" - 8 blk @ T , H there tlatest dup @ T , H ! there dup tlast ! - 9 over c@ 1+ even dup T allot cmove H ; -10 -11 : Theader tlast off -12 (theader Ghost dup glast' ! -13 there resolve ; -14 -15 -Screen 16 not modified - 0 \ prebuild defining words bp27jun85we - 1 - 2 | : executable? ( adr - adr f ) dup ; - 3 | : tpfa, there , ; - 4 | : (prebuild ( cfa.adr -- ) - 5 >in @ Create >in ! here 2- ! ; - 6 - 7 : prebuild ( adr 0.from.: - 0 ) - 8 0 ?pairs executable? dup >r - 9 IF [compile] Literal compile (prebuild ELSE drop THEN -10 compile Theader Ghost gdoes> , -11 r> IF compile tpfa, THEN 0 ; immediate restrict -12 -13 -14 -15 -Screen 17 not modified - 0 \ code portion of def.words bp11sep86we - 1 - 2 : dummy 0 ; - 3 - 4 : DO> ( - adr.of.jmp.dodoes> 0 ) - 5 [compile] Does> here 4- compile @ 0 ] ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 18 not modified - 0 \ the 68000 Assembler 11sep86we - 1 - 2 Forth definitions - 3 | Create relocate ] T c, , c@ here allot ! c! H [ - 4 - 5 Transient definitions - 6 - 7 : Assembler H [ Assembler ] relocate >codes ! Assembler ; - 8 : >label ( 16b -) H >in @ name gfind rot >in ! - 9 IF over resolve dup THEN drop Constant ; -10 : Label T here 1 and allot here >label Assembler H ; -11 : Code H Theader there 2+ T , Assembler H ; -12 -13 -14 -15 -Screen 19 not modified - 0 \ immed. restr. ' \ compile bp05mar86we - 1 - 2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ; - 3 : >mark ( - addr ) H there T 0 , H ; - 4 : >resolve ( addr - ) H there over - swap T ! H ; - 5 : - cfa ) H g' dup @ - abort" ?" 2+ @ ; -12 : | H ?thead @ ?exit ?thead on ; -13 : compile H Ghost , ; immediate restrict -14 -15 -Screen 20 not modified - 0 \ Target tools ks05mar86we - 1 - 2 Onlyforth Ttools also definitions - 3 - 4 | : ttype ( adr n -) bounds ?DO I T c@ H dup - 5 bl > IF emit ELSE drop Ascii . emit THEN LOOP ; - 6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype - 7 ELSE ." ??? " THEN space ?cr ; - 8 | : nfa? ( cfa lfa - nfa / cfa ff) - 9 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ even = -10 IF 2+ nip exit THEN -11 T @ H REPEAT ; -12 : >name ( cfa - nfa / ff) -13 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup -14 IF nip exit THEN -15 swap REPEAT nip ; -Screen 21 not modified - 0 \ Ttools for decompiling ks05mar86we - 1 - 2 | : ?: dup 4 u.r ." :" ; - 3 | : @? dup T @ H 6 u.r ; - 4 | : c? dup T c@ H 3 .r ; - 5 - 6 : s ( addr - addr+ ) ?: space c? 3 spaces - 7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ; - 8 - 9 : n ( addr - addr+2 ) ?: @? 2 spaces -10 dup T @ H [ Ttools ] >name .name H 2+ ; -11 -12 : d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP -13 2 spaces -rot ttype ; -14 -15 -Screen 22 not modified - 0 \ Tools for decompiling bp05mar86we - 1 - 2 : l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ; - 3 - 4 : c ( addr -- addr+1 ) 1 d ; - 5 - 6 : b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ; - 7 - 8 : dump ( adr n -) bounds ?DO cr I $10 d drop - 9 stop? IF LEAVE THEN $10 +LOOP ; -10 -11 : view T ' H [ Ttools ] >name ?dup -12 IF 4- T @ H l THEN ; -13 -14 -15 -Screen 23 not modified - 0 \ reinterpretation def.-words 05mar86we - 1 - 2 Onlyforth - 3 - 4 : redefinition - 5 tdoes> @ IF >in push [ ' >interpret >body ] Literal push - 6 state push context push >in: @ >in ! - 7 name [ ' Transient 2+ ] Literal (find nip 0= - 8 IF cr ." Redefinition: " here .name - 9 >in: @ >in ! : Defining interpret THEN -10 THEN 0 tdoes> ! ; -11 -12 -13 -14 -15 -Screen 24 not modified - 0 \ Create..does> structure bp05mar86we - 1 - 2 | : (;tcode Tlast @ dup T c@ dup 1 and - 2+ + ! H rdrop ; - 3 - 4 | : changecfa compile lit tdoes> @ , compile (;tcode ; - 5 - 6 Defining definitions - 7 - 8 : ;code 0 ?pairs changecfa reveal rdrop ; - 9 immediate restrict -10 -11 Defining ' ;code Alias does> immediate restrict -12 -13 : ; [compile] ; rdrop ; immediate restrict -14 -15 -Screen 25 not modified - 0 \ redefinition conditionals bp27jun85we - 1 - 2 ' DO Alias DO immediate restrict - 3 ' ?DO Alias ?DO immediate restrict - 4 ' LOOP Alias LOOP immediate restrict - 5 ' IF Alias IF immediate restrict - 6 ' THEN Alias THEN immediate restrict - 7 ' ELSE Alias ELSE immediate restrict - 8 ' BEGIN Alias BEGIN immediate restrict - 9 ' UNTIL Alias UNTIL immediate restrict -10 ' WHILE Alias WHILE immediate restrict -11 ' REPEAT Alias REPEAT immediate restrict -12 -13 -14 -15 -Screen 26 not modified - 0 \ clear Liter. Ascii ['] ." bp05mar86we - 1 - 2 Onlyforth Transient definitions - 3 - 4 : clear true abort" There are ghosts" ; - 5 : Literal ( n -) T compile lit , H ; immediate - 6 : Ascii H bl word 1+ c@ state @ - 7 IF T [compile] Literal H THEN ; immediate - 8 : ['] T ' [compile] Literal H ; immediate restrict - 9 : " T compile (" ," H ; immediate restrict -10 : ." T compile (." ," H ; immediate restrict -11 -12 -13 -14 -15 -Screen 27 not modified - 0 \ Target compilation ] [ bp05mar86we - 1 - 2 Forth definitions - 3 - 4 : tcompile - 5 ?stack >in @ name find ?dup - 6 IF 0> IF nip execute >interpret THEN - 7 drop dup >in ! name - 8 THEN gfind IF nip execute >interpret THEN - 9 nullstring? IF drop exit THEN -10 number? ?dup IF 0> IF swap T [compile] Literal THEN -11 [compile] Literal H drop >interpret THEN -12 drop >in ! Word, >interpret ; -13 -14 Transient definitions -15 : ] H state on ['] tcompile is >interpret ; -Screen 28 not modified - 0 \ Target conditionals bp05mar86we - 1 - 2 : IF T compile ?branch >mark H 1 ; immediate restrict - 3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict - 4 : ELSE T 1 ?pairs compile branch >mark swap >resolve - 5 H -1 ; immediate restrict - 6 : BEGIN T mark -2 H 2swap ; - 8 immediate restrict - 9 | : (repeat T 2 ?pairs resolve H REPEAT ; -11 : UNTIL T compile ?branch (repeat H ; immediate restrict -12 : REPEAT T compile branch (repeat H ; immediate restrict -13 -14 -15 -Screen 29 not modified - 0 \ Target conditionals bp27jun85we - 1 - 2 : DO T compile (do >mark H 3 ; immediate restrict - 3 : ?DO T compile (?do >mark H 3 ; immediate restrict - 4 : LOOP T 3 ?pairs compile (loop compile endloop - 5 >resolve H ; immediate restrict - 6 : +LOOP T 3 ?pairs compile (+loop compile endloop - 7 >resolve H ; immediate restrict - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 30 not modified - 0 \ predefinitions bp05mar86we - 1 - 2 : abort" T compile (abort" ," H ; immediate - 3 : error" T compile (err" ," H ; immediate - 4 - 5 Forth definitions - 6 - 7 Variable torigin - 8 Variable tudp 0 Tudp ! - 9 -10 : >user T c@ H torigin @ + ; -11 -12 -13 -14 -15 -Screen 31 not modified - 0 \ Datatypes bp05mar86we - 1 - 2 Transient definitions - 3 : origin! H torigin ! ; - 4 : user' ( -- n ) T ' >body c@ H ; - 5 : uallot ( n -- ) H tudp @ swap tudp +! ; - 6 - 7 DO> >user ; - 8 : User prebuild User 2 T uallot c, ; - 9 -10 DO> ; -11 : Create prebuild Create ; -12 -13 DO> T @ H ; -14 : Constant prebuild Constant T , ; -15 : Variable Create 2 T allot ; -Screen 32 not modified - 0 \ Datatypes bp05mar86we - 1 - 2 dummy - 3 : Vocabulary - 4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , - 5 here H tvoc-link @ T , H tvoc-link ! ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 33 not modified - 0 \ target defining words bp08sep86we - 1 - 2 Do> ; - 3 : Defer prebuild Defer 2 T allot ; - 4 : Is T ' H >body state @ IF T compile (is , H - 5 ELSE T ! H THEN ; immediate - 6 | : dodoes> T compile (;code H Glast' @ - 7 there resdoes> there tdoes> ! ; - 8 - 9 : ;code 0 T ?pairs dodoes> Assembler H [compile] [ -10 redefinition ; immediate restrict -11 : does> T dodoes> $4EAB , \ FP D) JSR -12 compile (dodoes> H ; immediate restrict -13 -14 -15 -Screen 34 not modified - 0 \ : Alias ; bp25mar86we - 1 - 2 : Create: T Create H current @ context ! T ] H 0 ; - 3 - 4 dummy - 5 : : H tdoes> off >in @ >in: ! T prebuild : - 6 H current @ context ! T ] H 0 ; - 7 - 8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve - 9 tlast @ T c@ H $20 or tlast @ T c! , H ; -10 -11 : ; T 0 ?pairs compile unnest [compile] [ H redefinition ; -12 immediate restrict -13 -14 -15 -Screen 35 not modified - 0 \ predefinitions bp11sep86we - 1 - 2 : compile T compile compile H ; immediate restrict - 3 : Host H Onlyforth Ttools also ; - 4 : Compiler T Host H Transient also definitions ; - 5 : [compile] H Word, ; immediate restrict - 6 : Onlypatch H there 4- 0 tdoes> ! 0 ; - 7 - 8 Onlyforth - 9 : Target Onlyforth Transient also definitions ; -10 -11 Transient definitions -12 Ghost c, drop -13 -14 -15 -Screen 36 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 37 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 38 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 39 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/TARGET.fth b/sources/AtariST/TARGET.fth new file mode 100644 index 0000000..437bfb8 --- /dev/null +++ b/sources/AtariST/TARGET.fth @@ -0,0 +1,680 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** volksFORTH-84 Target-Compiler *** + +Mit dem Target-Compiler l„žt sich ein neues System aus dem +Quelltext FORTH_83.SCR 'hochziehen'. + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Target compiler loadscr 09sep86we +\ Idea and first Implementation by ks/bp +\ Implemented on 6502 by ks/bp +\ ultraFORTH83-Version by bp/we +\ Atari 520 ST - Version by we + +Onlyforth Assembler nonrelocate +07 Constant imagepage \ Virtual memory bank +Vocabulary Ttools +Vocabulary Defining +: .stat .blk .s ; ' .stat Is .status + + 1 $12 +thru \ Target compiler +$13 $15 +thru \ Target Tools +$16 $18 +thru \ Redefinitions +save $19 $22 +thru \ Predefinitions +\ *** Block No. 2 Hexblock 2 +\ Target header pointers bp05mar86we + +Variable tdp : there tdp @ ; +Variable displace +Variable ?thead 0 ?thead ! +Variable tlast 0 tlast ! +Variable glast' 0 glast' ! +Variable tdoes> +Variable >in: +Variable tvoc 0 tvoc ! +Variable tvoc-link 0 tvoc-link ! +Variable tnext-link 0 tnext-link ! + +: c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + +\ *** Block No. 3 Hexblock 3 +\ Image and byteorder 15sep86we + +: >image ( addr1 - addr2 ) displace @ - ; + +: >heap ( from quan - ) + heap over - 1 and + \ 68000-align + dup hallot heap swap cmove ; +\\ +: >ascii 2drop ; ' noop Alias C64>ascii + +Code Lc@ ( laddr -- 8b ) +.l SP )+ A0 move .w D0 clr .b A0 ) D0 move +.w D0 SP -) move Next end-code +Code Lc! ( 8b addr -- ) +.l SP )+ A0 move .w SP )+ D0 move .b D0 A0 ) move +Next end-code +\ *** Block No. 4 Hexblock 4 +\ Ghost-creating 05mar86we + +0 | Constant 0 | Constant + +| : Make.ghost ( - cfa.ghost ) + here dup 1 and allot here + state @ IF context @ ELSE current THEN @ + dup @ , name + dup c@ 1 $1F uwithin not abort" inval.Gname" + dup c@ 1+ over c! + c@ dup 1+ allot 1 and 0= IF bl c, THEN + here 2 pick - -rot + , 0 , 0 , + swap here over - >heap + heap swap ! swap dp ! + heap + ; +\ *** Block No. 5 Hexblock 5 +\ ghost words 05mar86we + +: gfind ( string - cfa tf / string ff ) + dup count + 1+ bl swap c! + dup >r 1 over c+! find -1 r> c+! ; + +: ghost ( - cfa ) + >in @ name gfind IF nip exit THEN + drop >in ! Make.ghost ; + +: Word, ghost execute ; + +: gdoes> ( cfa.ghost - cfa.does ) + 4+ dup @ IF @ exit THEN + here dup , 0 , 4 >heap + dp ! heap dup rot ! ; +\ *** Block No. 6 Hexblock 6 +\ ghost utilities 04dec85we + +: g' name gfind 0= abort" ?" ; + +: '. + g' dup @ case? + IF ." forw" ELSE - abort" ??" ." res" THEN + 2+ dup @ 5 u.r + 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + +' ' Alias h' + + +\ *** Block No. 7 Hexblock 7 +\ .unresolved 05mar86we + +| : forward? ( cfa - cfa / exit&true ) + dup @ = over 2+ @ and IF drop true rdrop exit THEN ; + +| : unresolved? ( addr - f ) + 2+ dup c@ $1F and over + c@ BL = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + +: .unresolved voc-link @ + BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; +\ *** Block No. 8 Hexblock 8 +\ Extending Vocabularys for Target-Compilation 05mar86we + +: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + +Vocabulary Transient 0 tvoc ! + +Only definitions Forth also + +: T Transient ; immediate +: H Forth ; immediate + +definitions + + + + +\ *** Block No. 9 Hexblock 9 +\ Transient primitives 05mar86we + +Code byte> ( 8bh 8bl -- 16b ) + SP )+ D1 move SP ) D0 move 8 # D0 lsl .b D1 D0 move + .w D0 SP ) move Next end-code +Code >byte ( 16b -- 8bl 8bh ) + SP )+ D0 move D0 D1 move $FF D0 andi 8 # D1 lsr + D0 SP -) move D1 SP -) move Next end-code + +Transient definitions +: c@ H >image imagepage lc@ ; +: c! H >image imagepage lc! ; +: @ T dup c@ swap 1+ c@ byte> ; +: ! >r >byte r@ T c! r> 1+ c! ; +: cmove ( from.mem to.target quan -) + bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; +\ *** Block No. 10 Hexblock A +\ Transient primitives bp05mar86we + +: here there ; +: allot Tdp +! ; +: c, T here c! 1 allot H ; +: , T here ! 2 allot H ; + +: ," Ascii " parse dup T c, + under there swap cmove + dup 1 and 0= IF 1+ THEN allot H ; + +: fill ( addr quan 8b -) + -rot bounds ?DO dup I T c! H LOOP drop ; +: erase 0 T fill ; +: blank bl T fill ; +: here! H Tdp ! ; +\ *** Block No. 11 Hexblock B +\ Resolving 08dec85we +Forth definitions +: resolve ( cfa.ghost cfa.target -) + over dup @ = + IF space dup >name .name ." exists " ?cr 2+ ! drop exit THEN + >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = abort" resolve loop" r@ rot T ! + H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + +: resdoes> ( cfa.ghost cfa.target -) + swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; +] Does> [ here 4- 0 ] dup @ there rot ! T , H ; +' >body ! +] Does> [ here 4- 0 ] @ T , H ; +' >body ! +\ *** Block No. 12 Hexblock C +\ move-threads 68000-align 13jun86we + +: move-threads Tvoc @ Tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + error" some undef. Target-Vocs left" drop ; + +| : tlatest ( - addr) current @ 6 + ; +| : 68000-talign ( cfa -- ) 1 and IF 1 T allot H THEN ; + + + + + + + +\ *** Block No. 13 Hexblock D +\ save-target 09sep86we + +Dos definitions + +Code (filewrite ( buff len handle -- n) + SP )+ D0 move .l D2 clr .w SP )+ D2 move + .l 0 imagepage # D1 move .w SP )+ D1 move + .l D1 A7 -) move \ buffer adress + .l D2 A7 -) move \ buffer length + .w D0 A7 -) move \ handle + $40 # A7 -) move \ call WRITE + 1 trap $0C # A7 adda + .w D0 SP -) move Next end-code Forth definitions + + + +\ *** Block No. 14 Hexblock E +\ save Target-System 09sep86we + +: save-target [ Dos ] + bl word count dup 0= abort" missing filename" + over + off (createfile dup >r 0< abort" no device " + T here $1C - 4 ! 0 , 0 , H [ Dos ] \ Programm header + 0 there r@ (filewrite there - abort" write error" + r> (closefile 0< abort" close error" ; + + + + + + + + +\ *** Block No. 15 Hexblock F +\ compiling names into targ. 05mar86we + +: (theader + there 68000-talign + ?thead @ IF 1 ?thead +! exit THEN + >in @ name swap >in ! + dup c@ 1 $20 uwithin not + abort" inval. Tname" + blk @ T , H there tlatest dup @ T , H ! there dup tlast ! + over c@ 1+ even dup T allot cmove H ; + +: Theader tlast off + (theader Ghost dup glast' ! + there resolve ; + + +\ *** Block No. 16 Hexblock 10 +\ prebuild defining words bp27jun85we + +| : executable? ( adr - adr f ) dup ; +| : tpfa, there , ; +| : (prebuild ( cfa.adr -- ) + >in @ Create >in ! here 2- ! ; + +: prebuild ( adr 0.from.: - 0 ) + 0 ?pairs executable? dup >r + IF [compile] Literal compile (prebuild ELSE drop THEN + compile Theader Ghost gdoes> , + r> IF compile tpfa, THEN 0 ; immediate restrict + + + + +\ *** Block No. 17 Hexblock 11 +\ code portion of def.words bp11sep86we + +: dummy 0 ; + +: DO> ( - adr.of.jmp.dodoes> 0 ) + [compile] Does> here 4- compile @ 0 ] ; + + + + + + + + + + +\ *** Block No. 18 Hexblock 12 +\ the 68000 Assembler 11sep86we + +Forth definitions +| Create relocate ] T c, , c@ here allot ! c! H [ + +Transient definitions + +: Assembler H [ Assembler ] relocate >codes ! Assembler ; +: >label ( 16b -) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; +: Label T here 1 and allot here >label Assembler H ; +: Code H Theader there 2+ T , Assembler H ; + + + + +\ *** Block No. 19 Hexblock 13 +\ immed. restr. ' \ compile bp05mar86we + +: ?pairs ( n1 n2 -- ) H - abort" unstructured" ; +: >mark ( - addr ) H there T 0 , H ; +: >resolve ( addr - ) H there over - swap T ! H ; +: - cfa ) H g' dup @ - abort" ?" 2+ @ ; +: | H ?thead @ ?exit ?thead on ; +: compile H Ghost , ; immediate restrict + + +\ *** Block No. 20 Hexblock 14 +\ Target tools ks05mar86we + +Onlyforth Ttools also definitions + +| : ttype ( adr n -) bounds ?DO I T c@ H dup + bl > IF emit ELSE drop Ascii . emit THEN LOOP ; +: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype + ELSE ." ??? " THEN space ?cr ; +| : nfa? ( cfa lfa - nfa / cfa ff) + BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ even = + IF 2+ nip exit THEN + T @ H REPEAT ; +: >name ( cfa - nfa / ff) + Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup + IF nip exit THEN + swap REPEAT nip ; +\ *** Block No. 21 Hexblock 15 +\ Ttools for decompiling ks05mar86we + +| : ?: dup 4 u.r ." :" ; +| : @? dup T @ H 6 u.r ; +| : c? dup T c@ H 3 .r ; + +: s ( addr - addr+ ) ?: space c? 3 spaces + dup 1+ over T c@ H ttype dup T c@ H + 1+ ; + +: n ( addr - addr+2 ) ?: @? 2 spaces + dup T @ H [ Ttools ] >name .name H 2+ ; + +: d ( addr n - addr+n ) 2dup swap ?: swap 0 DO c? 1+ LOOP + 2 spaces -rot ttype ; + + +\ *** Block No. 22 Hexblock 16 +\ Tools for decompiling bp05mar86we + +: l ( addr -- addr+2 ) ?: 5 spaces @? 2+ ; + +: c ( addr -- addr+1 ) 1 d ; + +: b ( addr -- addr+1 ) ?: @? dup T @ H over + 5 u.r 2+ ; + +: dump ( adr n -) bounds ?DO cr I $10 d drop + stop? IF LEAVE THEN $10 +LOOP ; + +: view T ' H [ Ttools ] >name ?dup + IF 4- T @ H l THEN ; + + + +\ *** Block No. 23 Hexblock 17 +\ reinterpretation def.-words 05mar86we + +Onlyforth + +: redefinition + tdoes> @ IF >in push [ ' >interpret >body ] Literal push + state push context push >in: @ >in ! + name [ ' Transient 2+ ] Literal (find nip 0= + IF cr ." Redefinition: " here .name + >in: @ >in ! : Defining interpret THEN + THEN 0 tdoes> ! ; + + + + + +\ *** Block No. 24 Hexblock 18 +\ Create..does> structure bp05mar86we + +| : (;tcode Tlast @ dup T c@ dup 1 and - 2+ + ! H rdrop ; + +| : changecfa compile lit tdoes> @ , compile (;tcode ; + +Defining definitions + +: ;code 0 ?pairs changecfa reveal rdrop ; + immediate restrict + +Defining ' ;code Alias does> immediate restrict + +: ; [compile] ; rdrop ; immediate restrict + + +\ *** Block No. 25 Hexblock 19 +\ redefinition conditionals bp27jun85we + +' DO Alias DO immediate restrict +' ?DO Alias ?DO immediate restrict +' LOOP Alias LOOP immediate restrict +' IF Alias IF immediate restrict +' THEN Alias THEN immediate restrict +' ELSE Alias ELSE immediate restrict +' BEGIN Alias BEGIN immediate restrict +' UNTIL Alias UNTIL immediate restrict +' WHILE Alias WHILE immediate restrict +' REPEAT Alias REPEAT immediate restrict + + + + +\ *** Block No. 26 Hexblock 1A +\ clear Liter. Ascii ['] ." bp05mar86we + +Onlyforth Transient definitions + +: clear true abort" There are ghosts" ; +: Literal ( n -) T compile lit , H ; immediate +: Ascii H bl word 1+ c@ state @ + IF T [compile] Literal H THEN ; immediate +: ['] T ' [compile] Literal H ; immediate restrict +: " T compile (" ," H ; immediate restrict +: ." T compile (." ," H ; immediate restrict + + + + + +\ *** Block No. 27 Hexblock 1B +\ Target compilation ] [ bp05mar86we + +Forth definitions + +: tcompile + ?stack >in @ name find ?dup + IF 0> IF nip execute >interpret THEN + drop dup >in ! name + THEN gfind IF nip execute >interpret THEN + nullstring? IF drop exit THEN + number? ?dup IF 0> IF swap T [compile] Literal THEN + [compile] Literal H drop >interpret THEN + drop >in ! Word, >interpret ; + +Transient definitions +: ] H state on ['] tcompile is >interpret ; +\ *** Block No. 28 Hexblock 1C +\ Target conditionals bp05mar86we + +: IF T compile ?branch >mark H 1 ; immediate restrict +: THEN abs 1 T ?pairs >resolve H ; immediate restrict +: ELSE T 1 ?pairs compile branch >mark swap >resolve + H -1 ; immediate restrict +: BEGIN T mark -2 H 2swap ; + immediate restrict +| : (repeat T 2 ?pairs resolve H REPEAT ; +: UNTIL T compile ?branch (repeat H ; immediate restrict +: REPEAT T compile branch (repeat H ; immediate restrict + + + +\ *** Block No. 29 Hexblock 1D +\ Target conditionals bp27jun85we + +: DO T compile (do >mark H 3 ; immediate restrict +: ?DO T compile (?do >mark H 3 ; immediate restrict +: LOOP T 3 ?pairs compile (loop compile endloop + >resolve H ; immediate restrict +: +LOOP T 3 ?pairs compile (+loop compile endloop + >resolve H ; immediate restrict + + + + + + + + +\ *** Block No. 30 Hexblock 1E +\ predefinitions bp05mar86we + +: abort" T compile (abort" ," H ; immediate +: error" T compile (err" ," H ; immediate + +Forth definitions + +Variable torigin +Variable tudp 0 Tudp ! + +: >user T c@ H torigin @ + ; + + + + + +\ *** Block No. 31 Hexblock 1F +\ Datatypes bp05mar86we + +Transient definitions +: origin! H torigin ! ; +: user' ( -- n ) T ' >body c@ H ; +: uallot ( n -- ) H tudp @ swap tudp +! ; + + DO> >user ; +: User prebuild User 2 T uallot c, ; + + DO> ; +: Create prebuild Create ; + + DO> T @ H ; +: Constant prebuild Constant T , ; +: Variable Create 2 T allot ; +\ *** Block No. 32 Hexblock 20 +\ Datatypes bp05mar86we + +dummy +: Vocabulary + H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , + here H tvoc-link @ T , H tvoc-link ! ; + + + + + + + + + + +\ *** Block No. 33 Hexblock 21 +\ target defining words bp08sep86we + + Do> ; +: Defer prebuild Defer 2 T allot ; +: Is T ' H >body state @ IF T compile (is , H + ELSE T ! H THEN ; immediate +| : dodoes> T compile (;code H Glast' @ + there resdoes> there tdoes> ! ; + +: ;code 0 T ?pairs dodoes> Assembler H [compile] [ + redefinition ; immediate restrict +: does> T dodoes> $4EAB , \ FP D) JSR + compile (dodoes> H ; immediate restrict + + + +\ *** Block No. 34 Hexblock 22 +\ : Alias ; bp25mar86we + +: Create: T Create H current @ context ! T ] H 0 ; + +dummy +: : H tdoes> off >in @ >in: ! T prebuild : + H current @ context ! T ] H 0 ; + +: Alias ( n -- ) H Tlast off (theader Ghost over resolve + tlast @ T c@ H $20 or tlast @ T c! , H ; + +: ; T 0 ?pairs compile unnest [compile] [ H redefinition ; + immediate restrict + + + +\ *** Block No. 35 Hexblock 23 +\ predefinitions bp11sep86we + +: compile T compile compile H ; immediate restrict +: Host H Onlyforth Ttools also ; +: Compiler T Host H Transient also definitions ; +: [compile] H Word, ; immediate restrict +: Onlypatch H there 4- 0 tdoes> ! 0 ; + +Onlyforth +: Target Onlyforth Transient also definitions ; + +Transient definitions +Ghost c, drop + + + +\ *** Block No. 36 Hexblock 24 + + + + + + + + + + + + + + + + +\ *** Block No. 37 Hexblock 25 + + + + + + + + + + + + + + + + +\ *** Block No. 38 Hexblock 26 + + + + + + + + + + + + + + + + +\ *** Block No. 39 Hexblock 27 + + + + + + + + + + + + + + + + diff --git a/sources/AtariST/TASKER.FB.src b/sources/AtariST/TASKER.FB.src deleted file mode 100644 index fd26c80..0000000 --- a/sources/AtariST/TASKER.FB.src +++ /dev/null @@ -1,136 +0,0 @@ -Screen 0 not modified - 0 \\ *** Multitasker *** bp 12oct86 - 1 - 2 Dieses File enth„lt die Worte fr das Multitasking. - 3 - 4 Mit TASK werden Tasks eingerichtet. Jede Task hat ihren eige- - 5 nen Daten- und Returnstack, deren Gr”že beim Einrichten der - 6 Task angegeben werden muž. - 7 - 8 Mit MULTITASK wird der Tasker eingeschaltet, mit SINGLETASK - 9 abgeschaltet. Mit TASKS kann man die Tasks im System und -10 ihren Zustand anzeigen. -11 -12 N„heres zur Funktionsweise des Taskers findet man im Handbuch, -13 ebenso wie ein ausfhrliches Glossar ! -14 -15 -Screen 1 not modified - 0 \ Multitasker Loadscreen 22nov86bp - 1 - 2 Onlyforth - 3 - 4 \needs Code 2 loadfrom assemble.scr - 5 \needs multitask 1 +load - 6 - 7 02 05 +thru \ Tasker - 8 06 +load \ Spooler - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ stop singletask multitask 14sep86we - 1 - 2 Code stop - 3 .l FP IP suba .w IP SP -) move - 4 .l FP RP suba .w RP SP -) move - 5 UP R#) D6 move D6 reg) A0 lea - 6 .l FP SP suba .w SP 8 A0 D) move - 7 2 A0 D) D6 move D6 reg) jmp end-code - 8 - 9 Label taskpause -10 UP R#) D6 move D6 reg) A0 lea $4E43 # A0 ) move -11 Forth ' stop @ Assembler bra end-code -12 -13 : singletask [ ' pause @ ] Literal ['] pause ! ; -14 -15 : multitask taskpause ['] pause ! ; -Screen 3 not modified - 0 \ pass activate bp 12oct86 - 1 - 2 | : (pass ( n0 ... nm-1 Taskaddr m -- ) - 3 rdrop swap \ delete IP of ACTIVATE or PASS - 4 $4E43 over ! \ awake Task - 5 r> -rot \ get the IP; Stack: IP m Taskaddr - 6 &10 + >r \ push s0 of Task - 7 r@ 2+ @ swap \ Stack-Top: IP r0 m - 8 2+ 2* \ bytes on Taskstack incl. r0 & IP - 9 r@ @ over - \ new SP -10 dup r> 2- ! \ into Ssave -11 swap bounds ?DO I ! 2 +LOOP ; -12 -13 : activate ( Taddr -- ) 0 (pass ; restrict -14 -15 : pass ( n0 ... nm-1 Taskaddr m ) (pass ; restrict -Screen 4 not modified - 0 \ sleep wake taskerror bp 12oct86 - 1 - 2 : sleep ( Taddr -- ) $3C3C swap ! ; \ # D6 move opcode - 3 : wake ( Taddr -- ) $4E43 swap ! ; \ Trap 3 opcode - 4 - 5 | : taskerror ( string -- ) - 6 standardi/o singletask bell - 7 at? &24 0 at ." Task error : " rot count type at - 8 multitask stop ; - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ Task 14sep86we - 1 - 2 : Task ( rlen slen -- ) - 3 2 arguments - 4 0 Constant here >r \ Task-dp - 5 even dup r@ + r@ 2- ! allot even \ 68000 align - 6 up@ here 100 cmove \ init user area - 7 here $3C3C , up@ 2+ @ , \ JMP opcode to sleep task - 8 $4EF3 , $6800 , - 9 dup up@ 2+ ! \ link task -10 dup 6 - dup , , \ ssave and s0 -11 2dup + , \ here + rlen = r0 -12 r@ , \ dp -13 under + here - allot 0 , -14 ['] taskerror swap [ ' errorhandler >body c@ ] Literal + ! -15 r> 2- 2- , ; -Screen 6 not modified - 0 \ rendezvous 's tasks 22nov86bp - 1 - 2 : rendezvous ( semaphoraddr -- ) - 3 dup unlock pause lock ; - 4 - 5 | : statesmart state @ IF [compile] Literal THEN ; - 6 - 7 : 's ( Taddr -- adr ) \ adr is adress of the foll. uservar - 8 ' >body c@ + statesmart ; immediate - 9 -10 : tasks ( -- ) -11 cr ." Main " up@ dup 2+ @ -12 BEGIN 2dup - WHILE cr dup [ ' r0 >body c@ ] Literal + @ -13 2+ @ >name .name -14 dup @ $3C3C = IF ." sleeping" THEN -15 2+ @ REPEAT 2drop ; -Screen 7 not modified - 0 \ Printerspool 21oct86we - 1 - 2 $100 $200 Task spooler - 3 - 4 : spool' ( -- ) \ reads word - 5 ' isfile@ offset @ base @ spooler depth 1- 6 min pass - 6 base ! offset ! isfile ! execute - 7 true abort" SPOOL' ready for next job!" stop ; - 8 - 9 \\ syntax: -10 spool' listing -11 spool' printall -12 from to spool' pthru -13 from to spool' document -14 -15 diff --git a/sources/AtariST/TASKER.fth b/sources/AtariST/TASKER.fth new file mode 100644 index 0000000..be76b01 --- /dev/null +++ b/sources/AtariST/TASKER.fth @@ -0,0 +1,136 @@ +\ *** Block No. 0 Hexblock 0 +\\ *** Multitasker *** bp 12oct86 + +Dieses File enth„lt die Worte fr das Multitasking. + +Mit TASK werden Tasks eingerichtet. Jede Task hat ihren eige- + nen Daten- und Returnstack, deren Gr”že beim Einrichten der + Task angegeben werden muž. + +Mit MULTITASK wird der Tasker eingeschaltet, mit SINGLETASK + abgeschaltet. Mit TASKS kann man die Tasks im System und + ihren Zustand anzeigen. + +N„heres zur Funktionsweise des Taskers findet man im Handbuch, + ebenso wie ein ausfhrliches Glossar ! + + +\ *** Block No. 1 Hexblock 1 +\ Multitasker Loadscreen 22nov86bp + +Onlyforth + +\needs Code 2 loadfrom assemble.scr +\needs multitask 1 +load + +02 05 +thru \ Tasker + 06 +load \ Spooler + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ stop singletask multitask 14sep86we + +Code stop + .l FP IP suba .w IP SP -) move + .l FP RP suba .w RP SP -) move + UP R#) D6 move D6 reg) A0 lea + .l FP SP suba .w SP 8 A0 D) move + 2 A0 D) D6 move D6 reg) jmp end-code + +Label taskpause + UP R#) D6 move D6 reg) A0 lea $4E43 # A0 ) move + Forth ' stop @ Assembler bra end-code + +: singletask [ ' pause @ ] Literal ['] pause ! ; + +: multitask taskpause ['] pause ! ; +\ *** Block No. 3 Hexblock 3 +\ pass activate bp 12oct86 + +| : (pass ( n0 ... nm-1 Taskaddr m -- ) + rdrop swap \ delete IP of ACTIVATE or PASS + $4E43 over ! \ awake Task + r> -rot \ get the IP; Stack: IP m Taskaddr + &10 + >r \ push s0 of Task + r@ 2+ @ swap \ Stack-Top: IP r0 m + 2+ 2* \ bytes on Taskstack incl. r0 & IP + r@ @ over - \ new SP + dup r> 2- ! \ into Ssave + swap bounds ?DO I ! 2 +LOOP ; + +: activate ( Taddr -- ) 0 (pass ; restrict + +: pass ( n0 ... nm-1 Taskaddr m ) (pass ; restrict +\ *** Block No. 4 Hexblock 4 +\ sleep wake taskerror bp 12oct86 + +: sleep ( Taddr -- ) $3C3C swap ! ; \ # D6 move opcode +: wake ( Taddr -- ) $4E43 swap ! ; \ Trap 3 opcode + +| : taskerror ( string -- ) + standardi/o singletask bell + at? &24 0 at ." Task error : " rot count type at + multitask stop ; + + + + + + + +\ *** Block No. 5 Hexblock 5 +\ Task 14sep86we + +: Task ( rlen slen -- ) + 2 arguments + 0 Constant here >r \ Task-dp + even dup r@ + r@ 2- ! allot even \ 68000 align + up@ here 100 cmove \ init user area + here $3C3C , up@ 2+ @ , \ JMP opcode to sleep task + $4EF3 , $6800 , + dup up@ 2+ ! \ link task + dup 6 - dup , , \ ssave and s0 + 2dup + , \ here + rlen = r0 + r@ , \ dp + under + here - allot 0 , + ['] taskerror swap [ ' errorhandler >body c@ ] Literal + ! + r> 2- 2- , ; +\ *** Block No. 6 Hexblock 6 +\ rendezvous 's tasks 22nov86bp + +: rendezvous ( semaphoraddr -- ) + dup unlock pause lock ; + +| : statesmart state @ IF [compile] Literal THEN ; + +: 's ( Taddr -- adr ) \ adr is adress of the foll. uservar + ' >body c@ + statesmart ; immediate + +: tasks ( -- ) + cr ." Main " up@ dup 2+ @ + BEGIN 2dup - WHILE cr dup [ ' r0 >body c@ ] Literal + @ + 2+ @ >name .name + dup @ $3C3C = IF ." sleeping" THEN + 2+ @ REPEAT 2drop ; +\ *** Block No. 7 Hexblock 7 +\ Printerspool 21oct86we + +$100 $200 Task spooler + +: spool' ( -- ) \ reads word + ' isfile@ offset @ base @ spooler depth 1- 6 min pass + base ! offset ! isfile ! execute + true abort" SPOOL' ready for next job!" stop ; + +\\ syntax: +spool' listing +spool' printall +from to spool' pthru +from to spool' document + + diff --git a/sources/AtariST/TOOLS.FB.src b/sources/AtariST/TOOLS.FB.src deleted file mode 100644 index eb2cf20..0000000 --- a/sources/AtariST/TOOLS.FB.src +++ /dev/null @@ -1,272 +0,0 @@ -Screen 0 not modified - 0 \\ *** Tools *** 25may86we - 1 - 2 In diesem File sind die wichtigsten Debugging-Tools enthalten. - 3 - 4 Dazu geh”ren ein einfacher Decompiler, ein Speicherdump und - 5 der Tracer (s. Kapitel im Handbuch) - 6 Vor allem der Tracer hat sich als sehr sinnvolles Werkzeug bei - 7 der Fehlerbek„mpfung entwickelt. Normalerweise sind Fehlerquel- - 8 len beim Tracen sofort auffindbar, manchmal allerdings auch - 9 nicht ganz so schnell ... -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Loadscreen for simple decompiler 26oct86we - 1 - 2 Onlyforth Vocabulary Tools Tools also definitions - 3 - 4 1 5 +thru - 5 6 +load \ Tracer - 6 - 7 Onlyforth - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ Tools for decompiling 26oct86we - 1 - 2 | : ?: dup 4 u.r ." :" ; - 3 | : @? dup @ 6 u.r ; - 4 | : c? dup c@ 3 .r ; - 5 - 6 : s ( adr - adr+ ) - 7 ?: space c? 3 spaces dup 1+ over c@ type - 8 dup c@ + 1+ even ; - 9 -10 : n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ; -11 : k ( adr - adr+2 ) ?: 5 spaces @? 2+ ; -12 : b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ; -13 -14 -15 -Screen 3 not modified - 0 \ Tools for decompiling 26oct86we - 1 - 2 : d ( adr n - adr+n) - 3 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ; - 4 - 5 : c ( adr - adr+1) 1 d ; - 6 - 7 - 8 \\ - 9 : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE -10 THEN 10 +LOOP ; -11 -12 -13 -14 \ dekompiliere String Name Konstant Char Branch Dump -15 \ = = = = = = -Screen 4 not modified - 0 \ General Dump Utility - Output 26oct86we - 1 - 2 | : .2 ( n -- ) 0 <# # # #> type space ; - 3 | : .6 ( d -- ) <# # # # # # # #> type ; - 4 | : d.2 ( addr len -- ) bounds ?DO I c@ .2 LOOP ; - 5 | : emit. ( char -- ) $7F and - 6 dup bl $7E uwithin not IF drop Ascii . THEN emit ; - 7 - 8 | : dln ( addr --- ) - 9 cr dup 6 u.r 2 spaces 8 2dup d.2 space -10 over + 8 d.2 space $10 bounds ?DO I c@ EMIT. LOOP ; -11 | : ?.n ( n1 n2 -- n1 ) -12 2dup = IF ." \/" drop ELSE 2 .r THEN space ; -13 | : ?.a ( n1 n2 -- n1 ) -14 2dup = IF ." v" drop ELSE 1 .r THEN ; -15 -Screen 5 not modified - 0 \ Longdump basics 24aug86we - 1 - 2 | : ld.2 ( hiaddr loaddr len -- hiaddr ) - 3 bounds ?DO I over lc@ .2 LOOP ; - 4 - 5 | : ldln ( hiaddr loaddr -- ) - 6 cr dup >r over .6 2 spaces - 7 r@ 8 ld.2 space r@ 8 + 8 ld.2 space - 8 r> $10 bounds ?DO I over lc@ emit. LOOP drop ; - 9 -10 | : .head ( addr len -- addr' len' ) -11 swap dup -$10 and swap $0F and cr 8 spaces -12 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP -13 space $10 0 DO I ?.a LOOP rot + ; -14 -15 -Screen 6 not modified - 0 \ Dump and Fill Memory Utility 10sep86we - 1 - 2 Forth definitions - 3 - 4 : ldump ( laddr len -- ) - 5 base push hex >r swap r> .head - 6 bounds ?DO dup I ldln stop? IF LEAVE THEN - 7 I $FFF0 = IF 1+ THEN $10 +LOOP drop ; - 8 - 9 : dump ( addr len -- ) -10 base push hex .head -11 bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ; -12 -13 -14 -15 -Screen 7 not modified - 0 \ Trace Loadscreen 26oct86we - 1 - 2 Onlyforth \needs Tools Vocabulary Tools - 3 Tools also definitions - 4 - 5 \needs cpush 1 +load - 6 \needs >absaddr : >absaddr 0 forthstart d+ ; - 7 - 8 2 8 +thru - 9 -10 Onlyforth -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ throw status on Return-Stack 26oct86we - 1 - 2 | Create: cpull - 3 rp@ count 2dup + even rp! r> swap cmove ; - 4 - 5 : cpush ( addr len --) r> -rot over >r - 6 rp@ over 2+ - even dup rp! place cpull >r >r ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ Variables do-trace 10sep86we - 1 - 2 | Variable (W \ Variable for saving W - 3 | Variable \ end of trace trap range - 5 | Variable nest? \ True if NEST shall performed - 6 | Variable newnext \ Address of new Next for tracing - 7 | Variable last' \ holds adr of position in traced word - 8 | Variable #spaces \ for indenting nested trace - 9 | Variable trap? \ True if trace is allowed -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ install Tracer 11sep86we - 1 - 2 Label trnext 0 # D6 move .l 0 D6 FP DI) jmp end-code - 3 - 4 Label (do-trace newnext R#) D0 move D0 trnext 2+ R#) move - 5 .w trnext # D6 move .l D6 reg) A0 lea A0 D5 move - 6 .w UP R#) D6 move - 7 .l ' next-link >body c@ D6 FP DI) D6 .w move - 8 BEGIN .l D6 reg) A1 lea .w D6 tst 0<> - 9 WHILE .w &10 # A1 suba .l D5 A0 move -10 A0 )+ A1 )+ move A0 )+ A1 )+ move -11 .w 2 A1 addq A1 ) D6 move -12 REPEAT rts end-code -13 -14 Code do-trace \ opposite of end-trace -15 (do-trace bsr Next end-code -Screen 11 not modified - 0 \ reenter tracer 04sep86we - 1 - 2 | : oneline .status space query interpret -&82 allot - 3 rdrop ( delete quit from tracenext ) ; - 4 - 5 | Code (step - 6 RP )+ D7 move .l D7 IP lmove FP IP adda - 7 .w (W R#) D7 move -1 # trap? R#) move - 8 Label fnext - 9 D7 reg) D6 move D6 reg) jmp end-code -10 -11 | Create: nextstep (step ; -12 -13 : (debug ( addr -- ) \ start tracing at addr -14 dup ! ; -15 -Screen 12 not modified - 0 \ check trace conditions 10sep86we - 1 - 2 Label tracenext tracenext newnext ! - 3 IP )+ D7 move - 4 trap? R#) tst fnext beq - 5 .b nest? R#) D0 move \ byte order!! - 6 0= IF .l IP D0 move FP D0 sub - 7 .w R#) D0 cmp fnext bhi - 9 ELSE .b 0 # nest? R#) move THEN \ low byte still set -10 -11 \ one trace condition satisfied -12 .w D7 (W R#) move trap? R#) clr -13 -14 -15 -Screen 13 not modified - 0 \ tracer display 26oct86we - 1 - 2 ;c: nest? @ - 3 IF nest? off r> ip> push r THEN - 5 r@ nextstep >r input push output push standardi/o - 6 2- dup last' ! - 7 cr #spaces @ spaces dup 5 u.r @ dup 6 u.r 2 spaces - 8 >name .name $1C col - 0 max spaces .s - 9 state push blk push >in push ['] 'quit >body push -10 [ ' >interpret >body ] Literal push -11 #tib push tib #tib @ cpush r0 push rp@ r0 ! -12 &82 allot ['] oneline Is 'quit quit ; -13 -14 -15 -Screen 14 not modified - 0 \ DEBUG with errorchecking 11sep86we - 1 - 2 | : traceable ( cfa -- adr) - 3 recursive dup @ - 4 ['] : @ case? ?exit - 5 ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN - 6 ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN - 7 ['] r/w @ case? IF >body @ traceable exit THEN - 8 drop dup @ @ $4EAB = IF @ 4+ exit THEN \ 68000 voodoo code - 9 >name .name ." can't be DEBUGged" quit ; -10 -11 : nest \ trace next high-level word executed -12 last' @ @ traceable drop nest? on ; -13 -14 : unnest \ ends tracing of actual word -15 off ; \ clears trap range -Screen 15 not modified - 0 \ misc. words for tracing bp 9Mar86 - 1 - 2 : endloop \ sets trap range next current word - 3 last' @ 4+ name .name 2+ ; +: k ( adr - adr+2 ) ?: 5 spaces @? 2+ ; +: b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ; + + + +\ *** Block No. 3 Hexblock 3 +\ Tools for decompiling 26oct86we + +: d ( adr n - adr+n) + 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ; + +: c ( adr - adr+1) 1 d ; + + +\\ +: dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE +THEN 10 +LOOP ; + + + +\ dekompiliere String Name Konstant Char Branch Dump +\ = = = = = = +\ *** Block No. 4 Hexblock 4 +\ General Dump Utility - Output 26oct86we + +| : .2 ( n -- ) 0 <# # # #> type space ; +| : .6 ( d -- ) <# # # # # # # #> type ; +| : d.2 ( addr len -- ) bounds ?DO I c@ .2 LOOP ; +| : emit. ( char -- ) $7F and + dup bl $7E uwithin not IF drop Ascii . THEN emit ; + +| : dln ( addr --- ) + cr dup 6 u.r 2 spaces 8 2dup d.2 space + over + 8 d.2 space $10 bounds ?DO I c@ EMIT. LOOP ; +| : ?.n ( n1 n2 -- n1 ) + 2dup = IF ." \/" drop ELSE 2 .r THEN space ; +| : ?.a ( n1 n2 -- n1 ) + 2dup = IF ." v" drop ELSE 1 .r THEN ; + +\ *** Block No. 5 Hexblock 5 +\ Longdump basics 24aug86we + +| : ld.2 ( hiaddr loaddr len -- hiaddr ) + bounds ?DO I over lc@ .2 LOOP ; + +| : ldln ( hiaddr loaddr -- ) + cr dup >r over .6 2 spaces + r@ 8 ld.2 space r@ 8 + 8 ld.2 space + r> $10 bounds ?DO I over lc@ emit. LOOP drop ; + +| : .head ( addr len -- addr' len' ) + swap dup -$10 and swap $0F and cr 8 spaces + 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP + space $10 0 DO I ?.a LOOP rot + ; + + +\ *** Block No. 6 Hexblock 6 +\ Dump and Fill Memory Utility 10sep86we + +Forth definitions + +: ldump ( laddr len -- ) + base push hex >r swap r> .head + bounds ?DO dup I ldln stop? IF LEAVE THEN + I $FFF0 = IF 1+ THEN $10 +LOOP drop ; + +: dump ( addr len -- ) + base push hex .head + bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ; + + + + +\ *** Block No. 7 Hexblock 7 +\ Trace Loadscreen 26oct86we + +Onlyforth \needs Tools Vocabulary Tools +Tools also definitions + +\needs cpush 1 +load +\needs >absaddr : >absaddr 0 forthstart d+ ; + +2 8 +thru + +Onlyforth + + + + + +\ *** Block No. 8 Hexblock 8 +\ throw status on Return-Stack 26oct86we + +| Create: cpull + rp@ count 2dup + even rp! r> swap cmove ; + +: cpush ( addr len --) r> -rot over >r + rp@ over 2+ - even dup rp! place cpull >r >r ; + + + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ Variables do-trace 10sep86we + +| Variable (W \ Variable for saving W +| Variable \ end of trace trap range +| Variable nest? \ True if NEST shall performed +| Variable newnext \ Address of new Next for tracing +| Variable last' \ holds adr of position in traced word +| Variable #spaces \ for indenting nested trace +| Variable trap? \ True if trace is allowed + + + + + + +\ *** Block No. 10 Hexblock A +\ install Tracer 11sep86we + +Label trnext 0 # D6 move .l 0 D6 FP DI) jmp end-code + +Label (do-trace newnext R#) D0 move D0 trnext 2+ R#) move + .w trnext # D6 move .l D6 reg) A0 lea A0 D5 move + .w UP R#) D6 move + .l ' next-link >body c@ D6 FP DI) D6 .w move + BEGIN .l D6 reg) A1 lea .w D6 tst 0<> + WHILE .w &10 # A1 suba .l D5 A0 move + A0 )+ A1 )+ move A0 )+ A1 )+ move + .w 2 A1 addq A1 ) D6 move + REPEAT rts end-code + + Code do-trace \ opposite of end-trace + (do-trace bsr Next end-code +\ *** Block No. 11 Hexblock B +\ reenter tracer 04sep86we + +| : oneline .status space query interpret -&82 allot + rdrop ( delete quit from tracenext ) ; + +| Code (step + RP )+ D7 move .l D7 IP lmove FP IP adda + .w (W R#) D7 move -1 # trap? R#) move +Label fnext + D7 reg) D6 move D6 reg) jmp end-code + +| Create: nextstep (step ; + +: (debug ( addr -- ) \ start tracing at addr + dup ! ; + +\ *** Block No. 12 Hexblock C +\ check trace conditions 10sep86we + +Label tracenext tracenext newnext ! + IP )+ D7 move + trap? R#) tst fnext beq + .b nest? R#) D0 move \ byte order!! + 0= IF .l IP D0 move FP D0 sub + .w R#) D0 cmp fnext bhi + ELSE .b 0 # nest? R#) move THEN \ low byte still set + + \ one trace condition satisfied + .w D7 (W R#) move trap? R#) clr + + + +\ *** Block No. 13 Hexblock D +\ tracer display 26oct86we + +;c: nest? @ + IF nest? off r> ip> push r THEN + r@ nextstep >r input push output push standardi/o + 2- dup last' ! + cr #spaces @ spaces dup 5 u.r @ dup 6 u.r 2 spaces + >name .name $1C col - 0 max spaces .s + state push blk push >in push ['] 'quit >body push + [ ' >interpret >body ] Literal push + #tib push tib #tib @ cpush r0 push rp@ r0 ! + &82 allot ['] oneline Is 'quit quit ; + + + +\ *** Block No. 14 Hexblock E +\ DEBUG with errorchecking 11sep86we + +| : traceable ( cfa -- adr) + recursive dup @ + ['] : @ case? ?exit + ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN + ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN + ['] r/w @ case? IF >body @ traceable exit THEN + drop dup @ @ $4EAB = IF @ 4+ exit THEN \ 68000 voodoo code + >name .name ." can't be DEBUGged" quit ; + +: nest \ trace next high-level word executed + last' @ @ traceable drop nest? on ; + +: unnest \ ends tracing of actual word + off ; \ clears trap range +\ *** Block No. 15 Hexblock F +\ misc. words for tracing bp 9Mar86 + +: endloop \ sets trap range next current word + last' @ 4+ r >r - 8 over #tib @ dup span ! type - 9 r> r> at exit then then -10 STdecode ; -11 -12 Input: keyboard STkey STkey? undoSTdecode STexpect ; -13 -14 keyboard save -15 -Screen 2 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/AtariST/UNDO.fth b/sources/AtariST/UNDO.fth new file mode 100644 index 0000000..1e8bcb4 --- /dev/null +++ b/sources/AtariST/UNDO.fth @@ -0,0 +1,51 @@ +\ *** Block No. 0 Hexblock 0 +\\ Undo for the VolksForth command line cas2013apr05 + +The tool extends the VolksForth "decode" function +with an UNDO. If there was a typo in the previous line +pressing the UNDO key will re-fetch the last entered line so +that it can be edited + +Published in VD 3/87 by Bernd Pennemann + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Undo for Atari ST cas2013apr05 +Onlyforth + +| $6100 Constant #undo + +: undoSTdecode ( addr pos1 key -- addr pos2 ) + over 0= if + #undo case? if at? >r >r + over #tib @ dup span ! type + r> r> at exit then then + STdecode ; + +Input: keyboard STkey STkey? undoSTdecode STexpect ; + +keyboard save + +\ *** Block No. 2 Hexblock 2 + + + + + + + + + + + + + + + + diff --git a/sources/cpm/ASS8080.FB.src b/sources/cpm/ASS8080.FB.src deleted file mode 100644 index 58b04a8..0000000 --- a/sources/cpm/ASS8080.FB.src +++ /dev/null @@ -1,306 +0,0 @@ -Screen 0 not modified - 0 \ VolksForth 8080 Assembler UH 09Mar86 - 1 - 2 Ideen lieferten: - 3 John Cassady - 4 Mike Perry - 5 Klaus Schleisiek - 6 Bernd Pennemann - 7 Dietrich Weineck - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ VolksForth 8080 Assembler Load Screen UH 03Jun86 - 1 Onlyforth Assembler also definitions hex - 2 - 3 1 6 +THRU cr .( VolksForth 8080-Assembler geladen. ) cr - 4 - 5 OnlyForth - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ Vektorisierte Erzeugung UH 03Jun86 - 1 Variable >codes - 2 - 3 | Create nrc ] c, , c@ here allot ! c! [ - 4 - 5 : nonrelocate ( -- ) nrc >codes ! ; nonrelocate - 6 - 7 | : >exec ( n -- n+2 ) - 8 Create dup c, 2+ does> c@ >codes @ + perform ; - 9 -10 0 | >exec >c, | >exec >, | >exec >c@ | >exec >here -11 | >exec >allot | >exec >! | >exec >c! -12 drop -13 -14 -15 -Screen 3 not modified - 0 \ Register und Definierende Worte UH 09Mar86 - 1 - 2 7 Constant A - 3 0 Constant B 1 Constant C 2 Constant D 3 Constant E - 4 0 Constant I 1 Constant I' 2 Constant W 3 Constant W' - 5 0 Constant IP 1 Constant IP' 4 Constant H 5 Constant L - 6 6 Constant M 6 Constant PSW 6 Constant SP 6 Constant S - 7 - 8 | : 1MI Create >c, does> C@ >c, ; - 9 | : 2MI Create >c, does> C@ + >c, ; -10 | : 3MI Create >c, does> C@ swap 8 * + >c, ; -11 | : 4MI Create >c, does> C@ >c, >c, ; -12 | : 5MI Create >c, does> C@ >c, >, ; -13 -14 -15 -Screen 4 not modified - 0 \ Mnemonics UH 09Mar86 - 1 00 1MI nop 76 1MI hlt F3 1MI di FB 1MI ei 07 1MI rlc - 2 0F 1MI rrc 17 1MI ral 1F 1MI rar E9 1MI pchl EB 1MI xchg - 3 C9 1MI ret C0 1MI rnz C8 1MI rz D0 1MI rnc D8 1MI rc - 4 2F 1MI cma 37 1MI stc 3F 1MI cmc F9 1MI sphl E3 1MI xthl - 5 E0 1MI rpo E8 1MI rpe F8 1MI rm 27 1MI daa - 6 80 2MI add 88 2MI adc 90 2MI sub 98 2MI sbb A0 2MI ana - 7 A8 2MI xra B0 2MI ora B8 2MI cmp 02 3MI stax 04 3MI inr - 8 03 3MI inx 09 3MI dad 0B 3MI dcx C1 3MI pop C5 3MI push - 9 C7 3MI rst 05 3MI dcr 0A 3MI ldax D3 4MI out DB 4MI in -10 C6 4MI adi CE 4MI aci D6 4MI sui DE 4MI sbi E6 4MI ani -11 EE 4MI xri F6 4MI ori FE 4MI cpi 22 5MI shld CD 5MI call -12 2A 5MI lhld 32 5MI sta 3A 5MI lda C3 5MI jmp -13 C2 5MI jnz CA 5MI jz D2 5MI jnc DA 5MI jc E2 5MI jpo -14 EA 5MI jpe F2 5MI jp FA 5MI jm -15 -Screen 5 not modified - 0 \ Spezial Mnemonics und Spruenge UH 09Mar86 - 1 DA Constant C0= D2 Constant C0<> D2 Constant CS - 2 C2 Constant 0= CA Constant 0<> E2 Constant PE - 3 F2 Constant 0< FA Constant 0>= : not 8 [ FORTH ] xor ; - 4 - 5 : mov 8 * 40 + + >c, ; - 6 : mvi 8 * 6 + >c, >c, ; : lxi 8 * 1+ >c, >, ; - 7 - 8 : [[ ( -- addr ) >here ; \ BEGIN - 9 : ?] ( addr opcode -- ) >c, >, ; \ UNTIL -10 : ?[ ( opcode -- addr ) >c, >here 0 >, ; \ IF -11 : ?[[ ( addr -- addr' addr ) ?[ swap ; \ WHILE -12 : ]? ( addr -- ) >here swap >! ; \ THEN -13 : ][ ( addr -- addr' ) >here 1+ 0 jmp swap ]? ; \ ELSE -14 : ]] ( addr -- ) jmp ; \ AGAIN -15 : ]]? ( addr addr' -- ) jmp ]? ; \ REPEAT -Screen 6 not modified - 0 \ Macros UH 14May86 - 1 : end-code context 2- @ context ! ; - 2 - 3 : ;c: 0 recover call end-code ] ; - 4 - 5 : Next >next jmp ; - 6 - 7 : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) - 8 H dcx 1+ M mov ( low ) RP shld ; - 9 -10 : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx -11 M swap mov ( high ) H inx RP shld ; -12 \ rpush und rpop gehen nicht mit HL -13 -14 : mvx ( src dest -- ) -15 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) ; -Screen 7 not modified - 0 \ Definierende Worte UH 06Aug86 - 1 Forth definitions - 2 : Code ( -- ) Create here dup 2- ! Assembler ; - 3 - 4 : ;Code ( -- ) 0 ?pairs - 5 compile [ ' does> >body 2+ @ , ] - 6 reveal [compile] [ Assembler ; immediate - 7 - 8 : >label ( adr -- ) - 9 here | Create swap , 4 hallot >here 4 - heap 4 cmove -10 heap last @ (name> ! dp ! -11 does> ( -- adr ) @ State @ IF [compile] Literal THEN ; -12 -13 : Label [ Assembler ] >here >label Assembler ; -14 -15 -Screen 8 not modified - 0 UH 14May86 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 % VolksForth 8080 Assembler Shadow-Screens UH 09Mar86 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 % VolksForth 8080 Assembler UH 03Jun86 - 1 - 2 Der 8080 Assembler wurde von John Cassady, in den Forth - 3 Dimensions veroeffentlicht und von Mike Perry im F83 - 4 implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat - 5 und auch Befehle zur strukturierten Assemblerprogrammierung. - 6 Um ein Wort in Assembler zu definieren wird das definierende - 7 Wort Code benutzt, es kann, muss aber nicht mit end-code beendet - 8 werden. Wie der Assembler arbeitet ist ein interessantes - 9 Beispiel fuer die Maechtigkeit von Create does>. -10 Am Anfang werden die Befehle in Klassen eingeteilt und fuer -11 jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic -12 des Befehls spaeter interpretiert wird, kompiliert er den -13 entsprechenden Opcode. -14 -15 -Screen 11 not modified - 0 % Vektorisierte Erzeugung UH 09Mar86 - 1 Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren. - 2 - 3 Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler - 4 - 5 Schaltet Assembler in den In-Line Modus. - 6 - 7 Definierendes Wort fuer Erzeugungs-Operator-Namen. - 8 - 9 -10 Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden -11 aktuellen Erzeugungsoperator aus. -12 -13 Mit diesen Erweiterungen kann der Assembler auch fuer den -14 Target-Compiler benutzt werden. -15 -Screen 12 not modified - 0 % Register und Definierende Worte UH 09Mar86 - 1 - 2 Die 8080 Register werden definiert. Es sind einfach Konstanten - 3 die Information fuer die Mnemonics hinterlassen. - 4 Einige Register der Forth-Maschine: - 5 IP ist BC, W ist DE - 6 - 7 - 8 Definierende Worte fuer die Mnemonics. - 9 Fast alle 8080 Befehle fallen in diese 5 Klassen. -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 % Mnemonics UH 09Mar86 - 1 Die 8080 Mnemonics werden definiert. - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 14 not modified - 0 % Spezial Mnemonics und Spruenge UH 09Mar86 - 1 Vergleiche des 8080 - 2 - 3 not folgt einem Vergleich, wenn er invertiert werden soll. - 4 - 5 die Mnemonics, die sich nicht in die Klassen MI1 bis MI5 - 6 einteilen lassen. - 7 - 8 Die strukturierten Assembler-Anweisungen. - 9 Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungen -10 zu den strukturierten Anweisungen in Forth entstehen. -11 Es findet keine Absicherung der Kontrollstrukturen statt, sodass -12 sie auch beliebig missbraucht, werden koennen. -13 Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig. -14 -15 -Screen 15 not modified - 0 % Macros UH 17May86 - 1 end-code beendet eine Code-Definition - 2 - 3 ;c: Erlaubt das Einbinden von High-Level Forth in Code-Worten. - 4 - 5 Next Assembliert einen Sprung zum Adress-Interpretierer. - 6 - 7 rpush Das angegebene Register wird auf den Return-Stack gelegt. - 8 - 9 -10 rpop Das angegebene Register wird vom Return-Stack genommen. -11 -12 rpush und rpop benutzen das HL Register. -13 -14 mvx Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register -15 Bewegt Registerpaare HL BC DE -Screen 16 not modified - 0 % Definierende Worte UH 17May86 - 1 Code leitet eine Code-Definition ein. - 2 - 3 ;code ist das Low-Level-Aequivalent von does> - 4 - 5 - 6 >label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert - 7 - 8 - 9 -10 -11 Label erzeugt ein Label auf dem Heap, mit dem Wert von here -12 -13 -14 -15 -Screen 17 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/ASSTRAN.FB.src b/sources/cpm/ASSTRAN.FB.src deleted file mode 100644 index b8b05de..0000000 --- a/sources/cpm/ASSTRAN.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \\ Transinient Assembler 11Nov86 - 1 - 2 Dieses File enthaelt Befehle, die den Assembler vollstaendig in - 3 den Heap laden, so dass er schliesslich mit clear wieder - 4 vergessen werden kann. - 5 - 6 Dadurch ist es nicht notwendig in einer Anwendung den ganzen - 7 Assembler im Speicher lassen zu muessen, nur weil einige - 8 primitive Worte in Assembler geschrieben sind. - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Internal Assembler UH 22Oct86 - 1 - 2 Onlyforth - 3 - 4 here - 5 $C00 hallot heap dp ! include ass8080.scr - 6 dp ! - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/COPY.FB.src b/sources/cpm/COPY.FB.src deleted file mode 100644 index 5f93959..0000000 --- a/sources/cpm/COPY.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \ Copy und Convey 19Nov87 - 1 - 2 Dieses File enthaelt Definitionen, die urspruenglich im Kern - 3 enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern - 4 klein zu halten. - 5 - 6 copy kopiert einen Screen - 7 - 8 convey kopiert einen Bereich von Screens - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ moving blocks 20Oct86 19Nov87 - 1 | : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; - 2 | : fromblock ( blk -- adr ) fromfile @ (block ; - 3 | : (copy ( from to -- ) - 4 dup isfile@ core? IF prev @ emptybuf THEN - 5 full? IF save-buffers THEN - 6 offset @ + isfile@ rot fromblock 6 - 2! update ; - 7 | : blkmove ( from to quan --) save-buffers >r - 8 over r@ + over u> >r 2dup u< r> and - 9 IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP -10 ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN -11 save-buffers 2drop ; -12 -13 : copy ( from to --) 1 blkmove ; -14 : convey ( [blk1 blk2] [to.blk --) -15 swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ; diff --git a/sources/cpm/DISASS.FB.src b/sources/cpm/DISASS.FB.src deleted file mode 100644 index 35e816f..0000000 --- a/sources/cpm/DISASS.FB.src +++ /dev/null @@ -1,306 +0,0 @@ -Screen 0 not modified - 0 \\ Z80-Disassembler 08Nov86 - 1 - 2 Dieses File enthaelt einen Z80-Disassembler, der assemblierten - 3 Code in Standard Zilog-Z80 Mnemonics umsetzt. - 4 - 5 Benutzung: - 6 - 7 TOOLS ALSO \ Schalte Disassembler-Vokabular an - 8 - 9 addr DIS \ Disassembliere ab Adresse addr -10 -11 xxxx displace ! \ Beruecksichte bei allen Adressen einen -12 \ Versatz von xxxx. -13 \ Wird gebraucht, wenn ein Assemblerstueck -14 \ nicht an dem Platz disassembliert wird, -15 \ an dem es ablaeuft. -Screen 1 not modified - 0 \ Z80-Disassembler Load Screen 08Nov86 - 1 - 2 Onlyforth Tools also definitions hex - 3 - 4 ' Forth | Alias F: immediate - 5 ' Tools | Alias T: immediate - 6 - 7 1 $10 +THRU cr .( Disassembler geladen. ) cr - 8 - 9 OnlyForth -10 -11 -12 \\ Fragen Anregungen & Kritik an: -13 U. Hoffmann -14 Harmsstrasse 71 -15 2300 Kiel 1 -Screen 2 not modified - 0 \ Speicherzugriff und Ausgabe 07Jul86 - 1 internal - 2 \needs Case: : Case: Create: Does> swap 2* + perform ; - 3 - 4 Variable index Variable address Variable offset - 5 Variable oldoutput - 6 external Variable displace displace off internal - 7 - 8 ' pad Alias str1 ( -- addr ) - 9 : str2 ( -- addr ) str1 $40 + ; -10 -11 : byte ( -- b ) address @ displace @ + c@ ; -12 : word ( -- w ) address @ displace @ + @ ; -13 -14 : .byte ( byte -- ) 0 <# # #s #> type ; -15 : .word ( addr -- ) 0 <# # # # #s #> type ; -Screen 3 not modified - 0 \ neue Bytes lesen Byte-Fraktionen 07Jul86 - 1 - 2 : next-byte output push oldoutput @ output ! - 3 byte .byte space 1 address +! ; - 4 - 5 : next-word next-byte next-byte ; - 6 - 7 : f ( -- b ) byte $40 / ; - 8 : g ( -- b ) byte 8 / 7 and ; - 9 : h ( -- b ) byte 7 and ; -10 : j ( -- b ) g 2/ ; -11 : k ( -- b ) g 1 and ; -12 -13 \\ 76543210 -14 ffggghhh -15 jjk -Screen 4 not modified - 0 \ Select" 08Nov86 - 1 - 2 : scan/ ( limit start -- limit start' ) over swap - 3 DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ; - 4 - 5 : select ( n addr len -- addr' len' ) - 6 bounds rot - 7 0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN - 8 LOOP under scan/ nip over - ; - 9 -10 : (select" ( n -- ) "lit count select type ; -11 -12 : select" ( -- ) compile (select" ," ; immediate -13 -14 : append ( c str -- ) -15 under count + c! dup c@ 1+ swap c! ; -Screen 5 not modified - 0 \ StringOutput 07Jul86 - 1 - 2 Variable $ - 3 - 4 : $emit ( c -- ) $ @ append pause ; - 5 - 6 : $type ( adr len -- ) 0 ?DO count $emit LOOP drop ; - 7 - 8 : $cr ( -- ) $ @ off ; - 9 -10 : $at? ( -- row col ) 0 $ @ c@ ; -11 -12 Output: $output -13 $emit $cr $type noop $cr 2drop $at? ; -14 -15 -Screen 6 not modified - 0 \ Register 07Jul86 - 1 - 2 : reg ( n -- ) dup 5 = IF index @ negate index ! THEN - 3 select" B/C/D/E/H/L/$/A" ; - 4 - 5 : double-reg ( n -- ) select" BC/DE/%/SP" ; - 6 - 7 : double-reg2 ( n -- ) select" BC/DE/%/AF" ; - 8 - 9 : num ( n -- ) select" 0/1/2/3/4/5/6/7" ; -10 -11 : cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ; -12 -13 : arith ( n -- ) -14 select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ; -15 -Screen 7 not modified - 0 \ no-prefix Einteilung der Befehle in Klassen 07Jul86 - 1 - 2 : 00xxx000 - 3 g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN - 4 select" nop/ex AF,AF'/djnz ?/jr ?" ; - 5 - 6 : 00xxx001 - 7 k IF ." add %," j double-reg exit THEN - 8 ." ld " j double-reg ." ,&" ; - 9 -10 : 00xxx010 ." ld " g -11 select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)" -12 ; -13 -14 : 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ; -15 -Screen 8 not modified - 0 \ no-prefix 07Jul86 - 1 - 2 : 00xxx100 ." inc " g reg ; - 3 - 4 : 00xxx101 ." dec " g reg ; - 5 - 6 : 00xxx110 ." ld " g reg ." ,#" ; - 7 - 8 : 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ; - 9 -10 : 01xxxxxx ." ld " g reg ." ," h reg ; -11 -12 : 10xxxxxx g arith h reg ; -13 -14 -15 -Screen 9 not modified - 0 \ no-prefix 07Jul86 - 1 - 2 : 11xxx000 ." ret " g cond ; - 3 - 4 : 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN - 5 ." pop " j double-reg2 ; - 6 - 7 : 11xxx010 ." JP " g cond ." ,&" ; - 8 - 9 : 11xxx011 g -10 select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ; -11 -12 : 11xxx100 ." call " g cond ; -13 : 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ; -14 : 11xxx110 g arith ." #" ; -15 : 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ; -Screen 10 not modified - 0 \ no-prefix 07Jul86 - 1 - 2 Case: 00xxxhhh - 3 00xxx000 00xxx001 00xxx010 00xxx011 - 4 00xxx100 00xxx101 00xxx110 00xxx111 ; - 5 - 6 Case: 11xxxhhh - 7 11xxx000 11xxx001 11xxx010 11xxx011 - 8 11xxx100 11xxx101 11xxx110 11xxx111 ; - 9 -10 : 00xxxxxx h 00xxxhhh ; -11 : 11xxxxxx h 11xxxhhh ; -12 -13 Case: ffxxxxxx -14 00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ; -15 -Screen 11 not modified - 0 \ no-prefix 07Jul86 - 1 - 2 : get-offset index @ 0> IF byte offset ! next-byte THEN ; - 3 - 4 : no-prefix f ffxxxxxx next-byte get-offset ; - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 12 not modified - 0 \ CB-Prefix 07Jul86 - 1 - 2 : CB-00xxxxxx - 3 g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ; - 4 - 5 : CB-01xxxxxx ." bit " g num ." ," h reg ; - 6 - 7 : CB-10xxxxxx ." res " g num ." ," h reg ; - 8 - 9 : CB-11xxxxxx ." set " g num ." ," h reg ; -10 -11 case: singlebit -12 CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ; -13 -14 : CB-prefix get-offset f singlebit next-byte ; -15 -Screen 13 not modified - 0 \ ED-Prefix 30Sep86 - 1 : ED-01xxx000 ." in (C)," g reg ; - 2 : ED-01xxx001 ." out (C)," g reg ; - 3 : ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN - 4 ." HL," j double-reg ; - 5 : ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN - 6 ." (&)," j double-reg ; - 7 : ED-01xxx100 ." neg" ; - 8 : ED-01xxx101 k IF ." reti" exit THEN ." retn" ; - 9 : ED-01xxx110 g select" im 0/-/im 1/im 2" ; -10 : ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ; -11 : ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ; -12 Case: ED-01xxxhhh -13 ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011 -14 ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ; -15 : ED-01xxxxxx h ED-01xxxhhh ; -Screen 14 not modified - 0 \ ED-Prefix 07Jul86 - 1 - 2 Case: extended - 3 noop ED-01xxxxxx ED-10xxxxxx noop ; - 4 - 5 : ED-prefix get-offset f extended next-byte ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ Disassassemblieren eines einzelnen Befehls 30Sep86 - 1 - 2 : index-register ( n -- ) index ! next-byte ; - 3 - 4 : get-instruction ( -- ) - 5 index off str1 $ ! cr - 6 byte $DD = IF 1 index-register ELSE - 7 byte $FD = IF 2 index-register THEN THEN - 8 byte $76 case? IF next-byte ." halt" exit THEN - 9 $CB case? IF next-byte CB-prefix exit THEN -10 $ED case? IF next-byte ED-prefix exit THEN -11 drop no-prefix ; -12 -13 -14 -15 -Screen 16 not modified - 0 \ Adressierungsarten ausgeben 07Jul86 27Nov87 - 1 : .index-register ( -- ) index @ abs select" HL/IX/IY" ; - 2 - 3 : offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ; - 4 : +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ; - 5 - 6 : .offset ( -- ) offset @ offset-sign - 7 extend under dabs <# # #s rot +- #> type ; - 8 : .index-register-offset - 9 index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ; -10 -11 : .inline-byte ( -- ) byte .byte next-byte ; -12 : .inline-word ( -- ) word .word next-word ; -13 -14 : .displace ( -- ) -15 byte offset-sign address @ + 1+ .word next-byte ; -Screen 17 not modified - 0 \ Hauptebene: dis 07Jul86 - 1 : .char ( c -- ) - 2 Ascii % case? IF .index-register exit THEN - 3 Ascii $ case? IF .index-register-offset exit THEN - 4 Ascii # case? IF .inline-byte exit THEN - 5 Ascii & case? IF .inline-word exit THEN - 6 Ascii ? case? IF .displace exit THEN emit ; - 7 - 8 : instruction ( -- ) cr address @ .word 2 spaces - 9 output @ oldoutput ! $output get-instruction -10 str2 $ ! cr str1 count 0 ?DO count .char LOOP drop -11 oldoutput @ output ! $20 col - 0 max spaces str2 count type ; -12 -13 external -14 : dis ( addr -- ) address ! -15 BEGIN instruction stop? UNTIL ; diff --git a/sources/cpm/DOUBLE.FB.src b/sources/cpm/DOUBLE.FB.src deleted file mode 100644 index 5ac4cbe..0000000 --- a/sources/cpm/DOUBLE.FB.src +++ /dev/null @@ -1,51 +0,0 @@ -Screen 0 not modified - 0 \\ Double words 11Nov86 - 1 - 2 Dieses File enthaelt Worte fuer 32-Bit Objekte. - 3 - 4 Im Kern bereits enthalten sind: - 5 - 6 2@ 2! 2dup 2drop 2swap dnegate d+ - 7 - 8 Hier werden definiert: - 9 -10 2Variable 2Constant 2over d* -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ 2over 2@ 2! 2Variable 2Constant UH 30Oct86 - 1 - 2 : 2Variable Variable 2 allot ; - 3 : 2Constant Create , , does> 2@ ; - 4 - 5 Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi - 6 SP dad M D mov H dcx M E mov D push - 7 H dcx M D mov H dcx M E mov D push Next end-code - 8 --> \\ - 9 Code 2@ ( addr -- 32b ) H pop H push -10 H inx H inx M E mov H inx M D mov H pop D push -11 M E mov H inx M D mov D push Next end-code -12 -13 Code 2! ( 32b addr -- ) H pop -14 D pop E M mov H inx D M mov H inx -15 D pop E M mov H inx D M mov Next end-code -Screen 2 not modified - 0 \ d* d- 29Jun86 - 1 - 2 : d* ( d1 d2 -- d1*d2 ) - 3 rot 2over rot um* 2swap um* d+ 2swap um* d+ ; - 4 - 5 : d- ( d1 d2 -- d1-d2 ) dnegate d+ ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/EDITOR.FB.src b/sources/cpm/EDITOR.FB.src deleted file mode 100644 index c47895a..0000000 --- a/sources/cpm/EDITOR.FB.src +++ /dev/null @@ -1,544 +0,0 @@ -Screen 0 not modified - 0 \ Full-Screen Editor UH 02Nov86 - 1 - 2 Dieses File enthaelt den Full-Screen Editor fuer die CP/M - - 3 volksFORTH-Version. - 4 - 5 Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion - 6 sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- - 7 Funktion und des sichtbaren Laden von Screens (showload). - 8 - 9 Durch die integrierte Tastaturtabelle (keytable) laesst sich die -10 Kommandobelegung der Tasten auf einfache Art und Weise aendern. -11 -12 Anregungen, Kritik und Verbesserungsvorschlaege bitte an: -13 U. Hoffmann -14 Harmsstrasse 71 -15 2300 Kiel -Screen 1 not modified - 0 \ Load Screen for the Editor UH 03Nov86 UH 27Nov87 - 1 - 2 Onlyforth cr - 3 - 4 1 $1E +thru - 5 - 6 Onlyforth - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ String primitves 27Nov87 - 1 - 2 : delete ( buffer size count -- ) - 3 over umin dup >r - 2dup over r@ + -rot cmove - 4 + r> bl fill ; - 5 - 6 : insert ( string length buffer size -- ) - 7 rot over umin dup >r - - 8 over dup r@ + rot cmove> r> cmove ; - 9 -10 : replace ( string length buffer size -- ) rot umin cmove ; -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ usefull definitions and Editor vocabulary UH 27Nov87 - 1 - 2 : blank ( addr len -- ) bl fill ; - 3 - 4 : ?enough ( n --) depth 1- > abort" Not enough Parameters" ; - 5 - 6 : ?abort( ( f -- ) - 7 IF [compile] .( true abort" !" THEN [compile] ( ; - 8 - 9 Vocabulary Editor -10 -11 ' Forth | Alias F: immediate -12 ' Editor | Alias E: immediate -13 -14 Editor also definitions -15 -Screen 4 not modified - 0 \ move cursor with position-checking 23Nov86 - 1 - 2 | : c ( n --) \ checks the cursor position - 3 r# @ + dup 0 b/blk uwithin not - 4 Abort" There is a border!" r# ! ; - 5 - 6 \\ - 7 - 8 : c ( n --) \ goes thru the screens - 9 r# @ + dup b/blk 1- > IF 1 scr +! THEN -10 dup 0< IF -1 scr +! THEN b/blk mod r# ! ; -11 -12 : c ( n --) \ moves cyclic thru the screen -13 r# @ + b/blk mod r# ! ; -14 -15 -Screen 5 not modified - 0 \ calculate addresses UH 31Oct86 - 1 - 2 | Code *line ( l -- adr ) - 3 H pop H dad H dad H dad - 4 H dad H dad H dad Hpush jmp end-code - 5 - 6 | Code /line ( n -- c l ) - 7 H pop L A mov $3F ani A E mov 0 D mvi - 8 L A mov ral A L mov H A mov ral A H mov - 9 L A mov ral A L mov H A mov ral A H mov -10 L A mov ral 3 ani H L mov A H mov -11 dpush jmp end-code -12 -13 \\ -14 | : *line ( l -- adr ) c/l * ; -15 | : /line ( n -- c l ) c/l /mod ; -Screen 6 not modified - 0 \ calculate addresses UH 01Nov86 - 1 - 2 | : top ( -- ) r# off ; - 3 | : cursor ( -- n ) r# @ ; - 4 | : 'start ( -- adr ) scr @ block ; - 5 | : 'end ( -- adr ) 'start b/blk + ; - 6 | : 'cursor ( -- adr ) 'start cursor + ; - 7 | : position ( -- c l ) cursor /line ; - 8 | : line# ( -- l ) position nip ; - 9 | : col# ( -- c ) position drop ; -10 | : 'line ( -- adr ) 'start line# *line + ; -11 | : 'line-end ( -- adr ) 'line c/l + 1- ; -12 | : #after ( -- n ) c/l col# - ; -13 | : #remaining ( -- n ) b/blk cursor - ; -14 | : #end ( -- n ) b/blk line# *line - ; -15 -Screen 7 not modified - 0 \ move cursor directed UH 01Nov86 - 1 - 2 | : curup c/l negate c ; - 3 | : curdown c/l c ; - 4 | : curleft -1 c ; - 5 | : curright 1 c ; - 6 - 7 | : +tab \ 1/4 line forth - 8 cursor $10 / 1+ $10 * cursor - c ; - 9 -10 | : -tab \ 1/8 line back -11 cursor 8 mod negate dup 0= 8 * + c ; -12 -13 | : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; -14 | : #after c ; -15 -Screen 8 not modified - 0 \ show border UH 27Nov87 - 1 &15 | Constant dx 1 | Constant dy - 2 - 3 | : horizontal ( row -- row' ) - 4 dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ; - 5 - 6 | : vertical ( row -- row' ) - 7 l/s 0 DO dup dx 1- at Ascii | emit - 8 row dx c/l + at Ascii | emit 1+ LOOP ; - 9 -10 | : border dy 1- horizontal vertical horizontal drop ; -11 -12 | : edit-at ( -- ) position swap dy dx d+ at ; -13 -14 Forth definitions -15 : updated? ( -- f) scr @ block 2- @ 0< ; -Screen 9 not modified - 0 \ display screen UH 02Nov86 UH 27Nouho - 1 Editor definitions | Variable isfile' | Variable imode - 2 - 3 | : .updated ( -- ) 7 0 at - 4 updated? IF 4 spaces ELSE ." not " THEN ." updated" ; - 5 - 6 | : redisplay ( line# -- ) - 7 dup dy + dx at *line 'start + c/l type ; - 8 - 9 | : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ; -10 | : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file -11 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at -12 imode @ IF ." insert " exit THEN ." overwrite" ; -13 -14 | : .screen l/s 0 DO I redisplay LOOP ; -15 | : .all .title .screen ; -Screen 10 not modified - 0 \ check errors UH 02Nov86 - 1 - 2 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip - 3 Abort" You would lose a line" ; - 4 - 5 | : ?fit ( n -- ) 'line c/l -trailing nip + c/l > - 6 IF line# redisplay - 7 true Abort" You would lose a char" THEN ; - 8 - 9 | : ?end 1 ?fit ; -10 -11 -12 -13 -14 -15 -Screen 11 not modified - 0 \ programmer's id UH 02Nov86 - 1 - 2 $12 | Constant id-len - 3 Create id id-len allot id id-len erase - 4 - 5 | : stamp ( -- ) - 6 id 1+ count 'start c/l + over - swap cmove ; - 7 - 8 | : ?stamp ( -- ) updated? IF stamp THEN ; - 9 -10 | : get-id ( -- ) -11 id c@ ?exit id on -12 cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at -13 id id-len 2 /string expect rvsoff span @ id 1+ c! ; -14 -15 -Screen 12 not modified - 0 \ update screen-display UH 02Dec86 - 1 - 2 | : emptybuf prev @ 2+ dup on 4+ off ; - 3 - 4 | : undo emptybuf .all ; - 5 - 6 | : modified updated? ?exit update .updated ; - 7 - 8 | : linemodified modified line# redisplay ; - 9 -10 | : screenmodified modified -11 l/s line# ?DO I redisplay LOOP ; -12 -13 | : .modified ( -- ) dy l/s + 4+ 0 at scr @ . -14 updated? not IF ." un" THEN ." modified" ?stamp ; -15 -Screen 13 not modified - 0 \ leave editor UH 02Dec86 UH 23Feb88 - 1 | Variable (pad (pad off - 2 | : memtop ( -- adr) sp@ $100 - ; - 3 - 4 | Create char 1 allot - 5 - 6 ( | Variable imode ) imode off - 7 | : setimode imode on .title ; - 8 | : clrimode imode off .title ; - 9 | : flipimode ( -- ) imode @ 0= imode ! .title ; -10 -11 | : done ( -- ) -12 ['] (quit is 'quit ['] (error errorhandler ! quit ; -13 -14 | : update-exit ( -- ) .modified done ; -15 | : flushed-exit ( -- ) .modified save-buffers done ; -Screen 14 not modified - 0 \ handle lines UH 01Nov86 - 1 - 2 | : (clear-line 'line c/l blank ; - 3 | : clear-line (clear-line linemodified ; - 4 - 5 | : clear> 'cursor #after blank linemodified ; - 6 - 7 | : delete-line 'line #end c/l delete screenmodified ; - 8 - 9 | : backline curup delete-line ; -10 -11 | : (insert-line -12 ?bottom 'line c/l over #end insert (clear-line ; -13 -14 | : insert-line (insert-line screenmodified ; -15 -Screen 15 not modified - 0 \ handle characters UH 01Nov86 - 1 - 2 | : delete-char 'cursor #after 1 delete linemodified ; - 3 - 4 | : backspace curleft delete-char ; - 5 - 6 | : (insert-char ?end 'cursor 1 over #after insert ; - 7 - 8 - 9 | : insert-char (insert-char bl 'cursor c! linemodified ; -10 -11 | : putchar ( --) char c@ -12 imode @ IF (insert-char THEN -13 'cursor c! linemodified curright ; -14 -15 -Screen 16 not modified - 0 \ stack lines UH 31Oct86 - 1 - 2 | Create lines 4 allot \ { 2+pointer | 2base } - 3 | : 'lines ( -- adr) lines 2@ + ; - 4 - 5 | : @line 'lines memtop u> Abort" line buffer full" - 6 'line 'lines c/l cmove c/l lines +! ; - 7 - 8 | : copyline @line curdown ; - 9 | : line>buf @line delete-line ; -10 -11 | : !line c/l negate lines +! 'lines 'line c/l cmove ; -12 -13 | : buf>line lines @ 0= Abort" line buffer empty" -14 ?bottom (insert-line !line screenmodified ; -15 -Screen 17 not modified - 0 \ stack characters UH 01Nov86 - 1 - 2 | Create chars 4 allot \ { 2+pointer | 2base } - 3 | : 'chars ( -- adr) chars 2@ + ; - 4 - 5 | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" - 6 'cursor c@ 'chars c! 1 chars +! ; - 7 - 8 | : copychar @char curright ; - 9 | : char>buf @char delete-char ; -10 -11 | : !char -1 chars +! 'chars c@ 'cursor c! ; -12 -13 | : buf>char chars @ 0= Abort" char buffer empty" -14 ?end (insert-char !char linemodified ; -15 -Screen 18 not modified - 0 \ switch screens UH 03Nov86 UH 27Nov87 - 1 - 2 | Variable r#' r#' off - 3 | Variable scr' scr' off - 4 ( | Variable isfile' ) isfile@ isfile' ! - 5 - 6 | : associate \ switch to alternate screen - 7 isfile' @ isfile@ isfile' ! isfile ! - 8 scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; - 9 -10 | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ; -11 | : n ?stamp 1 scr +! .all ; -12 | : b ?stamp -1 scr +! .all ; -13 | : a ?stamp associate .all ; -14 -15 -Screen 19 not modified - 0 \ shadow screens UH 03Nov86 - 1 - 2 Variable shadow shadow off - 3 - 4 | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; - 5 - 6 | : >shadow ?stamp \ switch to shadow screen - 7 (shadow dup scr @ u> not IF negate THEN scr +! .all ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 20 not modified - 0 \ load and show screens UH 06Mar88 - 1 - 2 ' name >body &10 + | Constant 'name - 3 - 4 | : showoff ['] exit 'name ! curoff rvsoff ; - 5 - 6 | : show ( -- ) blk @ 0= IF showoff exit THEN - 7 >in @ 1- r# ! curoff edit-at curon - 8 stop? IF showoff true Abort" Break! " THEN - 9 blk @ scr @ - -10 IF blk @ scr ! rvsoff curoff .all rvson curon THEN ; -11 -12 | : showload ( -- ) ?stamp save-buffers -13 ['] show 'name ! curon rvson -14 ['] .status >body push ['] noop is .status -15 scr @ scr push scr off r# push r# @ (load showoff ; -Screen 21 not modified - 0 \ find strings UH 01Nov86 - 1 - 2 | Variable insert-buffer - 3 | Variable find-buffer - 4 | : 'insert ( -- addr ) insert-buffer @ ; - 5 | : 'find ( -- addr ) find-buffer @ ; - 6 - 7 | : .buf ( addr -- ) count type ." |" &80 col - spaces ; - 8 - 9 | : get ( addr -- ) >r at? r@ .buf -10 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN -11 at r> .buf ; -12 -13 | : get-buffers dy l/s + 2+ dx 1- 2dup at -14 ." find: |" 'find get swap 1+ swap 2- at -15 ." ? replace: |" 'insert get ; -Screen 22 not modified - 0 \ search for string UH 02Nov86 UH 27Nov87 - 1 - 2 | : skip ( addr -- addr' ) 'find c@ + ; - 3 - 4 | : find? ( -- addr T | F ) - 5 'find count 'cursor #remaining "search ; - 6 - 7 | : "find ( -- r# scr ) - 8 find? IF skip 'start - scr @ exit THEN ?stamp - 9 capacity scr @ 1+ -10 ?DO 'find count -11 I dup 5 5 at 4 .r block b/blk "search -12 IF skip I block - I endloop exit THEN -13 stop? Abort" Break! " -14 LOOP true Abort" not found!" ; -15 -Screen 23 not modified - 0 \ replace strings UH 03Nov86 UH 27Nov87 - 1 | : replace? ( -- f ) dy l/s + 3+ dx 3 - at - 2 key dup #cr = IF line# redisplay true Abort" Break!" THEN - 3 capital Ascii R = ; - 4 - 5 | : "mark ( -- ) r# push - 6 'find count dup negate c edit-at rvson type rvsoff ; - 7 - 8 | : (replace 'insert c@ 'find c@ - ?fit - 9 'find c@ negate c 'cursor #after 'find c@ delete -10 'insert count 'cursor #after insert -11 'insert c@ c modified ; -12 -13 | : "replace get-buffers -14 BEGIN "find dup scr @ - swap scr ! IF .all THEN r# ! -15 "mark replace? IF (replace THEN line# redisplay REPEAT ; -Screen 24 not modified - 0 \ Control-Characters 'normal' CP/M uho 08May2005 - 1 - 2 Forth definitions - 3 - 4 : Ctrl ( -- c ) - 5 name 1+ c@ $1F and state @ IF [compile] Literal THEN ; - 6 immediate - 7 - 8 $7F Constant #del - 9 -10 Editor definitions -11 -12 \ | : flipimode imode @ 0= imode ! ; -13 -14 -15 -Screen 25 not modified - 0 \ Try a Screen-Editor 'normal' CP/M UH 29Nov86 - 1 - 2 Create keytable - 3 Ctrl E c, Ctrl S c, Ctrl X c, Ctrl D c, - 4 Ctrl I c, Ctrl J c, Ctrl O c, Ctrl K c, - 5 Ctrl P c, Ctrl L c, - 6 Ctrl H c, Ctrl H c, #del c, Ctrl G c, - 7 Ctrl T c, Ctrl Y c, Ctrl N c, - 8 Ctrl V c, Ctrl Z c, - 9 #cr c, Ctrl F c, Ctrl A c, -10 Ctrl \ c, Ctrl U c, -11 Ctrl Q c, #esc c, Ctrl W c, -12 Ctrl C c, Ctrl R c, Ctrl ] c, Ctrl B c, -13 -14 -15 here keytable - Constant #keys -Screen 26 not modified - 0 \ Try a screen Editor UH 29Nov86 - 1 - 2 Create: actiontable - 3 curup curleft curdown curright - 4 line>buf char>buf buf>line buf>char - 5 copyline copychar - 6 backspace backspace backspace delete-char - 7 insert-char delete-line insert-line - 8 flipimode ( clear-line ) clear> - 9 +tab -tab -10 ( top >""end ) "replace undo -11 update-exit flushed-exit ( showload ) >shadow -12 n b a mark ; -13 -14 -15 here actiontable - 2/ 1- #keys - ?abort( # of actions) -Screen 27 not modified - 0 \ find keys UH 01Nov86 - 1 - 2 | Code findkey ( key -- addr/default ) - 3 H pop L A mov keytable H lxi #keys $100 * D lxi - 4 [[ M cmp 0= - 5 ?[ actiontable H lxi 0 D mvi D dad D dad - 6 M E mov H inx M D mov D push next ]? - 7 H inx E inr D dcr 0= ?] - 8 ' putchar H lxi hpush jmp - 9 end-code -10 -11 \\ -12 | : findkey ( key -- adr/default ) -13 #keys 0 DO dup keytable F: I + c@ = -14 IF drop E: actiontable F: I 2* + @ endloop exit THEN -15 LOOP drop ['] putchar ; -Screen 28 not modified - 0 \ allocate buffers UH 01Nov86 - 1 - 2 c/l 2* | Constant cstack-size - 3 - 4 | : nextbuf ( adr -- adr' ) cstack-size + ; - 5 - 6 | : ?clearbuffer pad (pad @ = ?exit - 7 pad dup (pad ! - 8 nextbuf dup find-buffer ! 'find off - 9 nextbuf dup insert-buffer ! 'insert off -10 nextbuf dup 0 chars 2! -11 nextbuf 0 lines 2! ; -12 -13 -14 -15 -Screen 29 not modified - 0 \ enter and exit the editor, editor's loop UH 02Nov86 - 1 | Variable jingle jingle on | : bell 07 con! jingle off ; - 2 - 3 | : clear-error - 4 jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; - 5 - 6 | : fullquit BEGIN ?clearbuffer edit-at key dup char c! - 7 findkey execute clear-error REPEAT ; - 8 - 9 | : fullerror ( string --) jingle @ IF bell THEN -10 dy l/s + 1+ dx $16 + at rvson count type rvsoff -11 &80 col - spaces scr @ capacity 1- min 0 max scr ! -12 .title quit ; -13 -14 | : install ( -- ) -15 ['] fullquit Is 'quit ['] fullerror errorhandler ! ; -Screen 30 not modified - 0 \ enter and exit the Editor UH 02Nov86 - 1 - 2 Forth definitions - 3 - 4 : v ( -- ) E: 'start drop get-id install ?clearbuffer - 5 page curoff border .all quit ; - 6 - 7 : l ( scr -- ) 1 ?enough scr ! E: top F: v ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 31 not modified - 0 \ savesystem uho 09May2uho - 1 - 2 : savesystem \ save image - 3 E: id off (pad off savesystem ; - 4 - 5 | : >find ?clearbuffer >in push - 6 bl word count 'find 1+ place - 7 bl 'find 1+ dup >r count dup >r + c! - 8 r> 2+ 'find c! bl r> c! ; - 9 | : %view ( -- ) >find ' >name 4- @ (view -10 ?dup 0= Abort" hand made" scr ! -11 E: top curdown find? 0= -12 IF ." From Scr # " scr @ u. true Abort" wrong file" THEN -13 skip 'start - 1- r# ! ; -14 : view ( -- ) %view scr @ list ; -15 : fix ( -- ) %view v ; diff --git a/sources/cpm/FILEINT.FB.src b/sources/cpm/FILEINT.FB.src deleted file mode 100644 index ea7b4c5..0000000 --- a/sources/cpm/FILEINT.FB.src +++ /dev/null @@ -1,544 +0,0 @@ -Screen 0 not modified - 0 \ CP/M 2.2 File-Interface (3.80a) UH 05Oct87 - 1 - 2 Dieses File enthaelt das File-Interface von volksFORTH zu CP/M. - 3 Damit ist Zugriff auf normale CP/M-Files moeglich. - 4 Wenn ein File mit USE benutzt wird, beziehen sich alle Worte, - 5 die mit dem Massenspeicher arbeiten, auf dieses File. - 6 - 7 Benutzung: - 8 USE \ benutze ein schon existierendes File - 9 FILE \ erzeuge ein Forthfile mit dem Namen . -10 MAKE \ Erzeuge ein File mit und ordne -11 \ es dem aktuellen Forthfile zu. -12 MAKEFILE \ Erzeuge ein File mit CP/M und FORTH-Namen -13 . -14 INCLUDE \ Lade File mit Forthnamen ab Screen 1 -15 DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M) -Screen 1 not modified - 0 \ CP/M 2.2 File-Interface load-Screen UH 18Feb88 - 1 OnlyForth - 2 - 3 2 load \ view numbers for this file - 4 3 4 thru \ DOS File Functions - 5 5 $11 thru \ Forth File Functions - 6 $12 $16 thru \ User Interface - 7 - 8 File source.fb \ Define already existing Files - 9 File fileint.fb File startup.fbr -10 -11 ' (makeview Is makeview -12 ' remove-files Is custom-remove -13 ' file-r/w Is r/w -14 ' noop Is drvinit -15 \ include startup.fb \ load Standard System -Screen 2 not modified - 0 \ Build correct view-numbers for this file UUH 19Nov87 - 1 - 2 | : fileintview ( -- ) $400 blk @ + ; - 3 - 4 ' fileintview Is makeview - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ File Control Blocks UH 18Feb88 - 1 Dos definitions also - 2 | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ; - 3 &11 Constant filenamelen - 4 0 2 | Fcbyte nextfile immediate - 5 1 Fcbyte drive ' drive | Alias >dosfcb - 6 filenamelen 3 - Fcbyte filename - 7 3 Fcbyte extension - 8 &21 + \ ex, s1, s2, rc, d0, ... dn, cr - 9 2 Fcbyte record \ r0, r1 -10 1+ \ r2 -11 2 Fcbyte opened -12 2 Fcbyte fileno -13 2 Fcbyte filesize \ in 128-Byte-Records -14 4 Fcbyte position -15 Constant b/fcb -Screen 4 not modified - 0 \ dos primitives UH 10Oct87 - 1 - 2 ' 2- | Alias body> ' 2- | Alias dosfcb> - 3 - 4 : drive! ( drv -- ) $0E bdos ; - 5 : search0 ( dosfcb -- dir ) $11 bdosa ; - 6 : searchnext ( dosfcb -- dir ) $12 bdosa ; - 7 : read-seq ( dosfcb -- f ) $14 bdosa dos-error? ; - 8 : write-seq ( dosfcb -- f ) $15 bdosa dos-error? ; - 9 : createfile ( dosfcb -- f ) $16 bdosa dos-error? ; -10 : size ( dos -- size ) dup $23 bdos dosfcb> record @ ; -11 : drive@ ( -- drv ) 0 $19 bdosa ; -12 : killfile ( dosfcb -- ) $13 bdos ; -13 -14 -15 -Screen 5 not modified - 0 \ File sizes UH 05Oct87 - 1 - 2 : (capacity ( fcb -- n ) \ filecapacity in blocks - 3 filesize @ rec/blk u/mod swap 0= ?exit 1+ ; - 4 - 5 : in-range ( block fcb -- ) - 6 (capacity u< not Abort" beyond capacity!" ; - 7 - 8 Forth definitions - 9 -10 : capacity ( -- n ) isfile@ (capacity ; -11 -12 Dos definitions -13 -14 -15 -Screen 6 not modified - 0 \ (open UH 18Feb88 - 1 - 2 : (open ( fcb -- ) - 3 dup opened @ IF drop exit THEN dup position 0. rot 2! - 4 dup >dosfcb openfile Abort" not found!" dup opened on - 5 dup >dosfcb size swap filesize ! ; - 6 - 7 : (make ( fcb -- ) - 8 dup >dosfcb killfile - 9 dup >dosfcb createfile Abort" directory full!" -10 dup position 0. rot 2! -11 dup filesize off opened on offset off ; -12 -13 : file-r/w ( buffer block fcb f -- f ) -14 over 0= Abort" no Direct Disk IO supported! " -15 >r dup (open 2dup in-range r> (r/w ; -Screen 7 not modified - 0 \ Print Filenames UH 10Oct87 - 1 - 2 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN - 3 fcb dosfcb> case? IF ." DEFAULT" exit THEN - 4 body> >name .name ; - 5 - 6 : .drive ( fcb -- ) drive c@ ?dup 0=exit - 7 [ Ascii A 1- ] Literal + emit Ascii : emit ; - 8 - 9 : .dosfile ( fcb -- ) dup filename 8 -trailing type -10 Ascii . emit extension 3 type ; -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ Print Filenames UH 10Oct87 - 1 - 2 : tab ( -- ) col &59 > IF cr exit THEN - 3 &20 col &20 mod - 0 max spaces ; - 4 - 5 : .fcb ( fcb -- ) dup fileno @ 3 u.r tab - 6 dup .file tab dup .drive dup .dosfile - 7 tab dup opened @ IF ." opened" ELSE ." closed" THEN - 8 3 spaces base push decimal (capacity 3 u.r ." kB" ; - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ Filenames UH 05Oct87 - 1 - 2 : !name ( addr len fcb -- ) - 3 dup >r filename filenamelen bl fill - 4 over 1+ c@ Ascii : = - 5 IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r> - 6 ELSE 0 THEN r@ drive c! r> dup filename 2swap - 7 filenamelen 1+ min bounds - 8 ?DO I c@ Ascii . = - 9 IF drop dup extension ELSE I c@ over c! 1+ THEN -10 LOOP 2drop ; -11 -12 : !fcb ( fcb -- ) dup opened off name count rot !name ; -13 -14 -15 -Screen 10 not modified - 0 \ Print Directory UH 18Nov87 - 1 - 2 | Create dirbuf b/rec allot dirbuf b/rec erase - 3 | Create fcb0 b/fcb allot fcb0 b/fcb erase - 4 - 5 | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ; - 6 | : (expand ( addr len -- ) false -rot bounds - 7 ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ; - 8 | : expand ( fcb -- ) \ expand * to ??? - 9 dup filename 8 (expand extension 3 (expand ; -10 -11 : (dir ( addr len -- ) -12 fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0 -13 BEGIN dup dos-error? not -14 WHILE $20 * dirbuf + dosfcb> tab .dosfile -15 fcb0 >dosfcb searchnext stop? UNTIL drop ; -Screen 11 not modified - 0 \ File List UH 10Oct87 - 1 - 2 User file-link file-link off - 3 - 4 | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ; - 5 - 6 - 7 Forth definitions - 8 - 9 : forthfiles ( -- ) -10 file-link @ -11 BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ; -12 -13 Dos definitions -14 -15 -Screen 12 not modified - 0 \ Close a file UH 10Oct87 - 1 - 2 ' save-buffers >body $0C + @ | Alias backup - 3 - 4 | : filebuffer? ( fcb -- fcb bufaddr/flag ) - 5 prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; - 6 - 7 | : flushfile ( fcb -- ) \ flush file buffers - 8 BEGIN filebuffer? ?dup WHILE - 9 dup backup emptybuf REPEAT drop ; -10 -11 : (close ( fcb -- ) \ close file in fcb -12 dup flushfile -13 dup opened dup @ 0= IF 2drop exit THEN off -14 >dosfcb closefile Abort" not found!" ; -15 -Screen 13 not modified - 0 \ Create fcbs UH 10Oct87 - 1 - 2 : !files ( fcb -- ) dup isfile ! fromfile ! ; - 3 - 4 ' r@ | Alias newfcb - 5 - 6 Forth definitions - 7 - 8 : File ( -- ) - 9 Create here >r b/fcb allot newfcb b/fcb erase -10 last @ count $1F and newfcb !name -11 #file newfcb fileno ! -12 file-link @ newfcb nextfile ! r> file-link ! -13 Does> !files ; -14 -15 : direct 0 !files ; -Screen 14 not modified - 0 \ flush buffers & misc. UH 10Oct87 UH 28Nov87 - 1 Dos definitions - 2 - 3 : save-files ( -- ) file-link BEGIN @ ?dup WHILE - 4 dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ; - 5 - 6 ' save-files Is save-dos-buffers - 7 - 8 \ : close-files ( -- ) file-link - 9 \ BEGIN @ ?dup WHILE dup (close REPEAT ; -10 -11 Forth definitions -12 -13 : file? isfile@ .file ; \ print current file -14 -15 : list ( n -- ) 3 spaces file? list ; -Screen 15 not modified - 0 \ words for viewing UH 10Oct87 - 1 - 2 Forth definitions - 3 - 4 | $200 Constant viewoffset \ max. %512 kB files - 5 - 6 : (makeview ( -- n ) \ calc. view filed for a name - 7 blk @ dup 0= ?exit - 8 loadfile @ ?dup IF fileno @ viewoffset * + THEN ; - 9 -10 : (view ( blk -- blk' ) \ select file and leave block -11 dup 0=exit -12 viewoffset u/mod file-link -13 BEGIN @ dup WHILE 2dup fileno @ = UNTIL -14 !files drop ; \ not found: direct access -15 -Screen 16 not modified - 0 \ FORGETing files UH 10Oct87 - 1 - 2 | : remove? ( dic symb addr -- dic symb addr f ) - 3 dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; - 4 - 5 - 6 | : remove-files ( dic symb -- dic symb ) \ flush files ! - 7 isfile@ remove? nip IF direct THEN - 8 fromfile @ remove? nip IF fromfile off THEN - 9 file-link -10 BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT -11 file-link remove ; -12 -13 -14 -15 -Screen 17 not modified - 0 \ print a list of all buffers UH 20Oct86 - 1 - 2 : .buffers - 3 prev BEGIN @ ?dup WHILE stop? abort" stopped" - 4 cr dup u. dup 2+ @ dup 1+ - 5 IF ." Block: " over 4+ @ 5 .r - 6 ." File : " [ Dos ] .file - 7 dup 6 + @ 0< IF ." updated" THEN - 8 ELSE ." Buffer empty" drop THEN REPEAT ; - 9 -10 -11 -12 -13 -14 -15 -Screen 18 not modified - 0 \ File Interface User words UH 11Oct87 - 1 - 2 | : same ( addr -- ) >in ! ; - 3 : open isfile@ (open offset off ; - 4 : close isfile@ (close ; - 5 : assign close isfile@ !fcb open ; - 6 : make isfile@ dup !fcb (make ; - 7 - 8 | : isfile? ( addr -- addr f ) \ is adr a fcb? - 9 file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ; -10 -11 : use >in @ name find \ create a fcb if not present -12 IF isfile? IF execute drop exit THEN THEN drop -13 dup same File same ' execute open ; -14 -15 -Screen 19 not modified - 0 \ File Interface User words UH 25May88 - 1 - 2 : makefile >in @ File dup same ' execute same make ; - 3 : emptyfile isfile@ >dosfcb createfile ; - 4 - 5 : from isfile push use ; - 6 : loadfrom ( n -- ) - 7 isfile push fromfile push use load close ; - 8 : include 1 loadfrom ; - 9 -10 : eof ( -- f ) isfile@ dup filesize @ swap record @ = ; -11 -12 : files " *.*" count (dir ; -13 : files" Ascii " word count 2dup upper (dir ; -14 -15 ' files Alias dir ' files" Alias dir" -Screen 20 not modified - 0 \ extend Files UH 20Nov87 - 1 - 2 | : >fileend isfile@ >dosfcb size drop ; - 3 - 4 | : addblock ( n -- ) \ add block n to file - 5 dup buffer under b/blk bl fill - 6 isfile@ rec/blk over filesize +! false file-r/w - 7 IF close Abort" disk full!" THEN ; - 8 - 9 : more ( n -- ) open >fileend -10 capacity swap bounds ?DO I addblock LOOP close -11 open close ; -12 -13 : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ; -14 0 Drive: a: Drive: b: Drive: c: Drive: d: -15 5 + Drive: j: drop -Screen 21 not modified - 0 \ save memory-image as disk-file UH 29Nov86 - 1 - 2 Forth definitions - 3 - 4 : savefile ( from count -- ) \ filename - 5 isfile push makefile bounds - 6 ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!" - 7 b/rec +LOOP close ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 \ Status UH 10OCt87 - 1 - 2 - 3 : .blk ( -- ) blk @ ?dup 0=exit - 4 dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ; - 5 - 6 ' .blk Is .status - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 23 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 25 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 26 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 27 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 28 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 29 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 30 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 31 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/HASHCASH.FB.src b/sources/cpm/HASHCASH.FB.src deleted file mode 100644 index 6711e24..0000000 --- a/sources/cpm/HASHCASH.FB.src +++ /dev/null @@ -1,85 +0,0 @@ -Screen 0 not modified - 0 \ HashCash Suchalgorithmus UH 11Nov86 - 1 - 2 Ein Algorithmus, der die Dictionarysuche beschleunigt: - 3 Zuerst wird uebr das gesucht Wort gehasht und in in einer - 4 Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normal - 5 gesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchen - 6 herunter. - 7 - 8 Hinzu kommen die Worte: - 9 cash, hash-thread, erase-cash, 'cash, und found? -10 -11 Im Kernal neudefiniert oder gepatched werden muessen: -12 (find, hide, reveal, forget-words -13 -14 (find und (forget benutzen jejweils die alten Worte. Sie muessen -15 umbenannt oder in die neuen Worte eingebettet werden. -Screen 1 not modified - 0 \ Hash Cash fuer volksFORTH UH 11Nov86 - 1 - 2 Create cash $200 allot - 3 - 4 ' Forth >body Constant hash-thread - 5 : erase-cash ( -- ) cash $200 erase ; erase-cash - 6 - 7 1 3 +thru - 8 - 9 patch (find -10 ( patch forget-words ) ' forget-words \ forget-words -11 dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen -12 dup ' (forget >body $12 + ! \ Adresse, sodass das automa- -13 dup ' empty >body 8 + ! \ tische Patchen nicht klappt. -14 ' save >body 4+ ! -15 patch hide patch reveal forget (patch save -Screen 2 not modified - 0 \ 'cash found? hfind UH 23Oct86 - 1 - 2 : 'cash ( nfa -- 'cash ) - 3 count $1F and under bounds - 4 ?DO I c@ + LOOP $FF and 2* cash + ; - 5 - 6 : found? ( str nfa -- f ) - 7 count rot count rot over = IF swap -text 0= exit THEN - 8 drop 2drop false ; - 9 -10 : (find ( str thread -- str false | nfa true ) -11 dup hash-thread - IF (find exit THEN -12 drop dup 'cash @ 2dup found? IF nip true exit THEN -13 drop hash-thread (find dup 0= ?exit over dup 'cash ! ; -14 -15 -Screen 3 not modified - 0 \ Kernal changes UH 23Oct86 - 1 - 2 ' hide >body @ | Alias last? - 3 - 4 : hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ; - 5 - 6 : reveal last? IF dup dup 'cash ! 2- current @ ! THEN ; - 7 - 8 ' clear >body 6 + @ | Alias forget-words - 9 -10 | : forget-words erase-cash forget-words ; -11 -12 : .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ; -13 -14 -15 -Screen 4 not modified - 0 \ patching UH 23Oct86 - 1 - 2 : (patch ( new old -- ) - 3 ['] cash 0 DO - 4 i @ over = IF cr I u. over I ! THEN LOOP 2drop ; - 5 - 6 : patch \ name - 7 >in @ ' swap >in ! dup >name 2- context push context ! ' - 8 (patch ; - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/INSTALL.FB.src b/sources/cpm/INSTALL.FB.src deleted file mode 100644 index 2336603..0000000 --- a/sources/cpm/INSTALL.FB.src +++ /dev/null @@ -1,85 +0,0 @@ -Screen 0 not modified - 0 \\ Install Editor - 1 - 2 Dieses File enthaelt einen Installer fuer den Editor. - 3 - 4 Es werden nacheinander die Tasten erfragt, die einen bestimmten - 5 Befehl ausloesen sollen. - 6 - 7 Damit ist es moeglich, die Tastatur an die individuellen - 8 Beduerfnisse anzupassen. - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ install Editor UH 17Nov86 - 1 - 2 Onlyforth Editor also save warning on - 3 - 4 : tab &20 col &20 mod - spaces ; - 5 : .key ( c -- ) - 6 dup $7E > IF ." $" u. exit THEN - 7 dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; - 8 - 9 : install \ install editor's keyboard -10 page ." Entsprechende Tasten druecken. (Blank uebernimmt.)" -11 #keys 0 ?DO cr I 2* actiontable + @ >name .name -12 tab ." : " I keytable + dup c@ .key tab ." -> " -13 key dup bl = IF drop dup c@ THEN dup .key swap c! -14 LOOP ; -15 --> -Screen 2 not modified - 0 \ define action-names UH 29Nov86 - 1 : :a ( addr -- adr' ) dup @ Alias 2+ ; - 2 actiontable - 3 :a up :a left :a down :a right - 4 :a push-line :a push-char :a pull-line :a pull-char - 5 :a copy-line :a copy-char - 6 :a backspace :a backspace :a backspace :a delete-char - 7 :a insert-char :a delete-line :a insert-line - 8 :a flipimode ( :a erase-line) :a clear-to-right - 9 :a new-line :a +tab :a -tab -10 ( :a home :a to-end ) :a search :a undo -11 :a update-exit :a flushed-exit ( :a showload ):a shadow-screen -12 :a next-Screen :a back-Screen :a alter-Screen :a mark-screen -13 drop -14 -15 warning off install empty -Screen 3 not modified - 0 UH 17Nov86 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/PORT8080.FB.src b/sources/cpm/PORT8080.FB.src deleted file mode 100644 index b4001bd..0000000 --- a/sources/cpm/PORT8080.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \ 8080-Portzugriff UH 11Nov86 - 1 - 2 Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit - 3 Adressen anzusprechen. - 4 - 5 Der Code ist leider selbstmodifizierend, da beim 8080 die - 6 Portadresse im Code ausdruecklich angegeben werden muss. - 7 - 8 Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen, - 9 kann auch das File portz80.scr benutzt werden, indem die -10 Z80-IO-Befehle (16Bit-Adressen) benutzt werden. -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ 8080-Portzugriff pc@, pc! 15Jul86 - 1 - 2 ' 0 | Alias patch - 3 - 4 Code pc@ ( addr -- c ) - 5 H pop L A mov here 4 + sta patch in - 6 0 H mvi A L mov Hpush jmp end-code - 7 - 8 Code pc! ( c addr -- ) - 9 H pop L A Mov here 6 + sta H pop L A mov patch out -10 Next end-code -11 -12 -13 -14 -15 diff --git a/sources/cpm/PORTZ80.FB.src b/sources/cpm/PORTZ80.FB.src deleted file mode 100644 index a867dfa..0000000 --- a/sources/cpm/PORTZ80.FB.src +++ /dev/null @@ -1,51 +0,0 @@ -Screen 0 not modified - 0 \ Z80-Portzugriff UH 05Nov86 - 1 - 2 Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit - 3 Adressen anzusprechen. - 4 - 5 Einige Komputer, so die der Schneider Serie dekodieren ihre - 6 Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit - 7 Adressen angesprochen werden muessen. - 8 Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen. - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Z80-Portaccess Extending 8080-Assembler UH 05Nov86 - 1 - 2 Assembler definitions - 3 - 4 | : Z80-io ( base -- ) \ define special Z80-io instruction - 5 Create c, - 6 Does> ( reg -- ) $ED c, c@ swap 8 * + c, ; - 7 - 8 $40 Z80-io (c)in - 9 $41 Z80-io (c)out -10 -11 Forth definitions -12 -13 --> -14 -15 -Screen 2 not modified - 0 \ store and fetch values with 16-bit port-adresses UH 05Nov86 - 1 - 2 Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr - 3 H pop IP push H B mvx L (c)in 0 H mvi - 4 IP pop hpush jmp - 5 end-code - 6 - 7 Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr - 8 H pop D pop IP push H B mvx E (c)out - 9 IP pop Next -10 end-code -11 -12 -13 -14 -15 diff --git a/sources/cpm/PRIMED.FB.src b/sources/cpm/PRIMED.FB.src deleted file mode 100644 index 5406b4a..0000000 --- a/sources/cpm/PRIMED.FB.src +++ /dev/null @@ -1,51 +0,0 @@ -Screen 0 not modified - 0 \\ Primitivst Editor zur Installation UH 17Nov86 - 1 - 2 Da zur Installationszeit der Full-Screen Editor noch nicht - 3 funtionsfaehig ist, muessen die zu aendernden Screens auf eine - 4 andere Weise ge{nder werden: mit dem primitivst Editor PRIMED, - 5 der nur ein Benutzer wort enthaelt: - 6 - 7 Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen, - 8 dann mit "ll NEW" den Screen aendern. Es koennen immer nur - 9 ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher -10 Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe -11 einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW. -12 Nach jeder Eingabe von RETURN wird die eingegebene Zeile in -13 den Screen uebernommen, und der ganze Screen zur Kontrolle -14 nocheinmal ausgegeben. -15 -Screen 1 not modified - 0 \ primitivst Editor PRIMED UH 17Nov86 - 1 - 2 | : !line ( adr count line# -- ) - 3 scr @ block swap c/l * + dup c/l bl fill - 4 swap cmove update ; - 5 - 6 : new ( n -- ) - 7 l/s 1+ swap - 8 ?DO cr I . - 9 pad c/l expect span @ 0= IF leave THEN -10 pad span @ I !line cr scr @ list LOOP ; -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ PRIMED Demo-Screen - 1 - 2 - 3 - 4 Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender - 5 Eingabe dieses Textes - 6 Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new - 7 durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit - 8 "0 NEW" erzeugt. - 9 Ulrich Hoffmann -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/PRINTER.FB.src b/sources/cpm/PRINTER.FB.src deleted file mode 100644 index cc948d3..0000000 --- a/sources/cpm/PRINTER.FB.src +++ /dev/null @@ -1,272 +0,0 @@ -Screen 0 not modified - 0 \\ Printer Interface 08Nov86 - 1 - 2 Dieses File enthaelt das Printer Interface zwischen volksFORTH - 3 und dem Drucker. - 4 - 5 Damit ist es moeglich Source-Texte auf bequeme Art und Weise - 6 in uebersichtlicher Form auszudrucken (6 auf eine Seite). - 7 - 8 In Verbindung mit dem Multitasker ist es moeglich, auch Texte im - 9 Hintergrund drucken zu lassen und trotztdem weiterzuarbeiten. -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Printer Interface Epson RX80 18Aug86 - 1 \ angepasst auf M 130i 07dec85we - 2 - 3 Onlyforth - 4 - 5 Variable shadow capacity 2/ shadow ! \ s. Editor - 6 - 7 Vocabulary Printer Printer definitions also - 8 | Variable printsem printsem off - 9 -10 01 +load 04 0C +thru \ M 130i - Printer -11 \ 01 03 +thru 06 0C +thru \ Fujitsu - Printer -12 -13 Onlyforth -14 -15 -Screen 2 not modified - 0 \ Printer p! and controls UH 02Nov87 - 1 - 2 | : ready? ( -- f ) [ Dos ] 0 &15 biosa 0= not ; - 3 - 4 : p! ( n --) BEGIN pause - 5 stop? IF printsem unlock true abort" stopped! " THEN - 6 ready? UNTIL [ Dos ] 5 bios ; - 7 - 8 | : ctrl: ( 8b --) Create c, Does> ( --) c@ p! ; - 9 -10 07 ctrl: BEL 7F | ctrl: DEL 0D | ctrl: RET -11 1B | ctrl: ESC 0A ctrl: LF 0C ctrl: FF -12 0F | ctrl: (+17cpi 12 | ctrl: (-17cpi -13 -14 -15 -Screen 3 not modified - 0 \ Printer Escapes 24dec85 - 1 - 2 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; - 3 - 4 Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" - 5 Ascii 2 esc: 1/6" Ascii T esc: suoff - 6 Ascii N esc: +jump Ascii O esc: -jump - 7 Ascii G esc: +dark Ascii H esc: -dark - 8 \ Ascii 4 esc: +cursive Ascii 5 esc: -cursive - 9 -10 -11 | : ESC2 ( 8b0 8b1 --) ESC p! p! ; -12 -13 | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; -14 | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; -15 -Screen 4 not modified - 0 \ Printer Escapes 29jan86 - 1 - 2 Ascii W on: +wide Ascii W off: -wide - 3 Ascii - on: +under Ascii - off: -under - 4 Ascii S on: sub Ascii S off: super - 5 Ascii P on: (10cpi Ascii P off: (12cpi - 6 - 7 : 10cpi (-17cpi (10cpi ; - 8 : 12cpi (-17cpi (12cpi ; - 9 : 17cpi (10cpi (+17cpi ; -10 -11 : lines ( #.of.lines --) Ascii C ESC2 ; -12 : "long ( inches --) 0 lines p! ; -13 : american 0 Ascii R ESC2 ; -14 : german 2 Ascii R ESC2 ; -15 : normal 12cpi american suoff 1/6" 0C "long RET ; -Screen 5 not modified - 0 \ Printer Escapes 16Jul86 - 1 - 2 | : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; - 3 - 4 Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" - 5 Ascii 2 esc: 1/6" Ascii T esc: suoff - 6 Ascii N esc: +jump Ascii O esc: -jump - 7 Ascii G esc: +dark Ascii H esc: -dark - 8 Ascii 4 esc: +cursive Ascii 5 esc: -cursive - 9 Ascii M esc: 12cpi Ascii P | esc: (-12cpi -10 -11 : 10cpi (-12cpi (-17cpi ; -12 : 17cpi (-12cpi (+17cpi ; -13 -14 ' 10cpi Alias pica ' 12cpi Alias elite -15 -Screen 6 not modified - 0 \ Printer Escapes 16Jul86 - 1 - 2 | : ESC2 ( 8b0 8b1 --) ESC p! p! ; - 3 - 4 | : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; - 5 | : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; - 6 - 7 Ascii W on: +wide Ascii W off: -wide - 8 Ascii - on: +under Ascii - off: -under - 9 Ascii S on: sub Ascii S off: super -10 Ascii p on: +prop Ascii p off: -prop -11 : lines ( #.of.lines --) Ascii C ESC2 ; -12 : "long ( inches --) 0 lines p! ; -13 : american 0 Ascii R ESC2 ; -14 : german 2 Ascii R ESC2 ; -15 : normal 12cpi american suoff 1/6" 0C "long RET ; -Screen 7 not modified - 0 \ Printer Output 04Jul86 - 1 - 2 : prinit ; \ initializing Printer - 3 - 4 | Variable pcol pcol off | Variable prow prow off - 5 | : pemit ( 8b --) p! 1 pcol +! ; - 6 | : pcr ( --) RET LF 1 prow +! pcol off ; - 7 | : pdel ( --) DEL pcol @ 1- 0 max pcol ! ; - 8 | : ppage ( --) FF prow off pcol off ; - 9 | : pat ( row col --) over prow @ < IF ppage THEN -10 swap prow @ - 0 ?DO pcr LOOP -11 dup pcol @ < IF RET pcol off THEN pcol @ - spaces ; -12 | : pat? ( -- row col) prow @ pcol @ ; -13 | : ptype ( adr len --) -14 dup pcol +! bounds ?DO I c@ p! LOOP ; -15 -Screen 8 not modified - 0 \ Printer output 28Jun86 - 1 - 2 | Output: >printer pemit pcr ptype pdel ppage pat pat? ; - 3 - 4 Forth definitions - 5 - 6 : print >printer normal ; - 7 - 8 : printable? ( char -- f) bl Ascii ~ uwithin ; - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ Variables and Setup 23Oct86 - 1 - 2 Printer definitions - 3 - 4 $00 | Constant logo | Variable pageno - 5 | Create scr#s $0E allot \ enough room for 6 screens - 6 - 7 | : header ( -- ) - 8 12cpi 4 spaces ." Page No " +dark pageno @ 2 .r - 9 $0D spaces ." volksFORTH83 der FORTH-Gesellschaft eV " -10 5 spaces file? -dark 1 pageno +! 17cpi ; -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ Print 2 screens across on a page 03dec85 - 1 - 2 | : text? ( scr# -- f) block dup c@ printable? - 3 IF b/blk -trailing nip 0= THEN 0= ; - 4 - 5 | : pr ( scr# --) dup capacity 1- u> IF drop logo THEN - 6 1 scr#s +! scr#s dup @ 2* + ! ; - 7 - 8 | : 2pr ( scr#1 scr#2 line# --) cr dup 2 .r space c/l * >r - 9 pad $101 bl fill swap block r@ + pad c/l cmove -10 block r> + pad c/l + 1+ c/l cmove pad $101 -trailing type ; -11 -12 | : 2scr ( scr#1 scr#2 --) cr cr $1E spaces -13 +wide +dark over 4 .r $1C spaces dup 4 .r -wide -dark -14 cr l/s 0 DO 2dup I 2pr LOOP 2drop ; -15 -Screen 11 not modified - 0 \ Printer 6 screens on a page 03dec85 - 1 - 2 | : pr-start ( --) scr#s off 1 pageno ! ; - 3 - 4 | : pagepr ( --) header scr#s off scr#s 2+ - 5 3 0 DO dup @ over 6 + @ 2scr 2+ LOOP drop page ; - 6 - 7 | : shadowpr ( --) header scr#s off scr#s 2+ - 8 3 0 DO dup @ over 2+ @ 2scr 4 + LOOP drop page ; - 9 -10 | : pr-flush ( -- f) scr#s @ dup \ any screens left over? -11 IF BEGIN scr#s @ 5 < WHILE -1 pr REPEAT logo pr THEN -12 0<> ; -13 -14 -15 -Screen 12 not modified - 0 \ Printer 6 screens on a page 23Nov86 - 1 Forth definitions - 2 - 3 : pthru ( first last --) - 4 printsem lock output push print pr-start 1+ swap - 5 ?DO I text? IF I pr THEN scr#s @ 6 = IF pagepr THEN - 6 LOOP pr-flush IF pagepr THEN printsem unlock ; - 7 - 8 : document ( first last --) - 9 isfile@ IF capacity 2/ shadow ! THEN -10 printsem lock output push print pr-start 1+ swap -11 ?DO I text? IF I pr I shadow @ + pr THEN -12 scr#s @ 6 = IF shadowpr THEN LOOP -13 pr-flush IF shadowpr THEN printsem unlock ; -14 -15 : listing ( --) 0 capacity 2/ 1- document ; -Screen 13 not modified - 0 \ Printerspool 03Nov86 - 1 - 2 \needs Task \\ - 3 - 4 | Input: noinput 0 false drop 2drop ; - 5 - 6 - 7 $100 $200 noinput Task spooler - 8 - 9 keyboard -10 -11 : spool ( from to -- ) -12 isfile@ spooler 3 pass isfile ! pthru stop ; -13 -14 -15 -Screen 14 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/RELOCATE.FB.src b/sources/cpm/RELOCATE.FB.src deleted file mode 100644 index 6bb34ba..0000000 --- a/sources/cpm/RELOCATE.FB.src +++ /dev/null @@ -1,51 +0,0 @@ -Screen 0 not modified - 0 \\ Relocate System 11Nov86 - 1 - 2 Dieses File enthaelt das Utility-Wort BUFFERS. - 3 Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen, - 4 die volksFORTH benutzt. Voreingestellt sind 4 Buffer. - 5 - 6 Benutzung: nn BUFFERS - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Relocate a system 16Jul86 - 1 - 2 | : relocate-tasks ( mainup -- ) up@ dup - 3 BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ; - 4 - 5 | : relocate ( stacklen rstacklen -- ) - 6 2dup + b/buf + 2+ limit origin - - 7 u> abort" kills all buffers" - 8 over pad $100 + origin - u< abort" cuts the dictionary" - 9 dup udp @ $40 + -10 u< abort" a ticket to the moon with no return ..." -11 flush empty over + origin + -12 origin $0A + ! \ r0 -13 origin + dup relocate-tasks \ multitasking link -14 6 - origin 8 + ! \ s0 -15 cold ; --> -Screen 2 not modified - 0 \ bytes.more buffers 29Jun86 - 1 - 2 | : bytes.more ( n+- -- ) - 3 up@ origin - + r0 @ up@ - relocate ; - 4 - 5 : buffers ( +n -- ) - 6 b/buf * 4+ limit r0 @ - swap - bytes.more ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/SAVESYS.FB.src b/sources/cpm/SAVESYS.FB.src deleted file mode 100644 index e4b4267..0000000 --- a/sources/cpm/SAVESYS.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \\ savesystem 11Nov86 - 1 - 2 Dieses File enthaelt das Utility-Wort SAVESYSTEM. - 3 - 4 Mit ihm kann man das gesamte System als File auf Disk schreiben. - 5 - 6 Achtung: - 7 Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM - 8 der Heap geloescht! - 9 -10 Benutzung: SAVESYSTEM -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ savsystem 05Nov86 - 1 - 2 : savesystem \ filename - 3 save $100 here over - savefile ; - 4 - 5 - 6 \\ Einfaches savesystem 18Aug86 - 7 - 8 | : message ( -- ) - 9 base push decimal -10 cr ." ready for SAVE " here 1- $100 / u. -11 ." VOLKS4TH.COM" cr ; -12 -13 : savesystem ( -- ) save message bye ; -14 -15 diff --git a/sources/cpm/SEE.FB.src b/sources/cpm/SEE.FB.src deleted file mode 100644 index f8fed64..0000000 --- a/sources/cpm/SEE.FB.src +++ /dev/null @@ -1,408 +0,0 @@ -Screen 0 not modified - 0 \ Extended-Decompiler for VolksForth LOAD-SCREEN UH 07Nov86 - 1 - 2 Dieses File enthaelt einen Decompiler, der bereits kompilierte - 3 Worte wieder in Sourcetextform bringt. - 4 Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL - 5 und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang - 6 erkannt und umgeformt. - 7 Ein Decompiler kann aber keine (Stack-) Kommentare wieder - 8 herzaubern, die Benutzung der Screens und dann view, wird - 9 daher staerkstens empfohlen. -10 -11 Denn: Es ist immernoch ein Fehler drin! -12 Und um den zu korrigieren, ist der Sourcetext dem Objektkode -13 doch vorzuziehen. -14 -15 Benutzung: see -Screen 1 not modified - 0 \ Extended-Decompiler for VolksForth LOAD-SCREEN 07Nov86 - 1 - 2 Onlyforth Tools also definitions - 3 - 4 1 13 +thru - 5 - 6 \\ - 7 Produces compilable Forth source from normal compiled Forth. - 8 - 9 These source blocks are based on the works of -10 -11 Henry Laxen, Mike Perry and Wil Baden -12 -13 volksFORTH version: U. Hoffmann -14 -15 -Screen 2 not modified - 0 \ detacting does> 01Jul86 - 1 - 2 internal - 3 - 4 ' does> 4+ @ Alias (;code - 5 ' Forth @ 1+ @ Constant (dodoes> - 6 - 7 : does? ( IP - f ) - 8 dup c@ $CD ( call ) = swap - 9 1+ @ (dodoes> = and ; -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ indentation. 04Jul86 - 1 Variable #spaces #spaces off - 2 - 3 : +in ( -- ) 3 #spaces +! ; - 4 - 5 : -in ( -- ) -3 #spaces +! ; - 6 - 7 : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; - 8 - 9 : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ case defining words 01Jul86 - 1 - 2 : Case: ( -- ) - 3 Create: Does> swap 2* + perform ; - 4 - 5 : Associative: ( n -- ) - 6 Constant Does> ( n - index ) - 7 dup @ -rot dup @ 0 - 8 DO 2+ 2dup @ = - 9 IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ branching 04Jul86 - 1 - 2 Variable #branches Variable #branch - 3 - 4 : branch-type ( n -- a ) 6 * pad + ; - 5 : branch-from ( n -- a ) branch-type 2+ ; - 6 : branch-to ( n -- a ) branch-type 4+ ; - 7 - 8 : branched ( adr type -- ) \ Make entry in branch-table. - 9 #branches @ branch-type ! dup #branches @ branch-from ! -10 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; -11 -12 \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } -13 -14 -15 -Screen 6 not modified - 0 \ branching 01Jul86 - 1 - 2 : branch-back ( adr type -- ) - 3 \ : make entry in branch-table & reclassify branch-type.) - 4 over swap branched - 5 2+ dup dup @ + swap 2+ ( loop-start,-end.) - 6 0 #branches @ 1- - 7 ?DO - 8 over I branch-from @ u> IF LEAVE THEN - 9 dup I branch-to @ = IF ['] while I branch-type ! THEN -10 -1 +LOOP 2drop ; -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ branching 01Jul86 - 1 : forward? ( ip -- f ) 2+ @ 0> ; - 2 - 3 : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? - 4 IF ['] if branched exit THEN ['] until branch-back ; - 5 - 6 : branch+ ( ip -- ip' ) dup 4+ swap dup forward? - 7 IF ['] else branched exit THEN ['] repeat branch-back ; - 8 - 9 : (loop)+ ( ip -- ip' ) -10 dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; -11 -12 : string+ ( ip -- ip' ) 2+ count + even ; -13 -14 : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; -15 -Screen 8 not modified - 0 \ classify each word 25Aug86 - 1 Forth - 2 - 3 &15 Associative: execution-class - 4 ] clit lit ?branch branch - 5 (do (." (abort" (;code - 6 (" (?do (loop - 7 (+loop unnest (is compile [ - 8 - 9 Case: execution-class+ -10 3+ 4+ ?branch+ branch+ -11 2+ string+ string+ (;code+ -12 string+ 2+ 4+ -13 4+ 0= 4+ 4+ 2+ ; -14 -15 Tools -Screen 9 not modified - 0 \ first pass 01Jul86 - 1 - 2 : pass1 ( cfa -- ) #branches off >body - 3 BEGIN dup @ execution-class execution-class+ - 4 dup 0= stop? or - 5 UNTIL drop ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ identify branch destinations. 04Jul86 - 1 : thru.branchtable ( -- limit start ) #branches @ 0 ; - 2 : ?.then ( ip -- ) thru.branchtable - 3 ?DO I branch-to @ over = - 4 IF I branch-from @ over u< - 5 IF I branch-type @ dup ['] else = swap ['] if = or - 6 IF -in ." THEN " ind-cr LEAVE THEN THEN THEN - 7 LOOP ; - 8 : ?.begin ( ip -- ) thru.branchtable - 9 ?DO I branch-to @ over = -10 IF I branch-from @ over u< not -11 IF I branch-type @ dup -12 ['] repeat = swap ['] until = or -13 IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN -14 LOOP ; -15 ( put "BEGIN" and "THEN" where used.) -Screen 11 not modified - 0 \ decompile each type of word 01Jul86 - 1 - 2 : .word ( ip -- ip' ) dup @ >name .name 2+ ; - 3 - 4 : .(word ( ip -- ip' ) dup @ >name - 5 ?dup 0= IF ." ??? " ELSE - 6 count $1f and swap 1+ swap 1- type space THEN 2+ ; - 7 : .inline ( val16b -- ) - 8 dup >name ?dup IF ." ['] " .name drop exit THEN . ; - 9 -10 : .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; -11 : .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; -12 : .string ( ip -- ip' ) -13 .(word count 2dup type Ascii " emit space + even ?.then ; -14 -15 : .unnest ( ip -- 0 ) ." ; " 0= ; -Screen 12 not modified - 0 \ decompile each type of word 01Jul86 - 1 - 2 : .default ( ip -- ip' ) dup @ >name ?dup IF - 3 c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; - 4 - 5 : .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; - 6 - 7 : .compile ( ip -- ip' ) .word .word ?.then ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ decompiling conditionals 04Jul86 - 1 - 2 : .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; - 3 : .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; - 4 : .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; - 5 : .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; - 6 : .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; - 7 - 8 5 Associative: branch-class - 9 ' if , ' while , ' else , ' repeat , ' until , -10 Case: .branch-class -11 .if .else .else .repeat .repeat ; -12 -13 : .branch ( ip -- ip' ) -14 #branch @ branch-type @ 1 #branch +! -15 dup >name swap branch-class .branch-class ; -Screen 14 not modified - 0 \ decompile Does> ;code 04Jul86 - 1 - 2 : .(;code ( IP - IP' f) - 3 2+ dup does? - 4 IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ classify word's output 01Jul86 - 1 - 2 Case: .execution-class - 3 .clit .lit .branch .branch - 4 .do .string .string .(;code - 5 .string .do .loop - 6 .loop .unnest .['] .compile - 7 .default ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \ decompile colon-definitions 04Jul86 - 1 - 2 : pass2 ( cfa -- ) #branch off >body - 3 BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class - 4 dup 0= stop? or - 5 UNTIL drop ; - 6 - 7 : .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; - 8 - 9 : .immediate ( cfa - ) >name c@ dup -10 ?ind-cr 40 and IF ." IMMEDIATE " THEN -11 ?ind-cr 80 and IF ." RESTRICT" THEN ; -12 -13 : .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; -14 -15 -Screen 17 not modified - 0 \ display category of word 01Jul86 - 1 external Defer (see internal - 2 - 3 : .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; - 4 - 5 : .user-variable ( cfa - ) ." USER " dup >name dup .name - 6 3 spaces swap execute @ u. .name ." ! " ; - 7 - 8 : .defer ( cfa - ) - 9 ." deferred " dup >name .name ." Is " >body @ (see ; -10 -11 : .other ( cfa - ) dup >name .name -12 dup @ over >body = IF drop ." is Code " exit THEN -13 dup @ does? IF .does> exit THEN -14 drop ." is unknown " ; -15 -Screen 18 not modified - 0 \ decompiling variables and constants 01Jul86 - 1 - 2 : .constant ( cfa - ) - 3 dup >body @ u. ." CONSTANT " >name .name ; - 4 - 5 : .variable ( cfa - ) ." VARIABLE " - 6 dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 19 not modified - 0 \ classify a word UH 25Jan88 - 1 - 2 5 Associative: definition-class - 3 ' quit @ , ' 0 @ , ' scr @ , ' base @ , - 4 ' 'cold @ , - 5 - 6 Case: .definition-class - 7 .: .constant .variable .user-variable - 8 .defer .other ; - 9 -10 -11 -12 -13 -14 -15 -Screen 20 not modified - 0 \ Top level of Decompiler 04Jul86 - 1 - 2 external - 3 - 4 : ((see ( cfa -) - 5 #spaces off cr - 6 dup dup @ - 7 definition-class .definition-class .immediate ; - 8 - 9 ' ((see Is (see -10 -11 Forth definitions -12 : see ' (see ; -13 -14 -15 -Screen 21 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 23 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/SIMPFILE.FB.src b/sources/cpm/SIMPFILE.FB.src deleted file mode 100644 index 7f1b7f8..0000000 --- a/sources/cpm/SIMPFILE.FB.src +++ /dev/null @@ -1,68 +0,0 @@ -Screen 0 not modified - 0 \\ Simple Files 11Nov86 - 1 - 2 Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es - 3 trotzdem wuenschenswert eine Art File-Struktur zu besitzen. - 4 Dieses File enthaelt eine einfache Implementation eines - 5 Filesystems. Der/die Programmierer/in muss selbst die Direktory - 6 auf dem laufenden halten: in ihr sind die Start-Bloecke des - 7 entsprechenden Diskettenteils gespeichert. - 8 Sogar eine Hierarchie von Direktories laesst sich so relisieren. - 9 -10 Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch -11 von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64). -12 -13 -14 -15 -Screen 1 not modified - 0 \ simple files 12feb86 - 1 - 2 \needs search .( search missing) \\ - 3 - 4 | Variable (dir : dir (dir @ ; : root 0 (dir ! ; root - 5 - 6 | : read" ( -- n) - 7 Ascii " word count dup >r dir block b/blk search - 8 0= abort" not found" r> + >in push >in ! - 9 bl dir block b/blk (word number drop ; -10 -11 : load" read" dir + load ; : dir" read" (dir +! ; -12 : list" read" dir + list ; -13 -14 \ 1 +load \ Only if file" is needed -15 -Screen 2 not modified - 0 \ simple files 01feb86 - 1 - 2 | : snap ( n0 -- n1) $20 / 3 max $20 * ; - 3 : file" ( n --) - 4 Ascii " word count 2dup dir block b/blk search - 5 IF + nip - 6 ELSE drop dir block b/blk -trailing nip snap $20 + - 7 dup b/blk 1- > abort" directory full" - 8 2dup + >r dir block + swap cmove r> - 9 THEN snap $18 + >r -10 dir - extend under dabs <# # # # # -11 base @ $0A = IF Ascii & ELSE Ascii $ THEN hold -12 rot 0< IF Ascii - ELSE bl THEN hold #> -13 r> dir block + swap cmove update ; -14 -15 -Screen 3 not modified - 0 \ dir load" 11feb86 - 1 - 2 \needs search .( search missing) \\ - 3 - 4 0 Constant dir - 5 - 6 : load" ( -- ) - 7 Ascii " word count dup >r dir block b/blk search - 8 0= abort" not found" r> + - 9 >in @ blk @ rot >in ! dir blk ! -10 bl word number drop -rot blk ! >in ! load ; -11 -12 -13 -14 -15 diff --git a/sources/cpm/SOURCE.FB.src b/sources/cpm/SOURCE.FB.src deleted file mode 100644 index ed51268..0000000 --- a/sources/cpm/SOURCE.FB.src +++ /dev/null @@ -1,2176 +0,0 @@ -Screen 0 not modified - 0 \\ volksFORTH CP/M 2.2 rev. 3.80a 18Nov87 - 1 - 2 Entwicklung des volksFORTH-83 von - 3 K. Schleisiek, B. Pennemann, - 4 G. Rehfeld, D. Weineck, U. Hoffmann - 5 - 6 Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann - 7 - 8 Dieses File enthaelt den kompletten Sourcetext des Kern-Systems - 9 fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+. -10 Mit Hilfe eines Target-Compilers wird daraus das volksFORTH- -11 System erzeugt, daher finden sich an einigen Stellen Anweisungen -12 an den Target-Compiler, die fuer das Verstaendnis des Systems -13 nicht wichtig sind. -14 Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins- -15 besondere die Bdos-Schnittstelle fuer Disk-IO im Kern. -Screen 1 not modified - 0 \ CP/M 2.2 volksForth Load Screen 27Nov87 - 1 - 2 Onlyforth - 3 $9000 displace ! - 4 Target definitions $100 here! - 5 - 6 - 7 1 $74 +thru \ Standard 8080-System - 8 - 9 cr .( unresolved: ) .unresolved ( ' .blk is .status ) -10 -11 save-target KERNEL.COM -12 -13 -14 -15 -Screen 2 not modified - 0 \ FORTH Preamble and ID uho 19May2005 - 1 - 2 Assembler - 3 - 4 nop 0 jmp here 2- >label >boot - 5 nop 0 jmp here 2- >label >cold - 6 nop 0 jmp here 2- >label >restart - 7 - 8 here dup origin! - 9 \ Hier beginnen die Kaltstartwerte der Benutzervariablen -10 -11 6 rst 0 jmp end-code \ for multitasker -12 -13 $100 allot -14 -15 | Create logo ," volksFORTH-83 rev. 3.80a" -Screen 3 not modified - 0 \ Assembler Labels Next Forth-Register 29Jun86 - 1 - 2 Label dpush D push Label hpush H push - 3 Label >next - 4 IP ldax IP inx A L mov IP ldax IP inx A H mov - 5 Label >next1 - 6 M E mov H inx M D mov xchg pchl - 7 end-code - 8 - 9 Variable RP -10 Variable UP -11 \ IP in BC -12 \ W in DE -13 \ SP in SP -14 Variable IPsave -15 -Screen 4 not modified - 0 \ Assembler Macros 20Oct86 - 1 Compiler Assembler also definitions Forth - 2 : Next T >next jmp [ Forth ] ; - 3 T hpush Forth Constant hpush T dpush Forth Constant dpush - 4 T >next Forth Constant >next - 5 - 6 : rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) - 7 H dcx 1+ M mov ( low ) RP shld [ Forth ] ; - 8 - 9 : rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx -10 M swap mov ( high ) H inx RP shld [ Forth ] ; -11 \ rpush und rpop gehen nicht mit HL -12 -13 : mvx ( src dest -- ) -14 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) [ Forth ] ; -15 Target -Screen 5 not modified - 0 \ recover ;c: noop 20Oct86 - 1 - 2 Create recover Assembler - 3 W pop IP rpush W IP mvx - 4 Next end-code - 5 - 6 Compiler Assembler also definitions Forth - 7 - 8 : ;c: 0 T recover call end-code ] [ Forth ] ; - 9 -10 Target -11 -12 | Code di di Next end-code -13 | Code ei ei Next end-code -14 -15 Code noop >next here 2- ! end-code -Screen 6 not modified - 0 \ User variables 04Oct87 - 1 - 2 Constant origin 8 uallot drop \ Multitasker - 3 \ Felder: entry link spare SPsave - 4 \ Laenge kompatibel zum 68000 und 6502 volksFORTH - 5 User s0 - 6 User r0 - 7 User dp - 8 User offset 0 offset ! - 9 User base $0A base ! -10 User output -11 User input -12 User errorhandler \ pointer for Abort" -code -13 User voc-link -14 User udp \ points to next free addr in User -15 -Screen 7 not modified - 0 \ manipulate system pointers 11Jun86 - 1 - 2 Code sp@ ( -- addr) 0 H lxi SP dad hpush jmp end-code - 3 - 4 Code sp! ( addr --) H pop sphl Next end-code - 5 - 6 - 7 Code up@ ( -- addr) UP lhld hpush jmp end-code - 8 - 9 Code up! ( addr --) H pop UP shld Next end-code -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ manipulate returnstack 11Jun86 - 1 - 2 Code rp@ ( -- addr ) RP lhld hpush jmp end-code - 3 - 4 Code rp! ( addr -- ) H pop RP shld Next end-code - 5 - 6 - 7 Code >r ( 16b -- ) D pop D rpush Next end-code restrict - 8 - 9 Code r> ( -- 16b ) D rpop D push Next end-code restrict -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ r@ rdrop exit unnest ?exit 07Oct87 - 1 Code r@ ( -- 16b ) - 2 RP lhld M E mov H inx M D mov D push Next end-code - 3 - 4 Code rdrop - 5 RP lhld H inx H inx RP shld Next end-code restrict - 6 - 7 Code exit Label >exit IP rpop Next end-code - 8 Code unnest >exit here 2- ! - 9 -10 Code ?exit ( flag -- ) -11 H pop H A mov L ora >exit jnz Next end-code -12 -13 Code 0=exit ( flag -- ) -14 H pop H A mov L ora >exit jz Next end-code -15 \ : ?exit ( flag -- ) IF rdrop THEN ; -Screen 10 not modified - 0 \ execute perform 11Jun86 18Nov87 - 1 - 2 Code execute ( cfa -- ) - 3 H pop >Next1 jmp end-code - 4 - 5 Code perform ( 'cfa -- ) - 6 H pop M A mov H inx M H mov A L mov >Next1 jmp - 7 end-code - 8 - 9 -10 \\ -11 : perform ( addr -- ) @ execute ; -12 -13 -14 -15 -Screen 11 not modified - 0 \ c@ c! ctoggle 07Oct87 - 1 - 2 Code c@ ( addr -- 8b ) - 3 H pop M L mov 0 H mvi hpush jmp end-code - 4 - 5 Code c! ( 16b addr -- ) - 6 H pop D pop E M mov Next end-code - 7 - 8 Code flip ( 16b1 -- 16b2 ) - 9 H pop H A mov L H mov A L mov Hpush jmp end-code -10 -11 Code ctoggle ( 8b addr -- ) -12 H pop D pop M A mov E xra A M mov Next end-code -13 -14 \\ -15 : ctoggle ( 8b addr --) under c@ xor swap c! ; -Screen 12 not modified - 0 \ @ ! 2@ 2! 11Jun86 18Nov87 - 1 - 2 Code @ ( addr -- 16b ) H pop Label fetch - 3 M E mov H inx M D mov D push Next end-code - 4 - 5 Code ! ( 16b addr -- ) - 6 H pop D pop E M mov H inx D M mov Next end-code - 7 - 8 Code 2@ ( addr -- 32b ) H pop H push - 9 H inx H inx M E mov H inx M D mov H pop D push -10 M E mov H inx M D mov D push Next end-code -11 -12 Code 2! ( 32b addr -- ) H pop -13 D pop E M mov H inx D M mov H inx -14 D pop E M mov H inx D M mov Next end-code -15 -Screen 13 not modified - 0 \ +! drop swap 11Jun86 18Nov87 - 1 - 2 Code +! ( 16b addr -- ) H pop - 3 Label +store D pop - 4 M A mov E add A M mov H inx - 5 M A mov D adc A M mov Next end-code - 6 - 7 \ : +! ( n addr -- ) under @ + swap ! ; - 8 - 9 -10 Code drop ( 16b -- ) H pop Next end-code -11 -12 Code swap ( 16b1 16b2 -- 16b2 16b1 ) -13 H pop xthl hpush jmp end-code -14 -15 -Screen 14 not modified - 0 \ dup ?dup 16May86 - 1 - 2 Code dup ( 16b -- 16b 16b ) - 3 H pop H push hpush jmp end-code - 4 - 5 Code ?dup ( 16b -- 16b 16b / false) - 6 H pop H A mov L ora 0<> ?[ H push ]? - 7 hpush jmp end-code - 8 - 9 \\ -10 : ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; -11 -12 : dup ( 16b -- 16b 16b ) sp@ @ ; -13 -14 -15 -Screen 15 not modified - 0 \ over rot nip under 11Jun86 - 1 - 2 Code over ( 16b1 16b2 - 16b1 16b2 16b1 ) - 3 D pop H pop H push dpush jmp end-code - 4 Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) - 5 D pop H pop xthl dpush jmp end-code - 6 Code nip ( 16b1 16b2 -- 16b2) - 7 H pop D pop hpush jmp end-code - 8 Code under ( 16b1 16b2 -- 16b2 16b1 16b2) - 9 H pop D pop H push dpush jmp end-code -10 -11 \\ -12 : over >r swap r> swap ; -13 : rot >r dup r> swap ; -14 : nip swap drop ; -15 : under swap over ; -Screen 16 not modified - 0 \ -rot pick roll -roll 11Jun86 - 1 Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) - 2 H pop D pop xthl H push D push Next end-code - 3 - 4 Code pick ( n -- 16b.n ) - 5 H pop H dad SP dad - 6 M E mov H inx M D mov D push Next end-code - 7 - 8 : roll ( n -- ) - 9 dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; -10 -11 : -roll ( n -- ) >r dup sp@ dup 2+ -12 dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; -13 \\ -14 : -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; -15 : pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; -Screen 17 not modified - 0 \ double word stack manipulation 09May86 - 1 Code 2swap ( 32b1 32b2 -- 32b2 32b1) - 2 H pop D pop xthl H push - 3 5 H lxi SP dad M A mov D M mov A D mov - 4 H dcx M A mov E M mov A E mov H pop dpush jmp - 5 end-code - 6 - 7 Code 2drop ( 32b -- ) H pop H pop Next end-code - 8 - 9 Code 2dup ( 32b -- 32b 32b) -10 H pop D pop D push H push dpush jmp end-code -11 -12 \\ -13 : 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; -14 : 2drop ( 32b -- ) drop drop ; -15 : 2dup ( 32b -- 32b 32b) over over ; -Screen 18 not modified - 0 \ + and or xor not 09May86 - 1 Code + ( n1 n2 -- n3 ) - 2 H pop D pop D dad hpush jmp end-code - 3 Code or ( 16b1 16b2 -- 16b3 ) - 4 H pop D pop H A mov D ora A H mov - 5 L A mov E ora A L mov hpush jmp end-code - 6 Code and ( 16b1 16b2 -- 16b3 ) - 7 H pop D pop H A mov D ana A H mov - 8 L A mov E ana A L mov hpush jmp end-code - 9 Code xor ( 16b1 16b2 -- 16b3 ) -10 H pop D pop H A mov D xra A H mov -11 L A mov E xra A L mov hpush jmp end-code -12 Code not ( 16b1 -- 16b2 ) H pop Label >not -13 H A mov cma A H mov L A mov cma A L mov -14 hpush jmp end-code -15 -Screen 19 not modified - 0 \ - negate 16May86 - 1 - 2 Code - ( n1 n2 -- n3 ) - 3 D pop H pop - 4 L A mov E sub A L mov - 5 H A mov D sbb A H mov hpush jmp end-code - 6 - 7 Code negate ( n1 -- n2 ) - 8 H pop H dcx >not jmp end-code - 9 -10 \\ -11 : - ( n1 n2 -- n3 ) negate + ; -12 -13 -14 -15 -Screen 20 not modified - 0 \ dnegate d+ 10Mar86 18Nov87 - 1 - 2 Code dnegate ( d1 -- -d1 ) H pop - 3 Label >dnegate - 4 D pop A sub E sub A E mov 0 A mvi D sbb - 5 A D mov 0 A mvi L sbb A L mov 0 A mvi H sbb - 6 A H mov dpush jmp end-code - 7 - 8 Code d+ ( d1 d2 -- d3) - 9 6 H lxi SP dad M E mov C M mov H inx -10 M D mov B M mov B pop H pop D dad xchg -11 H pop L A mov C adc A L mov H A mov B adc -12 A H mov B pop dpush jmp end-code -13 -14 -15 -Screen 21 not modified - 0 \ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86 - 1 Code 1+ ( n1 -- n2 ) H pop H inx hpush jmp end-code - 2 Code 2+ ( n1 -- n2 ) - 3 H pop H inx H inx hpush jmp end-code - 4 Code 3+ ( n1 -- n2 ) - 5 H pop H inx H inx H inx hpush jmp end-code - 6 Code 4+ ( n1 -- n2 ) - 7 H pop 4 D lxi D dad hpush jmp end-code - 8 | Code 6+ ( n1 -- n2 ) - 9 H pop 6 D lxi D dad hpush jmp end-code -10 Code 1- ( n1 -- n2 ) H pop H dcx hpush jmp end-code -11 Code 2- ( n1 -- n2 ) -12 H pop H dcx H dcx hpush jmp end-code -13 Code 4- ( n1 -- n2 ) -14 H pop -4 D lxi D dad hpush jmp end-code -15 -Screen 22 not modified - 0 \ number Constants 07Oct87 - 1 -1 Constant true 0 Constant false - 2 - 3 0 ( -- 0 ) Constant 0 - 4 1 ( -- 1 ) Constant 1 - 5 2 ( -- 2 ) Constant 2 - 6 3 ( -- 3 ) Constant 3 - 7 4 ( -- 4 ) Constant 4 - 8 -1 ( -- -1 ) Constant -1 - 9 -10 Code on ( addr -- ) H pop $FF A mvi -11 Label set A M mov H inx A M mov Next -12 Code off ( addr -- ) H pop A xra set jmp end-code -13 -14 \ : on ( addr -- ) true swap ! ; -15 \ : off ( addr -- ) false swap ! ; -Screen 23 not modified - 0 \ words for number literals 16May86 - 1 - 2 Code lit ( -- 16b ) - 3 IP ldax A L mov IP inx IP ldax A H mov IP inx - 4 hpush jmp end-code - 5 - 6 Code clit ( -- 8b ) - 7 IP ldax A L mov 0 H mvi IP inx hpush jmp - 8 end-code - 9 -10 : Literal ( 16b -- ) -11 dup $FF00 and IF compile lit , exit THEN -12 compile clit c, ; immediate restrict -13 -14 -15 -Screen 24 not modified - 0 \ comparision words 18Nov87 - 1 Label (u< ( HL,DE -> HL u< DE c,z ) - 2 H A mov D cmp rnz L A mov E cmp ret - 3 Label (< ( HL,DE -> HL < DE c,z ) - 4 H A mov D xra (u< jp D A mov H cmp ret - 5 - 6 Label yes true H lxi hpush jmp - 7 Code u< ( u1 u2 -- flag ) D pop H pop - 8 Label uless (u< call yes jc - 9 Label no false H lxi hpush jmp -10 -11 Code < ( n1 n2 -- flag ) D pop H pop -12 Label less (< call yes jc no jmp end-code -13 -14 Code u> ( u1 u2 -- flag ) H pop D pop uless jmp end-code -15 Code > ( n1 n2 -- flag ) H pop D pop less jmp end-code -Screen 25 not modified - 0 \ comparision words 18Nov87 - 1 Code 0< ( n1 n2 -- flag ) H pop - 2 Label negative H dad yes jc no jmp end-code - 3 - 4 Code 0> ( n -- flag ) H pop H A mov A ora no jm - 5 L ora yes jnz no jmp end-code - 6 - 7 Code 0= ( n -- flag ) H pop - 8 Label zero= H A mov L ora yes jz no jmp end-code - 9 -10 Code 0<> ( n -- flag ) -11 H pop H A mov L ora yes jnz no jmp end-code -12 -13 Code = ( n1 n2 -- flag ) H pop D pop -14 L A mov E cmp no jnz -15 H A mov D cmp no jnz yes jmp end-code -Screen 26 not modified - 0 \\ comparision words high level 18Nov87 - 1 : 0< ( n1 -- flag ) 8000 and 0<> ; - 2 : > ( n1 n2 -- flag ) swap < ; - 3 : 0> ( n -- flag ) negate 0< ; - 4 : 0<> ( n -- flag ) 0= not ; - 5 : u> ( u1 u2 -- flag ) swap u< ; - 6 : = ( n1 n2 -- flag ) - 0= ; - 7 : uwithin ( u1 [low up[ -- flag ) over - -rot - u> ; - 8 | : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; - 9 : min ( n1 n2 -- n3 ) 2dup > minimax ; -10 : max ( n1 n2 -- n3 ) 2dup < minimax ; -11 : umax ( u1 u2 -- u3 ) 2dup u< minimax ; -12 : umin ( u1 u2 -- u3 ) 2dup u> minimax ; -13 : extend ( n -- d ) dup 0< ; -14 : dabs ( d -- ud ) extend IF dnegate THEN ; -15 : abs ( n -- u) extend IF negate THEN ; -Screen 27 not modified - 0 \ uwthin double number comparison words 18Nov87 - 1 - 2 Code uwithin ( u1 [low up[ -- flag ) H pop D pop xthl - 3 (u< call cs ?[ H pop no jmp ]? - 4 D pop (u< call yes jc no jmp end-code - 5 - 6 Code d0= ( d -- flag ) H pop - 7 H A mov L ora H pop no jnz zero= jmp end-code - 8 - 9 : d= ( d1 d2 -- flag ) rot = -rot = and ; -10 : d< ( d1 d2 -- flag ) -11 rot 2dup = IF 2drop u< exit THEN > nip nip ; -12 -13 -14 \\ -15 : d0= ( d -- flag ) or 0= ; -Screen 28 not modified - 0 \ minimum maximum 18Nov87 - 1 - 2 Code umax ( u1 u2 -- u3 ) - 3 H pop D pop (u< call - 4 Label minimax cs ?[ xchg ]? hpush jmp end-code - 5 - 6 Code umin ( u1 u2 -- u3 ) - 7 H pop D pop (u< call cmc minimax jmp end-code - 8 - 9 Code max ( n1 n2 -- n3 ) -10 H pop D pop (< call minimax jmp end-code -11 -12 Code min ( n1 n2 -- n3 ) -13 H pop D pop (< call cmc minimax jmp end-code -14 -15 -Screen 29 not modified - 0 \ sign extension absolute values 18Nov87 - 1 - 2 Code extend ( n -- d ) H pop H push negative jmp end-code - 3 - 4 Code abs ( a -- u ) H pop H A mov A ora - 5 hpush jp H dcx >not jmp end-code - 6 - 7 Code dabs ( d -- ud ) H pop H A mov A ora - 8 hpush jp >dnegate jmp end-code - 9 -10 -11 -12 -13 -14 -15 -Screen 30 not modified - 0 \ branch ?branch 20Nov87 - 1 - 2 Code branch ( -- ) Label >branch - 3 IP H mvx M E mov H inx M D mov H dcx - 4 D dad H IP mvx Next end-code - 5 - 6 Code ?branch ( fl -- ) - 7 H pop H A mov L ora >branch jz - 8 IP inx IP inx Next end-code - 9 -10 -11 \\ -12 : branch r> dup @ + >r ; -13 -14 -15 -Screen 31 not modified - 0 \ loop primitives 11Jun86 20Nov87 - 1 - 2 Code bounds ( start count -- limit start ) - 3 H pop D pop D dad H push D push Next end-code - 4 - 5 Code endloop - 6 RP lhld 6 D lxi D dad RP shld next end-code restrict - 7 - 8 \\ dodo puts "index | limit | adr.of.DO" on return-stack - 9 : bounds ( start count -- limit start ) over + swap ; -10 -11 | : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; -12 -13 : (do ( limit start -- ) over - dodo ; restrict -14 : (?do ( limit start -- ) over - ?dup IF dodo THEN -15 r> dup @ + >r drop ; restrict -Screen 32 not modified - 0 \ loop primitives 20Nov87 - 1 - 2 Code (do ( limit start -- ) H pop D pop - 3 Label >do - 4 L A mov E sub A L mov - 5 H A mov D sbb A H mov - 6 H push IP inx IP inx - 7 RP lhld H dcx IP M mov H dcx IP' M mov - 8 H dcx D M mov H dcx E M mov - 9 D pop H dcx D M mov H dcx E M mov RP shld -10 Next end-code restrict -11 -12 Code (?do ( limit start -- ) H pop D pop -13 H A mov D cmp >do jnz -14 L A mov E cmp >do jnz >branch jmp -15 end-code restrict -Screen 33 not modified - 0 \ (loop (+loop 14May86 20Nov87 - 1 - 2 Code (loop - 3 RP lhld M inr 0= ?[ H inx M inr >next jz ]? - 4 Label doloop RP lhld 4 D lxi D dad - 5 M IP' mov H inx M IP mov Next - 6 end-code restrict - 7 - 8 Code (+loop - 9 RP lhld D pop -10 M A mov E add A M mov H inx -11 M A mov D adc A M mov -12 rar D xra doloop jp Next -13 end-code restrict -14 -15 -Screen 34 not modified - 0 \ loop indices 06May86 20Nov87 - 1 - 2 Code I ( -- n ) - 3 RP lhld - 4 Label >I M E mov H inx M D mov D push - 5 H inx M E mov H inx M D mov H pop D dad - 6 hpush jmp - 7 end-code - 8 - 9 Code J ( -- n ) -10 RP lhld 6 D lxi D dad >I jmp end-code -11 -12 -13 -14 -15 -Screen 35 not modified - 0 \ interpretive conditionals UH 25Jan88 - 1 - 2 | Create: remove>> r> rp! ; - 3 | : >>r ( addr len -- addr ) r> over rp@ under swap - dup rp! - 4 swap >r remove>> >r swap >r dup >r swap cmove r> ; - 5 - 6 | Variable saved-dp 0 saved-dp ! - 7 - 8 | Variable level 0 level ! - 9 -10 | : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit -11 1 level ! here saved-dp ! ] ; -12 -13 | : -level ( -- ) state @ 0= Abort" unstructured" -14 level @ 0=exit -1 level +! level @ ?exit compile unnest -15 [compile] [ saved-dp @ here over dp ! over - >>r >r ; -Screen 36 not modified - 0 \ resolve loops and branches UH 25Jan88 - 1 - 2 : >mark ( -- addr ) here 0 , ; - 3 - 4 : +>mark ( acf -- addr ) +level , >mark ; - 5 - 6 : >resolve ( addr -- ) here over - swap ! -level ; - 7 - 8 : mark 1 ; immediate - 3 : THEN abs 1 ?pairs >resolve ; immediate - 4 : ELSE 1 ?pairs ['] branch +>mark swap - 5 >resolve -1 ; immediate - 6 : BEGIN mark - 8 -2 2swap ; immediate - 9 -10 | : (reptil resolve REPEAT ; -12 -13 : REPEAT 2 ?pairs compile branch (reptil ; immediate -14 : UNTIL 2 ?pairs compile ?branch (reptil ; immediate -15 -Screen 39 not modified - 0 \ Loops UH 25Jan88 - 1 - 2 : DO ['] (do +>mark 3 ; immediate - 3 : ?DO ['] (?do +>mark 3 ; immediate - 4 : LOOP 3 ?pairs compile (loop compile endloop >resolve ; - 5 immediate - 6 : +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; - 7 immediate - 8 - 9 Code LEAVE -10 RP lhld 4 D lxi D dad M E mov H inx M D mov -11 H inx RP shld xchg H dcx M D mov H dcx M E mov -12 D dad H IP mvx Next end-code restrict -13 -14 \\ Returnstack: calladr | index limit | adr of DO -15 : LEAVE endloop r> 2- dup @ + >r ; restrict -Screen 40 not modified - 0 \ um* 16May86 - 1 Label (um* 0 H lxi ( 0=Teil-Produkt ) - 2 4 C mvi ( Schleifen-Zaehler ) - 3 [[ H dad ( Schiebe HL 24 bits nach links ) - 4 ral cs ?[ D dad 0 aci ]? - 5 H dad ral cs ?[ D dad 0 aci ]? - 6 C dcr 0= ?] ret - 7 - 8 Code um* ( u1 u2 -- ud ) - 9 D pop H pop B push H B mov L A mov (um* call -10 H push A H mov B A mov H B mov (um* call -11 D pop D C mov B dad 0 aci L D mov H L mov -12 A H mov B pop dpush jmp end-code -13 -14 -15 -Screen 41 not modified - 0 \ m* * 2* 2/ 16May86 - 1 - 2 : m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN - 3 swap dup 0< IF negate r> not >r THEN - 4 um* r> IF dnegate THEN ; - 5 - 6 : * ( n1 n2 - prod ) um* drop ; - 7 - 8 Code 2* ( n -- 2*n ) H pop H dad hpush jmp end-code - 9 -10 Code 2/ ( n -- n/2 ) -11 H pop H A mov rlc rrc rar A H mov -12 L A mov rar A L mov hpush jmp end-code -13 \\ -14 : 2* ( n -- 2*n ) 2 * ; -15 : 2/ ( n -- n/2 ) 2 / ; -Screen 42 not modified - 0 \ um/mod 14May86 - 1 Label usl0 - 2 A E mov H A mov C sub A H mov E A mov B sbb - 3 cs ?[ H A mov C add A H mov E A mov D dcr rz - 4 Label usla - 5 H dad ral usl0 jnc - 6 A E mov H A mov C sub A H mov E A mov B sbb - 7 ]? L inr D dcr usla jnz ret - 8 Label usbad -1 H lxi B pop H push hpush jmp - 9 Code um/mod ( d1 n1 -- rem quot ) -10 IP H mvx B pop D pop xthl xchg -11 L A mov C sub H A mov B sbb usbad jnc -12 H A mov L H mov D L mov 8 D mvi D push -13 usla call D pop H push E L mov usla call -14 A D mov H E mov B pop C H mov B pop -15 D push hpush jmp end-code -Screen 43 not modified - 0 \ m/mod 16May86 - 1 - 2 : m/mod ( d n -- mod quot) - 3 dup >r abs over 0< IF under + swap THEN - 4 um/mod r@ 0< IF negate over IF swap r@ + swap 1- - 5 THEN THEN rdrop ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 44 not modified - 0 \ /mod / mod */mod */ u/mod ud/mod 16May86 - 1 - 2 : /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; - 3 - 4 : / ( n1 n2 -- quot ) /mod nip ; - 5 - 6 : mod ( n1 n2 -- rem ) /mod drop ; - 7 - 8 : */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; - 9 -10 : */ ( n1 n2 n3 -- quot ) */mod nip ; -11 -12 : u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; -13 -14 : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r -15 um/mod r> ; -Screen 45 not modified - 0 \ cmove cmove> 16May86 18Nov87 - 1 - 2 Code cmove ( from to count -- ) IP H mvx IPsave shld - 3 B pop D pop H pop - 4 Label (cmove - 5 [[ B A mov C ora 0= not ?[[ - 6 M A mov H INX D stax D inx B dcx - 7 ]]? IPsave lhld H IP mvx Next end-code - 8 - 9 Code cmove> ( from to count -- ) IP H mvx IPsave shld -10 B pop D pop H pop -11 Label (cmove> -12 B dad H dcx xchg B dad H dcx xchg -13 [[ B A mov C ora 0= not ?[[ -14 M A mov H dcx D stax D dcx B dcx -15 ]]? IPsave lhld H IP mvx Next end-code -Screen 46 not modified - 0 \ move place count 17Oct86 18Nov87 - 1 - 2 Code move ( from to quan -- ) - 3 IP H mvx Ipsave shld B pop D pop H pop - 4 Label domove (u< call (cmove jnc (cmove> jmp end-code - 5 - 6 | Code (place ( addr len to -- len to ) IP H mvx Ipsave shld - 7 D pop B pop H pop - 8 B push D push D inx domove jmp end-code - 9 -10 : place ( addr len to -- ) (place c! ; -11 -12 Code count ( adr -- adr+1 len ) H pop M E mov 0 D mvi -13 H inx H push D push Next end-code -14 -15 -Screen 47 not modified - 0 \ fill erase 18Nov87 - 1 - 2 Code fill ( addr quan 8b -- ) - 3 IP H mvx IPsave shld D pop B pop H pop - 4 [[ B A mov C ora 0<> ?[[ - 5 E M mov H inx B dcx - 6 ]]? IPsave lhld H IP mvx Next end-code - 7 - 8 : erase ( addr quan --) 0 fill ; - 9 -10 \\ : fill ( addr quan 8b -- ) -11 swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; -12 : count ( adr -- adr+1 len ) dup 1+ swap c@ ; -13 : move ( from to quan -- ) -14 >r 2dup u< IF r> cmove> exit THEN r> cmove ; -15 : place ( addr len to --) over >r rot over 1+ r> move c! ; -Screen 48 not modified - 0 \ here allot , c, pad compile 11Jun86 18Nov87 - 1 - 2 Code here ( -- addr ) user' dp D lxi - 3 UP lhld D dad fetch jmp end-code - 4 - 5 Code allot ( n -- ) user' dp D lxi - 6 UP lhld D dad +store jmp end-code - 7 - 8 : , ( 16b -- ) here ! 2 allot ; - 9 : c, ( 8b -- ) here c! 1 allot ; -10 -11 : pad ( -- addr ) here $42 + ; -12 : compile r> dup 2+ >r @ , ; restrict -13 -14 \ : here ( -- addr ) dp @ ; -15 \ : allot ( n -- ) dp +! ; -Screen 49 not modified - 0 \ input strings 11Jun86 - 1 - 2 Variable #tib 0 #tib ! - 3 Variable >tib here >tib ! $50 allot - 4 Variable >in 0 >in ! - 5 Variable blk 0 blk ! - 6 Variable span 0 span ! - 7 - 8 : tib ( -- addr ) >tib @ ; - 9 -10 : query ( -- ) tib $50 expect span @ #tib ! >in off blk off ; -11 -12 -13 -14 -15 -Screen 50 not modified - 0 \\ scan skip /string 16May86 18Nov87 - 1 - 2 : scan ( addr0 len0 char -- addr1 len1 ) >r - 3 BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap REPEAT - 4 rdrop ; - 5 - 6 : skip ( addr len del -- addr1 len1 ) >r - 7 BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap REPEAT - 8 rdrop ; - 9 -10 : /string ( addr0 len0 +n - addr1 len1 ) -11 over umin rot over + -rot - ; -12 -13 -14 -15 -Screen 51 not modified - 0 \ skip scan 18Nov87 - 1 Label done H push B push IPsave lhld H IP mvx Next - 2 Code skip ( addr len del -- addr1 len1 ) - 3 IP H mvx IPsave shld D pop B pop H pop - 4 [[ B A mov C ora done jz - 5 M A mov E cmp done jnz H inx B dcx ]] end-code - 6 - 7 Code scan ( addr len chr -- addr1 len1 ) - 8 IP H mvx IPsave shld D pop B pop H pop - 9 [[ B A mov C ora done jz -10 M A mov E cmp done jz H inx B dcx ]] end-code -11 -12 Code /string ( addr0 len0 +n - addr1 len1 ) H pop D pop -13 D push (u< call cs ?[ xchg ]? H pop xthl D dad xthl -14 L A mov E sub A L mov H A mov D sbb A H mov -15 Hpush jmp end-code -Screen 52 not modified - 0 \ capitalize ohne Umlaute !! 16May86UH 25Jan88 - 1 Variable caps 0 caps ! - 2 Label ?capital caps lda A ana rz - 3 Label (capital ( e --> A,E ) E A mov Ascii a cpi rc - 4 Ascii z 1+ cpi rnc Ascii a Ascii A - sui A E mov ret - 5 - 6 Code capital ( char -- char') D pop - 7 (capital call D push Next end-code - 8 Code upper ( addr len -- ) D pop E D mov H pop D inr - 9 [[ D dcr >next jz M E mov (capital call E M mov H inx ]] -10 end-code -11 -12 \\ : capital ( char -- char') -13 dup Ascii a [ Ascii z 1+ ] Literal uwithin not ?exit -14 [ Ascii a Ascii A - ] Literal - ; -15 : upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ; -Screen 53 not modified - 0 \ (word 16May86 - 1 - 2 Code (word ( char adr0 len0 -- addr ) - 3 IP H mvx IPsave shld B pop B dcx D pop - 4 >in lhld D dad xchg xthl xchg H push >in lhld - 5 C A mov L sub A L mov B A mov H sbb A H mov - 6 cs ?[ B inx C A mov >in sta B A mov >in 1+ sta - 7 D pop H pop D push - 8 ][ H inx H B mvx H pop - 9 [[ B A mov C ora 0<> -10 ?[[ M A mov E cmp 0= ?[[ H inx B dcx ]]? ]? -11 H push -12 [[ B A mov C ora 0<> -13 ?[[ M A mov E cmp 0<> ?[[ H inx B dcx ]]? ]? -14 xchg H pop xthl -15 E A mov L sub A L mov D A mov H sbb A H mov -Screen 54 not modified - 0 \ (word Part2 16May86 - 1 - 2 B A mov C ora 0<> ?[ H inx ]? >in shld ]? - 3 H pop E A mov L sub A C mov D A mov H sbb A B mov - 4 H push user' dp D lxi UP lhld D dad - 5 M A mov H inx M H mov A L mov D pop H push - 6 C M mov H inx - 7 [[ B A mov C ora 0<> - 8 ?[[ D ldax A M mov H inx D inx B dcx ]]? bl M mvi - 9 IPsave lhld H IP mvx Next end-code -10 \\ -11 : (word ( char adr0 len0 -- addr ) -12 rot >r over swap >in @ /string -13 r@ skip over swap r> scan >r rot over swap - r> 0<> - -14 >in ! over - here dup >r place bl r@ count + c! r> ; -15 -Screen 55 not modified - 0 \ source word parse name 20Oct86UH 25Jan88 - 1 - 2 Variable loadfile - 3 - 4 : source ( -- addr len ) blk @ ?dup - 5 IF loadfile @ (block b/blk exit THEN tib #tib @ ; - 6 - 7 : word ( char -- addr ) source (word ; - 8 - 9 : parse ( char -- addr len ) -10 >r source >in @ /string over swap r> scan >r -11 over - dup r> 0<> - >in +! ; -12 -13 : name ( -- addr ) bl word dup count upper exit ; -14 -15 -Screen 56 not modified - 0 \ state Ascii ," "lit (" " 18Nov87 - 1 - 2 Variable state 0 state ! - 3 - 4 : Ascii ( char -- n ) - 5 bl word 1+ c@ state @ IF [compile] Literal THEN ; immediate - 6 - 7 Code "lit RP lhld M E mov H inx M D mov H dcx - 8 D push D ldax D inx E add A M mov H inx - 9 D A mov 0 aci A M mov Next end-code -10 -11 : ," Ascii " parse here over 1+ allot place ; -12 : (" "lit ; restrict -13 : " compile (" ," align ; immediate restrict -14 -15 \ : "lit r> r> under count + even >r >r ; restrict -Screen 57 not modified - 0 \ ." ( .( \ \\ hex decimal 07Oct87 - 1 - 2 : (." "lit count type ; restrict - 3 : ." compile (." ," align ; immediate restrict - 4 - 5 : ( ascii ) parse 2drop ; immediate - 6 : .( ascii ) parse type ; immediate - 7 - 8 : \ >in @ negate c/l mod >in +! ; immediate - 9 : \\ b/blk >in ! ; immediate -10 : \needs name find nip 0=exit [compile] \ ; -11 -12 : hex $10 base ! ; -13 : decimal $0A base ! ; -14 -15 -Screen 58 not modified - 0 \ number conversion: digit? 16May86 18Nov87 - 1 - 2 Code digit? ( char -- n true : false ) - 3 user' base D lxi UP lhld D dad - 4 D pop E A mov Ascii 0 sui no jc - 5 $0A cpi cs not ?[ Ascii A Ascii 0 - cpi no jc - 6 Ascii A Ascii 9 - 1- sui ]? - 7 M cmp no jnc - 8 0 H mvi A L mov H push yes jmp end-code - 9 -10 \\ -11 : digit? ( char -- digit true/ false ) dup Ascii 9 > -12 IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN -13 Ascii 0 - dup base @ u< dup ?exit nip ; -14 -15 -Screen 59 not modified - 0 \ number conversion: accumulate convert 11Jun86 - 1 - 2 | : end? ( -- flag ) >in @ 0= ; - 3 | : char ( addr0 -- addr1 char ) count -1 >in +! ; - 4 | : previous ( addr0 -- addr0 char ) 1- count ; - 5 - 6 : accumulate ( +d0 adr digit - +d1 adr ) - 7 swap >r swap base @ um* drop rot base @ um* d+ r> ; - 8 - 9 : convert ( +d1 addr0 -- +d2 addr2 ) -10 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; -11 -12 -13 -14 -15 -Screen 60 not modified - 0 \ number conversion: ?nonum punctuation? 07Oct87 - 1 - 2 | : ?nonum ( flag -- exit if true ) 0=exit - 3 rdrop 2drop drop rdrop false ; - 4 - 5 | : punctuation? ( char -- flag ) - 6 Ascii , over = swap Ascii . = or ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 61 not modified - 0 \ number conversion: fixbase? 07Oct87 - 1 - 2 | : fixbase? ( char - char false / newbase true ) capital - 3 Ascii & case? IF $0A true exit THEN - 4 Ascii $ case? IF $10 true exit THEN - 5 Ascii H case? IF $10 true exit THEN - 6 Ascii % case? IF 2 true exit THEN false ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 62 not modified - 0 \ number conversion: ?num ?dpl 07Oct87 - 1 - 2 Variable dpl -1 dpl ! - 3 - 4 | : ?num ( flag -- exit if true ) 0=exit - 5 rdrop drop r> IF dnegate THEN - 6 rot drop dpl @ 1+ ?dup ?exit drop true ; - 7 - 8 | : ?dpl dpl @ -1 = ?exit 1 dpl +! ; - 9 -10 -11 -12 -13 -14 -15 -Screen 63 not modified - 0 \ number conversion: number? number 11Jun86 - 1 - 2 : number? ( string - string false / n 0< / d 0> ) - 3 base push >in push dup count >in ! dpl on - 4 0 >r ( +sign) 0.0 rot end? ?nonum char - 5 Ascii - case? IF rdrop true >r end? ?nonum char THEN - 6 fixbase? IF base ! end? ?nonum char THEN - 7 BEGIN digit? 0= ?nonum - 8 BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL - 9 previous punctuation? 0= ?nonum dpl off end? ?num char -10 REPEAT ; -11 -12 : number ( string -- d ) -13 number? ?dup 0= Abort" ?" 0< IF extend THEN ; -14 -15 -Screen 64 not modified - 0 \ hide reveal immediate restrict 11Jun86 - 1 - 2 Variable last 0 last ! - 3 | : last? ( -- false / acf true) last @ ?dup ; - 4 : hide last? IF 2- @ current @ ! THEN ; - 5 : reveal last? IF 2- current @ ! THEN ; - 6 : Recursive reveal ; immediate restrict - 7 - 8 | : flag! ( 8b --) - 9 last? IF under c@ or over c! THEN drop ; -10 -11 : immediate $40 flag! ; -12 : restrict $80 flag! ; -13 -14 -15 -Screen 65 not modified - 0 \ clearstack hallot heap heap? 04Sep86 - 1 - 2 Code clearstack - 3 user' s0 D lxi UP lhld D dad M E mov H inx M D mov - 4 xchg sphl Next end-code - 5 - 6 : hallot ( quan -- ) - 7 s0 @ over - swap sp@ 2+ dup rot - dup s0 ! - 8 2 pick over - di move clearstack ei s0 ! ; - 9 -10 : heap ( -- addr ) s0 @ 6 + ; -11 : heap? ( addr -- flag ) heap up@ uwithin ; -12 -13 | : heapmove ( from -- from ) -14 dup here over - dup hallot -15 heap swap cmove heap over - last +! reveal ; -Screen 66 not modified - 0 \ Does> ; 11Jun86 20Nov87 - 1 - 2 Label (dodoes> - 3 IP rpush IP pop W inx W push Next end-code - 4 - 5 : (;code r> last @ name> ! ; - 6 - 7 : Does> - 8 compile (;code $CD ( 8080-Call ) c, - 9 compile (dodoes> ; immediate restrict -10 -11 -12 -13 -14 -15 -Screen 67 not modified - 0 \ ?head | alignments 20Oct86 18Nov87 - 1 - 2 Variable ?head 0 ?head ! - 3 - 4 : | ?head @ ?exit -1 ?head ! ; - 5 - 6 \ machen nichts beim 8080: - 7 : even ( addr -- addr1 ) ; immediate - 8 : align ( -- ) ; immediate - 9 : halign ( -- ) ; immediate -10 -11 Variable warning 0 warning ! -12 -13 | : exists? warning @ ?exit last @ current @ -14 (find nip 0=exit space last @ .name ." exists " ?cr ; -15 -Screen 68 not modified - 0 \ warning Create 20Oct86 18Nov87 - 1 - 2 Defer makeview ' 0 Is makeview - 3 - 4 : (create ( string -- ) align here - 5 swap count $1F and here 4+ place makeview , current @ @ , - 6 here last ! here c@ 1+ allot align exists? - 7 ?head @ IF 1 ?head +! dup , \ Pointer to Code - 8 halign heapmove $20 flag! dup dp ! - 9 THEN drop reveal 0 , -10 ;Code W inx W push Next end-code -11 -12 : Create name count 1 $20 uwithin not -13 Abort" invalid name" 1- (create ; -14 -15 -Screen 69 not modified - 0 \ nfa? 30Jun86 - 1 - 2 Code nfa? ( thread cfa -- nfa / false ) - 3 D pop H pop - 4 [[ M A mov H inx M H mov A L mov - 5 H ora Hpush jz H push H inx H inx H push D push - 6 M A mov H inx $1F ani A E mov 0 D mvi D dad - 7 D pop xthl M A mov H pop $20 ani - 8 0<> ?[ M A mov H inx M H mov A L mov ]? - 9 H A mov D cmp 0= ?[ L A mov E cmp ]? -10 H pop 0= ?] H inx H inx Hpush jmp -11 end-code -12 \\ -13 : nfa? ( thread cfa -- nfa / false) -14 >r BEGIN @ dup 0= IF rdrop exit THEN dup 2+ name> r@ = -15 UNTIL 2+ rdrop ; -Screen 70 not modified - 0 \ >name name> >body .name 30Jun86 07Oct87 - 1 - 2 : >name ( cfa -- nfa / false ) voc-link - 3 BEGIN @ dup WHILE 2dup 4 - swap nfa? - 4 ?dup IF -rot 2drop exit THEN REPEAT nip ; - 5 - 6 Code (name> ( nfa -- cfa ) H pop M A mov H inx $1F ani - 7 A E mov 0 D mvi D dad hpush jmp end-code - 8 \ : (name> ( nfa -- cfa ) count $1F and + ; - 9 -10 : name> ( nfa -- cfa ) dup (name> swap c@ $20 and IF @ THEN ; -11 -12 : >body ( cfa -- pfa ) 2+ ; : body> ( pfa -- cfa ) 2- ; -13 -14 : .name ( nfa -- ) ?dup IF dup heap? IF ." |" THEN -15 count $1F and type ELSE ." ???" THEN space ; -Screen 71 not modified - 0 \ : ; Constant Variable 07Nov87 - 1 - 2 : Create: Create hide current @ context ! 0 ] ; - 3 - 4 : : Create: ;Code IP rpush W inx W IP mvx Next end-code - 5 - 6 : ; 0 ?pairs compile unnest [compile] [ reveal ; - 7 immediate restrict - 8 - 9 : Constant ( n -- ) Create , ;Code -10 W inx xchg M E mov H inx M D mov D push Next -11 end-code -12 -13 : Variable Create 0 , ; -14 -15 -Screen 72 not modified - 0 \ uallot User Alias Defer 11Jun86 18Nov87 - 1 : uallot ( quan -- offset ) even dup udp @ + - 2 $FF u> Abort" Userarea full" udp @ swap udp +! ; - 3 - 4 : User Create 2 uallot c, - 5 ;Code W inx W ldax A E mov 0 D mvi - 6 UP lhld D dad hpush jmp end-code - 7 - 8 : Alias ( cfa -- ) Create last @ dup c@ $20 and - 9 IF -2 allot ELSE $20 flag! THEN (name> ! ; -10 -11 | : crash true Abort" crash" ; -12 -13 : Defer Create ['] crash , -14 ;Code W inx xchg M E mov H inx M D mov -15 xchg >next1 jmp end-code -Screen 73 not modified - 0 \ vp current context also toss 11Jun86 - 1 - 2 Create vp $10 allot Variable current - 3 - 4 : context ( -- adr ) vp dup @ + 2+ ; - 5 - 6 | : thru.vocstack ( -- from to ) vp 2+ context ; - 7 \ "Only Forth also Assembler" gives - 8 \ vp: countword = 6 | Only | Forth | Assembler | - 9 -10 : also vp @ $0A > Error" Vocabulary stack full" -11 context @ 2 vp +! context ! ; -12 : toss vp @ IF -2 vp +! THEN ; -13 -14 -15 -Screen 74 not modified - 0 \ Vocabulary Forth Only Onlyforth 24Nov85 18Nov87 - 1 - 2 : Vocabulary - 3 Create 0 , 0 , here voc-link @ , voc-link ! - 4 Does> context ! ; - 5 \ | Name | Code | Thread | Coldthread | Voc-link | - 6 - 7 Vocabulary Forth - 8 Vocabulary Root - 9 -10 : Only vp off Root also ; -11 -12 : Onlyforth Only Forth also definitions ; -13 -14 -15 -Screen 75 not modified - 0 \ definitions order words 10Oct87 20Nov87 - 1 - 2 | : init-vocabularys voc-link @ - 3 BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; - 4 - 5 : definitions context @ current ! ; - 6 - 7 | : .voc ( adr -- ) @ 2- >name .name ; - 8 - 9 : order vp 4+ context DO I .voc -2 +LOOP -10 2 spaces current .voc ; -11 -12 : words context @ -13 BEGIN @ dup stop? 0= and -14 WHILE ?cr dup 2+ .name space -15 REPEAT drop ; -Screen 76 not modified - 0 \ found -text 11Jun86 - 1 | : found ( nfa -- cfa n ) - 2 dup c@ >r (name> r@ $20 and IF @ THEN - 3 -1 r@ $80 and IF 1- THEN - 4 r> $40 and IF negate THEN ; - 5 - 6 \\ - 7 : -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1r count $1F and strlen ! string ! -13 BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ = -14 IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN -15 THEN drop REPEAT string @ 1- false ; -Screen 77 not modified - 0 \ (find 11Jun86 - 1 - 2 Code (find ( str thr - str false/ NFA true ) - 3 H pop D pop IP push D ldax $1F ani A C mov D inx - 4 Label findloop - 5 M A mov H inx M H mov A L mov - 6 H A mov L ora 0= ?[ IP pop D dcx D push no jmp ]? - 7 H push H inx H inx M A mov $1F ani C cmp - 8 0<> ?[ H pop findloop jmp ]? - 9 D push H inx C B mov B inr -10 [[ B dcr 0<> ?[[ -11 D ldax M cmp 0<> ?[ D pop H pop findloop jmp ]? -12 H inx D inx ]]? -13 D pop H pop H inx H inx IP pop H push yes jmp -14 end-code -15 \\ HL: thread, nfa DE: string C: strlen B: counter -Screen 78 not modified - 0 \ find ' [compile] ['] nullstring? 18Nov87 - 1 - 2 : find ( string -- cfa n / string false ) - 3 context dup @ over 2- @ = IF 2- THEN - 4 BEGIN under @ (find IF nip found exit THEN - 5 over vp 2+ u> WHILE swap 2- REPEAT nip false ; - 6 - 7 : ' ( -- cfa ) name find ?exit Error" ?" ; - 8 - 9 : [compile] ' , ; immediate restrict -10 -11 : ['] ' [compile] Literal ; immediate restrict -12 -13 : nullstring? ( string -- string false / true ) -14 dup c@ 0= dup 0=exit nip ; -15 -Screen 79 not modified - 0 \ notfound 17Oct86UH 25Jan88 - 1 - 2 : no.extensions ( string -- ) - 3 state @ IF Abort" ?" THEN Error" ?" ; - 4 - 5 Defer notfound ' no.extensions Is notfound - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 80 not modified - 0 \ interpret interpreter compiler parser UH 25Jan88 - 1 Defer parser - 2 - 3 : interpret ( -- ) - 4 BEGIN ?stack name nullstring? ?exit parser REPEAT ; - 5 - 6 | : interpreter ( str -- ) find ?dup - 7 IF 1 and IF execute exit THEN Error" compile only" THEN - 8 number? ?exit notfound ; - 9 -10 ' interpreter Is parser -11 -12 | : compiler ( str -- ) find ?dup -13 IF 0> IF execute exit THEN , exit THEN -14 number? ?dup IF 0> IF swap [compile] Literal THEN -15 [compile] Literal exit THEN notfound ; -Screen 81 not modified - 0 \ [ ] UH 25Jan88 - 1 - 2 : [ ['] interpreter Is Parser state off ; immediate - 3 - 4 : ] ['] compiler Is Parser state on ; - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 82 not modified - 0 \ Is 09May86UH 25Jan88 - 1 - 2 : (is r> dup 2+ >r @ ! ; - 3 - 4 | : def? ( cfa -- ) - 5 @ [ ' notfound @ ] Literal - Abort" not deferred" ; - 6 - 7 : Is ( adr -- ) ' dup def? >body - 8 state @ IF compile (is , exit THEN ! ; immediate - 9 -10 -11 -12 -13 -14 -15 -Screen 83 not modified - 0 \ ?stack 30Jun86 - 1 | : stackfull ( -- ) depth $20 > Abort" tight stack" - 2 reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN - 3 true Abort" Dictionary full" ; - 4 - 5 Code ?stack - 6 UP lhld user' dp D lxi D dad M E mov H inx M D mov - 7 0 H lxi SP dad L A mov E sub H A mov D sbb - 8 0= ?[ ;c: stackfull ; Assembler ]? H push - 9 UP lhld user' s0 D lxi D dad M E mov H inx M D mov -10 H pop D A mov H cmp c0= ?[ 0= ?[ E A mov L cmp ]? ]? -11 >next jnc ;c: true abort" Stack empty" ; -12 \\ -13 : ?stack sp@ here - 100 u< IF stackfull THEN -14 sp@ s0 @ u> Abort" Stack empty" ; -15 -Screen 84 not modified - 0 \ .status push load 20Oct86 - 1 - 2 Defer .status ' noop Is .status - 3 - 4 | Create: pull r> r> ! ; - 5 - 6 : push ( addr -- ) r> swap dup >r @ >r pull >r >r ; - 7 restrict - 8 - 9 : (load ( blk offset -- ) -10 isfile push loadfile push fromfile push blk push >in push -11 >in ! blk ! isfile@ loadfile ! .status interpret ; -12 -13 : load ( blk --) ?dup 0=exit 0 (load ; -14 -15 -Screen 85 not modified - 0 \ +load thru +thru --> rdepth depth 20Oct86 - 1 - 2 : +load ( offset --) blk @ + load ; - 3 - 4 : thru ( from to --) 1+ swap DO I load LOOP ; - 5 : +thru ( off0 off1 --) 1+ swap DO I +load LOOP ; - 6 - 7 : --> 1 blk +! >in off .status ; immediate - 8 - 9 : rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; -10 : depth ( -- +n) sp@ s0 @ swap - 2/ ; -11 -12 -13 -14 -15 -Screen 86 not modified - 0 \ quit (quit abort UH 25Jan88 - 1 - 2 : (prompt ( -- ) - 3 state @ IF cr ." ] " ELSE ." ok" cr THEN .status ; - 4 - 5 Defer prompt ' (prompt Is prompt - 6 - 7 : (quit BEGIN prompt query interpret REPEAT ; - 8 - 9 Defer 'quit ' (quit Is 'quit -10 : quit r0 @ rp! level off [compile] [ 'quit ; -11 -12 : standardi/o [ output ] Literal output 4 cmove ; -13 -14 Defer 'abort ' noop Is 'abort -15 : abort end-trace clearstack 'abort standardi/o quit ; -Screen 87 not modified - 0 \ (error Abort" Error" 20Oct86 18Nov87 - 1 - 2 Variable scr 1 scr ! Variable r# 0 r# ! - 3 - 4 : (error ( string -- ) standardi/o space here .name - 5 count type space ?cr - 6 blk @ ?dup IF scr ! >in @ r# ! THEN quit ; - 7 ' (error errorhandler ! - 8 - 9 : (abort" "lit swap IF >r clearstack r> -10 errorhandler perform exit THEN drop ; restrict -11 -12 | : (err" "lit swap IF errorhandler perform exit THEN -13 drop ; restrict -14 : Abort" compile (abort" ," align ; immediate restrict -15 : Error" compile (err" ," align ; immediate restrict -Screen 88 not modified - 0 \ -trailing 30Jun86 18Nov87 - 1 - 2 Code -trailing ( addr n1 -- addr n2 ) - 3 D pop H pop H push - 4 D dad xchg D dcx - 5 Label -trail H A mov L ora hpush jz - 6 D ldax BL cpi hpush jnz - 7 H dcx D dcx -trail jmp end-code - 8 - 9 \\ -10 : -trailing ( addr n1 -- addr n2) -11 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; -12 -13 -14 -15 -Screen 89 not modified - 0 \ space spaces 30Jun86 - 1 - 2 $20 Constant bl - 3 - 4 : space bl emit ; - 5 : spaces ( u --) 0 ?DO space LOOP ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 90 not modified - 0 \ hold <# #> sign # #s 17Oct86 - 1 - 2 | : hld ( -- addr) pad 2- ; - 3 - 4 : hold ( char -- ) -1 hld +! hld @ c! ; - 5 - 6 : <# hld hld ! ; - 7 - 8 : #> ( 32b -- addr +n ) 2drop hld @ hld over - ; - 9 -10 : sign ( n -- ) 0< IF Ascii - hold THEN ; -11 -12 : # ( +d1 -- +d2) base @ ud/mod rot 9 over < -13 IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; -14 -15 : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; -Screen 91 not modified - 0 \ print numbers 24Dec83 - 1 - 2 : d.r -rot under dabs <# #s rot sign #> - 3 rot over max over - spaces type ; - 4 - 5 : .r swap extend rot d.r ; - 6 - 7 : u.r 0 swap d.r ; - 8 - 9 : d. 0 d.r space ; -10 -11 : . extend d. ; -12 -13 : u. 0 d. ; -14 -15 -Screen 92 not modified - 0 \ .s list c/l l/s 05Oct87 - 1 - 2 : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; - 3 - 4 $40 Constant c/l \ Screen line length - 5 $10 Constant l/s \ lines per screen - 6 - 7 : list ( blk -- ) - 8 scr ! ." Scr " scr @ u. - 9 l/s 0 DO -10 cr I 2 .r space scr @ block I c/l * + c/l -trailing type -11 LOOP cr ; -12 -13 -14 -15 -Screen 93 not modified - 0 \ multitasker primitives 20Nov87 - 1 - 2 Code end-trace \ patch Next to its original state - 3 $0A A mvi ( IP ldax ) >next sta - 4 $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code - 5 - 6 Code pause >next here 2- ! end-code - 7 - 8 : lock ( addr -- ) dup @ up@ = IF drop exit THEN - 9 BEGIN dup @ WHILE pause REPEAT up@ swap ! ; -10 -11 : unlock ( addr -- ) dup lock off ; -12 -13 Label wake H pop H dcx UP shld -14 6 D lxi D dad M A mov H inx M H mov A L mov sphl -15 H pop RP shld IP pop Next end-code -Screen 94 not modified - 0 \ buffer mechanism 20Oct86 07Oct87 - 1 - 2 User isfile 0 isfile ! \ addr of file control block - 3 Variable fromfile 0 fromfile ! - 4 Variable prev 0 prev ! \ Listhead - 5 | Variable buffers 0 buffers ! \ Semaphor - 6 $408 Constant b/buf \ physikalische Groesse - 7 $400 Constant b/blk - 8 \\ Struktur eines Buffers: 0 : link - 9 2 : file -10 4 : blocknummer -11 6 : statusflags -12 8 : Data ... 1 Kb ... -13 Statusflag bits : 15 1 -> updated -14 file : -1 -> empty buffer, 0 -> no fcb, direct access -15 else addr of fcb ( system dependent ) -Screen 95 not modified - 0 \ search for blocks in memory 30Jun86 - 1 | Variable pred - 2 \ DE:blk BC:file HL:bufadr - 3 - 4 Label thisbuffer? ( Zero = this buffer ) - 5 H push H inx H inx M A mov C cmp 0= - 6 ?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp - 7 0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret - 8 - 9 Code (core? ( blk file -- adr\blk file ) -10 IP H mvx Ipsave shld -11 user' offset D lxi UP lhld D dad -12 M E mov H inx M D mov -13 B pop H pop H push B push D dad xchg -14 prev lhld -15 thisbuffer? call 0= ?[ -Screen 96 not modified - 0 \ search for blocks in memory 30Jun86 - 1 - 2 Label blockfound - 3 D pop D pop 8 D lxi D dad H push ' exit @ jmp ]? - 4 [[ pred shld - 5 M A mov H inx M H mov A L mov - 6 H ora 0= ?[ IPsave lhld H IP mvx Next ]? - 7 thisbuffer? call 0= ?] - 8 xchg pred lhld D ldax A M mov - 9 H inx D inx D ldax A M mov D dcx -10 prev lhld xchg E M mov H inx D M mov -11 H dcx prev shld -12 blockfound jmp end-code -13 -14 -15 -Screen 97 not modified - 0 \ (core? 29Jun86 - 1 \\ - 2 - 3 | : this? ( blk file bufadr -- flag ) - 4 dup 4+ @ swap 2+ @ d= ; - 5 - 6 | : (core? ( blk file -- dataaddr / blk file ) - 7 BEGIN over offset @ + over prev @ this? - 8 IF rdrop 2drop prev @ 8 + exit THEN - 9 2dup >r offset @ + >r prev @ -10 BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN -11 dup r> r> 2dup >r >r rot this? 0= -12 WHILE nip REPEAT -13 dup @ rot ! prev @ over ! prev ! rdrop rdrop -14 REPEAT ; -15 -Screen 98 not modified - 0 \ (diskerr 29Jul86 07Oct87 - 1 - 2 : (diskerr - 3 ." error! r to retry " key $FF and - 4 capital Ascii R = not Abort" aborted" ; - 5 - 6 Defer diskerr - 7 ' (diskerr Is diskerr - 8 - 9 Defer r/w -10 -11 -12 -13 -14 -15 -Screen 99 not modified - 0 \ backup emptybuf readblk 20Oct86 - 1 - 2 | : backup ( bufaddr -- ) dup 6+ @ 0< - 3 IF 2+ dup @ 1+ \ buffer empty if file = -1 - 4 IF input push output push standardi/o - 5 BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w - 6 WHILE ." write " diskerr - 7 REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ; - 8 - 9 : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; -10 -11 | : readblk ( blk file addr -- blk file addr ) -12 dup emptybuf -13 input push output push standardi/o >r -14 BEGIN over offset @ + over r@ 8 + -rot 1 r/w -15 WHILE ." read " diskerr REPEAT r> ; -Screen 100 not modified - 0 \ take mark updates? core? 10Mar86 19Nov87 - 1 - 2 | : take ( -- bufaddr) prev - 3 BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL - 4 buffers lock dup backup ; - 5 - 6 | : mark ( blk file bufaddr -- blk file ) - 7 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off - 8 buffers unlock ; - 9 -10 | : updates? ( -- bufaddr / flag) -11 prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; -12 -13 : core? ( blk file -- addr /false ) (core? 2drop false ; -14 -15 -Screen 101 not modified - 0 \ block & buffer manipulation 20Oct86 18Nov87 - 1 - 2 : (buffer ( blk file -- addr ) - 3 BEGIN (core? take mark REPEAT ; - 4 - 5 : (block ( blk file -- addr ) - 6 BEGIN (core? take readblk mark REPEAT ; - 7 - 8 Code isfile@ ( -- addr ) user' isfile D lxi - 9 UP lhld D dad fetch jmp end-code -10 -11 : buffer ( blk -- addr ) isfile@ (buffer ; -12 -13 : block ( blk -- addr ) isfile@ (block ; -14 -15 \ : isfile@ ( -- addr ) isfile @ ; -Screen 102 not modified - 0 \ block & buffer manipulation 05Oct87 - 1 - 2 : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; - 3 - 4 Defer save-dos-buffers - 5 - 6 : save-buffers ( -- ) buffers lock - 7 BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers - 8 buffers unlock ; - 9 -10 : empty-buffers ( -- ) buffers lock prev -11 BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; -12 -13 : flush save-buffers empty-buffers ; -14 -15 -Screen 103 not modified - 0 \ Allocating buffers 10Oct87 - 1 $10000 Constant limit Variable first - 2 - 3 : allotbuffer ( -- ) - 4 first @ r0 @ - b/buf 2+ u< ?exit - 5 b/buf negate first +! first @ dup emptybuf - 6 prev @ over ! prev ! ; - 7 - 8 : freebuffer ( -- ) first @ limit b/buf - u< - 9 IF first @ backup prev -10 BEGIN dup @ first @ - WHILE @ REPEAT -11 first @ @ swap ! b/buf first +! THEN ; -12 -13 : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; -14 -15 | : init-buffers prev off limit first ! all-buffers ; -Screen 104 not modified - 0 \ endpoints of forget 01Jul86 - 1 - 2 | : |? ( nfa -- flag ) c@ $20 and ; - 3 | : forget? ( adr nfa -- flag ) \ code in heap or above adr ? - 4 name> under 1+ u< swap heap? or ; - 5 - 6 | : endpoints ( addr -- addr symb ) - 7 heap voc-link @ >r - 8 BEGIN r> @ ?dup \ through all Vocabs - 9 WHILE dup >r 4- >r \ link on returnstack -10 BEGIN r> @ >r over 1- dup r@ u< \ until link or -11 swap r@ 2+ name> u< and \ code under adr -12 WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap -13 r@ 2+ |? IF over r@ 2+ forget? -14 IF r@ 2+ (name> 2+ umax THEN \ then update symb -15 THEN REPEAT rdrop REPEAT ; -Screen 105 not modified - 0 \ remove, -words, -tasks 20Oct86 - 1 - 2 : remove ( dic sym thread - dic sym ) - 3 BEGIN dup @ ?dup \ unlink forg. words - 4 WHILE dup heap? - 5 IF 2 pick over u> ELSE 3 pick over 1+ u< THEN - 6 IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; - 7 - 8 | : remove-words ( dic sym -- dic sym ) - 9 voc-link BEGIN @ ?dup -10 WHILE dup >r 4- remove r> REPEAT ; -11 -12 | : remove-tasks ( dic -- ) up@ -13 BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin -14 IF dup @ 2+ @ over ! 2- -15 ELSE @ THEN REPEAT 2drop ; -Screen 106 not modified - 0 \ remove-vocs trim 20Oct86 07Oct87 - 1 - 2 | : remove-vocs ( dic symb -- dic symb ) - 3 voc-link remove thru.vocstack - 4 DO 2dup I @ -rot uwithin - 5 IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP - 6 2dup current @ -rot uwithin - 7 IF [ ' Forth 2+ ] Literal current ! THEN ; - 8 - 9 Defer custom-remove ' noop Is custom-remove -10 -11 | : trim ( dic symb -- ) -12 over remove-tasks remove-vocs remove-words -13 custom-remove heap swap - hallot dp ! 0 last ! ; -14 -15 -Screen 107 not modified - 0 \ deleting words from dict. 01Jul86 18Nov87 - 1 - 2 : clear here dup up@ trim dp ! ; - 3 - 4 : (forget ( adr --) dup heap? Abort" is symbol" - 5 endpoints trim ; - 6 - 7 : forget ' dup [ dp ] Literal @ u< Abort" protected" - 8 >name dup heap? - 9 IF name> ELSE 4- THEN (forget ; -10 -11 : empty [ dp ] Literal @ up@ trim -12 [ udp ] Literal @ udp ! ; -13 -14 -15 -Screen 108 not modified - 0 \ save bye stop? ?cr 18Nov87 - 1 - 2 : save here up@ trim - 3 voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL - 4 up@ origin $100 cmove ; - 5 - 6 : bye flush empty (bye ; - 7 - 8 | : end? key #cr = IF true rdrop THEN ; - 9 -10 : stop? ( -- flag ) key? IF end? end? THEN false ; -11 -12 : ?cr col c/l u> 0=exit cr ; -13 -14 -15 -Screen 109 not modified - 0 \ in/output structure 07Jun86 - 1 - 2 | : Out: Create dup c, 2+ Does> c@ output @ + perform ; - 3 - 4 : Output: Create: Does> output ! ; - 5 0 Out: emit Out: cr Out: type Out: del - 6 Out: page Out: at Out: at? drop - 7 - 8 : row ( -- row) at? drop ; - 9 : col ( -- col) at? nip ; -10 -11 | : In: Create dup c, 2+ Does> c@ input @ + perform ; -12 -13 : Input: Create: Does> input ! ; -14 0 In: key In: key? In: decode In: expect drop -15 -Screen 110 not modified - 0 \ Alias only definitionen 18Nov87 - 1 - 2 Root definitions Forth - 3 - 4 : seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab. - 5 - 6 ' Only Alias Only - 7 ' Forth Alias Forth - 8 ' words Alias words - 9 ' also Alias also -10 ' definitions Alias definitions -11 -12 Host Target -13 -14 -15 -Screen 111 not modified - 0 \ 'restart 'cold 22Oct86 10Oct87 - 1 - 2 Defer 'restart ' noop Is 'restart - 3 - 4 | : (restart ['] (quit Is 'quit drvinit 'restart - 5 [ errorhandler ] Literal @ errorhandler ! - 6 ['] noop Is 'abort clearstack - 7 standardi/o interpret quit ; - 8 - 9 Defer 'cold ' noop Is 'cold -10 -11 | : (cold origin up@ $100 cmove $80 count -12 $50 umin >r tib r@ move r> #tib ! >in off blk off -13 init-vocabularys init-buffers flush 'cold -14 Onlyforth page &24 spaces logo count type cr (restart ; -15 -Screen 112 not modified - 0 \ cold bootsystem 20Oct86 - 1 - 2 Code cold here >cold ! - 3 s0 lhld 6 D lxi D dad origin D lxi $3F C mvi - 4 [[ D ldax A M mov H inx D inx C dcr 0= ?] - 5 ' (cold >body IP lxi - 6 Label bootsystem - 7 s0 lhld 6 D lxi D dad UP shld - 8 user' s0 D lxi D dad - 9 M E mov H inx M D mov xchg sphl -10 user' r0 D lxi UP lhld D dad -11 M E mov H inx M D mov xchg RP shld -12 $C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker ) -13 Next -14 end-code -15 -Screen 113 not modified - 0 \ restart boot 20Oct86 - 1 - 2 Code restart here >restart ! - 3 ' (restart >body IP lxi bootsystem jmp end-code - 4 - 5 Label boot here >boot ! \ find link to Main: - 6 s0 lhld 6 D lxi D dad H B mvx origin D lxi - 7 [[ [[ xchg H inx H inx M E mov H inx M D mov - 8 D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx - 9 6 lhld 0 L mvi ' limit >body shld -10 -$1100 D lxi D dad r0 shld \ set initial RP -11 -$400 D lxi D dad s0 shld \ set initial SP -12 6 D lxi D dad xchg B H mvx -13 D M mov H dcx E M mov \ set link to Maintask -14 >cold 2- jmp -15 end-code -Screen 114 not modified - 0 \ "search 05Mar88 - 1 - 2 Label notfound H pop H pop - 3 IPsave lhld H IP mvx False H lxi hpush jmp - 4 - 5 Code "search ( text tlen buf blen -- addr tf / ff ) - 6 IP H mvx IPsave shld D pop H pop xthl - 7 H A mov L ora notfound jz - 8 E A mov L sub A C mov D A mov H sbb A B mov notfound jc - 9 B inx D pop xthl M A mov xthl H push xchg -10 Label scanfirst -11 A E mov ?capital call E D mov -12 [[ M E mov H inx B A mov C ora notfound jz B dcx -13 ?capital call E A mov D cmp 0= ?] -14 B D mvx B pop xchg xthl xchg H push B push D push -15 -Screen 115 not modified - 0 \ "search part 2 27Nov87 - 1 - 2 Label match - 3 B dcx B A mov C ora 0<> ?[ - 4 D inx D ldax D push A E mov ?capital call E D mov - 5 M E mov H inx ?capital call E A mov D cmp D pop - 6 match jz H pop B pop D pop - 7 M A mov xthl B push H B mvx xchg scanfirst jmp ]? - 8 D pop D pop H pop D pop H dcx H push - 9 IPsave lhld H IP mvx True H lxi hpush jmp -10 end-code -11 -12 -13 -14 -15 -Screen 116 not modified - 0 \ Rest of Standard-System 04Oct87 07Oct87 - 1 - 2 2 +load \ Operating System - 3 - 4 Host ' Transient 8 + @ Transient Forth Context @ 6 + ! - 5 - 6 Target Forth also definitions - 7 - 8 Vocabulary Assembler Assembler definitions - 9 Transient Assembler -10 >Next Constant >Next -11 hpush Constant hpush -12 dpush Constant dpush -13 -14 Target Forth also definitions -15 : forth-83 ; \ last word in Dictionary -Screen 117 not modified - 0 \ System patchup 04Oct87 - 1 - 2 $EF00 r0 ! - 3 $EB00 s0 ! - 4 s0 @ 6 + origin 2+ ! \ link Maintask to itself - 5 - 6 \ s0 und r0 werden beim Booten neu an die Speichergroesse - 7 \ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask - 8 - 9 here dp ! -10 -11 Host Tudp @ Target udp ! -12 Host Tvoc-link @ Target voc-link ! -13 Host move-threads -14 -15 -Screen 118 not modified - 0 \ System dependent Load-Screen 20Nov87 - 1 - 2 1 +load \ CP/M interface - 3 - 4 2 4 +thru \ Character IO - 5 - 6 5 7 +thru \ Default Disk IO - 7 - 8 8 +load \ Postlude - 9 -10 \ 9 +load \ Index -11 -12 -13 -14 -15 -Screen 119 not modified - 0 \ CP/M-Interface 05Oct87 - 1 Vocabulary Dos Dos definitions also - 2 Label >bios pchl - 3 Code biosa ( arg fun -- res ) - 4 1 lhld D pop D dcx D dad D dad D dad - 5 D pop IP push D IP mvx >bios call - 6 Label back - 7 IP pop 0 H mvi A L mov Hpush jmp end-code - 8 - 9 Code bdosa ( arg fun -- res ) -10 H pop D pop IP push L C mov 5 call back jmp -11 end-code -12 -13 : bios ( arg fun -- ) biosa drop ; -14 : bdos ( arg fun -- ) bdosa drop ; -15 -Screen 120 not modified - 0 \ Character-IO Constants Character input 05Oct87 - 1 - 2 Target Dos also - 3 - 4 $08 Constant #bs $0D Constant #cr - 5 $0A Constant #lf $1B Constant #esc - 6 $09 Constant #tab $7F Constant #del - 7 $07 Constant #bel $0C Constant #ff - 8 - 9 : con! ( c -- ) 4 bios ; -10 : (key? ( -- ? ) 0 2 biosa 0= not ; -11 : getkey ( -- c ) 0 3 biosa ; -12 -13 : (key ( -- c ) BEGIN pause (key? UNTIL getkey ; -14 -15 -Screen 121 not modified - 0 \ Character output 07Oct87 UH 27Feb88 - 1 - 2 | Code ?ctrl ( c -- c' ) H pop L A mov - 3 $20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code - 4 - 5 : (emit ( c -- ) ?ctrl con! pause ; - 6 - 7 : (cr #cr con! #lf con! ; - 8 : (del #bs con! bl con! #bs con! ; - 9 : (at? ( -- row col ) 0 0 ; -10 -11 : tipp ( addr len -- ) 0 ?DO count emit LOOP drop ; -12 -13 Output: display [ here output ! ] -14 (emit (cr tipp (del noop 2drop (at? ; -15 -Screen 122 not modified - 0 \ Line input 04Oct87 - 1 - 2 | : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ; - 3 - 4 : (decode ( addr pos1 key -- addr pos2 ) - 5 #bs case? IF backspace exit THEN - 6 #del case? IF backspace exit THEN - 7 #cr case? IF dup span ! space exit THEN - 8 dup emit >r 2dup + r> swap c! 1+ ; - 9 -10 : (expect ( addr len -- ) span ! 0 -11 BEGIN span @ over u> WHILE key decode REPEAT 2drop ; -12 -13 Input: keyboard [ here input ! ] -14 (key (key? (decode (expect ; -15 -Screen 123 not modified - 0 \ Default Disk Interface: Constants and Primitives 18Nov87 - 1 - 2 $80 Constant b/rec b/blk b/rec / Constant rec/blk - 3 - 4 Dos definitions - 5 ' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb - 6 - 7 : dos-error? ( n -- f ) $FF = ; - 8 - 9 $5C Constant fcb -10 : reset ( -- ) 0 &13 bdos ; -11 : openfile ( fcb -- f ) &15 bdosa dos-error? ; -12 : closefile ( fcb -- f ) &16 bdosa dos-error? ; -13 : dma! ( dma -- ) &26 bdos ; -14 : rec@ ( fcb -- f ) &33 bdosa ; -15 : rec! ( fcb -- f ) &34 bdosa ; -Screen 124 not modified - 0 \ Default Disk Interface: open and close 20Nov87 - 1 - 2 Target Dos also Defer drvinit Dos definitions - 3 - 4 | Variable opened - 5 : default ( -- ) opened off - 6 fcb 1+ c@ bl = ?exit $80 count here place #tib off - 7 fcb dup dosfcb> dup isfile ! fromfile ! - 8 openfile Abort" default file not found!" opened on ; - 9 ' default Is drvinit -10 -11 : close-default ( -- ) opened @ not ?exit -12 fcb closefile Abort" can't close default-file!" ; -13 ' close-default Is save-dos-buffers -14 -15 -Screen 125 not modified - 0 \ Default Disk Interface: read/write 14Feb88 - 1 - 2 Target Dos also - 3 - 4 | : rec# ( 'dosfcb -- 'rec# ) &33 + ; - 5 - 6 : (r/w ( adr blk file r/wf -- flag ) >r - 7 dup 0= Abort" no Direct Disk IO supported! " >dosfcb - 8 swap rec/blk * over rec# 0 over 2+ c! ! - 9 r> rot b/blk bounds -10 DO I dma! 2dup IF rec@ drop -11 ELSE rec! IF 2drop true endloop exit THEN THEN -12 over rec# 0 over 2+ c! 1 swap +! -13 b/rec +LOOP 2drop false ; -14 -15 ' (r/w Is r/w -Screen 126 not modified - 0 \ Postlude 20Nov87 - 1 - 2 Defer postlude - 3 - 4 | : (bye ( -- ) postlude 0 0 bdos ; - 5 - 6 | : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ; - 7 - 8 : .size ( -- ) base push decimal - 9 cr ." Size: &" #pages u. ." Pages" ; -10 -11 ' .size Is postlude -12 -13 -14 -15 -Screen 127 not modified - 0 \ index findex 20Nov87 - 1 - 2 | : range ( from to -- to+1 from ) - 3 2dup > IF swap THEN 1+ swap ; - 4 - 5 : index ( from to --) - 6 range DO cr I 4 .r I space block c/l type - 7 stop? IF LEAVE THEN LOOP ; - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/STARTUP.FB.src b/sources/cpm/STARTUP.FB.src deleted file mode 100644 index d8b95f2..0000000 --- a/sources/cpm/STARTUP.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \\ Startup: Load Standard System UH 11Nov86 - 1 - 2 Dieses File enthaelt Befehle, die aus dem File KERNEL.COM - 3 ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM - 4 als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87 - 1 include ass8080.fb - 2 include xinout.fb \ extended I/O - 3 include terminal.fb save \ Terminal - 4 include copy.fb cr .( copy and convey loaded) cr - 5 include savesys.fb cr .( Savesystem loaded) cr - 6 include editor.fb cr .( Editor loaded) cr - 7 include tools.fb cr .( Tools loaded) cr - 8 include see.fb cr .( Decompiler loaded) cr - 9 include tasker.fb cr .( Multitasker loaded) cr -10 include printer.fb cr .( Printer Interface loaded) cr -11 include relocate.fb cr .( Relocating loaded) cr -12 -13 .( May the volksFORTH be with you ...) cr decimal caps on -14 scr off r# off savesystem volks4th.com -15 diff --git a/sources/cpm/TARGET.FB.src b/sources/cpm/TARGET.FB.src deleted file mode 100644 index 63a038f..0000000 --- a/sources/cpm/TARGET.FB.src +++ /dev/null @@ -1,578 +0,0 @@ -Screen 0 not modified - 0 \ 05Jul86 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Target compiler loadscr UH 07Jun86 - 1 \ Idea and first Implementation by ks/bp - 2 \ Implemented on 6502 by ks/bp - 3 \ ultraFORTH83-Version by bp/we - 4 \ Atari 520 ST - Version by we - 5 \ CP/M 2.2 Version by UH - 6 - 7 Onlyforth hex Assembler nonrelocate - 8 Vocabulary Ttools - 9 Vocabulary Defining -10 1 10 +thru \ Target compiler -11 11 13 +thru \ Target Tools -12 14 16 +thru \ Redefinitions -13 save 17 20 +thru \ Predefinitions -14 -15 Onlyforth -Screen 2 not modified - 0 \ Target header pointers UH 26Mar88 - 1 - 2 Create lastname $20 allot - 3 Variable tdp : there tdp @ ; - 4 Variable displace - 5 Variable image - 6 Variable ?thead ?thead off - 7 Variable tlast tlast off - 8 Variable glast' glast' off - 9 Variable tdoes> -10 Variable >in: -11 Variable tvoc tvoc off -12 Variable tvoc-link tvoc-link off -13 0 | Constant -14 0 | Constant -15 | : Is> ( cfa -- ) [compile] Does> here 3 - swap >body ! 0 ] ; -Screen 3 not modified - 0 \ Image and byteorder UH 26Mar88 - 1 - 2 Code c+! ( 8b addr -- ) - 3 H pop D pop E A mov M add A M mov Next end-code - 4 - 5 Code /block ( addr -- +n blk ) - 6 H pop L E mov H A mov 3 ani A D mov - 7 H A mov $FC ani rrc rrc A L mov 0 H mvi dpush jmp - 8 end-code - 9 -10 : >image ( addr1 - addr2 ) -11 displace @ ( - /block image @ + block ) + ; -12 -13 : >heap ( from quan - ) dup hallot heap swap cmove ; -14 \\ : c+! ( 8b addr -- ) dup c@ rot + swap c! ; -15 : /block ( addr -- +n blk ) b/blk /mod ; -Screen 4 not modified - 0 \ Ghost-creating UH 26Mar88 - 1 - 2 | : (make.ghost ( str -- cfa.ghost ) dp push - 3 count dup 1 $1F uwithin not Abort" invalid Ghostname" - 4 here 2+ place - 5 here state @ \ address of link field - 6 IF context @ ELSE current THEN @ under @ , \ link - 7 1 here c+! here c@ allot bl c, \ name - 8 here over - swap \ offset to codefield - 9 , 0 , 0 , \ code and parameter field -10 here over - >heap \ move to heap -11 heap rot ! \ link -12 heap + ; \ codefield address -13 -14 | : Make.Ghost ( -- cfa.ghost ) name (make.ghost ; -15 -Screen 5 not modified - 0 \ ghost words UH 28Apr88 - 1 - 2 : gfind ( string - cfa tf / string ff ) - 3 >r bl r@ count + c! 1 r@ c+! r@ find -1 r> c+! ; - 4 - 5 : (ghost ( string -- cfa ) gfind ?exit (make.ghost ; - 6 - 7 : ghost ( -- cfa ) name (ghost ; - 8 - 9 : gdoes> ( cfa.ghost - cfa.does ) dp push -10 4+ dup @ IF @ exit THEN \ defined -11 here , 0 , 4 >heap \ forward-chain -12 heap dup rot ! ; \ forward-link -13 -14 -15 -Screen 6 not modified - 0 \ ghost utilities 2UH 26Mar88 - 1 - 2 : g' ( -- cfa.ghost ) name gfind 0= abort" ?" ; - 3 - 4 | : .ghost-type ( cfa.ghost -- ) @ - 5 case? IF ." forward" exit THEN - 6 - Abort" type unknown" ." resolved " ; - 7 - 8 | : .does-type ( cfa.does -- ) @ - 9 case? IF ." forward-define" exit THEN -10 - Abort" does-type unknown" ." resolved-define" ; -11 -12 : '. ( -- ) g' dup .ghost-type dup 2+ @ 5 u.r -13 4+ @ ?dup 0=exit dup .does-type 2+ @ 5 u.r ; -14 -15 ' ' Alias h' -Screen 7 not modified - 0 \ .unresolved UH 26Mar88 - 1 - 2 | : forward? ( cfa -- f ) dup @ = swap 2+ @ and ; - 3 | : ghost? ( nfa -- f ) count $1F and + 1- c@ bl = ; - 4 - 5 | : unresolved? ( addr - f ) 2+ - 6 dup ghost? not IF drop false exit THEN - 7 name> dup forward? IF drop true exit THEN - 8 4+ @ forward? ; - 9 -10 | : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE -11 dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ; -12 -13 : .unresolved ( -- ) voc-link @ -14 BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; -15 -Screen 8 not modified - 0 \ Extending Vocabularys for Target-Compilation 2UH 26Mar88 - 1 - 2 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; - 3 - 4 Vocabulary Transient tvoc off - 5 - 6 Root definitions - 7 - 8 : T Transient ; immediate - 9 : H Forth ; immediate -10 -11 OnlyForth -12 -13 -14 -15 -Screen 9 not modified - 0 \ Transient primitives UH 26Mar88 - 1 - 2 Code byte> ( 8bl 8bh -- 16b ) - 3 D pop H pop E H mov hpush jmp end-code - 4 Code >byte ( 16b -- 8bh 8bl ) - 5 H pop H E mov 0 H mvi H D mov dpush jmp end-code - 6 - 7 Transient definitions - 8 : c@ ( addr -- 8b ) H >image c@ ; - 9 : c! ( 8b addr -- ) H >image c! ( update ) ; -10 : @ ( addr -- n ) dup T c@ H swap 1+ T c@ H byte> ; -11 : ! ( n addr -- ) >r >byte r@ T c! H r> 1+ T c! H ; -12 : cmove ( from.mem to.target quan -) -13 bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; -14 : on ( addr -- ) true swap T ! H ; -15 : off ( addr -- ) false swap T ! H ; -Screen 10 not modified - 0 \ Transient primitives UH 26Mar88 - 1 - 2 : here ( -- taddr ) there ; - 3 : allot ( n -- ) Tdp +! ; - 4 : c, ( c -- ) T here c! 1 allot H ; - 5 : , ( n -- ) T here ! 2 allot H ; - 6 - 7 : ," ( -- ) Ascii " parse - 8 dup T c, under here swap cmove allot H ; - 9 -10 : fill ( addr len c -- ) -11 -rot bounds ?DO dup I T c! H LOOP drop ; -12 -13 : erase ( addr len -- ) 0 T fill H ; -14 : blank ( addr len -- ) bl T fill H ; -15 : here! ( addr -- ) H tdp ! ; -Screen 11 not modified - 0 \ Resolving UH 26Mar88 - 1 - 2 Forth definitions - 3 - 4 : resolve ( cfa.ghost cfa.target -- ) - 5 2dup swap >body dup @ >r ! over @ = - 6 IF drop >name space .name ." exists" ?cr rdrop exit THEN - 7 r> swap >r rot ! ?dup 0= IF rdrop exit THEN - 8 BEGIN dup T @ H 2dup = abort" resolve loop" - 9 r@ rot T ! H ?dup 0= UNTIL rdrop ; -10 -11 : resdoes> ( cfa.ghost cfa.target -- ) -12 swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; -13 -14 ' Is> ( -- ) dup @ there rot ! T , H ; \ forward link -15 ' Is> ( -- ) @ T , H ; \ compile target.cfa -Screen 12 not modified - 0 \ move-threads UH 26Mar88 - 1 - 2 : move-threads Tvoc @ Tvoc-link @ - 3 BEGIN over ?dup - 4 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT - 5 error" some undef. Target-Vocs left" drop ; - 6 - 7 | : tlatest ( - addr) Current @ 6 + ; - 8 - 9 -10 : save-target \ filename -11 $100 dup >image there rot - savefile ; -12 -13 -14 -15 -Screen 13 not modified - 0 \ compiling names into targ. UH 26Mar88 - 1 - 2 | : viewfield ( -- n ) H blk @ $200 + ; \ in File #1 - 3 - 4 : (theader ( -- ) ?thead @ IF 1 ?thead +! exit THEN - 5 >in push - 6 name dup c@ 1 $20 uwithin not abort" invalid Targetname" - 7 viewfield T , - 8 H there tlatest @ T , H tlatest ! \ link - 9 there dup tlast ! -10 over c@ 1+ dup T allot cmove H ; -11 -12 : Theader ( -- ) tlast off -13 (theader Ghost dup glast' ! there resolve ; -14 -15 -Screen 14 not modified - 0 \ prebuild defining words bp2UH 26Mar88 - 1 - 2 | : executable? ( adr - adr f ) dup ; - 3 | : tpfa, there , ; - 4 - 5 | : (prebuild ( cfa.adr -- ) >in push Create here 2- ! ; - 6 - 7 : prebuild ( adr 0.from.: - 0 ) 0 ?pairs - 8 executable? dup >r - 9 IF [compile] Literal compile (prebuild ELSE drop THEN -10 compile Theader Ghost gdoes> , -11 r> IF compile tpfa, THEN 0 ; immediate restrict -12 -13 -14 -15 -Screen 15 not modified - 0 \ code portion of def.words bp2UH 26Mar88 - 1 - 2 : dummy 0 ; - 3 - 4 : DO> ( - adr.of.jmp.dodoes> 0 ) - 5 [compile] Does> here 3 - compile @ 0 ] ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \ The Target-Assembler UH 26Mar88 - 1 - 2 - 3 Forth definitions - 4 | Create relocate ] T c, , c@ here allot ! c! H [ - 5 - 6 Transient definitions - 7 - 8 : Assembler H [ Assembler ] relocate >codes ! Assembler ; - 9 : >label ( 16b -) H >in @ name gfind rot >in ! -10 IF over resolve dup THEN drop Constant ; -11 : Label H there T >label Assembler H ; -12 : Code H Theader there 2+ T , Assembler H ; -13 -14 -15 -Screen 17 not modified - 0 \ immed. restr. ' \ compile bp2UH 26Mar88 - 1 - 2 : ?pairs ( n1 n2 -- ) H - abort" unstructured" ; - 3 : >mark ( - addr) H there T 0 , H ; - 4 : >resolve ( addr -) H there over - swap T ! H ; - 5 : - cfa) H g' dup @ - abort" ?" 2+ @ ; -10 : | H ?thead @ ?exit ?thead on ; -11 : compile H Ghost , ; immediate restrict -12 -13 -14 -15 -Screen 18 not modified - 0 \ Target tools UH 26Mar88 - 1 Onlyforth Ttools also definitions - 2 - 3 | : ttype ( adr n -) bounds ?DO I T c@ H dup - 4 bl > IF emit ELSE drop ascii . emit THEN LOOP ; - 5 - 6 : .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype - 7 ELSE ." ??? " THEN space ?cr ; - 8 - 9 | : nfa? ( cfa lfa - nfa / cfa ff) -10 BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ = -11 IF 2+ nip exit THEN T @ H REPEAT ; -12 -13 : >name ( cfa - nfa / ff) -14 Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup -15 IF nip exit THEN swap REPEAT nip ; -Screen 19 not modified - 0 \ Ttools for decompiling ks29jun85we - 1 - 2 | : ?: dup 4 u.r ." :" ; - 3 | : @? dup T @ H 6 u.r ; - 4 | : c? dup T c@ H 3 .r ; - 5 - 6 : s ( adr - adr+) ?: space c? 3 spaces - 7 dup 1+ over T c@ H ttype dup T c@ H + 1+ ; - 8 - 9 : n ( adr - adr+2) ?: @? 2 spaces -10 dup T @ H [ Ttools ] >name .name H 2+ ; -11 -12 : d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP -13 2 spaces -rot ttype ; -14 -15 -Screen 20 not modified - 0 \ Tools for decompiling bp204dec85we - 1 - 2 : l ( adr - adr+2) ?: 5 spaces @? 2+ ; - 3 - 4 : c ( adr - adr+1) 1 d ; - 5 - 6 : b ( adr - adr+1) ?: @? dup T @ H over + 5 u.r 2+ ; - 7 - 8 : dump ( adr n -) bounds ?DO cr I 10 d drop stop? - 9 IF LEAVE THEN 10 +LOOP ; -10 -11 : view T ' H [ Ttools ] >name ?dup -12 IF 4 - T @ H list THEN ; -13 -14 -15 -Screen 21 not modified - 0 \ reinterpretation def.-words UH 26Mar88 - 1 - 2 Onlyforth - 3 - 4 : redefinition ( -- ) tdoes> @ 0=exit - 5 >in push [ ' parser >body ] Literal push - 6 state push context push - 7 >in: @ >in ! name [ ' Transient 2+ ] Literal (find nip ?exit - 8 cr ." Redefinition: " here .name - 9 >in: @ >in ! : Defining interpret tdoes> off ; -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 \ Create..does> structure 27Apr86 - 1 - 2 | : (;tcode Tlast @ dup T c@ + 1+ ! H rdrop ; - 3 - 4 | : changecfa compile lit tdoes> @ , compile (;tcode ; - 5 - 6 Defining definitions - 7 - 8 : ;code 0 ?pairs changecfa reveal rdrop rdrop ; - 9 immediate restrict -10 -11 Defining ' ;code Alias does> immediate restrict -12 -13 : ; [compile] ; rdrop rdrop ; immediate restrict -14 -15 -Screen 23 not modified - 0 \ redefinition conditionals bp27jun85we - 1 - 2 ' DO Alias DO immediate restrict - 3 ' ?DO Alias ?DO immediate restrict - 4 ' LOOP Alias LOOP immediate restrict - 5 ' IF Alias IF immediate restrict - 6 ' THEN Alias THEN immediate restrict - 7 ' ELSE Alias ELSE immediate restrict - 8 ' BEGIN Alias BEGIN immediate restrict - 9 ' UNTIL Alias UNTIL immediate restrict -10 ' WHILE Alias WHILE immediate restrict -11 ' REPEAT Alias REPEAT immediate restrict -12 -13 -14 -15 -Screen 24 not modified - 0 \ clear Liter. Ascii ['] ." UH 26Mar88 - 1 - 2 Onlyforth Transient definitions - 3 - 4 : clear True abort" There are ghosts" ; - 5 : Literal ( n -) H dup $FF00 and IF T compile lit , H exit THEN - 6 T compile clit c, H ; immediate - 7 : Ascii H bl word 1+ c@ - 8 state @ 0=exit T [compile] Literal H ; immediate - 9 : ['] T ' [compile] Literal H ; immediate restrict -10 : " T compile (" ," H ; immediate restrict -11 : ." T compile (." ," H ; immediate restrict -12 -13 : even H ; immediate \ machen nichts beim 8080 -14 : align H ; immediate -15 : halign H ; immediate -Screen 25 not modified - 0 \ Target compilation ] [ bp0UH 26Mar88 - 1 - 2 Forth definitions - 3 - 4 : tcompile ( str -- ) count lastname place - 5 lastname find ?dup - 6 IF 0> IF execute exit THEN drop lastname THEN - 7 gfind IF execute exit THEN - 8 number? ?dup - 9 IF 0> IF swap T [compile] Literal THEN -10 [compile] Literal H exit THEN -11 (ghost execute ; -12 -13 Transient definitions -14 : ] H State on ['] tcompile is parser ; -15 -Screen 26 not modified - 0 \ Target conditionals bp27jun85we - 1 - 2 : IF T compile ?branch >mark H 1 ; immediate restrict - 3 : THEN abs 1 T ?pairs >resolve H ; immediate restrict - 4 : ELSE T 1 ?pairs compile branch >mark swap >resolve - 5 H -1 ; immediate restrict - 6 : BEGIN T mark -2 H 2swap ; - 8 immediate restrict - 9 | : (repeat T 2 ?pairs resolve H REPEAT ; -11 : UNTIL T compile ?branch (repeat H ; immediate restrict -12 : REPEAT T compile branch (repeat H ; immediate restrict -13 -14 -15 -Screen 27 not modified - 0 \ Target conditionals bp27jun85we - 1 - 2 : DO T compile (do >mark H 3 ; immediate restrict - 3 : ?DO T compile (?do >mark H 3 ; immediate restrict - 4 : LOOP T 3 ?pairs compile (loop compile endloop - 5 >resolve H ; immediate restrict - 6 : +LOOP T 3 ?pairs compile (+loop compile endloop - 7 >resolve H ; immediate restrict - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 28 not modified - 0 \ predefinitions bp27jun85we - 1 - 2 : abort" T compile (abort" ," H ; immediate - 3 : error" T compile (err" ," H ; immediate - 4 - 5 Forth definitions - 6 - 7 Variable torigin - 8 Variable tudp 0 tudp ! - 9 -10 : >user T c@ H torigin @ + ; -11 -12 -13 -14 -15 -Screen 29 not modified - 0 \ Datatypes bp2UH 07Nov87 - 1 - 2 Transient definitions - 3 : origin! H torigin ! ; - 4 : user' ( - 8b) T ' 2 + c@ H ; - 5 : uallot ( n -) H tudp @ swap tudp +! ; - 6 - 7 DO> >user ; - 8 : User prebuild User 2 T uallot c, ; - 9 -10 DO> ; -11 : Create prebuild (create ; -12 -13 DO> T @ H ; -14 : Constant prebuild Constant T , ; -15 : Variable Create 2 T allot ; -Screen 30 not modified - 0 \ Datatypes UH 07Nov87 - 1 - 2 dummy - 3 : Vocabulary - 4 H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , - 5 here H tvoc-link @ T , H tvoc-link ! ; - 6 - 7 - 8 dummy - 9 : (create prebuild (create ; -10 -11 -12 -13 -14 -15 -Screen 31 not modified - 0 \ target defining words 27Apr86 - 1 - 2 Do> ; - 3 : Defer prebuild Defer 2 T allot ; - 4 : Is T ' H >body State @ IF T compile (is , H - 5 ELSE T ! H THEN ; immediate - 6 | : dodoes> T compile (;code H Glast' @ - 7 there resdoes> there tdoes> ! ; - 8 - 9 : ;code 0 T ?pairs dodoes> Assembler H [compile] [ -10 redefinition ; immediate restrict -11 : does> T dodoes> $CD c, -12 compile (dodoes> H ; immediate restrict -13 -14 -15 -Screen 32 not modified - 0 \ : Alias ; bUH 07Jun86 - 1 - 2 dummy - 3 : : H tdoes> off >in @ >in: ! T prebuild : - 4 H current @ context ! T ] H 0 ; - 5 - 6 : Create: Create H current @ context ! T ] H 0 ; - 7 - 8 : Alias ( n -- ) H Tlast off (theader Ghost over resolve - 9 tlast @ T c@ H 20 or tlast @ T c! , H ; -10 -11 : ; T 0 ?pairs compile unnest [compile] [ H redefinition ; -12 immediate restrict -13 -14 -15 -Screen 33 not modified - 0 \ predefinitions UH 26Mar88 - 1 - 2 : compile T compile compile H ; immediate restrict - 3 : Host H Onlyforth Ttools also ; - 4 : Compiler T Host H Transient also definitions ; - 5 : [compile] H ghost execute ; immediate restrict - 6 \ : Onlypatch H there 3 - 0 tdoes> ! 0 ; - 7 - 8 Onlyforth - 9 : Target Onlyforth Transient also definitions ; -10 -11 Transient definitions -12 Ghost c, drop -13 -14 -15 diff --git a/sources/cpm/TASKER.FB.src b/sources/cpm/TASKER.FB.src deleted file mode 100644 index 772b405..0000000 --- a/sources/cpm/TASKER.FB.src +++ /dev/null @@ -1,119 +0,0 @@ -Screen 0 not modified - 0 \\ Multitasker 11Nov86 - 1 - 2 Dieses File enthaelt den Multitasker des volksFORTHs. - 3 Er ist ein Round-Robin-Multitasker, d.h. jede Task behaelt - 4 die Kontrolle ueber den Prozessor solange, bis sie sie - 5 ausdruecklich abgibt. - 6 Hintergrundtasks im volksFORTH koennen durch Semaphore geordnet - 7 auf den Massenspeicher und auf den Drucker zugreifen. - 8 - 9 In Verbindung mit dem Printer-Interface ist es moeglich -10 Files im Hintergrund auszudrucken. (SPOOL) -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Multitasker Loadscreen 27Jun86 20Nov87 - 1 - 2 Onlyforth - 3 - 4 \needs multitask 1 +load - 5 - 6 02 05 +thru \ Tasker - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ stop singletask multitask 28Aug86 20Nov87 - 1 - 2 Code stop UP lhld 0 ( nop ) M mvi - 3 Label taskpause - 4 IP push RP lhld H push UP lhld 6 D lxi D dad xchg - 5 H L mov SP dad xchg E M mov H inx D M mov - 6 UP lhld H inx pchl - 7 end-code - 8 - 9 : singletask [ ' pause @ ] Literal ['] pause ! ; -10 -11 : multitask [ taskpause ] Literal ['] pause ! ; -12 -13 -14 -15 -Screen 3 not modified - 0 \ pass activate 28Aug86 - 1 - 2 : pass ( n0 ... nr-1 Taddr r -- ) - 3 BEGIN [ rot ( Trick !! ) ] - 4 swap $F7 over c! \ awake Task ( rst 6 ) - 5 r> -rot \ Stack: IP r addr - 6 8 + >r \ s0 of Task - 7 r@ 2+ @ swap \ Stack: IP r0 r - 8 2+ 2* \ bytes on Taskstack incl. r0 & IP - 9 r@ @ over - \ new SP -10 dup r> 2- ! \ into Ssave -11 swap bounds ?DO I ! 2 +LOOP ; restrict -12 -13 : activate ( Taddr -- ) -14 0 [ -rot ( Trick !! ) ] REPEAT ; restrict -15 -Screen 4 not modified - 0 \ sleep wake taskerror 28Aug86 20Nov87 - 1 - 2 : sleep ( Taddr -- ) $00 ( nop ) swap c! ; - 3 : wake ( Taddr -- ) $F7 ( rst 6 ) swap c! ; - 4 - 5 | : taskerror ( string -- ) - 6 standardi/o singletask ." Task error : " count type - 7 multitask stop ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ Task 20Nov87 - 1 - 2 : Task ( rlen slen -- ) - 3 0 Constant here 2- >r \ addr of task constant - 4 here -rot \ here for Task dp - 5 even allot even \ allot dictionary area - 6 here r@ ! \ set task constant addr - 7 up@ here $100 cmove \ init user area - 8 here dup $C300 , \ nop-jmp opcode to sleep task - 9 up@ 2+ dup @ , ! \ link task -10 r> , \ spare used for pointer to header -11 dup 6 - dup , , \ ssave and s0 -12 2dup + , \ here + rlen = r0 -13 rot , \ dp -14 under + dp ! 0 , \ allot rstack -15 ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; -Screen 6 not modified - 0 \ rendezvous 's tasks 27Jun86 20Nov87 - 1 - 2 : rendezvous ( semaphoraddr -- ) dup unlock pause lock ; - 3 - 4 | : statesmart state @ IF [compile] Literal THEN ; - 5 - 6 : 's ( Taddr -- adr.of.tasks.userarea ) - 7 ' >body c@ + statesmart ; immediate - 8 - 9 : tasks ( -- ) ." Main " cr up@ dup 2+ @ -10 BEGIN 2dup - WHILE dup 4+ @ body> >name .name -11 dup c@ 0= ( nop ) IF ." sleeping" THEN cr -12 2+ @ REPEAT 2drop ; -13 -14 -15 diff --git a/sources/cpm/TERMINAL.FB.src b/sources/cpm/TERMINAL.FB.src deleted file mode 100644 index d95c095..0000000 --- a/sources/cpm/TERMINAL.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \\ Terminal-Anpassung UH 08OCt87 - 1 - 2 In diesem File wird volksFORTH an das benutzte Terminal - 3 angepasst. Ueber folgende Faehigkeiten muss das Terminal - 4 verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt - 5 werden koennen: - 6 - 7 curon, curoff \ Ein- bzw. Ausschalten des Cursors - 8 rvson, rvsoff \ Ein- bzw. Ausschalten der Inversedarstellung - 9 dark \ Loeschen des Bildschirms -10 locate \ Positionieren des Cursors auf eine -11 \ bestimmte Position auf dem Bildschirm -12 -13 In der Version 3.80a nicht mehr in der Terminal-Anpassung: -14 -15 curleft, currite \ Cursor nach links bzw. rechts bewegen -Screen 1 not modified - 0 \ Anpassung fuer ANSI-Terminal uho 09May2005 - 1 | : ccon!! ( addr len -- ) bounds ?DO I C@ con! LOOP ; - 2 | : con!! ( addr -- ) count ccon!! ; - 3 | : ## ( n -- ) base push decimal 0 <# #S #> ccon!! ; - 4 | : csi ( -- ) #esc con! Ascii [ con! ; - 5 | : ANSIcuron ( -- ) csi " ?25h" con!! ; - 6 | : ANSIcuroff ( -- ) csi " ?25l" con!! ; - 7 | : ANSIrvson ( -- ) csi " 7m" con!! ; - 8 | : ANSIrvsoff ( -- ) csi " 0m" con!! ; - 9 | : ANSIdark ( -- ) csi " 2J" con!! csi " ;H" con!! ; -10 | : ANSIlocate ( row col -- ) -11 csi swap 1+ ## ascii ; con! 1+ ## ascii H con! ; -12 -13 Terminal: ANSI -14 noop noop ANSIrvson ANSIrvsoff ANSIdark ANSIlocate ; -15 ANSI page rvson .( ANSI Terminal installiert. ) rvsoff cr cr diff --git a/sources/cpm/TIMES.FB.src b/sources/cpm/TIMES.FB.src deleted file mode 100644 index 44da075..0000000 --- a/sources/cpm/TIMES.FB.src +++ /dev/null @@ -1,34 +0,0 @@ -Screen 0 not modified - 0 \\ Times Often: interactive loops 11Nov86 - 1 - 2 Dieses File enthaelt die Definitionen der beiden Utility-Worte - 3 TIMES, OFTEN, die interaktiv benutzt werden koennen, was - 4 normalerweise mit BEGIN WHILE ... nicht moeglich ist. - 5 - 6 Benutzung: nur interaktiv! - 7 - 8 a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal, - 9 \ oder bis eine Taste gedrueckt wird, oder -10 \ bis ein Fehler auftritt, -11 -12 a b ... often \ Wiederhole die Befehlsfolge "a b ..." -13 \ so oft, bis eine Taste gedrueckt wird, oder -14 \ bis ein Fehler auftritt. -15 -Screen 1 not modified - 0 \ Times, Often 02feb86 - 1 - 2 also Forth definitions - 3 - 4 : often stop? ?exit >in off ; - 5 - 6 | Variable #times #times off - 7 - 8 : times ( n --) - 9 ?dup IF #times @ 2+ u< stop? or -10 IF #times off exit THEN 1 #times +! -11 ELSE stop? ?exit THEN >in off ; -12 -13 toss definitions -14 -15 diff --git a/sources/cpm/TOOLS.FB.src b/sources/cpm/TOOLS.FB.src deleted file mode 100644 index 0628184..0000000 --- a/sources/cpm/TOOLS.FB.src +++ /dev/null @@ -1,306 +0,0 @@ -Screen 0 not modified - 0 \\ Tools 11Nov86 - 1 Dieses File enthaelt die wichtigsten Werkzeuge zur Programm- - 2 entwicklung: - den einfachen Decompiler - 3 - der DUMP-Befehl - 4 - den Tracer - 5 - 6 Der einfache Decompiler wird benutzt, um neue Defining-Words - 7 zu ueberpruefen. Der automatische Decompiler kann ja dafuer - 8 nicht benutzt werden, da ihm diese Strukturen unbekannt sind. - 9 (Benutzung: addr und dann, je nach Art: S N D L C oder B) -10 -11 DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP) -12 -13 Der Tracer erlaubt Einzelschrittausfuehrung von Worten. -14 Er ist unentbehrliches Hilfsmittel bei der Fehlersuche. -15 (Benutzung: DEBUG und END-TRACE) -Screen 1 not modified - 0 \ Programming-Tools word set / tracer cas 19july2020 - 1 - 2 Onlyforth Vocabulary Tools Tools also definitions - 3 - 4 01 05 +thru &15 &16 +thru - 5 06 +load \ Tracer - 6 - 7 Onlyforth - 8 - 9 : internal \ start headerless definitions -10 1 ?head ! ; -11 -12 : external \ end headerless definitions -13 ?head off ; -14 -15 -Screen 2 not modified - 0 \ Tools for decompiling 22feb86 - 1 - 2 | : ?: dup 4 u.r ." :" ; - 3 | : @? dup @ 6 u.r ; - 4 | : c? dup c@ 3 .r ; - 5 - 6 : s ( adr - adr+ ) - 7 ?: space c? 3 spaces dup 1+ over c@ type dup c@ + 1+ even ; - 8 - 9 : n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ; -10 : d ( adr n - adr+n) -11 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ; -12 -13 -14 -15 -Screen 3 not modified - 0 \ Tools for decompiling 22feb86 - 1 - 2 : l ( adr - adr+2 ) ?: 5 spaces @? 2+ ; - 3 : c ( adr - adr+1) 1 d ; - 4 : b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ; - 5 - 6 - 7 - 8 \\ - 9 : dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE -10 THEN 10 +LOOP ; -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ General Dump Utility - Output UH 07Jun86 - 1 - 2 | : .2 ( n -- ) 0 <# # # #> type space ; - 3 | : .6 ( d -- ) <# # # # # # # #> type ; - 4 | : d.2 ( addr len -- ) bounds ?DO I C@ .2 LOOP ; - 5 | : emit. ( char -- ) - 6 $7F and dup bl $7E uwithin not IF drop Ascii . THEN emit ; - 7 | : dln ( addr --- ) - 8 cr dup 6 u.r 2 spaces 8 2dup d.2 space - 9 over + 8 d.2 space $10 bounds ?DO I C@ EMIT. LOOP ; -10 | : ?.n ( n1 n2 -- n1 ) -11 2dup = IF ." \/" drop ELSE 2 .r THEN space ; -12 | : ?.a ( n1 n2 -- n1 ) -13 2dup = IF ." V" drop ELSE 1 .r THEN ; -14 -15 -Screen 5 not modified - 0 \ .head UH 03Jun86 - 1 - 2 - 3 | : .head ( addr len -- addr' len' ) - 4 swap dup -$10 and swap $0F and cr 8 spaces - 5 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP - 6 space $10 0 DO I ?.a LOOP rot + ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 \ Dump and Fill Memory Utility UH 25Aug86 - 1 - 2 Forth definitions - 3 - 4 : dump ( addr len -- ) - 5 base push hex .head - 6 bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ; - 7 - 8 Tools definitions - 9 -10 : du ( addr -- addr+$40 ) dup $40 dump $40 + ; -11 -12 : dl ( line# -- ) c/l * scr @ block + c/l dump ; -13 -14 Forth definitions -15 -Screen 7 not modified - 0 \ Trace Loadscreen 29Jun86 - 1 - 2 Onlyforth \needs Tools Vocabulary Tools - 3 Tools also definitions - 4 - 5 1 8 +thru - 6 - 7 Onlyforth - 8 - 9 \ clear -10 -11 \ don't forget END-TRACE after using DEBUG -12 -13 -14 -15 -Screen 8 not modified - 0 \ Variables do-trace UH 04Nov86 - 1 - 2 | Variable Wsave \ Variable for saving W - 3 | Variable \ end of trace trap range - 5 | Variable 'ip \ holds IP (preincrement!) - 6 | Variable nest? \ True if NEST shall be performed - 7 | Variable newnext \ Address of new Next for tracing - 8 | Variable #spaces \ for indenting nested trace - 9 | Variable tracing \ true if trace mode active -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ install Tracer UH 18Nov87 - 1 - 2 Tools definitions - 3 - 4 | Code do-trace \ patch Next to new definition - 5 $C3 A mvi ( jmp ) >next sta - 6 newnext lhld >next 1+ shld Next - 7 end-code - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ throw status on Return-Stack 29Jun86 - 1 - 2 | Create: npull - 3 rp@ count 2dup + even rp! r> swap cmove ; - 4 - 5 : npush ( addr len --) r> -rot over >r - 6 rp@ over 1+ - even dup rp! place npull >r >r ; - 7 - 8 | : oneline .status space query interpret -&82 allot - 9 rdrop ( delete quit from tracenext ) ; -10 -11 -12 -13 -14 -15 -Screen 11 not modified - 0 \ reenter tracer 04Nov86 - 1 - 2 | Code (step - 3 true H lxi tracing shld IP rpop Wsave lhld H W mvx - 4 Label fnext - 5 xchg - 6 M E mov H inx M D mov xchg pchl - 7 end-code - 8 - 9 | Create: nextstep (step ; -10 -11 | : (debug ( addr --) \ start tracing at addr -12 dup ! ; -14 -15 -Screen 12 not modified - 0 \ check trace conditions 04Nov86 - 1 - 2 Label tracenext tracenext newnext ! - 3 IP ldax IP inx A L mov IP ldax IP inx A H mov - 4 xchg tracing lhld H A mov L ora fnext jz - 5 nest? 1+ lda A ana - 6 0= ?[ - 7 lhld -11 H A mov IP cmp fnext jc -12 0= ?[ L A mov IP' cmp fnext jc ]? -13 ][ A xra nest? 1+ sta ]? \ low byte still set -14 \ one trace condition satisfied -15 W H mvx Wsave shld false H lxi tracing shld -Screen 13 not modified - 0 \ tracer display UH 25Jan88 - 1 - 2 ;c: nest? @ - 3 IF nest? off r> ip> push r THEN - 5 r@ nextstep >r input push output push standardi/o - 6 cr #spaces @ spaces - 7 dup 'ip ! 2- dup 5 u.r @ dup 6 u.r 2 spaces - 8 >name .name $1C col - 0 max spaces .s - 9 state push blk push >in push ['] 'quit >body push -10 [ ' parser >body ] Literal push -11 span push #tib push tib #tib @ npush r0 push -12 rp@ r0 ! &82 allot ['] oneline Is 'quit quit ; -13 -14 -15 -Screen 14 not modified - 0 \ DEBUG with errorchecking 28Nov86 - 1 - 2 | : traceable ( cfa -- cfa' ) - 3 recursive dup @ - 4 ['] : @ case? ?exit - 5 ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN - 6 ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN - 7 ['] r/w @ case? IF >body traceable exit THEN - 8 dup 1+ @ [ ' Forth @ 1+ @ ] Literal = IF nip 1+ exit THEN - 9 drop >name .name ." can't be DEBUGged" quit ; -10 -11 also Forth definitions -12 -13 : debug ( -- ) \ reads a word -14 ' traceable (debug Tools -15 nest? off #spaces off tracing on do-trace ; -Screen 15 not modified - 0 \ misc. words for tracing 28Nov86 - 1 Tools definitions - 2 - 3 : nest \ trace next high-level word executed - 4 'ip @ 2- @ traceable drop nest? on ; - 5 - 6 : unnest \ ends tracing of actual word - 7 off ; \ clears trap range - 8 - 9 : endloop \ stop tracing loop -10 'ip @ R NR> cr - 1 - 2 : N>R ( i * n +n -- ) ( R: -- j * x +n ) - 3 \ Transfer N items and count to the return stack. - 4 DUP BEGIN DUP WHILE - 5 ROT R> SWAP >R >R - 6 1- - 7 REPEAT DROP R> SWAP >R >R ; - 8 - 9 : NR> ( -- i * x +n ) ( R: j * x +n -- ) -10 \ Pull N items and count off the return stack. -11 R> R> SWAP >R DUP -12 BEGIN DUP WHILE -13 R> R> SWAP >R -ROT -14 1- -15 REPEAT DROP ; -Screen 17 not modified - 0 \ ? - 1 - 2 : ? ( a-addr -- ) - 3 \ Display the value stored at a-addr. - 4 @ . ; - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/XINOUT.FB.src b/sources/cpm/XINOUT.FB.src deleted file mode 100644 index 5cd6fe7..0000000 --- a/sources/cpm/XINOUT.FB.src +++ /dev/null @@ -1,136 +0,0 @@ -Screen 0 not modified - 0 \ Erweiterte I/O-Funktionen 3.80a UH 08Oct87 - 1 - 2 Dieses File enthaelt Definitionen, die eine erweiterte Bild- - 3 schirmdarstellung ermoeglichen: - 4 - 5 - Installation eines Terminals mit Hilfe des Wortes - 6 "Terminal:" - 7 - 8 - Editieren von Eingabezeilen - 9 -10 In der Version 3.80a sind diese Teile aus dem Kern genommen -11 worden, um diesen einfacher zu gestalten. -12 -13 -14 -15 -Screen 1 not modified - 0 \ Erweiterte I/O-Funktionen 3.80a LOAD-Screen UH 20Nov87 - 1 - 2 - 3 1 3 +thru \ Erweiterte Ausgabe - 4 - 5 4 6 +thru \ Erweiterte Eingabe - 6 - 7 - 8 ' curon Is postlude - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ Erweiterte Ausgabe: Terminal-Defintionen UH 08OCt87 - 1 | Variable terminal - 2 - 3 : Term: ( off -- off' ) Create dup c, 2+ - 4 Does> c@ terminal @ + perform ; - 5 - 6 : Terminal: Create: Does> terminal ! ; - 7 - 8 0 Term: curon Term: curoff - 9 Term: rvson Term: rvsoff -10 Term: dark Term: locate drop -11 -12 : curleft ( -- ) at? 1- at ; -13 : currite ( -- ) at? 1+ at ; -14 -15 Terminal: dumb noop noop noop noop noop 2drop ; dumb -Screen 3 not modified - 0 \ Erweiterte Ausgabe: UH 06Mar88 - 1 - 2 &80 Constant c/row &24 Constant c/col - 3 - 4 | Create 'at 0 , here 0 , | Constant 'row ' 'at | Alias 'col - 5 - 6 : (at ( row col -- ) c/row 1- min swap c/col 1- min swap - 7 2dup 'at 2! locate ; - 8 : (at? ( -- row col ) 'at 2@ ; - 9 -10 : (page ( -- ) 0 0 'at 2! dark ; -11 -12 : (type ( addr len -- ) dup 'col +! -13 0 ?DO count (emit LOOP drop ; -14 -15 : (emit ( c -- ) 1 'col +! (emit ; -Screen 4 not modified - 0 \ Erweiterte Ausgabe: UH 04Mar88 - 1 - 2 : (cr ( -- ) 'row @ 1+ 0 'at 2! (cr ; - 3 : (del ( -- ) 'col @ 0> 0=exit -1 'col +! (del ; - 4 - 5 ' (emit ' display 2+ ! - 6 ' (cr ' display 4 + ! - 7 ' (type ' display 6 + ! - 8 ' (del ' display 8 + ! - 9 ' (page ' display &10 + ! -10 ' (at ' display &12 + ! -11 ' (at? ' display &14 + ! -12 -13 -14 -15 -Screen 5 not modified - 0 \ Erweiterte Eingabe UH 08OCt87 - 1 | Variable maxchars | Variable oldspan oldspan off - 2 - 3 | : redisplay ( addr pos -- ) - 4 at? 2swap under + span @ rot - type space at ; - 5 | : del ( addr pos1 -- ) dup >r + dup 1+ swap - 6 span @ r> - 1- cmove -1 span +! ; - 7 | : ins ( addr pos1 -- ) dup >r + dup dup 1+ - 8 span @ r> - cmove> bl swap c! 1 span +! ; - 9 -10 | : (ins ( a p1 -- a p2 ) 2dup ins 2dup redisplay ; -11 | : (del ( a p1 -- a p2 ) 2dup del 2dup redisplay ; -12 | : (back ( a p1 -- a p2 ) 1- curleft (del ; -13 | : (recall ( a p1 -- a p2 ) ?dup ?exit -14 oldspan @ span ! 0 2dup redisplay ; -15 -Screen 6 not modified - 0 \ Tastenbelegung fuer Zeilen-Editor CP/M UH 18Mar88 - 1 : (decode ( addr pos1 key -- addr pos2 ) - 2 4 case? IF dup span @ < 0=exit currite 1+ exit THEN - 3 &19 case? IF dup 0=exit curleft 1- exit THEN - 4 &22 case? IF dup span @ = ?exit (ins exit THEN - 5 #bs case? IF dup 0=exit (back exit THEN - 6 #del case? IF dup 0=exit (back exit THEN - 7 7 case? IF span @ 2dup < and 0=exit (del exit THEN - 8 $1B case? IF (recall exit THEN - 9 #cr case? IF span @ dup maxchars ! oldspan ! -10 dup at? rot span @ - - at space exit THEN -11 dup emit >r 2dup + r> swap c! 1+ dup span @ max span ! ; -12 -13 : (expect ( addr len -- ) maxchars ! span off 0 -14 BEGIN span @ maxchars @ u< WHILE key decode REPEAT 2drop ; -15 -Screen 7 not modified - 0 \ Patch UH 08Oct87 - 1 - 2 : (key ( -- char ) - 3 curon BEGIN pause (key? UNTIL curoff getkey ; - 4 - 5 ' (key ' keyboard 2+ ! - 6 ' (decode ' keyboard 6 + ! - 7 ' (expect ' keyboard 8 + ! - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/cpm/ass8080.fth b/sources/cpm/ass8080.fth new file mode 100644 index 0000000..ac01429 --- /dev/null +++ b/sources/cpm/ass8080.fth @@ -0,0 +1,306 @@ +\ *** Block No. 0 Hexblock 0 +\ VolksForth 8080 Assembler UH 09Mar86 + +Ideen lieferten: + John Cassady + Mike Perry + Klaus Schleisiek + Bernd Pennemann + Dietrich Weineck + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ VolksForth 8080 Assembler Load Screen UH 03Jun86 +Onlyforth Assembler also definitions hex + + 1 6 +THRU cr .( VolksForth 8080-Assembler geladen. ) cr + +OnlyForth + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 + \ Vektorisierte Erzeugung UH 03Jun86 +Variable >codes + +| Create nrc ] c, , c@ here allot ! c! [ + +: nonrelocate ( -- ) nrc >codes ! ; nonrelocate + +| : >exec ( n -- n+2 ) + Create dup c, 2+ does> c@ >codes @ + perform ; + +0 | >exec >c, | >exec >, | >exec >c@ | >exec >here + | >exec >allot | >exec >! | >exec >c! +drop + + + +\ *** Block No. 3 Hexblock 3 + \ Register und Definierende Worte UH 09Mar86 + +7 Constant A +0 Constant B 1 Constant C 2 Constant D 3 Constant E +0 Constant I 1 Constant I' 2 Constant W 3 Constant W' +0 Constant IP 1 Constant IP' 4 Constant H 5 Constant L +6 Constant M 6 Constant PSW 6 Constant SP 6 Constant S + +| : 1MI Create >c, does> C@ >c, ; +| : 2MI Create >c, does> C@ + >c, ; +| : 3MI Create >c, does> C@ swap 8 * + >c, ; +| : 4MI Create >c, does> C@ >c, >c, ; +| : 5MI Create >c, does> C@ >c, >, ; + + + +\ *** Block No. 4 Hexblock 4 + \ Mnemonics UH 09Mar86 +00 1MI nop 76 1MI hlt F3 1MI di FB 1MI ei 07 1MI rlc +0F 1MI rrc 17 1MI ral 1F 1MI rar E9 1MI pchl EB 1MI xchg +C9 1MI ret C0 1MI rnz C8 1MI rz D0 1MI rnc D8 1MI rc +2F 1MI cma 37 1MI stc 3F 1MI cmc F9 1MI sphl E3 1MI xthl +E0 1MI rpo E8 1MI rpe F8 1MI rm 27 1MI daa +80 2MI add 88 2MI adc 90 2MI sub 98 2MI sbb A0 2MI ana +A8 2MI xra B0 2MI ora B8 2MI cmp 02 3MI stax 04 3MI inr +03 3MI inx 09 3MI dad 0B 3MI dcx C1 3MI pop C5 3MI push +C7 3MI rst 05 3MI dcr 0A 3MI ldax D3 4MI out DB 4MI in +C6 4MI adi CE 4MI aci D6 4MI sui DE 4MI sbi E6 4MI ani +EE 4MI xri F6 4MI ori FE 4MI cpi 22 5MI shld CD 5MI call +2A 5MI lhld 32 5MI sta 3A 5MI lda C3 5MI jmp +C2 5MI jnz CA 5MI jz D2 5MI jnc DA 5MI jc E2 5MI jpo +EA 5MI jpe F2 5MI jp FA 5MI jm + +\ *** Block No. 5 Hexblock 5 + \ Spezial Mnemonics und Spruenge UH 09Mar86 +DA Constant C0= D2 Constant C0<> D2 Constant CS +C2 Constant 0= CA Constant 0<> E2 Constant PE +F2 Constant 0< FA Constant 0>= : not 8 [ FORTH ] xor ; + +: mov 8 * 40 + + >c, ; +: mvi 8 * 6 + >c, >c, ; : lxi 8 * 1+ >c, >, ; + +: [[ ( -- addr ) >here ; \ BEGIN +: ?] ( addr opcode -- ) >c, >, ; \ UNTIL +: ?[ ( opcode -- addr ) >c, >here 0 >, ; \ IF +: ?[[ ( addr -- addr' addr ) ?[ swap ; \ WHILE +: ]? ( addr -- ) >here swap >! ; \ THEN +: ][ ( addr -- addr' ) >here 1+ 0 jmp swap ]? ; \ ELSE +: ]] ( addr -- ) jmp ; \ AGAIN +: ]]? ( addr addr' -- ) jmp ]? ; \ REPEAT +\ *** Block No. 6 Hexblock 6 + \ Macros UH 14May86 +: end-code context 2- @ context ! ; + +: ;c: 0 recover call end-code ] ; + +: Next >next jmp ; + +: rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) + H dcx 1+ M mov ( low ) RP shld ; + +: rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx + M swap mov ( high ) H inx RP shld ; +\ rpush und rpop gehen nicht mit HL + +: mvx ( src dest -- ) + 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) ; +\ *** Block No. 7 Hexblock 7 + \ Definierende Worte UH 06Aug86 +Forth definitions +: Code ( -- ) Create here dup 2- ! Assembler ; + +: ;Code ( -- ) 0 ?pairs + compile [ ' does> >body 2+ @ , ] + reveal [compile] [ Assembler ; immediate + +: >label ( adr -- ) + here | Create swap , 4 hallot >here 4 - heap 4 cmove + heap last @ (name> ! dp ! + does> ( -- adr ) @ State @ IF [compile] Literal THEN ; + +: Label [ Assembler ] >here >label Assembler ; + + +\ *** Block No. 8 Hexblock 8 + UH 14May86 + + + + + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 +% VolksForth 8080 Assembler Shadow-Screens UH 09Mar86 + + + + + + + + + + + + + + + +\ *** Block No. 10 Hexblock A +% VolksForth 8080 Assembler UH 03Jun86 + +Der 8080 Assembler wurde von John Cassady, in den Forth +Dimensions veroeffentlicht und von Mike Perry im F83 +implementiert. Er unterstuetzt den gesamten 8080 Befehlsvorrat +und auch Befehle zur strukturierten Assemblerprogrammierung. +Um ein Wort in Assembler zu definieren wird das definierende +Wort Code benutzt, es kann, muss aber nicht mit end-code beendet +werden. Wie der Assembler arbeitet ist ein interessantes +Beispiel fuer die Maechtigkeit von Create does>. +Am Anfang werden die Befehle in Klassen eingeteilt und fuer +jede Klasse ein definierndes Wort definiert. Wenn der Mnemonic +des Befehls spaeter interpretiert wird, kompiliert er den +entsprechenden Opcode. + + +\ *** Block No. 11 Hexblock B + % Vektorisierte Erzeugung UH 09Mar86 +Zeigt Auf die Tabelle mit den aktuellen Erzeugungs-Operatoren. + +Tabelle mit Erzeugungs-Operatoren fuer In-Line Assembler + +Schaltet Assembler in den In-Line Modus. + +Definierendes Wort fuer Erzeugungs-Operator-Namen. + + +Die Erzeugungs-Operator-Namen, sie fuehren den entsprechenden +aktuellen Erzeugungsoperator aus. + +Mit diesen Erweiterungen kann der Assembler auch fuer den +Target-Compiler benutzt werden. + +\ *** Block No. 12 Hexblock C + % Register und Definierende Worte UH 09Mar86 + +Die 8080 Register werden definiert. Es sind einfach Konstanten +die Information fuer die Mnemonics hinterlassen. +Einige Register der Forth-Maschine: + IP ist BC, W ist DE + + +Definierende Worte fuer die Mnemonics. +Fast alle 8080 Befehle fallen in diese 5 Klassen. + + + + + + +\ *** Block No. 13 Hexblock D + % Mnemonics UH 09Mar86 +Die 8080 Mnemonics werden definiert. + + + + + + + + + + + + + + +\ *** Block No. 14 Hexblock E + % Spezial Mnemonics und Spruenge UH 09Mar86 +Vergleiche des 8080 + +not folgt einem Vergleich, wenn er invertiert werden soll. + +die Mnemonics, die sich nicht in die Klassen MI1 bis MI5 +einteilen lassen. + +Die strukturierten Assembler-Anweisungen. +Die 'Fleischerhaken' werden benutzt, damit keine Verwechselungen +zu den strukturierten Anweisungen in Forth entstehen. +Es findet keine Absicherung der Kontrollstrukturen statt, sodass +sie auch beliebig missbraucht, werden koennen. +Das ist manchmal aus Geschwindigkeitsgruenden leider notwendig. + + +\ *** Block No. 15 Hexblock F + % Macros UH 17May86 +end-code beendet eine Code-Definition + +;c: Erlaubt das Einbinden von High-Level Forth in Code-Worten. + +Next Assembliert einen Sprung zum Adress-Interpretierer. + +rpush Das angegebene Register wird auf den Return-Stack gelegt. + + +rpop Das angegebene Register wird vom Return-Stack genommen. + +rpush und rpop benutzen das HL Register. + +mvx Ein 16-Bit-Move wie 'mov' fuer 8-Bit Register + Bewegt Registerpaare HL BC DE +\ *** Block No. 16 Hexblock 10 + % Definierende Worte UH 17May86 +Code leitet eine Code-Definition ein. + +;code ist das Low-Level-Aequivalent von does> + + +>label erzeugt ein Label auf dem Heap, mit dem angegebenen Wert + + + + +Label erzeugt ein Label auf dem Heap, mit dem Wert von here + + + + +\ *** Block No. 17 Hexblock 11 + + + + + + + + + + + + + + + + diff --git a/sources/cpm/asstran.fth b/sources/cpm/asstran.fth new file mode 100644 index 0000000..f526cd5 --- /dev/null +++ b/sources/cpm/asstran.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\\ Transinient Assembler 11Nov86 + +Dieses File enthaelt Befehle, die den Assembler vollstaendig in +den Heap laden, so dass er schliesslich mit clear wieder +vergessen werden kann. + +Dadurch ist es nicht notwendig in einer Anwendung den ganzen +Assembler im Speicher lassen zu muessen, nur weil einige +primitive Worte in Assembler geschrieben sind. + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Internal Assembler UH 22Oct86 + +Onlyforth + +here + $C00 hallot heap dp ! include ass8080.scr +dp ! + + + + + + + + + diff --git a/sources/cpm/copy.fth b/sources/cpm/copy.fth new file mode 100644 index 0000000..f622cbe --- /dev/null +++ b/sources/cpm/copy.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\ Copy und Convey 19Nov87 + +Dieses File enthaelt Definitionen, die urspruenglich im Kern +enthalten waren. Sie sind jetzt ausgelagert worden, um den Kern +klein zu halten. + +copy kopiert einen Screen + +convey kopiert einen Bereich von Screens + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ moving blocks 20Oct86 19Nov87 +| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; +| : fromblock ( blk -- adr ) fromfile @ (block ; +| : (copy ( from to -- ) + dup isfile@ core? IF prev @ emptybuf THEN + full? IF save-buffers THEN + offset @ + isfile@ rot fromblock 6 - 2! update ; +| : blkmove ( from to quan --) save-buffers >r + over r@ + over u> >r 2dup u< r> and + IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP + ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP THEN + save-buffers 2drop ; + +: copy ( from to --) 1 blkmove ; +: convey ( [blk1 blk2] [to.blk --) + swap 1+ 2 pick - dup 0> not Abort" Nein !" blkmove ; diff --git a/sources/cpm/disass.fth b/sources/cpm/disass.fth new file mode 100644 index 0000000..f74ef60 --- /dev/null +++ b/sources/cpm/disass.fth @@ -0,0 +1,306 @@ +\ *** Block No. 0 Hexblock 0 +\\ Z80-Disassembler 08Nov86 + +Dieses File enthaelt einen Z80-Disassembler, der assemblierten +Code in Standard Zilog-Z80 Mnemonics umsetzt. + +Benutzung: + + TOOLS ALSO \ Schalte Disassembler-Vokabular an + + addr DIS \ Disassembliere ab Adresse addr + + xxxx displace ! \ Beruecksichte bei allen Adressen einen + \ Versatz von xxxx. + \ Wird gebraucht, wenn ein Assemblerstueck + \ nicht an dem Platz disassembliert wird, + \ an dem es ablaeuft. +\ *** Block No. 1 Hexblock 1 +\ Z80-Disassembler Load Screen 08Nov86 + +Onlyforth Tools also definitions hex + +' Forth | Alias F: immediate +' Tools | Alias T: immediate + + 1 $10 +THRU cr .( Disassembler geladen. ) cr + +OnlyForth + + +\\ Fragen Anregungen & Kritik an: + U. Hoffmann + Harmsstrasse 71 + 2300 Kiel 1 +\ *** Block No. 2 Hexblock 2 + \ Speicherzugriff und Ausgabe 07Jul86 +internal +\needs Case: : Case: Create: Does> swap 2* + perform ; + +Variable index Variable address Variable offset +Variable oldoutput +external Variable displace displace off internal + +' pad Alias str1 ( -- addr ) +: str2 ( -- addr ) str1 $40 + ; + +: byte ( -- b ) address @ displace @ + c@ ; +: word ( -- w ) address @ displace @ + @ ; + +: .byte ( byte -- ) 0 <# # #s #> type ; +: .word ( addr -- ) 0 <# # # # #s #> type ; +\ *** Block No. 3 Hexblock 3 + \ neue Bytes lesen Byte-Fraktionen 07Jul86 + +: next-byte output push oldoutput @ output ! + byte .byte space 1 address +! ; + +: next-word next-byte next-byte ; + +: f ( -- b ) byte $40 / ; +: g ( -- b ) byte 8 / 7 and ; +: h ( -- b ) byte 7 and ; +: j ( -- b ) g 2/ ; +: k ( -- b ) g 1 and ; + +\\ 76543210 + ffggghhh + jjk +\ *** Block No. 4 Hexblock 4 + \ Select" 08Nov86 + +: scan/ ( limit start -- limit start' ) over swap + DO I c@ Ascii / = IF I F: ENDLOOP T: exit THEN LOOP dup ; + +: select ( n addr len -- addr' len' ) + bounds rot + 0 ?DO scan/ 1+ 2dup < IF 2drop " -" count ENDLOOP exit THEN + LOOP under scan/ nip over - ; + +: (select" ( n -- ) "lit count select type ; + +: select" ( -- ) compile (select" ," ; immediate + +: append ( c str -- ) + under count + c! dup c@ 1+ swap c! ; +\ *** Block No. 5 Hexblock 5 + \ StringOutput 07Jul86 + +Variable $ + +: $emit ( c -- ) $ @ append pause ; + +: $type ( adr len -- ) 0 ?DO count $emit LOOP drop ; + +: $cr ( -- ) $ @ off ; + +: $at? ( -- row col ) 0 $ @ c@ ; + +Output: $output + $emit $cr $type noop $cr 2drop $at? ; + + +\ *** Block No. 6 Hexblock 6 + \ Register 07Jul86 + +: reg ( n -- ) dup 5 = IF index @ negate index ! THEN + select" B/C/D/E/H/L/$/A" ; + +: double-reg ( n -- ) select" BC/DE/%/SP" ; + +: double-reg2 ( n -- ) select" BC/DE/%/AF" ; + +: num ( n -- ) select" 0/1/2/3/4/5/6/7" ; + +: cond ( n -- ) select" nz/z/nc/c/po/pe/p/m" ; + +: arith ( n -- ) + select" add A,/adc A,/sub /sbc A,/and /xor /or /cp " ; + +\ *** Block No. 7 Hexblock 7 + \ no-prefix Einteilung der Befehle in Klassen 07Jul86 + +: 00xxx000 + g dup 3 > IF ." jr " 4- cond ." ,?" exit THEN + select" nop/ex AF,AF'/djnz ?/jr ?" ; + +: 00xxx001 + k IF ." add %," j double-reg exit THEN + ." ld " j double-reg ." ,&" ; + +: 00xxx010 ." ld " g + select" (BC),A/A,(BC)/(DE),A/A,(DE)/(&),%/%,(&)/(&),A/A,(&)" +; + +: 00xxx011 k IF ." dec " ELSE ." inc " THEN j double-reg ; + +\ *** Block No. 8 Hexblock 8 + \ no-prefix 07Jul86 + +: 00xxx100 ." inc " g reg ; + +: 00xxx101 ." dec " g reg ; + +: 00xxx110 ." ld " g reg ." ,#" ; + +: 00xxx111 g select" rlca/rrca/rla/rra/daa/cpl/scf/ccf" ; + +: 01xxxxxx ." ld " g reg ." ," h reg ; + +: 10xxxxxx g arith h reg ; + + + +\ *** Block No. 9 Hexblock 9 + \ no-prefix 07Jul86 + +: 11xxx000 ." ret " g cond ; + +: 11xxx001 k IF j select" ret/exx/jp (%)/ld sp,%" exit THEN + ." pop " j double-reg2 ; + +: 11xxx010 ." JP " g cond ." ,&" ; + +: 11xxx011 g + select" jp &/-/out (#),A/in a,(#)/ex (SP),%/ex DE,HL/di/ei" ; + +: 11xxx100 ." call " g cond ; +: 11xxx101 k IF ." call &" exit THEN ." push " j double-reg2 ; +: 11xxx110 g arith ." #" ; +: 11xxx111 ." rst " g select" 00/08/10/18/20/28/30/38" ; +\ *** Block No. 10 Hexblock A + \ no-prefix 07Jul86 + +Case: 00xxxhhh + 00xxx000 00xxx001 00xxx010 00xxx011 + 00xxx100 00xxx101 00xxx110 00xxx111 ; + +Case: 11xxxhhh + 11xxx000 11xxx001 11xxx010 11xxx011 + 11xxx100 11xxx101 11xxx110 11xxx111 ; + +: 00xxxxxx h 00xxxhhh ; +: 11xxxxxx h 11xxxhhh ; + +Case: ffxxxxxx + 00xxxxxx 01xxxxxx 10xxxxxx 11xxxxxx ; + +\ *** Block No. 11 Hexblock B + \ no-prefix 07Jul86 + +: get-offset index @ 0> IF byte offset ! next-byte THEN ; + +: no-prefix f ffxxxxxx next-byte get-offset ; + + + + + + + + + + + +\ *** Block No. 12 Hexblock C + \ CB-Prefix 07Jul86 + +: CB-00xxxxxx + g select" rlc /rrc /rl /rr /sla /sra /-/srl " h reg ; + +: CB-01xxxxxx ." bit " g num ." ," h reg ; + +: CB-10xxxxxx ." res " g num ." ," h reg ; + +: CB-11xxxxxx ." set " g num ." ," h reg ; + +case: singlebit + CB-00xxxxxx CB-01xxxxxx CB-10xxxxxx CB-11xxxxxx ; + +: CB-prefix get-offset f singlebit next-byte ; + +\ *** Block No. 13 Hexblock D + \ ED-Prefix 30Sep86 +: ED-01xxx000 ." in (C)," g reg ; +: ED-01xxx001 ." out (C)," g reg ; +: ED-01xxx010 k IF ." adc " ELSE ." sbc " THEN + ." HL," j double-reg ; +: ED-01xxx011 ." ld " k IF j double-reg ." ,(&)" exit THEN + ." (&)," j double-reg ; +: ED-01xxx100 ." neg" ; +: ED-01xxx101 k IF ." reti" exit THEN ." retn" ; +: ED-01xxx110 g select" im 0/-/im 1/im 2" ; +: ED-01xxx111 g select" ld I,A/ld R,A/ld A,I/ld A,R/rrd/rld" ; +: ED-10xxxxxx h select" ld/cp/in/ot" g 4- select" i/d/ir/dr" ; +Case: ED-01xxxhhh + ED-01xxx000 ED-01xxx001 ED-01xxx010 ED-01xxx011 + ED-01xxx100 ED-01xxx101 ED-01xxx110 ED-01xxx111 ; +: ED-01xxxxxx h ED-01xxxhhh ; +\ *** Block No. 14 Hexblock E + \ ED-Prefix 07Jul86 + +Case: extended + noop ED-01xxxxxx ED-10xxxxxx noop ; + +: ED-prefix get-offset f extended next-byte ; + + + + + + + + + + +\ *** Block No. 15 Hexblock F + \ Disassassemblieren eines einzelnen Befehls 30Sep86 + +: index-register ( n -- ) index ! next-byte ; + +: get-instruction ( -- ) + index off str1 $ ! cr + byte $DD = IF 1 index-register ELSE + byte $FD = IF 2 index-register THEN THEN + byte $76 case? IF next-byte ." halt" exit THEN + $CB case? IF next-byte CB-prefix exit THEN + $ED case? IF next-byte ED-prefix exit THEN + drop no-prefix ; + + + + +\ *** Block No. 16 Hexblock 10 + \ Adressierungsarten ausgeben 07Jul86 27Nov87 +: .index-register ( -- ) index @ abs select" HL/IX/IY" ; + +: offset-sign ( o -- o' ) dup $7F > IF $100 - THEN ; +: +- ( s -- ) 0< IF Ascii - ELSE Ascii + THEN hold ; + +: .offset ( -- ) offset @ offset-sign + extend under dabs <# # #s rot +- #> type ; +: .index-register-offset + index @ abs dup select" (HL)/(IX/(IY" IF .offset ." )" THEN ; + +: .inline-byte ( -- ) byte .byte next-byte ; +: .inline-word ( -- ) word .word next-word ; + +: .displace ( -- ) + byte offset-sign address @ + 1+ .word next-byte ; +\ *** Block No. 17 Hexblock 11 + \ Hauptebene: dis 07Jul86 +: .char ( c -- ) + Ascii % case? IF .index-register exit THEN + Ascii $ case? IF .index-register-offset exit THEN + Ascii # case? IF .inline-byte exit THEN + Ascii & case? IF .inline-word exit THEN + Ascii ? case? IF .displace exit THEN emit ; + +: instruction ( -- ) cr address @ .word 2 spaces + output @ oldoutput ! $output get-instruction + str2 $ ! cr str1 count 0 ?DO count .char LOOP drop + oldoutput @ output ! $20 col - 0 max spaces str2 count type ; + +external +: dis ( addr -- ) address ! + BEGIN instruction stop? UNTIL ; diff --git a/sources/cpm/double.fth b/sources/cpm/double.fth new file mode 100644 index 0000000..ee08133 --- /dev/null +++ b/sources/cpm/double.fth @@ -0,0 +1,51 @@ +\ *** Block No. 0 Hexblock 0 +\\ Double words 11Nov86 + +Dieses File enthaelt Worte fuer 32-Bit Objekte. + +Im Kern bereits enthalten sind: + + 2@ 2! 2dup 2drop 2swap dnegate d+ + +Hier werden definiert: + + 2Variable 2Constant 2over d* + + + + + +\ *** Block No. 1 Hexblock 1 +\ 2over 2@ 2! 2Variable 2Constant UH 30Oct86 + +: 2Variable Variable 2 allot ; +: 2Constant Create , , does> 2@ ; + +Code 2over ( 32b1 32b2 -- 32b1 32b2 32b1 ) 7 H lxi + SP dad M D mov H dcx M E mov D push + H dcx M D mov H dcx M E mov D push Next end-code +--> \\ +Code 2@ ( addr -- 32b ) H pop H push + H inx H inx M E mov H inx M D mov H pop D push + M E mov H inx M D mov D push Next end-code + +Code 2! ( 32b addr -- ) H pop + D pop E M mov H inx D M mov H inx + D pop E M mov H inx D M mov Next end-code +\ *** Block No. 2 Hexblock 2 +\ d* d- 29Jun86 + +: d* ( d1 d2 -- d1*d2 ) + rot 2over rot um* 2swap um* d+ 2swap um* d+ ; + +: d- ( d1 d2 -- d1-d2 ) dnegate d+ ; + + + + + + + + + + diff --git a/sources/cpm/editor.fth b/sources/cpm/editor.fth new file mode 100644 index 0000000..d19ad70 --- /dev/null +++ b/sources/cpm/editor.fth @@ -0,0 +1,544 @@ +\ *** Block No. 0 Hexblock 0 +\ Full-Screen Editor UH 02Nov86 + +Dieses File enthaelt den Full-Screen Editor fuer die CP/M - +volksFORTH-Version. + +Er enthaelt Line- und Chararcter-Stacks, Find&Replace-Funktion +sowie Unterstuetzung des Shadow-Screen-Konzepts, der view- +Funktion und des sichtbaren Laden von Screens (showload). + +Durch die integrierte Tastaturtabelle (keytable) laesst sich die +Kommandobelegung der Tasten auf einfache Art und Weise aendern. + +Anregungen, Kritik und Verbesserungsvorschlaege bitte an: + U. Hoffmann + Harmsstrasse 71 + 2300 Kiel +\ *** Block No. 1 Hexblock 1 +\ Load Screen for the Editor UH 03Nov86 UH 27Nov87 + +Onlyforth cr + + 1 $1E +thru + +Onlyforth + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ String primitves 27Nov87 + +: delete ( buffer size count -- ) + over umin dup >r - 2dup over r@ + -rot cmove + + r> bl fill ; + +: insert ( string length buffer size -- ) + rot over umin dup >r - + over dup r@ + rot cmove> r> cmove ; + +: replace ( string length buffer size -- ) rot umin cmove ; + + + + + +\ *** Block No. 3 Hexblock 3 +\ usefull definitions and Editor vocabulary UH 27Nov87 + +: blank ( addr len -- ) bl fill ; + +: ?enough ( n --) depth 1- > abort" Not enough Parameters" ; + +: ?abort( ( f -- ) + IF [compile] .( true abort" !" THEN [compile] ( ; + +Vocabulary Editor + +' Forth | Alias F: immediate +' Editor | Alias E: immediate + +Editor also definitions + +\ *** Block No. 4 Hexblock 4 +\ move cursor with position-checking 23Nov86 + +| : c ( n --) \ checks the cursor position + r# @ + dup 0 b/blk uwithin not + Abort" There is a border!" r# ! ; + +\\ + +: c ( n --) \ goes thru the screens + r# @ + dup b/blk 1- > IF 1 scr +! THEN + dup 0< IF -1 scr +! THEN b/blk mod r# ! ; + +: c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + + +\ *** Block No. 5 Hexblock 5 +\ calculate addresses UH 31Oct86 + +| Code *line ( l -- adr ) + H pop H dad H dad H dad + H dad H dad H dad Hpush jmp end-code + +| Code /line ( n -- c l ) + H pop L A mov $3F ani A E mov 0 D mvi + L A mov ral A L mov H A mov ral A H mov + L A mov ral A L mov H A mov ral A H mov + L A mov ral 3 ani H L mov A H mov + dpush jmp end-code + +\\ +| : *line ( l -- adr ) c/l * ; +| : /line ( n -- c l ) c/l /mod ; +\ *** Block No. 6 Hexblock 6 +\ calculate addresses UH 01Nov86 + +| : top ( -- ) r# off ; +| : cursor ( -- n ) r# @ ; +| : 'start ( -- adr ) scr @ block ; +| : 'end ( -- adr ) 'start b/blk + ; +| : 'cursor ( -- adr ) 'start cursor + ; +| : position ( -- c l ) cursor /line ; +| : line# ( -- l ) position nip ; +| : col# ( -- c ) position drop ; +| : 'line ( -- adr ) 'start line# *line + ; +| : 'line-end ( -- adr ) 'line c/l + 1- ; +| : #after ( -- n ) c/l col# - ; +| : #remaining ( -- n ) b/blk cursor - ; +| : #end ( -- n ) b/blk line# *line - ; + +\ *** Block No. 7 Hexblock 7 +\ move cursor directed UH 01Nov86 + +| : curup c/l negate c ; +| : curdown c/l c ; +| : curleft -1 c ; +| : curright 1 c ; + +| : +tab \ 1/4 line forth + cursor $10 / 1+ $10 * cursor - c ; + +| : -tab \ 1/8 line back + cursor 8 mod negate dup 0= 8 * + c ; + +| : >""end 'start b/blk -trailing nip b/blk 1- min r# ! ; +| : #after c ; + +\ *** Block No. 8 Hexblock 8 +\ show border UH 27Nov87 +&15 | Constant dx 1 | Constant dy + +| : horizontal ( row -- row' ) + dup dx 1- at c/l 2+ 0 DO Ascii - emit LOOP 1+ ; + +| : vertical ( row -- row' ) + l/s 0 DO dup dx 1- at Ascii | emit + row dx c/l + at Ascii | emit 1+ LOOP ; + +| : border dy 1- horizontal vertical horizontal drop ; + +| : edit-at ( -- ) position swap dy dx d+ at ; + +Forth definitions +: updated? ( -- f) scr @ block 2- @ 0< ; +\ *** Block No. 9 Hexblock 9 +\ display screen UH 02Nov86 UH 27Nouho +Editor definitions | Variable isfile' | Variable imode + +| : .updated ( -- ) 7 0 at + updated? IF 4 spaces ELSE ." not " THEN ." updated" ; + +| : redisplay ( line# -- ) + dup dy + dx at *line 'start + c/l type ; + +| : .file ( 'file -- ) [ Dos ] .file &14 col - 0 max spaces ; +| : .title 1 0 at isfile@ .file 3 0 at isfile' @ .file + 5 0 at ." Scr# " scr @ 4 .r .updated &10 0 at + imode @ IF ." insert " exit THEN ." overwrite" ; + +| : .screen l/s 0 DO I redisplay LOOP ; +| : .all .title .screen ; +\ *** Block No. 10 Hexblock A +\ check errors UH 02Nov86 + +| : ?bottom ( -- ) 'end c/l - c/l -trailing nip + Abort" You would lose a line" ; + +| : ?fit ( n -- ) 'line c/l -trailing nip + c/l > + IF line# redisplay + true Abort" You would lose a char" THEN ; + +| : ?end 1 ?fit ; + + + + + + +\ *** Block No. 11 Hexblock B +\ programmer's id UH 02Nov86 + +$12 | Constant id-len +Create id id-len allot id id-len erase + +| : stamp ( -- ) + id 1+ count 'start c/l + over - swap cmove ; + +| : ?stamp ( -- ) updated? IF stamp THEN ; + +| : get-id ( -- ) + id c@ ?exit id on + cr ." Enter your ID : " at? $10 0 DO Ascii . emit LOOP at + id id-len 2 /string expect rvsoff span @ id 1+ c! ; + + +\ *** Block No. 12 Hexblock C +\ update screen-display UH 02Dec86 + +| : emptybuf prev @ 2+ dup on 4+ off ; + +| : undo emptybuf .all ; + +| : modified updated? ?exit update .updated ; + +| : linemodified modified line# redisplay ; + +| : screenmodified modified + l/s line# ?DO I redisplay LOOP ; + +| : .modified ( -- ) dy l/s + 4+ 0 at scr @ . + updated? not IF ." un" THEN ." modified" ?stamp ; + +\ *** Block No. 13 Hexblock D +\ leave editor UH 02Dec86 UH 23Feb88 +| Variable (pad (pad off +| : memtop ( -- adr) sp@ $100 - ; + +| Create char 1 allot + +( | Variable imode ) imode off +| : setimode imode on .title ; +| : clrimode imode off .title ; +| : flipimode ( -- ) imode @ 0= imode ! .title ; + +| : done ( -- ) + ['] (quit is 'quit ['] (error errorhandler ! quit ; + +| : update-exit ( -- ) .modified done ; +| : flushed-exit ( -- ) .modified save-buffers done ; +\ *** Block No. 14 Hexblock E +\ handle lines UH 01Nov86 + +| : (clear-line 'line c/l blank ; +| : clear-line (clear-line linemodified ; + +| : clear> 'cursor #after blank linemodified ; + +| : delete-line 'line #end c/l delete screenmodified ; + +| : backline curup delete-line ; + +| : (insert-line + ?bottom 'line c/l over #end insert (clear-line ; + +| : insert-line (insert-line screenmodified ; + +\ *** Block No. 15 Hexblock F +\ handle characters UH 01Nov86 + +| : delete-char 'cursor #after 1 delete linemodified ; + +| : backspace curleft delete-char ; + +| : (insert-char ?end 'cursor 1 over #after insert ; + + +| : insert-char (insert-char bl 'cursor c! linemodified ; + +| : putchar ( --) char c@ + imode @ IF (insert-char THEN + 'cursor c! linemodified curright ; + + +\ *** Block No. 16 Hexblock 10 +\ stack lines UH 31Oct86 + +| Create lines 4 allot \ { 2+pointer | 2base } +| : 'lines ( -- adr) lines 2@ + ; + +| : @line 'lines memtop u> Abort" line buffer full" + 'line 'lines c/l cmove c/l lines +! ; + +| : copyline @line curdown ; +| : line>buf @line delete-line ; + +| : !line c/l negate lines +! 'lines 'line c/l cmove ; + +| : buf>line lines @ 0= Abort" line buffer empty" + ?bottom (insert-line !line screenmodified ; + +\ *** Block No. 17 Hexblock 11 +\ stack characters UH 01Nov86 + +| Create chars 4 allot \ { 2+pointer | 2base } +| : 'chars ( -- adr) chars 2@ + ; + +| : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" + 'cursor c@ 'chars c! 1 chars +! ; + +| : copychar @char curright ; +| : char>buf @char delete-char ; + +| : !char -1 chars +! 'chars c@ 'cursor c! ; + +| : buf>char chars @ 0= Abort" char buffer empty" + ?end (insert-char !char linemodified ; + +\ *** Block No. 18 Hexblock 12 +\ switch screens UH 03Nov86 UH 27Nov87 + +| Variable r#' r#' off +| Variable scr' scr' off +( | Variable isfile' ) isfile@ isfile' ! + +| : associate \ switch to alternate screen + isfile' @ isfile@ isfile' ! isfile ! + scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; + +| : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .title ; +| : n ?stamp 1 scr +! .all ; +| : b ?stamp -1 scr +! .all ; +| : a ?stamp associate .all ; + + +\ *** Block No. 19 Hexblock 13 +\ shadow screens UH 03Nov86 + +Variable shadow shadow off + +| : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; + +| : >shadow ?stamp \ switch to shadow screen + (shadow dup scr @ u> not IF negate THEN scr +! .all ; + + + + + + + + +\ *** Block No. 20 Hexblock 14 +\ load and show screens UH 06Mar88 + +' name >body &10 + | Constant 'name + +| : showoff ['] exit 'name ! curoff rvsoff ; + +| : show ( -- ) blk @ 0= IF showoff exit THEN + >in @ 1- r# ! curoff edit-at curon + stop? IF showoff true Abort" Break! " THEN + blk @ scr @ - + IF blk @ scr ! rvsoff curoff .all rvson curon THEN ; + +| : showload ( -- ) ?stamp save-buffers + ['] show 'name ! curon rvson + ['] .status >body push ['] noop is .status + scr @ scr push scr off r# push r# @ (load showoff ; +\ *** Block No. 21 Hexblock 15 +\ find strings UH 01Nov86 + +| Variable insert-buffer +| Variable find-buffer +| : 'insert ( -- addr ) insert-buffer @ ; +| : 'find ( -- addr ) find-buffer @ ; + +| : .buf ( addr -- ) count type ." |" &80 col - spaces ; + +| : get ( addr -- ) >r at? r@ .buf + 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN + at r> .buf ; + +| : get-buffers dy l/s + 2+ dx 1- 2dup at + ." find: |" 'find get swap 1+ swap 2- at + ." ? replace: |" 'insert get ; +\ *** Block No. 22 Hexblock 16 +\ search for string UH 02Nov86 UH 27Nov87 + +| : skip ( addr -- addr' ) 'find c@ + ; + +| : find? ( -- addr T | F ) + 'find count 'cursor #remaining "search ; + +| : "find ( -- r# scr ) + find? IF skip 'start - scr @ exit THEN ?stamp + capacity scr @ 1+ + ?DO 'find count + I dup 5 5 at 4 .r block b/blk "search + IF skip I block - I endloop exit THEN + stop? Abort" Break! " + LOOP true Abort" not found!" ; + +\ *** Block No. 23 Hexblock 17 +\ replace strings UH 03Nov86 UH 27Nov87 +| : replace? ( -- f ) dy l/s + 3+ dx 3 - at + key dup #cr = IF line# redisplay true Abort" Break!" THEN + capital Ascii R = ; + +| : "mark ( -- ) r# push + 'find count dup negate c edit-at rvson type rvsoff ; + +| : (replace 'insert c@ 'find c@ - ?fit + 'find c@ negate c 'cursor #after 'find c@ delete + 'insert count 'cursor #after insert + 'insert c@ c modified ; + +| : "replace get-buffers + BEGIN "find dup scr @ - swap scr ! IF .all THEN r# ! + "mark replace? IF (replace THEN line# redisplay REPEAT ; +\ *** Block No. 24 Hexblock 18 +\ Control-Characters 'normal' CP/M uho 08May2005 + +Forth definitions + +: Ctrl ( -- c ) + name 1+ c@ $1F and state @ IF [compile] Literal THEN ; +immediate + +$7F Constant #del + +Editor definitions + +\ | : flipimode imode @ 0= imode ! ; + + + +\ *** Block No. 25 Hexblock 19 +\ Try a Screen-Editor 'normal' CP/M UH 29Nov86 + +Create keytable +Ctrl E c, Ctrl S c, Ctrl X c, Ctrl D c, +Ctrl I c, Ctrl J c, Ctrl O c, Ctrl K c, + Ctrl P c, Ctrl L c, +Ctrl H c, Ctrl H c, #del c, Ctrl G c, +Ctrl T c, Ctrl Y c, Ctrl N c, +Ctrl V c, Ctrl Z c, + #cr c, Ctrl F c, Ctrl A c, + Ctrl \ c, Ctrl U c, +Ctrl Q c, #esc c, Ctrl W c, +Ctrl C c, Ctrl R c, Ctrl ] c, Ctrl B c, + + +here keytable - Constant #keys +\ *** Block No. 26 Hexblock 1A +\ Try a screen Editor UH 29Nov86 + +Create: actiontable +curup curleft curdown curright +line>buf char>buf buf>line buf>char + copyline copychar +backspace backspace backspace delete-char +insert-char delete-line insert-line +flipimode ( clear-line ) clear> + +tab -tab +( top >""end ) "replace undo +update-exit flushed-exit ( showload ) >shadow +n b a mark ; + + +here actiontable - 2/ 1- #keys - ?abort( # of actions) +\ *** Block No. 27 Hexblock 1B +\ find keys UH 01Nov86 + +| Code findkey ( key -- addr/default ) + H pop L A mov keytable H lxi #keys $100 * D lxi + [[ M cmp 0= + ?[ actiontable H lxi 0 D mvi D dad D dad + M E mov H inx M D mov D push next ]? + H inx E inr D dcr 0= ?] + ' putchar H lxi hpush jmp + end-code + +\\ +| : findkey ( key -- adr/default ) + #keys 0 DO dup keytable F: I + c@ = + IF drop E: actiontable F: I 2* + @ endloop exit THEN + LOOP drop ['] putchar ; +\ *** Block No. 28 Hexblock 1C +\ allocate buffers UH 01Nov86 + +c/l 2* | Constant cstack-size + +| : nextbuf ( adr -- adr' ) cstack-size + ; + +| : ?clearbuffer pad (pad @ = ?exit + pad dup (pad ! + nextbuf dup find-buffer ! 'find off + nextbuf dup insert-buffer ! 'insert off + nextbuf dup 0 chars 2! + nextbuf 0 lines 2! ; + + + + +\ *** Block No. 29 Hexblock 1D +\ enter and exit the editor, editor's loop UH 02Nov86 +| Variable jingle jingle on | : bell 07 con! jingle off ; + +| : clear-error + jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; + +| : fullquit BEGIN ?clearbuffer edit-at key dup char c! + findkey execute clear-error REPEAT ; + +| : fullerror ( string --) jingle @ IF bell THEN + dy l/s + 1+ dx $16 + at rvson count type rvsoff + &80 col - spaces scr @ capacity 1- min 0 max scr ! + .title quit ; + +| : install ( -- ) + ['] fullquit Is 'quit ['] fullerror errorhandler ! ; +\ *** Block No. 30 Hexblock 1E +\ enter and exit the Editor UH 02Nov86 + +Forth definitions + +: v ( -- ) E: 'start drop get-id install ?clearbuffer + page curoff border .all quit ; + +: l ( scr -- ) 1 ?enough scr ! E: top F: v ; + + + + + + + + +\ *** Block No. 31 Hexblock 1F +\ savesystem uho 09May2uho + +: savesystem \ save image + E: id off (pad off savesystem ; + +| : >find ?clearbuffer >in push + bl word count 'find 1+ place + bl 'find 1+ dup >r count dup >r + c! + r> 2+ 'find c! bl r> c! ; +| : %view ( -- ) >find ' >name 4- @ (view + ?dup 0= Abort" hand made" scr ! + E: top curdown find? 0= + IF ." From Scr # " scr @ u. true Abort" wrong file" THEN + skip 'start - 1- r# ! ; +: view ( -- ) %view scr @ list ; +: fix ( -- ) %view v ; diff --git a/sources/cpm/fileint.fth b/sources/cpm/fileint.fth new file mode 100644 index 0000000..f31ec63 --- /dev/null +++ b/sources/cpm/fileint.fth @@ -0,0 +1,544 @@ +\ *** Block No. 0 Hexblock 0 +\ CP/M 2.2 File-Interface (3.80a) UH 05Oct87 + +Dieses File enthaelt das File-Interface von volksFORTH zu CP/M. +Damit ist Zugriff auf normale CP/M-Files moeglich. +Wenn ein File mit USE benutzt wird, beziehen sich alle Worte, +die mit dem Massenspeicher arbeiten, auf dieses File. + +Benutzung: + USE \ benutze ein schon existierendes File + FILE \ erzeuge ein Forthfile mit dem Namen . + MAKE \ Erzeuge ein File mit und ordne + \ es dem aktuellen Forthfile zu. + MAKEFILE \ Erzeuge ein File mit CP/M und FORTH-Namen + . + INCLUDE \ Lade File mit Forthnamen ab Screen 1 + DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M) +\ *** Block No. 1 Hexblock 1 +\ CP/M 2.2 File-Interface load-Screen UH 18Feb88 +OnlyForth + + 2 load \ view numbers for this file + 3 4 thru \ DOS File Functions + 5 $11 thru \ Forth File Functions +$12 $16 thru \ User Interface + +File source.fb \ Define already existing Files +File fileint.fb File startup.fbr + +' (makeview Is makeview +' remove-files Is custom-remove +' file-r/w Is r/w +' noop Is drvinit + \ include startup.fb \ load Standard System +\ *** Block No. 2 Hexblock 2 +\ Build correct view-numbers for this file UUH 19Nov87 + +| : fileintview ( -- ) $400 blk @ + ; + +' fileintview Is makeview + + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ File Control Blocks UH 18Feb88 +Dos definitions also +| : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ; +&11 Constant filenamelen +0 2 | Fcbyte nextfile immediate + 1 Fcbyte drive ' drive | Alias >dosfcb + filenamelen 3 - Fcbyte filename + 3 Fcbyte extension + &21 + \ ex, s1, s2, rc, d0, ... dn, cr + 2 Fcbyte record \ r0, r1 + 1+ \ r2 + 2 Fcbyte opened + 2 Fcbyte fileno + 2 Fcbyte filesize \ in 128-Byte-Records + 4 Fcbyte position +Constant b/fcb +\ *** Block No. 4 Hexblock 4 +\ dos primitives UH 10Oct87 + +' 2- | Alias body> ' 2- | Alias dosfcb> + +: drive! ( drv -- ) $0E bdos ; +: search0 ( dosfcb -- dir ) $11 bdosa ; +: searchnext ( dosfcb -- dir ) $12 bdosa ; +: read-seq ( dosfcb -- f ) $14 bdosa dos-error? ; +: write-seq ( dosfcb -- f ) $15 bdosa dos-error? ; +: createfile ( dosfcb -- f ) $16 bdosa dos-error? ; +: size ( dos -- size ) dup $23 bdos dosfcb> record @ ; +: drive@ ( -- drv ) 0 $19 bdosa ; +: killfile ( dosfcb -- ) $13 bdos ; + + + +\ *** Block No. 5 Hexblock 5 +\ File sizes UH 05Oct87 + +: (capacity ( fcb -- n ) \ filecapacity in blocks + filesize @ rec/blk u/mod swap 0= ?exit 1+ ; + +: in-range ( block fcb -- ) + (capacity u< not Abort" beyond capacity!" ; + +Forth definitions + +: capacity ( -- n ) isfile@ (capacity ; + +Dos definitions + + + +\ *** Block No. 6 Hexblock 6 +\ (open UH 18Feb88 + +: (open ( fcb -- ) + dup opened @ IF drop exit THEN dup position 0. rot 2! + dup >dosfcb openfile Abort" not found!" dup opened on + dup >dosfcb size swap filesize ! ; + +: (make ( fcb -- ) + dup >dosfcb killfile + dup >dosfcb createfile Abort" directory full!" + dup position 0. rot 2! + dup filesize off opened on offset off ; + +: file-r/w ( buffer block fcb f -- f ) + over 0= Abort" no Direct Disk IO supported! " + >r dup (open 2dup in-range r> (r/w ; +\ *** Block No. 7 Hexblock 7 +\ Print Filenames UH 10Oct87 + +: .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN + fcb dosfcb> case? IF ." DEFAULT" exit THEN + body> >name .name ; + +: .drive ( fcb -- ) drive c@ ?dup 0=exit + [ Ascii A 1- ] Literal + emit Ascii : emit ; + +: .dosfile ( fcb -- ) dup filename 8 -trailing type + Ascii . emit extension 3 type ; + + + + + +\ *** Block No. 8 Hexblock 8 +\ Print Filenames UH 10Oct87 + +: tab ( -- ) col &59 > IF cr exit THEN + &20 col &20 mod - 0 max spaces ; + +: .fcb ( fcb -- ) dup fileno @ 3 u.r tab + dup .file tab dup .drive dup .dosfile + tab dup opened @ IF ." opened" ELSE ." closed" THEN + 3 spaces base push decimal (capacity 3 u.r ." kB" ; + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ Filenames UH 05Oct87 + +: !name ( addr len fcb -- ) + dup >r filename filenamelen bl fill + over 1+ c@ Ascii : = + IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r> + ELSE 0 THEN r@ drive c! r> dup filename 2swap + filenamelen 1+ min bounds + ?DO I c@ Ascii . = + IF drop dup extension ELSE I c@ over c! 1+ THEN + LOOP 2drop ; + +: !fcb ( fcb -- ) dup opened off name count rot !name ; + + + +\ *** Block No. 10 Hexblock A +\ Print Directory UH 18Nov87 + +| Create dirbuf b/rec allot dirbuf b/rec erase +| Create fcb0 b/fcb allot fcb0 b/fcb erase + +| : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ; +| : (expand ( addr len -- ) false -rot bounds + ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ; +| : expand ( fcb -- ) \ expand * to ??? + dup filename 8 (expand extension 3 (expand ; + +: (dir ( addr len -- ) + fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0 + BEGIN dup dos-error? not + WHILE $20 * dirbuf + dosfcb> tab .dosfile + fcb0 >dosfcb searchnext stop? UNTIL drop ; +\ *** Block No. 11 Hexblock B +\ File List UH 10Oct87 + +User file-link file-link off + +| : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ; + + +Forth definitions + +: forthfiles ( -- ) + file-link @ + BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ; + +Dos definitions + + +\ *** Block No. 12 Hexblock C +\ Close a file UH 10Oct87 + +' save-buffers >body $0C + @ | Alias backup + +| : filebuffer? ( fcb -- fcb bufaddr/flag ) + prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; + +| : flushfile ( fcb -- ) \ flush file buffers + BEGIN filebuffer? ?dup WHILE + dup backup emptybuf REPEAT drop ; + +: (close ( fcb -- ) \ close file in fcb + dup flushfile + dup opened dup @ 0= IF 2drop exit THEN off + >dosfcb closefile Abort" not found!" ; + +\ *** Block No. 13 Hexblock D +\ Create fcbs UH 10Oct87 + +: !files ( fcb -- ) dup isfile ! fromfile ! ; + +' r@ | Alias newfcb + +Forth definitions + +: File ( -- ) + Create here >r b/fcb allot newfcb b/fcb erase + last @ count $1F and newfcb !name + #file newfcb fileno ! + file-link @ newfcb nextfile ! r> file-link ! + Does> !files ; + +: direct 0 !files ; +\ *** Block No. 14 Hexblock E +\ flush buffers & misc. UH 10Oct87 UH 28Nov87 +Dos definitions + +: save-files ( -- ) file-link BEGIN @ ?dup WHILE + dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ; + +' save-files Is save-dos-buffers + +\ : close-files ( -- ) file-link +\ BEGIN @ ?dup WHILE dup (close REPEAT ; + +Forth definitions + +: file? isfile@ .file ; \ print current file + +: list ( n -- ) 3 spaces file? list ; +\ *** Block No. 15 Hexblock F +\ words for viewing UH 10Oct87 + +Forth definitions + +| $200 Constant viewoffset \ max. %512 kB files + +: (makeview ( -- n ) \ calc. view filed for a name + blk @ dup 0= ?exit + loadfile @ ?dup IF fileno @ viewoffset * + THEN ; + +: (view ( blk -- blk' ) \ select file and leave block + dup 0=exit + viewoffset u/mod file-link + BEGIN @ dup WHILE 2dup fileno @ = UNTIL + !files drop ; \ not found: direct access + +\ *** Block No. 16 Hexblock 10 +\ FORGETing files UH 10Oct87 + +| : remove? ( dic symb addr -- dic symb addr f ) + dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; + + +| : remove-files ( dic symb -- dic symb ) \ flush files ! + isfile@ remove? nip IF direct THEN + fromfile @ remove? nip IF fromfile off THEN + file-link + BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT + file-link remove ; + + + + +\ *** Block No. 17 Hexblock 11 +\ print a list of all buffers UH 20Oct86 + +: .buffers + prev BEGIN @ ?dup WHILE stop? abort" stopped" + cr dup u. dup 2+ @ dup 1+ + IF ." Block: " over 4+ @ 5 .r + ." File : " [ Dos ] .file + dup 6 + @ 0< IF ." updated" THEN + ELSE ." Buffer empty" drop THEN REPEAT ; + + + + + + + +\ *** Block No. 18 Hexblock 12 +\ File Interface User words UH 11Oct87 + +| : same ( addr -- ) >in ! ; +: open isfile@ (open offset off ; +: close isfile@ (close ; +: assign close isfile@ !fcb open ; +: make isfile@ dup !fcb (make ; + +| : isfile? ( addr -- addr f ) \ is adr a fcb? + file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ; + +: use >in @ name find \ create a fcb if not present + IF isfile? IF execute drop exit THEN THEN drop + dup same File same ' execute open ; + + +\ *** Block No. 19 Hexblock 13 +\ File Interface User words UH 25May88 + +: makefile >in @ File dup same ' execute same make ; +: emptyfile isfile@ >dosfcb createfile ; + +: from isfile push use ; +: loadfrom ( n -- ) + isfile push fromfile push use load close ; +: include 1 loadfrom ; + +: eof ( -- f ) isfile@ dup filesize @ swap record @ = ; + +: files " *.*" count (dir ; +: files" Ascii " word count 2dup upper (dir ; + +' files Alias dir ' files" Alias dir" +\ *** Block No. 20 Hexblock 14 +\ extend Files UH 20Nov87 + +| : >fileend isfile@ >dosfcb size drop ; + +| : addblock ( n -- ) \ add block n to file + dup buffer under b/blk bl fill + isfile@ rec/blk over filesize +! false file-r/w + IF close Abort" disk full!" THEN ; + +: more ( n -- ) open >fileend + capacity swap bounds ?DO I addblock LOOP close + open close ; + +: Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ; +0 Drive: a: Drive: b: Drive: c: Drive: d: +5 + Drive: j: drop +\ *** Block No. 21 Hexblock 15 +\ save memory-image as disk-file UH 29Nov86 + +Forth definitions + +: savefile ( from count -- ) \ filename + isfile push makefile bounds + ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!" + b/rec +LOOP close ; + + + + + + + + +\ *** Block No. 22 Hexblock 16 +\ Status UH 10OCt87 + + +: .blk ( -- ) blk @ ?dup 0=exit + dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ; + +' .blk Is .status + + + + + + + + + +\ *** Block No. 23 Hexblock 17 + + + + + + + + + + + + + + + + +\ *** Block No. 24 Hexblock 18 + + + + + + + + + + + + + + + + +\ *** Block No. 25 Hexblock 19 + + + + + + + + + + + + + + + + +\ *** Block No. 26 Hexblock 1A + + + + + + + + + + + + + + + + +\ *** Block No. 27 Hexblock 1B + + + + + + + + + + + + + + + + +\ *** Block No. 28 Hexblock 1C + + + + + + + + + + + + + + + + +\ *** Block No. 29 Hexblock 1D + + + + + + + + + + + + + + + + +\ *** Block No. 30 Hexblock 1E + + + + + + + + + + + + + + + + +\ *** Block No. 31 Hexblock 1F + + + + + + + + + + + + + + + + diff --git a/sources/cpm/hashcash.fth b/sources/cpm/hashcash.fth new file mode 100644 index 0000000..dc39e6f --- /dev/null +++ b/sources/cpm/hashcash.fth @@ -0,0 +1,85 @@ +\ *** Block No. 0 Hexblock 0 +\ HashCash Suchalgorithmus UH 11Nov86 + +Ein Algorithmus, der die Dictionarysuche beschleunigt: +Zuerst wird uebr das gesucht Wort gehasht und in in einer +Tabelle nachgesehen. Schlaegt der Versuch fehl, wird ganz normal +gesucht. Suchzeit geht auf ca. 70-80% gegenueber normalem Suchen +herunter. + +Hinzu kommen die Worte: +cash, hash-thread, erase-cash, 'cash, und found? + +Im Kernal neudefiniert oder gepatched werden muessen: +(find, hide, reveal, forget-words + +(find und (forget benutzen jejweils die alten Worte. Sie muessen +umbenannt oder in die neuen Worte eingebettet werden. +\ *** Block No. 1 Hexblock 1 +\ Hash Cash fuer volksFORTH UH 11Nov86 + +Create cash $200 allot + +' Forth >body Constant hash-thread +: erase-cash ( -- ) cash $200 erase ; erase-cash + +1 3 +thru + +patch (find +( patch forget-words ) ' forget-words \ forget-words + dup ' clear >body 6 + ! \ liegt auf einer ungluecklichen + dup ' (forget >body $12 + ! \ Adresse, sodass das automa- + dup ' empty >body 8 + ! \ tische Patchen nicht klappt. + ' save >body 4+ ! +patch hide patch reveal forget (patch save +\ *** Block No. 2 Hexblock 2 +\ 'cash found? hfind UH 23Oct86 + +: 'cash ( nfa -- 'cash ) + count $1F and under bounds + ?DO I c@ + LOOP $FF and 2* cash + ; + +: found? ( str nfa -- f ) + count rot count rot over = IF swap -text 0= exit THEN + drop 2drop false ; + +: (find ( str thread -- str false | nfa true ) + dup hash-thread - IF (find exit THEN + drop dup 'cash @ 2dup found? IF nip true exit THEN + drop hash-thread (find dup 0= ?exit over dup 'cash ! ; + + +\ *** Block No. 3 Hexblock 3 +\ Kernal changes UH 23Oct86 + +' hide >body @ | Alias last? + +: hide last? IF 0 over 'cash ! 2- @ current @ ! THEN ; + +: reveal last? IF dup dup 'cash ! 2- current @ ! THEN ; + +' clear >body 6 + @ | Alias forget-words + +| : forget-words erase-cash forget-words ; + +: .cash cash $200 bounds DO I @ ?dup IF .name THEN 2 +LOOP ; + + + +\ *** Block No. 4 Hexblock 4 +\ patching UH 23Oct86 + +: (patch ( new old -- ) + ['] cash 0 DO + i @ over = IF cr I u. over I ! THEN LOOP 2drop ; + +: patch \ name + >in @ ' swap >in ! dup >name 2- context push context ! ' + (patch ; + + + + + + + diff --git a/sources/cpm/install.fth b/sources/cpm/install.fth new file mode 100644 index 0000000..0f51c66 --- /dev/null +++ b/sources/cpm/install.fth @@ -0,0 +1,85 @@ +\ *** Block No. 0 Hexblock 0 +\\ Install Editor + +Dieses File enthaelt einen Installer fuer den Editor. + +Es werden nacheinander die Tasten erfragt, die einen bestimmten +Befehl ausloesen sollen. + +Damit ist es moeglich, die Tastatur an die individuellen +Beduerfnisse anzupassen. + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ install Editor UH 17Nov86 + +Onlyforth Editor also save warning on + +: tab &20 col &20 mod - spaces ; +: .key ( c -- ) + dup $7E > IF ." $" u. exit THEN + dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; + +: install \ install editor's keyboard + page ." Entsprechende Tasten druecken. (Blank uebernimmt.)" + #keys 0 ?DO cr I 2* actiontable + @ >name .name + tab ." : " I keytable + dup c@ .key tab ." -> " + key dup bl = IF drop dup c@ THEN dup .key swap c! + LOOP ; +--> +\ *** Block No. 2 Hexblock 2 +\ define action-names UH 29Nov86 +: :a ( addr -- adr' ) dup @ Alias 2+ ; +actiontable +:a up :a left :a down :a right +:a push-line :a push-char :a pull-line :a pull-char + :a copy-line :a copy-char +:a backspace :a backspace :a backspace :a delete-char +:a insert-char :a delete-line :a insert-line +:a flipimode ( :a erase-line) :a clear-to-right +:a new-line :a +tab :a -tab +( :a home :a to-end ) :a search :a undo +:a update-exit :a flushed-exit ( :a showload ):a shadow-screen +:a next-Screen :a back-Screen :a alter-Screen :a mark-screen +drop + +warning off install empty +\ *** Block No. 3 Hexblock 3 + UH 17Nov86 + + + + + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + diff --git a/sources/cpm/port8080.fth b/sources/cpm/port8080.fth new file mode 100644 index 0000000..8ee7d31 --- /dev/null +++ b/sources/cpm/port8080.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\ 8080-Portzugriff UH 11Nov86 + +Dieses File enthaelt Definitionen um die 8080-Ports ueber 8-Bit +Adressen anzusprechen. + +Der Code ist leider selbstmodifizierend, da beim 8080 die +Portadresse im Code ausdruecklich angegeben werden muss. + +Sollte dies unerwuenscht sein und ein Z80-Komputer vorliegen, +kann auch das File portz80.scr benutzt werden, indem die +Z80-IO-Befehle (16Bit-Adressen) benutzt werden. + + + + + +\ *** Block No. 1 Hexblock 1 +\ 8080-Portzugriff pc@, pc! 15Jul86 + +' 0 | Alias patch + +Code pc@ ( addr -- c ) + H pop L A mov here 4 + sta patch in + 0 H mvi A L mov Hpush jmp end-code + +Code pc! ( c addr -- ) + H pop L A Mov here 6 + sta H pop L A mov patch out + Next end-code + + + + + diff --git a/sources/cpm/portz80.fth b/sources/cpm/portz80.fth new file mode 100644 index 0000000..45a42c7 --- /dev/null +++ b/sources/cpm/portz80.fth @@ -0,0 +1,51 @@ +\ *** Block No. 0 Hexblock 0 +\ Z80-Portzugriff UH 05Nov86 + +Dieses File enthaelt Definitionen um die Z80-Ports ueber 16-Bit +Adressen anzusprechen. + +Einige Komputer, so die der Schneider Serie dekodieren ihre +Ports etwas unkonventionell, sodass sie unbedingt ueber 16-Bit +Adressen angesprochen werden muessen. +Im allgemeinen sollte es ausreichen 8-Bit Adressen zu benutzen. + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Z80-Portaccess Extending 8080-Assembler UH 05Nov86 + +Assembler definitions + +| : Z80-io ( base -- ) \ define special Z80-io instruction + Create c, + Does> ( reg -- ) $ED c, c@ swap 8 * + c, ; + +$40 Z80-io (c)in +$41 Z80-io (c)out + +Forth definitions + +--> + + +\ *** Block No. 2 Hexblock 2 +\ store and fetch values with 16-bit port-adresses UH 05Nov86 + +Code pc@ ( 16b -- 8b ) \ fetch 8-bit value from 16-bit port-addr + H pop IP push H B mvx L (c)in 0 H mvi + IP pop hpush jmp +end-code + +Code pc! ( 8b 16b -- ) \ store 8-bit value to 16-bit port-addr + H pop D pop IP push H B mvx E (c)out + IP pop Next +end-code + + + + + diff --git a/sources/cpm/primed.fth b/sources/cpm/primed.fth new file mode 100644 index 0000000..8f7b1a4 --- /dev/null +++ b/sources/cpm/primed.fth @@ -0,0 +1,51 @@ +\ *** Block No. 0 Hexblock 0 +\\ Primitivst Editor zur Installation UH 17Nov86 + +Da zur Installationszeit der Full-Screen Editor noch nicht +funtionsfaehig ist, muessen die zu aendernden Screens auf eine +andere Weise ge{nder werden: mit dem primitivst Editor PRIMED, +der nur ein Benutzer wort enthaelt: + +Benutzung: Mit "nn LIST" Screen nn zum editieren Anwaehlen, + dann mit "ll NEW" den Screen aendern. Es koennen immer nur + ganze Zeilen neu geschrieben werden. ll gibt an, ab welcher + Zeilennummer neue Zeilen eingeben werden sollen. Die Eingabe + einer leeren Zeile (nur RETURN) bewirkt den Abruch von NEW. + Nach jeder Eingabe von RETURN wird die eingegebene Zeile in + den Screen uebernommen, und der ganze Screen zur Kontrolle + nocheinmal ausgegeben. + +\ *** Block No. 1 Hexblock 1 +\ primitivst Editor PRIMED UH 17Nov86 + +| : !line ( adr count line# -- ) + scr @ block swap c/l * + dup c/l bl fill + swap cmove update ; + +: new ( n -- ) + l/s 1+ swap + ?DO cr I . + pad c/l expect span @ 0= IF leave THEN + pad span @ I !line cr scr @ list LOOP ; + + + + + +\ *** Block No. 2 Hexblock 2 +\ PRIMED Demo-Screen + + + +Dieser Text entstand durch: "2 LIST 4 NEW" mit anschliessender +Eingabe dieses Textes +Die Kopfzeile (Zeile 0) wurde spaeter durch Verlassen von new +durch Eingabe einer leeren Zeile (nur RETURN) und Neustart mit +"0 NEW" erzeugt. + Ulrich Hoffmann + + + + + + diff --git a/sources/cpm/printer.fth b/sources/cpm/printer.fth new file mode 100644 index 0000000..52b568b --- /dev/null +++ b/sources/cpm/printer.fth @@ -0,0 +1,272 @@ +\ *** Block No. 0 Hexblock 0 +\\ Printer Interface 08Nov86 + +Dieses File enthaelt das Printer Interface zwischen volksFORTH +und dem Drucker. + +Damit ist es moeglich Source-Texte auf bequeme Art und Weise +in uebersichtlicher Form auszudrucken (6 auf eine Seite). + +In Verbindung mit dem Multitasker ist es moeglich, auch Texte im +Hintergrund drucken zu lassen und trotztdem weiterzuarbeiten. + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Printer Interface Epson RX80 18Aug86 +\ angepasst auf M 130i 07dec85we + +Onlyforth + +Variable shadow capacity 2/ shadow ! \ s. Editor + +Vocabulary Printer Printer definitions also +| Variable printsem printsem off + + 01 +load 04 0C +thru \ M 130i - Printer +\ 01 03 +thru 06 0C +thru \ Fujitsu - Printer + +Onlyforth + + +\ *** Block No. 2 Hexblock 2 +\ Printer p! and controls UH 02Nov87 + +| : ready? ( -- f ) [ Dos ] 0 &15 biosa 0= not ; + +: p! ( n --) BEGIN pause + stop? IF printsem unlock true abort" stopped! " THEN + ready? UNTIL [ Dos ] 5 bios ; + +| : ctrl: ( 8b --) Create c, Does> ( --) c@ p! ; + +07 ctrl: BEL 7F | ctrl: DEL 0D | ctrl: RET +1B | ctrl: ESC 0A ctrl: LF 0C ctrl: FF +0F | ctrl: (+17cpi 12 | ctrl: (-17cpi + + + +\ *** Block No. 3 Hexblock 3 +\ Printer Escapes 24dec85 + +| : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; + +Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" +Ascii 2 esc: 1/6" Ascii T esc: suoff +Ascii N esc: +jump Ascii O esc: -jump +Ascii G esc: +dark Ascii H esc: -dark +\ Ascii 4 esc: +cursive Ascii 5 esc: -cursive + + +| : ESC2 ( 8b0 8b1 --) ESC p! p! ; + +| : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; +| : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; + +\ *** Block No. 4 Hexblock 4 +\ Printer Escapes 29jan86 + +Ascii W on: +wide Ascii W off: -wide +Ascii - on: +under Ascii - off: -under +Ascii S on: sub Ascii S off: super +Ascii P on: (10cpi Ascii P off: (12cpi + +: 10cpi (-17cpi (10cpi ; +: 12cpi (-17cpi (12cpi ; +: 17cpi (10cpi (+17cpi ; + +: lines ( #.of.lines --) Ascii C ESC2 ; +: "long ( inches --) 0 lines p! ; +: american 0 Ascii R ESC2 ; +: german 2 Ascii R ESC2 ; +: normal 12cpi american suoff 1/6" 0C "long RET ; +\ *** Block No. 5 Hexblock 5 +\ Printer Escapes 16Jul86 + +| : esc: ( 8b --) Create c, does> ( --) ESC c@ p! ; + +Ascii 0 esc: 1/8" Ascii 1 esc: 1/10" +Ascii 2 esc: 1/6" Ascii T esc: suoff +Ascii N esc: +jump Ascii O esc: -jump +Ascii G esc: +dark Ascii H esc: -dark +Ascii 4 esc: +cursive Ascii 5 esc: -cursive +Ascii M esc: 12cpi Ascii P | esc: (-12cpi + +: 10cpi (-12cpi (-17cpi ; +: 17cpi (-12cpi (+17cpi ; + +' 10cpi Alias pica ' 12cpi Alias elite + +\ *** Block No. 6 Hexblock 6 +\ Printer Escapes 16Jul86 + +| : ESC2 ( 8b0 8b1 --) ESC p! p! ; + +| : on: ( 8b --) Create c, does> ( --) ESC c@ p! 1 p! ; +| : off: ( 8b --) Create c, does> ( --) ESC c@ p! 0 p! ; + +Ascii W on: +wide Ascii W off: -wide +Ascii - on: +under Ascii - off: -under +Ascii S on: sub Ascii S off: super +Ascii p on: +prop Ascii p off: -prop +: lines ( #.of.lines --) Ascii C ESC2 ; +: "long ( inches --) 0 lines p! ; +: american 0 Ascii R ESC2 ; +: german 2 Ascii R ESC2 ; +: normal 12cpi american suoff 1/6" 0C "long RET ; +\ *** Block No. 7 Hexblock 7 +\ Printer Output 04Jul86 + +: prinit ; \ initializing Printer + +| Variable pcol pcol off | Variable prow prow off +| : pemit ( 8b --) p! 1 pcol +! ; +| : pcr ( --) RET LF 1 prow +! pcol off ; +| : pdel ( --) DEL pcol @ 1- 0 max pcol ! ; +| : ppage ( --) FF prow off pcol off ; +| : pat ( row col --) over prow @ < IF ppage THEN + swap prow @ - 0 ?DO pcr LOOP + dup pcol @ < IF RET pcol off THEN pcol @ - spaces ; +| : pat? ( -- row col) prow @ pcol @ ; +| : ptype ( adr len --) + dup pcol +! bounds ?DO I c@ p! LOOP ; + +\ *** Block No. 8 Hexblock 8 +\ Printer output 28Jun86 + +| Output: >printer pemit pcr ptype pdel ppage pat pat? ; + +Forth definitions + +: print >printer normal ; + +: printable? ( char -- f) bl Ascii ~ uwithin ; + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ Variables and Setup 23Oct86 + +Printer definitions + +$00 | Constant logo | Variable pageno +| Create scr#s $0E allot \ enough room for 6 screens + +| : header ( -- ) + 12cpi 4 spaces ." Page No " +dark pageno @ 2 .r + $0D spaces ." volksFORTH83 der FORTH-Gesellschaft eV " + 5 spaces file? -dark 1 pageno +! 17cpi ; + + + + + +\ *** Block No. 10 Hexblock A +\ Print 2 screens across on a page 03dec85 + +| : text? ( scr# -- f) block dup c@ printable? + IF b/blk -trailing nip 0= THEN 0= ; + +| : pr ( scr# --) dup capacity 1- u> IF drop logo THEN + 1 scr#s +! scr#s dup @ 2* + ! ; + +| : 2pr ( scr#1 scr#2 line# --) cr dup 2 .r space c/l * >r + pad $101 bl fill swap block r@ + pad c/l cmove + block r> + pad c/l + 1+ c/l cmove pad $101 -trailing type ; + +| : 2scr ( scr#1 scr#2 --) cr cr $1E spaces + +wide +dark over 4 .r $1C spaces dup 4 .r -wide -dark + cr l/s 0 DO 2dup I 2pr LOOP 2drop ; + +\ *** Block No. 11 Hexblock B +\ Printer 6 screens on a page 03dec85 + +| : pr-start ( --) scr#s off 1 pageno ! ; + +| : pagepr ( --) header scr#s off scr#s 2+ + 3 0 DO dup @ over 6 + @ 2scr 2+ LOOP drop page ; + +| : shadowpr ( --) header scr#s off scr#s 2+ + 3 0 DO dup @ over 2+ @ 2scr 4 + LOOP drop page ; + +| : pr-flush ( -- f) scr#s @ dup \ any screens left over? + IF BEGIN scr#s @ 5 < WHILE -1 pr REPEAT logo pr THEN + 0<> ; + + + +\ *** Block No. 12 Hexblock C +\ Printer 6 screens on a page 23Nov86 +Forth definitions + +: pthru ( first last --) + printsem lock output push print pr-start 1+ swap + ?DO I text? IF I pr THEN scr#s @ 6 = IF pagepr THEN + LOOP pr-flush IF pagepr THEN printsem unlock ; + +: document ( first last --) + isfile@ IF capacity 2/ shadow ! THEN + printsem lock output push print pr-start 1+ swap + ?DO I text? IF I pr I shadow @ + pr THEN + scr#s @ 6 = IF shadowpr THEN LOOP + pr-flush IF shadowpr THEN printsem unlock ; + +: listing ( --) 0 capacity 2/ 1- document ; +\ *** Block No. 13 Hexblock D +\ Printerspool 03Nov86 + +\needs Task \\ + +| Input: noinput 0 false drop 2drop ; + + +$100 $200 noinput Task spooler + +keyboard + +: spool ( from to -- ) + isfile@ spooler 3 pass isfile ! pthru stop ; + + + +\ *** Block No. 14 Hexblock E + + + + + + + + + + + + + + + + +\ *** Block No. 15 Hexblock F + + + + + + + + + + + + + + + + diff --git a/sources/cpm/relocate.fth b/sources/cpm/relocate.fth new file mode 100644 index 0000000..01ac3ea --- /dev/null +++ b/sources/cpm/relocate.fth @@ -0,0 +1,51 @@ +\ *** Block No. 0 Hexblock 0 +\\ Relocate System 11Nov86 + +Dieses File enthaelt das Utility-Wort BUFFERS. +Mit ihm ist es moeglich die Zahl der Disk-Buffers festzulegen, +die volksFORTH benutzt. Voreingestellt sind 4 Buffer. + +Benutzung: nn BUFFERS + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Relocate a system 16Jul86 + +| : relocate-tasks ( mainup -- ) up@ dup + BEGIN 2+ under @ 2dup - WHILE rot drop REPEAT 2drop ! ; + +| : relocate ( stacklen rstacklen -- ) + 2dup + b/buf + 2+ limit origin - + u> abort" kills all buffers" + over pad $100 + origin - u< abort" cuts the dictionary" + dup udp @ $40 + + u< abort" a ticket to the moon with no return ..." + flush empty over + origin + + origin $0A + ! \ r0 + origin + dup relocate-tasks \ multitasking link + 6 - origin 8 + ! \ s0 + cold ; --> +\ *** Block No. 2 Hexblock 2 +\ bytes.more buffers 29Jun86 + +| : bytes.more ( n+- -- ) + up@ origin - + r0 @ up@ - relocate ; + +: buffers ( +n -- ) + b/buf * 4+ limit r0 @ - swap - bytes.more ; + + + + + + + + + diff --git a/sources/cpm/savesys.fth b/sources/cpm/savesys.fth new file mode 100644 index 0000000..8d0ba29 --- /dev/null +++ b/sources/cpm/savesys.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\\ savesystem 11Nov86 + +Dieses File enthaelt das Utility-Wort SAVESYSTEM. + +Mit ihm kann man das gesamte System als File auf Disk schreiben. + +Achtung: + Es wird SAVE ausgefuehrt, daher ist nach SAVESYSTEM + der Heap geloescht! + +Benutzung: SAVESYSTEM + + + + + +\ *** Block No. 1 Hexblock 1 +\ savsystem 05Nov86 + +: savesystem \ filename + save $100 here over - savefile ; + + +\\ Einfaches savesystem 18Aug86 + +| : message ( -- ) + base push decimal + cr ." ready for SAVE " here 1- $100 / u. + ." VOLKS4TH.COM" cr ; + +: savesystem ( -- ) save message bye ; + + diff --git a/sources/cpm/see.fth b/sources/cpm/see.fth new file mode 100644 index 0000000..fd594a8 --- /dev/null +++ b/sources/cpm/see.fth @@ -0,0 +1,408 @@ +\ *** Block No. 0 Hexblock 0 +\ Extended-Decompiler for VolksForth LOAD-SCREEN UH 07Nov86 + +Dieses File enthaelt einen Decompiler, der bereits kompilierte +Worte wieder in Sourcetextform bringt. +Strukturierte Worte wie IF THEN ELSE, BEGIN WHILE REPEAT UNTIL +und DO LOOP +LOOP werden in einem an AI-grenzenden Vorgang +erkannt und umgeformt. +Ein Decompiler kann aber keine (Stack-) Kommentare wieder +herzaubern, die Benutzung der Screens und dann view, wird +daher staerkstens empfohlen. + +Denn: Es ist immernoch ein Fehler drin! +Und um den zu korrigieren, ist der Sourcetext dem Objektkode +doch vorzuziehen. + + Benutzung: see +\ *** Block No. 1 Hexblock 1 +\ Extended-Decompiler for VolksForth LOAD-SCREEN 07Nov86 + +Onlyforth Tools also definitions + +1 13 +thru + +\\ +Produces compilable Forth source from normal compiled Forth. + + These source blocks are based on the works of + + Henry Laxen, Mike Perry and Wil Baden + + volksFORTH version: U. Hoffmann + + +\ *** Block No. 2 Hexblock 2 +\ detacting does> 01Jul86 + +internal + +' does> 4+ @ Alias (;code +' Forth @ 1+ @ Constant (dodoes> + +: does? ( IP - f ) + dup c@ $CD ( call ) = swap + 1+ @ (dodoes> = and ; + + + + + + +\ *** Block No. 3 Hexblock 3 +\ indentation. 04Jul86 +Variable #spaces #spaces off + +: +in ( -- ) 3 #spaces +! ; + +: -in ( -- ) -3 #spaces +! ; + +: ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; + +: ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; + + + + + + +\ *** Block No. 4 Hexblock 4 +\ case defining words 01Jul86 + +: Case: ( -- ) + Create: Does> swap 2* + perform ; + +: Associative: ( n -- ) + Constant Does> ( n - index ) + dup @ -rot dup @ 0 + DO 2+ 2dup @ = + IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; + + + + + + +\ *** Block No. 5 Hexblock 5 +\ branching 04Jul86 + +Variable #branches Variable #branch + +: branch-type ( n -- a ) 6 * pad + ; +: branch-from ( n -- a ) branch-type 2+ ; +: branch-to ( n -- a ) branch-type 4+ ; + +: branched ( adr type -- ) \ Make entry in branch-table. + #branches @ branch-type ! dup #branches @ branch-from ! + 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; + +\\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } + + + +\ *** Block No. 6 Hexblock 6 +\ branching 01Jul86 + +: branch-back ( adr type -- ) + \ : make entry in branch-table & reclassify branch-type.) + over swap branched + 2+ dup dup @ + swap 2+ ( loop-start,-end.) + 0 #branches @ 1- + ?DO + over I branch-from @ u> IF LEAVE THEN + dup I branch-to @ = IF ['] while I branch-type ! THEN + -1 +LOOP 2drop ; + + + + + +\ *** Block No. 7 Hexblock 7 +\ branching 01Jul86 +: forward? ( ip -- f ) 2+ @ 0> ; + +: ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? + IF ['] if branched exit THEN ['] until branch-back ; + +: branch+ ( ip -- ip' ) dup 4+ swap dup forward? + IF ['] else branched exit THEN ['] repeat branch-back ; + +: (loop)+ ( ip -- ip' ) + dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; + +: string+ ( ip -- ip' ) 2+ count + even ; + +: (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; + +\ *** Block No. 8 Hexblock 8 +\ classify each word 25Aug86 +Forth + +&15 Associative: execution-class + ] clit lit ?branch branch + (do (." (abort" (;code + (" (?do (loop + (+loop unnest (is compile [ + +Case: execution-class+ + 3+ 4+ ?branch+ branch+ + 2+ string+ string+ (;code+ + string+ 2+ 4+ + 4+ 0= 4+ 4+ 2+ ; + +Tools +\ *** Block No. 9 Hexblock 9 +\ first pass 01Jul86 + +: pass1 ( cfa -- ) #branches off >body + BEGIN dup @ execution-class execution-class+ + dup 0= stop? or + UNTIL drop ; + + + + + + + + + + +\ *** Block No. 10 Hexblock A +\ identify branch destinations. 04Jul86 +: thru.branchtable ( -- limit start ) #branches @ 0 ; +: ?.then ( ip -- ) thru.branchtable + ?DO I branch-to @ over = + IF I branch-from @ over u< + IF I branch-type @ dup ['] else = swap ['] if = or + IF -in ." THEN " ind-cr LEAVE THEN THEN THEN + LOOP ; +: ?.begin ( ip -- ) thru.branchtable + ?DO I branch-to @ over = + IF I branch-from @ over u< not + IF I branch-type @ dup + ['] repeat = swap ['] until = or + IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN + LOOP ; +( put "BEGIN" and "THEN" where used.) +\ *** Block No. 11 Hexblock B +\ decompile each type of word 01Jul86 + +: .word ( ip -- ip' ) dup @ >name .name 2+ ; + +: .(word ( ip -- ip' ) dup @ >name + ?dup 0= IF ." ??? " ELSE + count $1f and swap 1+ swap 1- type space THEN 2+ ; +: .inline ( val16b -- ) + dup >name ?dup IF ." ['] " .name drop exit THEN . ; + +: .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; +: .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; +: .string ( ip -- ip' ) + .(word count 2dup type Ascii " emit space + even ?.then ; + +: .unnest ( ip -- 0 ) ." ; " 0= ; +\ *** Block No. 12 Hexblock C +\ decompile each type of word 01Jul86 + +: .default ( ip -- ip' ) dup @ >name ?dup IF + c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; + +: .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; + +: .compile ( ip -- ip' ) .word .word ?.then ; + + + + + + + + +\ *** Block No. 13 Hexblock D +\ decompiling conditionals 04Jul86 + +: .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; +: .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; +: .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; +: .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; +: .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; + +5 Associative: branch-class + ' if , ' while , ' else , ' repeat , ' until , +Case: .branch-class + .if .else .else .repeat .repeat ; + +: .branch ( ip -- ip' ) + #branch @ branch-type @ 1 #branch +! + dup >name swap branch-class .branch-class ; +\ *** Block No. 14 Hexblock E +\ decompile Does> ;code 04Jul86 + +: .(;code ( IP - IP' f) + 2+ dup does? + IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; + + + + + + + + + + + +\ *** Block No. 15 Hexblock F +\ classify word's output 01Jul86 + +Case: .execution-class + .clit .lit .branch .branch + .do .string .string .(;code + .string .do .loop + .loop .unnest .['] .compile + .default ; + + + + + + + + +\ *** Block No. 16 Hexblock 10 +\ decompile colon-definitions 04Jul86 + +: pass2 ( cfa -- ) #branch off >body + BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class + dup 0= stop? or + UNTIL drop ; + +: .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; + +: .immediate ( cfa - ) >name c@ dup + ?ind-cr 40 and IF ." IMMEDIATE " THEN + ?ind-cr 80 and IF ." RESTRICT" THEN ; + +: .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; + + +\ *** Block No. 17 Hexblock 11 +\ display category of word 01Jul86 +external Defer (see internal + +: .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; + +: .user-variable ( cfa - ) ." USER " dup >name dup .name + 3 spaces swap execute @ u. .name ." ! " ; + +: .defer ( cfa - ) + ." deferred " dup >name .name ." Is " >body @ (see ; + +: .other ( cfa - ) dup >name .name + dup @ over >body = IF drop ." is Code " exit THEN + dup @ does? IF .does> exit THEN + drop ." is unknown " ; + +\ *** Block No. 18 Hexblock 12 +\ decompiling variables and constants 01Jul86 + +: .constant ( cfa - ) + dup >body @ u. ." CONSTANT " >name .name ; + +: .variable ( cfa - ) ." VARIABLE " + dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; + + + + + + + + + +\ *** Block No. 19 Hexblock 13 +\ classify a word UH 25Jan88 + +5 Associative: definition-class + ' quit @ , ' 0 @ , ' scr @ , ' base @ , + ' 'cold @ , + +Case: .definition-class + .: .constant .variable .user-variable + .defer .other ; + + + + + + + +\ *** Block No. 20 Hexblock 14 +\ Top level of Decompiler 04Jul86 + +external + +: ((see ( cfa -) + #spaces off cr + dup dup @ + definition-class .definition-class .immediate ; + +' ((see Is (see + +Forth definitions +: see ' (see ; + + + +\ *** Block No. 21 Hexblock 15 + + + + + + + + + + + + + + + + +\ *** Block No. 22 Hexblock 16 + + + + + + + + + + + + + + + + +\ *** Block No. 23 Hexblock 17 + + + + + + + + + + + + + + + + diff --git a/sources/cpm/simpfile.fth b/sources/cpm/simpfile.fth new file mode 100644 index 0000000..0c0387c --- /dev/null +++ b/sources/cpm/simpfile.fth @@ -0,0 +1,68 @@ +\ *** Block No. 0 Hexblock 0 +\\ Simple Files 11Nov86 + +Wenn volksFORTH im Direktzugriff Disketten bearbeitet, ist es +trotzdem wuenschenswert eine Art File-Struktur zu besitzen. +Dieses File enthaelt eine einfache Implementation eines +Filesystems. Der/die Programmierer/in muss selbst die Direktory +auf dem laufenden halten: in ihr sind die Start-Bloecke des +entsprechenden Diskettenteils gespeichert. +Sogar eine Hierarchie von Direktories laesst sich so relisieren. + +Vorgestellt wurde dieses FileSystem von Georg Rehfeld und auch +von ihm fuer volksFORTH implementiert (ultraFORTH auf dem C64). + + + + +\ *** Block No. 1 Hexblock 1 +\ simple files 12feb86 + +\needs search .( search missing) \\ + +| Variable (dir : dir (dir @ ; : root 0 (dir ! ; root + +| : read" ( -- n) + Ascii " word count dup >r dir block b/blk search + 0= abort" not found" r> + >in push >in ! + bl dir block b/blk (word number drop ; + +: load" read" dir + load ; : dir" read" (dir +! ; +: list" read" dir + list ; + +\ 1 +load \ Only if file" is needed + +\ *** Block No. 2 Hexblock 2 +\ simple files 01feb86 + +| : snap ( n0 -- n1) $20 / 3 max $20 * ; +: file" ( n --) + Ascii " word count 2dup dir block b/blk search + IF + nip + ELSE drop dir block b/blk -trailing nip snap $20 + + dup b/blk 1- > abort" directory full" + 2dup + >r dir block + swap cmove r> + THEN snap $18 + >r + dir - extend under dabs <# # # # # + base @ $0A = IF Ascii & ELSE Ascii $ THEN hold + rot 0< IF Ascii - ELSE bl THEN hold #> + r> dir block + swap cmove update ; + + +\ *** Block No. 3 Hexblock 3 +\ dir load" 11feb86 + +\needs search .( search missing) \\ + +0 Constant dir + +: load" ( -- ) + Ascii " word count dup >r dir block b/blk search + 0= abort" not found" r> + + >in @ blk @ rot >in ! dir blk ! + bl word number drop -rot blk ! >in ! load ; + + + + + diff --git a/sources/cpm/source.fth b/sources/cpm/source.fth new file mode 100644 index 0000000..a304356 --- /dev/null +++ b/sources/cpm/source.fth @@ -0,0 +1,2176 @@ +\ *** Block No. 0 Hexblock 0 +\\ volksFORTH CP/M 2.2 rev. 3.80a 18Nov87 + +Entwicklung des volksFORTH-83 von + K. Schleisiek, B. Pennemann, + G. Rehfeld, D. Weineck, U. Hoffmann + +Anpassung fuer Intel 8080 und CP/M 2.2 von U. Hoffmann + +Dieses File enthaelt den kompletten Sourcetext des Kern-Systems +fuer die Intel 8080-CPU und die Anpassung an CP/M 2.2 und CP/M+. +Mit Hilfe eines Target-Compilers wird daraus das volksFORTH- +System erzeugt, daher finden sich an einigen Stellen Anweisungen +an den Target-Compiler, die fuer das Verstaendnis des Systems +nicht wichtig sind. +Version 3.80a enthaelt gegenueber 3.80 einige Aenderungen, ins- +besondere die Bdos-Schnittstelle fuer Disk-IO im Kern. +\ *** Block No. 1 Hexblock 1 +\ CP/M 2.2 volksForth Load Screen 27Nov87 + +Onlyforth + $9000 displace ! +Target definitions $100 here! + + + 1 $74 +thru \ Standard 8080-System + +cr .( unresolved: ) .unresolved ( ' .blk is .status ) + +save-target KERNEL.COM + + + + +\ *** Block No. 2 Hexblock 2 +\ FORTH Preamble and ID uho 19May2005 + +Assembler + +nop 0 jmp here 2- >label >boot +nop 0 jmp here 2- >label >cold +nop 0 jmp here 2- >label >restart + +here dup origin! +\ Hier beginnen die Kaltstartwerte der Benutzervariablen + +6 rst 0 jmp end-code \ for multitasker + +$100 allot + +| Create logo ," volksFORTH-83 rev. 3.80a" +\ *** Block No. 3 Hexblock 3 +\ Assembler Labels Next Forth-Register 29Jun86 + +Label dpush D push Label hpush H push +Label >next + IP ldax IP inx A L mov IP ldax IP inx A H mov +Label >next1 + M E mov H inx M D mov xchg pchl +end-code + +Variable RP +Variable UP +\ IP in BC +\ W in DE +\ SP in SP +Variable IPsave + +\ *** Block No. 4 Hexblock 4 +\ Assembler Macros 20Oct86 +Compiler Assembler also definitions Forth +: Next T >next jmp [ Forth ] ; +T hpush Forth Constant hpush T dpush Forth Constant dpush +T >next Forth Constant >next + +: rpush ( reg -- ) RP lhld H dcx DUP M mov ( high ) + H dcx 1+ M mov ( low ) RP shld [ Forth ] ; + +: rpop ( reg -- ) RP lhld M over 1+ mov ( low ) H inx + M swap mov ( high ) H inx RP shld [ Forth ] ; +\ rpush und rpop gehen nicht mit HL + +: mvx ( src dest -- ) + 2dup mov ( high ) 1+ swap 1+ swap mov ( low ) [ Forth ] ; +Target +\ *** Block No. 5 Hexblock 5 +\ recover ;c: noop 20Oct86 + +Create recover Assembler + W pop IP rpush W IP mvx +Next end-code + +Compiler Assembler also definitions Forth + +: ;c: 0 T recover call end-code ] [ Forth ] ; + +Target + +| Code di di Next end-code +| Code ei ei Next end-code + +Code noop >next here 2- ! end-code +\ *** Block No. 6 Hexblock 6 +\ User variables 04Oct87 + +Constant origin 8 uallot drop \ Multitasker + \ Felder: entry link spare SPsave + \ Laenge kompatibel zum 68000 und 6502 volksFORTH +User s0 +User r0 +User dp +User offset 0 offset ! +User base $0A base ! +User output +User input +User errorhandler \ pointer for Abort" -code +User voc-link +User udp \ points to next free addr in User + +\ *** Block No. 7 Hexblock 7 +\ manipulate system pointers 11Jun86 + +Code sp@ ( -- addr) 0 H lxi SP dad hpush jmp end-code + +Code sp! ( addr --) H pop sphl Next end-code + + +Code up@ ( -- addr) UP lhld hpush jmp end-code + +Code up! ( addr --) H pop UP shld Next end-code + + + + + + +\ *** Block No. 8 Hexblock 8 +\ manipulate returnstack 11Jun86 + +Code rp@ ( -- addr ) RP lhld hpush jmp end-code + +Code rp! ( addr -- ) H pop RP shld Next end-code + + +Code >r ( 16b -- ) D pop D rpush Next end-code restrict + +Code r> ( -- 16b ) D rpop D push Next end-code restrict + + + + + + +\ *** Block No. 9 Hexblock 9 +\ r@ rdrop exit unnest ?exit 07Oct87 +Code r@ ( -- 16b ) + RP lhld M E mov H inx M D mov D push Next end-code + +Code rdrop + RP lhld H inx H inx RP shld Next end-code restrict + +Code exit Label >exit IP rpop Next end-code +Code unnest >exit here 2- ! + +Code ?exit ( flag -- ) + H pop H A mov L ora >exit jnz Next end-code + +Code 0=exit ( flag -- ) + H pop H A mov L ora >exit jz Next end-code +\ : ?exit ( flag -- ) IF rdrop THEN ; +\ *** Block No. 10 Hexblock A +\ execute perform 11Jun86 18Nov87 + +Code execute ( cfa -- ) + H pop >Next1 jmp end-code + +Code perform ( 'cfa -- ) + H pop M A mov H inx M H mov A L mov >Next1 jmp +end-code + + +\\ +: perform ( addr -- ) @ execute ; + + + + +\ *** Block No. 11 Hexblock B +\ c@ c! ctoggle 07Oct87 + +Code c@ ( addr -- 8b ) + H pop M L mov 0 H mvi hpush jmp end-code + +Code c! ( 16b addr -- ) + H pop D pop E M mov Next end-code + +Code flip ( 16b1 -- 16b2 ) + H pop H A mov L H mov A L mov Hpush jmp end-code + +Code ctoggle ( 8b addr -- ) + H pop D pop M A mov E xra A M mov Next end-code + +\\ +: ctoggle ( 8b addr --) under c@ xor swap c! ; +\ *** Block No. 12 Hexblock C +\ @ ! 2@ 2! 11Jun86 18Nov87 + +Code @ ( addr -- 16b ) H pop Label fetch + M E mov H inx M D mov D push Next end-code + +Code ! ( 16b addr -- ) + H pop D pop E M mov H inx D M mov Next end-code + +Code 2@ ( addr -- 32b ) H pop H push + H inx H inx M E mov H inx M D mov H pop D push + M E mov H inx M D mov D push Next end-code + +Code 2! ( 32b addr -- ) H pop + D pop E M mov H inx D M mov H inx + D pop E M mov H inx D M mov Next end-code + +\ *** Block No. 13 Hexblock D +\ +! drop swap 11Jun86 18Nov87 + +Code +! ( 16b addr -- ) H pop + Label +store D pop + M A mov E add A M mov H inx + M A mov D adc A M mov Next end-code + +\ : +! ( n addr -- ) under @ + swap ! ; + + +Code drop ( 16b -- ) H pop Next end-code + +Code swap ( 16b1 16b2 -- 16b2 16b1 ) + H pop xthl hpush jmp end-code + + +\ *** Block No. 14 Hexblock E +\ dup ?dup 16May86 + +Code dup ( 16b -- 16b 16b ) + H pop H push hpush jmp end-code + +Code ?dup ( 16b -- 16b 16b / false) + H pop H A mov L ora 0<> ?[ H push ]? + hpush jmp end-code + +\\ +: ?dup ( 16b -- 16b 16b / false) dup IF dup THEN ; + +: dup ( 16b -- 16b 16b ) sp@ @ ; + + + +\ *** Block No. 15 Hexblock F +\ over rot nip under 11Jun86 + +Code over ( 16b1 16b2 - 16b1 16b2 16b1 ) + D pop H pop H push dpush jmp end-code +Code rot ( 16b1 16b2 16b3 - 16b2 16b3 16b1 ) + D pop H pop xthl dpush jmp end-code +Code nip ( 16b1 16b2 -- 16b2) + H pop D pop hpush jmp end-code +Code under ( 16b1 16b2 -- 16b2 16b1 16b2) + H pop D pop H push dpush jmp end-code + +\\ +: over >r swap r> swap ; +: rot >r dup r> swap ; +: nip swap drop ; +: under swap over ; +\ *** Block No. 16 Hexblock 10 +\ -rot pick roll -roll 11Jun86 +Code -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) + H pop D pop xthl H push D push Next end-code + +Code pick ( n -- 16b.n ) + H pop H dad SP dad + M E mov H inx M D mov D push Next end-code + +: roll ( n -- ) + dup >r pick sp@ dup 2+ r> 1+ 2* cmove> drop ; + +: -roll ( n -- ) >r dup sp@ dup 2+ + dup 2+ swap r@ 2* cmove r> 1+ 2* + ! ; +\\ +: -rot ( 16b1 16b2 16b3 -- 16b3 16b1 16b2 ) rot rot ; +: pick ( n -- 16b.n ) 1+ 2* sp@ + @ ; +\ *** Block No. 17 Hexblock 11 +\ double word stack manipulation 09May86 +Code 2swap ( 32b1 32b2 -- 32b2 32b1) + H pop D pop xthl H push + 5 H lxi SP dad M A mov D M mov A D mov + H dcx M A mov E M mov A E mov H pop dpush jmp +end-code + +Code 2drop ( 32b -- ) H pop H pop Next end-code + +Code 2dup ( 32b -- 32b 32b) + H pop D pop D push H push dpush jmp end-code + +\\ +: 2swap ( 32b1 32b2 -- 32b2 32b1) rot >r rot r> ; +: 2drop ( 32b -- ) drop drop ; +: 2dup ( 32b -- 32b 32b) over over ; +\ *** Block No. 18 Hexblock 12 +\ + and or xor not 09May86 +Code + ( n1 n2 -- n3 ) + H pop D pop D dad hpush jmp end-code +Code or ( 16b1 16b2 -- 16b3 ) + H pop D pop H A mov D ora A H mov + L A mov E ora A L mov hpush jmp end-code +Code and ( 16b1 16b2 -- 16b3 ) + H pop D pop H A mov D ana A H mov + L A mov E ana A L mov hpush jmp end-code +Code xor ( 16b1 16b2 -- 16b3 ) + H pop D pop H A mov D xra A H mov + L A mov E xra A L mov hpush jmp end-code +Code not ( 16b1 -- 16b2 ) H pop Label >not + H A mov cma A H mov L A mov cma A L mov + hpush jmp end-code + +\ *** Block No. 19 Hexblock 13 +\ - negate 16May86 + +Code - ( n1 n2 -- n3 ) + D pop H pop + L A mov E sub A L mov + H A mov D sbb A H mov hpush jmp end-code + +Code negate ( n1 -- n2 ) + H pop H dcx >not jmp end-code + +\\ +: - ( n1 n2 -- n3 ) negate + ; + + + + +\ *** Block No. 20 Hexblock 14 +\ dnegate d+ 10Mar86 18Nov87 + +Code dnegate ( d1 -- -d1 ) H pop + Label >dnegate + D pop A sub E sub A E mov 0 A mvi D sbb + A D mov 0 A mvi L sbb A L mov 0 A mvi H sbb + A H mov dpush jmp end-code + +Code d+ ( d1 d2 -- d3) + 6 H lxi SP dad M E mov C M mov H inx + M D mov B M mov B pop H pop D dad xchg + H pop L A mov C adc A L mov H A mov B adc + A H mov B pop dpush jmp end-code + + + +\ *** Block No. 21 Hexblock 15 +\ 1+ 2+ 3+ 4+ 6+ 1- 2- 4- 27Apr86 +Code 1+ ( n1 -- n2 ) H pop H inx hpush jmp end-code +Code 2+ ( n1 -- n2 ) + H pop H inx H inx hpush jmp end-code +Code 3+ ( n1 -- n2 ) + H pop H inx H inx H inx hpush jmp end-code +Code 4+ ( n1 -- n2 ) + H pop 4 D lxi D dad hpush jmp end-code +| Code 6+ ( n1 -- n2 ) + H pop 6 D lxi D dad hpush jmp end-code +Code 1- ( n1 -- n2 ) H pop H dcx hpush jmp end-code +Code 2- ( n1 -- n2 ) + H pop H dcx H dcx hpush jmp end-code +Code 4- ( n1 -- n2 ) + H pop -4 D lxi D dad hpush jmp end-code + +\ *** Block No. 22 Hexblock 16 +\ number Constants 07Oct87 +-1 Constant true 0 Constant false + + 0 ( -- 0 ) Constant 0 + 1 ( -- 1 ) Constant 1 + 2 ( -- 2 ) Constant 2 + 3 ( -- 3 ) Constant 3 + 4 ( -- 4 ) Constant 4 +-1 ( -- -1 ) Constant -1 + +Code on ( addr -- ) H pop $FF A mvi + Label set A M mov H inx A M mov Next +Code off ( addr -- ) H pop A xra set jmp end-code + +\ : on ( addr -- ) true swap ! ; +\ : off ( addr -- ) false swap ! ; +\ *** Block No. 23 Hexblock 17 +\ words for number literals 16May86 + +Code lit ( -- 16b ) + IP ldax A L mov IP inx IP ldax A H mov IP inx +hpush jmp end-code + +Code clit ( -- 8b ) + IP ldax A L mov 0 H mvi IP inx hpush jmp +end-code + +: Literal ( 16b -- ) + dup $FF00 and IF compile lit , exit THEN + compile clit c, ; immediate restrict + + + +\ *** Block No. 24 Hexblock 18 +\ comparision words 18Nov87 +Label (u< ( HL,DE -> HL u< DE c,z ) + H A mov D cmp rnz L A mov E cmp ret +Label (< ( HL,DE -> HL < DE c,z ) + H A mov D xra (u< jp D A mov H cmp ret + +Label yes true H lxi hpush jmp +Code u< ( u1 u2 -- flag ) D pop H pop + Label uless (u< call yes jc + Label no false H lxi hpush jmp + +Code < ( n1 n2 -- flag ) D pop H pop + Label less (< call yes jc no jmp end-code + +Code u> ( u1 u2 -- flag ) H pop D pop uless jmp end-code +Code > ( n1 n2 -- flag ) H pop D pop less jmp end-code +\ *** Block No. 25 Hexblock 19 +\ comparision words 18Nov87 +Code 0< ( n1 n2 -- flag ) H pop + Label negative H dad yes jc no jmp end-code + +Code 0> ( n -- flag ) H pop H A mov A ora no jm + L ora yes jnz no jmp end-code + +Code 0= ( n -- flag ) H pop + Label zero= H A mov L ora yes jz no jmp end-code + +Code 0<> ( n -- flag ) + H pop H A mov L ora yes jnz no jmp end-code + +Code = ( n1 n2 -- flag ) H pop D pop + L A mov E cmp no jnz + H A mov D cmp no jnz yes jmp end-code +\ *** Block No. 26 Hexblock 1A +\\ comparision words high level 18Nov87 +: 0< ( n1 -- flag ) 8000 and 0<> ; +: > ( n1 n2 -- flag ) swap < ; +: 0> ( n -- flag ) negate 0< ; +: 0<> ( n -- flag ) 0= not ; +: u> ( u1 u2 -- flag ) swap u< ; +: = ( n1 n2 -- flag ) - 0= ; +: uwithin ( u1 [low up[ -- flag ) over - -rot - u> ; +| : minimax ( n1 n2 flag -- n3 ) rdrop IF swap THEN drop ; +: min ( n1 n2 -- n3 ) 2dup > minimax ; +: max ( n1 n2 -- n3 ) 2dup < minimax ; +: umax ( u1 u2 -- u3 ) 2dup u< minimax ; +: umin ( u1 u2 -- u3 ) 2dup u> minimax ; +: extend ( n -- d ) dup 0< ; +: dabs ( d -- ud ) extend IF dnegate THEN ; +: abs ( n -- u) extend IF negate THEN ; +\ *** Block No. 27 Hexblock 1B +\ uwthin double number comparison words 18Nov87 + +Code uwithin ( u1 [low up[ -- flag ) H pop D pop xthl + (u< call cs ?[ H pop no jmp ]? + D pop (u< call yes jc no jmp end-code + +Code d0= ( d -- flag ) H pop + H A mov L ora H pop no jnz zero= jmp end-code + +: d= ( d1 d2 -- flag ) rot = -rot = and ; +: d< ( d1 d2 -- flag ) + rot 2dup = IF 2drop u< exit THEN > nip nip ; + + +\\ +: d0= ( d -- flag ) or 0= ; +\ *** Block No. 28 Hexblock 1C +\ minimum maximum 18Nov87 + +Code umax ( u1 u2 -- u3 ) + H pop D pop (u< call +Label minimax cs ?[ xchg ]? hpush jmp end-code + +Code umin ( u1 u2 -- u3 ) + H pop D pop (u< call cmc minimax jmp end-code + +Code max ( n1 n2 -- n3 ) + H pop D pop (< call minimax jmp end-code + +Code min ( n1 n2 -- n3 ) + H pop D pop (< call cmc minimax jmp end-code + + +\ *** Block No. 29 Hexblock 1D +\ sign extension absolute values 18Nov87 + +Code extend ( n -- d ) H pop H push negative jmp end-code + +Code abs ( a -- u ) H pop H A mov A ora + hpush jp H dcx >not jmp end-code + +Code dabs ( d -- ud ) H pop H A mov A ora + hpush jp >dnegate jmp end-code + + + + + + + +\ *** Block No. 30 Hexblock 1E +\ branch ?branch 20Nov87 + +Code branch ( -- ) Label >branch + IP H mvx M E mov H inx M D mov H dcx + D dad H IP mvx Next end-code + +Code ?branch ( fl -- ) + H pop H A mov L ora >branch jz + IP inx IP inx Next end-code + + +\\ +: branch r> dup @ + >r ; + + + +\ *** Block No. 31 Hexblock 1F +\ loop primitives 11Jun86 20Nov87 + +Code bounds ( start count -- limit start ) + H pop D pop D dad H push D push Next end-code + +Code endloop + RP lhld 6 D lxi D dad RP shld next end-code restrict + +\\ dodo puts "index | limit | adr.of.DO" on return-stack +: bounds ( start count -- limit start ) over + swap ; + +| : dodo rdrop r> 2+ dup >r rot >r swap >r >r ; + +: (do ( limit start -- ) over - dodo ; restrict +: (?do ( limit start -- ) over - ?dup IF dodo THEN + r> dup @ + >r drop ; restrict +\ *** Block No. 32 Hexblock 20 +\ loop primitives 20Nov87 + +Code (do ( limit start -- ) H pop D pop + Label >do + L A mov E sub A L mov + H A mov D sbb A H mov + H push IP inx IP inx + RP lhld H dcx IP M mov H dcx IP' M mov + H dcx D M mov H dcx E M mov + D pop H dcx D M mov H dcx E M mov RP shld + Next end-code restrict + +Code (?do ( limit start -- ) H pop D pop + H A mov D cmp >do jnz + L A mov E cmp >do jnz >branch jmp +end-code restrict +\ *** Block No. 33 Hexblock 21 +\ (loop (+loop 14May86 20Nov87 + +Code (loop + RP lhld M inr 0= ?[ H inx M inr >next jz ]? +Label doloop RP lhld 4 D lxi D dad + M IP' mov H inx M IP mov Next +end-code restrict + +Code (+loop + RP lhld D pop + M A mov E add A M mov H inx + M A mov D adc A M mov + rar D xra doloop jp Next +end-code restrict + + +\ *** Block No. 34 Hexblock 22 +\ loop indices 06May86 20Nov87 + +Code I ( -- n ) + RP lhld +Label >I M E mov H inx M D mov D push + H inx M E mov H inx M D mov H pop D dad + hpush jmp +end-code + +Code J ( -- n ) + RP lhld 6 D lxi D dad >I jmp end-code + + + + + +\ *** Block No. 35 Hexblock 23 +\ interpretive conditionals UH 25Jan88 + +| Create: remove>> r> rp! ; +| : >>r ( addr len -- addr ) r> over rp@ under swap - dup rp! + swap >r remove>> >r swap >r dup >r swap cmove r> ; + +| Variable saved-dp 0 saved-dp ! + +| Variable level 0 level ! + +| : +level ( -- ) level @ IF 1 level +! exit THEN state @ ?exit + 1 level ! here saved-dp ! ] ; + +| : -level ( -- ) state @ 0= Abort" unstructured" + level @ 0=exit -1 level +! level @ ?exit compile unnest + [compile] [ saved-dp @ here over dp ! over - >>r >r ; +\ *** Block No. 36 Hexblock 24 +\ resolve loops and branches UH 25Jan88 + +: >mark ( -- addr ) here 0 , ; + +: +>mark ( acf -- addr ) +level , >mark ; + +: >resolve ( addr -- ) here over - swap ! -level ; + +: mark 1 ; immediate +: THEN abs 1 ?pairs >resolve ; immediate +: ELSE 1 ?pairs ['] branch +>mark swap + >resolve -1 ; immediate +: BEGIN mark + -2 2swap ; immediate + +| : (reptil resolve REPEAT ; + +: REPEAT 2 ?pairs compile branch (reptil ; immediate +: UNTIL 2 ?pairs compile ?branch (reptil ; immediate + +\ *** Block No. 39 Hexblock 27 +\ Loops UH 25Jan88 + +: DO ['] (do +>mark 3 ; immediate +: ?DO ['] (?do +>mark 3 ; immediate +: LOOP 3 ?pairs compile (loop compile endloop >resolve ; + immediate +: +LOOP 3 ?pairs compile (+loop compile endloop >resolve ; + immediate + +Code LEAVE + RP lhld 4 D lxi D dad M E mov H inx M D mov + H inx RP shld xchg H dcx M D mov H dcx M E mov + D dad H IP mvx Next end-code restrict + +\\ Returnstack: calladr | index limit | adr of DO +: LEAVE endloop r> 2- dup @ + >r ; restrict +\ *** Block No. 40 Hexblock 28 +\ um* 16May86 +Label (um* 0 H lxi ( 0=Teil-Produkt ) + 4 C mvi ( Schleifen-Zaehler ) + [[ H dad ( Schiebe HL 24 bits nach links ) + ral cs ?[ D dad 0 aci ]? + H dad ral cs ?[ D dad 0 aci ]? + C dcr 0= ?] ret + +Code um* ( u1 u2 -- ud ) + D pop H pop B push H B mov L A mov (um* call + H push A H mov B A mov H B mov (um* call + D pop D C mov B dad 0 aci L D mov H L mov + A H mov B pop dpush jmp end-code + + + +\ *** Block No. 41 Hexblock 29 +\ m* * 2* 2/ 16May86 + +: m* ( n1 n2 -- d ) dup 0< dup >r IF negate THEN + swap dup 0< IF negate r> not >r THEN + um* r> IF dnegate THEN ; + +: * ( n1 n2 - prod ) um* drop ; + +Code 2* ( n -- 2*n ) H pop H dad hpush jmp end-code + +Code 2/ ( n -- n/2 ) + H pop H A mov rlc rrc rar A H mov + L A mov rar A L mov hpush jmp end-code +\\ +: 2* ( n -- 2*n ) 2 * ; +: 2/ ( n -- n/2 ) 2 / ; +\ *** Block No. 42 Hexblock 2A +\ um/mod 14May86 +Label usl0 + A E mov H A mov C sub A H mov E A mov B sbb + cs ?[ H A mov C add A H mov E A mov D dcr rz +Label usla + H dad ral usl0 jnc + A E mov H A mov C sub A H mov E A mov B sbb + ]? L inr D dcr usla jnz ret +Label usbad -1 H lxi B pop H push hpush jmp +Code um/mod ( d1 n1 -- rem quot ) + IP H mvx B pop D pop xthl xchg + L A mov C sub H A mov B sbb usbad jnc + H A mov L H mov D L mov 8 D mvi D push + usla call D pop H push E L mov usla call + A D mov H E mov B pop C H mov B pop + D push hpush jmp end-code +\ *** Block No. 43 Hexblock 2B +\ m/mod 16May86 + +: m/mod ( d n -- mod quot) + dup >r abs over 0< IF under + swap THEN + um/mod r@ 0< IF negate over IF swap r@ + swap 1- + THEN THEN rdrop ; + + + + + + + + + + +\ *** Block No. 44 Hexblock 2C +\ /mod / mod */mod */ u/mod ud/mod 16May86 + +: /mod ( n1 n2 -- rem quot ) >r extend r> m/mod ; + +: / ( n1 n2 -- quot ) /mod nip ; + +: mod ( n1 n2 -- rem ) /mod drop ; + +: */mod ( n1 n2 n3 -- rem quot ) >r m* r> m/mod ; + +: */ ( n1 n2 n3 -- quot ) */mod nip ; + +: u/mod ( u1 u2 -- urem uquot ) 0 swap um/mod ; + +: ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r + um/mod r> ; +\ *** Block No. 45 Hexblock 2D +\ cmove cmove> 16May86 18Nov87 + +Code cmove ( from to count -- ) IP H mvx IPsave shld + B pop D pop H pop + Label (cmove + [[ B A mov C ora 0= not ?[[ + M A mov H INX D stax D inx B dcx + ]]? IPsave lhld H IP mvx Next end-code + +Code cmove> ( from to count -- ) IP H mvx IPsave shld + B pop D pop H pop + Label (cmove> + B dad H dcx xchg B dad H dcx xchg + [[ B A mov C ora 0= not ?[[ + M A mov H dcx D stax D dcx B dcx + ]]? IPsave lhld H IP mvx Next end-code +\ *** Block No. 46 Hexblock 2E +\ move place count 17Oct86 18Nov87 + +Code move ( from to quan -- ) + IP H mvx Ipsave shld B pop D pop H pop + Label domove (u< call (cmove jnc (cmove> jmp end-code + +| Code (place ( addr len to -- len to ) IP H mvx Ipsave shld + D pop B pop H pop + B push D push D inx domove jmp end-code + +: place ( addr len to -- ) (place c! ; + +Code count ( adr -- adr+1 len ) H pop M E mov 0 D mvi + H inx H push D push Next end-code + + +\ *** Block No. 47 Hexblock 2F +\ fill erase 18Nov87 + +Code fill ( addr quan 8b -- ) + IP H mvx IPsave shld D pop B pop H pop + [[ B A mov C ora 0<> ?[[ + E M mov H inx B dcx + ]]? IPsave lhld H IP mvx Next end-code + +: erase ( addr quan --) 0 fill ; + +\\ : fill ( addr quan 8b -- ) + swap ?dup IF >r over c! dup 1+ r> 1- cmove exit THEN 2drop ; +: count ( adr -- adr+1 len ) dup 1+ swap c@ ; +: move ( from to quan -- ) + >r 2dup u< IF r> cmove> exit THEN r> cmove ; +: place ( addr len to --) over >r rot over 1+ r> move c! ; +\ *** Block No. 48 Hexblock 30 +\ here allot , c, pad compile 11Jun86 18Nov87 + +Code here ( -- addr ) user' dp D lxi + UP lhld D dad fetch jmp end-code + +Code allot ( n -- ) user' dp D lxi + UP lhld D dad +store jmp end-code + +: , ( 16b -- ) here ! 2 allot ; +: c, ( 8b -- ) here c! 1 allot ; + +: pad ( -- addr ) here $42 + ; +: compile r> dup 2+ >r @ , ; restrict + +\ : here ( -- addr ) dp @ ; +\ : allot ( n -- ) dp +! ; +\ *** Block No. 49 Hexblock 31 +\ input strings 11Jun86 + +Variable #tib 0 #tib ! +Variable >tib here >tib ! $50 allot +Variable >in 0 >in ! +Variable blk 0 blk ! +Variable span 0 span ! + +: tib ( -- addr ) >tib @ ; + +: query ( -- ) tib $50 expect span @ #tib ! >in off blk off ; + + + + + +\ *** Block No. 50 Hexblock 32 +\\ scan skip /string 16May86 18Nov87 + +: scan ( addr0 len0 char -- addr1 len1 ) >r + BEGIN dup WHILE over c@ r@ - WHILE 1- swap 1+ swap REPEAT + rdrop ; + +: skip ( addr len del -- addr1 len1 ) >r + BEGIN dup WHILE over c@ r@ = WHILE 1- swap 1+ swap REPEAT + rdrop ; + +: /string ( addr0 len0 +n - addr1 len1 ) + over umin rot over + -rot - ; + + + + +\ *** Block No. 51 Hexblock 33 +\ skip scan 18Nov87 +Label done H push B push IPsave lhld H IP mvx Next +Code skip ( addr len del -- addr1 len1 ) + IP H mvx IPsave shld D pop B pop H pop + [[ B A mov C ora done jz + M A mov E cmp done jnz H inx B dcx ]] end-code + +Code scan ( addr len chr -- addr1 len1 ) + IP H mvx IPsave shld D pop B pop H pop + [[ B A mov C ora done jz + M A mov E cmp done jz H inx B dcx ]] end-code + +Code /string ( addr0 len0 +n - addr1 len1 ) H pop D pop + D push (u< call cs ?[ xchg ]? H pop xthl D dad xthl + L A mov E sub A L mov H A mov D sbb A H mov + Hpush jmp end-code +\ *** Block No. 52 Hexblock 34 +\ capitalize ohne Umlaute !! 16May86UH 25Jan88 +Variable caps 0 caps ! +Label ?capital caps lda A ana rz +Label (capital ( e --> A,E ) E A mov Ascii a cpi rc + Ascii z 1+ cpi rnc Ascii a Ascii A - sui A E mov ret + +Code capital ( char -- char') D pop + (capital call D push Next end-code +Code upper ( addr len -- ) D pop E D mov H pop D inr + [[ D dcr >next jz M E mov (capital call E M mov H inx ]] +end-code + +\\ : capital ( char -- char') + dup Ascii a [ Ascii z 1+ ] Literal uwithin not ?exit + [ Ascii a Ascii A - ] Literal - ; +: upper ( addr len -- ) bounds ?DO I c@ capital I c! LOOP ; +\ *** Block No. 53 Hexblock 35 +\ (word 16May86 + +Code (word ( char adr0 len0 -- addr ) + IP H mvx IPsave shld B pop B dcx D pop + >in lhld D dad xchg xthl xchg H push >in lhld + C A mov L sub A L mov B A mov H sbb A H mov + cs ?[ B inx C A mov >in sta B A mov >in 1+ sta + D pop H pop D push + ][ H inx H B mvx H pop + [[ B A mov C ora 0<> + ?[[ M A mov E cmp 0= ?[[ H inx B dcx ]]? ]? + H push + [[ B A mov C ora 0<> + ?[[ M A mov E cmp 0<> ?[[ H inx B dcx ]]? ]? + xchg H pop xthl + E A mov L sub A L mov D A mov H sbb A H mov +\ *** Block No. 54 Hexblock 36 +\ (word Part2 16May86 + + B A mov C ora 0<> ?[ H inx ]? >in shld ]? + H pop E A mov L sub A C mov D A mov H sbb A B mov + H push user' dp D lxi UP lhld D dad + M A mov H inx M H mov A L mov D pop H push + C M mov H inx + [[ B A mov C ora 0<> + ?[[ D ldax A M mov H inx D inx B dcx ]]? bl M mvi + IPsave lhld H IP mvx Next end-code +\\ +: (word ( char adr0 len0 -- addr ) + rot >r over swap >in @ /string + r@ skip over swap r> scan >r rot over swap - r> 0<> - + >in ! over - here dup >r place bl r@ count + c! r> ; + +\ *** Block No. 55 Hexblock 37 +\ source word parse name 20Oct86UH 25Jan88 + +Variable loadfile + +: source ( -- addr len ) blk @ ?dup + IF loadfile @ (block b/blk exit THEN tib #tib @ ; + +: word ( char -- addr ) source (word ; + +: parse ( char -- addr len ) + >r source >in @ /string over swap r> scan >r + over - dup r> 0<> - >in +! ; + +: name ( -- addr ) bl word dup count upper exit ; + + +\ *** Block No. 56 Hexblock 38 +\ state Ascii ," "lit (" " 18Nov87 + +Variable state 0 state ! + +: Ascii ( char -- n ) + bl word 1+ c@ state @ IF [compile] Literal THEN ; immediate + +Code "lit RP lhld M E mov H inx M D mov H dcx + D push D ldax D inx E add A M mov H inx + D A mov 0 aci A M mov Next end-code + +: ," Ascii " parse here over 1+ allot place ; +: (" "lit ; restrict +: " compile (" ," align ; immediate restrict + +\ : "lit r> r> under count + even >r >r ; restrict +\ *** Block No. 57 Hexblock 39 +\ ." ( .( \ \\ hex decimal 07Oct87 + +: (." "lit count type ; restrict +: ." compile (." ," align ; immediate restrict + +: ( ascii ) parse 2drop ; immediate +: .( ascii ) parse type ; immediate + +: \ >in @ negate c/l mod >in +! ; immediate +: \\ b/blk >in ! ; immediate +: \needs name find nip 0=exit [compile] \ ; + +: hex $10 base ! ; +: decimal $0A base ! ; + + +\ *** Block No. 58 Hexblock 3A +\ number conversion: digit? 16May86 18Nov87 + +Code digit? ( char -- n true : false ) + user' base D lxi UP lhld D dad + D pop E A mov Ascii 0 sui no jc + $0A cpi cs not ?[ Ascii A Ascii 0 - cpi no jc + Ascii A Ascii 9 - 1- sui ]? + M cmp no jnc + 0 H mvi A L mov H push yes jmp end-code + +\\ +: digit? ( char -- digit true/ false ) dup Ascii 9 > + IF [ Ascii A Ascii 9 - 1- ] Literal - dup Ascii 9 > and THEN + Ascii 0 - dup base @ u< dup ?exit nip ; + + +\ *** Block No. 59 Hexblock 3B +\ number conversion: accumulate convert 11Jun86 + +| : end? ( -- flag ) >in @ 0= ; +| : char ( addr0 -- addr1 char ) count -1 >in +! ; +| : previous ( addr0 -- addr0 char ) 1- count ; + +: accumulate ( +d0 adr digit - +d1 adr ) + swap >r swap base @ um* drop rot base @ um* d+ r> ; + +: convert ( +d1 addr0 -- +d2 addr2 ) + 1+ BEGIN count digit? WHILE accumulate REPEAT 1- ; + + + + + +\ *** Block No. 60 Hexblock 3C +\ number conversion: ?nonum punctuation? 07Oct87 + +| : ?nonum ( flag -- exit if true ) 0=exit + rdrop 2drop drop rdrop false ; + +| : punctuation? ( char -- flag ) + Ascii , over = swap Ascii . = or ; + + + + + + + + + +\ *** Block No. 61 Hexblock 3D +\ number conversion: fixbase? 07Oct87 + +| : fixbase? ( char - char false / newbase true ) capital + Ascii & case? IF $0A true exit THEN + Ascii $ case? IF $10 true exit THEN + Ascii H case? IF $10 true exit THEN + Ascii % case? IF 2 true exit THEN false ; + + + + + + + + + +\ *** Block No. 62 Hexblock 3E +\ number conversion: ?num ?dpl 07Oct87 + +Variable dpl -1 dpl ! + +| : ?num ( flag -- exit if true ) 0=exit + rdrop drop r> IF dnegate THEN + rot drop dpl @ 1+ ?dup ?exit drop true ; + +| : ?dpl dpl @ -1 = ?exit 1 dpl +! ; + + + + + + + +\ *** Block No. 63 Hexblock 3F +\ number conversion: number? number 11Jun86 + +: number? ( string - string false / n 0< / d 0> ) + base push >in push dup count >in ! dpl on + 0 >r ( +sign) 0.0 rot end? ?nonum char + Ascii - case? IF rdrop true >r end? ?nonum char THEN + fixbase? IF base ! end? ?nonum char THEN + BEGIN digit? 0= ?nonum + BEGIN accumulate ?dpl end? ?num char digit? 0= UNTIL + previous punctuation? 0= ?nonum dpl off end? ?num char + REPEAT ; + +: number ( string -- d ) + number? ?dup 0= Abort" ?" 0< IF extend THEN ; + + +\ *** Block No. 64 Hexblock 40 +\ hide reveal immediate restrict 11Jun86 + +Variable last 0 last ! +| : last? ( -- false / acf true) last @ ?dup ; +: hide last? IF 2- @ current @ ! THEN ; +: reveal last? IF 2- current @ ! THEN ; +: Recursive reveal ; immediate restrict + +| : flag! ( 8b --) + last? IF under c@ or over c! THEN drop ; + +: immediate $40 flag! ; +: restrict $80 flag! ; + + + +\ *** Block No. 65 Hexblock 41 +\ clearstack hallot heap heap? 04Sep86 + +Code clearstack + user' s0 D lxi UP lhld D dad M E mov H inx M D mov + xchg sphl Next end-code + +: hallot ( quan -- ) + s0 @ over - swap sp@ 2+ dup rot - dup s0 ! + 2 pick over - di move clearstack ei s0 ! ; + +: heap ( -- addr ) s0 @ 6 + ; +: heap? ( addr -- flag ) heap up@ uwithin ; + +| : heapmove ( from -- from ) + dup here over - dup hallot + heap swap cmove heap over - last +! reveal ; +\ *** Block No. 66 Hexblock 42 +\ Does> ; 11Jun86 20Nov87 + +Label (dodoes> + IP rpush IP pop W inx W push Next end-code + +: (;code r> last @ name> ! ; + +: Does> + compile (;code $CD ( 8080-Call ) c, + compile (dodoes> ; immediate restrict + + + + + + +\ *** Block No. 67 Hexblock 43 +\ ?head | alignments 20Oct86 18Nov87 + +Variable ?head 0 ?head ! + +: | ?head @ ?exit -1 ?head ! ; + +\ machen nichts beim 8080: +: even ( addr -- addr1 ) ; immediate +: align ( -- ) ; immediate +: halign ( -- ) ; immediate + +Variable warning 0 warning ! + +| : exists? warning @ ?exit last @ current @ + (find nip 0=exit space last @ .name ." exists " ?cr ; + +\ *** Block No. 68 Hexblock 44 +\ warning Create 20Oct86 18Nov87 + +Defer makeview ' 0 Is makeview + +: (create ( string -- ) align here + swap count $1F and here 4+ place makeview , current @ @ , + here last ! here c@ 1+ allot align exists? + ?head @ IF 1 ?head +! dup , \ Pointer to Code + halign heapmove $20 flag! dup dp ! + THEN drop reveal 0 , + ;Code W inx W push Next end-code + +: Create name count 1 $20 uwithin not + Abort" invalid name" 1- (create ; + + +\ *** Block No. 69 Hexblock 45 +\ nfa? 30Jun86 + +Code nfa? ( thread cfa -- nfa / false ) + D pop H pop + [[ M A mov H inx M H mov A L mov + H ora Hpush jz H push H inx H inx H push D push + M A mov H inx $1F ani A E mov 0 D mvi D dad + D pop xthl M A mov H pop $20 ani + 0<> ?[ M A mov H inx M H mov A L mov ]? + H A mov D cmp 0= ?[ L A mov E cmp ]? + H pop 0= ?] H inx H inx Hpush jmp +end-code +\\ +: nfa? ( thread cfa -- nfa / false) + >r BEGIN @ dup 0= IF rdrop exit THEN dup 2+ name> r@ = + UNTIL 2+ rdrop ; +\ *** Block No. 70 Hexblock 46 +\ >name name> >body .name 30Jun86 07Oct87 + +: >name ( cfa -- nfa / false ) voc-link + BEGIN @ dup WHILE 2dup 4 - swap nfa? + ?dup IF -rot 2drop exit THEN REPEAT nip ; + +Code (name> ( nfa -- cfa ) H pop M A mov H inx $1F ani + A E mov 0 D mvi D dad hpush jmp end-code +\ : (name> ( nfa -- cfa ) count $1F and + ; + +: name> ( nfa -- cfa ) dup (name> swap c@ $20 and IF @ THEN ; + +: >body ( cfa -- pfa ) 2+ ; : body> ( pfa -- cfa ) 2- ; + +: .name ( nfa -- ) ?dup IF dup heap? IF ." |" THEN + count $1F and type ELSE ." ???" THEN space ; +\ *** Block No. 71 Hexblock 47 +\ : ; Constant Variable 07Nov87 + +: Create: Create hide current @ context ! 0 ] ; + +: : Create: ;Code IP rpush W inx W IP mvx Next end-code + +: ; 0 ?pairs compile unnest [compile] [ reveal ; + immediate restrict + +: Constant ( n -- ) Create , ;Code + W inx xchg M E mov H inx M D mov D push Next + end-code + +: Variable Create 0 , ; + + +\ *** Block No. 72 Hexblock 48 +\ uallot User Alias Defer 11Jun86 18Nov87 +: uallot ( quan -- offset ) even dup udp @ + + $FF u> Abort" Userarea full" udp @ swap udp +! ; + +: User Create 2 uallot c, + ;Code W inx W ldax A E mov 0 D mvi + UP lhld D dad hpush jmp end-code + +: Alias ( cfa -- ) Create last @ dup c@ $20 and + IF -2 allot ELSE $20 flag! THEN (name> ! ; + +| : crash true Abort" crash" ; + +: Defer Create ['] crash , + ;Code W inx xchg M E mov H inx M D mov + xchg >next1 jmp end-code +\ *** Block No. 73 Hexblock 49 +\ vp current context also toss 11Jun86 + +Create vp $10 allot Variable current + +: context ( -- adr ) vp dup @ + 2+ ; + +| : thru.vocstack ( -- from to ) vp 2+ context ; +\ "Only Forth also Assembler" gives +\ vp: countword = 6 | Only | Forth | Assembler | + +: also vp @ $0A > Error" Vocabulary stack full" + context @ 2 vp +! context ! ; +: toss vp @ IF -2 vp +! THEN ; + + + +\ *** Block No. 74 Hexblock 4A +\ Vocabulary Forth Only Onlyforth 24Nov85 18Nov87 + +: Vocabulary +Create 0 , 0 , here voc-link @ , voc-link ! + Does> context ! ; +\ | Name | Code | Thread | Coldthread | Voc-link | + +Vocabulary Forth +Vocabulary Root + +: Only vp off Root also ; + +: Onlyforth Only Forth also definitions ; + + + +\ *** Block No. 75 Hexblock 4B +\ definitions order words 10Oct87 20Nov87 + +| : init-vocabularys voc-link @ + BEGIN dup 2- @ over 4- ! @ ?dup 0= UNTIL ; + +: definitions context @ current ! ; + +| : .voc ( adr -- ) @ 2- >name .name ; + +: order vp 4+ context DO I .voc -2 +LOOP + 2 spaces current .voc ; + +: words context @ + BEGIN @ dup stop? 0= and + WHILE ?cr dup 2+ .name space + REPEAT drop ; +\ *** Block No. 76 Hexblock 4C +\ found -text 11Jun86 +| : found ( nfa -- cfa n ) + dup c@ >r (name> r@ $20 and IF @ THEN + -1 r@ $80 and IF 1- THEN + r> $40 and IF negate THEN ; + +\\ +: -text ( adr1 u adr2 -- false:gleich/+1:str1>str2/-1:str1r count $1F and strlen ! string ! + BEGIN r> ?dup WHILE dup @ >r 2+ dup c@ $1F and strlen @ = + IF dup 1+ strlen @ string @ -text 0= ?dup IF rdrop exit THEN + THEN drop REPEAT string @ 1- false ; +\ *** Block No. 77 Hexblock 4D +\ (find 11Jun86 + +Code (find ( str thr - str false/ NFA true ) + H pop D pop IP push D ldax $1F ani A C mov D inx +Label findloop + M A mov H inx M H mov A L mov + H A mov L ora 0= ?[ IP pop D dcx D push no jmp ]? + H push H inx H inx M A mov $1F ani C cmp + 0<> ?[ H pop findloop jmp ]? + D push H inx C B mov B inr + [[ B dcr 0<> ?[[ + D ldax M cmp 0<> ?[ D pop H pop findloop jmp ]? + H inx D inx ]]? + D pop H pop H inx H inx IP pop H push yes jmp +end-code +\\ HL: thread, nfa DE: string C: strlen B: counter +\ *** Block No. 78 Hexblock 4E +\ find ' [compile] ['] nullstring? 18Nov87 + +: find ( string -- cfa n / string false ) + context dup @ over 2- @ = IF 2- THEN + BEGIN under @ (find IF nip found exit THEN + over vp 2+ u> WHILE swap 2- REPEAT nip false ; + +: ' ( -- cfa ) name find ?exit Error" ?" ; + +: [compile] ' , ; immediate restrict + +: ['] ' [compile] Literal ; immediate restrict + +: nullstring? ( string -- string false / true ) + dup c@ 0= dup 0=exit nip ; + +\ *** Block No. 79 Hexblock 4F +\ notfound 17Oct86UH 25Jan88 + +: no.extensions ( string -- ) + state @ IF Abort" ?" THEN Error" ?" ; + +Defer notfound ' no.extensions Is notfound + + + + + + + + + + +\ *** Block No. 80 Hexblock 50 +\ interpret interpreter compiler parser UH 25Jan88 +Defer parser + +: interpret ( -- ) + BEGIN ?stack name nullstring? ?exit parser REPEAT ; + +| : interpreter ( str -- ) find ?dup + IF 1 and IF execute exit THEN Error" compile only" THEN + number? ?exit notfound ; + +' interpreter Is parser + +| : compiler ( str -- ) find ?dup + IF 0> IF execute exit THEN , exit THEN + number? ?dup IF 0> IF swap [compile] Literal THEN + [compile] Literal exit THEN notfound ; +\ *** Block No. 81 Hexblock 51 +\ [ ] UH 25Jan88 + +: [ ['] interpreter Is Parser state off ; immediate + +: ] ['] compiler Is Parser state on ; + + + + + + + + + + + +\ *** Block No. 82 Hexblock 52 +\ Is 09May86UH 25Jan88 + +: (is r> dup 2+ >r @ ! ; + +| : def? ( cfa -- ) + @ [ ' notfound @ ] Literal - Abort" not deferred" ; + +: Is ( adr -- ) ' dup def? >body + state @ IF compile (is , exit THEN ! ; immediate + + + + + + + +\ *** Block No. 83 Hexblock 53 +\ ?stack 30Jun86 +| : stackfull ( -- ) depth $20 > Abort" tight stack" + reveal last? IF dup heap? IF name> ELSE 4- THEN (forget THEN + true Abort" Dictionary full" ; + +Code ?stack + UP lhld user' dp D lxi D dad M E mov H inx M D mov + 0 H lxi SP dad L A mov E sub H A mov D sbb + 0= ?[ ;c: stackfull ; Assembler ]? H push + UP lhld user' s0 D lxi D dad M E mov H inx M D mov + H pop D A mov H cmp c0= ?[ 0= ?[ E A mov L cmp ]? ]? + >next jnc ;c: true abort" Stack empty" ; +\\ +: ?stack sp@ here - 100 u< IF stackfull THEN + sp@ s0 @ u> Abort" Stack empty" ; + +\ *** Block No. 84 Hexblock 54 +\ .status push load 20Oct86 + +Defer .status ' noop Is .status + +| Create: pull r> r> ! ; + +: push ( addr -- ) r> swap dup >r @ >r pull >r >r ; + restrict + +: (load ( blk offset -- ) + isfile push loadfile push fromfile push blk push >in push + >in ! blk ! isfile@ loadfile ! .status interpret ; + +: load ( blk --) ?dup 0=exit 0 (load ; + + +\ *** Block No. 85 Hexblock 55 +\ +load thru +thru --> rdepth depth 20Oct86 + +: +load ( offset --) blk @ + load ; + +: thru ( from to --) 1+ swap DO I load LOOP ; +: +thru ( off0 off1 --) 1+ swap DO I +load LOOP ; + +: --> 1 blk +! >in off .status ; immediate + +: rdepth ( -- +n) r0 @ rp@ 2+ - 2/ ; +: depth ( -- +n) sp@ s0 @ swap - 2/ ; + + + + + +\ *** Block No. 86 Hexblock 56 +\ quit (quit abort UH 25Jan88 + +: (prompt ( -- ) + state @ IF cr ." ] " ELSE ." ok" cr THEN .status ; + +Defer prompt ' (prompt Is prompt + +: (quit BEGIN prompt query interpret REPEAT ; + +Defer 'quit ' (quit Is 'quit +: quit r0 @ rp! level off [compile] [ 'quit ; + +: standardi/o [ output ] Literal output 4 cmove ; + +Defer 'abort ' noop Is 'abort +: abort end-trace clearstack 'abort standardi/o quit ; +\ *** Block No. 87 Hexblock 57 +\ (error Abort" Error" 20Oct86 18Nov87 + +Variable scr 1 scr ! Variable r# 0 r# ! + +: (error ( string -- ) standardi/o space here .name + count type space ?cr + blk @ ?dup IF scr ! >in @ r# ! THEN quit ; +' (error errorhandler ! + +: (abort" "lit swap IF >r clearstack r> + errorhandler perform exit THEN drop ; restrict + +| : (err" "lit swap IF errorhandler perform exit THEN + drop ; restrict +: Abort" compile (abort" ," align ; immediate restrict +: Error" compile (err" ," align ; immediate restrict +\ *** Block No. 88 Hexblock 58 +\ -trailing 30Jun86 18Nov87 + +Code -trailing ( addr n1 -- addr n2 ) + D pop H pop H push + D dad xchg D dcx +Label -trail H A mov L ora hpush jz + D ldax BL cpi hpush jnz + H dcx D dcx -trail jmp end-code + +\\ +: -trailing ( addr n1 -- addr n2) + 2dup bounds ?DO 2dup + 1- c@ bl - IF LEAVE THEN 1- LOOP ; + + + + +\ *** Block No. 89 Hexblock 59 +\ space spaces 30Jun86 + +$20 Constant bl + +: space bl emit ; +: spaces ( u --) 0 ?DO space LOOP ; + + + + + + + + + + +\ *** Block No. 90 Hexblock 5A +\ hold <# #> sign # #s 17Oct86 + +| : hld ( -- addr) pad 2- ; + +: hold ( char -- ) -1 hld +! hld @ c! ; + +: <# hld hld ! ; + +: #> ( 32b -- addr +n ) 2drop hld @ hld over - ; + +: sign ( n -- ) 0< IF Ascii - hold THEN ; + +: # ( +d1 -- +d2) base @ ud/mod rot 9 over < + IF [ Ascii A Ascii 9 - 1- ] Literal + THEN Ascii 0 + hold ; + +: #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; +\ *** Block No. 91 Hexblock 5B +\ print numbers 24Dec83 + +: d.r -rot under dabs <# #s rot sign #> + rot over max over - spaces type ; + +: .r swap extend rot d.r ; + +: u.r 0 swap d.r ; + +: d. 0 d.r space ; + +: . extend d. ; + +: u. 0 d. ; + + +\ *** Block No. 92 Hexblock 5C +\ .s list c/l l/s 05Oct87 + +: .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; + +$40 Constant c/l \ Screen line length +$10 Constant l/s \ lines per screen + +: list ( blk -- ) + scr ! ." Scr " scr @ u. + l/s 0 DO + cr I 2 .r space scr @ block I c/l * + c/l -trailing type + LOOP cr ; + + + + +\ *** Block No. 93 Hexblock 5D +\ multitasker primitives 20Nov87 + +Code end-trace \ patch Next to its original state + $0A A mvi ( IP ldax ) >next sta + $6F03 H lxi ( IP inx A L mov ) >next 1+ shld Next end-code + +Code pause >next here 2- ! end-code + +: lock ( addr -- ) dup @ up@ = IF drop exit THEN + BEGIN dup @ WHILE pause REPEAT up@ swap ! ; + +: unlock ( addr -- ) dup lock off ; + +Label wake H pop H dcx UP shld + 6 D lxi D dad M A mov H inx M H mov A L mov sphl + H pop RP shld IP pop Next end-code +\ *** Block No. 94 Hexblock 5E +\ buffer mechanism 20Oct86 07Oct87 + +User isfile 0 isfile ! \ addr of file control block +Variable fromfile 0 fromfile ! +Variable prev 0 prev ! \ Listhead +| Variable buffers 0 buffers ! \ Semaphor +$408 Constant b/buf \ physikalische Groesse +$400 Constant b/blk +\\ Struktur eines Buffers: 0 : link + 2 : file + 4 : blocknummer + 6 : statusflags + 8 : Data ... 1 Kb ... +Statusflag bits : 15 1 -> updated +file : -1 -> empty buffer, 0 -> no fcb, direct access + else addr of fcb ( system dependent ) +\ *** Block No. 95 Hexblock 5F +\ search for blocks in memory 30Jun86 +| Variable pred +\ DE:blk BC:file HL:bufadr + +Label thisbuffer? ( Zero = this buffer ) + H push H inx H inx M A mov C cmp 0= + ?[ H inx M A mov B cmp 0= ?[ H inx M A mov E cmp + 0= ?[ H inx M A mov D cmp ]? ]? ]? H pop ret + +Code (core? ( blk file -- adr\blk file ) + IP H mvx Ipsave shld + user' offset D lxi UP lhld D dad + M E mov H inx M D mov + B pop H pop H push B push D dad xchg + prev lhld + thisbuffer? call 0= ?[ +\ *** Block No. 96 Hexblock 60 +\ search for blocks in memory 30Jun86 + +Label blockfound + D pop D pop 8 D lxi D dad H push ' exit @ jmp ]? + [[ pred shld + M A mov H inx M H mov A L mov + H ora 0= ?[ IPsave lhld H IP mvx Next ]? + thisbuffer? call 0= ?] + xchg pred lhld D ldax A M mov + H inx D inx D ldax A M mov D dcx + prev lhld xchg E M mov H inx D M mov + H dcx prev shld + blockfound jmp end-code + + + +\ *** Block No. 97 Hexblock 61 +\ (core? 29Jun86 +\\ + +| : this? ( blk file bufadr -- flag ) + dup 4+ @ swap 2+ @ d= ; + +| : (core? ( blk file -- dataaddr / blk file ) + BEGIN over offset @ + over prev @ this? + IF rdrop 2drop prev @ 8 + exit THEN + 2dup >r offset @ + >r prev @ + BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN + dup r> r> 2dup >r >r rot this? 0= + WHILE nip REPEAT + dup @ rot ! prev @ over ! prev ! rdrop rdrop + REPEAT ; + +\ *** Block No. 98 Hexblock 62 +\ (diskerr 29Jul86 07Oct87 + +: (diskerr + ." error! r to retry " key $FF and + capital Ascii R = not Abort" aborted" ; + +Defer diskerr +' (diskerr Is diskerr + +Defer r/w + + + + + + +\ *** Block No. 99 Hexblock 63 +\ backup emptybuf readblk 20Oct86 + +| : backup ( bufaddr -- ) dup 6+ @ 0< + IF 2+ dup @ 1+ \ buffer empty if file = -1 + IF input push output push standardi/o + BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w + WHILE ." write " diskerr + REPEAT THEN 4+ dup @ $7FFF and over ! THEN drop ; + +: emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; + +| : readblk ( blk file addr -- blk file addr ) + dup emptybuf + input push output push standardi/o >r + BEGIN over offset @ + over r@ 8 + -rot 1 r/w + WHILE ." read " diskerr REPEAT r> ; +\ *** Block No. 100 Hexblock 64 +\ take mark updates? core? 10Mar86 19Nov87 + +| : take ( -- bufaddr) prev + BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL + buffers lock dup backup ; + +| : mark ( blk file bufaddr -- blk file ) + 2+ >r 2dup r@ ! offset @ + r@ 2+ ! r> 4+ off + buffers unlock ; + +| : updates? ( -- bufaddr / flag) + prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; + +: core? ( blk file -- addr /false ) (core? 2drop false ; + + +\ *** Block No. 101 Hexblock 65 +\ block & buffer manipulation 20Oct86 18Nov87 + +: (buffer ( blk file -- addr ) + BEGIN (core? take mark REPEAT ; + +: (block ( blk file -- addr ) + BEGIN (core? take readblk mark REPEAT ; + +Code isfile@ ( -- addr ) user' isfile D lxi + UP lhld D dad fetch jmp end-code + +: buffer ( blk -- addr ) isfile@ (buffer ; + +: block ( blk -- addr ) isfile@ (block ; + +\ : isfile@ ( -- addr ) isfile @ ; +\ *** Block No. 102 Hexblock 66 +\ block & buffer manipulation 05Oct87 + +: update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; + +Defer save-dos-buffers + +: save-buffers ( -- ) buffers lock + BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers + buffers unlock ; + +: empty-buffers ( -- ) buffers lock prev + BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; + +: flush save-buffers empty-buffers ; + + +\ *** Block No. 103 Hexblock 67 +\ Allocating buffers 10Oct87 +$10000 Constant limit Variable first + +: allotbuffer ( -- ) + first @ r0 @ - b/buf 2+ u< ?exit + b/buf negate first +! first @ dup emptybuf + prev @ over ! prev ! ; + +: freebuffer ( -- ) first @ limit b/buf - u< + IF first @ backup prev + BEGIN dup @ first @ - WHILE @ REPEAT + first @ @ swap ! b/buf first +! THEN ; + +: all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; + +| : init-buffers prev off limit first ! all-buffers ; +\ *** Block No. 104 Hexblock 68 +\ endpoints of forget 01Jul86 + +| : |? ( nfa -- flag ) c@ $20 and ; +| : forget? ( adr nfa -- flag ) \ code in heap or above adr ? + name> under 1+ u< swap heap? or ; + +| : endpoints ( addr -- addr symb ) + heap voc-link @ >r + BEGIN r> @ ?dup \ through all Vocabs + WHILE dup >r 4- >r \ link on returnstack + BEGIN r> @ >r over 1- dup r@ u< \ until link or + swap r@ 2+ name> u< and \ code under adr + WHILE r@ heap? [ 2dup ] UNTIL \ search for name in heap + r@ 2+ |? IF over r@ 2+ forget? + IF r@ 2+ (name> 2+ umax THEN \ then update symb + THEN REPEAT rdrop REPEAT ; +\ *** Block No. 105 Hexblock 69 +\ remove, -words, -tasks 20Oct86 + +: remove ( dic sym thread - dic sym ) + BEGIN dup @ ?dup \ unlink forg. words + WHILE dup heap? + IF 2 pick over u> ELSE 3 pick over 1+ u< THEN + IF @ over ! ( unlink word) ELSE nip THEN REPEAT drop ; + +| : remove-words ( dic sym -- dic sym ) + voc-link BEGIN @ ?dup + WHILE dup >r 4- remove r> REPEAT ; + +| : remove-tasks ( dic -- ) up@ + BEGIN 2+ dup @ up@ - WHILE 2dup @ swap here uwithin + IF dup @ 2+ @ over ! 2- + ELSE @ THEN REPEAT 2drop ; +\ *** Block No. 106 Hexblock 6A +\ remove-vocs trim 20Oct86 07Oct87 + +| : remove-vocs ( dic symb -- dic symb ) + voc-link remove thru.vocstack + DO 2dup I @ -rot uwithin + IF [ ' Forth 2+ ] Literal I ! THEN -2 +LOOP + 2dup current @ -rot uwithin + IF [ ' Forth 2+ ] Literal current ! THEN ; + +Defer custom-remove ' noop Is custom-remove + +| : trim ( dic symb -- ) + over remove-tasks remove-vocs remove-words + custom-remove heap swap - hallot dp ! 0 last ! ; + + +\ *** Block No. 107 Hexblock 6B +\ deleting words from dict. 01Jul86 18Nov87 + +: clear here dup up@ trim dp ! ; + +: (forget ( adr --) dup heap? Abort" is symbol" + endpoints trim ; + +: forget ' dup [ dp ] Literal @ u< Abort" protected" + >name dup heap? + IF name> ELSE 4- THEN (forget ; + +: empty [ dp ] Literal @ up@ trim + [ udp ] Literal @ udp ! ; + + + +\ *** Block No. 108 Hexblock 6C +\ save bye stop? ?cr 18Nov87 + +: save here up@ trim + voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL + up@ origin $100 cmove ; + +: bye flush empty (bye ; + +| : end? key #cr = IF true rdrop THEN ; + +: stop? ( -- flag ) key? IF end? end? THEN false ; + +: ?cr col c/l u> 0=exit cr ; + + + +\ *** Block No. 109 Hexblock 6D +\ in/output structure 07Jun86 + +| : Out: Create dup c, 2+ Does> c@ output @ + perform ; + +: Output: Create: Does> output ! ; +0 Out: emit Out: cr Out: type Out: del + Out: page Out: at Out: at? drop + +: row ( -- row) at? drop ; +: col ( -- col) at? nip ; + +| : In: Create dup c, 2+ Does> c@ input @ + perform ; + +: Input: Create: Does> input ! ; +0 In: key In: key? In: decode In: expect drop + +\ *** Block No. 110 Hexblock 6E +\ Alias only definitionen 18Nov87 + +Root definitions Forth + +: seal [ ' Root >body ] Literal off ; \ "erase" Root Vocab. + +' Only Alias Only +' Forth Alias Forth +' words Alias words +' also Alias also +' definitions Alias definitions + +Host Target + + + +\ *** Block No. 111 Hexblock 6F +\ 'restart 'cold 22Oct86 10Oct87 + +Defer 'restart ' noop Is 'restart + +| : (restart ['] (quit Is 'quit drvinit 'restart + [ errorhandler ] Literal @ errorhandler ! + ['] noop Is 'abort clearstack + standardi/o interpret quit ; + +Defer 'cold ' noop Is 'cold + +| : (cold origin up@ $100 cmove $80 count + $50 umin >r tib r@ move r> #tib ! >in off blk off + init-vocabularys init-buffers flush 'cold + Onlyforth page &24 spaces logo count type cr (restart ; + +\ *** Block No. 112 Hexblock 70 +\ cold bootsystem 20Oct86 + +Code cold here >cold ! + s0 lhld 6 D lxi D dad origin D lxi $3F C mvi + [[ D ldax A M mov H inx D inx C dcr 0= ?] + ' (cold >body IP lxi +Label bootsystem + s0 lhld 6 D lxi D dad UP shld + user' s0 D lxi D dad + M E mov H inx M D mov xchg sphl + user' r0 D lxi UP lhld D dad + M E mov H inx M D mov xchg RP shld + $C3 ( jmp ) A mvi $30 sta wake H lxi $31 shld ( Tasker ) + Next +end-code + +\ *** Block No. 113 Hexblock 71 +\ restart boot 20Oct86 + +Code restart here >restart ! + ' (restart >body IP lxi bootsystem jmp end-code + +Label boot here >boot ! \ find link to Main: + s0 lhld 6 D lxi D dad H B mvx origin D lxi + [[ [[ xchg H inx H inx M E mov H inx M D mov + D A mov B cmp 0= ?] E A mov C cmp 0= ?] H B mvx + 6 lhld 0 L mvi ' limit >body shld + -$1100 D lxi D dad r0 shld \ set initial RP + -$400 D lxi D dad s0 shld \ set initial SP + 6 D lxi D dad xchg B H mvx + D M mov H dcx E M mov \ set link to Maintask + >cold 2- jmp +end-code +\ *** Block No. 114 Hexblock 72 +\ "search 05Mar88 + +Label notfound H pop H pop + IPsave lhld H IP mvx False H lxi hpush jmp + +Code "search ( text tlen buf blen -- addr tf / ff ) + IP H mvx IPsave shld D pop H pop xthl + H A mov L ora notfound jz + E A mov L sub A C mov D A mov H sbb A B mov notfound jc + B inx D pop xthl M A mov xthl H push xchg +Label scanfirst + A E mov ?capital call E D mov + [[ M E mov H inx B A mov C ora notfound jz B dcx + ?capital call E A mov D cmp 0= ?] + B D mvx B pop xchg xthl xchg H push B push D push + +\ *** Block No. 115 Hexblock 73 +\ "search part 2 27Nov87 + +Label match + B dcx B A mov C ora 0<> ?[ + D inx D ldax D push A E mov ?capital call E D mov + M E mov H inx ?capital call E A mov D cmp D pop + match jz H pop B pop D pop + M A mov xthl B push H B mvx xchg scanfirst jmp ]? + D pop D pop H pop D pop H dcx H push + IPsave lhld H IP mvx True H lxi hpush jmp +end-code + + + + + +\ *** Block No. 116 Hexblock 74 +\ Rest of Standard-System 04Oct87 07Oct87 + +2 +load \ Operating System + +Host ' Transient 8 + @ Transient Forth Context @ 6 + ! + +Target Forth also definitions + +Vocabulary Assembler Assembler definitions +Transient Assembler +>Next Constant >Next +hpush Constant hpush +dpush Constant dpush + +Target Forth also definitions +: forth-83 ; \ last word in Dictionary +\ *** Block No. 117 Hexblock 75 +\ System patchup 04Oct87 + +$EF00 r0 ! +$EB00 s0 ! +s0 @ 6 + origin 2+ ! \ link Maintask to itself + +\ s0 und r0 werden beim Booten neu an die Speichergroesse +\ angepasst. Ebenso der Multi-Tasker-Link auf die Maintask + +here dp ! + +Host Tudp @ Target udp ! +Host Tvoc-link @ Target voc-link ! +Host move-threads + + +\ *** Block No. 118 Hexblock 76 +\ System dependent Load-Screen 20Nov87 + +1 +load \ CP/M interface + +2 4 +thru \ Character IO + +5 7 +thru \ Default Disk IO + +8 +load \ Postlude + +\ 9 +load \ Index + + + + + +\ *** Block No. 119 Hexblock 77 +\ CP/M-Interface 05Oct87 +Vocabulary Dos Dos definitions also +Label >bios pchl +Code biosa ( arg fun -- res ) + 1 lhld D pop D dcx D dad D dad D dad + D pop IP push D IP mvx >bios call +Label back + IP pop 0 H mvi A L mov Hpush jmp end-code + +Code bdosa ( arg fun -- res ) + H pop D pop IP push L C mov 5 call back jmp +end-code + +: bios ( arg fun -- ) biosa drop ; +: bdos ( arg fun -- ) bdosa drop ; + +\ *** Block No. 120 Hexblock 78 +\ Character-IO Constants Character input 05Oct87 + +Target Dos also + +$08 Constant #bs $0D Constant #cr +$0A Constant #lf $1B Constant #esc +$09 Constant #tab $7F Constant #del +$07 Constant #bel $0C Constant #ff + +: con! ( c -- ) 4 bios ; +: (key? ( -- ? ) 0 2 biosa 0= not ; +: getkey ( -- c ) 0 3 biosa ; + +: (key ( -- c ) BEGIN pause (key? UNTIL getkey ; + + +\ *** Block No. 121 Hexblock 79 +\ Character output 07Oct87 UH 27Feb88 + +| Code ?ctrl ( c -- c' ) H pop L A mov + $20 cpi cs ?[ $80 ori ]? A L mov Hpush jmp end-code + +: (emit ( c -- ) ?ctrl con! pause ; + +: (cr #cr con! #lf con! ; +: (del #bs con! bl con! #bs con! ; +: (at? ( -- row col ) 0 0 ; + +: tipp ( addr len -- ) 0 ?DO count emit LOOP drop ; + +Output: display [ here output ! ] + (emit (cr tipp (del noop 2drop (at? ; + +\ *** Block No. 122 Hexblock 7A +\ Line input 04Oct87 + +| : backspace ( addr pos1 -- addr pos2 ) dup 0=exit (del 1- ; + +: (decode ( addr pos1 key -- addr pos2 ) + #bs case? IF backspace exit THEN + #del case? IF backspace exit THEN + #cr case? IF dup span ! space exit THEN + dup emit >r 2dup + r> swap c! 1+ ; + +: (expect ( addr len -- ) span ! 0 + BEGIN span @ over u> WHILE key decode REPEAT 2drop ; + +Input: keyboard [ here input ! ] + (key (key? (decode (expect ; + +\ *** Block No. 123 Hexblock 7B +\ Default Disk Interface: Constants and Primitives 18Nov87 + + $80 Constant b/rec b/blk b/rec / Constant rec/blk + +Dos definitions +' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb + +: dos-error? ( n -- f ) $FF = ; + +$5C Constant fcb +: reset ( -- ) 0 &13 bdos ; +: openfile ( fcb -- f ) &15 bdosa dos-error? ; +: closefile ( fcb -- f ) &16 bdosa dos-error? ; +: dma! ( dma -- ) &26 bdos ; +: rec@ ( fcb -- f ) &33 bdosa ; +: rec! ( fcb -- f ) &34 bdosa ; +\ *** Block No. 124 Hexblock 7C +\ Default Disk Interface: open and close 20Nov87 + +Target Dos also Defer drvinit Dos definitions + +| Variable opened +: default ( -- ) opened off + fcb 1+ c@ bl = ?exit $80 count here place #tib off + fcb dup dosfcb> dup isfile ! fromfile ! + openfile Abort" default file not found!" opened on ; +' default Is drvinit + +: close-default ( -- ) opened @ not ?exit + fcb closefile Abort" can't close default-file!" ; +' close-default Is save-dos-buffers + + +\ *** Block No. 125 Hexblock 7D +\ Default Disk Interface: read/write 14Feb88 + +Target Dos also + +| : rec# ( 'dosfcb -- 'rec# ) &33 + ; + +: (r/w ( adr blk file r/wf -- flag ) >r + dup 0= Abort" no Direct Disk IO supported! " >dosfcb + swap rec/blk * over rec# 0 over 2+ c! ! + r> rot b/blk bounds + DO I dma! 2dup IF rec@ drop + ELSE rec! IF 2drop true endloop exit THEN THEN + over rec# 0 over 2+ c! 1 swap +! + b/rec +LOOP 2drop false ; + +' (r/w Is r/w +\ *** Block No. 126 Hexblock 7E +\ Postlude 20Nov87 + +Defer postlude + +| : (bye ( -- ) postlude 0 0 bdos ; + +| : #pages ( -- n ) here $100 - $100 u/mod swap 0=exit 1+ ; + +: .size ( -- ) base push decimal + cr ." Size: &" #pages u. ." Pages" ; + +' .size Is postlude + + + + +\ *** Block No. 127 Hexblock 7F +\ index findex 20Nov87 + +| : range ( from to -- to+1 from ) + 2dup > IF swap THEN 1+ swap ; + +: index ( from to --) + range DO cr I 4 .r I space block c/l type + stop? IF LEAVE THEN LOOP ; + + + + + + + + diff --git a/sources/cpm/startup.fth b/sources/cpm/startup.fth new file mode 100644 index 0000000..35c3db7 --- /dev/null +++ b/sources/cpm/startup.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\\ Startup: Load Standard System UH 11Nov86 + +Dieses File enthaelt Befehle, die aus dem File KERNEL.COM +ein vollstaendiges volksFORTH machen, das mit SAVESYSTEM +als File (z.B. VOLKS4th.COM) auf Disk geschrieben werden kann. + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ System LOAD-Screen fuer CP/M VolksForth UH 27Nov87 +include ass8080.fb +include xinout.fb \ extended I/O +\ include terminal.fb save \ Terminal +include copy.fb cr .( copy and convey loaded) cr +include savesys.fb cr .( Savesystem loaded) cr +include editor.fb cr .( Editor loaded) cr +include tools.fb cr .( Tools loaded) cr +\ include see.fb cr .( Decompiler loaded) cr +\ include tasker.fb cr .( Multitasker loaded) cr +\ include printer.fb cr .( Printer Interface loaded) cr +include relocate.fb cr .( Relocating loaded) cr + +.( May the volksFORTH be with you ...) cr decimal caps on +scr off r# off savesystem volks4th.com + diff --git a/sources/cpm/target.fth b/sources/cpm/target.fth new file mode 100644 index 0000000..b9998b4 --- /dev/null +++ b/sources/cpm/target.fth @@ -0,0 +1,578 @@ +\ *** Block No. 0 Hexblock 0 + \ 05Jul86 + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Target compiler loadscr UH 07Jun86 +\ Idea and first Implementation by ks/bp +\ Implemented on 6502 by ks/bp +\ ultraFORTH83-Version by bp/we +\ Atari 520 ST - Version by we +\ CP/M 2.2 Version by UH + +Onlyforth hex Assembler nonrelocate +Vocabulary Ttools +Vocabulary Defining + 1 10 +thru \ Target compiler +11 13 +thru \ Target Tools +14 16 +thru \ Redefinitions +save 17 20 +thru \ Predefinitions + +Onlyforth +\ *** Block No. 2 Hexblock 2 +\ Target header pointers UH 26Mar88 + +Create lastname $20 allot +Variable tdp : there tdp @ ; +Variable displace +Variable image +Variable ?thead ?thead off +Variable tlast tlast off +Variable glast' glast' off +Variable tdoes> +Variable >in: +Variable tvoc tvoc off +Variable tvoc-link tvoc-link off +0 | Constant +0 | Constant +| : Is> ( cfa -- ) [compile] Does> here 3 - swap >body ! 0 ] ; +\ *** Block No. 3 Hexblock 3 +\ Image and byteorder UH 26Mar88 + +Code c+! ( 8b addr -- ) + H pop D pop E A mov M add A M mov Next end-code + +Code /block ( addr -- +n blk ) + H pop L E mov H A mov 3 ani A D mov + H A mov $FC ani rrc rrc A L mov 0 H mvi dpush jmp +end-code + +: >image ( addr1 - addr2 ) + displace @ ( - /block image @ + block ) + ; + +: >heap ( from quan - ) dup hallot heap swap cmove ; +\\ : c+! ( 8b addr -- ) dup c@ rot + swap c! ; + : /block ( addr -- +n blk ) b/blk /mod ; +\ *** Block No. 4 Hexblock 4 +\ Ghost-creating UH 26Mar88 + +| : (make.ghost ( str -- cfa.ghost ) dp push + count dup 1 $1F uwithin not Abort" invalid Ghostname" + here 2+ place + here state @ \ address of link field + IF context @ ELSE current THEN @ under @ , \ link + 1 here c+! here c@ allot bl c, \ name + here over - swap \ offset to codefield + , 0 , 0 , \ code and parameter field + here over - >heap \ move to heap + heap rot ! \ link + heap + ; \ codefield address + +| : Make.Ghost ( -- cfa.ghost ) name (make.ghost ; + +\ *** Block No. 5 Hexblock 5 +\ ghost words UH 28Apr88 + +: gfind ( string - cfa tf / string ff ) + >r bl r@ count + c! 1 r@ c+! r@ find -1 r> c+! ; + +: (ghost ( string -- cfa ) gfind ?exit (make.ghost ; + +: ghost ( -- cfa ) name (ghost ; + +: gdoes> ( cfa.ghost - cfa.does ) dp push + 4+ dup @ IF @ exit THEN \ defined + here , 0 , 4 >heap \ forward-chain + heap dup rot ! ; \ forward-link + + + +\ *** Block No. 6 Hexblock 6 +\ ghost utilities 2UH 26Mar88 + +: g' ( -- cfa.ghost ) name gfind 0= abort" ?" ; + +| : .ghost-type ( cfa.ghost -- ) @ + case? IF ." forward" exit THEN + - Abort" type unknown" ." resolved " ; + +| : .does-type ( cfa.does -- ) @ + case? IF ." forward-define" exit THEN + - Abort" does-type unknown" ." resolved-define" ; + +: '. ( -- ) g' dup .ghost-type dup 2+ @ 5 u.r + 4+ @ ?dup 0=exit dup .does-type 2+ @ 5 u.r ; + +' ' Alias h' +\ *** Block No. 7 Hexblock 7 +\ .unresolved UH 26Mar88 + +| : forward? ( cfa -- f ) dup @ = swap 2+ @ and ; +| : ghost? ( nfa -- f ) count $1F and + 1- c@ bl = ; + +| : unresolved? ( addr - f ) 2+ + dup ghost? not IF drop false exit THEN + name> dup forward? IF drop true exit THEN + 4+ @ forward? ; + +| : unresolved-words ( thread -- ) BEGIN @ ?dup WHILE + dup unresolved? IF dup 2+ .name ?cr THEN REPEAT ; + +: .unresolved ( -- ) voc-link @ + BEGIN dup 4- unresolved-words @ ?dup 0= UNTIL ; + +\ *** Block No. 8 Hexblock 8 +\ Extending Vocabularys for Target-Compilation 2UH 26Mar88 + +: Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + +Vocabulary Transient tvoc off + +Root definitions + +: T Transient ; immediate +: H Forth ; immediate + +OnlyForth + + + + +\ *** Block No. 9 Hexblock 9 +\ Transient primitives UH 26Mar88 + +Code byte> ( 8bl 8bh -- 16b ) + D pop H pop E H mov hpush jmp end-code +Code >byte ( 16b -- 8bh 8bl ) + H pop H E mov 0 H mvi H D mov dpush jmp end-code + +Transient definitions +: c@ ( addr -- 8b ) H >image c@ ; +: c! ( 8b addr -- ) H >image c! ( update ) ; +: @ ( addr -- n ) dup T c@ H swap 1+ T c@ H byte> ; +: ! ( n addr -- ) >r >byte r@ T c! H r> 1+ T c! H ; +: cmove ( from.mem to.target quan -) + bounds ?DO dup H c@ I T c! H 1+ LOOP drop ; +: on ( addr -- ) true swap T ! H ; +: off ( addr -- ) false swap T ! H ; +\ *** Block No. 10 Hexblock A +\ Transient primitives UH 26Mar88 + +: here ( -- taddr ) there ; +: allot ( n -- ) Tdp +! ; +: c, ( c -- ) T here c! 1 allot H ; +: , ( n -- ) T here ! 2 allot H ; + +: ," ( -- ) Ascii " parse + dup T c, under here swap cmove allot H ; + +: fill ( addr len c -- ) + -rot bounds ?DO dup I T c! H LOOP drop ; + +: erase ( addr len -- ) 0 T fill H ; +: blank ( addr len -- ) bl T fill H ; +: here! ( addr -- ) H tdp ! ; +\ *** Block No. 11 Hexblock B +\ Resolving UH 26Mar88 + +Forth definitions + +: resolve ( cfa.ghost cfa.target -- ) + 2dup swap >body dup @ >r ! over @ = + IF drop >name space .name ." exists" ?cr rdrop exit THEN + r> swap >r rot ! ?dup 0= IF rdrop exit THEN + BEGIN dup T @ H 2dup = abort" resolve loop" + r@ rot T ! H ?dup 0= UNTIL rdrop ; + +: resdoes> ( cfa.ghost cfa.target -- ) + swap gdoes> dup @ = IF 2+ ! exit THEN swap resolve ; + +' Is> ( -- ) dup @ there rot ! T , H ; \ forward link +' Is> ( -- ) @ T , H ; \ compile target.cfa +\ *** Block No. 12 Hexblock C +\ move-threads UH 26Mar88 + +: move-threads Tvoc @ Tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + error" some undef. Target-Vocs left" drop ; + +| : tlatest ( - addr) Current @ 6 + ; + + +: save-target \ filename + $100 dup >image there rot - savefile ; + + + + +\ *** Block No. 13 Hexblock D +\ compiling names into targ. UH 26Mar88 + +| : viewfield ( -- n ) H blk @ $200 + ; \ in File #1 + +: (theader ( -- ) ?thead @ IF 1 ?thead +! exit THEN + >in push + name dup c@ 1 $20 uwithin not abort" invalid Targetname" + viewfield T , + H there tlatest @ T , H tlatest ! \ link + there dup tlast ! + over c@ 1+ dup T allot cmove H ; + +: Theader ( -- ) tlast off + (theader Ghost dup glast' ! there resolve ; + + +\ *** Block No. 14 Hexblock E +\ prebuild defining words bp2UH 26Mar88 + +| : executable? ( adr - adr f ) dup ; +| : tpfa, there , ; + +| : (prebuild ( cfa.adr -- ) >in push Create here 2- ! ; + +: prebuild ( adr 0.from.: - 0 ) 0 ?pairs + executable? dup >r + IF [compile] Literal compile (prebuild ELSE drop THEN + compile Theader Ghost gdoes> , + r> IF compile tpfa, THEN 0 ; immediate restrict + + + + +\ *** Block No. 15 Hexblock F +\ code portion of def.words bp2UH 26Mar88 + +: dummy 0 ; + +: DO> ( - adr.of.jmp.dodoes> 0 ) + [compile] Does> here 3 - compile @ 0 ] ; + + + + + + + + + + +\ *** Block No. 16 Hexblock 10 +\ The Target-Assembler UH 26Mar88 + + +Forth definitions +| Create relocate ] T c, , c@ here allot ! c! H [ + +Transient definitions + +: Assembler H [ Assembler ] relocate >codes ! Assembler ; +: >label ( 16b -) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; +: Label H there T >label Assembler H ; +: Code H Theader there 2+ T , Assembler H ; + + + +\ *** Block No. 17 Hexblock 11 +\ immed. restr. ' \ compile bp2UH 26Mar88 + +: ?pairs ( n1 n2 -- ) H - abort" unstructured" ; +: >mark ( - addr) H there T 0 , H ; +: >resolve ( addr -) H there over - swap T ! H ; +: - cfa) H g' dup @ - abort" ?" 2+ @ ; +: | H ?thead @ ?exit ?thead on ; +: compile H Ghost , ; immediate restrict + + + + +\ *** Block No. 18 Hexblock 12 +\ Target tools UH 26Mar88 +Onlyforth Ttools also definitions + +| : ttype ( adr n -) bounds ?DO I T c@ H dup + bl > IF emit ELSE drop ascii . emit THEN LOOP ; + +: .name ( nfa -) ?dup IF dup 1+ swap T c@ H $1F and ttype + ELSE ." ??? " THEN space ?cr ; + +| : nfa? ( cfa lfa - nfa / cfa ff) + BEGIN dup WHILE 2dup 2+ dup T c@ H $1F and + 1+ = + IF 2+ nip exit THEN T @ H REPEAT ; + +: >name ( cfa - nfa / ff) + Tvoc BEGIN @ dup WHILE under 2- @ nfa? ?dup + IF nip exit THEN swap REPEAT nip ; +\ *** Block No. 19 Hexblock 13 +\ Ttools for decompiling ks29jun85we + +| : ?: dup 4 u.r ." :" ; +| : @? dup T @ H 6 u.r ; +| : c? dup T c@ H 3 .r ; + +: s ( adr - adr+) ?: space c? 3 spaces + dup 1+ over T c@ H ttype dup T c@ H + 1+ ; + +: n ( adr - adr+2) ?: @? 2 spaces + dup T @ H [ Ttools ] >name .name H 2+ ; + +: d ( adr n - adr+n) 2dup swap ?: swap 0 DO c? 1+ LOOP + 2 spaces -rot ttype ; + + +\ *** Block No. 20 Hexblock 14 +\ Tools for decompiling bp204dec85we + +: l ( adr - adr+2) ?: 5 spaces @? 2+ ; + +: c ( adr - adr+1) 1 d ; + +: b ( adr - adr+1) ?: @? dup T @ H over + 5 u.r 2+ ; + +: dump ( adr n -) bounds ?DO cr I 10 d drop stop? + IF LEAVE THEN 10 +LOOP ; + +: view T ' H [ Ttools ] >name ?dup + IF 4 - T @ H list THEN ; + + + +\ *** Block No. 21 Hexblock 15 +\ reinterpretation def.-words UH 26Mar88 + +Onlyforth + +: redefinition ( -- ) tdoes> @ 0=exit + >in push [ ' parser >body ] Literal push + state push context push + >in: @ >in ! name [ ' Transient 2+ ] Literal (find nip ?exit + cr ." Redefinition: " here .name + >in: @ >in ! : Defining interpret tdoes> off ; + + + + + + +\ *** Block No. 22 Hexblock 16 +\ Create..does> structure 27Apr86 + +| : (;tcode Tlast @ dup T c@ + 1+ ! H rdrop ; + +| : changecfa compile lit tdoes> @ , compile (;tcode ; + +Defining definitions + +: ;code 0 ?pairs changecfa reveal rdrop rdrop ; + immediate restrict + +Defining ' ;code Alias does> immediate restrict + +: ; [compile] ; rdrop rdrop ; immediate restrict + + +\ *** Block No. 23 Hexblock 17 +\ redefinition conditionals bp27jun85we + +' DO Alias DO immediate restrict +' ?DO Alias ?DO immediate restrict +' LOOP Alias LOOP immediate restrict +' IF Alias IF immediate restrict +' THEN Alias THEN immediate restrict +' ELSE Alias ELSE immediate restrict +' BEGIN Alias BEGIN immediate restrict +' UNTIL Alias UNTIL immediate restrict +' WHILE Alias WHILE immediate restrict +' REPEAT Alias REPEAT immediate restrict + + + + +\ *** Block No. 24 Hexblock 18 +\ clear Liter. Ascii ['] ." UH 26Mar88 + +Onlyforth Transient definitions + +: clear True abort" There are ghosts" ; +: Literal ( n -) H dup $FF00 and IF T compile lit , H exit THEN + T compile clit c, H ; immediate +: Ascii H bl word 1+ c@ + state @ 0=exit T [compile] Literal H ; immediate +: ['] T ' [compile] Literal H ; immediate restrict +: " T compile (" ," H ; immediate restrict +: ." T compile (." ," H ; immediate restrict + +: even H ; immediate \ machen nichts beim 8080 +: align H ; immediate +: halign H ; immediate +\ *** Block No. 25 Hexblock 19 +\ Target compilation ] [ bp0UH 26Mar88 + +Forth definitions + +: tcompile ( str -- ) count lastname place + lastname find ?dup + IF 0> IF execute exit THEN drop lastname THEN + gfind IF execute exit THEN + number? ?dup + IF 0> IF swap T [compile] Literal THEN + [compile] Literal H exit THEN + (ghost execute ; + +Transient definitions +: ] H State on ['] tcompile is parser ; + +\ *** Block No. 26 Hexblock 1A +\ Target conditionals bp27jun85we + +: IF T compile ?branch >mark H 1 ; immediate restrict +: THEN abs 1 T ?pairs >resolve H ; immediate restrict +: ELSE T 1 ?pairs compile branch >mark swap >resolve + H -1 ; immediate restrict +: BEGIN T mark -2 H 2swap ; + immediate restrict +| : (repeat T 2 ?pairs resolve H REPEAT ; +: UNTIL T compile ?branch (repeat H ; immediate restrict +: REPEAT T compile branch (repeat H ; immediate restrict + + + +\ *** Block No. 27 Hexblock 1B +\ Target conditionals bp27jun85we + +: DO T compile (do >mark H 3 ; immediate restrict +: ?DO T compile (?do >mark H 3 ; immediate restrict +: LOOP T 3 ?pairs compile (loop compile endloop + >resolve H ; immediate restrict +: +LOOP T 3 ?pairs compile (+loop compile endloop + >resolve H ; immediate restrict + + + + + + + + +\ *** Block No. 28 Hexblock 1C +\ predefinitions bp27jun85we + +: abort" T compile (abort" ," H ; immediate +: error" T compile (err" ," H ; immediate + +Forth definitions + +Variable torigin +Variable tudp 0 tudp ! + +: >user T c@ H torigin @ + ; + + + + + +\ *** Block No. 29 Hexblock 1D +\ Datatypes bp2UH 07Nov87 + +Transient definitions +: origin! H torigin ! ; +: user' ( - 8b) T ' 2 + c@ H ; +: uallot ( n -) H tudp @ swap tudp +! ; + + DO> >user ; +: User prebuild User 2 T uallot c, ; + + DO> ; +: Create prebuild (create ; + + DO> T @ H ; +: Constant prebuild Constant T , ; +: Variable Create 2 T allot ; +\ *** Block No. 30 Hexblock 1E +\ Datatypes UH 07Nov87 + +dummy +: Vocabulary + H >in @ Vocabulary >in ! T prebuild Vocabulary 0 , 0 , + here H tvoc-link @ T , H tvoc-link ! ; + + + dummy +: (create prebuild (create ; + + + + + + +\ *** Block No. 31 Hexblock 1F +\ target defining words 27Apr86 + + Do> ; +: Defer prebuild Defer 2 T allot ; +: Is T ' H >body State @ IF T compile (is , H + ELSE T ! H THEN ; immediate +| : dodoes> T compile (;code H Glast' @ + there resdoes> there tdoes> ! ; + +: ;code 0 T ?pairs dodoes> Assembler H [compile] [ + redefinition ; immediate restrict +: does> T dodoes> $CD c, + compile (dodoes> H ; immediate restrict + + + +\ *** Block No. 32 Hexblock 20 +\ : Alias ; bUH 07Jun86 + +dummy +: : H tdoes> off >in @ >in: ! T prebuild : + H current @ context ! T ] H 0 ; + +: Create: Create H current @ context ! T ] H 0 ; + +: Alias ( n -- ) H Tlast off (theader Ghost over resolve + tlast @ T c@ H 20 or tlast @ T c! , H ; + +: ; T 0 ?pairs compile unnest [compile] [ H redefinition ; + immediate restrict + + + +\ *** Block No. 33 Hexblock 21 +\ predefinitions UH 26Mar88 + +: compile T compile compile H ; immediate restrict +: Host H Onlyforth Ttools also ; +: Compiler T Host H Transient also definitions ; +: [compile] H ghost execute ; immediate restrict +\ : Onlypatch H there 3 - 0 tdoes> ! 0 ; + +Onlyforth +: Target Onlyforth Transient also definitions ; + +Transient definitions +Ghost c, drop + + + diff --git a/sources/cpm/tasker.fth b/sources/cpm/tasker.fth new file mode 100644 index 0000000..fe1e4ee --- /dev/null +++ b/sources/cpm/tasker.fth @@ -0,0 +1,119 @@ +\ *** Block No. 0 Hexblock 0 +\\ Multitasker 11Nov86 + +Dieses File enthaelt den Multitasker des volksFORTHs. +Er ist ein Round-Robin-Multitasker, d.h. jede Task behaelt +die Kontrolle ueber den Prozessor solange, bis sie sie +ausdruecklich abgibt. +Hintergrundtasks im volksFORTH koennen durch Semaphore geordnet +auf den Massenspeicher und auf den Drucker zugreifen. + +In Verbindung mit dem Printer-Interface ist es moeglich +Files im Hintergrund auszudrucken. (SPOOL) + + + + + +\ *** Block No. 1 Hexblock 1 +\ Multitasker Loadscreen 27Jun86 20Nov87 + +Onlyforth + +\needs multitask 1 +load + +02 05 +thru \ Tasker + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ stop singletask multitask 28Aug86 20Nov87 + +Code stop UP lhld 0 ( nop ) M mvi +Label taskpause + IP push RP lhld H push UP lhld 6 D lxi D dad xchg + H L mov SP dad xchg E M mov H inx D M mov + UP lhld H inx pchl +end-code + +: singletask [ ' pause @ ] Literal ['] pause ! ; + +: multitask [ taskpause ] Literal ['] pause ! ; + + + + +\ *** Block No. 3 Hexblock 3 +\ pass activate 28Aug86 + +: pass ( n0 ... nr-1 Taddr r -- ) + BEGIN [ rot ( Trick !! ) ] + swap $F7 over c! \ awake Task ( rst 6 ) + r> -rot \ Stack: IP r addr + 8 + >r \ s0 of Task + r@ 2+ @ swap \ Stack: IP r0 r + 2+ 2* \ bytes on Taskstack incl. r0 & IP + r@ @ over - \ new SP + dup r> 2- ! \ into Ssave + swap bounds ?DO I ! 2 +LOOP ; restrict + +: activate ( Taddr -- ) + 0 [ -rot ( Trick !! ) ] REPEAT ; restrict + +\ *** Block No. 4 Hexblock 4 +\ sleep wake taskerror 28Aug86 20Nov87 + +: sleep ( Taddr -- ) $00 ( nop ) swap c! ; +: wake ( Taddr -- ) $F7 ( rst 6 ) swap c! ; + +| : taskerror ( string -- ) + standardi/o singletask ." Task error : " count type + multitask stop ; + + + + + + + + +\ *** Block No. 5 Hexblock 5 +\ Task 20Nov87 + +: Task ( rlen slen -- ) + 0 Constant here 2- >r \ addr of task constant + here -rot \ here for Task dp + even allot even \ allot dictionary area + here r@ ! \ set task constant addr + up@ here $100 cmove \ init user area + here dup $C300 , \ nop-jmp opcode to sleep task + up@ 2+ dup @ , ! \ link task + r> , \ spare used for pointer to header + dup 6 - dup , , \ ssave and s0 + 2dup + , \ here + rlen = r0 + rot , \ dp + under + dp ! 0 , \ allot rstack + ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; +\ *** Block No. 6 Hexblock 6 +\ rendezvous 's tasks 27Jun86 20Nov87 + +: rendezvous ( semaphoraddr -- ) dup unlock pause lock ; + +| : statesmart state @ IF [compile] Literal THEN ; + +: 's ( Taddr -- adr.of.tasks.userarea ) + ' >body c@ + statesmart ; immediate + +: tasks ( -- ) ." Main " cr up@ dup 2+ @ + BEGIN 2dup - WHILE dup 4+ @ body> >name .name + dup c@ 0= ( nop ) IF ." sleeping" THEN cr + 2+ @ REPEAT 2drop ; + + + diff --git a/sources/cpm/terminal.fth b/sources/cpm/terminal.fth new file mode 100644 index 0000000..4593fce --- /dev/null +++ b/sources/cpm/terminal.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\\ Terminal-Anpassung UH 08OCt87 + +In diesem File wird volksFORTH an das benutzte Terminal +angepasst. Ueber folgende Faehigkeiten muss das Terminal +verfuegen, damit alle Moeglichkeiten von volksFORTH ausgenutzt +werden koennen: + +curon, curoff \ Ein- bzw. Ausschalten des Cursors +rvson, rvsoff \ Ein- bzw. Ausschalten der Inversedarstellung +dark \ Loeschen des Bildschirms +locate \ Positionieren des Cursors auf eine + \ bestimmte Position auf dem Bildschirm + +In der Version 3.80a nicht mehr in der Terminal-Anpassung: + +curleft, currite \ Cursor nach links bzw. rechts bewegen +\ *** Block No. 1 Hexblock 1 +\ Anpassung fuer ANSI-Terminal uho 09May2005 +| : ccon!! ( addr len -- ) bounds ?DO I C@ con! LOOP ; +| : con!! ( addr -- ) count ccon!! ; +| : ## ( n -- ) base push decimal 0 <# #S #> ccon!! ; +| : csi ( -- ) #esc con! Ascii [ con! ; +| : ANSIcuron ( -- ) csi " ?25h" con!! ; +| : ANSIcuroff ( -- ) csi " ?25l" con!! ; +| : ANSIrvson ( -- ) csi " 7m" con!! ; +| : ANSIrvsoff ( -- ) csi " 0m" con!! ; +| : ANSIdark ( -- ) csi " 2J" con!! csi " ;H" con!! ; +| : ANSIlocate ( row col -- ) + csi swap 1+ ## ascii ; con! 1+ ## ascii H con! ; + +Terminal: ANSI +noop noop ANSIrvson ANSIrvsoff ANSIdark ANSIlocate ; +ANSI page rvson .( ANSI Terminal installiert. ) rvsoff cr cr diff --git a/sources/cpm/times.fth b/sources/cpm/times.fth new file mode 100644 index 0000000..35a35b2 --- /dev/null +++ b/sources/cpm/times.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\\ Times Often: interactive loops 11Nov86 + +Dieses File enthaelt die Definitionen der beiden Utility-Worte +TIMES, OFTEN, die interaktiv benutzt werden koennen, was +normalerweise mit BEGIN WHILE ... nicht moeglich ist. + +Benutzung: nur interaktiv! + +a b ... nn times \ Wiederhole die Befehlsfolge "a b ..." nn mal, + \ oder bis eine Taste gedrueckt wird, oder + \ bis ein Fehler auftritt, + +a b ... often \ Wiederhole die Befehlsfolge "a b ..." + \ so oft, bis eine Taste gedrueckt wird, oder + \ bis ein Fehler auftritt. + +\ *** Block No. 1 Hexblock 1 +\ Times, Often 02feb86 + +also Forth definitions + +: often stop? ?exit >in off ; + +| Variable #times #times off + +: times ( n --) + ?dup IF #times @ 2+ u< stop? or + IF #times off exit THEN 1 #times +! + ELSE stop? ?exit THEN >in off ; + +toss definitions + + diff --git a/sources/cpm/tools.fth b/sources/cpm/tools.fth new file mode 100644 index 0000000..fbf6473 --- /dev/null +++ b/sources/cpm/tools.fth @@ -0,0 +1,306 @@ +\ *** Block No. 0 Hexblock 0 +\\ Tools 11Nov86 +Dieses File enthaelt die wichtigsten Werkzeuge zur Programm- +entwicklung: - den einfachen Decompiler + - der DUMP-Befehl + - den Tracer + +Der einfache Decompiler wird benutzt, um neue Defining-Words +zu ueberpruefen. Der automatische Decompiler kann ja dafuer +nicht benutzt werden, da ihm diese Strukturen unbekannt sind. +(Benutzung: addr und dann, je nach Art: S N D L C oder B) + +DUMP wird zum Ausgeben von Hexdumps benutzt. (from count DUMP) + +Der Tracer erlaubt Einzelschrittausfuehrung von Worten. +Er ist unentbehrliches Hilfsmittel bei der Fehlersuche. +(Benutzung: DEBUG und END-TRACE) +\ *** Block No. 1 Hexblock 1 +\ Programming-Tools word set / tracer cas 19july2020 + +Onlyforth Vocabulary Tools Tools also definitions + +01 05 +thru &15 &16 +thru + 06 +load \ Tracer + +Onlyforth + +: internal \ start headerless definitions + 1 ?head ! ; + +: external \ end headerless definitions + ?head off ; + + +\ *** Block No. 2 Hexblock 2 +\ Tools for decompiling 22feb86 + +| : ?: dup 4 u.r ." :" ; +| : @? dup @ 6 u.r ; +| : c? dup c@ 3 .r ; + +: s ( adr - adr+ ) + ?: space c? 3 spaces dup 1+ over c@ type dup c@ + 1+ even ; + +: n ( adr - adr+2 ) ?: @? 2 spaces dup @ >name .name 2+ ; +: d ( adr n - adr+n) + 2dup swap ?: swap 0 DO c? 1+ LOOP 2 spaces -rot type ; + + + + +\ *** Block No. 3 Hexblock 3 +\ Tools for decompiling 22feb86 + +: l ( adr - adr+2 ) ?: 5 spaces @? 2+ ; +: c ( adr - adr+1) 1 d ; +: b ( adr - adr+1) ?: @? dup @ over + 5 u.r 2+ ; + + + +\\ +: dump ( adr n -) bounds ?DO cr I 10 d drop stop? IF LEAVE +THEN 10 +LOOP ; + + + + + +\ *** Block No. 4 Hexblock 4 +\ General Dump Utility - Output UH 07Jun86 + +| : .2 ( n -- ) 0 <# # # #> type space ; +| : .6 ( d -- ) <# # # # # # # #> type ; +| : d.2 ( addr len -- ) bounds ?DO I C@ .2 LOOP ; +| : emit. ( char -- ) + $7F and dup bl $7E uwithin not IF drop Ascii . THEN emit ; +| : dln ( addr --- ) + cr dup 6 u.r 2 spaces 8 2dup d.2 space + over + 8 d.2 space $10 bounds ?DO I C@ EMIT. LOOP ; +| : ?.n ( n1 n2 -- n1 ) + 2dup = IF ." \/" drop ELSE 2 .r THEN space ; +| : ?.a ( n1 n2 -- n1 ) + 2dup = IF ." V" drop ELSE 1 .r THEN ; + + +\ *** Block No. 5 Hexblock 5 +\ .head UH 03Jun86 + + +| : .head ( addr len -- addr' len' ) + swap dup -$10 and swap $0F and cr 8 spaces + 8 0 DO I ?.n LOOP space $10 8 DO I ?.n LOOP + space $10 0 DO I ?.a LOOP rot + ; + + + + + + + + + +\ *** Block No. 6 Hexblock 6 +\ Dump and Fill Memory Utility UH 25Aug86 + +Forth definitions + +: dump ( addr len -- ) + base push hex .head + bounds ?DO I dln stop? IF LEAVE THEN $10 +LOOP ; + +Tools definitions + +: du ( addr -- addr+$40 ) dup $40 dump $40 + ; + +: dl ( line# -- ) c/l * scr @ block + c/l dump ; + +Forth definitions + +\ *** Block No. 7 Hexblock 7 +\ Trace Loadscreen 29Jun86 + +Onlyforth \needs Tools Vocabulary Tools +Tools also definitions + +1 8 +thru + +Onlyforth + +\ clear + +\ don't forget END-TRACE after using DEBUG + + + + +\ *** Block No. 8 Hexblock 8 +\ Variables do-trace UH 04Nov86 + +| Variable Wsave \ Variable for saving W +| Variable \ end of trace trap range +| Variable 'ip \ holds IP (preincrement!) +| Variable nest? \ True if NEST shall be performed +| Variable newnext \ Address of new Next for tracing +| Variable #spaces \ for indenting nested trace +| Variable tracing \ true if trace mode active + + + + + + +\ *** Block No. 9 Hexblock 9 +\ install Tracer UH 18Nov87 + +Tools definitions + +| Code do-trace \ patch Next to new definition + $C3 A mvi ( jmp ) >next sta + newnext lhld >next 1+ shld Next +end-code + + + + + + + + +\ *** Block No. 10 Hexblock A +\ throw status on Return-Stack 29Jun86 + +| Create: npull + rp@ count 2dup + even rp! r> swap cmove ; + +: npush ( addr len --) r> -rot over >r + rp@ over 1+ - even dup rp! place npull >r >r ; + +| : oneline .status space query interpret -&82 allot + rdrop ( delete quit from tracenext ) ; + + + + + + +\ *** Block No. 11 Hexblock B +\ reenter tracer 04Nov86 + +| Code (step + true H lxi tracing shld IP rpop Wsave lhld H W mvx +Label fnext + xchg + M E mov H inx M D mov xchg pchl +end-code + +| Create: nextstep (step ; + +| : (debug ( addr --) \ start tracing at addr + dup ! ; + + +\ *** Block No. 12 Hexblock C +\ check trace conditions 04Nov86 + +Label tracenext tracenext newnext ! + IP ldax IP inx A L mov IP ldax IP inx A H mov + xchg tracing lhld H A mov L ora fnext jz + nest? 1+ lda A ana + 0= ?[ + lhld + H A mov IP cmp fnext jc + 0= ?[ L A mov IP' cmp fnext jc ]? + ][ A xra nest? 1+ sta ]? \ low byte still set + \ one trace condition satisfied + W H mvx Wsave shld false H lxi tracing shld +\ *** Block No. 13 Hexblock D +\ tracer display UH 25Jan88 + +;c: nest? @ + IF nest? off r> ip> push r THEN + r@ nextstep >r input push output push standardi/o + cr #spaces @ spaces + dup 'ip ! 2- dup 5 u.r @ dup 6 u.r 2 spaces + >name .name $1C col - 0 max spaces .s + state push blk push >in push ['] 'quit >body push + [ ' parser >body ] Literal push + span push #tib push tib #tib @ npush r0 push + rp@ r0 ! &82 allot ['] oneline Is 'quit quit ; + + + +\ *** Block No. 14 Hexblock E +\ DEBUG with errorchecking 28Nov86 + +| : traceable ( cfa -- cfa' ) + recursive dup @ + ['] : @ case? ?exit + ['] key @ case? IF >body c@ Input @ + @ traceable exit THEN + ['] type @ case? IF >body c@ Output @ + @ traceable exit THEN + ['] r/w @ case? IF >body traceable exit THEN + dup 1+ @ [ ' Forth @ 1+ @ ] Literal = IF nip 1+ exit THEN + drop >name .name ." can't be DEBUGged" quit ; + +also Forth definitions + +: debug ( -- ) \ reads a word + ' traceable (debug Tools + nest? off #spaces off tracing on do-trace ; +\ *** Block No. 15 Hexblock F +\ misc. words for tracing 28Nov86 +Tools definitions + +: nest \ trace next high-level word executed + 'ip @ 2- @ traceable drop nest? on ; + +: unnest \ ends tracing of actual word + off ; \ clears trap range + +: endloop \ stop tracing loop + 'ip @ R NR> cr + +: N>R ( i * n +n -- ) ( R: -- j * x +n ) +\ Transfer N items and count to the return stack. + DUP BEGIN DUP WHILE + ROT R> SWAP >R >R + 1- + REPEAT DROP R> SWAP >R >R ; + +: NR> ( -- i * x +n ) ( R: j * x +n -- ) +\ Pull N items and count off the return stack. + R> R> SWAP >R DUP + BEGIN DUP WHILE + R> R> SWAP >R -ROT + 1- + REPEAT DROP ; +\ *** Block No. 17 Hexblock 11 +\ ? + +: ? ( a-addr -- ) +\ Display the value stored at a-addr. + @ . ; + + + + + + + + + + + diff --git a/sources/cpm/xinout.fth b/sources/cpm/xinout.fth new file mode 100644 index 0000000..38dfdca --- /dev/null +++ b/sources/cpm/xinout.fth @@ -0,0 +1,136 @@ +\ *** Block No. 0 Hexblock 0 +\ Erweiterte I/O-Funktionen 3.80a UH 08Oct87 + +Dieses File enthaelt Definitionen, die eine erweiterte Bild- +schirmdarstellung ermoeglichen: + + - Installation eines Terminals mit Hilfe des Wortes + "Terminal:" + + - Editieren von Eingabezeilen + +In der Version 3.80a sind diese Teile aus dem Kern genommen +worden, um diesen einfacher zu gestalten. + + + + +\ *** Block No. 1 Hexblock 1 +\ Erweiterte I/O-Funktionen 3.80a LOAD-Screen UH 20Nov87 + + +1 3 +thru \ Erweiterte Ausgabe + +4 6 +thru \ Erweiterte Eingabe + + +' curon Is postlude + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ Erweiterte Ausgabe: Terminal-Defintionen UH 08OCt87 +| Variable terminal + +: Term: ( off -- off' ) Create dup c, 2+ + Does> c@ terminal @ + perform ; + +: Terminal: Create: Does> terminal ! ; + +0 Term: curon Term: curoff + Term: rvson Term: rvsoff + Term: dark Term: locate drop + +: curleft ( -- ) at? 1- at ; +: currite ( -- ) at? 1+ at ; + +Terminal: dumb noop noop noop noop noop 2drop ; dumb +\ *** Block No. 3 Hexblock 3 +\ Erweiterte Ausgabe: UH 06Mar88 + +&80 Constant c/row &24 Constant c/col + +| Create 'at 0 , here 0 , | Constant 'row ' 'at | Alias 'col + +: (at ( row col -- ) c/row 1- min swap c/col 1- min swap + 2dup 'at 2! locate ; +: (at? ( -- row col ) 'at 2@ ; + +: (page ( -- ) 0 0 'at 2! dark ; + +: (type ( addr len -- ) dup 'col +! + 0 ?DO count (emit LOOP drop ; + +: (emit ( c -- ) 1 'col +! (emit ; +\ *** Block No. 4 Hexblock 4 +\ Erweiterte Ausgabe: UH 04Mar88 + +: (cr ( -- ) 'row @ 1+ 0 'at 2! (cr ; +: (del ( -- ) 'col @ 0> 0=exit -1 'col +! (del ; + +' (emit ' display 2+ ! +' (cr ' display 4 + ! +' (type ' display 6 + ! +' (del ' display 8 + ! +' (page ' display &10 + ! +' (at ' display &12 + ! +' (at? ' display &14 + ! + + + + +\ *** Block No. 5 Hexblock 5 +\ Erweiterte Eingabe UH 08OCt87 +| Variable maxchars | Variable oldspan oldspan off + +| : redisplay ( addr pos -- ) + at? 2swap under + span @ rot - type space at ; +| : del ( addr pos1 -- ) dup >r + dup 1+ swap + span @ r> - 1- cmove -1 span +! ; +| : ins ( addr pos1 -- ) dup >r + dup dup 1+ + span @ r> - cmove> bl swap c! 1 span +! ; + +| : (ins ( a p1 -- a p2 ) 2dup ins 2dup redisplay ; +| : (del ( a p1 -- a p2 ) 2dup del 2dup redisplay ; +| : (back ( a p1 -- a p2 ) 1- curleft (del ; +| : (recall ( a p1 -- a p2 ) ?dup ?exit + oldspan @ span ! 0 2dup redisplay ; + +\ *** Block No. 6 Hexblock 6 +\ Tastenbelegung fuer Zeilen-Editor CP/M UH 18Mar88 +: (decode ( addr pos1 key -- addr pos2 ) + 4 case? IF dup span @ < 0=exit currite 1+ exit THEN + &19 case? IF dup 0=exit curleft 1- exit THEN + &22 case? IF dup span @ = ?exit (ins exit THEN + #bs case? IF dup 0=exit (back exit THEN + #del case? IF dup 0=exit (back exit THEN + 7 case? IF span @ 2dup < and 0=exit (del exit THEN + $1B case? IF (recall exit THEN + #cr case? IF span @ dup maxchars ! oldspan ! + dup at? rot span @ - - at space exit THEN + dup emit >r 2dup + r> swap c! 1+ dup span @ max span ! ; + +: (expect ( addr len -- ) maxchars ! span off 0 + BEGIN span @ maxchars @ u< WHILE key decode REPEAT 2drop ; + +\ *** Block No. 7 Hexblock 7 +\ Patch UH 08Oct87 + +: (key ( -- char ) + curon BEGIN pause (key? UNTIL curoff getkey ; + +' (key ' keyboard 2+ ! +' (decode ' keyboard 6 + ! +' (expect ' keyboard 8 + ! + + + + + + + + diff --git a/sources/msdos/ansi.fth b/sources/msdos/ansi.fth new file mode 100644 index 0000000..fd0da0a --- /dev/null +++ b/sources/msdos/ansi.fth @@ -0,0 +1,136 @@ +\ *** Block No. 0 Hexblock 0 + cas 10nov05 +Video display interface for an ANSI.SYS interface. +It should work on any MS-DOS computer. Since ANSI.SYS does +not have a delete line function, split screen can not +be implemented as usual. Instead, the cursor "rotates" +ie. when a CR is performed on the bottom line, the cursor +moves up to the top line in the current window. + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ ansi cursor control cas 10nov05 + Onlyforth + +| : (char" "lit count bounds DO I c@ charout LOOP ; +| : char" compile (char" ," align ; immediate restrict + +| Ascii 0 Constant #0 + +| : (#S) ( u -- ) &10 /mod #0 + charout #0 + charout ; + + : (at ( row col -- ) char" [" + swap 1+ (#S) char" ;" 1+ (#S) char" H" ; + +| : )##( ( -- u ) (key #0 - &10 * (key #0 - + ; + + 1 4 +thru .( ANSI display interface active) cr +\ *** Block No. 2 Hexblock 2 +\ Ansi Standard display output cas 10nov05 +| : keydrop (key drop ; + + : (at? char" " keydrop keydrop + )##( 1- keydrop )##( 1- keydrop keydrop ; + + Variable top top off + + : full top off ; + + : blankline char" " ; +| : lineerase 0 (at blankline ; + + : normal char" " ; : invers char" " ; + : underline char" " ; : bright char" " ; + +\ *** Block No. 3 Hexblock 3 +\ Ansi Standard display output cas 10nov05 + + ' 2drop Alias curshape + ' drop Alias setpage + ' (at? Alias curat? + + : (type ( addr len -- ) pad place + pad count bounds ?DO I c@ (emit LOOP ; + + : (cr top @ 0= adr .status @ ['] noop = and + IF (cr exit THEN row c/col 2- u< + IF row 1+ ELSE top @ THEN lineerase ; + + : (page top @ 0= IF char" " exit THEN + top @ c/col 2- DO I lineerase -1 +LOOP ; + +\ *** Block No. 4 Hexblock 4 +\ statusline cas 10nov05 + + ' (cr ' display 4 + ! ' (type ' display 6 + ! + ' (page ' display &10 + ! + ' (at ' display &12 + ! ' (at? ' display &14 + ! + + + : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; + : .base base @ decimal dup 2 .r base ! ; + : (.drv ( n -- ) Ascii A + emit ." : " ; + : .dr ." " drv (.drv ; + : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN + @ 5 .r ; + : .space ." Dic" s0 @ here $100 + - 6 u.r ; + + +\ *** Block No. 5 Hexblock 5 +\ statusline cas 10nov05 + +| : fstat ( n -- ) invers .base .sp + .space .scr .dr file? 2 spaces order normal ; + + : .stat output @ (at? display c/col 1- 0 (at + 3 fstat blankline (at output ! ; + + : +stat ['] .stat Is .status .status ; + + : -stat ['] noop Is .status ; + + + + + +\ *** Block No. 6 Hexblock 6 + + + + + + + + + + + + + + + + +\ *** Block No. 7 Hexblock 7 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/ansi.vid.src b/sources/msdos/ansi.vid.src deleted file mode 100644 index 17eb29a..0000000 --- a/sources/msdos/ansi.vid.src +++ /dev/null @@ -1,136 +0,0 @@ -Screen 0 not modified - 0 cas 10nov05 - 1 Video display interface for an ANSI.SYS interface. - 2 It should work on any MS-DOS computer. Since ANSI.SYS does - 3 not have a delete line function, split screen can not - 4 be implemented as usual. Instead, the cursor "rotates" - 5 ie. when a CR is performed on the bottom line, the cursor - 6 moves up to the top line in the current window. - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ ansi cursor control cas 10nov05 - 1 Onlyforth - 2 - 3 | : (char" "lit count bounds DO I c@ charout LOOP ; - 4 | : char" compile (char" ," align ; immediate restrict - 5 - 6 | Ascii 0 Constant #0 - 7 - 8 | : (#S) ( u -- ) &10 /mod #0 + charout #0 + charout ; - 9 -10 : (at ( row col -- ) char" [" -11 swap 1+ (#S) char" ;" 1+ (#S) char" H" ; -12 -13 | : )##( ( -- u ) (key #0 - &10 * (key #0 - + ; -14 -15 1 4 +thru .( ANSI display interface active) cr -Screen 2 not modified - 0 \ Ansi Standard display output cas 10nov05 - 1 | : keydrop (key drop ; - 2 - 3 : (at? char" " keydrop keydrop - 4 )##( 1- keydrop )##( 1- keydrop keydrop ; - 5 - 6 Variable top top off - 7 - 8 : full top off ; - 9 -10 : blankline char" " ; -11 | : lineerase 0 (at blankline ; -12 -13 : normal char" " ; : invers char" " ; -14 : underline char" " ; : bright char" " ; -15 -Screen 3 not modified - 0 \ Ansi Standard display output cas 10nov05 - 1 - 2 ' 2drop Alias curshape - 3 ' drop Alias setpage - 4 ' (at? Alias curat? - 5 - 6 : (type ( addr len -- ) pad place - 7 pad count bounds ?DO I c@ (emit LOOP ; - 8 - 9 : (cr top @ 0= adr .status @ ['] noop = and -10 IF (cr exit THEN row c/col 2- u< -11 IF row 1+ ELSE top @ THEN lineerase ; -12 -13 : (page top @ 0= IF char" " exit THEN -14 top @ c/col 2- DO I lineerase -1 +LOOP ; -15 -Screen 4 not modified - 0 \ statusline cas 10nov05 - 1 - 2 ' (cr ' display 4 + ! ' (type ' display 6 + ! - 3 ' (page ' display &10 + ! - 4 ' (at ' display &12 + ! ' (at? ' display &14 + ! - 5 - 6 - 7 : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; - 8 : .base base @ decimal dup 2 .r base ! ; - 9 : (.drv ( n -- ) Ascii A + emit ." : " ; -10 : .dr ." " drv (.drv ; -11 : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN -12 @ 5 .r ; -13 : .space ." Dic" s0 @ here $100 + - 6 u.r ; -14 -15 -Screen 5 not modified - 0 \ statusline cas 10nov05 - 1 - 2 | : fstat ( n -- ) invers .base .sp - 3 .space .scr .dr file? 2 spaces order normal ; - 4 - 5 : .stat output @ (at? display c/col 1- 0 (at - 6 3 fstat blankline (at output ! ; - 7 - 8 : +stat ['] .stat Is .status .status ; - 9 -10 : -stat ['] noop Is .status ; -11 -12 -13 -14 -15 -Screen 6 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/anstest.fth b/sources/msdos/anstest.fth new file mode 100644 index 0000000..4a499f1 --- /dev/null +++ b/sources/msdos/anstest.fth @@ -0,0 +1,34 @@ +\ *** Block No. 0 Hexblock 0 +\ ANS Test Load Screen cas 25jun20 + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ ANS Test Load Screen cas 25jun20 + +include ans-shim.fb cr +include tester.fb cr + +: .block blk @ . ; ' .block IS .status + +verbose on +include coretest.fb + + + + + + + diff --git a/sources/msdos/asm.fb.src b/sources/msdos/asm.fb.src deleted file mode 100644 index 5210dc3..0000000 --- a/sources/msdos/asm.fb.src +++ /dev/null @@ -1,391 +0,0 @@ -Screen 0 not modified - 0 \ 8086 Assembler cas 10nov05 - 1 This 8086 Assembler was written by Klaus Schleisiek. - 2 Assembler Definitions are created with the definig word - 3 CODE and closed with the word END-CODE. - 4 - 5 The 8086 Registers naming and usage in volksFORTH - 6 - 7 Intel vForth Used for 8bit-Register - 8 AX A free A+ A- - 9 DX D topmost Stackitem D+ D- -10 CX C free C+ C- -11 BX R Returnstack Pointer R+ R- -12 BP U User Pointer -13 SP S Stack Pointer -14 SI I Instruction Pointer -15 DI W Word Pointer, mostly free -Screen 1 not modified - 0 \ 8086 Assembler loadscreen cas 10nov05 - 1 Onlyforth - 2 - 3 | : u2/ ( 16b -- 15b ) 2/ $7FFF and ; - 4 | : 8* ( 15b -- 16b ) 2* 2* 2* ; - 5 | : 8/ ( 16b -- 13b ) u2/ 2/ 2/ ; - 6 - 7 Vocabulary Assembler - 8 Assembler also definitions - 9 -10 3 &21 thru clear .( Assembler loaded ) cr -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ conditional Assembler compiler cas 10nov05 - 1 here - 2 - 3 : temp-assembler ( addr -- ) hide last off dp ! - 4 " ASSEMBLER" find nip ?exit here $1800 + sp@ u> - 5 IF display cr ." Assembler won't fit" abort THEN - 6 here sp@ $1800 - dp ! 1 load dp ! ; - 7 - 8 temp-assembler \\ - 9 -10 : blocks ( n -- addr / ff ) -11 first @ >r dup 0 ?DO freebuffer LOOP -12 [ b/blk negate ] Literal * first @ + r@ u> r> and ; -13 -14 -15 -Screen 3 not modified - 0 \ Code generating primitives cas 10nov05 - 1 - 2 Variable >codes \ points at table of execution vectors - 3 - 4 | Create nrc ] c, , here ! c! [ - 5 - 6 : nonrelocate nrc >codes ! ; nonrelocate - 7 - 8 | : >exec ( n -- n+2 ) Create dup c, 2+ - 9 Does> c@ >codes @ + perform ; -10 -11 0 | >exec >c, | >exec >, | >exec >here -12 | >exec >! | >exec >c! drop -13 -14 -15 -Screen 4 not modified - 0 \ 8086 Registers cas 10nov05 - 1 - 2 0 Constant A 1 Constant C 2 Constant D 3 Constant R - 3 4 Constant S 5 Constant U 6 Constant I 7 Constant W - 4 ' I Alias SI ' W Alias DI ' R Alias BX - 5 - 6 8 Constant A- 9 Constant C- $A Constant D- $B Constant R- - 7 $C Constant A+ $D Constant C+ $E Constant D+ $F Constant R+ - 8 ' R- Alias B- ' R+ Alias B+ - 9 -10 $100 Constant E: $101 Constant C: -11 $102 Constant S: $103 Constant D: -12 -13 | Variable isize ( specifies Size by prefix) -14 | : Size: ( n -- ) Create c, Does> c@ isize ! ; -15 0 Size: byte 1 Size: word word 2 Size: far -Screen 5 not modified - 0 \ 8086 Assembler System variables cas 10nov05 - 1 - 2 | Variable direction \ 0 reg>EA, -1 EA>reg - 3 | Variable size \ 1 word, 0 byte, -1 undefined - 4 | Variable displaced \ 1 direct, 0 nothing, -1 displaced - 5 | Variable displacement - 6 - 7 | : setsize isize @ size ! ; - 8 | : long? ( n -- f ) $FF80 and dup 0< not ?exit $FF80 xor ; - 9 | : wexit rdrop word ; -10 | : moderr word true Abort" invalid" ; -11 | : ?moderr ( f -- ) 0=exit moderr ; -12 | : ?word size @ 1- ?moderr ; -13 | : far? ( -- f ) size @ 2 = ; -14 -15 -Screen 6 not modified - 0 \ 8086 addressing modes cas 10nov05 - 1 - 2 | Create (EA 7 c, 0 c, 6 c, 4 c, 5 c, - 3 | : () ( 8b1 -- 8b2 ) - 4 3 - dup 4 u> over 1 = or ?moderr (EA + c@ ; - 5 - 6 -1 Constant # $C6 Constant #) -1 Constant C* - 7 - 8 : ) ( u1 -- u2 ) - 9 () 6 case? IF 0 $86 exit THEN $C0 or ; -10 : I) ( u1 u2 -- u3 ) + 9 - dup 3 u> ?moderr $C0 or ; -11 -12 : D) ( n u1 -- n u2 ) -13 () over long? IF $40 ELSE $80 THEN or ; -14 : DI) ( n u1 u2 -- n u3 ) -15 I) over long? IF $80 ELSE $40 THEN xor ; -Screen 7 not modified - 0 \ 8086 Registers and addressing modes cas 10nov05 - 1 - 2 | : displaced? ( [n] u1 -- [n] u1 f ) - 3 dup #) = IF 1 exit THEN - 4 dup $C0 and dup $40 = swap $80 = or ; - 5 - 6 | : displace ( [n] u1 -- u1 ) displaced? ?dup 0=exit - 7 displaced @ ?moderr displaced ! swap displacement ! ; - 8 - 9 | : rmode ( u1 -- u2 ) 1 size ! dup 8 and 0=exit -10 size off $FF07 and ; -11 -12 | : mmode? ( 9b - 9b f) dup $C0 and ; -13 -14 | : rmode? ( 8b1 - 8b1 f) mmode? $C0 = ; -15 -Screen 8 not modified - 0 \ 8086 decoding addressing modes cas 10nov05 - 1 - 2 | : 2address ( [n] source [displ] dest -- 15b / [n] 16b ) - 3 size on displaced off dup # = ?moderr mmode? - 4 IF displace False ELSE rmode True THEN direction ! - 5 >r # case? IF r> $80C0 xor size @ 1+ ?exit setsize exit - 6 THEN direction @ - 7 IF r> 8* >r mmode? IF displace - 8 ELSE dup 8/ 1 and size @ = ?moderr $FF07 and THEN - 9 ELSE rmode 8* -10 THEN r> or $C0 xor ; -11 -12 | : 1address ( [displ] 9b -- 9b ) -13 # case? ?moderr size on displaced off direction off -14 mmode? IF displace setsize ELSE rmode THEN $C0 xor ; -15 -Screen 9 not modified - 0 \ 8086 assembler cas 10nov05 - 1 | : immediate? ( u -- u f ) dup 0< ; - 2 - 3 | : nonimmediate ( u -- u ) immediate? ?moderr ; - 4 - 5 | : r/m 7 and ; - 6 - 7 | : reg $38 and ; - 8 - 9 | : ?akku ( u -- u ff / tf ) dup r/m 0= dup 0=exit nip ; -10 -11 | : smode? ( u1 -- u1 ff / u2 tf ) dup $F00 and -12 IF dup $100 and IF dup r/m 8* swap reg 8/ -13 or $C0 or direction off -14 THEN True exit -15 THEN False ; -Screen 10 not modified - 0 \ 8086 Registers and addressing modes cas 10nov05 - 1 - 2 | : w, size @ or >c, ; - 3 - 4 | : dw, size @ or direction @ IF 2 xor THEN >c, ; - 5 - 6 | : ?word, ( u1 f -- ) IF >, exit THEN >c, ; - 7 - 8 | : direct, displaced @ 0=exit - 9 displacement @ dup long? displaced @ 1+ or ?word, ; -10 -11 | : r/m, >c, direct, ; -12 -13 | : data, size @ ?word, ; -14 -15 -Screen 11 not modified - 0 \ 8086 Arithmetic instructions cas 10nov05 - 1 - 2 | : Arith: ( code -- ) Create , - 3 Does> @ >r 2address immediate? - 4 IF rmode? IF ?akku IF r> size @ - 5 IF 5 or >c, >, wexit THEN - 6 4 or >c, >c, wexit THEN THEN - 7 r@ or $80 size @ or r> 0< - 8 IF size @ IF 2 pick long? 0= IF 2 or size off THEN - 9 THEN THEN >c, >c, direct, data, wexit -10 THEN r> dw, r/m, wexit ; -11 -12 $8000 Arith: add $0008 Arith: or -13 $8010 Arith: adc $8018 Arith: sbb -14 $0020 Arith: and $8028 Arith: sub -15 $0030 Arith: xor $8038 Arith: cmp -Screen 12 not modified - 0 \ 8086 move push pop cas 10nov05 - 1 - 2 : mov [ Forth ] 2address immediate? - 3 IF rmode? IF r/m $B0 or size @ IF 8 or THEN - 4 >c, data, wexit - 5 THEN $C6 w, r/m, data, wexit - 6 THEN 6 case? IF $A2 dw, direct, wexit THEN - 7 smode? IF $8C direction @ IF 2 or THEN >c, r/m, wexit - 8 THEN $88 dw, r/m, wexit ; - 9 -10 | : pupo [ Forth ] >r 1address ?word -11 smode? IF reg 6 r> IF 1+ THEN or >c, wexit THEN -12 rmode? IF r/m $50 or r> or >c, wexit THEN -13 r> IF $8F ELSE $30 or $FF THEN >c, r/m, wexit ; -14 -15 : push 0 pupo ; : pop 8 pupo ; -Screen 13 not modified - 0 \ 8086 inc & dec , effective addresses cas 10nov05 - 1 - 2 | : inc/dec [ Forth ] >r 1address rmode? - 3 IF size @ IF r/m $40 or r> or >c, wexit THEN - 4 THEN $FE w, r> or r/m, wexit ; - 5 - 6 : dec 8 inc/dec ; : inc 0 inc/dec ; - 7 - 8 | : EA: ( code -- ) Create c, [ Forth ] - 9 Does> >r 2address nonimmediate -10 rmode? direction @ 0= or ?moderr r> c@ >c, r/m, wexit ; -11 -12 $C4 EA: les $8D EA: lea $C5 EA: lds -13 -14 -15 -Screen 14 not modified - 0 \ 8086 xchg segment prefix cas 10nov05 - 1 : xchg [ Forth ] 2address nonimmediate rmode? - 2 IF size @ IF dup r/m 0= - 3 IF 8/ true ELSE dup $38 and 0= THEN - 4 IF r/m $90 or >c, wexit THEN - 5 THEN THEN $86 w, r/m, wexit ; - 6 - 7 | : 1addr: ( code -- ) Create c, [ Forth ] - 8 Does> c@ >r 1address $F6 w, r> or r/m, wexit ; - 9 -10 $10 1addr: com $18 1addr: neg -11 $20 1addr: mul $28 1addr: imul -12 $38 1addr: idiv $30 1addr: div -13 -14 : seg ( 8b -) [ Forth ] -15 $100 xor dup $FFFC and ?moderr 8* $26 or >c, ; -Screen 15 not modified - 0 \ 8086 test not neg mul imul div idiv cas 10nov05 - 1 - 2 : test [ Forth ] 2address immediate? - 3 IF rmode? IF ?akku IF $A8 w, data, wexit THEN THEN - 4 $F6 w, r/m, data, wexit - 5 THEN $84 w, r/m, wexit ; - 6 - 7 | : in/out [ Forth ] >r 1address setsize - 8 $C2 case? IF $EC r> or w, wexit THEN - 9 6 - ?moderr $E4 r> or w, displacement @ >c, wexit ; -10 -11 : out 2 in/out ; : in 0 in/out ; -12 -13 : int 3 case? IF $CC >c, wexit THEN $CD >c, >c, wexit ; -14 -15 -Screen 16 not modified - 0 \ 8086 shifts and string instructions cas 10nov05 - 1 - 2 | : Shifts: ( code -- ) Create c, [ Forth ] - 3 Does> c@ >r C* case? >r 1address - 4 r> direction ! $D0 dw, r> or r/m, wexit ; - 5 - 6 $00 Shifts: rol $08 Shifts: ror - 7 $10 Shifts: rcl $18 Shifts: rcr - 8 $20 Shifts: shl $28 Shifts: shr - 9 $38 Shifts: sar ' shl Alias sal -10 -11 | : Str: ( code -- ) Create c, -12 Does> c@ setsize w, wexit ; -13 -14 $A6 Str: cmps $AC Str: lods $A4 Str: movs -15 $AE Str: scas $AA Str: stos -Screen 17 not modified - 0 \ implied 8086 instructions cas 10nov05 - 1 - 2 : Byte: ( code -- ) Create c, Does> c@ >c, ; - 3 : Word: ( code -- ) Create , Does> @ >, ; - 4 - 5 $37 Byte: aaa $AD5 Word: aad $AD4 Word: aam - 6 $3F Byte: aas $98 Byte: cbw $F8 Byte: clc - 7 $FC Byte: cld $FA Byte: cli $F5 Byte: cmc - 8 $99 Byte: cwd $27 Byte: daa $2F Byte: das - 9 $F4 Byte: hlt $CE Byte: into $CF Byte: iret -10 $9F Byte: lahf $F0 Byte: lock $90 Byte: nop -11 $9D Byte: popf $9C Byte: pushf $9E Byte: sahf -12 $F9 Byte: stc $FD Byte: std $FB Byte: sti -13 $9B Byte: wait $D7 Byte: xlat -14 $C3 Byte: ret $CB Byte: lret -15 $F2 Byte: rep $F2 Byte: 0<>rep $F3 Byte: 0=rep -Screen 18 not modified - 0 \ 8086 jmp call conditions cas 10nov05 - 1 | : jmp/call >r setsize # case? [ Forth ] - 2 IF far? IF r> IF $EA ELSE $9A THEN >c, swap >, >, wexit - 3 THEN >here 2+ - r> - 4 IF dup long? 0= IF $EB >c, >c, wexit THEN $E9 - 5 ELSE $E8 THEN >c, 1- >, wexit - 6 THEN 1address $FF >c, $10 or r> + - 7 far? IF 8 or THEN r/m, wexit ; - 8 : call 0 jmp/call ; : jmp $10 jmp/call ; - 9 -10 $71 Constant OS $73 Constant CS -11 $75 Constant 0= $77 Constant >= -12 $79 Constant 0< $7B Constant PE -13 $7D Constant < $7F Constant <= -14 $E2 Constant C0= $E0 Constant ?C0= -15 : not 1 [ Forth ] xor ; -Screen 19 not modified - 0 \ 8086 conditional branching cas 10nov05 - 1 - 2 : +ret $C2 >c, >, ; - 3 : +lret $CA >c, >, ; - 4 - 5 | : ?range dup long? abort" out of range" ; - 6 - 7 : ?[ >, >here 1- ; - 8 : ]? >here over 1+ - ?range swap >c! ; - 9 : ][ $EB ?[ swap ]? ; -10 : ?[[ ?[ swap ; -11 : [[ >here ; -12 : ?] >c, >here 1+ - ?range >c, ; -13 : ]] $EB ?] ; -14 : ]]? ]] ]? ; -15 -Screen 20 not modified - 0 \ Next user' end-code ;c: cas 10nov05 - 1 - 2 : Next lods A W xchg W ) jmp - 3 >here next-link @ >, next-link ! ; - 4 - 5 : u' ' >body c@ ; - 6 - 7 Forth definitions - 8 - 9 \needs end-code : end-code toss also ; -10 -11 Assembler definitions -12 -13 : ;c: recover # call last off end-code 0 ] ; -14 -15 -Screen 21 not modified - 0 \ 8086 Assembler, Forth words cas 10nov05 - 1 Onlyforth - 2 - 3 : Assembler Assembler [ Assembler ] wexit ; - 4 - 5 : ;code 0 ?pairs compile (;code - 6 reveal [compile] [ Assembler ; immediate - 7 - 8 : Code Create [ Assembler ] >here dup 2- >! Assembler ; - 9 -10 : >label ( addr -- ) -11 here | Create immediate swap , 4 hallot -12 here 4 - heap 4 cmove heap last @ (name> ! dp ! -13 Does> ( -- addr ) @ state @ 0=exit [compile] Literal ; -14 -15 : Label [ Assembler ] >here >label Assembler ; -Screen 22 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/asm.fth b/sources/msdos/asm.fth new file mode 100644 index 0000000..a019eee --- /dev/null +++ b/sources/msdos/asm.fth @@ -0,0 +1,391 @@ +\ *** Block No. 0 Hexblock 0 +\ 8086 Assembler cas 10nov05 +This 8086 Assembler was written by Klaus Schleisiek. +Assembler Definitions are created with the definig word +CODE and closed with the word END-CODE. + +The 8086 Registers naming and usage in volksFORTH + +Intel vForth Used for 8bit-Register +AX A free A+ A- +DX D topmost Stackitem D+ D- +CX C free C+ C- +BX R Returnstack Pointer R+ R- +BP U User Pointer +SP S Stack Pointer +SI I Instruction Pointer +DI W Word Pointer, mostly free +\ *** Block No. 1 Hexblock 1 +\ 8086 Assembler loadscreen cas 10nov05 + Onlyforth + +| : u2/ ( 16b -- 15b ) 2/ $7FFF and ; +| : 8* ( 15b -- 16b ) 2* 2* 2* ; +| : 8/ ( 16b -- 13b ) u2/ 2/ 2/ ; + + Vocabulary Assembler + Assembler also definitions + + 3 &21 thru clear .( Assembler loaded ) cr + + + + + +\ *** Block No. 2 Hexblock 2 +\ conditional Assembler compiler cas 10nov05 + here + + : temp-assembler ( addr -- ) hide last off dp ! + " ASSEMBLER" find nip ?exit here $1800 + sp@ u> + IF display cr ." Assembler won't fit" abort THEN + here sp@ $1800 - dp ! 1 load dp ! ; + + temp-assembler \\ + + : blocks ( n -- addr / ff ) + first @ >r dup 0 ?DO freebuffer LOOP + [ b/blk negate ] Literal * first @ + r@ u> r> and ; + + + +\ *** Block No. 3 Hexblock 3 +\ Code generating primitives cas 10nov05 + + Variable >codes \ points at table of execution vectors + +| Create nrc ] c, , here ! c! [ + + : nonrelocate nrc >codes ! ; nonrelocate + +| : >exec ( n -- n+2 ) Create dup c, 2+ + Does> c@ >codes @ + perform ; + +0 | >exec >c, | >exec >, | >exec >here + | >exec >! | >exec >c! drop + + + +\ *** Block No. 4 Hexblock 4 +\ 8086 Registers cas 10nov05 + + 0 Constant A 1 Constant C 2 Constant D 3 Constant R + 4 Constant S 5 Constant U 6 Constant I 7 Constant W +' I Alias SI ' W Alias DI ' R Alias BX + + 8 Constant A- 9 Constant C- $A Constant D- $B Constant R- +$C Constant A+ $D Constant C+ $E Constant D+ $F Constant R+ +' R- Alias B- ' R+ Alias B+ + + $100 Constant E: $101 Constant C: + $102 Constant S: $103 Constant D: + +| Variable isize ( specifies Size by prefix) +| : Size: ( n -- ) Create c, Does> c@ isize ! ; + 0 Size: byte 1 Size: word word 2 Size: far +\ *** Block No. 5 Hexblock 5 +\ 8086 Assembler System variables cas 10nov05 + +| Variable direction \ 0 reg>EA, -1 EA>reg +| Variable size \ 1 word, 0 byte, -1 undefined +| Variable displaced \ 1 direct, 0 nothing, -1 displaced +| Variable displacement + +| : setsize isize @ size ! ; +| : long? ( n -- f ) $FF80 and dup 0< not ?exit $FF80 xor ; +| : wexit rdrop word ; +| : moderr word true Abort" invalid" ; +| : ?moderr ( f -- ) 0=exit moderr ; +| : ?word size @ 1- ?moderr ; +| : far? ( -- f ) size @ 2 = ; + + +\ *** Block No. 6 Hexblock 6 +\ 8086 addressing modes cas 10nov05 + +| Create (EA 7 c, 0 c, 6 c, 4 c, 5 c, +| : () ( 8b1 -- 8b2 ) + 3 - dup 4 u> over 1 = or ?moderr (EA + c@ ; + + -1 Constant # $C6 Constant #) -1 Constant C* + + : ) ( u1 -- u2 ) + () 6 case? IF 0 $86 exit THEN $C0 or ; + : I) ( u1 u2 -- u3 ) + 9 - dup 3 u> ?moderr $C0 or ; + + : D) ( n u1 -- n u2 ) + () over long? IF $40 ELSE $80 THEN or ; + : DI) ( n u1 u2 -- n u3 ) + I) over long? IF $80 ELSE $40 THEN xor ; +\ *** Block No. 7 Hexblock 7 +\ 8086 Registers and addressing modes cas 10nov05 + +| : displaced? ( [n] u1 -- [n] u1 f ) + dup #) = IF 1 exit THEN + dup $C0 and dup $40 = swap $80 = or ; + +| : displace ( [n] u1 -- u1 ) displaced? ?dup 0=exit + displaced @ ?moderr displaced ! swap displacement ! ; + +| : rmode ( u1 -- u2 ) 1 size ! dup 8 and 0=exit + size off $FF07 and ; + +| : mmode? ( 9b - 9b f) dup $C0 and ; + +| : rmode? ( 8b1 - 8b1 f) mmode? $C0 = ; + +\ *** Block No. 8 Hexblock 8 +\ 8086 decoding addressing modes cas 10nov05 + +| : 2address ( [n] source [displ] dest -- 15b / [n] 16b ) + size on displaced off dup # = ?moderr mmode? + IF displace False ELSE rmode True THEN direction ! + >r # case? IF r> $80C0 xor size @ 1+ ?exit setsize exit + THEN direction @ + IF r> 8* >r mmode? IF displace + ELSE dup 8/ 1 and size @ = ?moderr $FF07 and THEN + ELSE rmode 8* + THEN r> or $C0 xor ; + +| : 1address ( [displ] 9b -- 9b ) + # case? ?moderr size on displaced off direction off + mmode? IF displace setsize ELSE rmode THEN $C0 xor ; + +\ *** Block No. 9 Hexblock 9 +\ 8086 assembler cas 10nov05 +| : immediate? ( u -- u f ) dup 0< ; + +| : nonimmediate ( u -- u ) immediate? ?moderr ; + +| : r/m 7 and ; + +| : reg $38 and ; + +| : ?akku ( u -- u ff / tf ) dup r/m 0= dup 0=exit nip ; + +| : smode? ( u1 -- u1 ff / u2 tf ) dup $F00 and + IF dup $100 and IF dup r/m 8* swap reg 8/ + or $C0 or direction off + THEN True exit + THEN False ; +\ *** Block No. 10 Hexblock A +\ 8086 Registers and addressing modes cas 10nov05 + +| : w, size @ or >c, ; + +| : dw, size @ or direction @ IF 2 xor THEN >c, ; + +| : ?word, ( u1 f -- ) IF >, exit THEN >c, ; + +| : direct, displaced @ 0=exit + displacement @ dup long? displaced @ 1+ or ?word, ; + +| : r/m, >c, direct, ; + +| : data, size @ ?word, ; + + +\ *** Block No. 11 Hexblock B +\ 8086 Arithmetic instructions cas 10nov05 + +| : Arith: ( code -- ) Create , + Does> @ >r 2address immediate? + IF rmode? IF ?akku IF r> size @ + IF 5 or >c, >, wexit THEN + 4 or >c, >c, wexit THEN THEN + r@ or $80 size @ or r> 0< + IF size @ IF 2 pick long? 0= IF 2 or size off THEN + THEN THEN >c, >c, direct, data, wexit + THEN r> dw, r/m, wexit ; + + $8000 Arith: add $0008 Arith: or + $8010 Arith: adc $8018 Arith: sbb + $0020 Arith: and $8028 Arith: sub + $0030 Arith: xor $8038 Arith: cmp +\ *** Block No. 12 Hexblock C +\ 8086 move push pop cas 10nov05 + + : mov [ Forth ] 2address immediate? + IF rmode? IF r/m $B0 or size @ IF 8 or THEN + >c, data, wexit + THEN $C6 w, r/m, data, wexit + THEN 6 case? IF $A2 dw, direct, wexit THEN + smode? IF $8C direction @ IF 2 or THEN >c, r/m, wexit + THEN $88 dw, r/m, wexit ; + +| : pupo [ Forth ] >r 1address ?word + smode? IF reg 6 r> IF 1+ THEN or >c, wexit THEN + rmode? IF r/m $50 or r> or >c, wexit THEN + r> IF $8F ELSE $30 or $FF THEN >c, r/m, wexit ; + + : push 0 pupo ; : pop 8 pupo ; +\ *** Block No. 13 Hexblock D +\ 8086 inc & dec , effective addresses cas 10nov05 + +| : inc/dec [ Forth ] >r 1address rmode? + IF size @ IF r/m $40 or r> or >c, wexit THEN + THEN $FE w, r> or r/m, wexit ; + + : dec 8 inc/dec ; : inc 0 inc/dec ; + +| : EA: ( code -- ) Create c, [ Forth ] + Does> >r 2address nonimmediate + rmode? direction @ 0= or ?moderr r> c@ >c, r/m, wexit ; + + $C4 EA: les $8D EA: lea $C5 EA: lds + + + +\ *** Block No. 14 Hexblock E +\ 8086 xchg segment prefix cas 10nov05 + : xchg [ Forth ] 2address nonimmediate rmode? + IF size @ IF dup r/m 0= + IF 8/ true ELSE dup $38 and 0= THEN + IF r/m $90 or >c, wexit THEN + THEN THEN $86 w, r/m, wexit ; + +| : 1addr: ( code -- ) Create c, [ Forth ] + Does> c@ >r 1address $F6 w, r> or r/m, wexit ; + + $10 1addr: com $18 1addr: neg + $20 1addr: mul $28 1addr: imul + $38 1addr: idiv $30 1addr: div + + : seg ( 8b -) [ Forth ] + $100 xor dup $FFFC and ?moderr 8* $26 or >c, ; +\ *** Block No. 15 Hexblock F +\ 8086 test not neg mul imul div idiv cas 10nov05 + + : test [ Forth ] 2address immediate? + IF rmode? IF ?akku IF $A8 w, data, wexit THEN THEN + $F6 w, r/m, data, wexit + THEN $84 w, r/m, wexit ; + +| : in/out [ Forth ] >r 1address setsize + $C2 case? IF $EC r> or w, wexit THEN + 6 - ?moderr $E4 r> or w, displacement @ >c, wexit ; + + : out 2 in/out ; : in 0 in/out ; + + : int 3 case? IF $CC >c, wexit THEN $CD >c, >c, wexit ; + + +\ *** Block No. 16 Hexblock 10 +\ 8086 shifts and string instructions cas 10nov05 + +| : Shifts: ( code -- ) Create c, [ Forth ] + Does> c@ >r C* case? >r 1address + r> direction ! $D0 dw, r> or r/m, wexit ; + + $00 Shifts: rol $08 Shifts: ror + $10 Shifts: rcl $18 Shifts: rcr + $20 Shifts: shl $28 Shifts: shr + $38 Shifts: sar ' shl Alias sal + +| : Str: ( code -- ) Create c, + Does> c@ setsize w, wexit ; + + $A6 Str: cmps $AC Str: lods $A4 Str: movs + $AE Str: scas $AA Str: stos +\ *** Block No. 17 Hexblock 11 +\ implied 8086 instructions cas 10nov05 + + : Byte: ( code -- ) Create c, Does> c@ >c, ; + : Word: ( code -- ) Create , Does> @ >, ; + + $37 Byte: aaa $AD5 Word: aad $AD4 Word: aam + $3F Byte: aas $98 Byte: cbw $F8 Byte: clc + $FC Byte: cld $FA Byte: cli $F5 Byte: cmc + $99 Byte: cwd $27 Byte: daa $2F Byte: das + $F4 Byte: hlt $CE Byte: into $CF Byte: iret + $9F Byte: lahf $F0 Byte: lock $90 Byte: nop + $9D Byte: popf $9C Byte: pushf $9E Byte: sahf + $F9 Byte: stc $FD Byte: std $FB Byte: sti + $9B Byte: wait $D7 Byte: xlat + $C3 Byte: ret $CB Byte: lret + $F2 Byte: rep $F2 Byte: 0<>rep $F3 Byte: 0=rep +\ *** Block No. 18 Hexblock 12 +\ 8086 jmp call conditions cas 10nov05 +| : jmp/call >r setsize # case? [ Forth ] + IF far? IF r> IF $EA ELSE $9A THEN >c, swap >, >, wexit + THEN >here 2+ - r> + IF dup long? 0= IF $EB >c, >c, wexit THEN $E9 + ELSE $E8 THEN >c, 1- >, wexit + THEN 1address $FF >c, $10 or r> + + far? IF 8 or THEN r/m, wexit ; + : call 0 jmp/call ; : jmp $10 jmp/call ; + + $71 Constant OS $73 Constant CS + $75 Constant 0= $77 Constant >= + $79 Constant 0< $7B Constant PE + $7D Constant < $7F Constant <= + $E2 Constant C0= $E0 Constant ?C0= + : not 1 [ Forth ] xor ; +\ *** Block No. 19 Hexblock 13 +\ 8086 conditional branching cas 10nov05 + + : +ret $C2 >c, >, ; + : +lret $CA >c, >, ; + +| : ?range dup long? abort" out of range" ; + + : ?[ >, >here 1- ; + : ]? >here over 1+ - ?range swap >c! ; + : ][ $EB ?[ swap ]? ; + : ?[[ ?[ swap ; + : [[ >here ; + : ?] >c, >here 1+ - ?range >c, ; + : ]] $EB ?] ; + : ]]? ]] ]? ; + +\ *** Block No. 20 Hexblock 14 +\ Next user' end-code ;c: cas 10nov05 + + : Next lods A W xchg W ) jmp + >here next-link @ >, next-link ! ; + + : u' ' >body c@ ; + + Forth definitions + +\needs end-code : end-code toss also ; + + Assembler definitions + + : ;c: recover # call last off end-code 0 ] ; + + +\ *** Block No. 21 Hexblock 15 +\ 8086 Assembler, Forth words cas 10nov05 + Onlyforth + + : Assembler Assembler [ Assembler ] wexit ; + + : ;code 0 ?pairs compile (;code + reveal [compile] [ Assembler ; immediate + + : Code Create [ Assembler ] >here dup 2- >! Assembler ; + + : >label ( addr -- ) + here | Create immediate swap , 4 hallot + here 4 - heap 4 cmove heap last @ (name> ! dp ! + Does> ( -- addr ) @ state @ 0=exit [compile] Literal ; + + : Label [ Assembler ] >here >label Assembler ; +\ *** Block No. 22 Hexblock 16 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/bios.fth b/sources/msdos/bios.fth new file mode 100644 index 0000000..6ecc995 --- /dev/null +++ b/sources/msdos/bios.fth @@ -0,0 +1,153 @@ +\ *** Block No. 0 Hexblock 0 + +This video display interface utilizes the ROM BIOS call $10. +The display is fairly fast and should work on most IBM +compatible computers + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ BIOS display interface ks 1 secas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + Variable dpage dpage off + Variable top top off + + Code (at ( lin col -- ) A pop R push U push + dpage #) R+ mov A- D+ mov 2 # A+ mov $10 int + U pop R pop D pop Next end-code + + Code (at? ( -- lin col ) D push R push U push + dpage #) R+ mov 3 # A+ mov $10 int U pop R pop + D+ A- mov 0 # A+ mov A+ D+ mov A push Next + end-code + + 1 6 +thru .( BIOS display interface active) cr + +\ *** Block No. 2 Hexblock 2 +\ BIOS normal invers blankline ks 1 sep 86 + : full top off ; + + Variable attribut 7 attribut ! + + : normal 7 attribut ! ; : invers $70 attribut ! ; + : underline 1 attribut ! ; : bright $F attribut ! ; + + Code blankline D push R push U push + dpage #) R+ mov attribut #) R- mov + 3 # A+ mov $10 int ' c/row >body #) C mov + D- C- sub bl # A- mov 9 # A+ mov $10 int + U pop R pop D pop Next end-code + +| : lineerase 0 (at blankline ; + +\ *** Block No. 3 Hexblock 3 +\ curshape setpage curat? ks 8 mar 88 + + Code curshape ( top bot -- ) D C mov D pop + D- C+ mov 1 # A+ mov $10 int D pop Next + end-code + + Code setpage ( n -- ) + $503 # A mov D- A- and $10 int D pop Next + end-code + + ' (at? Alias curat? + + + + + +\ *** Block No. 4 Hexblock 4 +\ BIOS (type (emit ks 1 sep 86 + + Code (type ( addr len -- ) W pop R push U push + D U mov dpage #) R+ mov attribut #) R- mov + 3 # A+ mov $10 int U inc C push $E0E # C mov + 1 # A+ mov $10 int 1 # C mov [[ U dec 0= not + ?[[ D- inc ' c/row >body #) D- cmp 0= not + ?[[ W ) A- mov W inc 9 # A+ mov + $10 int 2 # A+ mov $10 int ]]? + ]? C pop 1 # A+ mov $10 int + U pop R pop D pop ' pause #) jmp + end-code + + : (emit ( char -- ) sp@ 1 (type drop ; + + +\ *** Block No. 5 Hexblock 5 +\ BIOS (del scroll (cr (page ks 2 sep 86 + + : (del (at? ?dup + IF 1- 2dup (at bl (emit (at exit THEN drop ; + + Code scroll D push R push U push attribut #) R+ mov + top #) C+ mov 0 # C- mov ' c/row >body #) D- mov + D- dec ' c/col >body #) D+ mov D+ dec D+ dec + $601 # A mov $10 int U pop R pop D pop Next + end-code + + : (cr (at? drop 1+ dup 2+ c/col u> + IF scroll 1- THEN lineerase ; + + : (page top @ c/col 2- DO I lineerase -1 +LOOP ; + +\ *** Block No. 6 Hexblock 6 +\ BIOS status display ks 2 sep 86 + + ' (emit ' display 2 + ! ' (cr ' display 4 + ! + ' (type ' display 6 + ! ' (del ' display 8 + ! + ' (page ' display &10 + ! + ' (at ' display &12 + ! ' (at? ' display &14 + ! + + : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; + : .base base @ decimal dup 2 .r base ! ; + : (.drv ( n -- ) Ascii A + emit ." : " ; + : .dr ." " drv (.drv ; + : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN + @ 5 .r ; + : .space ." Dic" s0 @ here $100 + - 6 u.r ; + + +\ *** Block No. 7 Hexblock 7 +\ statuszeile ks 1 sep 86 + +| : fstat ( n -- ) .base .sp + .space .scr .dr file? 2 spaces order ; + + : .stat attribut @ output @ (at? + display invers c/col 1- 0 (at 4 fstat + blankline (at output ! attribut ! ; + + : +stat ['] .stat Is .status .status ; + + : -stat ['] noop Is .status ; + + + + +\ *** Block No. 8 Hexblock 8 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/bios.vid.src b/sources/msdos/bios.vid.src deleted file mode 100644 index 36b2d48..0000000 --- a/sources/msdos/bios.vid.src +++ /dev/null @@ -1,153 +0,0 @@ -Screen 0 not modified - 0 - 1 This video display interface utilizes the ROM BIOS call $10. - 2 The display is fairly fast and should work on most IBM - 3 compatible computers - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ BIOS display interface ks 1 secas 09jun20 - 1 Onlyforth \needs Assembler 2 loadfrom asm.fb - 2 Variable dpage dpage off - 3 Variable top top off - 4 - 5 Code (at ( lin col -- ) A pop R push U push - 6 dpage #) R+ mov A- D+ mov 2 # A+ mov $10 int - 7 U pop R pop D pop Next end-code - 8 - 9 Code (at? ( -- lin col ) D push R push U push -10 dpage #) R+ mov 3 # A+ mov $10 int U pop R pop -11 D+ A- mov 0 # A+ mov A+ D+ mov A push Next -12 end-code -13 -14 1 6 +thru .( BIOS display interface active) cr -15 -Screen 2 not modified - 0 \ BIOS normal invers blankline ks 1 sep 86 - 1 : full top off ; - 2 - 3 Variable attribut 7 attribut ! - 4 - 5 : normal 7 attribut ! ; : invers $70 attribut ! ; - 6 : underline 1 attribut ! ; : bright $F attribut ! ; - 7 - 8 Code blankline D push R push U push - 9 dpage #) R+ mov attribut #) R- mov -10 3 # A+ mov $10 int ' c/row >body #) C mov -11 D- C- sub bl # A- mov 9 # A+ mov $10 int -12 U pop R pop D pop Next end-code -13 -14 | : lineerase 0 (at blankline ; -15 -Screen 3 not modified - 0 \ curshape setpage curat? ks 8 mar 88 - 1 - 2 Code curshape ( top bot -- ) D C mov D pop - 3 D- C+ mov 1 # A+ mov $10 int D pop Next - 4 end-code - 5 - 6 Code setpage ( n -- ) - 7 $503 # A mov D- A- and $10 int D pop Next - 8 end-code - 9 -10 ' (at? Alias curat? -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ BIOS (type (emit ks 1 sep 86 - 1 - 2 Code (type ( addr len -- ) W pop R push U push - 3 D U mov dpage #) R+ mov attribut #) R- mov - 4 3 # A+ mov $10 int U inc C push $E0E # C mov - 5 1 # A+ mov $10 int 1 # C mov [[ U dec 0= not - 6 ?[[ D- inc ' c/row >body #) D- cmp 0= not - 7 ?[[ W ) A- mov W inc 9 # A+ mov - 8 $10 int 2 # A+ mov $10 int ]]? - 9 ]? C pop 1 # A+ mov $10 int -10 U pop R pop D pop ' pause #) jmp -11 end-code -12 -13 : (emit ( char -- ) sp@ 1 (type drop ; -14 -15 -Screen 5 not modified - 0 \ BIOS (del scroll (cr (page ks 2 sep 86 - 1 - 2 : (del (at? ?dup - 3 IF 1- 2dup (at bl (emit (at exit THEN drop ; - 4 - 5 Code scroll D push R push U push attribut #) R+ mov - 6 top #) C+ mov 0 # C- mov ' c/row >body #) D- mov - 7 D- dec ' c/col >body #) D+ mov D+ dec D+ dec - 8 $601 # A mov $10 int U pop R pop D pop Next - 9 end-code -10 -11 : (cr (at? drop 1+ dup 2+ c/col u> -12 IF scroll 1- THEN lineerase ; -13 -14 : (page top @ c/col 2- DO I lineerase -1 +LOOP ; -15 -Screen 6 not modified - 0 \ BIOS status display ks 2 sep 86 - 1 - 2 ' (emit ' display 2 + ! ' (cr ' display 4 + ! - 3 ' (type ' display 6 + ! ' (del ' display 8 + ! - 4 ' (page ' display &10 + ! - 5 ' (at ' display &12 + ! ' (at? ' display &14 + ! - 6 - 7 : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; - 8 : .base base @ decimal dup 2 .r base ! ; - 9 : (.drv ( n -- ) Ascii A + emit ." : " ; -10 : .dr ." " drv (.drv ; -11 : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN -12 @ 5 .r ; -13 : .space ." Dic" s0 @ here $100 + - 6 u.r ; -14 -15 -Screen 7 not modified - 0 \ statuszeile ks 1 sep 86 - 1 - 2 | : fstat ( n -- ) .base .sp - 3 .space .scr .dr file? 2 spaces order ; - 4 - 5 : .stat attribut @ output @ (at? - 6 display invers c/col 1- 0 (at 4 fstat - 7 blankline (at output ! attribut ! ; - 8 - 9 : +stat ['] .stat Is .status .status ; -10 -11 : -stat ['] noop Is .status ; -12 -13 -14 -15 -Screen 8 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/blocking.fb.src b/sources/msdos/blocking.fb.src deleted file mode 100644 index 4ed777e..0000000 --- a/sources/msdos/blocking.fb.src +++ /dev/null @@ -1,51 +0,0 @@ -Screen 0 not modified - 0 \ cas 11nov05 - 1 Routines to copy physical blocks into files. - 2 - 3 The copy will done from the current file and drive into a new - 4 file created in on the current MS-DOS drive and sub-directory. - 5 So there can be a different drives used in the DIRECT Mode and - 6 in the FILE Mode. - 7 - 8 This command sequence will copy the physical blocks 10-20 on - 9 driver C: into file "TEST.FB" on drive D: in Subdirectory -10 "\VOLKS". -11 -12 -13 KERNEL.FB D: CD \VOLKS -14 DIRECT C: -15 10 20 BLOCKS>FILE TEST.FB -Screen 1 not modified - 0 \ copy physical blocks to file cas 10nov05 - 1 - 2 | File outfile - 3 - 4 : blocks>file ( from to -- ) [ Dos ] - 5 isfile@ -rot outfile make 1+ swap - 6 ?DO I over (block - 7 ds@ swap b/blk isfile@ lfputs - 8 LOOP close isfile ! ; - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/blocking.fth b/sources/msdos/blocking.fth new file mode 100644 index 0000000..96734fb --- /dev/null +++ b/sources/msdos/blocking.fth @@ -0,0 +1,51 @@ +\ *** Block No. 0 Hexblock 0 +\ cas 11nov05 +Routines to copy physical blocks into files. + +The copy will done from the current file and drive into a new +file created in on the current MS-DOS drive and sub-directory. +So there can be a different drives used in the DIRECT Mode and +in the FILE Mode. + +This command sequence will copy the physical blocks 10-20 on +driver C: into file "TEST.FB" on drive D: in Subdirectory +"\VOLKS". + + +KERNEL.FB D: CD \VOLKS +DIRECT C: +10 20 BLOCKS>FILE TEST.FB +\ *** Block No. 1 Hexblock 1 +\ copy physical blocks to file cas 10nov05 + +| File outfile + + : blocks>file ( from to -- ) [ Dos ] + isfile@ -rot outfile make 1+ swap + ?DO I over (block + ds@ swap b/blk isfile@ lfputs + LOOP close isfile ! ; + + + + + + + +\ *** Block No. 2 Hexblock 2 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/ced.fb.src b/sources/msdos/ced.fb.src deleted file mode 100644 index cdcafb1..0000000 --- a/sources/msdos/ced.fb.src +++ /dev/null @@ -1,136 +0,0 @@ -Screen 0 not modified - 0 \ Commandline EDitor for volksFORTH rev. 3.80 cas 10nov05 - 1 This File contains definitions to create an editable Forth - 2 command line with history. - 3 The commandline histroy allows older commands to be recalled. - 4 These older commands will be stored in Screen 0 in a file called - 5 "history" and will be preserved even when calling SAVE-SYSTEM. - 6 - 7 - 8 Keys: - 9 Cursor left/right   -10 Delete Char und <- -11 Delete Line -12 toggle Insert -13 finish line -14 Jump to Beginning/End of Line -15 recall older commands   -Screen 1 not modified - 0 \ Commandline EDitor LOAD-Screen cas 10nov05 - 1 - 2 - 3 : curleft ( -- ) at? 1- at ; - 4 : currite ( -- ) at? 1+ at ; - 5 - 6 1 5 +thru \ enhanced Input - 7 - 8 .( Commandline Editor loaded ) cr - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ History -- Commandhistory cas 10nov05 - 1 makefile history 1 more - 2 - 3 | Variable line# line# off - 4 | Variable lastline# lastline# off - 5 - 6 | : 'history ( n -- addr ) isfile push history - 7 c/l * b/blk /mod block + ; - 8 - 9 | : @line ( n -- addr len ) 'history c/l -trailing ; -10 | : !history ( addr line# -- ) -11 'history dup c/l blank span @ c/l min cmove update ; -12 | : @history ( addr line# -- ) -13 @line rot swap dup span ! cmove ; -14 -15 | : +line ( n addr -- ) dup @ rot + l/s mod swap ! ; -Screen 3 not modified - 0 \ End of input cas 10nov05 - 1 - 2 | Variable maxchars | Variable insert insert on - 3 - 4 | : -text ( a1 a2 l -- 0=equal ) bounds - 5 ?DO count I c@ - ?dup IF nip ENDLOOP exit THEN LOOP 0= ; - 6 - 7 | : done ( a p1 -- a p2 ) 2dup - 8 at? rot - span @ dup maxchars ! + at space blankline - 9 line# @ @line span @ = IF span @ -text 0=exit 2dup THEN -10 drop lastline# @ !history 1 lastline# +line ; -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ enhanced input cas 10nov05 - 1 | : redisplay ( addr pos -- ) - 2 at? 2swap span @ swap /string type blankline at ; - 3 - 4 | : del ( addr pos -- ) span @ 0=exit dup >r + dup 1+ swap - 5 span @ r> - cmove -1 span +! ; - 6 | : ins ( addr pos1 -- ) dup >r + dup dup 1+ - 7 span @ r> - cmove> bl swap c! 1 span +! ; - 8 - 9 | : delete ( a p1 -- a p2 ) 2dup del 2dup redisplay ; -10 | : back ( a p1 -- a p2 ) 1- curleft delete ; -11 -12 | : recall ( a p1 -- a p2 ) at? rot - at dup line# @ @history -13 dup 0 redisplay at? span @ + at span @ ; -14 -15 | : r insert @ IF 2dup ins THEN 2dup + -15 r> swap c! 1+ dup span @ max span ! 2dup redisplay ; -Screen 6 not modified - 0 \ Patch cas 10nov05 - 1 - 2 : showcur ( -- ) - 3 insert @ IF &11 ELSE &6 THEN &12 curshape ; - 4 - 5 : (expect ( addr len -- ) maxchars ! span off - 6 lastline# @ line# ! 0 - 7 BEGIN span @ maxchars @ u< - 8 WHILE key decode showcur REPEAT 2drop ; - 9 -10 ' (decode ' keyboard 6 + ! -11 ' (expect ' keyboard 8 + ! -12 -13 -14 -15 -Screen 7 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/ced.fth b/sources/msdos/ced.fth new file mode 100644 index 0000000..eb8a420 --- /dev/null +++ b/sources/msdos/ced.fth @@ -0,0 +1,136 @@ +\ *** Block No. 0 Hexblock 0 +\ Commandline EDitor for volksFORTH rev. 3.80 cas 10nov05 +This File contains definitions to create an editable Forth +command line with history. +The commandline histroy allows older commands to be recalled. +These older commands will be stored in Screen 0 in a file called +"history" and will be preserved even when calling SAVE-SYSTEM. + + +Keys: + Cursor left/right   + Delete Char und <- + Delete Line + toggle Insert + finish line + Jump to Beginning/End of Line + recall older commands   +\ *** Block No. 1 Hexblock 1 +\ Commandline EDitor LOAD-Screen cas 10nov05 + + +: curleft ( -- ) at? 1- at ; +: currite ( -- ) at? 1+ at ; + +1 5 +thru \ enhanced Input + +.( Commandline Editor loaded ) cr + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ History -- Commandhistory cas 10nov05 +makefile history 1 more + +| Variable line# line# off +| Variable lastline# lastline# off + +| : 'history ( n -- addr ) isfile push history + c/l * b/blk /mod block + ; + +| : @line ( n -- addr len ) 'history c/l -trailing ; +| : !history ( addr line# -- ) + 'history dup c/l blank span @ c/l min cmove update ; +| : @history ( addr line# -- ) + @line rot swap dup span ! cmove ; + +| : +line ( n addr -- ) dup @ rot + l/s mod swap ! ; +\ *** Block No. 3 Hexblock 3 +\ End of input cas 10nov05 + +| Variable maxchars | Variable insert insert on + +| : -text ( a1 a2 l -- 0=equal ) bounds + ?DO count I c@ - ?dup IF nip ENDLOOP exit THEN LOOP 0= ; + +| : done ( a p1 -- a p2 ) 2dup + at? rot - span @ dup maxchars ! + at space blankline + line# @ @line span @ = IF span @ -text 0=exit 2dup THEN + drop lastline# @ !history 1 lastline# +line ; + + + + + +\ *** Block No. 4 Hexblock 4 +\ enhanced input cas 10nov05 +| : redisplay ( addr pos -- ) + at? 2swap span @ swap /string type blankline at ; + +| : del ( addr pos -- ) span @ 0=exit dup >r + dup 1+ swap + span @ r> - cmove -1 span +! ; +| : ins ( addr pos1 -- ) dup >r + dup dup 1+ + span @ r> - cmove> bl swap c! 1 span +! ; + +| : delete ( a p1 -- a p2 ) 2dup del 2dup redisplay ; +| : back ( a p1 -- a p2 ) 1- curleft delete ; + +| : recall ( a p1 -- a p2 ) at? rot - at dup line# @ @history + dup 0 redisplay at? span @ + at span @ ; + +| : r insert @ IF 2dup ins THEN 2dup + + r> swap c! 1+ dup span @ max span ! 2dup redisplay ; +\ *** Block No. 6 Hexblock 6 +\ Patch cas 10nov05 + +: showcur ( -- ) + insert @ IF &11 ELSE &6 THEN &12 curshape ; + +: (expect ( addr len -- ) maxchars ! span off + lastline# @ line# ! 0 + BEGIN span @ maxchars @ u< + WHILE key decode showcur REPEAT 2drop ; + +' (decode ' keyboard 6 + ! +' (expect ' keyboard 8 + ! + + + + +\ *** Block No. 7 Hexblock 7 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/coretest.fth b/sources/msdos/coretest.fth new file mode 100644 index 0000000..a927147 --- /dev/null +++ b/sources/msdos/coretest.fth @@ -0,0 +1,1207 @@ +\ *** Block No. 0 Hexblock 0 +\ From: John Hayes S1I cas 25jun20 +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY + +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE +\ REMAINS +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. + + + + + + +\ *** Block No. 1 Hexblock 1 +\ ANS Core Test cas 25jun20 + + 1 69 +thru cr .( Core Test finished ) + + + + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ ANS Core Test cas 25jun20 + +CR +TESTING CORE WORDS +HEX + +TESTING BASIC ASSUMPTIONS + +T{ -> }T \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T +T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) +T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +T{ -1 BITSSET? -> 0 0 }T + + +\ *** Block No. 3 Hexblock 3 +\ ANS Core Test cas 25jun20 + +TESTING BOOLEANS: INVERT AND OR XOR + +T{ 0 0 AND -> 0 }T +T{ 0 1 AND -> 0 }T +T{ 1 0 AND -> 0 }T +T{ 1 1 AND -> 1 }T + +T{ 0 INVERT 1 AND -> 1 }T +T{ 1 INVERT 1 AND -> 0 }T + + + + + +\ *** Block No. 4 Hexblock 4 +\ ANS Core Test cas 25jun20 + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +T{ 0S INVERT -> 1S }T +T{ 1S INVERT -> 0S }T + +T{ 0S 0S AND -> 0S }T +T{ 0S 1S AND -> 0S }T +T{ 1S 0S AND -> 0S }T +T{ 1S 1S AND -> 1S }T + + + + +\ *** Block No. 5 Hexblock 5 +\ ANS Core Test cas 25jun20 + +T{ 0S 0S OR -> 0S }T +T{ 0S 1S OR -> 1S }T +T{ 1S 0S OR -> 1S }T +T{ 1S 1S OR -> 1S }T + +T{ 0S 0S XOR -> 0S }T +T{ 0S 1S XOR -> 1S }T +T{ 1S 0S XOR -> 1S }T +T{ 1S 1S XOR -> 0S }T + + + + + +\ *** Block No. 6 Hexblock 6 +\ ANS Core Test cas 25jun20 + +TESTING 2* 2/ LSHIFT RSHIFT + +\ WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT +\ LATER +1S 1 RSHIFT INVERT CONSTANT MSB +T{ MSB BITSSET? -> 0 0 }T + +T{ 0S 2* -> 0S }T +T{ 1 2* -> 2 }T +T{ 4000 2* -> 8000 }T +T{ 1S 2* 1 XOR -> 1S }T +T{ MSB 2* -> 0S }T + + +\ *** Block No. 7 Hexblock 7 +\ ANS Core Test cas 25jun20 + +T{ 0S 2/ -> 0S }T +T{ 1 2/ -> 0 }T +T{ 4000 2/ -> 2000 }T +T{ 1S 2/ -> 1S }T \ MSB PROPOGATED +T{ 1S 1 XOR 2/ -> 1S }T +\ TODO T{ MSB 2/ MSB AND -> MSB }T + +T{ 1 0 LSHIFT -> 1 }T +T{ 1 1 LSHIFT -> 2 }T +T{ 1 2 LSHIFT -> 4 }T +T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT +T{ 1S 1 LSHIFT 1 XOR -> 1S }T +\ TODO T{ MSB 1 LSHIFT -> 0 }T + +\ *** Block No. 8 Hexblock 8 +\ ANS Core Test cas 25jun20 + +T{ 1 0 RSHIFT -> 1 }T +T{ 1 1 RSHIFT -> 0 }T +T{ 2 1 RSHIFT -> 1 }T +T{ 4 2 RSHIFT -> 1 }T +T{ 8000 F RSHIFT -> 1 }T \ BIGGEST +\ T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS +\ TODO T{ MSB 1 RSHIFT 2* -> MSB }T + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ ANS Core Test cas 25jun20 + +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX + + +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT +1S CONSTANT + + + +\ *** Block No. 10 Hexblock A +\ ANS Core Test cas 25jun20 +T{ 0 0= -> }T +T{ 1 0= -> }T +T{ 2 0= -> }T +T{ -1 0= -> }T +T{ MAX-UINT 0= -> }T +T{ MIN-INT 0= -> }T +T{ MAX-INT 0= -> }T + +T{ 0 0 = -> }T +T{ 1 1 = -> }T +T{ -1 -1 = -> }T +T{ 1 0 = -> }T +T{ -1 0 = -> }T +T{ 0 1 = -> }T +T{ 0 -1 = -> }T +\ *** Block No. 11 Hexblock B +\ ANS Core Test cas 25jun20 + +T{ 0 0< -> }T +T{ -1 0< -> }T +T{ MIN-INT 0< -> }T +T{ 1 0< -> }T +T{ MAX-INT 0< -> }T + + + + + + + + + +\ *** Block No. 12 Hexblock C +\ ANS Core Test cas 25jun20 + +T{ 0 1 < -> }T T{ 1 2 < -> }T +T{ -1 0 < -> }T T{ -1 1 < -> }T +T{ MIN-INT 0 < -> }T T{ MIN-INT MAX-INT < -> }T +T{ 0 MAX-INT < -> }T T{ 0 0 < -> }T +T{ 1 1 < -> }T T{ 1 0 < -> }T +T{ 2 1 < -> }T T{ 0 -1 < -> }T +T{ 1 -1 < -> }T T{ 0 MIN-INT < -> }T + +T{ MAX-INT MIN-INT < -> }T +T{ MAX-INT 0 < -> }T + + + + +\ *** Block No. 13 Hexblock D +\ ANS Core Test cas 25jun20 + +T{ 0 1 > -> }T T{ 1 2 > -> }T +T{ -1 0 > -> }T T{ -1 1 > -> }T +T{ MIN-INT 0 > -> }T +T{ MIN-INT MAX-INT > -> }T +T{ 0 MAX-INT > -> }T T{ 0 0 > -> }T +T{ 1 1 > -> }T T{ 1 0 > -> }T +T{ 2 1 > -> }T T{ 0 -1 > -> }T +T{ 1 -1 > -> }T T{ 0 MIN-INT > -> }T +T{ MAX-INT MIN-INT > -> }T +T{ MAX-INT 0 > -> }T + + + + +\ *** Block No. 14 Hexblock E +\ ANS Core Test cas 25jun20 + +T{ 0 1 U< -> }T +T{ 1 2 U< -> }T +T{ 0 MID-UINT U< -> }T +T{ 0 MAX-UINT U< -> }T +T{ MID-UINT MAX-UINT U< -> }T +T{ 0 0 U< -> }T +T{ 1 1 U< -> }T +T{ 1 0 U< -> }T +T{ 2 1 U< -> }T +T{ MID-UINT 0 U< -> }T +T{ MAX-UINT 0 U< -> }T +T{ MAX-UINT MID-UINT U< -> }T + + +\ *** Block No. 15 Hexblock F +\ ANS Core Test cas 25jun20 + +T{ 0 1 MIN -> 0 }T T{ 1 2 MIN -> 1 }T +T{ -1 0 MIN -> -1 }T T{ -1 1 MIN -> -1 }T +T{ MIN-INT 0 MIN -> MIN-INT }T +T{ MIN-INT MAX-INT MIN -> MIN-INT }T +T{ 0 MAX-INT MIN -> 0 }T +T{ 0 0 MIN -> 0 }T T{ 1 1 MIN -> 1 }T +T{ 1 0 MIN -> 0 }T T{ 2 1 MIN -> 1 }T +T{ 0 -1 MIN -> -1 }T T{ 1 -1 MIN -> -1 }T + +T{ 0 MIN-INT MIN -> MIN-INT }T +T{ MAX-INT MIN-INT MIN -> MIN-INT }T +T{ MAX-INT 0 MIN -> 0 }T + + +\ *** Block No. 16 Hexblock 10 +\ ANS Core Test cas 25jun20 + +T{ 0 1 MAX -> 1 }T T{ 1 2 MAX -> 2 }T +T{ -1 0 MAX -> 0 }T T{ -1 1 MAX -> 1 }T +T{ MIN-INT 0 MAX -> 0 }T +T{ MIN-INT MAX-INT MAX -> MAX-INT }T +T{ 0 MAX-INT MAX -> MAX-INT }T +T{ 0 0 MAX -> 0 }T T{ 1 1 MAX -> 1 }T +T{ 1 0 MAX -> 1 }T T{ 2 1 MAX -> 2 }T +T{ 0 -1 MAX -> 0 }T T{ 1 -1 MAX -> 1 }T +T{ 0 MIN-INT MAX -> 0 }T +T{ MAX-INT MIN-INT MAX -> MAX-INT }T +T{ MAX-INT 0 MAX -> MAX-INT }T + + + +\ *** Block No. 17 Hexblock 11 +\ ANS Core Test cas 25jun20 + +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP +OVER ROT SWAP + +T{ 1 2 2DROP -> }T +T{ 1 2 2DUP -> 1 2 1 2 }T +T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T +T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T +T{ 0 ?DUP -> 0 }T T{ 1 ?DUP -> 1 1 }T +T{ -1 ?DUP -> -1 -1 }T T{ DEPTH -> 0 }T +T{ 0 DEPTH -> 0 1 }T T{ 0 1 DEPTH -> 0 1 2 }T +T{ 0 DROP -> }T T{ 1 2 DROP -> 1 }T +T{ 1 DUP -> 1 1 }T T{ 1 2 OVER -> 1 2 1 }T +T{ 1 2 3 ROT -> 2 3 1 }T T{ 1 2 SWAP -> 2 1 }T + +\ *** Block No. 18 Hexblock 12 +\ ANS Core Test cas 25jun20 + +TESTING >R R> R@ + +T{ : GR1 >R R> ; -> }T +T{ : GR2 >R R@ R> DROP ; -> }T +T{ 123 GR1 -> 123 }T +T{ 123 GR2 -> 123 }T +T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) + + + + + + + +\ *** Block No. 19 Hexblock 13 +\ ANS Core Test cas 25jun20 + +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +T{ 0 5 + -> 5 }T T{ 5 0 + -> 5 }T +T{ 0 -5 + -> -5 }T T{ -5 0 + -> -5 }T +T{ 1 2 + -> 3 }T T{ 1 -2 + -> -1 }T +T{ -1 2 + -> 1 }T T{ -1 -2 + -> -3 }T +T{ -1 1 + -> 0 }T +T{ MID-UINT 1 + -> MID-UINT+1 }T + + + + + + +\ *** Block No. 20 Hexblock 14 +\ ANS Core Test cas 25jun20 + +T{ 0 5 - -> -5 }T T{ 5 0 - -> 5 }T +T{ 0 -5 - -> 5 }T T{ -5 0 - -> -5 }T +T{ 1 2 - -> -1 }T T{ 1 -2 - -> 3 }T +T{ -1 2 - -> -3 }T T{ -1 -2 - -> 1 }T +T{ 0 1 - -> -1 }T +T{ MID-UINT+1 1 - -> MID-UINT }T +T{ 0 1+ -> 1 }T +T{ -1 1+ -> 0 }T +T{ 1 1+ -> 2 }T +T{ MID-UINT 1+ -> MID-UINT+1 }T + + + + +\ *** Block No. 21 Hexblock 15 +\ ANS Core Test cas 25jun20 + +T{ 2 1- -> 1 }T T{ 1 1- -> 0 }T +T{ 0 1- -> -1 }T +T{ MID-UINT+1 1- -> MID-UINT }T + +T{ 0 NEGATE -> 0 }T T{ 1 NEGATE -> -1 }T +T{ -1 NEGATE -> 1 }T T{ 2 NEGATE -> -2 }T +T{ -2 NEGATE -> 2 }T + +T{ 0 ABS -> 0 }T T{ 1 ABS -> 1 }T +T{ -1 ABS -> 1 }T +T{ MIN-INT ABS -> MID-UINT+1 }T + + + +\ *** Block No. 22 Hexblock 16 +\ ANS Core Test cas 25jun20 + +TESTING MULTIPLY: S>D * M* UM* + +T{ 0 S>D -> 0 0 }T T{ 1 S>D -> 1 0 }T +T{ 2 S>D -> 2 0 }T T{ -1 S>D -> -1 -1 }T +T{ -2 S>D -> -2 -1 }T +T{ MIN-INT S>D -> MIN-INT -1 }T +T{ MAX-INT S>D -> MAX-INT 0 }T + + + + + + + +\ *** Block No. 23 Hexblock 17 +\ ANS Core Test cas 25jun20 + +T{ 0 0 M* -> 0 S>D }T T{ 0 1 M* -> 0 S>D }T +T{ 1 0 M* -> 0 S>D }T T{ 1 2 M* -> 2 S>D }T +T{ 2 1 M* -> 2 S>D }T T{ 3 3 M* -> 9 S>D }T +T{ -3 3 M* -> -9 S>D }T T{ 3 -3 M* -> -9 S>D }T +T{ -3 -3 M* -> 9 S>D }T T{ 0 MIN-INT M* -> 0 S>D }T +T{ 1 MIN-INT M* -> MIN-INT S>D }T +T{ 2 MIN-INT M* -> 0 1S }T T{ 0 MAX-INT M* -> 0 S>D }T +T{ 1 MAX-INT M* -> MAX-INT S>D }T +T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T +T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T +T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T +T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T + + +\ *** Block No. 24 Hexblock 18 +\ ANS Core Test cas 25jun20 + +T{ 0 0 * -> 0 }T \ TEST IDENTITIES +T{ 0 1 * -> 0 }T +T{ 1 0 * -> 0 }T +T{ 1 2 * -> 2 }T +T{ 2 1 * -> 2 }T +T{ 3 3 * -> 9 }T +T{ -3 3 * -> -9 }T +T{ 3 -3 * -> -9 }T +T{ -3 -3 * -> 9 }T + + + + + +\ *** Block No. 25 Hexblock 19 +\ ANS Core Test cas 25jun20 + +T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T +T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T +T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T + +T{ 0 0 UM* -> 0 0 }T T{ 0 1 UM* -> 0 0 }T +T{ 1 0 UM* -> 0 0 }T T{ 1 2 UM* -> 2 0 }T +T{ 2 1 UM* -> 2 0 }T T{ 3 3 UM* -> 9 0 }T + +T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T +T{ MID-UINT+1 2 UM* -> 0 1 }T +T{ MID-UINT+1 4 UM* -> 0 2 }T +T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T +T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T + +\ *** Block No. 26 Hexblock 1A +\ ANS Core Test cas 25jun20 + +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +T{ 0 S>D 1 FM/MOD -> 0 0 }T T{ 1 S>D 1 FM/MOD -> 0 1 }T +T{ 2 S>D 1 FM/MOD -> 0 2 }T T{ -1 S>D 1 FM/MOD -> 0 -1 }T +T{ -2 S>D 1 FM/MOD -> 0 -2 }T T{ 0 S>D -1 FM/MOD -> 0 0 }T +T{ 1 S>D -1 FM/MOD -> 0 -1 }T T{ 2 S>D -1 FM/MOD -> 0 -2 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T T{ -2 S>D -1 FM/MOD -> 0 2 }T +T{ 2 S>D 2 FM/MOD -> 0 1 }T T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -2 FM/MOD -> 0 1 }T T{ 7 S>D 3 FM/MOD -> 1 2 }T +T{ 7 S>D -3 FM/MOD -> -2 -3 }T T{ -7 S>D 3 FM/MOD -> 2 -3 }T +T{ -7 S>D -3 FM/MOD -> -1 2 }T + + + +\ *** Block No. 27 Hexblock 1B +\ ANS Core Test cas 25jun20 + +T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T +T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T +T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T +T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T +T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T +T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T +T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T +T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T +T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T +T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T + +\ *** Block No. 28 Hexblock 1C +\ ANS Core Test cas 25jun20 + +T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T + +T{ 0 S>D 1 SM/REM -> 0 0 }T T{ 1 S>D 1 SM/REM -> 0 1 }T +T{ 2 S>D 1 SM/REM -> 0 2 }T T{ -1 S>D 1 SM/REM -> 0 -1 }T +T{ -2 S>D 1 SM/REM -> 0 -2 }T T{ 0 S>D -1 SM/REM -> 0 0 }T +T{ 1 S>D -1 SM/REM -> 0 -1 }T T{ 2 S>D -1 SM/REM -> 0 -2 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T T{ -2 S>D -1 SM/REM -> 0 2 }T +T{ 2 S>D 2 SM/REM -> 0 1 }T T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -2 SM/REM -> 0 1 }T T{ 7 S>D 3 SM/REM -> 1 2 }T +T{ 7 S>D -3 SM/REM -> 1 -2 }T +T{ -7 S>D 3 SM/REM -> -1 -2 }T T{ -7 S>D -3 SM/REM -> -1 2 }T +\ *** Block No. 29 Hexblock 1D +\ ANS Core Test cas 25jun20 + +T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T +T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T +T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T +T{ 1S 1 4 SM/REM -> 3 MAX-INT }T +T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T +T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T + +\ *** Block No. 30 Hexblock 1E +\ ANS Core Test cas 25jun20 + +T{ 0 0 1 UM/MOD -> 0 0 }T T{ 1 0 1 UM/MOD -> 0 1 }T +T{ 1 0 2 UM/MOD -> 1 0 }T T{ 3 0 2 UM/MOD -> 1 1 }T +T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T +T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T +T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T + + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + + +\ *** Block No. 31 Hexblock 1F +\ ANS Core Test cas 25jun20 + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN +\ USE THEM IN TEST. + +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; +\ *** Block No. 32 Hexblock 20 +\ ANS Core Test cas 25jun20 + +T{ 0 1 /MOD -> 0 1 T/MOD }T T{ 1 1 /MOD -> 1 1 T/MOD }T +T{ 2 1 /MOD -> 2 1 T/MOD }T T{ -1 1 /MOD -> -1 1 T/MOD }T +T{ -2 1 /MOD -> -2 1 T/MOD }T T{ 0 -1 /MOD -> 0 -1 T/MOD }T +T{ 1 -1 /MOD -> 1 -1 T/MOD }T T{ 2 -1 /MOD -> 2 -1 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T T{ -2 -1 /MOD -> -2 -1 T/MOD }T +T{ 2 2 /MOD -> 2 2 T/MOD }T T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -2 /MOD -> -2 -2 T/MOD }T T{ 7 3 /MOD -> 7 3 T/MOD }T +T{ 7 -3 /MOD -> 7 -3 T/MOD }T T{ -7 3 /MOD -> -7 3 T/MOD }T +T{ -7 -3 /MOD -> -7 -3 T/MOD }T +T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T +T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T +T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T +T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T + +\ *** Block No. 33 Hexblock 21 +\ ANS Core Test cas 25jun20 + +T{ 0 1 / -> 0 1 T/ }T T{ 1 1 / -> 1 1 T/ }T +T{ 2 1 / -> 2 1 T/ }T T{ -1 1 / -> -1 1 T/ }T +T{ -2 1 / -> -2 1 T/ }T T{ 0 -1 / -> 0 -1 T/ }T +T{ 1 -1 / -> 1 -1 T/ }T T{ 2 -1 / -> 2 -1 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T T{ -2 -1 / -> -2 -1 T/ }T +T{ 2 2 / -> 2 2 T/ }T T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -2 / -> -2 -2 T/ }T T{ 7 3 / -> 7 3 T/ }T +T{ 7 -3 / -> 7 -3 T/ }T T{ -7 3 / -> -7 3 T/ }T +T{ -7 -3 / -> -7 -3 T/ }T +T{ MAX-INT 1 / -> MAX-INT 1 T/ }T +T{ MIN-INT 1 / -> MIN-INT 1 T/ }T +T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T +T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T + +\ *** Block No. 34 Hexblock 22 +\ ANS Core Test cas 25jun20 + +T{ 0 1 MOD -> 0 1 TMOD }T T{ 1 1 MOD -> 1 1 TMOD }T +T{ 2 1 MOD -> 2 1 TMOD }T T{ -1 1 MOD -> -1 1 TMOD }T +T{ -2 1 MOD -> -2 1 TMOD }T T{ 0 -1 MOD -> 0 -1 TMOD }T +T{ 1 -1 MOD -> 1 -1 TMOD }T T{ 2 -1 MOD -> 2 -1 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T T{ -2 -1 MOD -> -2 -1 TMOD }T +T{ 2 2 MOD -> 2 2 TMOD }T T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -2 MOD -> -2 -2 TMOD }T T{ 7 3 MOD -> 7 3 TMOD }T +T{ 7 -3 MOD -> 7 -3 TMOD }T T{ -7 3 MOD -> -7 3 TMOD }T +T{ -7 -3 MOD -> -7 -3 TMOD }T +T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T +T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T +T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T +T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T + +\ *** Block No. 35 Hexblock 23 +\ ANS Core Test cas 25jun20 + +T{ 0 2 1 */ -> 0 2 1 T*/ }T T{ 1 2 1 */ -> 1 2 1 T*/ }T +T{ 2 2 1 */ -> 2 2 1 T*/ }T T{ -1 2 1 */ -> -1 2 1 T*/ }T +T{ -2 2 1 */ -> -2 2 1 T*/ }T T{ 0 2 -1 */ -> 0 2 -1 T*/ }T +T{ 1 2 -1 */ -> 1 2 -1 T*/ }T T{ 2 2 -1 */ -> 2 2 -1 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T T{ -2 2 -1 */ -> -2 2 -1 T*/ }T +T{ 2 2 2 */ -> 2 2 2 T*/ }T T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -2 */ -> -2 2 -2 T*/ }T T{ 7 2 3 */ -> 7 2 3 T*/ }T +T{ 7 2 -3 */ -> 7 2 -3 T*/ }T T{ -7 2 3 */ -> -7 2 3 T*/ }T +T{ -7 2 -3 */ -> -7 2 -3 T*/ }T + +T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T +T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T + + +\ *** Block No. 36 Hexblock 24 +\ ANS Core Test cas 25jun20 + +T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T +T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T +T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T +T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T +T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T +T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T +T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T +T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T +T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T + +\ *** Block No. 37 Hexblock 25 +\ ANS Core Test cas 25jun20 + +T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T +T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T +T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T +T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T +T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T +T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T + + + + + + + + +\ *** Block No. 38 Hexblock 26 +\ ANS Core Test cas 25jun20 + +ESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED + +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT +( MISSING TEST: NEGATIVE ALLOT ) + + + + +\ *** Block No. 39 Hexblock 27 +\ ANS Core Test cas 25jun20 + +\ Added by GWJ so that ALIGN can be used before , (comma) is +\ tested +1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit align +ment +ALIGN +T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> }T +\ End of extra test + + + + + + + +\ *** Block No. 40 Hexblock 28 +\ ANS Core Test cas 25jun20 + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL + +T{ 1ST 1 CELLS + -> 2ND }T T{ 1ST @ 2ND @ -> 1 2 }T +T{ 5 1ST ! -> }T T{ 1ST @ 2ND @ -> 5 2 }T +T{ 6 2ND ! -> }T T{ 1ST @ 2ND @ -> 5 6 }T +T{ 1ST 2@ -> 6 5 }T T{ 2 1 1ST 2! -> }T +T{ 1ST 2@ -> 2 1 }T +T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE + +\ *** Block No. 41 Hexblock 29 +\ ANS Core Test cas 25jun20 + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR +T{ 1STC 1 CHARS + -> 2NDC }T T{ 1STC C@ 2NDC C@ -> 1 2 }T +T{ 3 1STC C! -> }T T{ 1STC C@ 2NDC C@ -> 3 2 }T +T{ 4 2NDC C! -> }T T{ 1STC C@ 2NDC C@ -> 3 4 }T + + + + + +\ *** Block No. 42 Hexblock 2A +\ ANS Core Test cas 25jun20 +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +T{ UA-ADDR ALIGNED -> A-ADDR }T +T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T +T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T +T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T +T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T +T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T +T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T +T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T + + + + + +\ *** Block No. 43 Hexblock 2B +\ ANS Core Test cas 25jun20 + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT + DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +T{ 1 CHARS 1 < -> }T +T{ 1 CHARS 1 CELLS > -> }T +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +T{ 1 CELLS 1 < -> }T +T{ 1 CELLS 1 CHARS MOD -> 0 }T +T{ 1S BITS 10 < -> }T + + +\ *** Block No. 44 Hexblock 2C +\ ANS Core Test cas 25jun20 + +T{ 0 1ST ! -> }T +T{ 1 1ST +! -> }T +T{ 1ST @ -> 1 }T +T{ -1 1ST +! 1ST @ -> 0 }T + + + + + + + + + + +\ *** Block No. 45 Hexblock 2D +\ ANS Core Test cas 25jun20 + +TESTING CHAR [CHAR] [ ] BL S" + +T{ BL -> 20 }T T{ CHAR X -> 58 }T +T{ CHAR HELLO -> 48 }T T{ : GC1 [CHAR] X ; -> }T +T{ : GC2 [CHAR] HELLO ; -> }T T{ GC1 -> 58 }T +T{ GC2 -> 48 }T +T{ : GC3 [ GC1 ] LITERAL ; -> }T +T{ GC3 -> 58 }T +T{ : GC4 S" XY" ; -> }T +T{ GC4 SWAP DROP -> 2 }T +T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T + + + +\ *** Block No. 46 Hexblock 2E +\ ANS Core Test cas 25jun20 + +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE + STATE + +T{ : GT1 123 ; -> }T T{ ' GT1 EXECUTE -> 123 }T +T{ : GT2 ['] GT1 ; IMMEDIATE -> }T +T{ GT2 EXECUTE -> 123 }T +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +T{ GT1STRING FIND -> ' GT1 -1 }T +T{ GT2STRING FIND -> ' GT2 1 }T +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +T{ : GT3 GT2 LITERAL ; -> }T +T{ GT3 -> ' GT1 }T +T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T +\ *** Block No. 47 Hexblock 2F +\ ANS Core Test cas 25jun20 + +T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T +T{ : GT5 GT4 ; -> }T T{ GT5 -> 123 }T +T{ : GT6 345 ; IMMEDIATE -> }T T{ : GT7 POSTPONE GT6 ; -> }T +T{ GT7 -> 345 }T + +T{ : GT8 STATE @ ; IMMEDIATE -> }T +T{ GT8 -> 0 }T +T{ : GT9 GT8 LITERAL ; -> }T +T{ GT9 0= -> }T + + + + + +\ *** Block No. 48 Hexblock 30 +\ ANS Core Test cas 25jun20 + +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +T{ : GI1 IF 123 THEN ; -> }T +T{ : GI2 IF 123 ELSE 234 THEN ; -> }T +T{ 0 GI1 -> }T T{ 1 GI1 -> 123 }T +T{ -1 GI1 -> 123 }T T{ 0 GI2 -> 234 }T +T{ 1 GI2 -> 123 }T T{ -1 GI1 -> 123 }T + +T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T +T{ 0 GI3 -> 0 1 2 3 4 5 }T +T{ 4 GI3 -> 4 5 }T T{ 5 GI3 -> 5 }T +T{ 6 GI3 -> 6 }T + + +\ *** Block No. 49 Hexblock 31 +\ ANS Core Test cas 25jun20 + +T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T +T{ 3 GI4 -> 3 4 5 6 }T T{ 5 GI4 -> 5 6 }T +T{ 6 GI4 -> 6 7 }T +T{ : GI5 BEGIN DUP 2 > + WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T + +T{ 1 GI5 -> 1 345 }T T{ 2 GI5 -> 2 345 }T +T{ 3 GI5 -> 3 4 5 123 }T T{ 4 GI5 -> 4 5 123 }T +T{ 5 GI5 -> 5 123 }T +T{ : GI6 ( N -- 0,1,..N ) + DUP IF DUP >R 1- RECURSE R> THEN ; -> }T +T{ 0 GI6 -> 0 }T T{ 1 GI6 -> 0 1 }T +T{ 2 GI6 -> 0 1 2 }T T{ 3 GI6 -> 0 1 2 3 }T +T{ 4 GI6 -> 0 1 2 3 4 }T +\ *** Block No. 50 Hexblock 32 +\ ANS Core Test cas 25jun20 + +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +T{ : GD1 DO I LOOP ; -> }T T{ 4 1 GD1 -> 1 2 3 }T +T{ 2 -1 GD1 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T +T{ : GD2 DO I -1 +LOOP ; -> }T +T{ 1 4 GD2 -> 4 3 2 1 }T T{ -1 2 GD2 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T +T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T +T{ 4 1 GD3 -> 1 2 3 }T T{ 2 -1 GD3 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T + + + +\ *** Block No. 51 Hexblock 33 +\ ANS Core Test cas 25jun20 + +T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T +T{ 1 4 GD4 -> 4 3 2 1 }T T{ -1 2 GD4 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T +T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T + +T{ 1 GD5 -> 123 }T T{ 5 GD5 -> 123 }T +T{ 6 GD5 -> 234 }T + +T{ : GD6 +( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> }T T{ 1 GD6 -> 1 }T +T{ 2 GD6 -> 3 }T T{ 3 GD6 -> 4 1 2 }T +\ *** Block No. 52 Hexblock 34 +\ ANS Core Test cas 25jun20 + +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +T{ 123 CONSTANT X123 -> }T T{ X123 -> 123 }T +T{ : EQU CONSTANT ; -> }T T{ X123 EQU Y123 -> }T +T{ Y123 -> 123 }T + +T{ VARIABLE V1 -> }T T{ 123 V1 ! -> }T +T{ V1 @ -> 123 }T + +T{ : NOP : POSTPONE ; ; -> }T T{ NOP NOP1 NOP NOP2 -> }T +T{ NOP1 -> }T T{ NOP2 -> }T + + + +\ *** Block No. 53 Hexblock 35 +\ ANS Core Test cas 25jun20 + +T{ : DOES1 DOES> @ 1 + ; -> }T T{ : DOES2 DOES> @ 2 + ; -> }T +T{ CREATE CR1 -> }T T{ CR1 -> HERE }T +T{ ' CR1 >BODY -> HERE }T T{ 1 , -> }T +T{ CR1 @ -> 1 }T T{ DOES1 -> }T +T{ CR1 -> 2 }T T{ DOES2 -> }T +T{ CR1 -> 3 }T + +T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T +T{ WEIRD: W1 -> }T T{ ' W1 >BODY -> HERE }T +T{ W1 -> HERE 1 + }T T{ W1 -> HERE 2 + }T + + + + +\ *** Block No. 54 Hexblock 36 +\ ANS Core Test cas 25jun20 + +TESTING EVALUATE + +: GE1 S" 123" ; IMMEDIATE : GE2 S" 123 1+" ; IMMEDIATE +: GE3 S" : GE4 345 ;" ; : GE5 EVALUATE ; IMMEDIATE +T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) +T{ GE2 EVALUATE -> 124 }T T{ GE3 EVALUATE -> }T +T{ GE4 -> 345 }T +T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) +T{ GE6 -> 123 }T +T{ : GE7 GE2 GE5 ; -> }T +T{ GE7 -> 124 }T + + + +\ *** Block No. 55 Hexblock 37 +\ ANS Core Test cas 25jun20 + +TESTING SOURCE >IN WORD + +: GS1 S" SOURCE" 2DUP EVALUATE + >R SWAP >R = R> R> = ; +T{ GS1 -> }T + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +T{ 2 SCANS ! +345 RESCAN? +-> 345 345 }T + + +\ *** Block No. 56 Hexblock 38 +\ ANS Core Test cas 25jun20 + +: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +T{ GS2 -> 123 123 123 123 123 }T + +: GS3 WORD COUNT SWAP C@ ; +T{ BL GS3 HELLO -> 5 CHAR H }T +T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T +T{ BL GS3 +DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +T{ GS4 123 456 +-> }T + + +\ *** Block No. 57 Hexblock 39 +\ ANS Core Test cas 25jun20 + +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; +\ *** Block No. 58 Hexblock 3A +\ ANS Core Test cas 25jun20 + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +T{ GP1 -> }T + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +T{ GP2 -> }T + +: GP3 <# 1 0 # # #> S" 01" S= ; +T{ GP3 -> }T + +: GP4 <# 1 0 #S #> S" 1" S= ; +T{ GP4 -> }T + + + +\ *** Block No. 59 Hexblock 3B +\ ANS Core Test cas 25jun20 + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +T{ GP5 -> }T + +\ *** Block No. 60 Hexblock 3C +\ ANS Core Test cas 25jun20 + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +T{ GP6 -> }T + + + + +\ *** Block No. 61 Hexblock 3D +\ ANS Core Test cas 25jun20 + +: GP7 + BASE @ >R MAX-BASE BASE ! + + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND + LOOP + R> BASE ! ; + +T{ GP7 -> }T +\ *** Block No. 62 Hexblock 3E +\ ANS Core Test cas 25jun20 + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T +T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T +T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T + +T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO + \ CONVERT THESE +T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T +T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T +\ *** Block No. 63 Hexblock 3F +\ ANS Core Test cas 25jun20 + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; +T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T +T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T +T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T +T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T + + + + + + +\ *** Block No. 64 Hexblock 40 +\ ANS Core Test cas 25jun20 +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND +\ LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +T{ 0 0 2 GN1 -> 0 0 0 }T +T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T +T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T +T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +T{ GN2 -> 10 A }T +\ *** Block No. 65 Hexblock 41 +\ ANS Core Test cas 25jun20 +TESTING FILL MOVE +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; +T{ FBUF 0 20 FILL -> }T T{ SEEBUF -> 00 00 00 }T +T{ FBUF 1 20 FILL -> }T T{ SEEBUF -> 20 00 00 }T +T{ FBUF 3 20 FILL -> }T T{ SEEBUF -> 20 20 20 }T +T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE +T{ SEEBUF -> 20 20 20 }T +T{ SBUF FBUF 0 CHARS MOVE -> }T T{ SEEBUF -> 20 20 20 }T +T{ SBUF FBUF 1 CHARS MOVE -> }T T{ SEEBUF -> 12 20 20 }T +T{ SBUF FBUF 3 CHARS MOVE -> }T T{ SEEBUF -> 12 34 56 }T +T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 12 34 }T +T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T T{ SEEBUF -> 12 34 34 }T +\ *** Block No. 66 Hexblock 42 +\ ANS Core Test cas 25jun20 + +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR +\ *** Block No. 67 Hexblock 43 +\ ANS Core Test cas 25jun20 + + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NU +MBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +T{ OUTPUT-TEST -> }T + + + + + +\ *** Block No. 68 Hexblock 44 +\ ANS Core Test cas 25jun20 + +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +T{ ACCEPT-TEST -> }T + + +\ *** Block No. 69 Hexblock 45 +\ ANS Core Test cas 25jun20 + +TESTING DICTIONARY SEARCH RULES + +T{ : GDX 123 ; : GDX GDX 234 ; -> }T + +T{ GDX -> 123 234 }T + +CR .( End of Core word set tests) CR + + + + + + + +\ *** Block No. 70 Hexblock 46 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/disasm.fb.src b/sources/msdos/disasm.fb.src deleted file mode 100644 index 30f1914..0000000 --- a/sources/msdos/disasm.fb.src +++ /dev/null @@ -1,748 +0,0 @@ -Screen 0 not modified - 0 \ - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ A disassembler for the 8086 by Charles Curley cas 10nov05 - 1 \ adapted to volksFORTH-83 by B. Molte - 2 - 3 | : internal 1 ?head ! ; - 4 | : external ?head off ; - 5 - 6 onlyFORTH forth DEFINITIONS DECIMAL - 7 - 8 VOCABULARY DISAM DISAM also DEFINITIONS - 9 -10 2 capacity 1- thru -11 onlyforth -12 -13 cr .( Use DIS to disassemble word. ) -14 cr .( ESC will stop the output. ) -15 -Screen 2 not modified - 0 \ cas 10nov05 - 1 - 2 internal - 3 - 4 : [and] and ; \ the forth and - 5 : [or] or ; - 6 - 7 : mask ( n maskb -- n n' ) over and ; - 8 - 9 5 constant 5 \ save some space -10 6 constant 6 -11 7 constant 7 -12 8 constant 8 -13 -14 -15 -Screen 3 not modified - 0 \ - 1 internal - 2 - 3 : EXEC [and] 2* R> + PERFORM ; - 4 - 5 : STOP[ - 6 0 ?pairs [compile] [ reveal ; immediate restrict - 7 - 8 code shift> \ n ct --- n' | shift n right ct times - 9 D C mov D pop D C* shr next end-code -10 \ : shift> 0 ?DO 2/ ( shift's artihm.!) $7FFF and LOOP ; -11 -12 code SEXT \ n --- n' | sign extend lower half of n to upper -13 D A mov cbw A D mov next end-code -14 \ : hsext $FF and dup $80 and IF $FF00 or THEN ; -15 -Screen 4 not modified - 0 \ - 1 external - 2 VARIABLE RELOC 0 , ds@ 0 RELOC 2! \ keeps relocation factor - 3 internal - 4 - 5 VARIABLE CP - 6 VARIABLE OPS \ operand count - 7 - 8 : cp@ cp @ ; - 9 : C? C@ . ; -10 -11 : (T@) RELOC 2@ ROT + L@ ; \ in first word, seg in 2nd. You -12 \ dump/dis any segment w/ any -13 : (TC@) RELOC 2@ ROT + LC@ ; \ relocation you want by setting -14 \ RELOC correctly. -15 : SETSEG RELOC 2+ ! ; -Screen 5 not modified - 0 \ - 1 external - 2 - 3 DEFER T@ DEFER TC@ - 4 - 5 : HOMESEG ds@ SETSEG ; HOMESEG - 6 - 7 : SEG? RELOC 2+ @ 4 U.r ; - 8 - 9 : .seg:off seg? ." :" cp@ 4 u.r 2 spaces ; -10 -11 : MEMORY ['] (TC@) IS TC@ ['] (T@) IS T@ ; MEMORY -12 -13 -14 -15 -Screen 6 not modified - 0 \ - 1 internal - 2 - 3 - 4 : oops ." ??? " ; - 5 - 6 : OOPS0 oops ; - 7 : OOPS1 oops drop ; - 8 : OOPS2 oops 2drop ; - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ - 1 - 2 : NEXTB CP@ TC@ 1 CP +! ; - 3 : NEXTW CP@ T@ 2 CP +! ; - 4 - 5 : .myself \ --- | have the current word print out its name. - 6 LAST @ [COMPILE] LITERAL COMPILE .name ; IMMEDIATE - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ - 1 internal - 2 - 3 VARIABLE IM \ 2nd operand extension flag/ct - 4 - 5 : ?DISP \ op ext --- op ext | does MOD operand have a disp? - 6 DUP 6 shift> DUP 3 = OVER 0= [or] 0= IF IM ! exit then - 7 0= IF DUP 7 [and] 6 = IF 2 IM ! THEN THEN ; - 8 - 9 -10 : .SELF \ -- | create a word which prints its name -11 CREATE LAST @ , DOES> @ .name ; \ the ultimate in self-doc! -12 -13 -14 -15 -Screen 9 not modified - 0 \ register byte/word - 1 internal - 2 - 3 create wreg-tab ," ACDRSUIW" - 4 create breg-tab ," A-C-D-R-A+C+D+R+" - 5 - 6 : .16REG \ r# --- | register printed out - 7 7 and wreg-tab 1+ + c@ emit space ; - 8 - 9 : .8REG \ r# --- | register printed out -10 7 and 2* breg-tab 1+ + 2 type space ; -11 -12 : .A 0 .16reg ; : .A- 0 .8reg ; -13 : .D 2 .16reg ; -14 -15 -Screen 10 not modified - 0 \ indizierte/indirekte Adressierung cas 10nov05 - 1 - 2 internal - 3 - 4 : ?d DUP 6 shift> 3 [and] 1 3 uwithin ; - 5 - 6 : .D) ( disp_flag ext -- op ) \ indirect - 7 ?d IF ." D" THEN ." ) " ; \ with/without Displacement - 8 - 9 : .I) ( disp_flag ext -- op ) \ indexted indirect -10 ?d IF ." D" THEN ." I) " ; \ with/without Displacement -11 -12 -13 -14 -15 -Screen 11 not modified - 0 \ indexed/indirect addressing cas 10nov05 - 1 internal - 2 - 3 : I) 6 .16reg .D) ; - 4 : W) 7 .16reg .D) ; - 5 : R) 3 .16reg .D) ; - 6 : S) 4 .16reg .D) ; - 7 : U) 5 .16reg .D) ; - 8 - 9 : U+W) 5 .16reg 7 .16reg .I) ; -10 : R+I) 3 .16reg 6 .16reg .I) ; -11 : U+I) 5 .16reg 6 .16reg .I) ; -12 : R+W) 3 .16reg 7 .16reg .I) ; -13 -14 : .# ." # " ; -15 -Screen 12 not modified - 0 \ - 1 internal - 2 - 3 : (.R/M) \ op ext --- | print a register - 4 IM OFF SWAP 1 [and] IF .16REG exit then .8REG ; - 5 - 6 : .R/M \ op ext --- op ext | print r/m as register - 7 2DUP (.R/M) ; - 8 - 9 : .REG \ op ext --- op ext | print reg as register -10 2DUP 3 shift> (.R/M) ; -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ - 1 internal - 2 - 3 CREATE SEGTB ," ECSD" - 4 - 5 : (.seg ( n -- ) - 6 3 shift> 3 and segtb + 1+ c@ emit ; - 7 - 8 : .SEG \ s# --- | register printed out - 9 (.seg ." : " ; -10 -11 : SEG: \ op --- | print segment overrides -12 (.seg ." S:" ; -13 -14 -15 -Screen 14 not modified - 0 \ - 1 internal - 2 : disp@ ( ops-cnt -- ) - 3 ops +! CP@ IM @ + IM off ." $" ; - 4 - 5 : BDISP \ --- | do if displacement is byte - 6 1 disp@ TC@ sext U. ; - 7 - 8 : WDisp \ --- | do if displacement is word - 9 2 disp@ T@ U. ; -10 -11 : .DISP \ op ext --- op ext | print displacement -12 DUP 6 shift> 3 EXEC noop BDISP WDISP .R/M STOP[ -13 -14 : BIMM \ --- | do if immed. value is byte -15 1 disp@ TC@ . ; -Screen 15 not modified - 0 \ - 1 internal - 2 - 3 - 4 : .MREG \ op ext --- op ext | register(s) printed out + disp - 5 $C7 mask 6 = IF WDISP ." ) " exit then - 6 $C0 mask $C0 - 0= IF .R/M exit THEN - 7 .DISP DUP 7 exec - 8 R+I) R+W) U+I) U+W) \ I) oder DI) - 9 I) W) U) R) \ ) oder D) -10 ; -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \ - 1 internal - 2 - 3 : .SIZE \ op --- | decodes for size; WORD is default - 4 1 [and] 0= IF ." BYTE " THEN ; - 5 - 6 create adj-tab ," DAADASAAAAASAAMAAD" - 7 - 8 : .adj-tab 3 * adj-tab 1+ + 3 type space ; - 9 -10 : ADJUSTS \ op --- | the adjusts -11 3 shift> 3 [and] .adj-tab ; -12 -13 : .AAM 4 .adj-tab nextb 2drop ; -14 : .AAD 5 .adj-tab nextb 2drop ; -15 -Screen 17 not modified - 0 \ - 1 internal - 2 : .POP \ op --- | print pops - 3 DUP 8 = IF OOPS1 THEN .SEG ." POP " ; - 4 - 5 : .PUSH \ op --- | print pushes - 6 .SEG ." PUSH " ; - 7 - 8 : P/P \ op --- | pushes or pops - 9 1 mask IF .pop ELSE .push THEN ; -10 -11 -12 -13 -14 -15 -Screen 18 not modified - 0 \ - 1 internal - 2 : P/SEG \ op --- | push or seg overrides - 3 DUP 5 shift> 1 exec P/P SEG: STOP[ - 4 - 5 : P/ADJ \ op --- | pop or adjusts - 6 DUP 5 shift> 1 exec P/P ADJUSTS STOP[ - 7 - 8 : 0GP \ op --- op | opcode decoded & printed - 9 4 mask IF 1 mask -10 IF WDISP ELSE BIMM THEN .# -11 1 [and] IF .A ELSE .A- THEN ELSE -12 NEXTB OVER 2 [and] -13 IF .MREG .REG ELSE ?DISP .REG .MREG -14 THEN 2DROP THEN ; -15 -Screen 19 not modified - 0 \ - 1 external - 2 .SELF ADD .SELF ADC .SELF AND .SELF XOR - 3 .SELF OR .SELF SBB .SELF SUB .SELF CMP - 4 - 5 internal - 6 - 7 : 0GROUP \ op --- | select 0 group to print - 8 DUP 0GP 3 shift> 7 EXEC - 9 ADD OR ADC SBB AND SUB XOR CMP STOP[ -10 -11 : LOWS \ op --- | 0-3f opcodes printed out -12 DUP 7 EXEC -13 0GROUP 0GROUP 0GROUP 0GROUP -14 0GROUP 0GROUP P/SEG P/ADJ STOP[ -15 -Screen 20 not modified - 0 \ - 1 internal - 2 - 3 : .REGGP \ op --- | register group defining word - 4 CREATE LAST @ , DOES> @ SWAP .16REG .name ; - 5 - 6 external - 7 - 8 .REGGP INC .REGGP DEC .REGGP PUSH .REGGP POP - 9 -10 : POPs \ op --- | handle illegal opcode for cs pop -11 $38 mask 8 = IF ." illegal" DROP ELSE POP THEN ; -12 -13 : REGS \ op --- | 40-5f opcodes printed out -14 DUP 3 shift> 3 exec INC DEC PUSH POPs STOP[ -15 -Screen 21 not modified - 0 \ conditional branches - 1 - 2 create branch-tab - 3 ," O NO B NB E NE BE NBES NS P NP L GE LE NLE" - 4 - 5 : .BRANCH \ op --- | branch printed out w/ dest. - 6 NEXTB SEXT CP@ + u. ASCII J EMIT - 7 &15 [and] 3 * branch-tab 1+ + 3 type ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 \ - 1 \\ - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 23 not modified - 0 \ - 1 internal - 2 - 3 : MEDS \ op --- | 40-7f opcodes printed out - 4 DUP 4 shift> 3 exec - 5 REGS REGS OOPS1 .BRANCH STOP[ - 6 - 7 : 80/81 \ op --- | secondary at 80 or 81 - 8 NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# .MREG - 9 SWAP .SIZE 3 shift> 7 EXEC -10 ADD OR ADC SBB AND SUB XOR CMP STOP[ -11 -12 -13 -14 -15 -Screen 24 not modified - 0 \ - 1 internal - 2 : 83S \ op --- | secondary at 83 - 3 NEXTB ?DISP BIMM .# .MREG - 4 SWAP .SIZE 3 shift> 7 EXEC - 5 ADD OOPS0 ADC SBB oops0 SUB OOPS0 CMP STOP[ - 6 - 7 : 1GP \ op --- | r/m reg opcodes - 8 CREATE LAST @ , DOES> @ >R NEXTB ?DISP .REG .MREG 2DROP - 9 R> .name ; -10 -11 external 1GP TEST 1GP XCHG .SELF LEA .SELF MOV internal -12 -13 : MOVRM/REG NEXTB ?DISP .REG .MREG 2DROP MOV ; \ 88-89 -14 : MOVD NEXTB .MREG .REG 2DROP MOV ; \ 8A-8B -15 -Screen 25 not modified - 0 \ - 1 internal - 2 : MOVS>M \ op --- | display instructions 8C-8E - 3 NEXTB OVER $8D = IF .MREG .REG LEA ELSE - 4 OVER $8F = IF .MREG [ ' POP >NAME ] LITERAL .name ELSE - 5 SWAP 1 [or] SWAP \ 16 bit moves only, folks! - 6 OVER 2 [and] IF .MREG DUP .SEG ELSE - 7 DUP .SEG .MREG THEN MOV THEN THEN 2DROP ; - 8 - 9 -10 : 8MOVS \ op --- | display instructions 80-8F -11 DUP 2/ 7 exec -12 80/81 83S TEST XCHG MOVRM/REG MOVD MOVS>M MOVS>M STOP[ -13 -14 -15 -Screen 26 not modified - 0 \ - 1 external - 2 .SELF XCHG .SELF CBW .SELF CWD .SELF CALL .SELF NOP - 3 .SELF WAIT .SELF PUSHF .SELF POPF .SELF SAHF .SELF LAHF - 4 internal - 5 - 6 : INTER \ --- | decode interseg jmp or call - 7 NEXTW 4 u.r ." :" NEXTW U. ; - 8 - 9 : CALLINTER \ --- | decode interseg call -10 INTER CALL ; -11 -12 : 9HIS \ op --- | 98-9F decodes -13 7 exec -14 CBW CWD CALLINTER WAIT PUSHF POPF SAHF LAHF STOP[ -15 -Screen 27 not modified - 0 \ - 1 internal - 2 : XCHGA \ op --- | 98-9F decodes - 3 dup $90 = IF drop NOP ELSE .A .16REG XCHG THEN ; - 4 - 5 : 90S \ op --- | 90-9F decodes - 6 DUP 3 shift> 1 exec XCHGA 9HIS STOP[ - 7 - 8 : MOVSs \ op --- | A4-A5 decodes - 9 .SIZE ." MOVS " ; -10 -11 : CMPSs \ op --- | A6-A7 decodes -12 .SIZE ." CMPS " ; -13 -14 -15 -Screen 28 not modified - 0 \ - 1 internal - 2 : .AL/AX \ op --- | decodes for size - 3 1 EXEC .A- .A STOP[ - 4 - 5 : MOVS/ACC \ op --- | A0-A3 decodes - 6 2 mask - 7 IF .AL/AX WDISP ." ) " ELSE WDISP ." ) " .AL/AX THEN MOV ; - 8 - 9 create ss-tab ," TESTSTOSLODSSCAS" -10 -11 : .ss-tab 3 [and] 4 * ss-tab 1+ + 4 type space ; -12 -13 : .TEST \ op --- | A8-A9 decodes -14 1 mask IF WDISP ELSE BIMM THEN .# .AL/AX 0 .ss-tab ; -15 -Screen 29 not modified - 0 \ - 1 internal - 2 : STOSs ( op --- ) .SIZE 1 .ss-tab ; \ STOS - 3 : LODSs ( op --- ) .SIZE 2 .ss-tab ; \ LODS - 4 : SCASs ( op --- ) .SIZE 3 .ss-tab ; \ SCAS - 5 - 6 : A0S \ op --- | A0-AF decodes - 7 DUP 2/ 7 exec - 8 MOVS/ACC MOVS/ACC MOVSs CMPSs .TEST STOSs LODSs SCASs STOP[ - 9 -10 : MOVS/IMM \ op --- | B0-BF decodes -11 8 mask -12 IF WDISP .# .16REG ELSE BIMM .# .8REG THEN MOV ; -13 -14 : HMEDS \ op --- | op codes 80 - C0 displayed -15 DUP 4 shift> 3 exec 8MOVS 90S A0S MOVS/IMM STOP[ -Screen 30 not modified - 0 \ - 1 external - 2 .SELF LES .SELF LDS .SELF INTO .SELF IRET - 3 internal - 4 - 5 : LES/LDS \ op --- | les/lds instruction C4-C5 - 6 NEXTB .MREG .REG DROP 1 exec LES LDS STOP[ - 7 external - 8 : RET \ op --- | return instruction C2-C3, CA-CB - 9 1 mask 0= IF WDISP ." SP+" THEN -10 8 [and] IF ." FAR " THEN .myself ; -11 -12 internal -13 : MOV#R/M \ op --- | return instruction C2-C3, CA-CB -14 NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# -15 .MREG MOV 2DROP ; -Screen 31 not modified - 0 \ - 1 external - 2 - 3 : INT \ op --- | int instruction CC-CD - 4 1 [and] IF NEXTB ELSE 3 THEN U. .myself ; - 5 - 6 internal - 7 : INTO/IRET \ op --- | int & iret instructions CE-CF - 8 1 exec INTO IRET STOP[ - 9 -10 : C0S \ op --- | display instructions C0-CF -11 DUP 2/ 7 exec -12 OOPS1 RET LES/LDS MOV#R/M OOPS1 RET INT INTO/IRET STOP[ -13 -14 -15 -Screen 32 not modified - 0 \ - 1 external - 2 .SELF ROL .SELF ROR .SELF RCL .SELF RCR - 3 .SELF SHL/SAL .SELF SHR .SELF SAR - 4 internal - 5 - 6 : SHIFTS \ op --- | secondary instructions d0-d3 - 7 2 mask IF 0 .8reg ( C-) THEN - 8 NEXTB .MREG NIP 3 shift> 7 exec - 9 ROL ROR RCL RCR SHL/SAL SHR OOPS0 SAR STOP[ -10 -11 : XLAT DROP ." XLAT " ; -12 -13 : ESC \ op --- | esc instructions d8-DF -14 NEXTB .MREG 3 shift> 7 [and] U. 7 [and] U. ." ESC " ; -15 -Screen 33 not modified - 0 \ - 1 internal - 2 : D0S \ op --- | display instructions D0-DF - 3 8 mask IF ESC EXIT THEN - 4 DUP 7 exec - 5 SHIFTS SHIFTS SHIFTS SHIFTS .AAM .AAD OOPS1 XLAT STOP[ - 6 - 7 external - 8 .SELF LOOPE/Z .SELF LOOP .SELF JCXZ .SELF LOOPNE/NZ - 9 internal -10 -11 : LOOPS \ op --- | display instructions E0-E3 -12 NEXTB SEXT CP@ + u. 3 exec -13 LOOPNE/NZ LOOPE/Z LOOP JCXZ STOP[ -14 -15 external .SELF IN .SELF OUT .SELF JMP -Screen 34 not modified - 0 \ - 1 internal - 2 - 3 : IN/OUT \ op --- | display instructions E4-E6,EC-EF - 4 8 mask - 5 IF 2 mask IF .AL/AX .D OUT ELSE .D .AL/AX IN THEN - 6 ELSE 2 mask - 7 IF .AL/AX BIMM .# OUT ELSE BIMM .# .AL/AX IN THEN - 8 THEN ; - 9 -10 -11 -12 -13 -14 -15 -Screen 35 not modified - 0 \ - 1 internal - 2 : CALLs \ op --- | display instructions E7-EB - 3 2 mask IF 1 mask IF NEXTB SEXT CP@ + u. - 4 ELSE INTER THEN - 5 ELSE NEXTW CP@ + u. THEN - 6 3 exec CALL JMP JMP JMP STOP[ - 7 - 8 : E0S \ op --- | display instructions E0-EF - 9 DUP 2 shift> 3 EXEC LOOPS IN/OUT CALLs IN/OUT STOP[ -10 -11 : FTEST \ op --- | display instructions F6,7:0 -12 ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# -13 .MREG DROP .SIZE 0 .ss-tab ; \ TEST -14 -15 -Screen 36 not modified - 0 \ - 1 external - 2 .SELF NOT .SELF NEG .SELF MUL .SELF IMUL - 3 .SELF DIV .SELF IDIV .SELF REP/NZ .SELF REPZ - 4 .SELF LOCK .SELF HLT .SELF CMC .SELF CLC - 5 .SELF STC .SELF CLI .SELF STI .SELF CLD - 6 .SELF STD .SELF INC .SELF DEC .SELF PUSH - 7 internal - 8 - 9 : MUL/DIV \ op ext --- | secondary instructions F6,7:4-7 -10 .MREG .A OVER 1 [and] IF .D THEN NIP -11 3 shift> 3 exec MUL IMUL DIV IDIV STOP[ -12 -13 -14 -15 -Screen 37 not modified - 0 \ - 1 internal - 2 : NOT/NEG \ op ext --- | secondary instructions F6,7:2,3 - 3 .MREG SWAP .SIZE 3 shift> 1 exec NOT NEG STOP[ - 4 - 5 : F6-F7S \ op --- | display instructions F6,7 - 6 NEXTB DUP 3 shift> 7 exec FTEST OOPS2 NOT/NEG NOT/NEG - 7 MUL/DIV MUL/DIV MUL/DIV MUL/DIV STOP[ - 8 - 9 : FES \ op --- | display instructions FE -10 NEXTB .MREG ." BYTE " NIP 3 shift> -11 3 exec INC DEC oops oops STOP[ -12 -13 : FCALL/JMP \ op ext --- | display call instructions FF -14 .MREG 3 shift> 1 mask IF ." FAR " THEN -15 NIP 2/ 1 exec JMP CALL STOP[ -Screen 38 not modified - 0 \ - 1 internal - 2 - 3 : FPUSH \ op ext --- | display push instructions FF - 4 dup $FF = IF oops2 exit THEN \ FF FF gibt's nicht! - 5 4 mask IF .MREG 2DROP PUSH EXIT THEN OOPS2 ; - 6 - 7 : FINC \ op ext --- | display inc/dec instructions FF - 8 .MREG NIP 3 shift> 1 exec INC DEC STOP[ - 9 -10 : FFS \ op --- | display instructions FF -11 NEXTB DUP 4 shift> 3 exec -12 FINC FCALL/JMP FCALL/JMP FPUSH STOP[ -13 -14 -15 -Screen 39 not modified - 0 \ - 1 internal - 2 - 3 : F0S \ op --- | display instructions F0-FF - 4 &15 mask 7 mask 6 < IF NIP THEN -1 exec - 5 LOCK OOPS0 REP/NZ REPZ HLT CMC F6-F7S F6-F7S - 6 CLC STC CLI STI CLD STD FES FFS STOP[ - 7 - 8 : HIGHS \ op -- | op codes C0 - FF displayed - 9 DUP 4 shift> 3 exec C0S D0S E0S F0S STOP[ -10 -11 : (INST) \ op --- | highest level vector table -12 &255 [and] DUP 6 shift> -13 -1 exec LOWS MEDS HMEDS HIGHS STOP[ -14 -15 -Screen 40 not modified - 0 \ - 1 internal - 2 - 3 : INST \ --- | display opcode at ip, advancing as needed - 4 [ disam ] .seg:off - 5 NEXTB (INST) OPS @ CP +! OPS OFF IM OFF ; - 6 - 7 : (DUMP) \ addr ct --- | dump as pointed to by reloc - 8 [ forth ] BOUNDS ?do I TC@ u. LOOP ; - 9 -10 -11 -12 -13 -14 -15 -Screen 41 not modified - 0 \ - 1 internal - 2 - 3 : steps? - 4 1+ dup &10 mod 0= IF key #esc = exit THEN 0 ; - 5 - 6 create next-code assembler next forth - 7 - 8 : ?next ( steps-count -- steps-count ) - 9 cp@ 2@ next-code 2@ D= -10 IF cr .seg:off ." NEXT Link= " cp@ 4+ @ U. -11 cp@ 6 + cp ! \ 4 bytes code, 2 byte link -12 drop 9 \ forces stop at steps? -13 THEN ; -14 -15 -Screen 42 not modified - 0 \ ks 28 feb 89 - 1 forth definitions - 2 - 3 external - 4 - 5 : DISASM \ addr --- | disassemble until esc key - 6 [ disam ] CP ! base [ forth ] push hex 0 - 7 BEGIN CP@ >R - 8 CR INST R> CP@ OVER - &35 tab (DUMP) - 9 ?next ?stack steps? -10 UNTIL drop ; -11 -12 : dis ( -- ) ' @ disasm ; -13 -14 -15 -Screen 43 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/disasm.fth b/sources/msdos/disasm.fth new file mode 100644 index 0000000..837ffc6 --- /dev/null +++ b/sources/msdos/disasm.fth @@ -0,0 +1,748 @@ +\ *** Block No. 0 Hexblock 0 +\ + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ A disassembler for the 8086 by Charles Curley cas 10nov05 +\ adapted to volksFORTH-83 by B. Molte + + | : internal 1 ?head ! ; + | : external ?head off ; + + onlyFORTH forth DEFINITIONS DECIMAL + + VOCABULARY DISAM DISAM also DEFINITIONS + + 2 capacity 1- thru + onlyforth + + cr .( Use DIS to disassemble word. ) + cr .( ESC will stop the output. ) + +\ *** Block No. 2 Hexblock 2 +\ cas 10nov05 + + internal + + : [and] and ; \ the forth and + : [or] or ; + + : mask ( n maskb -- n n' ) over and ; + + 5 constant 5 \ save some space + 6 constant 6 + 7 constant 7 + 8 constant 8 + + + +\ *** Block No. 3 Hexblock 3 +\ + internal + + : EXEC [and] 2* R> + PERFORM ; + + : STOP[ + 0 ?pairs [compile] [ reveal ; immediate restrict + + code shift> \ n ct --- n' | shift n right ct times + D C mov D pop D C* shr next end-code +\ : shift> 0 ?DO 2/ ( shift's artihm.!) $7FFF and LOOP ; + + code SEXT \ n --- n' | sign extend lower half of n to upper + D A mov cbw A D mov next end-code +\ : hsext $FF and dup $80 and IF $FF00 or THEN ; + +\ *** Block No. 4 Hexblock 4 +\ + external + VARIABLE RELOC 0 , ds@ 0 RELOC 2! \ keeps relocation factor + internal + + VARIABLE CP + VARIABLE OPS \ operand count + + : cp@ cp @ ; + : C? C@ . ; + + : (T@) RELOC 2@ ROT + L@ ; \ in first word, seg in 2nd. You + \ dump/dis any segment w/ any + : (TC@) RELOC 2@ ROT + LC@ ; \ relocation you want by setting + \ RELOC correctly. + : SETSEG RELOC 2+ ! ; +\ *** Block No. 5 Hexblock 5 +\ + external + + DEFER T@ DEFER TC@ + + : HOMESEG ds@ SETSEG ; HOMESEG + + : SEG? RELOC 2+ @ 4 U.r ; + + : .seg:off seg? ." :" cp@ 4 u.r 2 spaces ; + + : MEMORY ['] (TC@) IS TC@ ['] (T@) IS T@ ; MEMORY + + + + +\ *** Block No. 6 Hexblock 6 +\ + internal + + + : oops ." ??? " ; + + : OOPS0 oops ; + : OOPS1 oops drop ; + : OOPS2 oops 2drop ; + + + + + + + +\ *** Block No. 7 Hexblock 7 +\ + + : NEXTB CP@ TC@ 1 CP +! ; + : NEXTW CP@ T@ 2 CP +! ; + + : .myself \ --- | have the current word print out its name. + LAST @ [COMPILE] LITERAL COMPILE .name ; IMMEDIATE + + + + + + + + + +\ *** Block No. 8 Hexblock 8 +\ + internal + + VARIABLE IM \ 2nd operand extension flag/ct + + : ?DISP \ op ext --- op ext | does MOD operand have a disp? + DUP 6 shift> DUP 3 = OVER 0= [or] 0= IF IM ! exit then + 0= IF DUP 7 [and] 6 = IF 2 IM ! THEN THEN ; + + +: .SELF \ -- | create a word which prints its name + CREATE LAST @ , DOES> @ .name ; \ the ultimate in self-doc! + + + + +\ *** Block No. 9 Hexblock 9 +\ register byte/word + internal + + create wreg-tab ," ACDRSUIW" + create breg-tab ," A-C-D-R-A+C+D+R+" + + : .16REG \ r# --- | register printed out + 7 and wreg-tab 1+ + c@ emit space ; + + : .8REG \ r# --- | register printed out + 7 and 2* breg-tab 1+ + 2 type space ; + + : .A 0 .16reg ; : .A- 0 .8reg ; + : .D 2 .16reg ; + + +\ *** Block No. 10 Hexblock A +\ indizierte/indirekte Adressierung cas 10nov05 + + internal + + : ?d DUP 6 shift> 3 [and] 1 3 uwithin ; + + : .D) ( disp_flag ext -- op ) \ indirect + ?d IF ." D" THEN ." ) " ; \ with/without Displacement + + : .I) ( disp_flag ext -- op ) \ indexted indirect + ?d IF ." D" THEN ." I) " ; \ with/without Displacement + + + + + +\ *** Block No. 11 Hexblock B +\ indexed/indirect addressing cas 10nov05 + internal + + : I) 6 .16reg .D) ; + : W) 7 .16reg .D) ; + : R) 3 .16reg .D) ; + : S) 4 .16reg .D) ; + : U) 5 .16reg .D) ; + + : U+W) 5 .16reg 7 .16reg .I) ; + : R+I) 3 .16reg 6 .16reg .I) ; + : U+I) 5 .16reg 6 .16reg .I) ; + : R+W) 3 .16reg 7 .16reg .I) ; + + : .# ." # " ; + +\ *** Block No. 12 Hexblock C +\ + internal + + : (.R/M) \ op ext --- | print a register + IM OFF SWAP 1 [and] IF .16REG exit then .8REG ; + + : .R/M \ op ext --- op ext | print r/m as register + 2DUP (.R/M) ; + + : .REG \ op ext --- op ext | print reg as register + 2DUP 3 shift> (.R/M) ; + + + + + +\ *** Block No. 13 Hexblock D +\ + internal + + CREATE SEGTB ," ECSD" + + : (.seg ( n -- ) + 3 shift> 3 and segtb + 1+ c@ emit ; + + : .SEG \ s# --- | register printed out + (.seg ." : " ; + + : SEG: \ op --- | print segment overrides + (.seg ." S:" ; + + + +\ *** Block No. 14 Hexblock E +\ + internal + : disp@ ( ops-cnt -- ) + ops +! CP@ IM @ + IM off ." $" ; + + : BDISP \ --- | do if displacement is byte + 1 disp@ TC@ sext U. ; + + : WDisp \ --- | do if displacement is word + 2 disp@ T@ U. ; + + : .DISP \ op ext --- op ext | print displacement + DUP 6 shift> 3 EXEC noop BDISP WDISP .R/M STOP[ + + : BIMM \ --- | do if immed. value is byte + 1 disp@ TC@ . ; +\ *** Block No. 15 Hexblock F +\ + internal + + + : .MREG \ op ext --- op ext | register(s) printed out + disp + $C7 mask 6 = IF WDISP ." ) " exit then + $C0 mask $C0 - 0= IF .R/M exit THEN + .DISP DUP 7 exec + R+I) R+W) U+I) U+W) \ I) oder DI) + I) W) U) R) \ ) oder D) + ; + + + + + +\ *** Block No. 16 Hexblock 10 +\ + internal + + : .SIZE \ op --- | decodes for size; WORD is default + 1 [and] 0= IF ." BYTE " THEN ; + + create adj-tab ," DAADASAAAAASAAMAAD" + + : .adj-tab 3 * adj-tab 1+ + 3 type space ; + + : ADJUSTS \ op --- | the adjusts + 3 shift> 3 [and] .adj-tab ; + + : .AAM 4 .adj-tab nextb 2drop ; + : .AAD 5 .adj-tab nextb 2drop ; + +\ *** Block No. 17 Hexblock 11 +\ + internal + : .POP \ op --- | print pops + DUP 8 = IF OOPS1 THEN .SEG ." POP " ; + + : .PUSH \ op --- | print pushes + .SEG ." PUSH " ; + + : P/P \ op --- | pushes or pops + 1 mask IF .pop ELSE .push THEN ; + + + + + + +\ *** Block No. 18 Hexblock 12 +\ +internal + : P/SEG \ op --- | push or seg overrides + DUP 5 shift> 1 exec P/P SEG: STOP[ + + : P/ADJ \ op --- | pop or adjusts + DUP 5 shift> 1 exec P/P ADJUSTS STOP[ + + : 0GP \ op --- op | opcode decoded & printed + 4 mask IF 1 mask + IF WDISP ELSE BIMM THEN .# + 1 [and] IF .A ELSE .A- THEN ELSE + NEXTB OVER 2 [and] + IF .MREG .REG ELSE ?DISP .REG .MREG + THEN 2DROP THEN ; + +\ *** Block No. 19 Hexblock 13 +\ + external + .SELF ADD .SELF ADC .SELF AND .SELF XOR + .SELF OR .SELF SBB .SELF SUB .SELF CMP + + internal + + : 0GROUP \ op --- | select 0 group to print + DUP 0GP 3 shift> 7 EXEC + ADD OR ADC SBB AND SUB XOR CMP STOP[ + + : LOWS \ op --- | 0-3f opcodes printed out + DUP 7 EXEC + 0GROUP 0GROUP 0GROUP 0GROUP + 0GROUP 0GROUP P/SEG P/ADJ STOP[ + +\ *** Block No. 20 Hexblock 14 +\ + internal + + : .REGGP \ op --- | register group defining word + CREATE LAST @ , DOES> @ SWAP .16REG .name ; + + external + + .REGGP INC .REGGP DEC .REGGP PUSH .REGGP POP + + : POPs \ op --- | handle illegal opcode for cs pop + $38 mask 8 = IF ." illegal" DROP ELSE POP THEN ; + +: REGS \ op --- | 40-5f opcodes printed out + DUP 3 shift> 3 exec INC DEC PUSH POPs STOP[ + +\ *** Block No. 21 Hexblock 15 +\ conditional branches + + create branch-tab + ," O NO B NB E NE BE NBES NS P NP L GE LE NLE" + + : .BRANCH \ op --- | branch printed out w/ dest. + NEXTB SEXT CP@ + u. ASCII J EMIT + &15 [and] 3 * branch-tab 1+ + 3 type ; + + + + + + + + +\ *** Block No. 22 Hexblock 16 +\ +\\ + + + + + + + + + + + + + + +\ *** Block No. 23 Hexblock 17 +\ +internal + + : MEDS \ op --- | 40-7f opcodes printed out + DUP 4 shift> 3 exec + REGS REGS OOPS1 .BRANCH STOP[ + + : 80/81 \ op --- | secondary at 80 or 81 + NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# .MREG + SWAP .SIZE 3 shift> 7 EXEC + ADD OR ADC SBB AND SUB XOR CMP STOP[ + + + + + +\ *** Block No. 24 Hexblock 18 +\ + internal + : 83S \ op --- | secondary at 83 + NEXTB ?DISP BIMM .# .MREG + SWAP .SIZE 3 shift> 7 EXEC + ADD OOPS0 ADC SBB oops0 SUB OOPS0 CMP STOP[ + + : 1GP \ op --- | r/m reg opcodes + CREATE LAST @ , DOES> @ >R NEXTB ?DISP .REG .MREG 2DROP + R> .name ; + + external 1GP TEST 1GP XCHG .SELF LEA .SELF MOV internal + +: MOVRM/REG NEXTB ?DISP .REG .MREG 2DROP MOV ; \ 88-89 +: MOVD NEXTB .MREG .REG 2DROP MOV ; \ 8A-8B + +\ *** Block No. 25 Hexblock 19 +\ + internal +: MOVS>M \ op --- | display instructions 8C-8E + NEXTB OVER $8D = IF .MREG .REG LEA ELSE + OVER $8F = IF .MREG [ ' POP >NAME ] LITERAL .name ELSE + SWAP 1 [or] SWAP \ 16 bit moves only, folks! + OVER 2 [and] IF .MREG DUP .SEG ELSE + DUP .SEG .MREG THEN MOV THEN THEN 2DROP ; + + + : 8MOVS \ op --- | display instructions 80-8F + DUP 2/ 7 exec + 80/81 83S TEST XCHG MOVRM/REG MOVD MOVS>M MOVS>M STOP[ + + + +\ *** Block No. 26 Hexblock 1A +\ + external + .SELF XCHG .SELF CBW .SELF CWD .SELF CALL .SELF NOP + .SELF WAIT .SELF PUSHF .SELF POPF .SELF SAHF .SELF LAHF + internal + + : INTER \ --- | decode interseg jmp or call + NEXTW 4 u.r ." :" NEXTW U. ; + + : CALLINTER \ --- | decode interseg call + INTER CALL ; + + : 9HIS \ op --- | 98-9F decodes + 7 exec + CBW CWD CALLINTER WAIT PUSHF POPF SAHF LAHF STOP[ + +\ *** Block No. 27 Hexblock 1B +\ + internal + : XCHGA \ op --- | 98-9F decodes + dup $90 = IF drop NOP ELSE .A .16REG XCHG THEN ; + + : 90S \ op --- | 90-9F decodes + DUP 3 shift> 1 exec XCHGA 9HIS STOP[ + + : MOVSs \ op --- | A4-A5 decodes + .SIZE ." MOVS " ; + + : CMPSs \ op --- | A6-A7 decodes + .SIZE ." CMPS " ; + + + +\ *** Block No. 28 Hexblock 1C +\ + internal + : .AL/AX \ op --- | decodes for size + 1 EXEC .A- .A STOP[ + + : MOVS/ACC \ op --- | A0-A3 decodes + 2 mask + IF .AL/AX WDISP ." ) " ELSE WDISP ." ) " .AL/AX THEN MOV ; + + create ss-tab ," TESTSTOSLODSSCAS" + + : .ss-tab 3 [and] 4 * ss-tab 1+ + 4 type space ; + + : .TEST \ op --- | A8-A9 decodes + 1 mask IF WDISP ELSE BIMM THEN .# .AL/AX 0 .ss-tab ; + +\ *** Block No. 29 Hexblock 1D +\ + internal + : STOSs ( op --- ) .SIZE 1 .ss-tab ; \ STOS + : LODSs ( op --- ) .SIZE 2 .ss-tab ; \ LODS + : SCASs ( op --- ) .SIZE 3 .ss-tab ; \ SCAS + + : A0S \ op --- | A0-AF decodes + DUP 2/ 7 exec + MOVS/ACC MOVS/ACC MOVSs CMPSs .TEST STOSs LODSs SCASs STOP[ + + : MOVS/IMM \ op --- | B0-BF decodes + 8 mask + IF WDISP .# .16REG ELSE BIMM .# .8REG THEN MOV ; + + : HMEDS \ op --- | op codes 80 - C0 displayed + DUP 4 shift> 3 exec 8MOVS 90S A0S MOVS/IMM STOP[ +\ *** Block No. 30 Hexblock 1E +\ + external + .SELF LES .SELF LDS .SELF INTO .SELF IRET + internal + + : LES/LDS \ op --- | les/lds instruction C4-C5 + NEXTB .MREG .REG DROP 1 exec LES LDS STOP[ + external + : RET \ op --- | return instruction C2-C3, CA-CB + 1 mask 0= IF WDISP ." SP+" THEN + 8 [and] IF ." FAR " THEN .myself ; + + internal + : MOV#R/M \ op --- | return instruction C2-C3, CA-CB + NEXTB ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# + .MREG MOV 2DROP ; +\ *** Block No. 31 Hexblock 1F +\ + external + + : INT \ op --- | int instruction CC-CD + 1 [and] IF NEXTB ELSE 3 THEN U. .myself ; + + internal + : INTO/IRET \ op --- | int & iret instructions CE-CF + 1 exec INTO IRET STOP[ + + : C0S \ op --- | display instructions C0-CF + DUP 2/ 7 exec + OOPS1 RET LES/LDS MOV#R/M OOPS1 RET INT INTO/IRET STOP[ + + + +\ *** Block No. 32 Hexblock 20 +\ + external + .SELF ROL .SELF ROR .SELF RCL .SELF RCR + .SELF SHL/SAL .SELF SHR .SELF SAR + internal + + : SHIFTS \ op --- | secondary instructions d0-d3 + 2 mask IF 0 .8reg ( C-) THEN + NEXTB .MREG NIP 3 shift> 7 exec + ROL ROR RCL RCR SHL/SAL SHR OOPS0 SAR STOP[ + + : XLAT DROP ." XLAT " ; + + : ESC \ op --- | esc instructions d8-DF + NEXTB .MREG 3 shift> 7 [and] U. 7 [and] U. ." ESC " ; + +\ *** Block No. 33 Hexblock 21 +\ + internal + : D0S \ op --- | display instructions D0-DF + 8 mask IF ESC EXIT THEN + DUP 7 exec + SHIFTS SHIFTS SHIFTS SHIFTS .AAM .AAD OOPS1 XLAT STOP[ + + external + .SELF LOOPE/Z .SELF LOOP .SELF JCXZ .SELF LOOPNE/NZ + internal + + : LOOPS \ op --- | display instructions E0-E3 + NEXTB SEXT CP@ + u. 3 exec + LOOPNE/NZ LOOPE/Z LOOP JCXZ STOP[ + + external .SELF IN .SELF OUT .SELF JMP +\ *** Block No. 34 Hexblock 22 +\ + internal + + : IN/OUT \ op --- | display instructions E4-E6,EC-EF + 8 mask + IF 2 mask IF .AL/AX .D OUT ELSE .D .AL/AX IN THEN + ELSE 2 mask + IF .AL/AX BIMM .# OUT ELSE BIMM .# .AL/AX IN THEN + THEN ; + + + + + + + +\ *** Block No. 35 Hexblock 23 +\ + internal + : CALLs \ op --- | display instructions E7-EB + 2 mask IF 1 mask IF NEXTB SEXT CP@ + u. + ELSE INTER THEN + ELSE NEXTW CP@ + u. THEN + 3 exec CALL JMP JMP JMP STOP[ + + : E0S \ op --- | display instructions E0-EF + DUP 2 shift> 3 EXEC LOOPS IN/OUT CALLs IN/OUT STOP[ + + : FTEST \ op --- | display instructions F6,7:0 + ?DISP OVER 1 [and] IF WDISP ELSE BIMM THEN .# + .MREG DROP .SIZE 0 .ss-tab ; \ TEST + + +\ *** Block No. 36 Hexblock 24 +\ + external + .SELF NOT .SELF NEG .SELF MUL .SELF IMUL + .SELF DIV .SELF IDIV .SELF REP/NZ .SELF REPZ + .SELF LOCK .SELF HLT .SELF CMC .SELF CLC + .SELF STC .SELF CLI .SELF STI .SELF CLD + .SELF STD .SELF INC .SELF DEC .SELF PUSH + internal + +: MUL/DIV \ op ext --- | secondary instructions F6,7:4-7 + .MREG .A OVER 1 [and] IF .D THEN NIP + 3 shift> 3 exec MUL IMUL DIV IDIV STOP[ + + + + +\ *** Block No. 37 Hexblock 25 +\ + internal + : NOT/NEG \ op ext --- | secondary instructions F6,7:2,3 + .MREG SWAP .SIZE 3 shift> 1 exec NOT NEG STOP[ + + : F6-F7S \ op --- | display instructions F6,7 + NEXTB DUP 3 shift> 7 exec FTEST OOPS2 NOT/NEG NOT/NEG + MUL/DIV MUL/DIV MUL/DIV MUL/DIV STOP[ + + : FES \ op --- | display instructions FE + NEXTB .MREG ." BYTE " NIP 3 shift> + 3 exec INC DEC oops oops STOP[ + + : FCALL/JMP \ op ext --- | display call instructions FF + .MREG 3 shift> 1 mask IF ." FAR " THEN + NIP 2/ 1 exec JMP CALL STOP[ +\ *** Block No. 38 Hexblock 26 +\ + internal + + : FPUSH \ op ext --- | display push instructions FF + dup $FF = IF oops2 exit THEN \ FF FF gibt's nicht! + 4 mask IF .MREG 2DROP PUSH EXIT THEN OOPS2 ; + + : FINC \ op ext --- | display inc/dec instructions FF + .MREG NIP 3 shift> 1 exec INC DEC STOP[ + + : FFS \ op --- | display instructions FF + NEXTB DUP 4 shift> 3 exec + FINC FCALL/JMP FCALL/JMP FPUSH STOP[ + + + +\ *** Block No. 39 Hexblock 27 +\ + internal + + : F0S \ op --- | display instructions F0-FF + &15 mask 7 mask 6 < IF NIP THEN -1 exec + LOCK OOPS0 REP/NZ REPZ HLT CMC F6-F7S F6-F7S + CLC STC CLI STI CLD STD FES FFS STOP[ + + : HIGHS \ op -- | op codes C0 - FF displayed + DUP 4 shift> 3 exec C0S D0S E0S F0S STOP[ + + : (INST) \ op --- | highest level vector table + &255 [and] DUP 6 shift> + -1 exec LOWS MEDS HMEDS HIGHS STOP[ + + +\ *** Block No. 40 Hexblock 28 +\ + internal + + : INST \ --- | display opcode at ip, advancing as needed + [ disam ] .seg:off + NEXTB (INST) OPS @ CP +! OPS OFF IM OFF ; + + : (DUMP) \ addr ct --- | dump as pointed to by reloc + [ forth ] BOUNDS ?do I TC@ u. LOOP ; + + + + + + + +\ *** Block No. 41 Hexblock 29 +\ + internal + + : steps? + 1+ dup &10 mod 0= IF key #esc = exit THEN 0 ; + + create next-code assembler next forth + + : ?next ( steps-count -- steps-count ) + cp@ 2@ next-code 2@ D= + IF cr .seg:off ." NEXT Link= " cp@ 4+ @ U. + cp@ 6 + cp ! \ 4 bytes code, 2 byte link + drop 9 \ forces stop at steps? + THEN ; + + +\ *** Block No. 42 Hexblock 2A +\ ks 28 feb 89 + forth definitions + + external + + : DISASM \ addr --- | disassemble until esc key + [ disam ] CP ! base [ forth ] push hex 0 + BEGIN CP@ >R + CR INST R> CP@ OVER - &35 tab (DUMP) + ?next ?stack steps? + UNTIL drop ; + + : dis ( -- ) ' @ disasm ; + + + +\ *** Block No. 43 Hexblock 2B + + + + + + + + + + + + + + + + diff --git a/sources/msdos/dos.fb.src b/sources/msdos/dos.fb.src deleted file mode 100644 index 08345a6..0000000 --- a/sources/msdos/dos.fb.src +++ /dev/null @@ -1,306 +0,0 @@ -Screen 0 not modified - 0 \ 28 jun 88 - 1 - 2 DOS loads higher level file functions which go beyond - 3 including a screen file. Calls to MS-DOS are implemented - 4 and used for directory manipulation. These functions may - 5 not work for versions before MS-DOS 3.0. - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ MS-DOS file handli cas 09jun20 - 1 Onlyforth \needs Assembler 2 loadfrom asm.fb - 2 - 3 : fswap isfile@ fromfile @ isfile ! fromfile ! ; - 4 - 5 $80 Constant dta - 6 - 7 | : COMSPEC ( -- string ) [ dos ] - 8 $2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove - 9 filename counted &60 min filename place filename ; -10 -11 1 &12 +thru .( MS-DOS functions loaed ) cr -12 -13 Onlyforth -14 -15 -Screen 2 not modified - 0 \ moving blocks ks 04 okt 87 - 1 - 2 | : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; - 3 - 4 : used? ( blk -- f ) - 5 block count b/blk 1- swap skip nip 0<> ; - 6 - 7 | : (copy ( from to -- ) - 8 full? IF save-buffers THEN isfile@ fromfile @ - - 9 IF dup used? Abort" target block not empty" THEN -10 dup isfile@ core? IF prev @ emptybuf THEN -11 isfile@ 0= IF offset @ + THEN -12 isfile@ rot fromfile @ (block 6 - 2! update ; -13 -14 -15 -Screen 3 not modified - 0 \ moving blocks ks 04 okt 87 - 1 - 2 | : blkmove ( from to quan -- ) 3 arguments save-buffers - 3 >r over r@ + over u> >r 2dup u< r> and - 4 IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP - 5 ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP - 6 THEN save-buffers 2drop ; - 7 - 8 : copy ( from to -- ) 1 blkmove ; - 9 -10 : convey ( blk1 blk2 to.blk -- ) -11 3 arguments >r 2dup swap - >r -12 fswap dup capacity 1- > isfile@ 0<> and -13 fswap r> r@ + capacity 1- > isfile@ 0<> and or >r -14 1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ; -15 -Screen 4 not modified - 0 \ MORE extending forth files ks 10 okt 87 - 1 Dos also definitions - 2 - 3 | : addblock ( blk -- ) dup buffer dup b/blk blank - 4 isfile@ f.size dup 2@ b/blk 0 d+ rot 2! - 5 swap isfile@ fblock! ; - 6 - 7 Forth definitions - 8 - 9 : more ( n -- ) 1 arguments isfile@ -10 IF capacity swap bounds ?DO I addblock LOOP close exit -11 THEN drop ; -12 -13 -14 -15 -Screen 5 not modified - 0 \ file eof? create dta-addressing ks 03 apr 88 - 1 Dos definitions - 2 - 3 : ftime ( -- mm hh ) - 4 isfile@ f.time @ $20 u/mod nip $40 u/mod ; - 5 - 6 : fdate ( -- dd mm yy ) - 7 isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; - 8 - 9 : .when base push decimal -10 fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r -11 ftime 3 .r ." :" 2 .r ; -12 -13 -14 -15 -Screen 6 not modified - 0 \ ks 20mar88 - 1 - 2 : (.fcb ( fcb -- ) - 3 dup .file ?dup 0=exit pushfile - 4 isfile ! &13 tab ." is" - 5 isfile@ f.handle @ 2 .r - 6 isfile@ f.size 2@ 7 d.r .when - 7 space isfile@ f.name count type ; - 8 - 9 Forth definitions -10 -11 : files file-link -12 BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ; -13 -14 : ?file isfile@ (.fcb ; -15 -Screen 7 not modified - 0 \ dir make makefile ks 25 okt 87 - 1 Forth definitions - 2 - 3 : killfile close - 4 isfile@ f.name filename >asciz ~unlink drop ; - 5 - 6 : emptyfile isfile@ 0=exit - 7 isfile@ f.name filename >asciz 0 ~creat ?diskerror - 8 isfile@ f.handle ! isfile@ f.size 4 erase ; - 9 -10 : make close name isfile@ fname! emptyfile ; -11 -12 : makefile File last @ name> execute emptyfile ; -13 -14 -15 -Screen 8 not modified - 0 \ getpath ks 10 okt 87 - 1 Dos definitions - 2 - 3 | &40 Constant pathlen - 4 | Create pathes 0 c, pathlen allot - 5 - 6 | : (setpath ( string -- ) count - 7 dup pathlen u> Abort" path too long" pathes place ; - 8 - 9 | : getpath ( +n -- string / ff ) -10 >r 0 pathes count r> 0 -11 DO rot drop Ascii ; skip stash Ascii ; scan LOOP -12 drop over - ?dup -13 IF here place here dup count + 1- c@ -14 ?" :\" ?exit Ascii \ here append exit -15 THEN 0= ; -Screen 9 not modified - 0 \ pathsearch .path path ks 09 okt 87 - 1 - 2 : pathsearch ( string -- asciz *f ) dup >r - 3 (fsearch dup 0= IF rdrop exit THEN 2drop 0 0 - 4 BEGIN drop 1+ dup getpath ?dup 0= - 5 IF drop r> filename >asciz 2 exit THEN - 6 r@ count 2 pick attach (fsearch - 7 0= UNTIL nip rdrop false ; - 8 - 9 ' pathsearch Is fsearch -10 -11 Forth definitions -12 -13 : .path pathes count type ; -14 -15 : path name nullstring? IF .path exit THEN (setpath ; -Screen 10 not modified - 0 \ call another executable file ks 04 aug 87 - 1 Dos definitions - 2 - 3 | Create cpb 0 , \ inherit parent environment - 4 dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 , - 5 - 6 | Code ~exec ( asciz -- *f ) - 7 I push R push U push S ssave #) mov cpb # R mov - 8 $4B00 # A mov $21 int C: D mov D D: mov D S: mov - 9 D E: mov ssave #) S mov CS not -10 ?[ A A xor A push $2F # A+ mov $21 int E: A mov -11 A D: mov C: A mov A E: mov R I mov dta # W mov -12 $40 # C mov rep movs A D: mov A pop -13 ]? A W xchg dta # D mov $1A # A+ mov $21 int -14 W D mov U pop R pop I pop Next -15 end-code -Screen 11 not modified - 0 \ calling MS-DOS thru forth interpreter ks 19 mr 88 - 1 - 2 | : execute? ( extension -- *f ) - 3 count filename count Ascii . scan drop swap - 4 2dup 1+ erase move filename 1+ ~exec ; - 5 - 6 : fcall ( string -- ) count filename place ds@ cpb 4+ ! - 7 " .EXE" execute? dup IF drop " .COM" execute? THEN - 8 ?diskerror ; - 9 -10 : fdos ( string -- ) -11 dta $80 erase " /c " count dta place count dta attach -12 status push status off .status COMSPEC fcall curat? at ; -13 -14 -15 -Screen 12 not modified - 0 \ einige MS-DOS Funktionen msdos call ks 10 okt 87 - 1 - 2 : dos: Create ," Does> count here place - 3 Ascii " parse here attach here fdos ; - 4 - 5 Forth definitions - 6 - 7 dos: dir dir " - 8 dos: ren ren " - 9 dos: md md " -10 dos: cd cd " -11 dos: rd rd " -12 dos: fcopy copy " -13 dos: delete del " -14 dos: ftype type " -15 -Screen 13 not modified - 0 \ msdos call ks 23 okt 88 - 1 - 2 : msdos savevideo status push status off .status - 3 flush dta off COMSPEC fcall restorevideo ; - 4 - 5 : call name source >in @ /string c/l umin - 6 dta place dta dta >asciz drop [compile] \ - 7 status push status off .status fcall curat? at ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 14 not modified - 0 \ time date ks 19 mr 88 - 1 Dos definitions - 2 - 3 : ftime ( -- mm hh ) - 4 open isfile@ f.time @ $20 u/mod nip $40 u/mod ; - 5 - 6 : fdate ( -- dd mm yy ) - 7 open isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ ~lseek position? ks 10 okt 87 - 1 Dos definitions - 2 - 3 Code ~lseek ( d handle method -- d' ) - 4 R W mov D A mov R pop C pop D pop - 5 $42 # A+ mov $21 int W R mov CS not - 6 ?[ A push Next ]? A D xchg ;c: ?diskerror ; - 7 - 8 Forth definitions - 9 -10 : position? ( -- dfaddr ) -11 isfile@ f.handle @ 0= Abort" file not open" -12 0 0 isfile@ f.handle @ 1 ~lseek ; -13 -14 -15 -Screen 16 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 17 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/dos.fth b/sources/msdos/dos.fth new file mode 100644 index 0000000..e8e7f3e --- /dev/null +++ b/sources/msdos/dos.fth @@ -0,0 +1,306 @@ +\ *** Block No. 0 Hexblock 0 +\ 28 jun 88 + +DOS loads higher level file functions which go beyond +including a screen file. Calls to MS-DOS are implemented +and used for directory manipulation. These functions may +not work for versions before MS-DOS 3.0. + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ MS-DOS file handli cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : fswap isfile@ fromfile @ isfile ! fromfile ! ; + + $80 Constant dta + +| : COMSPEC ( -- string ) [ dos ] + $2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove + filename counted &60 min filename place filename ; + + 1 &12 +thru .( MS-DOS functions loaed ) cr + + Onlyforth + + +\ *** Block No. 2 Hexblock 2 +\ moving blocks ks 04 okt 87 + +| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ; + + : used? ( blk -- f ) + block count b/blk 1- swap skip nip 0<> ; + +| : (copy ( from to -- ) + full? IF save-buffers THEN isfile@ fromfile @ - + IF dup used? Abort" target block not empty" THEN + dup isfile@ core? IF prev @ emptybuf THEN + isfile@ 0= IF offset @ + THEN + isfile@ rot fromfile @ (block 6 - 2! update ; + + + +\ *** Block No. 3 Hexblock 3 +\ moving blocks ks 04 okt 87 + +| : blkmove ( from to quan -- ) 3 arguments save-buffers + >r over r@ + over u> >r 2dup u< r> and + IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP + ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP + THEN save-buffers 2drop ; + + : copy ( from to -- ) 1 blkmove ; + + : convey ( blk1 blk2 to.blk -- ) + 3 arguments >r 2dup swap - >r + fswap dup capacity 1- > isfile@ 0<> and + fswap r> r@ + capacity 1- > isfile@ 0<> and or >r + 1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ; + +\ *** Block No. 4 Hexblock 4 +\ MORE extending forth files ks 10 okt 87 + Dos also definitions + +| : addblock ( blk -- ) dup buffer dup b/blk blank + isfile@ f.size dup 2@ b/blk 0 d+ rot 2! + swap isfile@ fblock! ; + + Forth definitions + + : more ( n -- ) 1 arguments isfile@ + IF capacity swap bounds ?DO I addblock LOOP close exit + THEN drop ; + + + + +\ *** Block No. 5 Hexblock 5 +\ file eof? create dta-addressing ks 03 apr 88 + Dos definitions + + : ftime ( -- mm hh ) + isfile@ f.time @ $20 u/mod nip $40 u/mod ; + + : fdate ( -- dd mm yy ) + isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; + + : .when base push decimal + fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r + ftime 3 .r ." :" 2 .r ; + + + + +\ *** Block No. 6 Hexblock 6 +\ ks 20mar88 + + : (.fcb ( fcb -- ) + dup .file ?dup 0=exit pushfile + isfile ! &13 tab ." is" + isfile@ f.handle @ 2 .r + isfile@ f.size 2@ 7 d.r .when + space isfile@ f.name count type ; + + Forth definitions + + : files file-link + BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ; + + : ?file isfile@ (.fcb ; + +\ *** Block No. 7 Hexblock 7 +\ dir make makefile ks 25 okt 87 + Forth definitions + + : killfile close + isfile@ f.name filename >asciz ~unlink drop ; + + : emptyfile isfile@ 0=exit + isfile@ f.name filename >asciz 0 ~creat ?diskerror + isfile@ f.handle ! isfile@ f.size 4 erase ; + + : make close name isfile@ fname! emptyfile ; + + : makefile File last @ name> execute emptyfile ; + + + +\ *** Block No. 8 Hexblock 8 +\ getpath ks 10 okt 87 + Dos definitions + +| &40 Constant pathlen +| Create pathes 0 c, pathlen allot + +| : (setpath ( string -- ) count + dup pathlen u> Abort" path too long" pathes place ; + +| : getpath ( +n -- string / ff ) + >r 0 pathes count r> 0 + DO rot drop Ascii ; skip stash Ascii ; scan LOOP + drop over - ?dup + IF here place here dup count + 1- c@ + ?" :\" ?exit Ascii \ here append exit + THEN 0= ; +\ *** Block No. 9 Hexblock 9 +\ pathsearch .path path ks 09 okt 87 + + : pathsearch ( string -- asciz *f ) dup >r + (fsearch dup 0= IF rdrop exit THEN 2drop 0 0 + BEGIN drop 1+ dup getpath ?dup 0= + IF drop r> filename >asciz 2 exit THEN + r@ count 2 pick attach (fsearch + 0= UNTIL nip rdrop false ; + + ' pathsearch Is fsearch + + Forth definitions + + : .path pathes count type ; + + : path name nullstring? IF .path exit THEN (setpath ; +\ *** Block No. 10 Hexblock A +\ call another executable file ks 04 aug 87 + Dos definitions + +| Create cpb 0 , \ inherit parent environment + dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 , + +| Code ~exec ( asciz -- *f ) + I push R push U push S ssave #) mov cpb # R mov + $4B00 # A mov $21 int C: D mov D D: mov D S: mov + D E: mov ssave #) S mov CS not + ?[ A A xor A push $2F # A+ mov $21 int E: A mov + A D: mov C: A mov A E: mov R I mov dta # W mov + $40 # C mov rep movs A D: mov A pop + ]? A W xchg dta # D mov $1A # A+ mov $21 int + W D mov U pop R pop I pop Next + end-code +\ *** Block No. 11 Hexblock B +\ calling MS-DOS thru forth interpreter ks 19 mr 88 + +| : execute? ( extension -- *f ) + count filename count Ascii . scan drop swap + 2dup 1+ erase move filename 1+ ~exec ; + + : fcall ( string -- ) count filename place ds@ cpb 4+ ! + " .EXE" execute? dup IF drop " .COM" execute? THEN + ?diskerror ; + + : fdos ( string -- ) + dta $80 erase " /c " count dta place count dta attach + status push status off .status COMSPEC fcall curat? at ; + + + +\ *** Block No. 12 Hexblock C +\ einige MS-DOS Funktionen msdos call ks 10 okt 87 + + : dos: Create ," Does> count here place + Ascii " parse here attach here fdos ; + + Forth definitions + + dos: dir dir " + dos: ren ren " + dos: md md " + dos: cd cd " + dos: rd rd " + dos: fcopy copy " + dos: delete del " + dos: ftype type " + +\ *** Block No. 13 Hexblock D +\ msdos call ks 23 okt 88 + + : msdos savevideo status push status off .status + flush dta off COMSPEC fcall restorevideo ; + + : call name source >in @ /string c/l umin + dta place dta dta >asciz drop [compile] \ + status push status off .status fcall curat? at ; + + + + + + + + +\ *** Block No. 14 Hexblock E +\ time date ks 19 mr 88 + Dos definitions + + : ftime ( -- mm hh ) + open isfile@ f.time @ $20 u/mod nip $40 u/mod ; + + : fdate ( -- dd mm yy ) + open isfile@ f.date @ $20 u/mod $10 u/mod &80 + ; + + + + + + + + +\ *** Block No. 15 Hexblock F +\ ~lseek position? ks 10 okt 87 + Dos definitions + + Code ~lseek ( d handle method -- d' ) + R W mov D A mov R pop C pop D pop + $42 # A+ mov $21 int W R mov CS not + ?[ A push Next ]? A D xchg ;c: ?diskerror ; + + Forth definitions + + : position? ( -- dfaddr ) + isfile@ f.handle @ 0= Abort" file not open" + 0 0 isfile@ f.handle @ 1 ~lseek ; + + + +\ *** Block No. 16 Hexblock 10 + + + + + + + + + + + + + + + + +\ *** Block No. 17 Hexblock 11 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/double.fb.src b/sources/msdos/double.fb.src deleted file mode 100644 index 4b5dd4c..0000000 --- a/sources/msdos/double.fb.src +++ /dev/null @@ -1,85 +0,0 @@ -Screen 0 not modified - 0 \\ Double words cas 10nov05 - 1 - 2 This File contains definitions for 32Bit Math - 3 - 4 This definitions are already included in the volksFORTH Kernel: - 5 - 6 2! 2@ 2drop 2dup 2over 2swap d+ d. d.r - 7 d0= d< d= dabs dnegate - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ 2constant 2rot 2variable d- d2/ ks 22 dez 87 - 1 - 2 : 2constant Create , , does> 2@ ; - 3 - 4 : 2rot ( d1 d2 d3 -- d2 d3 d1 ) 5 roll 5 roll ; - 5 - 6 : 2variable Variable 2 allot ; - 7 - 8 : d- ( d1 d2 -- d3 ) dnegate d+ ; - 9 -10 Code d2/ ( d1 -- d2 ) -11 A pop D sar A rcr A push Next end-code -12 -13 -14 -15 -Screen 2 not modified - 0 \ dmax dmin du< ks 22 dez 87 - 1 - 2 : dmax ( d1 d2 -- d3 ) - 3 2over 2over d< IF 2swap THEN 2drop ; - 4 - 5 : dmin ( d1 d2 -- d3 ) - 6 2over 2over d< IF 2drop exit THEN 2swap 2drop ; - 7 - 8 : du< ( 32b1 32b2 -- f ) - 9 rot 2dup = IF 2drop u< exit THEN u> -rot 2drop ; -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/double.fth b/sources/msdos/double.fth new file mode 100644 index 0000000..ae88f7b --- /dev/null +++ b/sources/msdos/double.fth @@ -0,0 +1,85 @@ +\ *** Block No. 0 Hexblock 0 +\\ Double words cas 10nov05 + +This File contains definitions for 32Bit Math + +This definitions are already included in the volksFORTH Kernel: + + 2! 2@ 2drop 2dup 2over 2swap d+ d. d.r + d0= d< d= dabs dnegate + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ 2constant 2rot 2variable d- d2/ ks 22 dez 87 + + : 2constant Create , , does> 2@ ; + + : 2rot ( d1 d2 d3 -- d2 d3 d1 ) 5 roll 5 roll ; + + : 2variable Variable 2 allot ; + + : d- ( d1 d2 -- d3 ) dnegate d+ ; + + Code d2/ ( d1 -- d2 ) + A pop D sar A rcr A push Next end-code + + + + +\ *** Block No. 2 Hexblock 2 +\ dmax dmin du< ks 22 dez 87 + + : dmax ( d1 d2 -- d3 ) + 2over 2over d< IF 2swap THEN 2drop ; + + : dmin ( d1 d2 -- d3 ) + 2over 2over d< IF 2drop exit THEN 2swap 2drop ; + + : du< ( 32b1 32b2 -- f ) + rot 2dup = IF 2drop u< exit THEN u> -rot 2drop ; + + + + + + +\ *** Block No. 3 Hexblock 3 + + + + + + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/editor.fb.src b/sources/msdos/editor.fb.src deleted file mode 100644 index 5414a1c..0000000 --- a/sources/msdos/editor.fb.src +++ /dev/null @@ -1,714 +0,0 @@ -Screen 0 not modified - 0 volksFORTH Full-Screen-Editor HELP Screen cas 11nov05 - 1 - 2 Quit Editor : flushed: ESC updated: ^E - 3 discard changes : ^U (UNDO) - 4 move cursor : Cursorkeys (delete with DEL or <- ) - 5 insert : INS (toggle), ^ENTER (insert Screen) - 6 Tabs : TAB (to right), SHIFT TAB (to left) - 7 paging : Pg Dn (next screen), Pg Up (previous scr) - 8 : F9 (alternate), SHIFT F9 (shadow scr) - 9 mark alternate Scr. : F10 -10 delete/insert line : ^Y (delete), ^N (insert) -11 split line : ^PgDn (split), ^PgUp (join) -12 search and replace : F2 (stop with ESC, replace with 'R' ) -13 linebuffer : F3 (push&delete), F5 (push), F7 (pop) -14 charbuffer : F4 (push&delete), F6 (push), F8 (pop) -15 misc : ^F (Fix), ^L (Showload), ^S (Screen #) -Screen 1 not modified - 0 --> \ Full-Screen Editor cas 10nov05 - 1 This is the Full-Screen Editor for MS-DOS volksFORTH - 2 - 3 Features: Line- and Char-Buffer, Find- and Replace, Support for - 4 "Shadow-Screens", View Function and loading of screens with - 5 visual feedback (showload) - 6 - 7 The Keybinding can be easily changed by using the integrated - 8 Keytable. - 9 -10 -11 Ported to the MS-DOS volksFORTH by K.Schleisiek on 22 dez 87 -12 Original design by Ullrich Hoffmann -13 -14 -15 -Screen 2 not modified - 0 \ Load Screen for the Editor cas 10nov05 - 1 - 2 Onlyforth \needs Assembler 2 loadfrom asm.scr - 3 - 4 3 load \ PC adaption - 5 4 9 thru \ Editor - 6 - 7 \ &10 load \ ANSI display interface - 8 \ &11 load \ BIOS display interface - 9 &12 load \ MULTItasking display interface -10 -11 &13 &39 thru \ Editor -12 -13 Onlyforth .( Screen Editor loaded ) cr -14 -15 -Screen 3 not modified - 0 \ BIM adaption UH 11dez88 - 1 - 2 | : ?range ( n -- n ) isfile@ 0=exit dup 0< 9 and ?diskerror - 3 dup capacity - 1+ 0 max ?dup 0=exit more ; - 4 | : block ( n -- adr ) ?range block ; - 5 - 6 $1B Constant #esc - 7 - 8 : curon &11 &12 curshape ; - 9 -10 : curoff &14 dup curshape ; -11 -12 Variable caps caps off -13 -14 Label ?capital 1 # caps #) byte test -15 0= ?[ (capital # jmp ]? ret end-code -Screen 4 not modified - 0 \ search delete insert replace ks 20 dez 87 - 1 - 2 | : delete ( buffer size count -- ) - 3 over min >r r@ - ( left over ) dup 0> - 4 IF 2dup swap dup r@ + -rot swap cmove THEN - 5 + r> bl fill ; - 6 - 7 | : insert ( string length buffer size -- ) - 8 rot over min >r r@ - ( left over ) - 9 over dup r@ + rot cmove> r> cmove ; -10 -11 | : replace ( string length buffer size -- ) -12 rot min cmove ; -13 -14 -15 -Screen 5 not modified - 0 \ usefull definitions and Editor vocabulary UH 11mai88 - 1 - 2 Vocabulary Editor - 3 - 4 ' Forth | Alias [F] immediate - 5 ' Editor | Alias [E] immediate - 6 - 7 Editor also definitions - 8 - 9 | : c ( n --) \ moves cyclic thru the screen -10 r# @ + b/blk mod r# ! ; -11 -12 | Variable r#' r#' off -13 | Variable scr' scr' off -14 ' fromfile | Alias isfile' -15 | Variable lastfile | Variable lastscr | Variable lastr# -Screen 6 not modified - 0 \\ move cursor with position-checking ks 18 dez 87 - 1 \ different versions of cursor positioning error reporting - 2 - 3 | : c ( n --) \ checks the cursor position - 4 r# @ + dup 0 b/blk uwithin not - 5 Abort" There is a border!" r# ! ; - 6 - 7 | : c ( n --) \ goes thru the screens - 8 r# @ + dup b/blk 1- > IF 1 scr +! THEN - 9 dup 0< IF -1 scr +! THEN b/blk mod r# ! ; -10 -11 | : c ( n --) \ moves cyclic thru the screen -12 r# @ + b/blk mod r# ! ; -13 -14 -15 -Screen 7 not modified - 0 \ calculate addresses ks 20 dez 87 - 1 | : *line ( l -- adr ) c/l * ; - 2 | : /line ( n -- c l ) c/l /mod ; - 3 | : top ( -- ) r# off ; - 4 | : cursor ( -- n ) r# @ ; - 5 | : 'start ( -- adr ) scr @ block ; - 6 | : 'end ( -- adr ) 'start b/blk + ; - 7 | : 'cursor ( -- adr ) 'start cursor + ; - 8 | : position ( -- c l ) cursor /line ; - 9 | : line# ( -- l ) position nip ; -10 | : col# ( -- c ) position drop ; -11 | : 'line ( -- adr ) 'start line# *line + ; -12 | : 'line-end ( -- adr ) 'line c/l + 1- ; -13 | : #after ( -- n ) c/l col# - ; -14 | : #remaining ( -- n ) b/blk cursor - ; -15 | : #end ( -- n ) b/blk line# *line - ; -Screen 8 not modified - 0 \ move cursor directed UH 11dez88 - 1 | Create >at 0 , 0 , - 2 | : curup c/l negate c ; - 3 | : curdown c/l c ; - 4 | : curleft -1 c ; - 5 | : curright 1 c ; - 6 - 7 | : +tab ( 1/4 -> ) cursor $10 / 1+ $10 * cursor - c ; - 8 | : -tab ( 1/8 <- ) cursor 8 mod negate dup 0= 8 * + c ; - 9 -10 | : >last ( adr len -- ) -trailing nip b/blk min r# ! ; -11 | : #after c ; -12 | : ( -- ) 'start line# 1+ *line 1- >last ; -15 | : >""end ( -- ) 'start b/blk >last ; -Screen 9 not modified - 0 \ show border UH 29Sep87 - 1 - 2 &14 | Constant dx 1 | Constant dy - 3 - 4 | : horizontal ( row eck1 eck2 -- row' ) - 5 rot dup >r dx 1- at swap emit - 6 c/l 0 DO Ascii - emit LOOP emit r> 1+ ; - 7 - 8 | : vertical ( row -- row' ) - 9 l/s 0 DO dup dx 1- at Ascii | emit -10 row dx c/l + at Ascii | emit 1+ LOOP ; -11 -12 | : border dy 1- Ascii / Ascii \ horizontal -13 vertical Ascii \ Ascii / horizontal drop ; -14 -15 | : edit-at ( -- ) position swap dy dx d+ at ; -Screen 10 not modified - 0 \ ANSI display interface ks 03 feb 88 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 | : redisplay ( line# -- ) - 9 dup dy + dx at *line 'start + c/l type ; -10 -11 | : (done ( -- ) ; immediate -12 -13 -14 | : install-screen ( -- ) l/s 6 + 0 >at 2! page ; -15 -Screen 11 not modified - 0 \ BIOS-display interface ks 03 feb 88 - 1 | Code (.line ( line addr videoseg -- ) - 2 A pop W pop I push E: push D E: mov - 3 $0E # W add W W add A I xchg c/l # C mov - 4 attribut #) A+ mov [[ byte lods stos C0= ?] - 5 E: pop I pop D pop Next end-code - 6 - 7 - 8 | : redisplay ( line# -- ) - 9 dup 1+ c/row * swap c/l * 'start + video@ (.line ; -10 -11 | : (done ( -- ) ; immediate -12 -13 -14 | : install-screen ( -- ) l/s 6 + 0 >at 2! page ; -15 -Screen 12 not modified - 0 \ MULTI-display interface ks UH 10Sep87 - 1 | Code (.line ( line addr videoseg -- ) - 2 C pop W pop I push E: push D E: mov - 3 $0E # W add W W add u' area U D) I mov - 4 u' catt I D) A+ mov C I mov - 5 c/l # C mov [[ byte lods stos C0= ?] - 6 E: pop I pop D pop Next end-code - 7 - 8 | : redisplay ( line# -- ) - 9 dup 1+ c/row * swap c/l * 'start + video@ (.line ; -10 -11 | : (done ( -- ) line# 2+ c/col 2- window ; -12 -13 | : cleartop ( -- ) 0 l/s 5 + window (page ; -14 | : install-screen ( -- ) row l/s 6 + u< -15 IF l/s 6 + 0 full page ELSE at? cleartop THEN >at 2! ; -Screen 13 not modified - 0 \ display screen UH 11mai88 - 1 Forth definitions - 2 : updated? ( -- f) 'start 2- @ 0< ; - 3 Editor definitions - 4 | : .updated ( -- ) 9 0 at - 5 updated? IF 4 spaces ELSE ." not " THEN ." updated" ; - 6 - 7 | : .screen l/s 0 DO I redisplay LOOP ; - 8 \ | : .file ( fcb -- ) - 9 \ ?dup IF body> >name .name exit THEN ." direct" ; -10 | : .title [ DOS ] 1 0 at isfile@ .file dx 1- tab -11 2 0 at drv (.drv scr @ 6 .r -12 4 0 at fromfile @ .file dx 1- tab -13 5 0 at fswap drv (.drv scr' @ 6 .r fswap .updated ; -14 -15 | : .all .title .screen ; -Screen 14 not modified - 0 \ check errors UH 02Nov86 - 1 - 2 | : ?bottom ( -- ) 'end c/l - c/l -trailing nip - 3 Abort" You would lose a line" ; - 4 - 5 | : ?fit ( n -- ) 'line c/l -trailing nip + c/l > - 6 IF line# redisplay - 7 true Abort" You would lose a char" THEN ; - 8 - 9 | : ?end 1 ?fit ; -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ programmer's id ks 18 dez 87 - 1 - 2 $12 | Constant id-len - 3 Create id id-len allot id id-len erase - 4 - 5 | : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; - 6 - 7 | : ?stamp ( -- ) updated? IF stamp THEN ; - 8 - 9 | : ## ( n -- ) base push decimal 0 <# # # #> id 1+ attach ; -10 -11 | : get-id ( -- ) id c@ ?exit ID on -12 cr ." Enter your ID : " at? 3 0 DO Ascii . emit LOOP at -13 id 2+ 3 expect normal span @ dup id 1+ c! 0=exit -14 bl id 1+ append date@ rot ## swap >months id 1+ attach ## ; -15 -Screen 16 not modified - 0 \ update screen-display UH 28Aug87 - 1 - 2 | : emptybuf prev @ 2+ dup on 4+ off ; - 3 - 4 | : undo emptybuf .all ; - 5 - 6 | : modified updated? ?exit update .updated ; - 7 - 8 | : linemodified modified line# redisplay ; - 9 -10 | : screenmodified modified -11 l/s line# ?DO I redisplay LOOP ; -12 -13 | : .modified ( -- ) >at 2@ at space scr @ . -14 updated? not IF ." un" THEN ." modified" ?stamp ; -15 -Screen 17 not modified - 0 \ leave editor UH 10Sep87 - 1 | Variable (pad (pad off - 2 | : memtop ( -- adr) sp@ $100 - ; - 3 - 4 | Create char 1 allot - 5 | Variable imode imode off - 6 | : .imode at? 7 0 at - 7 imode @ IF ." insert " ELSE ." overwrite" THEN at ; - 8 | : setimode imode on .imode ; - 9 | : clrimode imode off .imode ; -10 -11 | : done ( -- ) (done -12 ['] (quit is 'quit ['] (error errorhandler ! quit ; -13 -14 | : update-exit ( -- ) .modified done ; -15 | : flushed-exit ( -- ) .modified save-buffers done ; -Screen 18 not modified - 0 \ handle screens UH 21jan89 - 1 - 2 | : insert-screen ( scr -- ) \ before scr - 3 1 more fromfile push isfile@ fromfile ! - 4 capacity 2- over 1+ convey ; - 5 - 6 | : wipe-screen ( -- ) 'start b/blk blank ; - 7 - 8 | : new-screen ( -- ) - 9 scr @ insert-screen wipe-screen top screenmodified ; -10 -11 -12 -13 -14 -15 -Screen 19 not modified - 0 \ handle lines UH 01Nov86 - 1 - 2 | : (clear-line 'line c/l blank ; - 3 | : clear-line (clear-line linemodified ; - 4 - 5 | : clear> 'cursor #after blank linemodified ; - 6 - 7 | : delete-line 'line #end c/l delete screenmodified ; - 8 - 9 | : backline curup delete-line ; -10 -11 | : (insert-line -12 ?bottom 'line c/l over #end insert (clear-line ; -13 -14 | : insert-line (insert-line screenmodified ; -15 -Screen 20 not modified - 0 \ join and split lines UH 11dez88 - 1 - 2 | : insert-spaces ( n -- ) 'cursor swap - 3 2dup over #remaining insert blank ; - 4 - 5 | : split ( -- ) ?bottom cursor col# insert-spaces r# ! - 6 #after insert-spaces screenmodified ; - 7 - 8 | : delete-characters ( n -- ) 'cursor #remaining rot delete ; - 9 -10 | : join ( -- ) cursor line> col# Abort" next line will not fit!" -12 #after + dup delete-characters -13 cursor c/l rot - dup 0< -14 IF negate insert-spaces ELSE delete-characters THEN r# ! -15 screenmodified ; -Screen 21 not modified - 0 \ handle characters UH 01Nov86 - 1 - 2 | : delete-char 'cursor #after 1 delete linemodified ; - 3 - 4 | : backspace curleft delete-char ; - 5 - 6 | : (insert-char ?end 'cursor 1 over #after insert ; - 7 - 8 - 9 | : insert-char (insert-char bl 'cursor c! linemodified ; -10 -11 | : putchar ( --) char c@ -12 imode @ IF (insert-char THEN -13 'cursor c! linemodified curright ; -14 -15 -Screen 22 not modified - 0 \ stack lines UH 31Oct86 - 1 - 2 | Create lines 4 allot \ { 2+pointer | 2base } - 3 | : 'lines ( -- adr) lines 2@ + ; - 4 - 5 | : @line 'lines memtop u> Abort" line buffer full" - 6 'line 'lines c/l cmove c/l lines +! ; - 7 - 8 | : copyline @line curdown ; - 9 | : line>buf @line delete-line ; -10 -11 | : !line c/l negate lines +! 'lines 'line c/l cmove ; -12 -13 | : buf>line lines @ 0= Abort" line buffer empty" -14 ?bottom (insert-line !line screenmodified ; -15 -Screen 23 not modified - 0 \ stack characters UH 01Nov86 - 1 - 2 | Create chars 4 allot \ { 2+pointer | 2base } - 3 | : 'chars ( -- adr) chars 2@ + ; - 4 - 5 | : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" - 6 'cursor c@ 'chars c! 1 chars +! ; - 7 - 8 | : copychar @char curright ; - 9 | : char>buf @char delete-char ; -10 -11 | : !char -1 chars +! 'chars c@ 'cursor c! ; -12 -13 | : buf>char chars @ 0= Abort" char buffer empty" -14 ?end (insert-char !char linemodified ; -15 -Screen 24 not modified - 0 \ switch screens UH 11mai88 - 1 - 2 | : imprint ( -- ) \ remember valid file - 3 isfile@ lastfile ! scr @ lastscr ! r# @ lastr# ! ; - 4 - 5 | : remember ( -- ) - 6 lastfile @ isfile ! lastscr @ scr ! lastr# @ r# ! ; - 7 - 8 | : associate \ switch to alternate screen - 9 isfile' @ isfile@ isfile' ! isfile ! -10 scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; -11 -12 | : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .all ; -13 | : n ?stamp 1 scr +! .all ; -14 | : b ?stamp -1 scr +! .all ; -15 | : a ?stamp associate .all ; -Screen 25 not modified - 0 \ shadow screens UH 03Nov86 - 1 - 2 Variable shadow shadow off - 3 - 4 | : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; - 5 - 6 | : >shadow ?stamp \ switch to shadow screen - 7 (shadow dup scr @ u> not IF negate THEN scr +! .all ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 26 not modified - 0 \ load and show screens ks 02 mar 88 - 1 - 2 | : showoff ['] exit 'name ! normal ; - 3 - 4 | : show ( -- ) blk @ 0= IF showoff exit THEN - 5 >in @ 1- r# ! edit-at imprint blk @ scr @ - 0=exit - 6 blk @ scr ! normal curoff .all invers curon ; - 7 - 8 | : showload ( -- ) ?stamp save-buffers - 9 ['] show 'name ! curon invers -10 adr .status push ['] noop is .status -11 scr @ scr push scr off r# push r# @ (load showoff ; -12 -13 -14 -15 -Screen 27 not modified - 0 \ find strings ks 20 dez 87 - 1 | Variable insert-buffer - 2 | Variable find-buffer - 3 - 4 | : 'insert ( -- addr ) insert-buffer @ ; - 5 | : 'find ( -- addr ) find-buffer @ ; - 6 - 7 | : .buf ( addr -- ) count type ." |" &80 col - spaces ; - 8 - 9 | : get ( addr -- ) >r at? r@ .buf -10 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN -11 at r> .buf ; -12 -13 | : get-buffers dy l/s + 2+ dx 1- 2dup at -14 ." find: |" 'find get swap 1+ swap 2- at -15 ." ? replace: |" 'insert get ; -Screen 28 not modified - 0 \ ks 20 dez 87 - 1 Code match ( addr1 len1 string -- addr2 len2 ) - 2 D W mov W ) D- mov $FF # D and 0= ?[ D pop Next ]? - 3 W inc D dec C pop I A mov I pop A push - 4 W ) A- mov W inc ?capital # call A- A+ mov D C sub - 5 >= ?[ I inc Label done I dec - 6 A pop I push A I mov C D add Next ]? - 7 [[ byte lods ?capital # call A+ A- cmp 0= - 8 ?[ D D or done 0= not ?] - 9 I push W push C push A push D C mov -10 [[ byte lods ?capital # call A+ A- xchg -11 W ) A- mov W inc ?capital # call A+ A- cmp -12 0= ?[[ C0= ?] A pop C pop -13 W pop I pop done ]] -14 ]? A pop C pop W pop I pop -15 ]? C0= ?] I inc done ]] end-code -Screen 29 not modified - 0 \ search for string UH 11mai88 - 1 - 2 | : skip ( addr -- addr' ) 'find c@ + ; - 3 - 4 | : search ( buf len string -- offset flag ) - 5 >r stash r@ match r> c@ < - 6 IF drop 0= false exit THEN swap - true ; - 7 - 8 | : find? ( -- r# f ) 'cursor #remaining 'find search ; - 9 -10 | : searchthru ( -- r# scr ) -11 find? IF skip cursor + scr @ exit THEN drop -12 capacity scr @ 1+ -13 ?DO I 2 3 at 6 .r I block b/blk 'find search -14 IF skip I endloop exit THEN stop? Abort" Break!" -15 LOOP true Abort" not found!" ; -Screen 30 not modified - 0 \ replace strings UH 14mai88 - 1 | : replace? ( -- f ) dy l/s + 3+ dx 3 - at - 2 key dup #cr = IF line# redisplay true Abort" Break!" THEN - 3 capital Ascii R = ; - 4 - 5 | : "mark ( -- ) r# push - 6 'find count dup negate c edit-at invers type normal ; - 7 - 8 | : (replace 'insert c@ 'find c@ - ?fit - 9 r# push 'find c@ negate c -10 'cursor #after 'find c@ delete -11 'insert count 'cursor #after insert modified ; -12 -13 | : "replace get-buffers BEGIN searchthru -14 scr @ - ?dup IF ?stamp scr +! .all THEN r# ! imprint -15 "mark replace? IF (replace THEN line# redisplay REPEAT ; -Screen 31 not modified - 0 \ Display Help-Screen, misc commands cas 11nov05 - 1 - 2 | : helpfile ( -- ) fromfile push editor.fb ; - 3 | : .help ( --) - 4 isfile push scr push helpfile scr off .screen ; - 5 | : help ( -- ) .help key drop .screen ; - 6 - 7 | : screen# ( -- scr ) scr @ ; - 8 - 9 | Defer (fix-word -10 -11 | : fix-word ( -- ) isfile@ loadfile ! -12 scr @ blk ! cursor >in ! (fix-word ; -13 -14 -15 -Screen 32 not modified - 0 \ Control-Characters IBM-PC Functionkeys UH 10Sep87 - 1 - 2 Forth definitions - 3 - 4 : Ctrl ( -- c ) - 5 name 1+ c@ $1F and state @ IF [compile] Literal THEN ; - 6 immediate - 7 - 8 \needs #del $7F Constant #del - 9 -10 Editor definitions -11 -12 | : flipimode imode @ 0= imode ! .imode ; -13 -14 | : F ( # -- 16b ) $FFC6 swap - ; -15 | : shift ( n -- n' ) dup 0< + &24 - ; -Screen 33 not modified - 0 \ Control-Characters IBM-PC Functionkeys UH 11dez88 - 1 - 2 Create keytable - 3 -&72 , -&75 , -&80 , -&77 , - 4 3 F , 4 F , 7 F , 8 F , - 5 Ctrl F , Ctrl S , 5 F , 6 F , - 6 1 F , Ctrl H , #del , -&83 , - 7 Ctrl Y , Ctrl N , - 8 -&82 , - 9 #cr , #tab , #tab shift , -10 -&119 , -&117 , 2 F , Ctrl U , -11 Ctrl E , #esc , Ctrl L , 9 F shift , -12 -&81 , -&73 , 9 F , &10 F , -13 -&71 , -&79 , -&118 , -&132 , -14 #lf , -15 here keytable - 2/ Constant #keys -Screen 34 not modified - 0 \ Try a screen Editor UH 11dez88 - 1 - 2 Create: actiontable - 3 curup curleft curdown curright - 4 line>buf char>buf buf>line buf>char - 5 fix-word screen# copyline copychar - 6 help backspace backspace delete-char - 7 ( insert-char ) delete-line insert-line - 8 flipimode ( clear-line clear> ) - 9 +tab -tab -10 top >""end "replace undo -11 update-exit flushed-exit showload >shadow -12 n b a mark -13 split join -14 new-screen ; -15 here actiontable - 2/ 1- #keys - abort( # of actions) -Screen 35 not modified - 0 \ find keys ks 20 dez 87 - 1 - 2 | : findkey ( key -- adr/default ) - 3 #keys 0 DO dup keytable [F] I 2* + @ = - 4 IF drop [E] actiontable [F] I 2* + @ endloop exit THEN - 5 LOOP drop ['] putchar ; - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 36 not modified - 0 \ allocate buffers UH 01Nov86 - 1 - 2 c/l 2* | Constant cstack-size - 3 - 4 | : nextbuf ( adr -- adr' ) cstack-size + ; - 5 - 6 | : ?clearbuffer pad (pad @ = ?exit - 7 pad dup (pad ! - 8 nextbuf dup find-buffer ! 'find off - 9 nextbuf dup insert-buffer ! 'insert off -10 nextbuf dup 0 chars 2! -11 nextbuf 0 lines 2! ; -12 -13 -14 -15 -Screen 37 not modified - 0 \ enter and exit the editor, editor's loop UH 11mai88 - 1 - 2 | Variable jingle jingle on | : bell 07 charout jingle off ; - 3 - 4 | : clear-error ( -- ) - 5 jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; - 6 - 7 | : fullquit ( -- ) BEGIN ?clearbuffer edit-at key dup char c! - 8 findkey imprint execute ( .status ) clear-error REPEAT ; - 9 -10 | : fullerror ( string -- ) jingle @ IF bell THEN count -11 dy l/s + 1+ over 2/ dx $20 + swap - at invers type normal -12 &80 col - spaces remember .all quit ; -13 -14 | : install ( -- ) -15 ['] fullquit Is 'quit ['] fullerror errorhandler ! ; -Screen 38 not modified - 0 \ enter and exit the Editor UH 11mai88 - 1 - 2 Forth definitions - 3 - 4 : v ( -- ) - 5 [E] 'start drop get-id install-screen - 6 install ?clearbuffer - 7 border .all .imode .status quit ; - 8 - 9 ' v Alias ed -10 -11 : l ( scr -- ) 1 arguments scr ! [E] top [F] v ; -12 -13 ' l Alias edit -14 -15 -Screen 39 not modified - 0 \ savesystem enhanced view UH 24jun88 - 1 - 2 : savesystem [E] id off (pad off savesystem ; - 3 - 4 Editor definitions - 5 | : >find ?clearbuffer >in push - 6 name dup c@ 2+ >r bl over c! r> 'find place ; - 7 - 8 Forth definitions - 9 : fix [ Dos ] >find ' @view >file -10 isfile ! scr ! [E] top curdown -11 find? IF skip 1- THEN c v ; -12 -13 ' fix Is (fix-word -14 -15 -Screen 40 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 41 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/editor.fth b/sources/msdos/editor.fth new file mode 100644 index 0000000..011f519 --- /dev/null +++ b/sources/msdos/editor.fth @@ -0,0 +1,714 @@ +\ *** Block No. 0 Hexblock 0 + volksFORTH Full-Screen-Editor HELP Screen cas 11nov05 + +Quit Editor : flushed: ESC updated: ^E +discard changes : ^U (UNDO) +move cursor : Cursorkeys (delete with DEL or <- ) +insert : INS (toggle), ^ENTER (insert Screen) +Tabs : TAB (to right), SHIFT TAB (to left) +paging : Pg Dn (next screen), Pg Up (previous scr) + : F9 (alternate), SHIFT F9 (shadow scr) +mark alternate Scr. : F10 +delete/insert line : ^Y (delete), ^N (insert) +split line : ^PgDn (split), ^PgUp (join) +search and replace : F2 (stop with ESC, replace with 'R' ) +linebuffer : F3 (push&delete), F5 (push), F7 (pop) +charbuffer : F4 (push&delete), F6 (push), F8 (pop) +misc : ^F (Fix), ^L (Showload), ^S (Screen #) +\ *** Block No. 1 Hexblock 1 +--> \ Full-Screen Editor cas 10nov05 +This is the Full-Screen Editor for MS-DOS volksFORTH + +Features: Line- and Char-Buffer, Find- and Replace, Support for +"Shadow-Screens", View Function and loading of screens with +visual feedback (showload) + +The Keybinding can be easily changed by using the integrated +Keytable. + + +Ported to the MS-DOS volksFORTH by K.Schleisiek on 22 dez 87 +Original design by Ullrich Hoffmann + + + +\ *** Block No. 2 Hexblock 2 +\ Load Screen for the Editor cas 10nov05 + + Onlyforth \needs Assembler 2 loadfrom asm.scr + + 3 load \ PC adaption + 4 9 thru \ Editor + +\ &10 load \ ANSI display interface +\ &11 load \ BIOS display interface + &12 load \ MULTItasking display interface + +&13 &39 thru \ Editor + +Onlyforth .( Screen Editor loaded ) cr + + +\ *** Block No. 3 Hexblock 3 +\ BIM adaption UH 11dez88 + +| : ?range ( n -- n ) isfile@ 0=exit dup 0< 9 and ?diskerror + dup capacity - 1+ 0 max ?dup 0=exit more ; +| : block ( n -- adr ) ?range block ; + + $1B Constant #esc + + : curon &11 &12 curshape ; + + : curoff &14 dup curshape ; + + Variable caps caps off + + Label ?capital 1 # caps #) byte test + 0= ?[ (capital # jmp ]? ret end-code +\ *** Block No. 4 Hexblock 4 +\ search delete insert replace ks 20 dez 87 + +| : delete ( buffer size count -- ) + over min >r r@ - ( left over ) dup 0> + IF 2dup swap dup r@ + -rot swap cmove THEN + + r> bl fill ; + +| : insert ( string length buffer size -- ) + rot over min >r r@ - ( left over ) + over dup r@ + rot cmove> r> cmove ; + +| : replace ( string length buffer size -- ) + rot min cmove ; + + + +\ *** Block No. 5 Hexblock 5 +\ usefull definitions and Editor vocabulary UH 11mai88 + +Vocabulary Editor + +' Forth | Alias [F] immediate +' Editor | Alias [E] immediate + +Editor also definitions + +| : c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + +| Variable r#' r#' off +| Variable scr' scr' off +' fromfile | Alias isfile' +| Variable lastfile | Variable lastscr | Variable lastr# +\ *** Block No. 6 Hexblock 6 +\\ move cursor with position-checking ks 18 dez 87 +\ different versions of cursor positioning error reporting + +| : c ( n --) \ checks the cursor position + r# @ + dup 0 b/blk uwithin not + Abort" There is a border!" r# ! ; + +| : c ( n --) \ goes thru the screens + r# @ + dup b/blk 1- > IF 1 scr +! THEN + dup 0< IF -1 scr +! THEN b/blk mod r# ! ; + +| : c ( n --) \ moves cyclic thru the screen + r# @ + b/blk mod r# ! ; + + + +\ *** Block No. 7 Hexblock 7 +\ calculate addresses ks 20 dez 87 +| : *line ( l -- adr ) c/l * ; +| : /line ( n -- c l ) c/l /mod ; +| : top ( -- ) r# off ; +| : cursor ( -- n ) r# @ ; +| : 'start ( -- adr ) scr @ block ; +| : 'end ( -- adr ) 'start b/blk + ; +| : 'cursor ( -- adr ) 'start cursor + ; +| : position ( -- c l ) cursor /line ; +| : line# ( -- l ) position nip ; +| : col# ( -- c ) position drop ; +| : 'line ( -- adr ) 'start line# *line + ; +| : 'line-end ( -- adr ) 'line c/l + 1- ; +| : #after ( -- n ) c/l col# - ; +| : #remaining ( -- n ) b/blk cursor - ; +| : #end ( -- n ) b/blk line# *line - ; +\ *** Block No. 8 Hexblock 8 +\ move cursor directed UH 11dez88 +| Create >at 0 , 0 , +| : curup c/l negate c ; +| : curdown c/l c ; +| : curleft -1 c ; +| : curright 1 c ; + +| : +tab ( 1/4 -> ) cursor $10 / 1+ $10 * cursor - c ; +| : -tab ( 1/8 <- ) cursor 8 mod negate dup 0= 8 * + c ; + +| : >last ( adr len -- ) -trailing nip b/blk min r# ! ; +| : #after c ; +| : ( -- ) 'start line# 1+ *line 1- >last ; +| : >""end ( -- ) 'start b/blk >last ; +\ *** Block No. 9 Hexblock 9 +\ show border UH 29Sep87 + +&14 | Constant dx 1 | Constant dy + +| : horizontal ( row eck1 eck2 -- row' ) + rot dup >r dx 1- at swap emit + c/l 0 DO Ascii - emit LOOP emit r> 1+ ; + +| : vertical ( row -- row' ) + l/s 0 DO dup dx 1- at Ascii | emit + row dx c/l + at Ascii | emit 1+ LOOP ; + +| : border dy 1- Ascii / Ascii \ horizontal + vertical Ascii \ Ascii / horizontal drop ; + +| : edit-at ( -- ) position swap dy dx d+ at ; +\ *** Block No. 10 Hexblock A +\ ANSI display interface ks 03 feb 88 + + + + + + + +| : redisplay ( line# -- ) + dup dy + dx at *line 'start + c/l type ; + +| : (done ( -- ) ; immediate + + +| : install-screen ( -- ) l/s 6 + 0 >at 2! page ; + +\ *** Block No. 11 Hexblock B +\ BIOS-display interface ks 03 feb 88 +| Code (.line ( line addr videoseg -- ) + A pop W pop I push E: push D E: mov + $0E # W add W W add A I xchg c/l # C mov + attribut #) A+ mov [[ byte lods stos C0= ?] + E: pop I pop D pop Next end-code + + +| : redisplay ( line# -- ) + dup 1+ c/row * swap c/l * 'start + video@ (.line ; + +| : (done ( -- ) ; immediate + + +| : install-screen ( -- ) l/s 6 + 0 >at 2! page ; + +\ *** Block No. 12 Hexblock C +\ MULTI-display interface ks UH 10Sep87 +| Code (.line ( line addr videoseg -- ) + C pop W pop I push E: push D E: mov + $0E # W add W W add u' area U D) I mov + u' catt I D) A+ mov C I mov + c/l # C mov [[ byte lods stos C0= ?] + E: pop I pop D pop Next end-code + +| : redisplay ( line# -- ) + dup 1+ c/row * swap c/l * 'start + video@ (.line ; + +| : (done ( -- ) line# 2+ c/col 2- window ; + +| : cleartop ( -- ) 0 l/s 5 + window (page ; +| : install-screen ( -- ) row l/s 6 + u< + IF l/s 6 + 0 full page ELSE at? cleartop THEN >at 2! ; +\ *** Block No. 13 Hexblock D +\ display screen UH 11mai88 +Forth definitions +: updated? ( -- f) 'start 2- @ 0< ; +Editor definitions +| : .updated ( -- ) 9 0 at + updated? IF 4 spaces ELSE ." not " THEN ." updated" ; + +| : .screen l/s 0 DO I redisplay LOOP ; +\ | : .file ( fcb -- ) +\ ?dup IF body> >name .name exit THEN ." direct" ; +| : .title [ DOS ] 1 0 at isfile@ .file dx 1- tab + 2 0 at drv (.drv scr @ 6 .r + 4 0 at fromfile @ .file dx 1- tab + 5 0 at fswap drv (.drv scr' @ 6 .r fswap .updated ; + +| : .all .title .screen ; +\ *** Block No. 14 Hexblock E +\ check errors UH 02Nov86 + +| : ?bottom ( -- ) 'end c/l - c/l -trailing nip + Abort" You would lose a line" ; + +| : ?fit ( n -- ) 'line c/l -trailing nip + c/l > + IF line# redisplay + true Abort" You would lose a char" THEN ; + +| : ?end 1 ?fit ; + + + + + + +\ *** Block No. 15 Hexblock F +\ programmer's id ks 18 dez 87 + +$12 | Constant id-len +Create id id-len allot id id-len erase + +| : stamp ( -- ) id 1+ count 'start c/l + over - swap cmove ; + +| : ?stamp ( -- ) updated? IF stamp THEN ; + +| : ## ( n -- ) base push decimal 0 <# # # #> id 1+ attach ; + +| : get-id ( -- ) id c@ ?exit ID on + cr ." Enter your ID : " at? 3 0 DO Ascii . emit LOOP at + id 2+ 3 expect normal span @ dup id 1+ c! 0=exit + bl id 1+ append date@ rot ## swap >months id 1+ attach ## ; + +\ *** Block No. 16 Hexblock 10 +\ update screen-display UH 28Aug87 + +| : emptybuf prev @ 2+ dup on 4+ off ; + +| : undo emptybuf .all ; + +| : modified updated? ?exit update .updated ; + +| : linemodified modified line# redisplay ; + +| : screenmodified modified + l/s line# ?DO I redisplay LOOP ; + +| : .modified ( -- ) >at 2@ at space scr @ . + updated? not IF ." un" THEN ." modified" ?stamp ; + +\ *** Block No. 17 Hexblock 11 +\ leave editor UH 10Sep87 +| Variable (pad (pad off +| : memtop ( -- adr) sp@ $100 - ; + +| Create char 1 allot +| Variable imode imode off +| : .imode at? 7 0 at + imode @ IF ." insert " ELSE ." overwrite" THEN at ; +| : setimode imode on .imode ; +| : clrimode imode off .imode ; + +| : done ( -- ) (done + ['] (quit is 'quit ['] (error errorhandler ! quit ; + +| : update-exit ( -- ) .modified done ; +| : flushed-exit ( -- ) .modified save-buffers done ; +\ *** Block No. 18 Hexblock 12 +\ handle screens UH 21jan89 + +| : insert-screen ( scr -- ) \ before scr + 1 more fromfile push isfile@ fromfile ! + capacity 2- over 1+ convey ; + +| : wipe-screen ( -- ) 'start b/blk blank ; + +| : new-screen ( -- ) + scr @ insert-screen wipe-screen top screenmodified ; + + + + + + +\ *** Block No. 19 Hexblock 13 +\ handle lines UH 01Nov86 + +| : (clear-line 'line c/l blank ; +| : clear-line (clear-line linemodified ; + +| : clear> 'cursor #after blank linemodified ; + +| : delete-line 'line #end c/l delete screenmodified ; + +| : backline curup delete-line ; + +| : (insert-line + ?bottom 'line c/l over #end insert (clear-line ; + +| : insert-line (insert-line screenmodified ; + +\ *** Block No. 20 Hexblock 14 +\ join and split lines UH 11dez88 + +| : insert-spaces ( n -- ) 'cursor swap + 2dup over #remaining insert blank ; + +| : split ( -- ) ?bottom cursor col# insert-spaces r# ! + #after insert-spaces screenmodified ; + +| : delete-characters ( n -- ) 'cursor #remaining rot delete ; + +| : join ( -- ) cursor line> col# Abort" next line will not fit!" + #after + dup delete-characters + cursor c/l rot - dup 0< + IF negate insert-spaces ELSE delete-characters THEN r# ! + screenmodified ; +\ *** Block No. 21 Hexblock 15 +\ handle characters UH 01Nov86 + +| : delete-char 'cursor #after 1 delete linemodified ; + +| : backspace curleft delete-char ; + +| : (insert-char ?end 'cursor 1 over #after insert ; + + +| : insert-char (insert-char bl 'cursor c! linemodified ; + +| : putchar ( --) char c@ + imode @ IF (insert-char THEN + 'cursor c! linemodified curright ; + + +\ *** Block No. 22 Hexblock 16 +\ stack lines UH 31Oct86 + +| Create lines 4 allot \ { 2+pointer | 2base } +| : 'lines ( -- adr) lines 2@ + ; + +| : @line 'lines memtop u> Abort" line buffer full" + 'line 'lines c/l cmove c/l lines +! ; + +| : copyline @line curdown ; +| : line>buf @line delete-line ; + +| : !line c/l negate lines +! 'lines 'line c/l cmove ; + +| : buf>line lines @ 0= Abort" line buffer empty" + ?bottom (insert-line !line screenmodified ; + +\ *** Block No. 23 Hexblock 17 +\ stack characters UH 01Nov86 + +| Create chars 4 allot \ { 2+pointer | 2base } +| : 'chars ( -- adr) chars 2@ + ; + +| : @char 'chars 1- lines 2+ @ u> Abort" char buffer full" + 'cursor c@ 'chars c! 1 chars +! ; + +| : copychar @char curright ; +| : char>buf @char delete-char ; + +| : !char -1 chars +! 'chars c@ 'cursor c! ; + +| : buf>char chars @ 0= Abort" char buffer empty" + ?end (insert-char !char linemodified ; + +\ *** Block No. 24 Hexblock 18 +\ switch screens UH 11mai88 + +| : imprint ( -- ) \ remember valid file + isfile@ lastfile ! scr @ lastscr ! r# @ lastr# ! ; + +| : remember ( -- ) + lastfile @ isfile ! lastscr @ scr ! lastr# @ r# ! ; + +| : associate \ switch to alternate screen + isfile' @ isfile@ isfile' ! isfile ! + scr' @ scr @ scr' ! scr ! r#' @ r# @ r#' ! r# ! ; + +| : mark isfile@ isfile' ! scr @ scr' ! r# @ r#' ! .all ; +| : n ?stamp 1 scr +! .all ; +| : b ?stamp -1 scr +! .all ; +| : a ?stamp associate .all ; +\ *** Block No. 25 Hexblock 19 +\ shadow screens UH 03Nov86 + +Variable shadow shadow off + +| : (shadow isfile@ IF capacity 2/ exit THEN shadow @ ; + +| : >shadow ?stamp \ switch to shadow screen + (shadow dup scr @ u> not IF negate THEN scr +! .all ; + + + + + + + + +\ *** Block No. 26 Hexblock 1A +\ load and show screens ks 02 mar 88 + +| : showoff ['] exit 'name ! normal ; + +| : show ( -- ) blk @ 0= IF showoff exit THEN + >in @ 1- r# ! edit-at imprint blk @ scr @ - 0=exit + blk @ scr ! normal curoff .all invers curon ; + +| : showload ( -- ) ?stamp save-buffers + ['] show 'name ! curon invers + adr .status push ['] noop is .status + scr @ scr push scr off r# push r# @ (load showoff ; + + + + +\ *** Block No. 27 Hexblock 1B +\ find strings ks 20 dez 87 +| Variable insert-buffer +| Variable find-buffer + +| : 'insert ( -- addr ) insert-buffer @ ; +| : 'find ( -- addr ) find-buffer @ ; + +| : .buf ( addr -- ) count type ." |" &80 col - spaces ; + +| : get ( addr -- ) >r at? r@ .buf + 2dup at r@ 1+ c/l expect span @ ?dup IF r@ c! THEN + at r> .buf ; + +| : get-buffers dy l/s + 2+ dx 1- 2dup at + ." find: |" 'find get swap 1+ swap 2- at + ." ? replace: |" 'insert get ; +\ *** Block No. 28 Hexblock 1C +\ ks 20 dez 87 + Code match ( addr1 len1 string -- addr2 len2 ) + D W mov W ) D- mov $FF # D and 0= ?[ D pop Next ]? + W inc D dec C pop I A mov I pop A push + W ) A- mov W inc ?capital # call A- A+ mov D C sub + >= ?[ I inc Label done I dec + A pop I push A I mov C D add Next ]? + [[ byte lods ?capital # call A+ A- cmp 0= + ?[ D D or done 0= not ?] + I push W push C push A push D C mov + [[ byte lods ?capital # call A+ A- xchg + W ) A- mov W inc ?capital # call A+ A- cmp + 0= ?[[ C0= ?] A pop C pop + W pop I pop done ]] + ]? A pop C pop W pop I pop + ]? C0= ?] I inc done ]] end-code +\ *** Block No. 29 Hexblock 1D +\ search for string UH 11mai88 + +| : skip ( addr -- addr' ) 'find c@ + ; + +| : search ( buf len string -- offset flag ) + >r stash r@ match r> c@ < + IF drop 0= false exit THEN swap - true ; + +| : find? ( -- r# f ) 'cursor #remaining 'find search ; + +| : searchthru ( -- r# scr ) + find? IF skip cursor + scr @ exit THEN drop + capacity scr @ 1+ + ?DO I 2 3 at 6 .r I block b/blk 'find search + IF skip I endloop exit THEN stop? Abort" Break!" + LOOP true Abort" not found!" ; +\ *** Block No. 30 Hexblock 1E +\ replace strings UH 14mai88 +| : replace? ( -- f ) dy l/s + 3+ dx 3 - at + key dup #cr = IF line# redisplay true Abort" Break!" THEN + capital Ascii R = ; + +| : "mark ( -- ) r# push + 'find count dup negate c edit-at invers type normal ; + +| : (replace 'insert c@ 'find c@ - ?fit + r# push 'find c@ negate c + 'cursor #after 'find c@ delete + 'insert count 'cursor #after insert modified ; + +| : "replace get-buffers BEGIN searchthru + scr @ - ?dup IF ?stamp scr +! .all THEN r# ! imprint + "mark replace? IF (replace THEN line# redisplay REPEAT ; +\ *** Block No. 31 Hexblock 1F +\ Display Help-Screen, misc commands cas 11nov05 + +| : helpfile ( -- ) fromfile push editor.fb ; +| : .help ( --) + isfile push scr push helpfile scr off .screen ; +| : help ( -- ) .help key drop .screen ; + +| : screen# ( -- scr ) scr @ ; + +| Defer (fix-word + +| : fix-word ( -- ) isfile@ loadfile ! + scr @ blk ! cursor >in ! (fix-word ; + + + +\ *** Block No. 32 Hexblock 20 +\ Control-Characters IBM-PC Functionkeys UH 10Sep87 + +Forth definitions + +: Ctrl ( -- c ) + name 1+ c@ $1F and state @ IF [compile] Literal THEN ; +immediate + +\needs #del $7F Constant #del + +Editor definitions + +| : flipimode imode @ 0= imode ! .imode ; + +| : F ( # -- 16b ) $FFC6 swap - ; +| : shift ( n -- n' ) dup 0< + &24 - ; +\ *** Block No. 33 Hexblock 21 +\ Control-Characters IBM-PC Functionkeys UH 11dez88 + +Create keytable +-&72 , -&75 , -&80 , -&77 , + 3 F , 4 F , 7 F , 8 F , +Ctrl F , Ctrl S , 5 F , 6 F , + 1 F , Ctrl H , #del , -&83 , + Ctrl Y , Ctrl N , +-&82 , + #cr , #tab , #tab shift , + -&119 , -&117 , 2 F , Ctrl U , +Ctrl E , #esc , Ctrl L , 9 F shift , +-&81 , -&73 , 9 F , &10 F , +-&71 , -&79 , -&118 , -&132 , +#lf , +here keytable - 2/ Constant #keys +\ *** Block No. 34 Hexblock 22 +\ Try a screen Editor UH 11dez88 + +Create: actiontable +curup curleft curdown curright +line>buf char>buf buf>line buf>char +fix-word screen# copyline copychar +help backspace backspace delete-char +( insert-char ) delete-line insert-line +flipimode ( clear-line clear> ) + +tab -tab +top >""end "replace undo +update-exit flushed-exit showload >shadow +n b a mark + split join +new-screen ; +here actiontable - 2/ 1- #keys - abort( # of actions) +\ *** Block No. 35 Hexblock 23 +\ find keys ks 20 dez 87 + +| : findkey ( key -- adr/default ) + #keys 0 DO dup keytable [F] I 2* + @ = + IF drop [E] actiontable [F] I 2* + @ endloop exit THEN + LOOP drop ['] putchar ; + + + + + + + + + + +\ *** Block No. 36 Hexblock 24 +\ allocate buffers UH 01Nov86 + +c/l 2* | Constant cstack-size + +| : nextbuf ( adr -- adr' ) cstack-size + ; + +| : ?clearbuffer pad (pad @ = ?exit + pad dup (pad ! + nextbuf dup find-buffer ! 'find off + nextbuf dup insert-buffer ! 'insert off + nextbuf dup 0 chars 2! + nextbuf 0 lines 2! ; + + + + +\ *** Block No. 37 Hexblock 25 +\ enter and exit the editor, editor's loop UH 11mai88 + +| Variable jingle jingle on | : bell 07 charout jingle off ; + +| : clear-error ( -- ) + jingle @ ?exit dy l/s + 1+ dx at c/l spaces jingle on ; + +| : fullquit ( -- ) BEGIN ?clearbuffer edit-at key dup char c! + findkey imprint execute ( .status ) clear-error REPEAT ; + +| : fullerror ( string -- ) jingle @ IF bell THEN count + dy l/s + 1+ over 2/ dx $20 + swap - at invers type normal + &80 col - spaces remember .all quit ; + +| : install ( -- ) + ['] fullquit Is 'quit ['] fullerror errorhandler ! ; +\ *** Block No. 38 Hexblock 26 +\ enter and exit the Editor UH 11mai88 + +Forth definitions + +: v ( -- ) + [E] 'start drop get-id install-screen + install ?clearbuffer + border .all .imode .status quit ; + + ' v Alias ed + +: l ( scr -- ) 1 arguments scr ! [E] top [F] v ; + + ' l Alias edit + + +\ *** Block No. 39 Hexblock 27 +\ savesystem enhanced view UH 24jun88 + +: savesystem [E] id off (pad off savesystem ; + +Editor definitions +| : >find ?clearbuffer >in push + name dup c@ 2+ >r bl over c! r> 'find place ; + +Forth definitions +: fix [ Dos ] >find ' @view >file + isfile ! scr ! [E] top curdown + find? IF skip 1- THEN c v ; + +' fix Is (fix-word + + +\ *** Block No. 40 Hexblock 28 + + + + + + + + + + + + + + + + +\ *** Block No. 41 Hexblock 29 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/emu2-4th.fth b/sources/msdos/emu2-4th.fth new file mode 100644 index 0000000..6ffbe11 --- /dev/null +++ b/sources/msdos/emu2-4th.fth @@ -0,0 +1,85 @@ +\ *** Block No. 0 Hexblock 0 +\\ Startup: Load Standard System cas 10nov05 + +This file contains commands to create a full volksFORTH from the +KERNEL.COM file. + +The new system will be saved as "VOLKS4TH.COM". + +If needed this file must be adapted with the simple editor in +MINIMAL.COM to create a volksFORTH that can work with not +100% compatible display hardware. + + + + + + +\ *** Block No. 1 Hexblock 1 +\ System LOAD-Screen for MS-DOS volksFORTH cas 18jul20 + Onlyforth warning off + + include asm.fb + include extend.fb + include multi.vid + include dos.fb + include tasker.fb + include timer.fb + include tools.fb + include neditor.fb + include graphic.prn + + warning on clear status on .status + savesystem volks4th.com bell + .( new system saved as VOLKS4TH.COM ) cr +\ *** Block No. 2 Hexblock 2 + + + + + + + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 + + + + + + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/extend.fb.src b/sources/msdos/extend.fb.src deleted file mode 100644 index 6defeb0..0000000 --- a/sources/msdos/extend.fb.src +++ /dev/null @@ -1,187 +0,0 @@ -Screen 0 not modified - 0 \ ks 11 mai 88 - 1 Dieses File enth„lt Definitionen, die zum Laden der weiteren - 2 System- und Applikationsfiles ben”tigt werden. - 3 - 4 Unter anderem finden sich hier auch MS-DOS spezifische - 5 Befehle wie zum Beispiel das Allokieren von Speicher- - 6 platz ausserhalb des auf 64k begrenzten Forthsystems - 7 und einige Routinen, die das Arbeiten mit dem Video- - 8 Display erleichtern sowie einige Operatoren zur String- - 9 manipulation. -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ loadscreen for often used words ks cas 25sep16 - 1 - 2 Onlyforth \needs Assembler 2 loadfrom asm.fb - 3 - 4 ' save-buffers Alias sav - 5 - 6 ' name &12 + Constant 'name - 7 - 8 ' page Alias cls - 9 -10 1 8 +thru .( Systemerweiterung geladen) cr -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ Postkernel words ks 22 dez 87 - 1 - 2 : blank ( addr quan -- ) bl fill ; - 3 - 4 Code stash ( u1 u2 -- u1 u1 u2 ) - 5 S W mov W ) push Next end-code - 6 \ : stash ( u1 u2 -- u1 u1 u2 ) over swap ; - 7 - 8 : >expect ( addr len -- ) stash expect span @ over place ; - 9 -10 : .field ( addr len quan -- ) -11 over - >r type r> 0 max spaces ; -12 -13 : tab ( n -- ) col - 0 max spaces ; -14 -15 -Screen 3 not modified - 0 \ postkernel ks 08 m„r 89 - 1 \ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT - 2 - 3 \needs end-code : end-code toss also ; - 4 - 5 : u? ( addr -- ) @ u. ; - 6 - 7 : adr ' >body state @ 0=exit [compile] Literal ; immediate - 8 - 9 : Abort( ( f -- ) IF [compile] .( true abort" !" THEN -10 [compile] ( ; -11 -12 : arguments ( n -- ) -13 depth 1- > Error" zu wenige Parameter" ; -14 -15 -Screen 4 not modified - 0 \ MS-DOS memory management - 1 - 2 Code lallocate ( pages -- seg ff / rest err# ) - 3 R push D R mov $48 # A+ mov $21 int CS - 4 ?[ A D xchg A pop R push A R xchg - 5 ][ R pop A push 0 # D mov ]? Next end-code - 6 - 7 Code lfree ( seg -- err# ) - 8 E: push D E: mov $49 # A+ mov $21 int CS - 9 ?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ postkernel ks 03 aug 87 - 1 - 2 c/row c/col * 2* Constant c/dis \ characters per display - 3 - 4 Code video@ ( -- seg ) D push R D mov $F # A+ mov - 5 $10 int R D xchg 0 # D- mov 7 # A- cmp - 6 0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next - 7 end-code - 8 - 9 : savevideo ( -- seg / ff ) -10 [ c/dis b/seg /mod swap 0<> - ] Literal lallocate -11 IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ; -12 -13 : restorevideo ( seg -- ) ?dup 0=exit -14 dup 0 video@ 0 c/dis lmove lfree drop ; -15 -Screen 6 not modified - 0 \ string operators append attach ks 21 jun 87 - 1 - 2 | : .stringoverflow true Abort" String zu lang" ; - 3 - 4 Code append ( char addr -- ) - 5 D W mov D pop W ) A- mov 1 # A- add CS - 6 ?[ ;c: .stringoverflow ; Assembler ]? - 7 A- W ) mov 0 # A+ mov A W add - 8 D- W ) mov D pop Next end-code - 9 -10 Code attach ( addr len addr1 -- ) D W mov C pop -11 I D mov I pop W ) A- mov A- A+ mov C- A+ add CS -12 ?[ ;c: .stringoverflow ; Assembler ]? -13 A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc -14 rep byte movs D I mov D pop Next end-code -15 -Screen 7 not modified - 0 \\ string operators append attach detract ks 21 jun 87 - 1 - 2 : append ( char addr -- ) - 3 under count + c! dup c@ 1+ swap c! ; - 4 - 5 : attach ( addr len addr.to -- ) - 6 >r under r@ count + swap move r@ c@ + r> c! ; - 7 - 8 : detract ( addr -- char ) - 9 dup c@ 1- dup 0> and over c! -10 count >r dup count -rot swap r> cmove ; -11 -12 -13 -14 -15 -Screen 8 not modified - 0 \ ?" string operator ks 09 feb 88 - 1 - 2 \ : (?" ( 8b -- index ) "lit under count rot - 3 \ scan IF swap - exit THEN 2drop false ; - 4 - 5 | Create months ," janfebm„raprmaijunjulaugsepoktnovdez" - 6 - 7 : >months ( n -- addr len ) 3 * 2- months + 3 ; - 8 - 9 | Code (?" ( 8b -- index ) -10 A D xchg I ) C- mov 0 # C+ mov C I add -11 I W mov I inc std 0<>rep byte scas cld -12 0= ?[ C inc ]? C D mov Next -13 end-code -14 -15 : ?" compile (?" ," align ; immediate restrict -Screen 9 not modified - 0 \ Conditional compilation ks 12 dez 88 - 1 | Defer cond - 2 - 3 : .THEN ; immediate - 4 - 5 : .ELSE ( -- ) 0 - 6 BEGIN name nullstring? IF drop exit THEN - 7 find IF cond -1 case? ?exit ELSE drop THEN - 8 REPEAT ; immediate - 9 -10 : .IF ( f -- ) ?exit [compile] .ELSE ; immediate -11 -12 | : (cond ( n cfa -- n' ) -13 ['] .THEN case? IF 1- exit THEN -14 ['] .ELSE case? IF dup 0= + exit THEN -15 ['] .IF = 0=exit 1+ ; ' (cond is cond -Screen 10 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/extend.fth b/sources/msdos/extend.fth new file mode 100644 index 0000000..fd67fa0 --- /dev/null +++ b/sources/msdos/extend.fth @@ -0,0 +1,187 @@ +\ *** Block No. 0 Hexblock 0 +\ ks 11 mai 88 +Dieses File enth„lt Definitionen, die zum Laden der weiteren +System- und Applikationsfiles ben”tigt werden. + +Unter anderem finden sich hier auch MS-DOS spezifische +Befehle wie zum Beispiel das Allokieren von Speicher- +platz ausserhalb des auf 64k begrenzten Forthsystems +und einige Routinen, die das Arbeiten mit dem Video- +Display erleichtern sowie einige Operatoren zur String- +manipulation. + + + + + + +\ *** Block No. 1 Hexblock 1 +\ loadscreen for often used words ks cas 25sep16 + + Onlyforth \needs Assembler 2 loadfrom asm.fb + + ' save-buffers Alias sav + + ' name &12 + Constant 'name + + ' page Alias cls + + 1 8 +thru .( Systemerweiterung geladen) cr + + + + + +\ *** Block No. 2 Hexblock 2 +\ Postkernel words ks 22 dez 87 + + : blank ( addr quan -- ) bl fill ; + + Code stash ( u1 u2 -- u1 u1 u2 ) + S W mov W ) push Next end-code +\ : stash ( u1 u2 -- u1 u1 u2 ) over swap ; + + : >expect ( addr len -- ) stash expect span @ over place ; + + : .field ( addr len quan -- ) + over - >r type r> 0 max spaces ; + + : tab ( n -- ) col - 0 max spaces ; + + +\ *** Block No. 3 Hexblock 3 +\ postkernel ks 08 m„r 89 +\ hier sollte END-CODE eigentlich aehem, also z.B. -TRANSIENT + +\needs end-code : end-code toss also ; + + : u? ( addr -- ) @ u. ; + + : adr ' >body state @ 0=exit [compile] Literal ; immediate + + : Abort( ( f -- ) IF [compile] .( true abort" !" THEN + [compile] ( ; + + : arguments ( n -- ) + depth 1- > Error" zu wenige Parameter" ; + + +\ *** Block No. 4 Hexblock 4 +\ MS-DOS memory management + + Code lallocate ( pages -- seg ff / rest err# ) + R push D R mov $48 # A+ mov $21 int CS + ?[ A D xchg A pop R push A R xchg + ][ R pop A push 0 # D mov ]? Next end-code + + Code lfree ( seg -- err# ) + E: push D E: mov $49 # A+ mov $21 int CS + ?[ A D xchg ][ 0 # D mov ]? E: pop Next end-code + + + + + + +\ *** Block No. 5 Hexblock 5 +\ postkernel ks 03 aug 87 + + c/row c/col * 2* Constant c/dis \ characters per display + + Code video@ ( -- seg ) D push R D mov $F # A+ mov + $10 int R D xchg 0 # D- mov 7 # A- cmp + 0= ?[ $B0 # D+ mov ][ $B8 # D+ add ]? Next + end-code + + : savevideo ( -- seg / ff ) + [ c/dis b/seg /mod swap 0<> - ] Literal lallocate + IF drop false exit THEN video@ 0 2 pick 0 c/dis lmove ; + + : restorevideo ( seg -- ) ?dup 0=exit + dup 0 video@ 0 c/dis lmove lfree drop ; + +\ *** Block No. 6 Hexblock 6 +\ string operators append attach ks 21 jun 87 + +| : .stringoverflow true Abort" String zu lang" ; + + Code append ( char addr -- ) + D W mov D pop W ) A- mov 1 # A- add CS + ?[ ;c: .stringoverflow ; Assembler ]? + A- W ) mov 0 # A+ mov A W add + D- W ) mov D pop Next end-code + + Code attach ( addr len addr1 -- ) D W mov C pop + I D mov I pop W ) A- mov A- A+ mov C- A+ add CS + ?[ ;c: .stringoverflow ; Assembler ]? + A+ W ) mov A+ A+ xor A+ C+ mov A W add W inc + rep byte movs D I mov D pop Next end-code + +\ *** Block No. 7 Hexblock 7 +\\ string operators append attach detract ks 21 jun 87 + + : append ( char addr -- ) + under count + c! dup c@ 1+ swap c! ; + + : attach ( addr len addr.to -- ) + >r under r@ count + swap move r@ c@ + r> c! ; + + : detract ( addr -- char ) + dup c@ 1- dup 0> and over c! + count >r dup count -rot swap r> cmove ; + + + + + +\ *** Block No. 8 Hexblock 8 +\ ?" string operator ks 09 feb 88 + +\ : (?" ( 8b -- index ) "lit under count rot +\ scan IF swap - exit THEN 2drop false ; + +| Create months ," janfebm„raprmaijunjulaugsepoktnovdez" + + : >months ( n -- addr len ) 3 * 2- months + 3 ; + +| Code (?" ( 8b -- index ) + A D xchg I ) C- mov 0 # C+ mov C I add + I W mov I inc std 0<>rep byte scas cld + 0= ?[ C inc ]? C D mov Next + end-code + + : ?" compile (?" ," align ; immediate restrict +\ *** Block No. 9 Hexblock 9 +\ Conditional compilation ks 12 dez 88 +| Defer cond + + : .THEN ; immediate + + : .ELSE ( -- ) 0 + BEGIN name nullstring? IF drop exit THEN + find IF cond -1 case? ?exit ELSE drop THEN + REPEAT ; immediate + + : .IF ( f -- ) ?exit [compile] .ELSE ; immediate + +| : (cond ( n cfa -- n' ) + ['] .THEN case? IF 1- exit THEN + ['] .ELSE case? IF dup 0= + exit THEN + ['] .IF = 0=exit 1+ ; ' (cond is cond +\ *** Block No. 10 Hexblock A + + + + + + + + + + + + + + + + diff --git a/sources/msdos/f83asm.fb.src b/sources/msdos/f83asm.fb.src deleted file mode 100644 index 5c7549d..0000000 --- a/sources/msdos/f83asm.fb.src +++ /dev/null @@ -1,578 +0,0 @@ -Screen 0 not modified - 0 \ 8086 Assembler cas 10nov05 - 1 - 2 The 8086 Assembler was written by Mike Perry. - 3 To create and assembler language definition, use the defining - 4 word CODE. It must be terminated with either END-CODE or - 5 its synonym C;. How the assembler operates is a very - 6 interesting example of the power of CREATE DOES> Basically - 7 the instructions are categorized and a defining word is - 8 created for each category. When the nmemonic for the - 9 instruction is interpreted, it compiles itself. -10 -11 Adapted for volksFORTH by Klaus Schleisiek -12 -13 No really tested, but -14 CODE TEST TOS PUSH 1 # TOS MOV NEXT END-CODE -15 works! -Screen 1 not modified - 0 \ 8086 Assembler ks cas 10nov05 - 1 Onlyforth - 2 Vocabulary Assembler - 3 : octal 8 Base ! ; - 4 - 5 decimal 1 14 +THRU clear - 6 - 7 Onlyforth - 8 - 9 : Code Create [ Assembler ] here dup 2- ! Assembler ; -10 -11 CR .( 8086 Assembler loaded ) -12 Onlyforth -13 -14 -15 -Screen 2 not modified - 0 \ 8086 Assembler ks 19 m„r 88 - 1 : LABEL CREATE ASSEMBLER ; - 2 \ 232 CONSTANT DOES-OP - 3 \ 3 CONSTANT DOES-SIZE - 4 \ : DOES? ( IP -- IP' F ) - 5 \ DUP DOES-SIZE + SWAP C@ DOES-OP = ; - 6 ASSEMBLER ALSO DEFINITIONS - 7 : C; ( -- ) END-CODE ; - 8 OCTAL - 9 DEFER C, FORTH ' C, ASSEMBLER IS C, -10 DEFER , FORTH ' , ASSEMBLER IS , -11 DEFER HERE FORTH ' HERE ASSEMBLER IS HERE -12 DEFER ?>MARK -13 DEFER ?>RESOLVE -14 DEFER ? @ SWAP 7000 AND = 0<> ; - 2 | 0 MD R8? | 1 MD R16? | 2 MD MEM? | 3 MD SEG? | 4 MD #? - 3 | : REG? ( n -- f ) 7000 AND 2000 < 0<> ; - 4 | : BIG? ( N -- F ) ABS -200 AND 0<> ; - 5 | : RLOW ( n1 -- n2 ) 7 AND ; - 6 | : RMID ( n1 -- n2 ) 70 AND ; - 7 | VARIABLE SIZE SIZE ON - 8 : BYTE ( -- ) SIZE OFF ; - 9 | : OP, ( N OP -- ) OR C, ; -10 | : W, ( OP MR -- ) R16? 1 AND OP, ; -11 | : SIZE, ( OP -- OP' ) SIZE @ 1 AND OP, ; -12 | : ,/C, ( n f -- ) IF , ELSE C, THEN ; -13 | : RR, ( MR1 MR2 -- ) RMID SWAP RLOW OR 300 OP, ; -14 | VARIABLE LOGICAL -15 | : B/L? ( n -- f ) BIG? LOGICAL @ OR ; -Screen 5 not modified - 0 \ Addressing ks 19 m„r 88 - 1 | : MEM, ( DISP MR RMID -- ) OVER #) = - 2 IF RMID 6 OP, DROP , - 3 ELSE RMID OVER RLOW OR -ROT [BP] = OVER 0= AND - 4 IF SWAP 100 OP, C, ELSE SWAP OVER BIG? - 5 IF 200 OP, , ELSE OVER 0= - 6 IF C, DROP ELSE 100 OP, C, - 7 THEN THEN THEN THEN ; - 8 | : WMEM, ( DISP MEM REG OP -- ) OVER W, MEM, ; - 9 | : R/M, ( MR REG -- ) -10 OVER REG? IF RR, ELSE MEM, THEN ; -11 | : WR/SM, ( R/M R OP -- ) 2 PICK DUP REG? -12 IF W, RR, ELSE DROP SIZE, MEM, THEN SIZE ON ; -13 | VARIABLE INTER -14 : FAR ( -- ) INTER ON ; -15 | : ?FAR ( n1 -- n2 ) INTER @ IF 10 OR THEN INTER OFF ; -Screen 6 not modified - 0 \ Defining Words to Generate Op Codes ks 19 m„r 88 - 1 | : 1MI CREATE C, DOES> C@ C, ; - 2 | : 2MI CREATE C, DOES> C@ C, 12 C, ; - 3 | : 3MI CREATE C, DOES> C@ C, HERE - 1- - 4 DUP -200 177 uWITHIN NOT ABORT" Branch out of Range" C, ; - 5 | : 4MI CREATE C, DOES> C@ C, MEM, ; - 6 | : 5MI CREATE C, DOES> C@ SIZE, SIZE ON ; - 7 | : 6MI CREATE C, DOES> C@ SWAP W, ; - 8 | : 7MI CREATE C, DOES> C@ 366 WR/SM, ; - 9 | : 8MI CREATE C, DOES> C@ SWAP R16? 1 AND OR SWAP # = -10 IF C, C, ELSE 10 OR C, THEN ; -11 | : 9MI CREATE C, DOES> C@ OVER R16? -12 IF 100 OR SWAP RLOW OP, ELSE 376 WR/SM, THEN ; -13 | : 10MI CREATE C, DOES> C@ OVER CL = -14 IF NIP 322 ELSE 320 THEN WR/SM, ; -15 -Screen 7 not modified - 0 \ Defining Words to Generate Op Codes ks 19 m„r 88 - 1 | : 11MI CREATE C, C, DOES> OVER #) = - 2 IF NIP C@ INTER @ - 3 IF 1 AND IF 352 ELSE 232 THEN C, SWAP , , INTER OFF - 4 ELSE SWAP HERE - 2- SWAP 2DUP 1 AND SWAP BIG? NOT AND - 5 IF 2 OP, C, ELSE C, 1- , THEN THEN - 6 ELSE OVER S#) = IF NIP #) SWAP THEN - 7 377 C, 1+ C@ ?FAR R/M, THEN ; - 8 | : 12MI CREATE C, C, C, DOES> OVER REG? - 9 IF C@ SWAP RLOW OP, ELSE 1+ OVER SEG? -10 IF C@ RLOW SWAP RMID OP, -11 ELSE COUNT SWAP C@ C, MEM, -12 THEN THEN ; -13 | : 14MI CREATE C, DOES> C@ -14 DUP ?FAR C, 1 AND 0= IF , THEN ; -15 -Screen 8 not modified - 0 \ Defining Words to Generate Op Codes ks 19 m„r 88 - 1 | : 13MI CREATE C, C, DOES> COUNT >R C@ LOGICAL ! DUP REG? - 2 IF OVER REG? - 3 IF R> OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR - 4 IF R> 2 OR WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? ) - 5 IF R> 4 OR OVER W, R16? ,/C, - 6 ELSE OVER B/L? OVER R16? 2DUP AND - 7 -ROT 1 AND SWAP NOT 2 AND OR 200 OP, - 8 SWAP RLOW 300 OR R> OP, ,/C, - 9 THEN THEN THEN -10 ELSE ( MEM ) ROT DUP REG? -11 IF R> WMEM, -12 ELSE ( # ) DROP 2 PICK B/L? DUP NOT 2 AND 200 OR SIZE, -13 -ROT R> MEM, SIZE @ AND ,/C, SIZE ON -14 THEN THEN ; -15 -Screen 9 not modified - 0 \ Instructions ks 19 m„r 88 - 1 : TEST ( source dest -- ) DUP REG? - 2 IF OVER REG? - 3 IF 204 OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR - 4 IF 204 WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? ) - 5 IF 250 OVER W, - 6 ELSE 366 OVER W, DUP RLOW 300 OP, - 7 THEN R16? ,/C, THEN THEN - 8 ELSE ( MEM ) ROT DUP REG? - 9 IF 204 WMEM, -10 ELSE ( # ) DROP 366 SIZE, 0 MEM, SIZE @ ,/C, SIZE ON -11 THEN THEN ; -12 -13 -14 -15 -Screen 10 not modified - 0 \ Instructions ks 19 m„r 88 - 1 HEX - 2 : ESC ( source ext-opcode -- ) RLOW 0D8 OP, R/M, ; - 3 : INT ( N -- ) 0CD C, C, ; - 4 : SEG ( SEG -- ) RMID 26 OP, ; - 5 : XCHG ( MR1 MR2 -- ) DUP REG? - 6 IF DUP AX = - 7 IF DROP RLOW 90 OP, ELSE OVER AX = - 8 IF NIP RLOW 90 OP, ELSE 86 WR/SM, THEN THEN - 9 ELSE ROT 86 WR/SM, THEN ; -10 -11 : CS: CS SEG ; -12 : DS: DS SEG ; -13 : ES: ES SEG ; -14 : SS: SS SEG ; -15 -Screen 11 not modified - 0 \ Instructions ks 19 m„r 88 - 1 : MOV ( S D -- ) DUP SEG? - 2 IF 8E C, R/M, ELSE DUP REG? - 3 IF OVER #) = OVER RLOW 0= AND - 4 IF A0 SWAP W, DROP , ELSE OVER SEG? - 5 IF SWAP 8C C, RR, ELSE OVER # = - 6 IF NIP DUP R16? SWAP RLOW OVER 8 AND OR B0 OP, ,/C, - 7 ELSE 8A OVER W, R/M, THEN THEN THEN - 8 ELSE ( MEM ) ROT DUP SEG? - 9 IF 8C C, MEM, ELSE DUP # = -10 IF DROP C6 SIZE, 0 MEM, SIZE @ ,/C, -11 ELSE OVER #) = OVER RLOW 0= AND -12 IF A2 SWAP W, DROP , ELSE 88 OVER W, R/M, -13 THEN THEN THEN THEN THEN SIZE ON ; -14 -15 -Screen 12 not modified - 0 \ Instructions 12Oct83map - 1 37 1MI AAA D5 2MI AAD D4 2MI AAM 3F 1MI AAS - 2 0 10 13MI ADC 0 00 13MI ADD 2 20 13MI AND 10 E8 11MI CALL - 3 98 1MI CBW F8 1MI CLC FC 1MI CLD FA 1MI CLI - 4 F5 1MI CMC 0 38 13MI CMP A6 5MI CMPS 99 1MI CWD - 5 27 1MI DAA 2F 1MI DAS 08 9MI DEC 30 7MI DIV - 6 ( ESC ) F4 1MI HLT 38 7MI IDIV 28 7MI IMUL - 7 E4 8MI IN 00 9MI INC ( INT ) 0CE 1MI INTO - 8 0CF 1MI IRET 77 3MI JA 73 3MI JAE 72 3MI JB - 9 76 3MI JBE E3 3MI JCXZ 74 3MI JE 7F 3MI JG -10 7D 3MI JGE 7C 3MI JL 7E 3MI JLE 20 E9 11MI JMP -11 75 3MI JNE 71 3MI JNO 79 3MI JNS 70 3MI JO -12 7A 3MI JPE 7B 3MI JPO 78 3MI JS 9F 1MI LAHF -13 C5 4MI LDS 8D 4MI LEA C4 4MI LES F0 1MI LOCK -14 0AC 6MI LODS E2 3MI LOOP E1 3MI LOOPE E0 3MI LOOPNE -15 -Screen 13 not modified - 0 \ Instructions 12Apr84map - 1 ( MOV ) 0A4 5MI MOVS 20 7MI MUL 18 7MI NEG - 2 90 1MI NOP 10 7MI NOT 2 08 13MI OR E6 8MI OUT - 3 8F 07 58 12MI POP 9D 1MI POPF - 4 0FF 36 50 12MI PUSH 9C 1MI PUSHF - 5 10 10MI RCL 18 10MI RCR - 6 F2 1MI REP F2 1MI REPNZ F3 1MI REPZ - 7 C3 14MI RET 00 10MI ROL 8 10MI ROR 9E 1MI SAHF - 8 38 10MI SAR 0 18 13MI SBB 0AE 5MI SCAS ( SEG ) - 9 20 10MI SHL 28 10MI SHR F9 1MI STC FD 1MI STD -10 FB 1MI STI 0AA 6MI STOS 0 28 13MI SUB ( TEST ) -11 9B 1MI WAIT ( XCHG ) D7 1MI XLAT 2 30 13MI XOR -12 C2 14MI +RET -13 -14 -15 -Screen 14 not modified - 0 \ Structured Conditionals ks 19 m„r 88 - 1 : A?>MARK ( -- f addr ) TRUE HERE 0 C, ; - 2 : A?>RESOLVE ( f addr -- ) HERE OVER 1+ - SWAP C! true ?pairs ; - 3 : A?MARK ASSEMBLER IS ?>MARK - 6 ' A?>RESOLVE ASSEMBLER IS ?>RESOLVE - 7 ' A? 79 CONSTANT 0< -11 78 CONSTANT 0>= 7D CONSTANT < 7C CONSTANT >= -12 7F CONSTANT <= 7E CONSTANT > 73 CONSTANT U< -13 72 CONSTANT U>= 77 CONSTANT U<= 76 CONSTANT U> -14 71 CONSTANT OV -15 DECIMAL -Screen 15 not modified - 0 \ Structured Conditionals cas 10nov05 - 1 HEX - 2 : IF C, ?>MARK ; - 3 : THEN ?>RESOLVE ; - 4 : ELSE 0EB IF 2SWAP THEN ; - 5 : BEGIN ? U - 4 C; A synonym for END-CODE - 5 - 6 Deferring the definitions of the commas, marks, and resolves - 7 allows the same assembler to serve for both the system and the - 8 Meta-Compiler. - 9 -10 -11 -12 -13 -14 -15 -Screen 18 not modified - 0 \ 8086 Assembler Register Definitions 12Oct83map - 1 - 2 On the 8086, register names are cleverly defined constants. - 3 - 4 The value returned by registers and by modes such as #) contains - 5 both mode and register information. The instructions use the - 6 mode information to decide how many arguments exist, and what to - 7 assemble. - 8 Like many CPUs, the 8086 uses many 3 bit fields in its opcodes - 9 This makes octal ( base 8 ) natural for describing the registers -10 -11 -12 We redefine the Registers that FORTH uses to implement its -13 virtual machine. -14 -15 -Screen 19 not modified - 0 \ Addressing Modes 16Oct83map - 1 MD defines words which test for various modes. - 2 R8? R16? MEM? SEG? #? test for mode equal to 0 thru 4. - 3 REG? tests for any register mode ( 8 or 16 bit). - 4 BIG? tests offsets size. True if won't fit in one byte. - 5 RLOW mask off all but low register field. - 6 RMID mask off all but middle register field. - 7 SIZE true for 16 bit, false for 8 bit. - 8 BYTE set size to 8 bit. - 9 OP, for efficiency. OR two numbers and assemble. -10 W, assemble opcode with W field set for size of register. -11 SIZE, assemble opcode with W field set for size of data. -12 ,/C, assemble either 8 or 16 bits. -13 RR, assemble register to register instruction. -14 LOGICAL true while assembling logical instructions. -15 B/L? see 13MI -Screen 20 not modified - 0 \ Addressing 16Oct83map - 1 These words perform most of the addressing mode encoding. - 2 MEM, handles memory reference modes. It takes a displacement, - 3 a mode/register, and a register, and encodes and assembles - 4 them. - 5 - 6 - 7 WMEM, uses MEM, after packing the register size into the opcode - 8 R/M, assembles either a register to register or a register to - 9 or from memory mode. -10 WR/SM, assembles either a register mode with size field, or a -11 memory mode with size from SIZE. Default is 16 bit. Use BYTE -12 for 8 bit size. -13 INTER true if inter-segment jump, call, or return. -14 FAR sets INTER true. Usage: FAR JMP, FAR CALL, FAR RET. -15 ?FAR sets far bit, clears flag. -Screen 21 not modified - 0 \ Defining Words to Generate Op Codes 12Oct83map - 1 1MI define one byte constant instructions. - 2 2MI define ascii adjust instructions. - 3 3MI define branch instructions, with one byte offset. - 4 4MI define LDS, LEA, LES instructions. - 5 5MI define string instructions. - 6 6MI define more string instructions. - 7 7MI define multiply and divide instructions. - 8 8MI define input and output instructions. - 9 -10 9MI define increment/decrement instructions. -11 -12 10MI define shift/rotate instructions. -13 *NOTE* To allow both 'ax shl' and 'ax cl shl', if the register -14 on top of the stack is cl, shift second register by cl. If not, -15 shift top ( only) register by one. -Screen 22 not modified - 0 \ Defining Words to Generate Op Codes 09Apr84map - 1 11MI define calls and jumps. - 2 notice that the first byte stored is E9 for jmp and E8 for call - 3 so C@ 1 AND is zero for call, 1 for jmp. - 4 syntax for direct intersegment: address segment #) FAR JMP - 5 - 6 - 7 - 8 12MI define pushes and pops. - 9 -10 -11 -12 -13 14MI defines returns. -14 RET FAR RET n +RET n FAR +RET -15 -Screen 23 not modified - 0 \ Defining Words to Generate Op Codes 16Oct83map - 1 13MI define arithmetic and logical instructions. - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 \ Instructions 16Oct83map - 1 TEST bits in dest - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 25 not modified - 0 \ Instructions 16Oct83map - 1 - 2 ESC - 3 INT assemble interrupt instruction. - 4 SEG assemble segment instruction. - 5 XCHG assemble register swap instruction. - 6 - 7 - 8 - 9 -10 -11 CS: DS: ES: SS: assemble segment over-ride instructions. -12 -13 -14 -15 -Screen 26 not modified - 0 \ Instructions 12Oct83map - 1 MOV as usual, the move instruction is the most complicated. - 2 It allows more addressing modes than any other, each of which - 3 assembles something more or less unique. - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 27 not modified - 0 \ Instructions 12Oct83map - 1 Most instructions are defined on these two screens. Mnemonics in - 2 parentheses are defined earlier or not at all. - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 28 not modified - 0 \ Instructions 12Oct83map - 1 Most instructions are defined on these two screens. Mnemonics in - 2 parentheses are defined earlier or not at all. - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 29 not modified - 0 \ Structured Conditionals 16Oct83map - 1 A?>MARK assembler version of forward mark. - 2 A?>RESOLVE assembler version of forward resolve. - 3 A? Basically +the instructions are categorized and a defining word is +created for each category. When the nmemonic for the +instruction is interpreted, it compiles itself. + +Adapted for volksFORTH by Klaus Schleisiek + +No really tested, but + CODE TEST TOS PUSH 1 # TOS MOV NEXT END-CODE +works! +\ *** Block No. 1 Hexblock 1 +\ 8086 Assembler ks cas 10nov05 +Onlyforth +Vocabulary Assembler +: octal 8 Base ! ; + +decimal 1 14 +THRU clear + +Onlyforth + + : Code Create [ Assembler ] here dup 2- ! Assembler ; + +CR .( 8086 Assembler loaded ) +Onlyforth + + + +\ *** Block No. 2 Hexblock 2 +\ 8086 Assembler ks 19 m„r 88 +: LABEL CREATE ASSEMBLER ; +\ 232 CONSTANT DOES-OP +\ 3 CONSTANT DOES-SIZE +\ : DOES? ( IP -- IP' F ) +\ DUP DOES-SIZE + SWAP C@ DOES-OP = ; +ASSEMBLER ALSO DEFINITIONS +: C; ( -- ) END-CODE ; +OCTAL +DEFER C, FORTH ' C, ASSEMBLER IS C, +DEFER , FORTH ' , ASSEMBLER IS , +DEFER HERE FORTH ' HERE ASSEMBLER IS HERE +DEFER ?>MARK +DEFER ?>RESOLVE +DEFER ? @ SWAP 7000 AND = 0<> ; +| 0 MD R8? | 1 MD R16? | 2 MD MEM? | 3 MD SEG? | 4 MD #? +| : REG? ( n -- f ) 7000 AND 2000 < 0<> ; +| : BIG? ( N -- F ) ABS -200 AND 0<> ; +| : RLOW ( n1 -- n2 ) 7 AND ; +| : RMID ( n1 -- n2 ) 70 AND ; +| VARIABLE SIZE SIZE ON +: BYTE ( -- ) SIZE OFF ; +| : OP, ( N OP -- ) OR C, ; +| : W, ( OP MR -- ) R16? 1 AND OP, ; +| : SIZE, ( OP -- OP' ) SIZE @ 1 AND OP, ; +| : ,/C, ( n f -- ) IF , ELSE C, THEN ; +| : RR, ( MR1 MR2 -- ) RMID SWAP RLOW OR 300 OP, ; +| VARIABLE LOGICAL +| : B/L? ( n -- f ) BIG? LOGICAL @ OR ; +\ *** Block No. 5 Hexblock 5 +\ Addressing ks 19 m„r 88 +| : MEM, ( DISP MR RMID -- ) OVER #) = + IF RMID 6 OP, DROP , + ELSE RMID OVER RLOW OR -ROT [BP] = OVER 0= AND + IF SWAP 100 OP, C, ELSE SWAP OVER BIG? + IF 200 OP, , ELSE OVER 0= + IF C, DROP ELSE 100 OP, C, + THEN THEN THEN THEN ; +| : WMEM, ( DISP MEM REG OP -- ) OVER W, MEM, ; +| : R/M, ( MR REG -- ) + OVER REG? IF RR, ELSE MEM, THEN ; +| : WR/SM, ( R/M R OP -- ) 2 PICK DUP REG? + IF W, RR, ELSE DROP SIZE, MEM, THEN SIZE ON ; +| VARIABLE INTER +: FAR ( -- ) INTER ON ; +| : ?FAR ( n1 -- n2 ) INTER @ IF 10 OR THEN INTER OFF ; +\ *** Block No. 6 Hexblock 6 +\ Defining Words to Generate Op Codes ks 19 m„r 88 +| : 1MI CREATE C, DOES> C@ C, ; +| : 2MI CREATE C, DOES> C@ C, 12 C, ; +| : 3MI CREATE C, DOES> C@ C, HERE - 1- + DUP -200 177 uWITHIN NOT ABORT" Branch out of Range" C, ; +| : 4MI CREATE C, DOES> C@ C, MEM, ; +| : 5MI CREATE C, DOES> C@ SIZE, SIZE ON ; +| : 6MI CREATE C, DOES> C@ SWAP W, ; +| : 7MI CREATE C, DOES> C@ 366 WR/SM, ; +| : 8MI CREATE C, DOES> C@ SWAP R16? 1 AND OR SWAP # = + IF C, C, ELSE 10 OR C, THEN ; +| : 9MI CREATE C, DOES> C@ OVER R16? + IF 100 OR SWAP RLOW OP, ELSE 376 WR/SM, THEN ; +| : 10MI CREATE C, DOES> C@ OVER CL = + IF NIP 322 ELSE 320 THEN WR/SM, ; + +\ *** Block No. 7 Hexblock 7 +\ Defining Words to Generate Op Codes ks 19 m„r 88 +| : 11MI CREATE C, C, DOES> OVER #) = + IF NIP C@ INTER @ + IF 1 AND IF 352 ELSE 232 THEN C, SWAP , , INTER OFF + ELSE SWAP HERE - 2- SWAP 2DUP 1 AND SWAP BIG? NOT AND + IF 2 OP, C, ELSE C, 1- , THEN THEN + ELSE OVER S#) = IF NIP #) SWAP THEN + 377 C, 1+ C@ ?FAR R/M, THEN ; +| : 12MI CREATE C, C, C, DOES> OVER REG? + IF C@ SWAP RLOW OP, ELSE 1+ OVER SEG? + IF C@ RLOW SWAP RMID OP, + ELSE COUNT SWAP C@ C, MEM, + THEN THEN ; +| : 14MI CREATE C, DOES> C@ + DUP ?FAR C, 1 AND 0= IF , THEN ; + +\ *** Block No. 8 Hexblock 8 +\ Defining Words to Generate Op Codes ks 19 m„r 88 +| : 13MI CREATE C, C, DOES> COUNT >R C@ LOGICAL ! DUP REG? + IF OVER REG? + IF R> OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR + IF R> 2 OR WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? ) + IF R> 4 OR OVER W, R16? ,/C, + ELSE OVER B/L? OVER R16? 2DUP AND + -ROT 1 AND SWAP NOT 2 AND OR 200 OP, + SWAP RLOW 300 OR R> OP, ,/C, + THEN THEN THEN + ELSE ( MEM ) ROT DUP REG? + IF R> WMEM, + ELSE ( # ) DROP 2 PICK B/L? DUP NOT 2 AND 200 OR SIZE, + -ROT R> MEM, SIZE @ AND ,/C, SIZE ON + THEN THEN ; + +\ *** Block No. 9 Hexblock 9 +\ Instructions ks 19 m„r 88 +: TEST ( source dest -- ) DUP REG? + IF OVER REG? + IF 204 OVER W, SWAP RR, ELSE OVER DUP MEM? SWAP #) = OR + IF 204 WMEM, ELSE ( # ) NIP DUP RLOW 0= ( ACC? ) + IF 250 OVER W, + ELSE 366 OVER W, DUP RLOW 300 OP, + THEN R16? ,/C, THEN THEN + ELSE ( MEM ) ROT DUP REG? + IF 204 WMEM, + ELSE ( # ) DROP 366 SIZE, 0 MEM, SIZE @ ,/C, SIZE ON + THEN THEN ; + + + + +\ *** Block No. 10 Hexblock A +\ Instructions ks 19 m„r 88 +HEX +: ESC ( source ext-opcode -- ) RLOW 0D8 OP, R/M, ; +: INT ( N -- ) 0CD C, C, ; +: SEG ( SEG -- ) RMID 26 OP, ; +: XCHG ( MR1 MR2 -- ) DUP REG? + IF DUP AX = + IF DROP RLOW 90 OP, ELSE OVER AX = + IF NIP RLOW 90 OP, ELSE 86 WR/SM, THEN THEN + ELSE ROT 86 WR/SM, THEN ; + +: CS: CS SEG ; +: DS: DS SEG ; +: ES: ES SEG ; +: SS: SS SEG ; + +\ *** Block No. 11 Hexblock B +\ Instructions ks 19 m„r 88 +: MOV ( S D -- ) DUP SEG? + IF 8E C, R/M, ELSE DUP REG? + IF OVER #) = OVER RLOW 0= AND + IF A0 SWAP W, DROP , ELSE OVER SEG? + IF SWAP 8C C, RR, ELSE OVER # = + IF NIP DUP R16? SWAP RLOW OVER 8 AND OR B0 OP, ,/C, + ELSE 8A OVER W, R/M, THEN THEN THEN + ELSE ( MEM ) ROT DUP SEG? + IF 8C C, MEM, ELSE DUP # = + IF DROP C6 SIZE, 0 MEM, SIZE @ ,/C, + ELSE OVER #) = OVER RLOW 0= AND + IF A2 SWAP W, DROP , ELSE 88 OVER W, R/M, + THEN THEN THEN THEN THEN SIZE ON ; + + +\ *** Block No. 12 Hexblock C +\ Instructions 12Oct83map + 37 1MI AAA D5 2MI AAD D4 2MI AAM 3F 1MI AAS +0 10 13MI ADC 0 00 13MI ADD 2 20 13MI AND 10 E8 11MI CALL + 98 1MI CBW F8 1MI CLC FC 1MI CLD FA 1MI CLI + F5 1MI CMC 0 38 13MI CMP A6 5MI CMPS 99 1MI CWD + 27 1MI DAA 2F 1MI DAS 08 9MI DEC 30 7MI DIV + ( ESC ) F4 1MI HLT 38 7MI IDIV 28 7MI IMUL + E4 8MI IN 00 9MI INC ( INT ) 0CE 1MI INTO +0CF 1MI IRET 77 3MI JA 73 3MI JAE 72 3MI JB + 76 3MI JBE E3 3MI JCXZ 74 3MI JE 7F 3MI JG + 7D 3MI JGE 7C 3MI JL 7E 3MI JLE 20 E9 11MI JMP + 75 3MI JNE 71 3MI JNO 79 3MI JNS 70 3MI JO + 7A 3MI JPE 7B 3MI JPO 78 3MI JS 9F 1MI LAHF + C5 4MI LDS 8D 4MI LEA C4 4MI LES F0 1MI LOCK +0AC 6MI LODS E2 3MI LOOP E1 3MI LOOPE E0 3MI LOOPNE + +\ *** Block No. 13 Hexblock D +\ Instructions 12Apr84map + ( MOV ) 0A4 5MI MOVS 20 7MI MUL 18 7MI NEG + 90 1MI NOP 10 7MI NOT 2 08 13MI OR E6 8MI OUT + 8F 07 58 12MI POP 9D 1MI POPF + 0FF 36 50 12MI PUSH 9C 1MI PUSHF + 10 10MI RCL 18 10MI RCR + F2 1MI REP F2 1MI REPNZ F3 1MI REPZ + C3 14MI RET 00 10MI ROL 8 10MI ROR 9E 1MI SAHF + 38 10MI SAR 0 18 13MI SBB 0AE 5MI SCAS ( SEG ) + 20 10MI SHL 28 10MI SHR F9 1MI STC FD 1MI STD + FB 1MI STI 0AA 6MI STOS 0 28 13MI SUB ( TEST ) + 9B 1MI WAIT ( XCHG ) D7 1MI XLAT 2 30 13MI XOR + C2 14MI +RET + + + +\ *** Block No. 14 Hexblock E +\ Structured Conditionals ks 19 m„r 88 +: A?>MARK ( -- f addr ) TRUE HERE 0 C, ; +: A?>RESOLVE ( f addr -- ) HERE OVER 1+ - SWAP C! true ?pairs ; +: A?MARK ASSEMBLER IS ?>MARK +' A?>RESOLVE ASSEMBLER IS ?>RESOLVE +' A? 79 CONSTANT 0< +78 CONSTANT 0>= 7D CONSTANT < 7C CONSTANT >= +7F CONSTANT <= 7E CONSTANT > 73 CONSTANT U< +72 CONSTANT U>= 77 CONSTANT U<= 76 CONSTANT U> +71 CONSTANT OV +DECIMAL +\ *** Block No. 15 Hexblock F +\ Structured Conditionals cas 10nov05 +HEX +: IF C, ?>MARK ; +: THEN ?>RESOLVE ; +: ELSE 0EB IF 2SWAP THEN ; +: BEGIN ? U +C; A synonym for END-CODE + +Deferring the definitions of the commas, marks, and resolves + allows the same assembler to serve for both the system and the + Meta-Compiler. + + + + + + + +\ *** Block No. 18 Hexblock 12 +\ 8086 Assembler Register Definitions 12Oct83map + +On the 8086, register names are cleverly defined constants. + +The value returned by registers and by modes such as #) contains +both mode and register information. The instructions use the +mode information to decide how many arguments exist, and what to +assemble. + Like many CPUs, the 8086 uses many 3 bit fields in its opcodes +This makes octal ( base 8 ) natural for describing the registers + + +We redefine the Registers that FORTH uses to implement its +virtual machine. + + +\ *** Block No. 19 Hexblock 13 +\ Addressing Modes 16Oct83map +MD defines words which test for various modes. +R8? R16? MEM? SEG? #? test for mode equal to 0 thru 4. +REG? tests for any register mode ( 8 or 16 bit). +BIG? tests offsets size. True if won't fit in one byte. +RLOW mask off all but low register field. +RMID mask off all but middle register field. +SIZE true for 16 bit, false for 8 bit. +BYTE set size to 8 bit. +OP, for efficiency. OR two numbers and assemble. +W, assemble opcode with W field set for size of register. +SIZE, assemble opcode with W field set for size of data. +,/C, assemble either 8 or 16 bits. +RR, assemble register to register instruction. +LOGICAL true while assembling logical instructions. +B/L? see 13MI +\ *** Block No. 20 Hexblock 14 +\ Addressing 16Oct83map +These words perform most of the addressing mode encoding. +MEM, handles memory reference modes. It takes a displacement, + a mode/register, and a register, and encodes and assembles + them. + + +WMEM, uses MEM, after packing the register size into the opcode +R/M, assembles either a register to register or a register to + or from memory mode. +WR/SM, assembles either a register mode with size field, or a + memory mode with size from SIZE. Default is 16 bit. Use BYTE + for 8 bit size. +INTER true if inter-segment jump, call, or return. +FAR sets INTER true. Usage: FAR JMP, FAR CALL, FAR RET. +?FAR sets far bit, clears flag. +\ *** Block No. 21 Hexblock 15 +\ Defining Words to Generate Op Codes 12Oct83map +1MI define one byte constant instructions. +2MI define ascii adjust instructions. +3MI define branch instructions, with one byte offset. +4MI define LDS, LEA, LES instructions. +5MI define string instructions. +6MI define more string instructions. +7MI define multiply and divide instructions. +8MI define input and output instructions. + +9MI define increment/decrement instructions. + +10MI define shift/rotate instructions. +*NOTE* To allow both 'ax shl' and 'ax cl shl', if the register +on top of the stack is cl, shift second register by cl. If not, +shift top ( only) register by one. +\ *** Block No. 22 Hexblock 16 +\ Defining Words to Generate Op Codes 09Apr84map +11MI define calls and jumps. + notice that the first byte stored is E9 for jmp and E8 for call + so C@ 1 AND is zero for call, 1 for jmp. + syntax for direct intersegment: address segment #) FAR JMP + + + +12MI define pushes and pops. + + + + +14MI defines returns. + RET FAR RET n +RET n FAR +RET + +\ *** Block No. 23 Hexblock 17 +\ Defining Words to Generate Op Codes 16Oct83map +13MI define arithmetic and logical instructions. + + + + + + + + + + + + + + +\ *** Block No. 24 Hexblock 18 +\ Instructions 16Oct83map +TEST bits in dest + + + + + + + + + + + + + + +\ *** Block No. 25 Hexblock 19 +\ Instructions 16Oct83map + +ESC +INT assemble interrupt instruction. +SEG assemble segment instruction. +XCHG assemble register swap instruction. + + + + + +CS: DS: ES: SS: assemble segment over-ride instructions. + + + + +\ *** Block No. 26 Hexblock 1A +\ Instructions 12Oct83map +MOV as usual, the move instruction is the most complicated. + It allows more addressing modes than any other, each of which + assembles something more or less unique. + + + + + + + + + + + + +\ *** Block No. 27 Hexblock 1B +\ Instructions 12Oct83map +Most instructions are defined on these two screens. Mnemonics in +parentheses are defined earlier or not at all. + + + + + + + + + + + + + +\ *** Block No. 28 Hexblock 1C +\ Instructions 12Oct83map +Most instructions are defined on these two screens. Mnemonics in +parentheses are defined earlier or not at all. + + + + + + + + + + + + + +\ *** Block No. 29 Hexblock 1D +\ Structured Conditionals 16Oct83map +A?>MARK assembler version of forward mark. +A?>RESOLVE assembler version of forward resolve. +A? IF ." $" u. exit THEN - 7 dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; - 8 - 9 : install \ install editor's keyboard -10 page ." Press keys requested (Spacebar to confirm)" -11 #keys 0 ?DO cr I 2* actiontable + @ >name .name -12 tab ." : " I 2* keytable + dup @ .key tab ." -> " -13 key dup bl = IF drop dup @ THEN dup .key swap ! -14 LOOP ; -15 --> -Screen 2 not modified - 0 \ define action-names UH 11mai88 - 1 : :a ( addr -- adr' ) dup @ Alias 2+ ; - 2 actiontable - 3 :a up :a left :a down :a right - 4 :a push-line :a push-char :a pull-line :a pull-char - 5 :a fix-word :a screen# :a copy-line :a copy-char - 6 :a backspace :a backspace :a backspace :a delete-char - 7 ( :a insert-char ) :a delete-line :a insert-line - 8 :a flipimode ( :a erase-line :a clear-to-right) - 9 :a new-line :a +tab :a -tab -10 :a home :a to-end :a search :a undo -11 :a update-exit :a flushed-exit :a showload :a shadow-screen -12 :a next-Screen :a back-Screen :a alter-Screen :a mark-screen -13 drop -14 -15 warning off install empty -Screen 3 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 11 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 12 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 14 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 17 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/install.fth b/sources/msdos/install.fth new file mode 100644 index 0000000..9803fd4 --- /dev/null +++ b/sources/msdos/install.fth @@ -0,0 +1,306 @@ +\ *** Block No. 0 Hexblock 0 +\\ Install Editor cas 10nov05 + +This file contains the Installer for the Forth Editor + +The Installer will query for keystrokes that should invoke +the Editor commands. + +This allows custom keybinding for the individual requirements + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ install Editor cas 10nov05 + +Onlyforth Editor also save warning on + +: tab &20 col &20 mod - spaces ; +: .key ( c -- ) + dup $7E > IF ." $" u. exit THEN + dup bl < IF ." ^" [ Ascii A 1- ] Literal + THEN emit ; + +: install \ install editor's keyboard + page ." Press keys requested (Spacebar to confirm)" + #keys 0 ?DO cr I 2* actiontable + @ >name .name + tab ." : " I 2* keytable + dup @ .key tab ." -> " + key dup bl = IF drop dup @ THEN dup .key swap ! + LOOP ; +--> +\ *** Block No. 2 Hexblock 2 +\ define action-names UH 11mai88 +: :a ( addr -- adr' ) dup @ Alias 2+ ; +actiontable +:a up :a left :a down :a right +:a push-line :a push-char :a pull-line :a pull-char +:a fix-word :a screen# :a copy-line :a copy-char +:a backspace :a backspace :a backspace :a delete-char +( :a insert-char ) :a delete-line :a insert-line +:a flipimode ( :a erase-line :a clear-to-right) +:a new-line :a +tab :a -tab +:a home :a to-end :a search :a undo +:a update-exit :a flushed-exit :a showload :a shadow-screen +:a next-Screen :a back-Screen :a alter-Screen :a mark-screen +drop + +warning off install empty +\ *** Block No. 3 Hexblock 3 + + + + + + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + +\ *** Block No. 5 Hexblock 5 + + + + + + + + + + + + + + + + +\ *** Block No. 6 Hexblock 6 + + + + + + + + + + + + + + + + +\ *** Block No. 7 Hexblock 7 + + + + + + + + + + + + + + + + +\ *** Block No. 8 Hexblock 8 + + + + + + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 + + + + + + + + + + + + + + + + +\ *** Block No. 10 Hexblock A + + + + + + + + + + + + + + + + +\ *** Block No. 11 Hexblock B + + + + + + + + + + + + + + + + +\ *** Block No. 12 Hexblock C + + + + + + + + + + + + + + + + +\ *** Block No. 13 Hexblock D + + + + + + + + + + + + + + + + +\ *** Block No. 14 Hexblock E + + + + + + + + + + + + + + + + +\ *** Block No. 15 Hexblock F + + + + + + + + + + + + + + + + +\ *** Block No. 16 Hexblock 10 + + + + + + + + + + + + + + + + +\ *** Block No. 17 Hexblock 11 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/kernel.fb.src b/sources/msdos/kernel.fb.src deleted file mode 100644 index 07f10b6703c0474c2ab75d8c3f169f468b80e01f..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 178610 zcmeFaZF3yOvMzc*^D7G57i%peS(1%00&EG%-so-?5H>8%If%1kG#c5nJ(|&;7aIs- zMcjz}6YdYb&y$&zUHwusJyI)h9^T&dREKD&H#WWq&#tjKg*qPv+rbayC34 z4$cCP4{-D3{|dKpgz$DUdNX_e-HRW-#xHtH9%}lh-{y})a_x^n=yzIXo4TiJf;LXS3tF7?; zU_2gN^v2_l!@q5X7lYU5gVEW?;b<%TG#HKt{WrzuJ_rwa@#APT3|~*q&-JbEUk^va z%kaMj7pKz+-aPD0XLHo><$OAs^O2$eoP7{J36DP6-VJXD)7fw`X7#_?aw0-+dq}=FxXANlTfdXM^9v<4?;aeXz4r zzHx=C4|Y1}r#sS5ukiKal@E5LpB6W+aQ4B@Cs%l@{K^L}6OPAYR5n4hR58efVf~~{v{(*=B>@C2xck=dJ`1rF5Bm%jljFN)v& zjL>r3gU}Mf`DihFT`TG&^hcA~pv0-#L%2a`x$Z$|=}*JfhP2I_!E`(r1YWaT0W`}a|7$Uso{d?l-xsLYI2@1X=uTG9Wb|q1Hjl)-iu{Hns6b$sED`+{Ax*S7h0DWT9+5g z>q4o8!|cUizL<{xV@9(7<8m@Y@2m~AavkE;`zEzKc)y|LM{Tn2g?&HH2GjrOO$WX9 zEGM+Qlrmmw8Peg_YdAv7v6gWxbR3Uo^XZ~b;i4@ilv;k0GLE#2p8#<2<&VSgqBN*E z$jbwpL!&FHP#s{pf)>(qo#TT)p+fX911&0! zhVLdwjHndr*iVTweS)#2d)Elv)aLW65hve(Fjg8c#0ql}~Vl+u=Vic##~h z2h%~=-3(7g5N<}{Nq;g@laoI~Xj!j}=>U@s22ydTLR4H|`kzLVbuP6Z!{O0F$PgS$Eaf4VEPtz zm>#+SKPN|5QcDPTo_z+j7<_`HxY-BHgs}NAe2gES9};U}1zd7aAv%FpH=IEv#b2n_ zus#jvy%`i6lnceOHyZxl;}n2Pd18UtDR6eOa=U_-Kf+#Ok!ySReYPJ51(DF$RTD~3py0l@d%mK6%`cP*IQ3(IEo(*OA*ZJmXI2Hpd ztj~TaW2#C{>^fp=$^6*zwkkwlPoPnWHkM#!Z#0`=94;}CI2|3B$HdmM7h=ndCNN%w zZ~$@W*Z%8QIQ=R7t&W|gTB@z3xP<`;WStkx+z&rsY=52J`Y?Q6ynwT=pyfnsLQQoz zX3Gu&;bkj47yXu?H#l9qdId00p(C92KrS%{7^G6mNw`JYXSawQ)Z?b%8>;K!Vn`7Q z>hzd6^X;?$@x$gf$KU=t&FH640taK2V7h{q5cb02uCZw&Y;FeF`yqj$L2&#K?uOla zp}!BtmU(G!KmvOZPp|w}6(Y0RU9prd&A5+p&@vtLCuoQ8d4CU&$i%;t+?#?Hn++m4 z7)ow?SxS%oXdWV%7tqoAxEKE(cA!l z4-upm3SDPnlIp{iSU#+0<@*q!#mZ2#)@-h22=q%~Ey{RU{^}L36k4P%>7W-XAlh>l z&sV~}7tOez=Aea!jSz)lRgjmGN`>fAm<=w&j^bkoIXBDlk9T9j+ zp+(BDX*GFuJ5IIBb~#VfQ(8H;i!Gk!qxoQTE{VB3eC1XZKJ$T!3ciee(PJkCK2LNkV!3$h~2)D3B@ z&cFvF&|@7OBf3&(j}Q@RZPUy+frIqodB#A1geK zN??hpT{)kvkDbl3eGG>0C7rB0=QE6C=lp}g-vV$Zvw=r zr*cs$$}XC)MW!Vbls0>FyEls*lr*n*D7GjaS{pB~sjK0~dOuTa@%OHDqGF5Ck>%j3 zf)!i7QBRhY!m)E~;I^tlEWbNri;5iDD?)gp^t4vWJH{64mK%t|>%B6pT*XfL-Hk0r z=$FuZ1eQel)EaGn8J_;4CH?$!Xq28zBWm@z>_e&%2~W4b6kcAXE@o`W*M(!9_4$Q$ z@}8bhMUChLHfd#OnTF%%h6q1={p{O}J(@*1wq)aR2fq&b3+O|X#Gr3B1!g8RRbuAQ zhdVHkNj$ENM)bMS62M2mR!LW5R;CA$0GQycwK&WY;gb(CoQ5s z6_vIT?SkOXyuAjcbS$@ktE>y9_sXbVQ6a~cqAmw!;z4vTL9C3l&9Y!uP9kj=?;aZg zjnck8jxE``{92MC8tVd~`??3Qg;-nk^IApdt)9|%Op0djdY2p*DeQKKEyB}tu1=Hw zv13}^F4eq%K8v1ekp|8D=*mfSJ+8Xkl8ea2^z~ub-4DCVt^EZRH;OI$DYCduoyrDL zsje{Hv85n%?X$$*0%p`up%@(;-fGT`5{ywpd}3_N`ysb54g)Qlvh=~Oq4n9~l2I7^ zRff@iX%yiuj;>-`gboE-e!m1vI-vO@s3{L+p+V^A2wS|sE1qd~W7NCgYZ7|@m6a>Bu6HDO&42v7f= z`I~e!?T33hs2j$U%PlKwoqwQXdyAQ{v|ZeBw!~c)DRa3c-nhbFbrZ>4Z=KX;drUsN zKIP+LN9O&;FSt$=dj)!ex*reFDV7KcNojv!OTrACy4;eD$>j_dp31-FS2I^PiY-Ql z_hE`IF1}c2s7NeIrejNn>NdBDEtH!JUNq5xi5||Zrg@&<=*|T#W69d3M#uedjxgcD zlCcy6=iJ^0Yo%EDV5yAb>X)Y(tEFC=qbovVX(tDU)TYc$fH5zUUZR*e*C^JQgf?kWSVQ$fnwi?Q%=OkHd-{ zhwC_Vm)PRM9I=J`P$Iw&VZ?e2=~!-IA5EE|-e|E?yj0J#{V`8ZQ5UnfumDp7MHXw> ztkTHcVT;TgI@X$MBMmB@pMYCCTqkOf!AdQ;L^qFqA|*l^Rzve^U(4TcY{^FDZnEoK z4%6I7`Qq@)jbe)sgO8*f2b1GqvT@YF_GQ=-2bDvMk17>`Vh8L_C)x{ZR)lT9|4Ucz zPA8H+9NU)4nU2M+abDm_+TP`sqcH1@@I#?*zJ#8sS|)8z85Iz$kaZ4()b1&@v zT?9(nkQxBPb)uwx>z;OpE$e={{JdjJ`Sw~@8kM`&E47CmTe4xf(+O6EU?|j=(bfu+ z8#jtAN`{SsM$m313VqmO=ME4CV(N1-Bo5uP5@SSO;xQc@MS+ej$H{m(#wb#^%&{#~ z`pH7GX7kDtYL?`3%M?o@7-h+qXZWEn3$7FD;shK2x;YqSFycQV9!p*SpxmM|hqUVz zILf+EZoxtMjS+YU321QOm&-HQbd(c30S9v2)r_liDN%68}b}tt>tXwn$y71<1AhQyRZbB)U%2^kd6=Dz{i&fF@oQv?m+5 zjqu~xQX13Rrs8hXQyYHGV~+L~)!O3VvF)aM+n4g#Af}9|4|^c zQ~u3Pi;68M-Me_fm`8x9BX}T{B@gwgA`_A>m0Oy5)kJsGy{HrI`cPk1mj@;@+F$E^ zQEu7I#^o~MC>;89>eJS@@@T@Al`k!QAc=2L3QQwPl<6a^$Y)evwhy}8vh+*Ke^hLd zzC)&zH8UmVLB7{$*)F$4U6}R`EiFrXm8y<)B8eX9-V#|rrx=3lQs{)+-OmIPo zSi)1byv%YuA;b7rJ8^fmTxnYks7bZ%w)}`O|0zGTwAKu9Y^gT-8rScePPChi%e@yi znb`Fe*DAI-ZWLP}XJZtML99qUV;#$BTdE>cYs-$YCGtaPLDvI0G8G+>Q=n15-!OF$ zTR6wY0%CoVGB{|UN#sS3jN?TtN3&1-DX}FRmwRUId&Y6y;d6tz}K z`H*7JSs%~V;ML#fNq0I?so1qITqj!l&Ekc>u%+My&)z$^B^#GZW8A&);9humFFX=_ z+1X^;$A>c2lxxMS8^sn7Qxz4sbPNNkSkhW233n7*R2N=RhDhGBh^takq7#7~OX*lr z2IF#t4)F7;Wju<>gU}$=G9oMD-{$3L-C>K=1zn;_hqa5Q;WD7BFjU%w*;}+-R+N$F zsmLwL(|Q?4W`K=)rWN$}QQr-0|W9Y12KM1brGy4`9oK?eL$yv1f+b z-0`;qvR0dFl_aRpIInD}Zp+O+vHAy>TaX(~R%7F@SdU|p3?@xmaTIdPj+LQ8lPB5; zu-C0P+};9%p3IsJN4qL1)9#qrjGjR>s3BKUOYEah(VaEOg*+ znWwn1;^pJ zI?%leI-2oK%UIcT`AXO?lv}8GlNl8%bodEMHw1hqB}ZE>D^e*#M{AohY$|tsBJ_1g7Kg zJ}g-}T6JWXTZ$NWu6(xnjM+J$TAA3K3w7@pTeiQDL`D*@*1jUBeu6EQYeZIY7j>aE zctw4PEu7m(1hg3fLYW3z0+6>Tla6lF&V8Y6yVwZ}u|7FL(T2v~8xCTN$sEy^oG=6i zwiUc!k=2>v$ExuS{>VN<2E!ntSnLQ%7 ztiTmA6xag(l(XduzoqN2BS$Y!>%Ig10evUmeZm(jyN_cFNxb5b*judYG*xA3*THz~ zD#yR@ben`UVZ#CR0Cj)H%9gq?=;$WL0>=Rxwy9a;mzVujKM|ggz$sF^{e{RZ5~hRm zR9e~Ok9D*owvZ0vMXh`3cx-yJpp4ieSSw??0c*{p(MW(5)19A4+xDt_bz5%pJX#wp zO=kb76QRD^w$;hUxA*1jRBscq#N%7Cak;77(gIp;)|P8xOVgOvMYnW*_N%)Nv7XS0 z8^24{+HDFh1N5^K%ju zdCCr_es{CC;LDYcg=)ATkHcLsKO-DRxkZU+q(K&;f(%+N8)bI2w}1}e*_RSpYb!iu zQDEfTG9D3Iu6sDPWaDzrCJSzNX2zC?G>sb+3o$pU6P=;i(CTN1xj8q!rj6_oST(j3 z*itO_rIpY6K3h6E5^}@9v4unk4OKmYv+fFT=?+`49$R^_6V!q2Vql1#dU&}>Yg1q9 zN^X(ScqSrg;!7_`iEtKMsoF4RZ%HF#bdpGsNoU#u_9{?k*n*l;`8mWumcd?AhP08@ z4p+8AsZPXsgH>s)NR{x0YsxJryw9L+k;C9hrQPU>3~4TdOr8RAA>C){jHJWLN{6gbqFky3` z*jl7&7X}^fgIE5n-n03BlY zDbdnE2Yt}jI}}@_F4iMWOFV0y*PFiP_Lig@_202?gUKz{9k9%fbs~;1tH?qs5>*`N zDQZE2o`$CNL>RHZyH39I~P_)c72wp*We9XR#=^Jjli6Hi1hc zrc{aE+5Sgw`naonxqo0z!B`v;;2aoadPJQqJXceOW1pp3K@OUn2nQ^q5dA&{^Xn}iO`i_LU=DrG3%yUDSJZ(2sK zE{{=$cZTeMCeq~W6qH-CJvia1eFcph`*D#7n%J@@GoCbzjDjX*p(rDUMWVVlDVEqG;?14MG$b4#;ixE3aifg*H@c|f-?TWFThfgf zV|%pD4Bn zPva2Tuuj^?keL(o(w^Idf36e7{+!5Bg*?1mmQs7mUN9nB&>)5xOLV9+VVCxn2idsX z4F!~qd-``J%bRqfl`k!QAjK9Vf}@d!WeZkW`nvq+*z#Qw^ZyWi59>;81$`k~79PQJ zA9QS4{kiNDiB9AkRdCT!(BzjaQ$c)Uj)m(T;)53Bz}3rfY`J<7f-RIu&nBET(nFI%xM?aJCKwxA5o=1qWaWk|w7N^#^{CFW;^+ya)8pU7i_ zD0}eGWcxBTonlKiE>}h~T5H(Hj&3cE8^xAmN-b0(D64qr7?CDABz6@rxT=QQvKeO4 zhv_FO1c4S6sXan$p}h}8;3()oV=-pJ?4`$n)LFEm!)yztkPJc#&5+ak=G6Z|h4du%%VWonlKi zF86fW8~0y_r}lRxWjBf~ZHcH+>2gadzgIm%W$11wL$Sq(FgPKa#2K{qO6^9+*y61c z?R-%sf%XzDsWlpS!~H~2`HO$o;7M0;lJn0l$vT?Z>aFY@C zZ>Rh+lgt@9wsKMouw{EUOy0~p-VPeEQ5U`G8)1RS448$d6kp;Yd--i6I6SqT#vfH~ ziC0(qt2z*aA9Q@MAOE zE?wDMum|8}Z#Wg%I`Kvp9b_|Z6TiSd%hN@FzL*ZqZdq^n3tP$^p;K(h#^rt`a?5Zm zyIq$FXuJZp?0g#jb1~{1TNo;UBd!{WbGAXw4thy``G{i6UQ|u#S=;f>=wQK-xU38= z-`fk%zIpi!C&l}bA`@r|48&8Fqk=7FIxzTVxS4~&GCI1kx3Df>J^Q!gZ$YEt)Nb*4 zr+XP4)QR@OPhTH@Lx$`+Lw9S9p#%1o>mI}w+I=>Vk8;rC zI6AgcfaeTsmGP zc5W~H`0WqJ-_*xkyE1I8;)85l?l&T@Eaz(a>rLrId*SFi`%dJR7|m=XKR_epyPw%x zFt^1*ybK!6+Loc%^38YOeJ_+e@WJGznXNfxNa?(SEk&!j7tT8$P^P&;YHz_7N0E>Q zI#yZUYjR7h!CG{5Wp5GN(KpWy{z-@`d3Z23Q-gbnm+``NqL{I`_*?j|R_J|2Yzc(7e9*wgGD|MKhb7cGxxj}ql zKfT`3soau{%UxXjJp}$A|Ft=YEuYyt#H3+fmP~0iU9J-)KD`(-icH*)vQ|e) zb?hf1PZQz2bya|qCbu-!W!S1R#1@W&DiKsNIR+4q!ap!1QChUcG$!?lumyfmClXha zy?`g}L5w9@d+@fpFxYIk*AQw|m0MP~Wc>-nmc7_Pou}b)I?-q^e&0i#>IJYao#k(l zeu|XU?5A`)?EXDQzRg~UJF1Wf*Zk%A7+v z*BBsU5a5P@Q5B&+<`1Nv#;imcyX$!{KL(y9Kcdlk|b*c+$*z=#UcQ z%VHE;uGuafVT<6k^ijsL%9=-x9&Zr??1G7vGsPC%q}DD*JFuPbt{Vke3`$h()rUfaA*D^7PJ5$b()JqG~NkAR{keIuaTOQ`(a)U669Z<3?%%|96JM7+% z^{D@)y`{Piy8hHUcar#)h%CNvpfr@06xx6-5mPFm-8R0QMZN2tl$Q8<{*1{YX< zh7Cp99gZyz5$g8R0tc|7=p3)hdN0dL^Lc+Snqu$Em^;V1Of$r~PSoy`jZdlEqA~|M zx5z$>b-2GP6BhR$VV#x=9kjO)TR1vUfW%7J`@2}<=$5ob0_O|HxQ=OUINJQFgowjYdPdiC>IuTZ5=-8;s)@LQA)at<-jxA_9u0@B0 zQ3xltg{S;vccE#f)sQmZJDn&Sm#bSH+2&Ocm_>Y+IyC=tQ`jPNiV}la;e0x|2=fVq zO(f66kmATrwv#H90VC3}CFZq0uIx}+-LEPs%qA<0N7~3L!b~$0vUj_~mVzIWa-@kN zSt=52DeCDwGZs}jR4a{gi%Ko*7BB^H5whmTJw!f8jnq5z)d0|X#!M1kIviVcr?@4p zpqs-r2@W00E!xMMyI6_#>V^A>3Z6p0iz;}os{ly}kckyx4Xld&d_GgRTfwK1h;WGV($^I~GhmTKW^ToYTw&Y=_E z6;Ofl0&_#*pimGOdD1=s!NBI#G(SSTTM`Fr?%3j`u79G~g4NX4wbHiT+$6U7v8@#@ zz8`<-PHu@MUhS{TEmwP8-g2GjT4hkazTVL(wq)aSCCn5Kb|CG?0SS&TduJXQ)kOcz z$Ssy@M2IOz<@zd`#ocgr8GhvQ!??I8qC%8guB*>z%)bzUs;6||%S}^AjX@pjMA|NH zI#f9$B%DyiB%)@@59V*VEh=+Lyuj7B6FV36m2KIcZr)m$qE;G95@k_}L0-!H@1@{{L$+nEoc5 zAVqA=!LOHtJ~}Tsw6Fc;!=k-Xpy|$*D+FBmpFgGCl8wuqy@B6l)<^5ySAbc;H)6}~ z4PcAd280-NWVcfEU&A*Dt%x_oMiBQ|tWfDXQ4)0#b)rLC*jIU_cB$Bc+l=Rkiq!U( zg$jivr}#B46O@OdX;aLYl0z?vZ;4h2rgvc22DEOxzsk&p@o2GgH459`NbD`rw#L(K znpw6(JFdD;ROe}1mKNBO@D$md8+fV@RQbsomvo|(r)w~^J8Y4D>O)1lsu zRmYYXArU*NXZ@rl7hQ`ySE1C?uCp5{KTId`P#`>O_O7I0NU={pp|2T%nL=ZdVw6** zRM&}YHA(PjrOJa#F1y1P@RXCrm3eA0|JUNF$t`uBZpL*uD|s5%6J3X=9mUR3CyK+Q z#MTzL!X|fYk}8*sYQiPYz1opr-SFHS#qOTkBt z)p5Bcnb^In-If(ScrW>}FkN|hYRkQ*4GTW#>mKhNwq)aS7nhgq!z{rTV9WM{&|AFf z*xn+2ClaGmg7`^Wxrs0ytiWYZF~#M{B><1l$W9)uq+M!f~5fi_2X*aG`!Gq9AL zO*xtzTWBstcyWI?3_U#jvz`A=x9=~-7LrZnxSuF)h{6f(sk*Mcpq>?YfY6DeJeNgW zZfW{J%X^9~h~d+byY^V&XIv+;#F(iLP|v}>>&eg__SLvkCepDbeHETTu~~?X$5mq~ z7XkQK`-^SoHl?2dQIl(41M8})}uw%q#9t?tyYrPW*Ihg@zc-(KsgJGo`8&(PHl`%_#R}i6V@rG1)Sgsqf&EiC zQn+0iR!ez_j^zEYEMyH>Yknfed^+*_VdHc(>Awl5_r)unhJezaDsK0E-8t)Xl+l%+ zXiuB9uuf1Cl&Zu!O0zqvm08jqwlF4yJ*z@U=?+`=bbLtfFvqI)4dpe7&{;!O7HR5&!GB6@$;Ra(Lk;9d)j&VK6>g2Nd&kDD z5b$5)0c_cMRM`*OaX|}1Pmw}b;6W^2*FndttNm4M!CG3;q?1k@Q9)atT6KRv^9h$* zlzJ>{|1v7m7V1^yZr9iYaJi*qyRvOwR3|yGbx689iz;X(E0ki3>j2FGWh;10 zY+)RrRs;Zq|1_i_)0VCH^BX>!0aPZh?$0Z7bA#-teiVwdu~53x3F#Vk94^ zLZ|DEhOfrpL38G^f;5*~vT?avx6os@Ho*B4*zK@4140b21zFZ{L~OD67Pu(8(uwHX z+W;wY2+I}x=f7PJP|bQn7gdzAh%K=Q4}4^yE&1ixQYm|#OT`w{CBCH4@Hc~o7*=02 zTYN708?gnAqDQ$5W69DYI>eSeT{}QZXrI}S`Js?f@BWC6NBcn}gc?zbEhs}4AmCAz z+*lIhdTY<~Gu1<}WiPz$$wJzV@C7AnsG`_YmqM7x+2=^vCR?W>07-U7FBh$H3+NaR z2D0~-6c#6spMCBCnPrepi0KkrIMC#{17p%Dm)f)nbCy@4E!PL?M^`B$iNi|jxX!6# zOExaoH-a9&9ZZ?S1)IqXUk&F^L$BXoAjuiUn*M~p!jhqWqQ^Iqi`zb12+ndtHr>7- z&SeX3^rXbl{~0znw8M2G>LStjkEkONV?Kj~j3A0a>VUw^V&bnTrH7vB*rIuK^w(`l z*YdRV04$0BLNCohP)RJ%rQDM6eqL;$Vgg{D zd924+>`cP1m`fI|u29jPPE@9C-K#&PPLz$ytzpXwcF~l}*txO$iD-v~#0sOg93nRt zyOAfw>AVN`LV0TFN+%*65^Wdh@Gi`g9sP|%Q9C9QW0Rn$ky8eHm=JrlQ(_D0xSS5& z4krtGFJg$5xwIjyzk91XRv(=+-_{3a-AJp6lLLo#{7aX zLc=n>yTu#W!m?ZiFNku>3Hec?BOybu@#(Fw1>rJRM%7Q`rMEvJwvZp^!(R!gWnM_9 z(aGyR#Ikn+x!5XTK;ok3n|7aF{h-$T4t`=un9V4B$n&Wot&up#7A@oJtCeB>RLl6N zD1!n_TRKc`(K7z;q6}s!Zz@CilQxmdExEYdP{S6;EtjM46!-DZME>wbJcupsCc=2^ z#!r;2pYe}j@bg^!FY)WSzb?1r9%yl&*uwrNRhQ?noPX4N#R*nA&G1~gjvg1K>1weq zw`e@Br>tz_Wu=e{j5sCTO1SNSz8b594dKpRVT=mD6*Tfd( zhx7uzm1Rht9~PIZ{7{`xxg!78du*LJms{#TwZ0RvjuQ`iFg`{LqsFx4r=EbtiB zcIMLx6NlbMuF~x%GUXX_?sVK*>Mdt$uCOS(JTy%H|ETH^)QL2hjell!HCRu)gWk~fLZI_i{ z*rM_JraUlcPp6B5;{2J*E&7N>{wJD;3{;~5Gm$XFz7$J!TP|+k>$YV@A=Q=TnP&Pb z*g{kgFG2C;R9uZ;F8_6%sBveH^0T?C?yx2Hb#$_#qib66+{csqjxBM($kYSg9h^?4 z^IHK@AV-G*=HS;k7*&-CyYxXLWu7~n&*p=C9+?v~ne^Bu16L0c`Z@+ZnIltTrYEz5#5Mau#mTdZ-3_3CTt?^7)l zm65@$Hc6;ZT4~$PV*dA%(aH+kLArgdUHOa6l~ZhC{~)*_R!xpOkJl>0_9uFjjmzzi z28cc2Rw*#VOQw$31LWi8KO7vjmT`y7)BO!~kZB5wn(qbrM{C;hXr^_uhdfVSn zY@t6QCM-!aYPKuK@z`!*oG+wMLRK`c44HDTXw_c5Y6JH z;JqO>WI&<7goINA+znEMcPqE$wj;aoDV1Bm5B3KfWe2ppBDH+9Bx_0Z6UFXi0qO)? zYMUI|Qv3ppiJ|mf3Hb!=926U`cSLOA$CQDnj^qg?DNLZc8f6??#GN47J7W9tPV6>I z33Z)FYAxNu^0+D=tU#g{ErD@vD6z!lmZe`>{$rfbaj_fXd=o=vb<8CQI)mr&lZ<%PxA$G^weTkCIzOept6wWQ`B$-9b9bOkEN587MclmEOw z(Va}R7}%gVe(u&KuKH)X!WPnDy&WI%n2t!Eb>$~w-$6CXhtjd{_Bx}Bu|d_tv8DRM8rO;~@S8CZi~W?iQzW4I8$Mff!%Vp` zzC~l0R9uMtTV82Z2JI~(gE0_FM2_{#VBWclUjH@fG9LC{qhp*7h8N-S_T$G}{P$6K zGZ~D>2vQi#-yylptdF&fBW^MBZZJI~2U2@Wrn)O{E4H}a{jN71+ZMy|v}QW1mFf1D z+Ar;I5L?8y4a5FS21)$>e%`oWDc-R~B$HIF-S7yVsP|T0^-ISV1W+{z_{+>TOMWOa!p?Frt>OfPMWYK^JvT4iY-TjbM(oJ-Wxb?2k-pVyVz*q zcvipf59o=@EtUK0Tt=P9ID%JgbjuV~kbt?Zuu?GjU~;(JA}!tD7wu<9R?$U~UkqPn zb{mf0;u{G1f&^rNgB*`$%a!j+*MW5GVYrbhG1h4xPYAG6*NGyw(m22^f%KZcG0TaVDjvd!xvBC}SJ*GGRKyfFYX1_`D#r0ot@{< zN#e?Bf1`fla!bsw5ErKY1l0((x|ngU{$_ELjxBbjgLh(UG-EA6M+r{(GR zk7Els{l$^wBP{C61U?y|fg}XvDbOVqQ0$e9$a~ zBe6w{%)_*5GDko;Q||;8!MZyRH`O;;hr3SYmTX+^6PaO^uqUUJv)_VBS0(b33(74w zk-udxC?%pu^v^|)7@reTB(NJ4yq)wnN5e6UoAtx7rPO8?uqk^+JcMQ}wzJqZYK1tq z*e~MRW1DZ%?5d#|X~Ua4vlN-@*itLK{f(#-ZD^yAAp}=oY;=5S#2rGmo(ojjT9~v4 zm9eG$x6>!1Emz5?5s^NcJ$Idm;*3>D4cq;Fk>&`sQ3=ST;O)}hqCK1}wQ1`ToQ=~J z#$w9DYNgcPvKKf=7!bY@_;S)Ld;t!;O^}!PQ7LRX6tC#XT`d#{uo?B zRr&*Khhmfi=C7y|X;+FpN!F8uXWzVh##f#`r8`?*QuV7`Gmme{#^vsT7l#vAu6poh zHi>(cx>IiXET&k%9NSgw++I+*at|Vmnsv`rFImcqnT_IcLnZo1PYws=p+fFvvsR;;^~blYY+7?&H{ z7N?@0>0;QrZq_W?x!lt9ftL5&-qP~yI<&+Xtf|EOKi3 z$bA6Vvb|ebPlOy;=C=jEqvIBK+!Wa{Jh8>2*S}L_?YZO@7O+UZA|to!nB4Q)BMWcYiVBR`yiImWY$C zBWu5+kCVQ#6`RmRZ22@Bm-`ltZ1Gc3F2J(D3G906RZW;Er%l*WeP+FD#TMfa$dTn4 z5vy7jrP$(PSFBOXxAn2APPEp`_ON1$tj!Y<%OLXpq7y`}9(8=fP!oP=B7jYq$Q=ZG484NEjS zmxmbK3a=1Qx70C-@yLA@-(EtV6bW8(&U^`j_aEWK1lsB!R`MT3vA9=0y22LPa-{}d zJUF-?xRB>bcs89*rnkaBC;i?j*7#z>6J>jx9Pv&wwnYB#(-ejRX=;!6Dj+Fkl1#88M-XUmE`Ou0>ms?gmx9n%dmc1aI zn-5|bNq~gVBfQCsprTZdZz*oAeWuu=bm;gBN>iqhnuzL7C&JRf%ILNV#X-35az`EF zf@4cIE_Z@JgeeF9OwuPUpF;5II<|0rB>Zfm5Cd#41-En<@8_Grbt1FFa!Qw&b_r5^ zxQWqYvGK5{>xz^b%ZV+dgL5>##JCa(D=`6np9QL|SS{7H0`O9I*s=$=61j>4efS|1 zz}Q$)rNu?>SN@hcTy8n~4vUDaN|;3MNn&J9ZDLuQdAm!c%Qfm!Cz8Ig+?1ZF33+OM zBDb-Nh1`tnZ0Sd^v8OE)(<2o1=@MHg^PqEz0LQ*jn2B@&SX}iiKAzZU`&vE67OxBG zhio!I1UtH>xd5}g;14dh7zY@GBK;kG1TLP_5xhLoM-Xz*-`DMH=%P%I1Y4*jYKK;1 zt0{`Q+Mux9rf=)H+gr>bp+N!iZ^8KbYo$AmE!ntSjoAt3*pZyh(Uk{vqVoPk9Mk%` zTdZk>S0fi0*WZ_HvALohTTE33kLh?7XDykxZ!a$8Rm}6xXR)}IWngiHmw|K!ax5>S zENdcml#4XHjPc+VbJ?ijJktW*`H4jGvc|z!ur+Nad%+4B*KpF6)`LTB9^GkDPsf%d z_jPp7yWOXh3oa(ORzC4xms<+|GtE7R(cGiX{eyUk6KrZA+)B$ZY@tj373y>kZuFTmTUS8Y(3GZxwu>?5}RTfh~2oTL-W~9*<1D^9TYia3q_vn(wL8x z&pTi2Vho{?cD|GoY?l5cO(^8HTmgOC7@@fW*}E>cP+kxSR|lPJt*|M*6;Suhvx9#= zGjE;<5;y0AmPk#I+l(x}1oGSG2LW4em29kzEy9mJkkAA73H2pi{6YjpUGU0cksp z7Knu`vA5WCqkrVp_)_JsW6QPnU`w#2QhwV@$CkD)G(6{WOT%w%Z@Ju(jmy;zjJ3ms zco=AKM#_WHNGHcqY#p%WhJ4Vqp#)gzA<_lA$@(k}%~&$_RO|2966IL!xBIrxPgE@Q zb#_9WCyxH4AjcLPOS;B&KN#xrUE+v}XlbBJsf=J?#`*vT?Z*?Tv&QjQMVJP;U7YHlVKenpck+5<#@q&QfX} zThg0ro)cTtb_8BHN78nuXrN<~ZP|3VPDCU^@4s%3VCE##@MhQvqK<0x$u+e#WaiNqvXhJKvq zugfjY3ASKTpiBbA^cry{ZL6i&((r0oa?&cey`{u#Yoyrsm$nM|QP$l{MYX)>6kD=! zx!&qOBOI;80c@$|`ET*sl1J3uf_yoXElFg{873J6huOG(nzI2-; zSB|z`W`ec?U2bXmK+AiIEq5z*!Gb6s&Z`S5Vaw{r8=p{YQM{J@J2-Jv2Q{RcbY=mS z{wNFW3R~#6_3t!NyZokOi^-Eu)w3(oS33U_DSAwgG&mCS+vKNQEM8-@mF0plwNEmfG8W#7uPLz$y zWqsB;Zc1*!I{cwg0wXGC73lG>4m2b_Y9QCKrQx@>x1!tvzZ|r{tHz3%PPEUI;KUe{ z!*HD>1Ba0-h6v&bdIASX^K_<4Nq5+?r;S^z##W4mqD1~`JwptGud&IoCB^F~K(VpP zass`Sg;HasEwQ)MzL&e<*phpo#r-O_w0NcVNO#y$D|)RP-C@gGpRGOY*piLQwOOF{ zX6^>DWv3FCn|rq1eabDAn`Js;oRJy`bR3)wE)j4=zmW&*&WEpF&-H0n4_dC_vR01kL|D*>OwqC-kjC)hVch$?pYr?jBbie8xNL#!6D1+I_um|gCZHOOn_y|cLv@ug;+DE`{+ z@B4-=@W--gv7OBDd<)v5qbIM^^r#*aCS{d&P$AD`_h^OivxoxC7>r5Cg}SWRFR(5N0dn zdXwEV?PcAwQhw6yAmmhNbZoI?$3h1pSL4UMXxww&xTc}ibh!m>8;ijyzlyim;!coV zr=`X+cJ%~L>$lhFp!z28>4BYH{f}bHo@OYcfX!OC;lPsTszSJJjpsNWzuKj}<#9GH z_n!0|#)gM`^6%y*#Lg|6CEzeNH1xiql13>p4oCAXXA3Q zl@5$J@Lv4af(~;FdHeLtQO3nP z(BSZonsb-s;u36G$$+H~D7L7~;nji65$guAqqvB*D89LkCR%}sz-1Qy?e#kkvQQXWH=W&o6j-K-C-eKzdF-|<;*dN#bzjJdRhP8Rda#XPZr+Kq<@zC=)1!aT>8 zD!FT1t4<_#j)Ez8e+=)HE?l_n!IO6mju1VGKv0dP^sl(wf;HWreTqk7PO3HXO=Yn~ z0#otL&4*0Y6te&yhRp}*wa}8)iGHD-V>FR{OAqkcul?7r@J7?p*Uqt}=wLK*tAcm8 zxamx+oOFpT{eCY~XD%D&2^1ZXSIhnsx<<1U?OQYk&bu(HB!e5=tsjmprCMALrm(|bs1PfRu+=bW zxSJQ&l}<#TgYvYYE_wRgEZkskSw^3}ca2-W#T{CZw#bhHH!pFPI!-gDNXwybsC@zJN6n^()w^>Uw_RD?to(%f@~8fiTPpmp^+ZU? zp79gCM)ra5#qDq#&JpHV#u<5^J*X3X)_Ghm=Y!WE#0+HY`<0G=2@e*+^)r2_JDmu0 zkRw8g>=anoafK&XN=8B@n>A0c3_WpYx!fYpUhN;nmOVDgl7rvo|C5g=PiJ+ankb+Fnma4fvk(yh0p?_r&leAT**di&w*+V>KTv7!rIuj?i8sp-& zmeQ8!GhN9ov~9;`!Ooj!g4FlUR-kl2rpqm|K_-0HXZPW|#qY9%FEIQw#9AOf1_QdW z&PuDX&C^&D)}^bsT-3$JI_tuw-Nyflfv0A=+d8A1!GKxHLJ;Fy9%tinFQ+i-*?y_? zZx(!LJ_EKO=Kp+f8XjYbYnM4K&$g%{Y+yfD^jjOzvi3|D_MG)jX99vVX$S?vC_^v9 z7B-vocBVG4Zg2CKC@2xGRBnMEV2d>;9R;jxY*pa=E3rwf31}3-S_L+rk;?ZM$ur{!A78ThULnuy!c~ z4(2vpSq&+tOKj0G;tnC}QIu5|7jU21LRpG=$C!CQbxe-|c00Cs?bbi(4qMj$cKU{6 zOExZdguPZm|Nbb9?ytlZmQ0U zVw_N@G@L9ur|PIF_683$_3!6JDmuz2jnU&Hn6BDKvAzia*$qs zIR7mmOl!&EIuY#=ECB`*db_{}82@==KPYD83n|Ghc=?F0o=xBK#TXZ|CGjQ8%1HJQ zAvd=J)gpZV7{djK5S0`q>2x&VCXnSLBe!5_Ia>JdoR8(KP~9{ebg2-xw-k3pZy_Zr zr4&Ep&Kz6RMD-c6Ru5-yL|a~gutkY~=|lxDc;?uWjmy1QjON36kBo+UbO_ybd6GfZ zi6+=W7J62Pa*Oz9E_(~CbH?F0Mm*QXix?NjpKFK9EiaL5NFqqpfwQX@KWa=WoXodz z12R1d_|bBLdRdAs*UV|rSzIn-qcB#l6a~n3vG^8Z+CFj(U*aEi$|o5Jbf7r{DkmV#_zZ z)4?db!#-Mg*mHB@{6|gJ0@!6AlYnW2ElUEIqF9$(aG!o|>#T84VsvsQe2Ix)I1J=k zLz%4@m0PaaPbJSkw~~Aah<`GYN_M6*=8wi;&+J7f1sz=)a!LAz*yJj2I`;uw@rz_-wq5!E`p9 z4giC_e&04#^*8D#4RQ;ND_=rZ8caW~Ki+t!K_{Bgs0%#fwyszSEdrF#$aE0X$q431 z@H~+jO>TLJy2wvhx_gmrjz%gRTOOed4V_@VYJTINlj-jR?2$MapTYwA2D>84E$^IUGzU(2{ywFr@p7c3>kDxy9)~riQmt5&R?P z(W!nCzJb=H+vUaw;$LD5lKS?h!`|s=5VV05d*ZnigK1%K(Yt(I&3VXjTyBYlUg57| z3sUbrE)>nv`yioG7WUYF{o8E#2Ky~y)7C-ww<)$5SMd{cFz+17NF8VQ>0B=#C*kxr zZ0v?#>WWo^PE>xm#g$@<#_&z=7u$ALU#-+-8jhek{l0iL9iE@7+~Vyb3YFP)?L79= zZ*?{}gBm^>%zx(;`F!vi{{NX`i_(#(WmPiJPxXb<7eb=Ox(!4j4=`rnHP!2;J!yCI<{2!Kzj5c1_8zwB6pIC z;MC=oD$~l3Exl4~xvnnqVCgs7{P^BsOD-<=BwPVp9$+D~8eF=PTj+zHzaGw>!oc7F zf+-TJ1dXAT=o8;qy#*XwsCXm!^**ei?|PD_0jFnQHtFEiQXE^VKdf=B*s`@@T*bB* zhGa-dps{Ob(9@`LB6UCZ)qn)mpPUUoOepXFcMT{*V2d%W=}#g@IIdo{JLwbx|KSpld~nFvyBY5Yiw zo5U9OvDmv4u#H{Kr!=`y6^!u>#}+n)j~7N3w?7!Ih5e{whuHYhLl9xOB6r6dzY{|yu&S~+!=uO|4Ef1mt zGnG8WeA=ihslBD^b3OM(ac!5FtM15;o@jI$a6R4dD| zMNtU4vg-cqN``w&IIYFiu%-5u)i>1MvZsxb41xr5eH@TQs93FkJGMyYMYn?=Tl!$N z7qb)NXOvM}3gFm+K4ya+OZfz$XJMgEn^g=+<(AboZ+?Q6d_`_x!*B?- z4Ny=j%;gsCPS#7bW5jO4c8>E`DM-vpa%?G;yxxUk3v+yOa3zh48VRP|*A&XEk0}%? zscN|-?ak*+e`zTK97cl4|SBV%n8^23z={`3U;~h7&-!^f4 zRo8+19`#u3Hr6l&azpUh5p>c-cX8Tiw6~$c^(FpXl^kFYu1oKY&k*yh(yTrQ_x@qW;Uuf znjBjiXl#2+u?6zAc`mhaBPg(4okDx0-q&1iY5UQJ=M-DaiHP5q(ILICPDUZOG?d@= zmSamcF83yvsAb3UqbN{dORf0UHxye;7fC7; zza@29AriXW;lFV3cOsg<1M8Wa!X;##T-j> z1+ylmUd9na@T3&?*qslji1KJW6k8g9YJF3&g?sgmCUdQa&atb-1pkK1ElTS?lm#Xn zLTcNfu2(1y45`(PH~h8IiDQetVcVr?fn0(Vi!P7MQW1sRV!#?LD{@(hO)I}yTy-b6 zU`!*BxysU54{d3!>}Er}vCA#6U&VK#f~gZnL38dbv9~BPka_zBFVQ}({N|v+vBin- zSU+oA{ef*HCawmMaBRsD+TwoHiO^3SkD^^Kl9u-2cn?NlSJS%EiKu7FeyGW~mp(?5 z7edWAhV}bkN=mTt#^si5TrNb>%L$eg&0tN!-aC>#b{Ufvufs0ZQe95NW8V*Y+4HM^ zBet-fe^3D(V@F1aneG_sV?Qmd)S&gUp}D>AuH+Wdp-dn#^iov`IuXYX9X!m#OJ^?D zY9p5npM45kuw2}ln-^vY*}D}&7vucJb!GW``DSyCx{_O1m)N>e8BjR;?SlKy!(LA= zi(-LWcT+c2!c&X+x4GV@{AkQJDKpS^+;A- zMNg$grH7^)v3o6DZt+H~%B0{jl1h930gtNHj@ZI<%$bGI(*c461|Nq_*((=+8TqTB zT24xOLcs-ty#y{az_S$864|ROJviRUiV!Ziq|=hrRla*d!yyB9*^{<1yH-26=oD6T z-jwte=PtOYztr48(vLBIY_Hu1>Lil81{vBzwQvU)En{DY!G~asRf1dwCnO^{{g3*x zwVQf%x&#+(7j4_5bzt`8(6~#HYc&ZYvWYx9UN!u1LG@K>iqVU44M4n^U9LRh3k`#K!bj)ZwZ^nhP zu{Z}8by4;g*kA;U)%T&FF_a<1juv;)i|?g>T`S6bKNh-7$#QT>3tsbFB^QlE?Juw~ z`^9F`Fhv5o`ftUDQpu&byWW|C3-=X}9$xNVfQ2HvU_xHy6E3;Ps4Zhm+IQ_-H@3G6 zT8TJgJGfLTEHZ{*$tEJ9sM?3KOZE}&SyA!Kr{Gc{vGt`(F0J3FKUhdE+0fjx0V0!W za8YJ3NS?FWJh#}EuA-YU=Sm8)SO>vtL1mc^v{MMb8+8c>m-zk_{zh|d+*(A{BAt`k z7U$qn$WE5^3h{GLKu#wkENYIzCc2wctXw4rm$n~mcrKcARd2upcZHWfv&;U1B?r1e z>Askdj6memon!eGH%ijO!R3kUG$sWUd$P#puP)F*ele_!+|xQ`)FS&ryFUspW}3z; zwMwvute6+8lFQFXo>Jxnua`k>65`U1?8c`YTpE9Eck}%Nmt1VFct)_GV}NyS6Kv&^ z$+cKi8{o3@0~;51+h@}+tGx%1xYw_aB<0H zKbpxn%+dEvLxIHjA~AJGpqW-K+=Z$QD+_{HOYl0c8?c0+L*EDU-L>RkY_8!>o@Lt4ulp%{z*s zVD&N{y?@}64bB~o?^~K{?323aV^y?_@GQ${bMd%;3~D-yu6IPW=)1)nf%3Lnk<63* zkEu)?Vg1{a&<8qber^Vx$CRnD5gc5uK}wWdKnK!*gOs>$k`iEFUopGEpvx_cr7n_j z(azCf?99@X$P*A7>jXz|ktZ&Duh<@P-lMn8&cx&?dUCx0+;O$2@z-`Y6&kJb&f8VQ?P3n6n zbO{YjKMA+6ka{+l-O{K233vYK76!E$%GM#i@~nc(-S8co#13tx^iKSx`LBXYH23H; zT80{cn%^qlRdBgmGNEf3szH~ZZoX1*xeG_;Ot)~rV_HUfr}^D@SHT5(UD7$UjPy=? zy7_NaEoy#h`CXMZ0@6{sgcPqJM<8wDoDKfM_Xmi;K7ypeo7lbf$r4}JcyrjUoJsU8Ukx1b$V1^m! zGUznVS0kwoE{FQkU5f!yu>*nTFKk)<3!GV^0lLr9!)-2_Cjom5#chaQgu}mw*=uSx zFVG8ULYX34Ly_9Ri*ay~utH=(h~Jgx{jsGd3NA1JY?^et^y%gwyHks_U1Bdu8=^lN z;^Tc8tOrQ7_AB{{zeiXSHL>(HZgbIwy$!n!x8@CKrWpEv1Rf#a1~*@XXUVI$p@)MD z0-m_Rb<7#T^JDwevFBZwV%o#!E0S*_xk&1`+rg8qd0Ge1`~8BBT|GS;zMZ@s z;p^cEPMNUHpG6sdGc6-FzkAGZ|D%n;M;H+?xo5JKe9Wy_rNe^g zVv0q)fskcMfDms~Pav(M_y)2hm zDvdW1=HOD1T1u0D9N7mM@f+YGM+G?UJlw(fG}#?FHo-^`8zf{H0eUj7qZIDoa_8Ye zI;e~BDPKS-T+tOS5ZH`en#+fS%i&AOKnD#AMOE;C*&q!tAY^gOq^al(Tucg6=_TfC zqxABVDI#WfDAWrswTOy`+guV(t;L`MC%Xj@Yb=8RL@x3_-i*(x>-URzd{+FY!RB#tR~8Gf^Y6I!y`T&#>D9CyDcqqvzX zM8U<%C>CaW8Rmy8erYI3)gmq92Tl%yOkGcCBy*bO$b4 zm;Gwf?mTMOwlU5{+P2W|@~!Dru--wbql0)X3?j4JaG-2pl3l-D;=;u=-|u?Og1WqC z23^!C2QC`aH6n_#En0vJ8tQEDd&gP-v7Ly8mnGnWjn5dp#nH6v};B@46^T$X=l)vqeK=wMQgZpgL+TMiEMNpb#Pi(W(hTrE0)4f)spYbJa@avup& zSIY)Au>R;tBS{V}*zHLkcQB$~rGEht6-w9g!@-5#Gpa^W6-%a?Nl5IG~ zgLfLcXeW6~a8h!|;IaV<_RXtq;unPkO?PB;!I)_J#)H?SR zT%_})#DqJC64nr<-(plX6rM;fw`1$*0E*KsUNWxdSlS)9AP`SEDWf1t|F+6rcPO-B z(v-^A!G+J*GAPSWrEhVqkN#%4sM56g+hQtmaB1LG+gmQVw0)uBx$eNFq3|_sx#Y6O zJJm<4;8Oj)&2<%A+PqVJCIy%3Z*8x;wYlUXbWg%p$Jdlx+Eys{TmmjSWOQcI+1@86 zKs)}^K&?A4DXVWZmg(T4)43@VrFmrqv`}IwW`tPox_=Y3NP!@oWxXz(Hhrq%j!IfB z`!3MZCwAPOFxi?=|;Bpd} zp6zTnm_cFx_rY)T>0o#|n2y722r(S@!}G=X4K4l%jh2l<$B^U;O@QEnG6o39JX=g5 z;~#wc@_6gz|9lx<4*qK~z^<2LBzKx(pV+~xTw;Rv4_xvQy0*+IE^zYp$ei4ii^Wz2i0NfCDrlAlKB$uEAY;Bp7%4e1&P?BG)1^^Wem zMHozR0h;ZId^wrz$VxR>p~T#c8@m~Ml!FWTrK_1K?{I~^nb(11fGmpD)D0g?XhUKMkS`5H2sNOXx;G#JrlsAZHd>;56{0WOFI~ z(*8oh1w6HGZY+gOZ^w*!RwZgWnZqR)!!+ThytdCggO+KNB5Q28dM2jsBo|xyh|j4x z<7agS#+8r1WGZ2|%aRMBSY%Ksb2}W29zDq96>NAZU z!lJuahQS@~8S0@H2f83+r$Uola!ON{A*CO>1DB7m#Klprf1fLoljEb^PtsozyOI2e zQwNvw?X|8HTsR;#A#$lr2ves>6!3*)p5%HQnu`>qVk-hH6kJe76HE(eS&QEW;3w~; zgetfQ*j8$ZrvyB$4A2vcNN*Ff99(2&d0INoml*leCly>k2iJsGk8OZb1{~8z6EV;CLrS_0ZE(pBLc#9NVE~gScjslMFe;2;TQp?cm z_py(7tw=~NSXJ-z-#WbwJtq3b5HDhfw4>QDHu5?Ha2Nzm6bn!o|6cAq+ql`0C zKCq1}QfQH92Qrte94&Sz@PEy(Kz(rHomAQK7;aA(?;}HMse1&{|xGer|KgTs6ad1g! zTlbXUVv8`JTI0fG7w$>S9&Qk;kB~)zMvSEK3sV&CJGe0TS3}*>7}*BjP@T%Z)S@y^ z{+!^FjnKsco-;rJcSuLx@$uPcfMEZ#;gq@YnlvMT3x-Aa`$UWAESo>>i|E2l=(!#8 z+4L;|wjbk3spTD95Y?)oZiiT|s738UJ&Son z;-I_(qiWe9&H>5bBu%+MA>6hCk8!f`F9;C(GANS2;xo5T72tBH3l|X}<$mh}O*M79 z2!Tsn(}`yAKB+|pa?-XEHZRg>t!Pkwqt1{7XEcq7&ti z>~@C^F3+aZ$@CVC!@o@!ctG(bPR+mFTCN&7xLl*{6 z_738M*Q@0IbjgL5W7hr{Y137-{Ebn~aOtU&MwGs9o*n%2S98=-4UkGVPK2>S*$TXB;*LUP%8teNOsEut3GMgdBSNlv>` zi<0pF^L`QI!gCM*w{C#61b!Z1xSp6{nOhgI-YmZ)Io&v*fmh`DWg zXPe9h{c(6bJUbg;&532}a>=Dy_!`%Ld5g--D!?Tdp&RoWU<#pPB#B@1)?AbhaJeDL zWlKJO8{gQvrG!8ife?Z;*s7->tYvtC1>5%Ae%NwR#3h$<{nxruaM=r6NahRihg|S4 zeFQ))V$m>z)#d{IR01wL_JVB-BmjhHv)LRuy_X&?xxnVzPzEK?b9%*>6_bF=gK`m{V&4GW2B2ahuCWJD--z zcsHG3^RU%aP{lK^rbwR$l3UT;ovgIZbFzIzJxg_`2JuSc`8=>ox%l}bu;l4#1 zq(Fue9>t2N%jD`y$X8Fknh^w8%%2vQ$@#G|JKJE*4l~S82X$ z_-8799+p9y3l55uXm`$~=xMs0Ca&L2u^$<3WUxtIb#RH@1@AFe)D&y>Hh#N5{#&-| z%Ij9fr+UHIO9W&=5gE=ggbv_w8HWEEbUA^I4e5^D46WQFyHkshVybA{V}uG7R|U!0 zvjkkS&#d~v!DZEhOMd@Law#*X0GDip?!RRA3ID>ruZ&*&SAR5tq>w-8EqZuUaV|zo zbVXk<=P9hYYG|fW_dbP*+jZNngA10!$20|Z9vr1nGWjamFA6SdjD4b9@hFNS#3uPb zLx~P9Fvb?Efee`vvn`hfCHB`+NeV94G#tWPblt<$BDO*79kF3t8(GyjF1ZvrBknvX zCEip{|H7ESOqII>7jYVR58sIW3YDOpgPFo@QCcJG99-@^c$RjoqHnw?I$v}qR2o?& zmrO+)zgoZPl1u%k)_1y{lD1A&JeB3Ol&mDK%u#O0lJvILEt_ zT(mAWG{iiueg_btF2*}MpQX@Ku9&Mu1@&oor1ZC#T%m$XUXX%|HK0=GDcJfF#LpuaG?YO}@rr(ESW+ z7rS*uKkqZD8+KGoZ9DXUP-Yp+x?giyNUUxDW4I-%hk}c4i7CG!0bKu7MkETs>G^Pg z4R#>?_PJGO*|=bZxy_|o_!`%gTuxx(q%f$TL`GgQd2Wt|<0U*zzCmy?(;>_{A+qIs z3pP+a;GbFG1E=&;6<K9H7ihEVR@OO^Ys7FElb4=-Am zk%G&^q%O1J@9oQAoQpf%5}v{hCp3Hb<>`HNmr6C{($%7-A6wodxY!3YkuEYN&-F%; zDtSd&3Ak7mVRf-f)N0G{)ovx1Y=rK{mf(u;-PjKsX#RlYg2tY_nRmRlXiuA--}aDs zwlc7R3NeNjy8%7;=I|_$=#mTF{N9JY5JWYzrBqW2p|fKI+dS>0Pb{t;aMKmIFlL7z zJ6)W^??k;)kd8HBg>YLy@4j3$1P8i7m(K7IY=Qs2L@?O8ehF&89tryardds4QpU>? zxRf~6{(|5lbs0h47w++0uM1mc<>BCBwMhB$lx@}GaJ9%P&(}_S{Wtg{$;H4>Y^e6^ z`)3C~Fl+`~&aRAGtl!NEo5 zTG=8+TPIqR&SSZZz^L;=`C*QS7W~gW;s)IZ*$CaMfJ-&bCHMJu_ZjEHPW);xx4B4E zS&=hP!q0&V`ajxz1c{^A6?NBgf*9`{T-trI@hJrtc&*N{TQn2-6etH=(6uaZVJ#h0 zZqQ|OD;(;J>`ZP3-4ABzYHWE2mqsev-BfVVZB)HFYu2YExwQLi?I{Hpc#9$t@D;_= z+QXR}4lbGB+uSC&oP<|MD>67=j3D#9?!85%(liXuWg-Y?6UfXI?j>5Fu}DfT66}e` z#E&mX`*#DE61H%^h`WUTpD~^Mf(alV4leX2A{K{I6T6DawflIbxWYW^u~z8qgE@bK zVDI30m&uzc#s_7;LF+ z>5_{{NpTQ7Ejp6}Al46_ZwVCcmgGDKmk5cwB}m-o!o%||(FscLC1gN?GJ|d`<6%=7 zqMIx!!_=bPpdPrS`%ql-$?e0;)CPjO1DCXR>z^yQhz&}6=|(tH;V+SFR}|}#OR-4; z_K$Qf{1lG7nQ)q?X{4?3_lQ z4;t28i`Ay&E49PH#WUsKc~G(+7cGvY@o}ZmVP$V*6F0q26pftpg`y8Mw7i2$jl%Xf zRB{oX#s;qP)JCQ=v{tx-OTp^wfGoM0l9F64O75+Ds^Bu8E(XQA)WHO*&>Dw>%Np-g zA60O{B&Z|B^+TkPK!gMcS}N0OX$~%!*$};d31xR?GWZTb-x^C(CPPhXk|P{kssyfa zt>B{S`##588LrbR**vVc&Us0y55fv?$wugo&XJRd;DSE}F4_5z)B{|wQ0ayiF8)h` z%$9)*8?fl?BuEZ|%asr%7J$DE;PQ};5_e7&;L-pckq!eFz)z9uF7A>9c!{%KX(~xz z5tELC3vesU7BDWx+2thw~k_dq{Z5wD!5=UX)l+gGKJiOk=``UWndIW9G6_$f426df{PAn3^SplJg&jZ z+He-49cQ`&ml}C%-6+5%8=-q&R;z~acl*1ld`d36H(=0}P8^8=l2VoBp5d}In!UFW z0U$N#V&Z~USBp3x)w6nli~=;X4lay5Kr$xXF$mHN#g{{D<4Tzd zpVn{&9pME9de&8(%L!~y%b0PBAK!$<#eKvXHcf9GgG=ljvdWGvBL=Zz6K&xF|05PF6PVQmint>4ITR>9@E?rhpz_Pm#uD*^|Ovh(jvyo_z!9k|32ulD!-1D9-s z?zw==B!Y&zKfBBrOtdb*PAz?wO@@ZyRG z!G%UYWhM%-2o(}xGo^2jCJG;KRwjOzT=*N>Bi4x%S{&v4X&-H7mNLrLn^Tx02N%Dy{)vK1Iz;j*GsxAV_1WNWyno=5jnLhYlq2HMa`Km*5L~L>qH8W? zFQPh@eR%0_D!IVZqX|?h&5oP0P)U6~>cP{2E9X|Sg9`@}{~vMp91#SAQl9(>#OW_m ziW_v*a141{I(baNuxus0*U!NP3NFbo^iQ3W*1gLe*9*XjgG+jI&2t48czVcFczKky z>lM-!xDc=le~FtrIGBeswG+B$rD=Y2a3MnL8?t@&`E+u@*Kv_&rd7E+$pyAxO_(If zH=-M8B>_$cgFUZzbZXFr@gNgK_nfQ^PlUs52&T>DK_%rvoA>h1L~oH&0?mV~oT@%L z+eV#as@o1-=;NYHSBu2o_Ok^l?P7K=yw|GC_C_O_;RjQ$woVTRm*OM)_?_KxAC3it zu=V$uOELt7C%IGU$qp{&B2*{fot@{VRZ(IvXOuYwQC#IvaM6H3A5d+3o|V-dxJavD zJ?VHb+L~z&|GU`W#IN^hmf!tOG$)Zx?);x~}T@4JQ07c;q zvT;T7Tvn`0F5(51sbg~X+mrA_!WJ}^E1gBKW>s-0SylSpNiGkw5xT}IS`s*@5Td3l z7j5NUjZ>6dcCp}o7_d=2W=KXps^oIjlrCN6bK%NrRza3S#raID*J@}wxYX+0{)U1J zwsCfLN}yhxEY)7))1_WQy!l+rOVc5jbQK2O_Mfdiso;XV#BmvF>MYYn~ z-%xPb)7%Vv&FRp%gI08OXwdD=X2VxZixcVK)ZtNaGQuUjlEh(h;*epWRCXu1kP%lu z-al~3M(9c;@u_g3NiC{8vgT!!Tu6i*PmuL!A7|3m=iJI} z<>8V`nt+Stu!G3ttKmg=W443wuofNa;G(jM$3Kaj^7GwaqAdHRL_su@x7M2`=8RNK3MEu>fI` z!>0@n6Uw^u7L~d+)|kZZo_sEHtM>OVa4ECIy+seR5xSOdPg3Q1`av4-kYbIa8(!+t zadY6Jlq5Yb&MuT5<67-hW=!aEaB-^!f)p7X$XLbgxYtmT%+G$k2kh~!ryN|8a@ReL zl8dktqX;gfK%qcf-ZSAjUjGxiG*F@FTv&i zZ|`b*qKJX;cYno2FTt3gfE*;ogcAYvH;5ljTp|$y0Y&}yKGSJur`?v@UFw(3Tu5kl zyM1}ueYTy>OiA{0bbJ2>kNed-Ox>_#YwmCo!;;?`>4Z!fvMkEn>wAf3E;u`l>hX@M zLMCV~cF3_EjzJxQey=$OeTeqQGM8PxbIf-Z96RCI9>+d#Y@cHvqddYv^t(k3-OKa4 z6+AU!qwv1rbrFTUcfhtb5+ZW>Kek1oCK$r;j*35=H(B^pz%w6KLR-`?8dlSrk#Nkt-Z>9n-pg<9m& zue5TidgM|rqtBhX0^Op9?)^pc8wVBjsgX-VVc*7-S+Eq+0nebFZ2S zx%5h%PsHSc9jB|+kA^CMWa?9$e<-;szI9#Fov?!AYzoc53{o6=AWT1jx*V zzV-@;7q9|=nH6Ayp|$=>XEZsPT(Hw4ZNYYrgp*1aqBY57$#{Y$&)mM9+nR@noMfRa z%p~iWC1MV;x4KF~E`-N?{{(tRq;sT@`Q_AoB207!2n)G*bCTIHJ92L@^cy;a@+a1; zYYt?sw=9B#ZvKvAe4PUYd^SloOkhMKMj0BZ_K3_yOj_Mj+NL#ZKLo4RnV!{BR&~jx zsG$p&0DzY~J8z^bAl0BY2y(%0k+X_U1iE8gbd$`5rkfiKxO<;zUjkTT&VV@;!YulX z<)Yd+NXX^0+gA7jOLiX5+>2h?@bG@4%v{>W4i1H7k>@6E(j^?{J~UTON(nQU@69F2 zg*Xpco9w&-$E?j!W-dwIL!v}3)GxOUv=W_|9J-AcXYhG_1^4FUUj{Ele4(QPFUz8x z+06yqcsThLcHD4$K{7un*G$NzoMi1CBA2!;n>5le+EsgWQ!wx-LFyz!$VFai$5j5M z4k*d`&&$$zr5B90W#-Zrzz?o%L7PCxC9F(wE0j(oLN#c!Uxt?k5`cEqDdZxX3ov{0 z{Y-iIFJdS`Qt3CSmAMo(bPqq_9D3|6{{4Ery8Q+Z@=*P08`2HY%w-SjmK(KO)J-+y z3JY|dhVFCJW9jD$ux~&wi=QZHbmH$19e0kS#KNI7p&TKX$d{LP@`W(|+~eV)cHi3W0kZyWT4AIXf&v*zy1`*mjXlTyA} zasf%xhtVBzy_mfOlH_5RLw@w@H=fAl^t4n$zw1mc(zn>ibKedoA?e#~ZDetTKId-s zMF_dH-Hsk2IXT%<1TwGh6tA|aXN8jW5drT%_CE|xlYb25x zCqgdS68c?aa={FndXMqscO{IKn-xjN>Gpy5$KfJN#pgmU{ff+{YRRRbp__ebz{OhU z77Zven^edpd$-?3A(wv1v#IKlOE&x77qjHj`)N*CZ&@_3;3T<_OLBckv>v$(DYcun z9=UY$9&)8FxfC>Xhg2w+*2pDB#mFVaqt>}aalS)iMlLa8Rmo*h(9n&G93C@ri7_*B zN%1gp(TGfP=CUYg=<0@#2^+b@s2RDWco?~8M5akD1r1%@@G)T{ml!o8mlO{p7mdg? z$)%v7s~bKhY~&K7X5^CMVdSC_nI^duG<0>t$ApbsV$_UWQap@YG$PX^mx6|_Zupq6 zkxPu4kxPn)k&8xTn&eW@(A5ne6E<>*Q8RK$@i21Hh)k1Q3L3h);bX!^E-`9GE-4;H zE*g<(l8b5R>ORhfO+z<^#WZviJm7NSvA=1Oi)rYt9T!F}F+@f#2_8l+5gvB}bvM#!R^Au%Z8`)SwH$ccXv@F50&hoS!U{CM8!Fxrk)q-BMx;6U(#^IO| zCt^LqdEoPXd8tw3*4M!_%fT>Kk84&|W>!{KR#w)F@cHMThj04B&g<~~a4T$wZ@a&p z$>nyq_Tqnp8#qFEGwi<}Kl$P5Pv3@Mw{TK@blT&vbMT+j{_gg*zsq;S(d1Qlh1+M{ z?jW3Z-*o%KtL}L?dshu1yL&A=UG0nj{(UPv>%8iBd*fdB^%vort?*-aFz8;k2ZJxd zziox5-B%ag{`nW-WGnpA?G3u1MLY=L=YGEzz8zj%=qEqE>h*h9;s10m&qhOhcHAC~ zC#cx7$!Iv?EAeBVT)TI7dpEr4j>f&=fK~oxD;6KxgL9ylVVC>TF0TCu`i03b9N*gy z*Qfo-s4bkhj^_ZERiNr)-irY49c*uJOPNQL_NW)0{X_sKTV82mlVaxpBY=bLgY6&y zj(@!KH-7x{meYkVgX!Vmo`078MgYe<_wrQ$h~url4_{8Qm#fYq0AO%%2SpIozdhSL z`QaI{$dmBA`+GRJp9j;3Amu?WdG%Mo;6*`O>}1+v2in3p;`&0`{ddFmIojWdO}}`& z9*0z0gz&?l|L#IQ3oi!U?)fQ-k{T;o_E7#chcUvI4eR6O^|pu^nvij zXm}a^_V}lxs$xpzW;dF^V9&ed-Sq9fdakg4SEx(lW|tEpEZHO ze)x1}XD3WvjiwGZgcs0nXm#z;d0->leD)4X?=pKH&zivCqCXwKiV*$eMdR z{w)1nAA`;)Y;6Q`;&pd4==K9Tuj`R1*TdUUZvvJ7S-^{D-F`nUo#*RgP=vVb^*R{* z4;Ho#06`Y|Aa7gjX4+yG+Tukx>2<^R)5-7C!Al7BNaTvj{b~1Q55hGPFv%aNi{1NS z*qN}CSs%aC%WyOvqZjX^sBsTH$`h)dm#_@FxF5c6UqWYHO!4#_m`1E#cHg$Uulkc~ zC+)LtF920}{(q*!(fNRN`F)D&48rMP0?9Eb!~V(JGv16;9?<;T+9-cm@+~(hZOMKpEZ5 zd3PK(PTFkco6vln*W;~-bpB-hDm;}cd}CF3s#SQZRd}jZcsj2NkkY5!$#gXMk1?_R zkE>x1@>gm@dDQ)C{VF)5Rewv`VlUGcdmnHxMJd=xKy*QQ&sjmGY21osVH$3aUWGfwcPw}=pqRNFnz6@u>A%|n_ z>4m7_U%D7Ru{HA`fa4*q^!sr@Q7>^d`F$eV>vBrfk8$B!3=yHpy5Ty9Zcya?2?tyP zKnue=y)L^g76dS$*%U)Zho&!;b;kNcBpT}+e+3MRw#9y?E%rGQQD4Q6Xrb)hWw>~H zGJ|L^Enx9p{uhjp2Vin$7tHu(#-sH~JQ!X9{#_j5M)=Q5UL?n>?x-7fH^aj|Optzf z*ctZElgBu{wj6*_7rh4BNp`GXg=0`39qMq@d)edIPmtEDPgssz-`s&qVmn;)DvanC z;oBbC*BKf){59|#p*jA0yFU?B(Y^qj?N1d|ck~86jW)Q=vgBC53L)Hl`~c%l5C+!U zW(S%hgw6f%1s*&(rpg?qH1mSvFC=mDsyBv>h+hm`;l1fi+G7kV02D*GcE9&~n>rkq z^2QV$OJK)hAl9$KAHn$0AHE!hFRmxPyv>8XFzUY93VT}zJ6roZqTnL#jbTuPxa{@% zG$?9|yP3AQOKtIe_qUmBEMlA+h&0eGhVXZjU5q(@n{4)b193raCzsM>iip_t`V%4l2(_g}8Wi4oB>rajbXlziB zlZ=?H@Dm#Cx9P1GD?E`gBsEy~Z2Iygnz&jA;k*q* zsYakyptE0u>qL2co$7$&rcwBgBjIq_qX~oY>VT@_`^W$5r_Jw9zyEi-mCrEf>JHS- z$kAXytaGmcz+sr)vU?k0b2Gs04f6=($MI9R6?SijP79RG6VJYAq%D}6%Rw&ryFLwy z+TvcOE#P)|0hQSqg7D$X&S4k~rJtUOWAoa=G`b^#mJ`+B4PaZ)B03j;P6v}@`NPDgURJId0CfnBCkjAxw?LW?AYb6}SKxwF zA#KM}K8$Pjxb?VOS<69AP?N3;;rd@pcLJVmBPXXk7s3g;CUE z#p5lh7@@R2Pr@@R7`UY7NnS@cfk87w zoYoWZ=YI_mr&nbn{#+oU54v(xY=Vet8jNcN3BKSNlGFqS@GU`{;V5szfpc~TK3_8S z1tLbEV8Rvjm$`u}`P~Etm4Fw%S<)5{GHvmope;r+_ajq3_3+=rNQAn3R4?dHXYrUC zeZ2z!M9fANg8uYhCFspm;URj{4VZps9CSn9`MAt~Pm=LjP62`jvF*~0JL+MAe3_#; zE<9uvfIe%1D#Sj6BTH}VPthmpxKn@Gi+m7OScYWfcbgz$8R{~3O4%fmI@+TqRO?SZ)V4Ig)Z>vpCXh|p5P;I1mxFF`1TlDfz}UHSrCwzj5dU^LLV za4|W-jDY$oy)VpW2%KDv398pWHy()?qzE`th72%pWR|YJe6W5MC?<|Sd*^gSg(6y! z%hmq;Mw-fMb@#8L}@23guRpr3PD%h&@pnXYD$6&C)YNZ1G;9h36ah`b>Jk)@l`C6%ZoL z*&Ul+(Z_|85h30-01Lr5nC#lUF$Wt2+G(kkI%c_4rVgOMtsf#3}6SE|E zE&-iL-w+Uf!G%B)+cJaZ?@3<>8fISX&;j7xie1$9Ez0Jk7jav{n+k%dXXzW#;83X$ zFcV1;9z9e`ARXGyphy#fCS5DJfI}KvR_(pCf88T#N}X(x2FK?8a8lsfJKG#7qMao) z(BeS@>Ef3oLSr>%vAYUU;a%+NE;pZva3(rgJ9=>clcJJl~|4T=mjSG4=59t+8l1RQoU3G0iQW zeK`m(-TK3P_tcoED+z@L=IV6S;Jn4FLh`SFmVu~#o4EZ;G3HAqj2f~rMXKg<3$ zRs{)h$PMXMu7ZGCxCW~7w0P7j9aN?mkjc_L@q|R;uZn78G|)JYIt((Rm(CP}l#L2% zVInk9g%Vav-B=%kqJ6QOgm&&o#*5owGhnUSOD;59(j_JmeD}4fRqCf=}JyW9bl&=S9AcfZV*U{KN*No*$; zql3-o#?EuL*aeRFq%Rzejc_g@ahv#2%g-$gm*yjDzlN)F2?^!cEFV3mw@#KHaRzbT z)QEs+g3V$gIR&K(=c4w`^J>qBWI7a!#8wP`0k*0WQByVMk7=u%ckp6KO~#LT(nJ+< z0GGb_h{0cj3nhJ#1b1St1p0!GtlMGlcG$li?upLW*<`}Hed#UAg7cpA1<)w=%Ul%X zt=}6=86QZhdQj#75Ia~F=@ei%0FYoN26F*`fGYy9N=|1#Q~uGXh(f93&wv9}%mvpvu(Ih#B2(}1+NHl|5d|7)mGEy(q&sGzqY=omyG zBb4}7J@)`_%sC8$9Rr|djgtf4?#%h#d-q)fpu?C1!0v(o_6&g9Bng1M1p(|Efc+v3 z_7?*HUJ4QMnU zBUn^HF}S!WU;r7)FsRm62B03jMV`o@jsz%_ukA`yZAEZ!0$Bk7{{jGQgNp&k&yVaT z;hj5@`Qk0ISC0cz4w>fY_mJ!y@q`H;>FIm2FHkB=Ns}I+Q#HFhKiR3-4jd zPOja2^2D}ALiWQam{&%UGh~TEmb3}-hUyA=Sx}t^r~v$BA!X+a_l_rQRRWLEBs=-V#@$txlEU9?S8{0Nf zsA}>@u*Y?B&%e$IY6BQB0)#xQ;-Hr~>lcECL!x(x==N7)TS)W>&Qq&mlMl;{MjD&d zza&H2*s4Cua1sEdU=;y<0~ zlRZnB10(|g6!b+J->Jzj68mBSb@9I9!Ogs=YONYh&#ApmaW@fGk@b`jrkNFGtD=gu z@|FA%BD46)wgU0~x`wz8qA@|6zU^Vp4H>|re}3K{z74N>FJC>!#vO^x;2pJ3wg3&q z;0PgcLLu#tp@n6{nj?;pLMD$K{|G>DoTOmTe~SOWO}65A&tV7=EAXFQ8TR54kw~IV zkDcEP=!{)%8zUmN%`6ELv96DAi##feC%(y3z?q`XZE?Bi?|8?tEa8cS7Z zpv6~~E^7vX0KI&brZWKG5F&joQJS_aPnLE$p`7AXzv~mRq%YF=PRV|8KAdu2B6D8& z=%jK-PeJiLjYrPWEWzY+M1x!yF;kw#P@oc-ltyNA({81E%*30Fb+3Azq^nY9@ltxy zFr_GVmU9%w`ds32_;aoQPSBayXrHAM-o&y>Zq~;@EUa^Oj3h%D30F?elOh|4K^nH9 zIzCl3+CgSYO!*NN7XhGlWZ*HHsI=kIKt%be{;Rw%$NE;*pc4Ngz7^NnS{VT>W)gho zbiX{5#>#bUsgb0?xP{Th`dp~MYN=c6V^Gu=nA(V$J9i}g#U(nl%l2B=)Z%VcS)>8@Uspv4mj0^>8p_#VHgYEVWef_) zS6wOwB~s4UWG5n{3 zzmG65P*F#W1OQU`DN-)ZO<;hIhvfqSbiJ_PA_a}GZnAj1Q@;Cw&diTT_R{!H=D)y3 z0wsk}sV9mA+}ZwHdvvgV75_lr3KV*|_Ab3Es%v4MBN+%o-HU-O-u1Y!Vtovx{5iTt zx*T*ij%iBfYXC4;St)?8>Hvtgp4rp|0D80<3`AKi0HC%Ck?FNfl^V3p0RS4*$Y~-s zRs{Iy(wb$S1ptxr*wU&j_6&eKBoY8gK`WiEFGwpDn|$;EU{KN*Nqi^Pl0ctqoDajs zBm9Au>&u>IXG1KZubWP#|00dQNUFQiDQF~}Gtq#o^n2X!PIn}QzM#-}&tC&x9qTs_ zWR4uU5oP4!sq_8Ur(69ug{53dH$n5S{P!qH!0-3`7myS{w4q>&JO$$URg(FR1S>w% zbp1`pi4u`~oJqv!1)}W_lfe$B0W*@T8D$dyW!Fy*bN{~9OpGtgI{^k#g(!s~+{3`~ zsi9M}4$4?GMno6?4HLr-n!|*Bbt;=x+DtKUaV4eWifK1aXIndHjfdF7T3X)%rHiA( zlD298wLT3>`XY(%#99*S3sn*uxAk`(U*DI%)6kHnMz^cQQ_MvtsJ{3iiwEBa46FvU zRm_>ymrZ=-g>8KzyUKGCs=~;%I~wqAcIK4@YPdcIFca50*2jQm;`xwDKRwhi#Bz9q z5Ys%dCBpa-OA){LC$bJnl+UrJ**IM9A#c-f;SXz~e?V!BwuTp5CqG;dh-cCrayIi@ zdXZ|oEpychjzBmsLRw{D004C=+W<%oGFn)qRUr;#Ruw=)5)ipR5Q7b(nSGtd zV-|pvEw$(1LSa0T#CPsW{tHnP;7_lEotG9kO8$!lzM1g~swn-+DXj~RKxk9M&?R=% z?wa3KJ-`(e9GF^?n?fPvr&7{c@-YnZ=`?S z$$Qclixyu(%i}vUQ+mGbngb&G!iqN)K@H&@U+&$?izXyhbY|p%JIH)cfWd?N9A{wQ zgDwAEf(}hop%Sx&Z+^s}iRQjAxoci5+ZRcE=dR?xfJHOxV+Ui}8DmLGplzql+JL^; z-VMXolg9QfW-(T&4b4|qRo zYGelzQNN4;TsriDAU*6m!KE(h05-EZ03Lt$>@nWTK6YHp@W?b85zQZ|oY=73bTDI` zVjG`{K_23=S3-kt9{=0v_xMs3&u&(5gf zekzbSM}ygARX-Ir8t8)jVWetRo7)zC{{E-a@5+s7F#sifk;HfIO8$%Q#IC5WK-Jym z$0OJ+`v)t@sU&VEYomKJ)dl-jY!~SeA^^IbmH_bG4?p}UIPAs75<$n1?%KZ}n3 zC}n6i)h$-4aNAL+z`z};Rs7(+CNQXjz1V$VAVaF}9v}UkIwv=|frgj5perG26+B;R z_Pg*fGf#ucGG^bDacRUqP8VW`itG;5AEi+$6j8b-H2^%#_9{PwySCHr_u;C=S%m{P z3@<47e`Hv#Uxf_TYG>u~ND|+L8+CES@7eiaA0i_yd0o z%{b2krmlH0hfpy9z+rFWHG2zfg?&C%U%NmRX9!pP(afXk^r&(Sdp;R5HX?N9*6K|jWvmhF%(Dk$^T9$D%eO&kWP zlR#0z_yD-T=m%{D433nAzHAwh{-$-k%B5dbx*QXWrwc@;g4XRoEKI@&&fe%a`G)uG zPymTm7dX5Yy)F}Va)z`<3Q5(t&RWBKRW3NV6@JV5B8l&WnSkdaqm(pR(LNbr7uv9U zr@k!uFLLWs>t9{u392Y<#hXfuD9<&O8IY7lSzB^FQ3waNwv>y5P^h56p;94d9u&)W z84!l4SlPIIeJ*iH*u#GNtlJL{f#~V?Kh3Cc#iJ%Lh$?6JrXP;R)S17si7Kdh0NE7-g_HAlGB4AZ! z+6N*BlzeP3}i-x?UyHy>@J3NDfR-Zi7FJ4TJE}RU!?J!lK(>Y zGO>+lVA6{{JEN55^@Vf`iUyj?#b|gLCPSEkNco2*!#1025R(}ahNBYMGw7Zcb^Ce#pN22Yd*S=}O$j4VZ}lt9^lhU~{k8|cJwgYR#493#as=ol~s zaqdtIbUUXRG}ld>s=E0m+KLY9M1-s5D2HRS_=vzJY$DWM8E5os$3Js^9K(F>l5o`9+SV^@ZiS-B3I%`k~() zP-h@!UrtIo!;>@uVI{IVIlX1z+V{&*={{F3R*gp%sr9UPfC0Ah6EdQyOZ0~0PsFWe zo%+;^T7_9f%y|X?s&s{mSp*4jxxFJqBqrHDheddbf$Vu$nF!GLcSFOeUhTPl6~ud> z-PH<>9daNpTXx~TGLHj)bmOLl)8*)XH`m3>c%+(*?6rWJM6b)9S8{63@Qn;;J5_r+u1~}wUzfcu+ZSnkr{up-kQY7dhlsSD*advf(X_rW zQ5OVE(#5nu228UqW+S9T=6Z8m-Q%jmI|UDtjCy-K88Rm51F|pJR%Q@DBrMzfyi5;m zD`+2RE+WbhUz1JHUlKn{&7&xre zem`O$N;kiLWIv7Xl>8SGJc)T?_{+ZtNU?g=K95m4RfK;}`a;miM|Z{*6w_Pb{3`s+ zRb;-H#2dTV7i&&$u(e9@sBVe@%B<=IN z?vrK?65Ou0ixNsSL4!jGpd2xaD{xT8e1iBZMX#)B3=3dzNcrWl5whM!06>54EChhk zF96V2iKY0NVsI0Vzj+g)ih-p!CKNlMvZ=hW}R9$PIh32_kx-tNoVki!{EI z`7baS#gafQ-5nvsbCCsS)E9dg-u~WLeCOYhJ+#dnUpFQ_ZmJdZWXQbe^A8X?0(j^E zL`dZ7lW_CywuwqLup9uU{o(NtCkrCL5mCh8tgmtHfhVf~7+=9{!$VFMgwTYb9R?CF z)t5mCxRANo`DGrF~HCkAJ6kr zHPYCWh-9M?ahq<7?XVab>xj504Xp|Z5s_22f{6M;k$_}L*4R=aEBa|Fu*DNP z`fqVMEUq2E_+O)BJm{tXQvq1qe~7^|g|}v0uFqz6&ceqJjfk7R0OP+25xoiI=(vEc zAa|9GB0-YvjHy87%F-ch=G?0l^3a4FRDfOLR%tu}6EEiP+>`tlo%U64(q^>lVh8jE zHaco@JaRn35}|I`h?u0&LO1Wp_EvP+VWJN@Iv<$mT%zW_dH);43mw(JT3x}6O9JG8 zK}QaRS*Qs4;IZBmg8}JU5SR!P;zjr`g3JK$>gIzg01qBi1Ni?c034(>b_^aIB>-5s zVDTdSzj*+BaubQuqzW3-$rt7wT7?L9`GD6v4dxYB@f-l8cXuJ!h?Wt%j$1PVd<~dl zko3e+o^HrG4!o8;%zQr)7XVn(5f(wMc+vzBS1j5-E9;9SzH?9VUrevA77ybCSm=xG zz0jV%Y|MWla^h&HVwWkvg{DWWwU+0~-77fPq*g9bEg%M3HqnE&(2+!0w7;vn}=_(yC3g^|0-b&oKa7w6KHHW7Hkb$OshY2uo28g#LjzZ-jLbS0y z6Z=DLicCRWyS@+rn>PQ)ZjN7D_|I9N4iSrqyDeHCV4{v+pNP2%t#I)X183t3#Pd)7 z3PddFizL2tPx4=khtm-PJf+2ABUJ=!4ceD8jL_!CBXKgaKWv{PY)K1`7jxzmo8S_h zg-V5NI*}2Yv}ial+6uFRrA%isnlR$r3L9trVdr%?yCXBKX>cK@3T5WFrCZ>9*?`ie zF)tjRKteI7)7qwtWwc=m8yZ{S zczj4RRS?-1DX_^xl>sF#i&v$ug9hPhM$slP$g^eHtMxG`>5C-3b5HVLAj>i=J00?U zaXnn;KH3}CL%_ev1Nvg;Ub=s3Z0-sPQXvrMG;@c&eihkP6n)Gj`n-xac4ah2ubq|` zS@=~96ltt3{@MqvmiQ(csHT~XQW(ut0kp@V6}gV6IcjdTR;00@1{$!WCQBxz{Hh5I z#ET@{2f$2k>L}3W_0sgq`QUQJfCGi-{ILxlbX0I;i%xWF1|1gVe2xGRZSm@8CRTLD zfuZ-IN-s@7{L_Wx*1&HEIA#X4`S6d#E0@s(5s~3b*eG=TvZ9a~6=;Typn;U(X`6r# zB&*%;y&Rz4)%lt-q{{w_B))S`@?UIShjeUhz}Ziq7qYlxb{v}r)lQgDUs(LbK~q)S z01|QtomGWT-d%N3!!lp9+Q}K%d>H)u7@10l3(~0}IdQbK#eZfk-UF{QM)`ZmuU28h z?&JX&8D@Uph`u<41lU1mN6T~OAhX+@K70X;d*lP@&r9e?6*#z+L#-;l&EU||%l208 zM*zHP%W}t!@D=-c4EnG;C2b_>^)Ha4N;W4%IE-u4o z+5`sxSntp(pascsb7wo8aec)?@v-uW0Eo@+)0F_MS%s2)k;HfIN&bttaq0jIYM289 z`$+U&_9l-)yVIE>y%Wuk&X7-KK^n&+2My=@wE{EqKyJv+w0FXV>{AP=NqpZAu+^9y z%4UuR+!>BI7;%t4fXRw!|I9#u1xpzI6d>9VK?R_hNA%G)ZC!a)7>g~V$ObbjOy^zJYuIaA0(4B2e2V7)1SwbO#H zJ(E)2U!TatK!zb&m`B>gc@=racBT@D6uhyUlrNgW;A+%;(;H6d#4liAF_y#t!mUWW z4;oxe2gsP+o?iO!g@3=hX832w3@)#rt zh?;wJJ#4|`s{;^0t#~4i^NZeZRE+uhivVb^a|c$_TTz|9OS(_tx+H3CZ(_(02&(0WAHyS0L*?|1wd(%GNe2nN#i>u|3yh(z`nTZhex=N zKSTN94L_(a;`B%Z%{^Is5sN{a=DEy1c)4}I%`|tZt`vdA)cy8L_KPAQy$dBZn!B5~ zMNAX}jq8+zI_SD-@AxL6o`jA4ygaW4z#6ycX%XkDnKJUe@H%B{HGtyXC9b8h8Mpaa zEfE%>fsVnH67sh!mu1u%VxxRv5W$LZ zkP!gNwS@MW#g(@^sxgZI0FlLsyF4p1wIIFB{I3G2O!S|BvF<9xpzfWS_W{5~8IqLA zaoi$(=GSn7gZcEp}L>~QmWY0Yz_g+30Blws@@FUN714|LVJX7Oh=&LTYa|4{x*NAvcDt{ceEkl48KwkEuI z7NZSy*vJO#l#2VJf*SXj#RuI z?FMTryWy$_Ca7rgJ$O5jwjGj+rk+rzi@QO-k0R6%4aj#K`N>q?VR0>NDN>&SLWyWH zW3kLsoE+M*(TYq>K@5+#j<^ea?_2F+l^+>Wu^6QoY9W~&i3Bq|&et4DL~*K1Is{P> z-~;ctc+5mh0Z2`S{gz@<>u%7b+rp5@d*~b)nqcEh4Cg*9`7iFJ@tulNh--&; z8KldIax~HG?H3Y@#Ys{aC=<8?>G1E4>E5*F&e#KwLEb~q?MD*%|7723jcmIBXxc z$_9~PmHae=feAC<#`pur>E`1Hf$4NM!hd4rV$XI|gmc(6iDDqc6MX?Sue(2HJ^l>) z2t_tgg@ht2oUV^S$-YS9J7MZTpFDy>gk1lD$wdZrT*Bm)R#1m7^~HnA@rXgfhkCZq zh-CdL(wGPK`9m>iMPHX;#F&-h(F_I>4n%3BBFXZ0e1-xuc`Fue*TCS=LTa>gcM+E7 zivmC&$emk ztVio}yMede(K)_qq^-n(?c4TfU>kJ$Y02wUBIWvQEUt zjvhB+;E0b73*W^{1%TW@h_^N{TM~MLU?Rf{evD4-Bvk`kDCvtNzH^`XFT8h;%!=68 zoRsuM&3g;p28~X-7m&Qm_G`>YcHhSDZXqlC>9~A9zMv=T%L!Yn**E~Htqw-y2;+c= z6gsAC_|Keb$)OksV>>M|Uw33-l$+kN1mCH&C9LQH413mY@rhmkoHXEPIz1&4W zGac#r2pvbB3p&Wx84~r3akuQ52LODj2o;7yb%vkXZSaV0s!@~2U}jm>4*}pXOO%$p zW3o}V;dgwq2@E2zl}^^jprkL7_)erGguWPDv@87-bqLdc(d7D6%X?sGY=p@xq{Bc8 zQMd{*_QY+>iKzcD*J(!dlt!K!>nYY^Y6SAlohKL-_+rcWdig{F_*!;fOZW?hCGc~3 zX07sP*&PM&h!AWr^VAo_A7fa=n6MD`aE5`->1X)OjdbuVVY4p4G%yqF&lxe`x=)U= zo@)Jai&PT;CwM_pg>V`IYv>KsFQq~={38a0nXQ;)=(dvbUoxbM!J#?C7QaYnu=q#m zn*f064QmbaBo4Jdi#_b~_+?~_YH2|`ZLWD<)k-lTU@BMDMI+k9Ov!ZQb;1b%@V0D!^2 zvVcUOl7z1Gc^(b%Lg3I7(LJ^lB9)eAFi-?a#V=3+S9z3itA{##J1w!as50FcugM46 zOchjsNki*zu0TrfXVB16q7~~UTwnuW=#e_L%QKdc=8I`9jA%`3jZ&ok@J>zU03+ z1PzXdaR0P1SGT~Zg!aV)U(TL(jmy!--xeCF#dio(LsM+tqsdQ|sxi(Sk% zsM_pmq6*c-S@iDu7?kXbB))T>`7gp$CsBVMV^Dk4@4=g;{)9Rlp)a;~)Ab{V4uVAX z*+}?0$8gS5wVNkUbmLTV^kaT89$LklPo9M7Lk~?ME^TOza53%oIm*}1Y?hK2Ns!+9 zG-B^A)kjGtT)SQ;der9~z`zA9KlUyOnh#S75NoTzC7#$iS;Z6kDb!85)B-3JRC@^k zSmZ0*k6p8O%e5b+4-^Ae_vWl)Z`jE!jP(7|xdIT&&bJQGPEiaLbDC&RY8Fgk9oPCa zpue+&EqGof$VsrB`JUuiZ9scdDlcn&M$PB9el@h_$|7jsk{HLKDmh1naB*S{ModM61Xv zvhc@zaeYB!V{_VB&*W>v3=`Ciji-eOh6<~AeGDk-aQsZSFmlsa8qr+7x1==6AQ;L|A!ZOiQYcuMzO^M|e8K zxbP1H`$q<|G$pov705as8xOx} z!uszc$(gjcu1 zPowr=++!5y0aQy1BTe2_ki7G)&qw5eUGrEAeN%+K$hZ6#g{y{XAdS3G#GK0}FgOe% zyDSOKM5glv6QM^<3(3%G4g+mCL9wY}NfkQHU{J$&Z(Z3`Z&_hcYv=bjyPw2&?o0lQ zAtumA^eB!cx6JHb0Msq$3-)Z(C!2s^nm2;LEmsm5TMB1NBXcUV50=rRqZKG`zwkzSEFauXr>A@Odx(@Tu}xxZ;LMP@ztm@z2Pisu>z$k5N+5HLqs`4_-vL-->mto zRj^t!OhUvNvVhqQWMuqWBX==V-f8K66`X%d52pb~Wh$@gleB@E#-L~3&Gb_}R{-Xd z*XeBen~}NvP3}%vUnKFJ`;z}c!%4ygw(8})-`s=ak!1f7>I?lgI&|rpR!(q0Iwn>ksVVbq)!=Oi>$yp^hS9& z*YZ#>&UMps3YSe96OW7w*mGOA`N>j%r2)4Y()qItK>og5C3&AwI(tOh*}D>hv^eh4 zt`&iN!X0H76=hfzegzRT%*BPJ-^diYr<3-L#eH`ti6cf8)^wbg?29zMlld=T&2P%o zg9~d_MbdlC`!5b116l{Vn>bE(Ih%zQsXJfoqK$wpJ73EQ_78rTW?oS?OE+$b)KhF1 zI9CAd-9;DcY?S0--;^E#itD?_M}L28^H$RBzmNG;2?GSa)!HJiVf+5cQNRW|Id5b_ zgAO#NO}w%bZ7o0myrKXSD=)DP2tsB@;r-AVy-rpJH8huuD*!w%9Mt-3*i3}OSNC<1 z3@%mb;_Gz)_yU+uI2v^z6Wzioo#%E4bpWiZ&>#8EzbO1FfIoTLsRB+*Ue?iIVK8O; zB8~5q{1+;wSlpS}Zh9VX#(#!@pFBoahifYBHEV&rc1 zylX=kP;isuRwC8k^$^#JMc8S4eLC~o3FN4aDA^Zje5d5UknmvSDqxWCA_wh@`v@~=Zog%nLBa+x3y+CXJlCg@x?oWM zNQIQm?8vpjk$Y8#VnEe`By?z*JnR03wcT8A@f*@7SL>+^R8|FR&c0Y`2(L5eljj`@ zK)cYGKEcGy$(qv-MSvLw#U~41ix(-bWy43ykfC9OF1ezCa%!?a@ne(_b3p$QD=_co<#lwIaWF)%Cdko7B?bSIuBx ztysb~hL=~^pF<3RG6ofkFU#YRG`>^vU$8369L?Joh=uMM4sbWJW57rmgYSyOFcpZd zPh{E`n1sTpYn@o7784FrZm=1MyhI+2#+~+1To>7I&UIL@eibOG!pCfVtSVXz zQb2!;-0ax@xerYYY9mu!9{V@0x= zp0A&KhLv=(wIlYNE*{!eup$k~X=U3F4FtuTxc6lT+cA-3Lf|ixkSA{Fs_WJi07^w- z9K?}g7ZIPFKrh)ralU^@#G-(L0lU+?=(*`N~B{EegFWug8(E?P!@PxjkfM}W3P75XbVJ`Ag{H|L2-kwImkj^H0tm4d^t=n4TWKw%~Zsa)Zhgg@l%Q7E%vT8 zpX6^Vkzv`$7?+wxY#aO$gz$@hvo=CmpG&@`-+7?}oFPWwA zHddAJTOWgxzDVLb?@IoQ+kzm2iNkIAySa(&p|o??zj-=QU))1{XTPESmf74D2b8nH zVJR1$L_+zFgts-pRf$9m4f>?!tf-}NLwbk|1KA5>v6)FLjL_-J zyzXY$y_0Lu&0r8Ez6yhAafmd$7Yv*MtNpG|gOa{T;ydq3{)=#hPT&eo{C`a8%Ab2c zUo`IT+;AMCT+(ig4orl~VJYsfSh|}!xC~RJk$b^fK3R_sFlfRbb$Pzmq(p8W#9F|Q z;Z=f#kln5!?)q$|!r4#;n#<4%{l~P6VO7!%KuY-A8#P~vP&3cdWjN7$`j)*vF zg7h9gEXX_Vo$_9WaS2cpRmjJKA0+Xe*sC2FG9YX+VhS*6b0r*#H{OSR0iq7h+oSW| zouL%>JPfCktLY?h7}||}1ot5}DQO5 zH|#M^v=1n~UcS);k5($r>006zYRzd#0g8t<^8vEBpj)sURR1#0LY=kRj zJG)D`DUxOja+VLpAcy=_cLcZer5cq|d0PyTMp;Ej>sNvEWJ<(}D%4{Z{ia0>W?>uA zPEU#e(q{{uuMeQ4FOvAqyORHc#zhawt6u85CSToDi(g4!)V{gU15^>27gSmCgE)_8 zvNw0rWC8G4R~zR52#2rF-*tI?A_tkpIrgMOSX;E*(F6tzs&_`3+jk)T56M3~*qt56 zq8QNEi(EMjjhEbHw`BuISuC~5$%Qm5o-1<_7fLf#u;o>G>VcfyOAM7~*x~#D7+@ZV zxpK$2+6dF={IMz-@C506IZad{4{_P64*-LbzDVLb?@IoQS6K2LzPb@^V1j`8rEx}r z*B%^?JZLb!lUn^1P%tMK#k(NeSD3RwGG(luwKq?3hvU^wN>l8X*r4Uh+)VVyt zn&8BH-V6p{!Hk2Y^8cjRGZ=^f z0*53!R#HnWCSvT0?eOLM$qDBm8_i(gOwcW(>2y7xqiQn*6$9Cm4*RT}-_bqoWfx2+ zV%Z}6z61bcEsbKojT8kcdLrBnRl%Ast3WPpk!guZB^D4>2i+q_Ssle z+E_LyRJGC=qBbCO65p{zrxgu73ak@mgD~Eitg-akY)RBeS~vWxiEBYB4Cj zSa&TL2nnR6WHbf zqzY5xLS`E%7v^9uK$@w7%72^)F|lC~(DV{hMYf`mCfF%@4dCmE2SDE@Fo^V6>12Hj zO8O#+@4PGdFZ$STA$0EaL;ucPUBOClJd)dgWTl$Lk5I)=@9k$9M2U$VFT%6VsEge# zFj~Tf4Bf#?#BY@j0>Fe#91SGZz$QcZ5)%{{$-^B$P!-4eM5e+KGQ#}<4~1$R8uv)I z(C+jm?*f8_W*mxvL=&mshm$*~JDlN!*9y{%<^tdg`0|9`osZt|D-U4Uk|>CJ2pJ7X zzU{yv2}(Xib3jA)VS*xa)*o^kw)~L+$nIl}FPQl``%pQ{227fRHhU9iMF28vAP!Y4 zHF96tg#u6?&jX~$?Tuf{h;$KMBOr}k-$Vv zHL$A}KWm&LR#D%;4Vc$}@U!JHjKF}wnn?p9s1;9u0Td2f;YtB#&IM|y7LuJ_;g7D# zO_qIYL#jhiMct-i6^^ZFH@^5XZvq#qr!X*50CnIOxGyxA4onwS(1BRVQ+mQHtfeL} z_^y4{?T5G62?rR*bb>hlIp}VjyCO&uW{Z$ly%#H|7~m#nYfT(|J5R_krixDckKQ>Xm>lW#uL~AKh8oUB1bOm0zm9Rx6xS6d!sHi z8ul2sJqzRO<&&bI!CCP&teNiUi}JgbcZvYUbbLZP!Ho|U*cB5;u;Zfp(Xfvg01!Db z<_KUPRgn8wVR>0g{L1oGU)%!#o$P0FTtff*aP)f@+m&?(XK)w3#s+0_IY2nv^y*yF z069EjZ~y=&?MXXqZEazt?Z2PNiN7)Dw@8CIua_Tx1mJ4FOq+%8tWU(EeeocT@09!( zXWA++(MsEc-uQAJa;h(euVG)@Z>EZIKGgzo1p_NKUWALz8N!yZuisU#I~rny(&ieG#<%jrlK3}HK{@w%;TPdM4E%KONq@nAv4$pA zLD`|o#Loo=MrYm2_SLIm5;p=_UrsQ^v%h_ijq1+spm4{}ez6Jdt9RqxYi!Vl4H3KH z-$vMaSB*kq007%L0EmprA1}h$JM6)9r)osgL=`jwWOOInBQIaR?4z4jVH8dEQ8$+nXLd;(kGzNd%?u3G zXRcnwQ;F=xA$~m<+li-wQA@WN;#jtrUPX?i-&Wn#o5r5+rpJHw&w$ ziUMFM7Fl()z(*;#Oil>oK*Og6;HF|AS^tcHPEb!k#}soObcQ5y)T#y zHyCf`Z#zZubx;h7RLZ|I^9lgg9u3SaVD3Y$!ra&DUsxYN$-YSAJDLCDMOZ;$>|ueb zIxyD9kn^dNSH1Bg4Bi>CBuW9D8|-;{4ryE`(?MlgDFz(fBF%0K;Z$$ivLGI(=U-P1 zbc-O?uL9hR8%9QC#5cW!b>JE`b&k;y$9Ks3jePsCak$^-CuyD5$3Q}jRPiTNTu|eJ zAc}$cFJw}{YQY^4@;2&%!?OnhO)`>Jy`|)+GU^0IEa&lh^7`%l1VY-zoVo&al!Mq>=T-v_ZLhDcfz` zLHlB_LH`9s-Ee@YQ%~eld`tRfpxqk^$R^4(R|J1 zz;;9~iBu&%Ka?t50$eO|(!`TMBNPqZ3;-dTpAg#}XD<3Va+3j2uOt+oR^;aWC)mh| zIlD|;Vl1H}ufGbw;tBJQ7Q4zYSnU1MTL5sF$xsy|jXT(A9o2&}D5&!FF`yv1@Fq&r za-(RaqC!T*v@I|&b@4+1m;i~A!E7+Hf~#HI(v-!SXqExzXdoPi?rq7|5)xg2 zeAY9@TCoZyfxA@_$k^HnXR+f_))#4fr{uqw&>MW&9=$dv7&>|;N_d2BuyUND{)^_; zr;2?+9ArhHDGXt!^eJAG+TR?Pw3!*fTGHyIwTlna_Ny&IQUIz}FecT>LIN@^HiNth zD#zv`^hK^E2Z*pBk@G}#Mo}kOP@j?%D+VH>kS_#*i?9`Cm7`BM2r=g67;UUUf`SH600DZCTZ{s*T8zVP*DZ%FGZQu zSEY$6$gH-k^%2o7>KBq5omx0CI3Yd-+52+U#y}pa{H$) z!;|v6!lmN$9`_Kj5i5EG3@iR4ar;eoQzb#>Cj8XQjWXWJ z9mT*}d+Z`*=xmmbSt>r7b>QB2H&X=}aV2%|QltuVY_(h!%G(Xa!K$mQlKIh06)yVf ztfmi3R|h9#o^v{<3KyOJkaIcCgEBM)kQ0PFNh=y?4oVX=$N^mXVtous`XY(%yeIiD zj`|QNm=l=TaS5A=C+v&N-ARqc9B}DOTAwjr0wPWlUi3zYNT@v4uOhnz*>hFV*RFA% z^_t+K7$}M@SnN#8f^3^XrxanmGdj~2EhL|1rwTw{xBZP28rPdRTw23fv&%l_nF25c z>7EL?EJQ`+Kg+I~A>suhV2d<#^p&Yv$IXgxRmA{aB>%uibE@|Tp59Z z8*z+T*WwjGEIx*n86WilIU+uyini|<)L}UHJ^+X$W;)yY5JxJNQojeUX&fA_j{yhw zvfE(Nltqx}FhYzITc(x_LI9nJs?no79!cUm?|J@X^Bi?}T1uB?lV0v;y z8n6hwBx)1h7H14^J&HkHs8P!TO+J>yyd=v1J!5Rq2258JtNPuq>$HBF$Rs8CY?EuYH3ifYB3WJT>I-!SLc z^h@KE&S^M+8A#54B$B3FP&OvKfV`zlh;o*Ls2I$Wv;a{vK37Uw4%`YCQiX@$pSW~Y z5};Xb*XY=C35^ob+JH(lCwkQ$dK9Dor1AsYA88k4n%^Pb(Bg65)AIGGLgT$#%OF ztRP9huR1S{NUC01{9Y>Sf%S)s(SPCGf zec;MNT^*aSGJCt?Eb>`8U~Vh$ME14^SARuZr|zqD%4rE@>!z=2bXW>N=ioY1>@r6&$A}e*r+F8#`0%Qhd3YupvvdReqM0(gX&~ zL@olHmm#$FEMZ!LSXQ{4DF)IWO*LBInYIu+*PWg1g8mlvunM41NihdRKWri*2cv&% zCvintU^e^0%yJVnC{$|6%L;{&gm~VQ6d31SM7Gj_p+sOLHM^uq-Lgn1jP0gfo|1pb z>n4gs4grLt^-%9!C$(^t$uUu5bC&HGghGV8_?03l`zLx8hkAL~us41`=s zeeyMFrV3UAX4@hz&ncLh!fJ^p#!y3k&k2^;a0?VY6a(EvUA{I$jROH2YiV}|JHynT zQ%tMUOclh(1B^`+HKk}PcTU%|4cw&)l044N zAslvQDIeqw*mJmDIHU^l_^SPq)R*%%r5j#)R>D0y^ zPz%M50s{st*{)MO$p9>}U2p@i62Pl)1q#H_zjo zj4j`EH1fYqD-2AG4>_=lMFW{-j`fKoT~n8N;OPYrY}5;%8T1;({32Y(>eg|0d|luA zJEo)0wi=PNTj2*Xzz*d}ddHts|AGeYIMEjrfVxtuKgr(}06Hd30i<{G9~7?y0QMi( zEbn-#7^HWKpX9FvKq>?ZAib0Spm+rU>m2}~1Y5k!e1T11kcYVJ)%qBe6-FB7$ut<@ z7LzWwnT-7wI)-_hoJpE3gn42-($KW3d&?3$vUKzjw|dg8Pb79t8(B%*ueP{>MuuDk zB8tKDAnTt!L3gHXTKNa?cNGrrh-}6$jz16M zR~%S81=H!37-3m_wwOG^PyiCXhDGOIqP!g6nRx;L)C^{E&V04{p<+<|Y@xdVpj>ci zNXg#m_W-0Loyif>OZ`Sd;`ijxNQEoKKzVorP7v;J8Nd_|3qJu}5DJ2uPs8KnJKWGi z0U%)}_ks0g`8+?hLQdlv_YpcPG~$9K>NJonSvNvVFclZi1Dkjg!`*m4kHLBG&G1bh z<%WkiWrnKwA^^mjDFEj*F!=M?=(Snxx59^!26{>&jI3*2tPCiOZA;|YsKR*L9$`vB z8ngI5A39>-4P5i_@{?S~G#6FkuEHM0b+PIQ0Cl#)td9!YG)@%PS->DD+S-Wz_#Kjj z&7GUhgHu_DJZ9S+$3~U3%cJnDs;L2%0>Cc85bmF?f!%}9dosdgM`h0xSA~IRi^J;( zca@AGuKvaoDvewkxg3NKqOr(Y7#ACJp^LYBp_Z&f%++eSi@ySZvW1aGdNLCRBA_ut zvc%E6g%JbDp{l2&!GCy9n_gyyUlG;y*@V5H=}p>DLTG=Q_N1}#7CKPJL@}u8PGdJ* z-CGI_1yJZ+lYUfND_&)o9VPhB>@aOlgShf{qS#5uvrxnv)*z2Bh*132n5sP=1xc(~uC@GAcG}2R2 zVPvDe#c0#Kg`xfXLqP=Q1nr5SR~Rp*ws9qb%BF&Kk?XC!%^uA%h6~Ez=Kc;EpPA9f z42W?I&PQ(&l@_7aI!Lm_D=dnJ?e1f5jltQ7A?DQM9xYBg#^K zX;lE=&sP|t_f4LK9*dh7sD;uX&zYsJ{t5uf3L}m5lw26k)P}xlPdcwKpE>uSg>kP@ zr{_-ibnmWh6fecU2!DIFdGf@=%=5OyVCARcE4fCMr= zb~tqeA669}O<=H%@sKVJ(k4pR=*^QSPeAEy`q^;x`2PK44i)4oj|VWoYglfz&G=!y zAniqBmGW=aTs2XJZ--o8IAMfT%ZmA_ZA+6hY^tVkxeW{qKoU|DB7k_aqV@_l1CWJv zwlV$=5x`H>?cGgX$TJS#&Z>9%3;=RVW#QCB61V99X63N| zrh9(Kx$3R#I{jA80bsqO?8DeeB0cX*GK_ww75Z2!9{Tvj&lnTDJveL#X=CqIXUSHDS;^epv zLR8@5&b?*Xm<_4w85c2+qR?Cw&69FWE5q8ducU$)kl7 z24+dlyT3PV~E&VW*;gj=_a732=Ai)(J(6A24}`XoaQ7=Nw^`2 z%C};hpA56}e@xpI)lv+O;9<25)lcF)0rKR^t`+d3=t(6p6acnwk$0nZ;lx7c5>_Kd zJF^c3z!4FLB|ZR3x{2AJyFLFa030*I2(L49ug;4cqhfxh(@ho7GA@iKoJ=X=p_4Qf zANnl?z=X&NA#-Xo`l9@k{I3E?oXqY6Hdk+1N9Di&5ZZeIqopq^EQ}=5^S-3R2;b27 zXK>lsuq_riW8vzL!jR-ez`~o$>3AI8_C~M!*!?0Pdgt}<@~Yqa9hv+m=q-DLFOc~g z_qk2SYg~r^d(3s<;s5^F0F{&6{DbaW4U)5ydRJ*uzf4qNNkBIO2q&{+~UKy5Bn&3E;CmM><2fYVw!Nr(g37}6+l~&SYL}$ z)ikS{<^X`X?ZFGH{8bDpA1!th03s35=ry`q`-_EWm?t9AF~Z1ni<7RLGDV9)^SLUJ z6FEb5fm-AMP87yD0ZJl+`9GK#D^bU~6ft11CL7BZMiS|HU-MyH zUQOO@Le|lrY-n>!aVVV^6h`U!k~dsXG_{eU5pEvKbi7-nS*xi4u52Q6a}C6MNqjM< zhsg1{qJX)#005C+N;(mAx590?xNaH77a#*wNktU{zF>>{EnAO%!WAC+%#!n@dAGO4 z>C!|M=2mm&3m-8^+WSmO&3O0$5V5Q>vg)yW43q1mnV$agbbY^Dw$13DI$5;h+c(JQFfsvuLu{vlKvZ|r) zlby-YNu8*HFE&MeO`4E2slsAvy8@9WFmSD#nrIa|*Ho_R&@WvK8ZcE~1m>eU?{&u* z4*z@i-DK45opncpFz&$`#{KYQI(SX*H)3jKOTGaN>dYF4J%8Cnq~G~;1Uvia`)8+H z&;Iwb@T~ifX%~CV4UqF@gbf(GFY8uI# zYYpypJHdeZR18yOku#Jxj5tUhfIa^zAyp`hB+~P~0;tlpvR>Ypdjl#v`6$Is0aPvK z6+LJGfQf&f-lh^#0J6k4g^TkU4)63$2LL0naBM@%)abeNO$A^Jj?)KNaOh6n)b9qR)q4@r_p&-;=OV+Dl)li;%bE*#u#N>pK1unCBH;Q~>nXEia`ClVXW zq<2M~oApelvCf8Y&W^()vig(@?USh&$FK`){$bM z&3=P&DV0M1f<@;V?1<*H!4>PJJ|+b)tDxFv9|1Je7HSE+(1Z24P*NC(?u$7+?@K-m zRTx(z2{r~=r+0n`KO&5&ZpU+27+6cvp1y3>!sw4DpP;=W20pVCB_+V&&5eR7j zMmibhPmSXXr9l>EB2H^DIis0aQ+XrB2SEeFWyK$*!HOUAv-JU#6-E;2d0+Bj{Ekh` z1I8kky#cbN=D ztvECDADc5Gl@RHKC=>bxQg^`mf|6jf(rFVIAVt5?5Jb!oj#&bAFmGh8U}_T>tW@>* z(O&_BvcgCsJtZFoH@b(b>#E&B<{U|88YxhDLWOal7RG_JHc2BRYyXj4h>C`PC3DIm znMj(T^1W<;f8%`Ad$T|-lBzXM>WDq0%!BF8?#NA^{bF@WTn%O7&seO zBAY$(eu$8b~M<5WtNR$vc8$E!}L+hv3We7dhpcGev+$@0zjCgMpzwV$(i~^ zcQGjP%naV*Zo>VTpVk#N>GF2ADcdR6qb~gyMT_?pxX7=}{8~BITy60gf_35q?2+c) zxsgR)CDW{lg^nuBZqK<2S6r;$+Dv5$8zr_{48#%};jhMUOX=%;5_}YcdX~-Mk2jW# zPd@$bOv$a4s~`cn@MjaT3aw@CtnN7uty_uY_l<}@?BJAHS3wu^iHDsV`0N6VD$Fl8za zZDrRGL0vFbdW+6JRwp;Prx?($${L>{5wjY6?-&k?i7TC=ka5;`kB|QTxHL7IRbf-h z!FWZ>)4+H+uQ21IFlGSat>sPtfO~?z1{tu}M@AH}5~x1!X0@uqqzMfE{0w^-nwlt+ z2%yJ~Nwi1qKo%K%# zhF^5D7!01r&~RIQ%6nQvahNC$*cl~e;jw(bhv?uVRoyh_P?6Kz;uv?f9q)P63I(h7=+~M0)^4Ig|Q{Y-atWH*VPKg zXaM#C67K3q0bv)tODv(a_gY~qD#rEML>p)8BGx>X@hKEz7RR*f?#DbiaOD{6*xR=G zhiDXpI*lht8a(rG0J{|c81i|+x!qYX9Kc>408$pbl9GZW)KtrWBVjl^Qt#N6FI_^LofXApmF9V{vvnWz$h__i z@}W{9&iiM<9|`mdaEbwZme~RjQ#FZeldC}zH)ReC0Q~vxHgP?>6gV5=cwinYlm^+d z{F{5Zbb(6RUm1Q@Q&R@ zYYY4YfSSrxmRG*n1P#him$_4+Fp@~m1IdT+Pu=}J{L?lM4*wiu{LD>K{>d()6e#U~G?I)!#~=RvAYlHze{RfvL=M&F50`9k)BqKQxdpsHr^`P`HBX;88-;9HB+ zst1w}Z>k;Ogk9ixUkXFfFb{iF6B(=axv0dYJ;AfcrvJ|E9phxy49%TW%j$1W z+kBR4KOq24l?FbAdvm`grN%FqfzcVw{O1l}Y0_n2J^)$IkXh|){noZxx!G4A00w1+ zkwkhTgC$H5^I?dKt}`4=Mp!2E4f55#&MHzo6Q}0`tUqgNTJ=eXk-+e^qF>tKEC6kb zfvn9m=e>k&cD{gvzIcGjx*453K)S2WnKU;*!0AP=i~Tg<4(V`vy!^o3Ag#})7w`v; zkQ+z~LwZp04{r8*gBe6j>TwMYRXuislj33v4nsXKJAp0HF=d=9#vaN~R)yUJfDPx; z7wgWe0i1K=%EgXq0FxdfG#5KE0Q*T5#=YN{01#)F5+X82lt*0IcXkJ2QH4{6LDka* z?p-s`nwu0por&Javb4?t;uu&aQ=KK25Xc2%AsxV+a_S$Kha`JRq~`(iVT6q>(G@~$ z%&l@t4GzQl0~QAIS`S}O8e2<(6ue$)jH@P7(d6m)MAISHISXymc{${iNSvpR^755< z6U@ygwG#;R`S;;ZRIEWLy#R{+7>Fcp znXY+su1{hGJ_$(A?Dl zi%FZAjYcsbcU80LR}`G+Gi(KO6;(32i7K3Qp{qiy#gf%%0t3vFc=4Dc@zWWs&plcn zgBRf?GBk8ArhOP=ui9@AG&2gl3sL3a9D8d^HzM=gxsv@tB=Hd(*D?t$8uN2g7&(2x zeDb%byq}{t_!TPL53K@c%Mc<$yM`j6c4iCjXIJQuW55rDxjW$_*w+~iBxijq>|@oD zrhbn7rl1R@3$%k=)B<9!x5De}vWI)rx zu$|8|a4T2h(if;B^t$4Z@6~c#s)wsYs?zIZovUY?)#PhpswD6ffY~uF=ZWA%b%vE- z7h9s(c5^nE0&wlNo6~MBt{=PD65BlYQG$R8iUZiM0wAM{%kCtyTbL9RK*C03=1|T=xCJPDFOUhC+ z_dAhHI4w#+0XVo7ek&A466tv$`7rty?BAgd@zcQ%lwE69QFMCV*R>>#D2x|28^!(H_%Vf1+mn$nP#D-xy79$l z|C9))Sqg(J%j*i^)3uefgnX)hluen!*ym(HoQ}y9MukR50YIN**}MQvrXy@xwxlEy zC5L`PF@P2d<0<@co>$D)spWNzd1g+yR`AWR-0vDfx$8) zE5BQzFp@}5?7of{?#Kee5I(oxGL-xsS{S>HIz2^H9StZ(4jj3Ms4Q8fjAnf{`gmRK znc<{VW^2LqT%%AlEXj4cvr^`KClhS#>6 zm91w0u;%pn3&{E`0-WLD>oC2%gLt;8zNraG6E3(A$igY|LEK5%Mzcyhqmr(x)e9pc z*1RFcl!|@S;V<-V;YJ-Pn;~K~{=w<@c@^=TolOwYVXgN20bo#edZv+{k`LoT6h#Xr zhMdf_E=Y%x597~Ye1^fCtvR4-XWN3P^9S07N`3pQ7+(IMH12DlZkrqA8H&x`{i(If_9BE-W@F+1F0&Vy|L*1zZM#BEp9lyApl(%Izaq!J+<)I( zqh`~vYGwF3?e2(6VADeZWZ+wPNV#jl%Z}iwPK(*_LQs7pcM9^V0Bj~q=eln0Jh9;n z`*)jxvAHk6DjWcyv1hTtEGl9KNHHitUFH%1ga=pwIOz7b#xj^g=uvXrqGQ!IgU|`Z zw16fs__Iw_N}>iO(NIn8inONn=Sl;a+!M_|Jb(8vJd~++4JArD0W2|8-IA;WY=VgO z=q>W3LSdwlo{|s4NW@V(8x4Y^bn%X@#3~g-3u70Ho_hgKQ}%6YVXT@GqX{CZt4UV9 zcxR-wTBzMMgF!|=2@CUXPMsgIqti>6AzzA@W`tegLEvUE@Q|a}AzKjAB1C8ggD5i2 z1)G=r*J02ek9#kfN5nCp=8wTx(sm{HOpFv1loh`wXi#b`OWpVYFenX4_R~mD$%i3T z;+`FpYD7Y|&*cQW=Jux&ep0A&X-HCdzT_o{bQoB?91oEdriC+M?FBcSntLdf(@aDJ zLL)%>OzcW8fi^ZEAM{FbhYCP#iWrL{_QdmBzq*O}wM^YtBNH*O84NC3ZHv1cF{K#Q zbURa+O^Ik0!6<;@-6gI807{em^TW(?RZv3TnXR@N45IK5i)8g#rcB9bzGb~qf>SdX zn>f4@XN(?GoyKLopz`q)+!K=9cG_ zle-q4SD6|lt3t_ZD>lLQR}V4JObG(FvLpmFB4hv@rzL+S((`2W<`Cc6*cgkKY_QmA zX^V&?uK>P22K0Og21i5!xmWb+8@<}qE6m^X*wZUa;AaOg*w@?Gsh-DOy?UZo_w?%D z^ywUvIiPCgGXoJBc3l*gND2)EhQi{UPor9WNI0HV=8-f{&8_c z3s*v>uTtDH8r;191W_=IfJvw^l@OF19n!CHt^jO3L3pf5p}UamE;oRiV01WVze5F3 zfV#{j03ZplcDfLv3)CF;CY`4wKu$7}g(XP|ih-@*Yw0KH`a^fZ`wGO6TA75ieih0J zBZ>5UAo(z`8XGiaKG|Ev(MM93>=X(Evm~-wHFbKfng&=5!COjYX{q$kgTUzFVfEnL zhT-`^Ic)(ult|BIH@Pq)p5_NaESi5Pxp!f zh@*quJJ1_*!L45fPHK+22z~47V%zgx2ibKmku#Z@IUx7>8>LWb#b7sF^^g}q96*>_ zLbmgQ9Z{%wa@k}RHYrXJW&{CxHPRYDy7)pd{eWT+o2#fEYpzb2IOH-1vktC&8La}y zK{-6-7Z>lTh6E&EsT2@Ib8WH$&7awc!WAij3IZMZdvb+uy-&u=FUO5 zApZTvO@OfvkncC)u$4%;j7DjyBb?)(eCuBneht9anp^93z}6WWGm1#Y&JcdYG|N_1 zNT&iQKwah%0I<6&V_SW7yHevucigdrvbqML4rmzzXj*n@vJ>pxum#dF>?0RGa)H9Iz8sVlMiS}y z0QoSY%&mCx5kM1cT9NqivyWW($OQ_+`f^ZK7)hk(1LVVqGPmN%M*vN*X+`44&pvYD zBNr$P>&rn|VI+~B50DQd%G`=49|1JMrWJ`FKl{jqk6fTItS<*;g^@;jA|FPSxfM@7 z0%(FwD-u6`_K^!8xjFpyVz0?)&Mr#UhiqXtkTn#c@%xVF()7>xx`VxT-7U=|q2D?Ned eVZhTInT$~bs1Z$M20mQdXe^Az0w^(1o(=$1FU6Yx literal 0 HcmV?d00001 diff --git a/sources/msdos/krnlbios.fth b/sources/msdos/krnlbios.fth new file mode 100644 index 0000000000000000000000000000000000000000..37505b2177cbc16e30f9c24fab4b1d2e7d9eb7c9 GIT binary patch literal 171554 zcmeFa>vB}bvMzdl^Au&^7};1t5(0#5L(38@>nu;(0rvFX8@yMvS}o{Bt6Q@#U>uGa zu_M+a><2#ImzNqfZhak0vm6@6>T%7=%FN2j%F4=m89x8~^YBf7*m)DaA8v*1@NM_E zQ@Pv@*IxcV;RcQn-VXb3#!r8E_S3f^*e#q?AD#9%?Ck&Nw7t=D-M8KT@UnXrPTyBU$nIXtPFFi4fPdc#&pWUC-QKv@ee*^5W-I*I9Sph`?ZM!S z@NZk;S@-pMw}19UINl1sbbEs?Xb}$r__^Qjg>Q%F=laQyuY3L8W%ys+i__5%pB=SF z;|VJEd@>qN_)7ekC)e)Z+ujXtyQ6V$IAE2(*^0%7_TUWYW!UAuw2Ny$f_`B#3`h6( z!u4r?GHMGauH!ktWfiFUnD-)p`}^D5+fwG?q&@0|=RXm^@s?Mb*reDwzzAS}dw)9! zfTJJp{EZ*~yybM^%V2ugzwe)AzY)OE&i#B90ODxt@55J5EN zkAHYhEb=5g>;4}0ALPL_B1n0VOJ4mIFnC$e7CV`?*nzfij<~*%cK_Y5eTMcoV$&}k zZ^j|j79spF=)XUg&%(<=w|h1YKaJW0wA%p%q&MjFr)S-8(Veun&QFWbLK7t34SgVd zJ{n$xzdiZsu&S6+x!H{-Fc@^-1!>@0M?d@xpfj5M)E>R+PM|=~dxPEt>SUai>}O42 zuophv+1Uw`*Q2R}4dEs98(Lj^bQahMH=n$Fn9dIPXu#uOmc1c^NwW;kcWl zjz3F(*TpeoP* z*K{~K8?Y|FPf?vgI2lYJIR<6ef7KnJk{4}&9vn#3)~~{0`0DFN;qZSbr4Bds@;kXa zyscL>+3JpKNAk{*0XR|sM+)Fb0UXT)5Hh+PhAC)xq@?_PItuMRDt$qVY7oBZ4vf?1 zBM>bf>(k&^s&H&oIMym0YZZ>Q3deJ*aE9hRJcWri>4qnLpp5S3tUC@H$8EOqO=!N( zoAFjeI)Ac$6`n~IzOgDi(<(gEDm>FFJeyYqNa?fgWI7uB$C%ju$K|jG`75=dJnDY6 zeia<@LU0iU@ga~YbOfe zL@+oRj3=XMhgQI%I9&Th030iTU!bl0%P&IjBG+2kdh;!o!oR+h93LnO&sm2jdhtXq zp6kVPxj52`Be{_3+8<(Y*zb44^X@CQ(vkNR@46$ZTVz@Vrt_A+g;$B~HoDt<%@W%n+_#gpS1M1yGoi}&Kc zV1zsblQX+u#y2w_txw{?@DlLv;RrXve_rq+IbL^1-LShE9`#{@^uwdhuz!|3#_6@? z0F1imHPBA7WBn=|f%@oBhoj!B9>;!yv|fF}a^(8v4qOu3;k;L2M86E*_Rzjg(a7Pi zf#(R#@!#A1iJ*%11>kIds;Ii7xA1AS!EKf$$NE(W;pUTv7SIb?u9S# z;OP-n<}jt17aV^fiIdm8F>FNqV&DqzO>fd3V^9I07{aytz2Do^;kcAHrs!A#I~D`6 zeii-*#)tm!)i8WvK~P0$$}RyNE{IM24rG4P-AR`r!t152J4k^VK81DP<4F&Ci+k*^b7*k!43aC!P#fwV)z#KPQs;B zt41#ZK-L>BP+;km^?9_Owo)^`gw`@QPz5+~C;|cI%TG}#Zos1rQ|8x>Y3tavRT#zcH?O4i(am^mL z9(OAX`XKMOc#vs}2hk z5;iNx9luX6f=nuY5oDH={y&)`Oy`RMKxi=DF2P>xh65O_3*f9Uidw9AyyX~JUzmKi z?fv5{^DF~!+J;{_cYM0D9pvs}0EW}a<#Z`q)k^a!^aiVaA8F7XjfSJwm?f@{@>^cOU>G`GCg`rEs?dRhkMO?kbK32;|VLO0nUXqLk7~>7aU=MI{YmI2f zMPDJSP}COtnYP&HQ-lxnE~lhG80!R^k+(*3KwE6zg$L@D%yLz$kb0g{0}e^q3#~l3;MHJJf=op?*IT1vr&bh zKl@h+dNWmcgx+)mrr#+C-OzVFF7w~xWPFxWfS^HayL97@dYB+z=4g%!k5~nu&sv}g zvCrVh(%bqo^ocs|)L-@@A4L_GAzAs|CWu&uy3C!Dwt)7F!JLOw7o%1f=^&!}8yreg zIMreCJeG^9l1l1A+nQ-~V{$c@Kd5bBm53-;i4-1|TSXI05*pN!EaFsi0t~*>DH{X9 zrg37LYF<4Ev#}}|_d|H3m@GW%Z43hwyp3?)Z@)6FS3|b^ZN=ail7}IOs2MQ_wIbVJ zhsVF_`!8OEO6#UMB5r>z#B06^1I#P28o#nCQIHcdpgA8{)6JKD^3)pnPv1WIzQ#*S zIAwK_M00+_$KBt$ohb$)w3INotBUnY5DKBBE^<$oz5ti4ttlE94Rp?3OpY-lpuS4) z3$qylCs$*F>h;f!ML=tX~C+iQ~`SIUP}y<#&iBO2)CkdalOfmLX(bLvs7!l5}z5Ex30lvkKlwP>yi zQ4BT$Sg?3C=2YRgT#x@@sz8;QiE#;k&bN*z?ZjpLu6;?dPqk-bL_Fs*Bawq08&&Oc zSQQ|ZkVTsr|1dO|BWQCUm#vE=p7WUMqJ{aD-B#G0?f1?K`atTUl`4xkZcY1fAGj6> z-58fafKpq}Ya#V^x}9Noh`#x=tqV?qf{7^&@9vt$J)2%KSb$HZm9%n=1b1;XK}2An z`jRE*6pgl2J_H{5HY%kzg+TZL=^-B6GQ8q(QoX=9vT-r(oK7zxnIS= zxet!(tlA-%KchoWKr~T>1l$Uz9{~m>b&*7LKBc-~=Mx^w--T-Ufz*W|pz6XLub<4zIeGIIz8W&0!+zIChFYV52D$&gc$DVk_;MDVG z^Xuap2Vav!%%rHU3be^dYV!v2)W!o%5K-&0>fb92Aj&0mk%V+&mITiwpcCmE0>Ur2 z5J+NMX3+ct=?g)_%!?g50K8kVi`u?L*_`wuZcBJmK``|!eM1@?C=~)`A}PY7M`{VA zL)#e?X+qGXYb6(ONMp;YeK+l2?~*j7PPRycBlCVZDRAwbZH^St&Jr4E@t}cp@yijR zF&a<`Qvzt$A*282I)7?EHouXt0>8FFmsm;*a!{DtSQWGpRaHWGC$de&Svs7JanxJM zv>A?dVWSo=Jk((AQaSZE03aXJxswESVwo78Z&FMydugVadU$y9f%Ju-0q`lAL0NAs z)=nyD?L>}NXVOSyGA*i$*lN^HaY)c_k3rH;%1wh)%s~oF|_JQ<;B4C1EseP-_F-bi{sDh1BGpRp{^9mlv@EotH z{AbXV%_m8FI6*7X8Hp2Hit>wv28|~%I=Bd6gt&Ny@A1nq9(H8iYl4^ei~bwErL2N0 zuMFxkXVR}23s)ea*r6zowiScDq}g%=#v5=@(%{ne+Ck;IkJR6lYqL$X6|u2Y5|c_K z6fAQ#A(CQ11(%;pBFpv8b7Q9eCLi-u0TkIt-C3NUN>Iv}C;%E@qc_D!0yBD3eiSf| zmyiP-#x=DPF^}ShO6f{TJ+*<`&Ps9E6u{{ZYPq zYE0CXghB&zb-HTsUpIa71`fG^DhLCTujP6%tGdA|Ktn_vz&i4B5er2z$hB5wA6r{) z3{;~UjRw`li#*OTuA8HQNl)tr|nPLznI3vb==$zw7hCRJ17;9`| z0MLNK*^RAtRu%4=F=xM~{7d>`H;L@TObMPdA0nosIVDXe+1#U~FXnzR^99gI6pof{ zqmg9LdW=Orj32Ai6@=WFoRARt@sOf%w_ZY6zGL8Oke(C;Rg1EImi=w43KHUw8`7;@ z1p&2i4OHc6@u*iis7x^+lcjs&35mpC71hRQpm82`7-U2*ohb$>8x_>TL};Q4C9IaZ zu|5Vx`(iff$8Zsk zr>A%`aU&byYkEMTK~3>SnpqTZrCW*IVmF&0;$kJ$z4ceXprkL7*iI})2b<4~oo8&Z z3mhLvUpN{Y;Y>o}Hu0mDpIaC%&4<>04Oit763VezK7K)Ooh(1%4C1`05dqNzo5e(O z3Q85uMD3mB)t(Q@bSM^ytr+|QY*i0FWw=0 z^*Au)kZF#756R9EPnh75o_-+v0;RH)H0c34RkO?UlbxFFz;RMJIk5@PqTRkg8i&S2 z9ckNG2dTp1i{#jfnZ)nU#WRUoxg`at>uG0Zrkq)Org^k!MC_U>jsvtC&e#N&o!gME0#e)-3araXV6gLmt(<;k~m5=aE{VUlx1sCh85U2KS zW}FHFLD)a>cH7v27EDswRI3dt4{? z{Og>cHh=*mK*+-?4tklhej#W$BzlL4Zhs}Vg+!0wJhdt|`LNt*q_J83OERR5t?IK3 zCjmeTRuRxA04s|&7>x-M3R#Viia~YPS853E(TnN|g(?kDys)v@al}0_*|U^6Kr#S8 zL0_ctotpe2u`d=-7auAf+{}xr)~ez3oZ9OYcN1Y1Sx*^Znpsh{Dym2;U&$XKGK;Tl zD-iFmYl!P08WXhXyB_x3kO4gU=NJ9qyYRaA>h%k3+>zJ}-ckEx3(!yu4iOS36w(eE zT3AM`IpP>8Wb(-Ij{x+>aS8_gr}z)tWGjyM9EK3F0{`iyVJ{vLi6q+e*!j(X&e-L) zF(P7H&Mv0L$^jTV0R#IxVRBAXoQRYvojP_w%G;#CKF(ILA&b_ou~dZyT6|^cvSttn z(92h8Is*U>A=1|prD@CZWNDWZ$|+v;yFL+1`XY_*laOLDYDYAhWq+uJX<5N|m9b~4& zlpj%X5ddmO1|Fe_N*gW>M3kTEzsmb^tZ!uvD)BGkTXC(el@Y*VCc$@3_sb(`tX#*I z8c7!5`#Lg|$<_ zxTG&c)CdKfispgFTe);aE$&v8MH+zrbyb95>A$L=p_~n7BWI#t#-MEpIZfooiU1#7TC>cv z03dQ6TUwRHo&j)&L;@fwXr5in(7Ze)r`D?(dWBum7%#kBEqKsTT zb-w@lbgTcSu#`*bCTRYZ{~jg@`2C*$0+IrVHWX};XFxo^N;2P(V8v&euD=O6Q6iF$ zGl>|zK(zf~GT7lXU`BE^qih18?E1-J?%&s%iSdPbC%{0e5T!7L`xsb0Gjxj9K^cq2 zi0Ixc4p8XD5n=ytVuin-_n)fYcx@!)%afz^PviaE3TvWc&} zu&qyIS9wlCRT#N;M+4r?&b+cf4cEs2X5w1M`WVnmJR4H!r-vGbSPqX6VwxwmL>NC} zDdHFZMAjjR@;UZ28;9#X4=9b%*6@7m_=oEO@l3iy&Srj#ob{_fFH&u{ zWv*Jm5eVl+NUIDC0H97~8vw~cMhlCyD#W48ssd<80wVVZVz5Cpv#;}b%mR?IrS=?L zD2zvv_|9F)e<5lD{ONVD^U?xG$$zoHH#1&A6{TM}p>@F#2yKcOy2Os!UGuxD2e_hw z15@j9*w|u2oKa5wBhl(89!G`&*u#7QWYLH$(sVe9d?)bM=aSLj|4T85G`R2eR*Pld zFB3AXPlKd7E1fn$gOv)7A6;S4NXJvu7fF2QuH?Ts9kmCY*Wt1KM*7#Cd?07)w$DZ98?=2K2@DZWz9qG`4T* zL3ni09=(w&NDq&mb0n?{tCei9wT)=v)XV5KZbHz2fs+9?h7@nklN1B9C`)1Z&0z4= z0yLYm#Ni$ z{|XqC#v@65C)SccpL`?sMQ0#dqE_G1{u$j#P@Z`JaPw-auvEyQfN2bw;X#Pm$#D?XjgBj}-+xScj@(`E3 z5*mE->hU^q_1YonE)iRXkZGzKUvaHbkw0QIP{tRN!kTint4+K!s;detdHHQ-Q=e8q6-M z`l+zdKo{f>BUP)~+_v!Z_dlI{S8hy;0VwHc13jss_r&F9>H$eKUhgl zC2>1h8@)SIU9fM(c99Mt0-)Pz2>{>y@WYRS!`;|eBB*(e;JlppXVK9gr3}rcy2VNr zZaWGU7`P*~iXXh!1O|1m7rPG(WJvYhlf%DL=j0|g(C|_hbR|Tsg6B)keit5Q=4nt_ z#_XFiE{*ud=|T)qk==p%qclo|B1-q927qVTUgZaH*LK?dK3ugpt8n0k;W-8Wj|{8z ztB}E3?W{Z=N#Z+qCI7|r;`0#rKmILpP+vT3)V>fwBN}O>k!6~hkC75NnZ5E*L}dGg z5i~zyM*++)sP+v2kSdUfi5s1{_bOt3njqqVi(n*TxEu{N;D{y1kefG{^ib zH~_3U!BRwN*=t~+3dczR3TRqF5+K&UTt_eHn(pk5iuSO;7zZ}#JoG(dkK|nAQj922 zA=Crep+wYR?4Hmo3*4?HT;N=_9SYzm=*O7TvK`Vz1!dmaLrZ<5iNhdu5-3U-9|0E_ z{h+OY!I84imn|dG-?Xk*x%8__mt$h_bb-iJ(7GLng-Q6p*&7`v-|(It3Lw$y0*BY4 z*JYwk&XCqfA*mYIS!~AcKhKG5Iy<+rx_Klc+><2QRNKZ_QTxpmI`daHQ3W**AiH9qaB}{RCNJVf1gy$T`#|J?l8>)t zX5T*E#Ui!L12cmhO;lk9_yr!Vk3rFYv6seoO8$#G=$FsJ=h9w3zZ0g~aHnVbTSl^Z z`vR?1i-~rqrUHzL9Zv-tuKFo)Zhacj0U{<=NnfN^jbKn|5;uc^azI5L#swnbA@Dh+ zg<*k?2Xfkqq-zQTVS{r)F-VzUQc}f+W-u_}OUI?8Kw@HUYgcRib1DoCVW4tfwsOyM zgb+d%|0o9F64gJ9fy{`o{qp3I-Nmpj#a>`FQH3H>%Uzf4i!{Dd@?Yp)Cbkg`OnR|r zXOz;szL0J~(Li%K9}O?UWC$}5DgV%9*k+RrVlqR*a8x3D2HlgwPJqSjXA(%(*?bI^ zu-RC~gc>5u;EB>8t6LVx%|*9RsEy&K-(@Zs#}?M}B<=FJ!+zsS+FzOY=k8;XZTKlHl;>I}r}%SlOR zc#=jStVDJvr?(7T`+hkp-Dk?hs`1DowVw43Fu+!RLPj)oiQaJhiMZ9QQ=fWKt1zpG zInMw$2Bn`y!3+l>8S8^1O%r5RtYMyMWI*n${O4>Vkktx|kNo zfN9pnY=o4^TyJixdt7yRr{F=7QE!hYL&gMsMD_*S$_xUCgk_tbm+7Hx1?>aPMMN3m zYtjjUhIdS@H)%5BBGdd0nL*ryq#i{1N!hr$Nlg`xZLMckvOj481BbQR?-d53bo1*+ z_R{!H$$ufilb9!lzx<1U6swo*vlyjQMfeY-F9eNzbZ1;aF})SeF2m1UMdpi1ys?XY zvF7v!TdNe0>ZTZ=%&K0XM3g23P0R!3LUg#PNf46S!(Kq?t^k{+ffaA=K56D4!R>mx zD4|3XG&q0&$`P};0taQxCy2jN^vasXumA=JlwTejA?s}f0QBe1LI5cJ0swuLSc;!1 z1~=jOn>Qh<7+88^La_rXo5~wY?x4&B$VO|^oa44D^w{sAIK0FNAi2#H*M5^mnx zHc_btmIJ`FKRh1cWI+TtB8nKC_BF0O@MIML<4d@0c*x0u5SkFQgFxb?`Z5Rs7gCuG zjGWor|1s^3-b?L?3mMn_?Xuf}c#akqe^2Ay{IpC8`T%mw+b5R@W1mKQ(&g$WeD#3ofYs?E+s(%J{~!;Ra%Aj zOP30Ou?Iea+5S2kyC5GUzVHQK@{(@dV{X4(iZCDEGcbW61{m7n<9S}HMjD$Ek!&;~ zZqseC9Tp>F9T69$p;aLvB67-B5K&(!5|Av(8e2-lC8(GIAh;C{01zU^W}w3=qvLIH zzSHEW6-Fnb<|1@4j9Cil?S%YLQq@k3S)4tNMFGUv6dIE1ElQ+&rZBBfgOa{T;yaOR zi}|%gS4eY>l$u3t>WgOMI}cQ6<=9gr<}xFd$4+UKg#G6q&%aUtws=BE|1D03#kB(% z|7(5SA@YamW_1VnMS@`&|5pmNOVEi{BqBnsY9T(6QSvrKxoO`uG9-5GY3b0GuDvd{A;>G-(cP0Ntr+wL*v>ENX*a3ZkjgFcej~tD# zM5r4!A|`3H(9Qd@y%k+{nCOF!&Icwsm#DdKKKKUlLWlLQR#!0Nk^tFf(2)aS7AivC zf1)?VU_iPS1SZ0Scp3hSATt2Gy7{mQz{7{t0RC?Ufc><_j={sj1ON*cEMA8HlLx>j zH<36^s-Q8Qd|}?9Rfu4h4|vVfU|w+*&jCPscNc<4vQ1 zz-!6F%=Z&<0f03fVG-1dCruD>#iH%Avc5>-JMT*Vi|OU%;$eIM3w^PDH?*g(8uMR> zoH!b)*kuZEq3IE8t>w9L_X^H6sg+Aq3y6W1P4u8GbRaV{q_`!e32thgGIh5yaNDmS6bgyP!_ov zmcn=OQZb-o5z(ogUN5xq=!KpC&WX%lvmM;xSILP2@I4VE--yn^MksBAc8H1o3|KT9 znxTO;gr(a7YoZufMn74Dc@jFUNLF0H`6KHZzf3BgoR;-P65n}O@?UI7_PgYpIj0?6T#uOWTm@fV7QNeah_HgJqC44p10hR_&|JPMqC${X1<3e||DrhlYs7^>=~M5exo zK^qKI&@pD&mGO)FCCsPcTq0-!`Ncw=d>@0#@TNQ-c|n^y@)xy}gOCB>Gp9w&%a1!o z7p+w8Te-*p`~oVdvW&Eg6)k@k?_>Z-gJT4D+3a>QyW>GKM~OzQ0Ki)w?-5-fK#6`N zHJzxBPv1k6DWVD^!+_VsK%XWE6dX$WUHp4Z2Aw3}(L8d+Z*nIY1_Y9n>lFv~*edcy z)}P=k#R&lZYzwF8zqpsgciv_G3q-jrsWGT99)uyh*85lxpQG3c7n-)9pezcyVx}>w z7;vn}=_(yC3g^|0-b&oKa7w6KHHW7Hkb$OshY2uo28g#LjzZ-jLbS0y6Z=DLicCRW zyS@+rn>PQ)ZjN7D_|Ivd4iSrqyDeHCV4{v+pNP2%t#EOLfwOT1;`t|k1tOO8MH1h6 zSMpzshtm-PJf+2ABUJ=!4cZqojL_!CBXKgaKWv{NY)K1`7jxzmo8S_hg-V5NI*}2Y zv}ial+6uFRrA%isnlR$r3LB^WVdqUay(2TMX>cK@3T5WFrCZ>9*?`ieF)tjRKteI7)7qwtWwc=m8yZ{Sczj4RRS?-1 zDX_^xl>sF#i&v$ug9hPhM$slP$g^eHtMxG`>5C-3^RDE-K$c}#b~@zy;(EBweY7{O zhk$>T2lU0x{dE7-*xVHoq(UIhY32@l{VKApDEgR5^m!F;?8<14UOO!>vhb@IDAHJ6 z{Iw5SE%8k@P)#!%r7)VQ0%(szD{>uCbJW~wtw>`*4K!d$O_oeb`Bf7bh!;t?4}h88 z)KQ?#>!s4JgNLIVwdo@74 ztMfHwNR|B;NqpyB$$znR9n!J20cSsbUdZB(*>P+hR6AipePQtz`%P7G14zgrbXFBU zd4JhO4aXEz2D@ z!dL9)G3dkYl(dng*FQ&&D%qS6;V`mca2~E=Fz9w=>l}gPy8lH~{Xj6UX%id(V7)`D zfEFaj&7JLV%Jmfs#mCAg0w6ZOPger4W)({IMH1h6SMp!PjZ+6$P{SM;*hixGsyBHY z+MUi6>78hPbcTE?3(`0q*>5=CuN9b?2XaGpro9u+WuIC|P2&50h^@x#P&RWk;LdQw z!H9$WAxu_G`)39MELg(urvTB02r2;0Jfe@bY3s_X!f>oi{z@+&tL;%((5(O*pA~*Z zP7-QwgxhC`NyT_V>40W)8!2>ngWbJ2QfS`CLorbAi=*rbsnC_ux0BosXILo39yn_{ z%~Zjqg!mI(`m6#JWLR`eLL*P12?lF5ny5k^rDd=F z3K*31MH=5J`7cWPVh)+0FC<=Tpz|Ytpm&EM$(cePV#sED1?x@utDP2n?U|JF{`y2F z1~LrM!aUL@&a22XwlkGLq~ML+q6~i?JjI5N<`{L(t%IIzYzk z_5>=Q+{lz~B|D_*@sH9#wIya#xfJtjJQNM2cei*0d&lK5&j4^VkjEfFK-Aph>tPEf zUmbu5YQ+PitPgtx&&%^_0IYF~o)&Sgnkggi3$IhQRs$&BUE*3An{k_;)e>P58t52I zDItH$a#=>LAvU@QDKVL!9cs>KsY2!c(Gm*lV^9LQk0Pr9_rKL%nje9`r2pXX{W}lo0mQ z%O45=3Gqf~Cb!3M4AB(W-rB}rHgU0@tSu#WOa?>&XvYKtLi;x=3{@f0+5x-_N5??k zvn72aVH1GVDr(Jn0Mw8-3!Wijs_ipG>(5e2wedh=`#)yuv(nLv2obCp2N?mNTuW%5 zSzLL$qZ+da01#Q6xXZILQw!3|%>OEY%0&P97wfK44C>yQc^?2=lp#r(9LFuvXMT-` zih;L2={7*D!_(ntay`I2qvV_Jvz@04oyhuCDCvtdzEkpFyk?467}H(2I5Q7Yy_*sG zVh8bB|1}Ex>hFy6BmMSRJRCtz{-yIHEb$g7F2kYDc{^1o$|b=GPCW6W<;c7~kvSqF zd{ubRbWz0t6RHa;Af<{;&E^oGoM1)0rRvSleH<+sB(z8P#&k65BB@cU>_HO%#zXzy z@Nshh05Be#3BbNv@kcOt)lyEFg{XS z>jX=u#bKBX(HI?RI$rI>5*rsRs^&EzV%7%v)=ebn)=K5es)k^4KvjkCC^@(h`4Rw1 z`XY_*l>8T+eiw6hlQx0{Uh9nA>n?Ks@(<;|bTn^Y=(>Rn4T+5#Z)?Jf=P}w)m;II2 z=P8>@XfA$3h-_7d!b$T0E(Sy~0KzQ`7enJz-y?o6TTFZ)&QlsI?nuSk(QdG|vKuaY zV1kM!--EXkY1<*GXzB@dy0{zU`zS&U(SUr%k)KTE9TwNZmLl~TAe4wEGZxEC#mS)^ z8?DIH6vXg&>xjF+_rBFGR{4=36^l`dp%#+akw`GZ<9yAbL=>mGq(cxD0Y31Ki^ojF z6oAxJ*l#H&weAK@x-ATeyob(_p$Rt5#BlDzlKu>JQ0JLG(3ss>2B)DgABXMZR@opjtdgH* zFfd^T+!%l0INf~mFfg6YM)*&xT+_)FuBN}jtiK)(hBO(rM`GrIUX@c_)yOl8j-ADMH=(K zK7S|%t?27Aj2N?0Jet8k!htA_R3us6j?YkFCU3=}?HU*ySV)a_?k>Xed{F@C0~wSf z*1^&MUSdU1=QSdl2EEQ}2*7E#cM_kMUY><$K)Snp2WAtA`PgY{^AZa46* zJ37NxjkJ|GuzlAa4Qzu>KP`EkN~Bz$jU3R>JusFA;3c=}9o+>S6a%p!($V8a3>@*% zVd1-YsQ{202=UeiW=ld(5KLrv!H?0Youq1j3nhJ##CPs7|AqJNky#P@nv;^gsCjR} z+n~{L_Z*UU(SCy&$?m)O-7REgKN*+r#~1WueK}!kH5&&Ywbj9h9AO*~kwV9m4gZ-_ zEjbheVQi-*=If3ujB?Xkmf)M$syBFx0uXluGsR-mys=4%A|^0bV>qYdlSpz>w4Evj zt|K}2=Efg-P2*RPBF-{c{Fe-=VsK~%-D z=@=EQN2kNH_d#u-l$7Z??TcpfUmOI*L9F@Cxft_xSZvbat`KaKM zMFUD+`8^Cm#rx!vP=b&XG?~OAi#O?=)JTGq&o*C|i}1_=D1l$#1^{62uPh)Ds3f5) zeV#`{ybw6_RCJFmg-E5P84MJGQt=B^z*Qb)-0GnY-%d*`Evig6#%uC{Hd6%^VA9a~ zn@f<=`x!K}lxW3z2^ZJ^7&^QW_+`QbzKvO?IRJ_2Q0 z%+)P0DxrPx(3i8PUE^}J@wbIWYVjSw)X-F0Ho2IM01# z5f#5N{}&jTDUBXkb5r_n>UOoB{=|BE>$C|T05ZFJetG3LnxR3Y>UP|tKDrI3gMk=3 zAzO>_0(itZQ(%y}X=b|x%jok?GgXL!oFq9nnVK^m5)7P;z(+~-E{rPfrB8CeKr!l&M}UIi5~TN2QY9!%a6TFg66}N0>s)XaET|jPFC^6ehPI{F0}v(1=U^x02cWQ_hZ-W z-E!?m=>x^U)xA0E*c)~-3nP8Mbglrzvh%G2v{MuV#hfPElbQunSjV+K4e0OeU<;nt z333u_XTB$SRvXaXl*-FmpHcJ0tzQkTxv~fvxFp7Ls0t5f?>H|sr)MhJ7Y~y7PV7a3 z=WoGN3*_-$91FaLaER$_VM07PE$NHm3(H-jibfY8BEkBqzZQl90MRP)iY)vwUtC|% z*w~zQ)-(CqFvA3OW8-Ndf}z4HULOOBIvhXKEsWeWmPRy}?=2}!A2^_F$1@reg5mlY zybRZW81&zVrwB%T4JR!mD9(&u53dl!HFMTYB@tGh7}Juf<7)(b{1KiFF)sYW!2XfJ zEKP~6Uj?#J5I3e_988vR`NpI0WHcI%u7|%5JMB}f!Nj%)N@wrVss+iZ-J&B2(CB>j zdj)-04IrYj&7Mi}|1) zS1~EW>AzrpaI81e_)a*LGa`E9$FSiG`QIiQAjj%~khz6;^$A<6Pny>gGS;W!1XYCW ze2@7C{D_DBkMNWFOnKcuGY9G)L{o9d&%QPxXbA( zxewLS!bp>M6(sL`>+=zLVAnj>Lf;gjFY+z_Md7Mp8b~8A6fx(r2@DQ`$SzAlGm+_h z!9?g$(?T+|n!`XFPEc%WSW<;fGZ@q`-dk5T)mv6r)Y|#|%^oE2oqLl1Vu%U!5j~1y z$t^Rx7XWn&`hq;s2MIP837KGx`zRmvqx$&y=YrjghK80QZYFG z0gFb0)&%{)ZOO~Zen}it<7frS8~KVfQw5QM+0Nxk^m#MKM&p^eoypYu@H(e_@YU#9 zHJYgc4HJl;7*~{m%-f>NdweyjOm8@gTC6~+3Pc+=#1K)=5I&pb(l=}VY89;343iLX zhAd!q0~r~=*2rDVly_RXUj^si(!*)MQJKoC`Xp^&rZMQ5cQgG|&lQ0AG10cqG|>g!)3ijSgM9rqxqKf^}Mw$+8ZvR?&u} zAS@>oWd@Q&YuQ)xX~Y+?7?A)FFdqS60l6HD0l=#WNo2@=1Tg5nV*U^HDA$nP*{nsa z@D~8YFfvv^+-6Az0`}b2ZGN&8U}?Z@hIIZc1CYNjS4rMyl+GT}cJ{8sAT5r&v};8mpKwRn zMMW7_g?k0|tUCw4r zIvXW<*f*tzfa3b@$>HCh*u0f=`yXOHRl)#)Z?(3FYuLVjdKj>QPR<*d(4Yg2X%nyP zL|Y3G0Iw*3#L7!-1A>s*QFuReMz52VK@H6%;|c)J3kS768#WW+@YOwCB!f$py7+n> z0KNd`6OKk5$V9hrO6R#9LLC6>D)dLb^Dhd&3gA!PcB+8Wl9zQfSQt#%zDVOcCI5wr zDHeBTwp*Y}7K_aLeeKqA@m$asjnAi+nhI1!8<7~;qcQfZ7=(87twgDyG;-TgrL$$L zwq$Grai+B4JejFZD5wCet>~J>Rxs_!52+i}f=UB1N&xJJwk(=8Y$h0-_&`dvQDrKK z_1R267uV;iCGLS6xMoZRwnT^Ns0*RZZHGztoUzml28jd_7hv>7z8JY%J@48O1{B=n zxRprtcRj?lVi9&4U!TtWHiJRF)kNK&n1~|CcVbqR1Y5CeOORVQn|pTl|Lf$<=x)1C>?5nzJvK8p7+$`Q&+r0?;lrrcW?2 zbF$|2LlIzxLGj6g*WyKrYuWJ8awK#Eg``80hgu4LQBP20`QQ zGX0Ti<6ITIa?7O8$pKgfb$=HC4v<7v4qE7u9O#J?f~%-<_9nG-_*F9)SSyyWjp4;5 z_U8~opo~Gq;>+@QB#rNs{1>dsGDq|F1!AFlh6CJ<>=-ao#^AdmF-!%b>l2yw1ty^| z>RKmOsl|lD)Ej0d;W|k*3@?#Kqj9G_6xT)en=>62tX~C6s_-#eAFGNMgA@`}s~0?6 zxN#i>g z{<88#F=VAXVdRUBzg5)Fx|fLj;e1I9{G4Em&j~ylNbVEObdeK_OJ-c5Bxz+EVd4_G z&~*_KL60d~F*!CcMb6|9ybu6s9N!s|6T#47OpZq5%rxbj;F8UcWUNRw)ARLn&#{tD zwsypx)5SyE3Ra{cIjwB_p@E=y6ZgLCU^^y~ObGmC67s|iU3J}>0zj!qjDt8*>>}cm z6X+#7D9-l}iC7d+Pyn_aHkZa}xI3Y<{FJ!lZ|nIcI?#- z8f}3H6Xdm)IVf(>H3wPfi$?vOo-c>#rJ*ovvzdxmk{Y}~BYrATyv5$N=9BzwB{D1< z8RJsZh;4&Ef)IZ3Z`MXA>vPH1^gAzffHTAhd>r|cM>>Di1O~A3l=~a9r<(=z+la6? z=Du??X2unRWPdl%41OPEwvr9&>`UD&P9ABxcsZ52C;-c|Di|OX(u<97aWB#+n)^x% z1pqcW44kq&d_tLusMvK1vH(C!#fMRu=?nAzHp2yF0y<729|z=?%u@$o+s3LAe(PgU z(icg5=RL`Paa#~%Fmbpoe>XR=J(PCt`ZrG}>Wlk`@9a0U-!hxK;(&5CI4tGDlSnAv zk?^)AxGIsTp+TS2oE5b+Zb%Q2p@7*x(IuF3J<&}MbDLbR&n2OOqaZZcCLwkr4mk{z zTIn|1&0s*r+p#0kis)rFJ`T0Ll~xQzfn3F*Y-4g%LV^nb+M6yLWO8 zx)}_j#8+VuEe?@}4}yU+V71@%X;9J^Nqpx$$$t?p(Ft6_iT{r&UHNkl=!?evog0or zluO!;(SeCjIV{Ef6-#$h2bW>0G;%Lk%O~sc0R~O@qb|=6nv}@RgIEjrF}zB!5VG4f z#9g1wR5%;TKyw*dq5qh6F|10u;%X0I6Bww+^;Q%k&_K>Xf$U}t1)3Su9b__W%7w;6 zHoNfxSM0T^0Aa!jc3B6sJ`Fe`>R?Pf?sYJ4ix^+Xty%9;o^iYO&=C9t@{4d7RL5BfvdAMg<0{MLE>3a?i!RjdXO zYdHS|08C$GQbgykj;U^CH|sz(fdQ6_aq@&kWXw!bB^w&4v?V&D2@L9Lx7huU0E3c! zk;Hf2ll&JOaMUAa_fU5^u&Kux^()yIadqez`c#e`BzPQEuZ$`I28|+s(G7cy6YT>^ zua|E$L1c8!N`>Myq=pn?_$z{lSv+)DskjL`ih+jui-*lqo@l73BrMUVTvSkTC;%PY z$AmpfLLKIV9w=BXr9{FbC;&iju2qn~uc3cAkH-FWk)t6Z3YEkYEgRvA+0O0~Zi=MY zf}G_;F~}i**&V?xeW6CBRNfXtq)}E8()v~4Jed-)q6+nxMZakggIU-{w9}I!fb`iy z=j#I~>5C-3^Pc3tpmEVd@~T(5uE|$7)#6vu7qxFL^Z->v<^@$&{2ND`o_Zi>_X0!Z8Fn~700x)`Vy@gVt~SCn zI)AK620TGJUrrNM$U|KA>Lb9Qq%V^A&U=#o;x(3hhp%pg8<-$qercSM;I#+GBM%#l z@1$0L4HV4DMe#1k_9f0Lpy{s#GL1reZxOd@LweHo%baF#pMXz zFx!!kvv*njtIwb>5D$LdJq`O0o8r>h7VY#6>~#p~w6-eiigY>0S^IP>Ds3zq6slTt zqqdgFWRwUr7n7T0TmK_N1lK-0U#zKe==3Q~osaUrt} zlnZmP7a+}4LFGSAgqYYc2xxkNsUlm^NE7S?y$100!~>vj6BtB#taP$I1|@xw#CP74 z{1<)fw-7pa`k{YkuC8DuI3CIEKeAHI;zy|Br}y`=45Gxuj+fziXVk^+78osILx%3) z72>x_2LWKhCXNP@YG9Kge2EDPjO5`CAgGFCeIirg2pQr2fQLdg4vl-HTWEKBllK9^ zLNgA4 zpgEwS`!GR~IqeU*4O{-m0A%;E#uv=|oPDUAWdkP7L7TmavmyW)HV}uZl^VG(?Lq;l zkLMv$LG|MxgRduQ>;J55mPqAGzQN+9INVk!{9kmvPfW}rW)AQi=Q>l z5v!RW1nKyxp)l(Q4DS$fg3)~kPOb4cmD(FD0&^c{~UBT&Rr2C3A07WtKN&1Qw(sEv$ZCUzMUsz7*jV>&*eo#4iY3hauBBiM1#{b<-n3;>9n7;^-$hbqW@ ztgyVOC4Oc3sxR&XfKK)^IWD39eK`8Pi|xv~gHyN*-(Z6>xf~!IZhCnpX@DFaG1v!y z8(FVkk>JL?m%XkR=`<2xn)#i_Q+3$)Vq zpf|plhn(t*;TzZ&51OfBoKLktT*1K3bz1c$Z3AqQeXd#|*X}^02p|Ui0z^C~h?n8K zbBeGf?CW>g>yCyPp|rV1r17o%uq6JiQ&7%*UifAB4g){kd(vO80Yr8li%5~J?*~6&yaMaCZ#Fs^nB9-#*%)A1CwMPRp3z+**t1$Pq`WMy*P_i%5_)g}(co|ku7b5OZCMbH)3dLu2D(KM>sJA8 z#tkDQGUA(F!a8t`nmWVih~qnC{YJih*f`wp^OLkr>ti6HMymJ|DlVvTK@i2j{1-AQ zV71^52y!hAyk(p!lF$L*KE1XY<)#y`_8pU(R|NBCfFcbf@&f^02?Dq>FxmU1vj{+I zp-vcErj=l&xK%lJA^-(V0EjHZKgS4YaFR-emFo@)M+Bg*A11_dw@=~Cn#%}4k!N9_ zc+G_gcJ+x-SnHAiQvlT=|H*6hr)B#hjqjBF7pGY14ARK@V%nhGy_D^??x1~fw?Y2} zMcr_Ks8dhmQhZDLhWpe6n0~K1ltvU&tV2>lGg+h^FoAWvCG`tE8_|5tj~2ViFj(yU(pvy^)a9zx$q`R)8#4lMRKEP zrJ_Pc#I!9iFm>@m0hj=ZlEG{+vVyB!+tQT9nP`>)=V%}thwg33))Eq3fPB_7##*ro zCV{(E63E!v3TLt7Qq~t~e5d5Un9v)1(H^}qCm1?j$wC4$EjEL^3M$9uBJ@SB zB?pMGAd&M#bw*JqSx}#n6e|WIqL42Hfs3#eWtF0e#{f_Y6ITEbCTq)BmnCX;9Bj&B z9ubnx1G9b=s57gKJkd~h zvQ5LyqE`bf$>`by205B6eNomINqpyh$$z2Fr%$~fzJSvcc^||ZSXmtPMU(k*NaPKb z&U8cqd8z9N@@N^6O+<_pnG*D_ya3;@OIHUc zWS(<6rwZqt{*ZGy&Vw>E1&|YjJV`4WXbwsfG{^y5`eJ2U$^~@6dKo?I9yu8S+mPN=9vO81?ip&xhzCQ z`VdDdl~TV4uW1|{t&af*_p;ky(v(Gz z=rBTz6I-U13_<{%h^o<}JRV8nJMVk`i_0OFkc{D&!9E+3)^ZkUrmw>;md#v_eE-y0 zFVBA_WA{HeIWoYuXfOcdgh;0qH#@7~ZiL(nk+tGPgYz;)R9?!Q2In@I6qGZRSUrm@ z9DMh&HFwPtit#?f-e?ms23#gjONyd-K9 z-WF#JZ{yN7!n4H1y3eFKi6a04wV4BbLLc7(hXPnE~dD(bU((&iz)woeR?Ysd3PAfG0#Fex zVm;$p0q9hqwGfe3v=7_4@~*ZUxoet0MNy%q09rnkffdz?JIRXLOTJ;wvFVq_DV@`B z05g!B{YWHDxu9%Jcma7!nGoeH2T?JYC20YoW_+%cv>dnx9!1%GOO^)#$JkfX=~nrr2o!ONLt*6>$na zxI}G#UBC890o0W25NC~UvMM-EOa20YMmKh**roVlGhsuPXsi4zE2Rkxn2B5jI4?tJ z?ODRK1hK4eIa3UzJ(_B?zB6qhcCI@++XekC>|qr^p^{<_hM8?5+Oq7KQ+)!#>uVx)}($lKSLp(o7Ys z2F$iaTwYKxGlkU>PmH04{GJmmvEddddMF0EiMo7kh8hO~HrCSa40eX8J*SvfrI{*- zj|Ui)aHk~9>CJK&yg&+yeC>HXOJ#a{H-fD4lf&S@DS)EOb7wn=@w_iNFz6IUY=0LE zmbia?P1?Au{!kb@KYxon;p6V*{(cig!dfZffJ1dfA{{&(j(V?Pv&r@vn!qzd24{*v zv@lveHOWQ;@wPDn%(+kEa3`NBq=_or-1#P3K5?Tv?&MIMcdc?!!jisePJMoY(=94QYtCxN%#YhX$FI={dBOpkc;{;v~}wcw4FtlCNRiT zb=j*53nK~gye~;GdV@QbP!~H9PCHnwDs8v6s1GqD`C&RiG<7(FhYp#++0;8<&^LCB zRZWjV2aR5H05e3{Q#(54o1pSR00u}h3?vi>EZ3Bxt=u_X(>8FIDoFA;JBM)CnWcP? zH(<}XK zuw=VV@gxJV$acXEG*>FklL6&uh9LC@%q3kVM-5;=8l13zOqg+|lB5MMAV{nNl|Gzm zdPd&!^sLL(1a{H=?UJjol{vVl$NF+mwlI+hJ3KHX|W z(r$$x$N)Q(C+Qu3QvC}WxZ^}$Pyp&mss1E?R{-dkGzE~}$$wD15&+nLT(i96sbY}c zDSnc_767RbD1h`%{)6Hb0IYWafD&x+GV=vCfk7VPvRCV4P*xaem?zUX|{`>yEUEWFV8j}sY)weg0MajBO6_aGGFIH zaW7L!^|OWU0)TSCr6DDIr{4pR zj&vr6NH6sp35nn110xl#6a(eq4LCu#!({+dJS_YebU`QxZaxc7lJ9Us4+VgPncN4~ zm*w;P#0oiyYurcZtk8%HmZ;M}vSi%|F~L+^JP&N*O$>MA{X7O|y|=@+eUuv>;glJw z;)?(fZ>9j8)4<@*XQS6LRb+Iy_Ft#m`XQK+^U3-Kn1!>IU`+Vex zfj4l?$IDN08Pi-;iMtAW6xYS7BLLLd3bQ^cY|}VVTxS7;plE9&`s4RV5;k{kIuA}| z9rBoMcN`m4(k>6f^Qxu>SPB5U1Vgxgwgz?|Lhs24lO2^kQ(P4Wo-GcqBivOohPe70 zPpC9Izz49OBl^A<)7 zAcv}+jt2kXJ#BiK8Gc1n*Jl&9TUZ%raO(@aCL7fFcd(c zcTM_HZLN5fVRo1ZfLmII9HZ$a0(5a0fW0FqiNo8bF@O-ww3Ld_C*_UW5&*k91dJO| zdoQYffx(~OyJFc^lx4O3b)HsCdttA8%30^)p+qd+UE=z$0HCBWcG5^sNrjP(`WB;2 z^A?8o?~eo#m=m-of?i>~nA*mb2r8Qj)fInYh zh~77O7J4jhUZ56AgFI)Jy80^sC@YLK(o=F_JXag~vOVd%#(d`7gBHg9MxCBJ;nTbK zY@>K7{$=>v^UdQQo@+mP&V63%k0#iJ%)#_BZDOZc?Srr@0R!qZH$L>X^=Kix<+pvKYa>HZ`03)t0xa09C4^1S9v^u0bav$t8K;)^95-y604Md zv*xOaDttTS`oak#q*_+YPiO!7z_;yyk(`NvXTPh2uCX%>K2QVv#{kPq-1I|@% zW!LGqat;9N9c3TJP7>+)K$2nfJFU>iTJg}wFMh_D;O$|KaesS%KWLWR;mA8vpaX@0 z#b=FgEGo5a#fR=G#JmF+Y5f7cDsrb-uDF7x! zP6(M(o6#5LpX7fPK;mR}AF#Q4%Q`Cm{m0PW3m7eZSz%!$k)98j4&!C`hQ>dG%T9-F zvA`J%SAP_SBrgLN-ds$_>Lv6}!8iHJt8(cRi#EJVXR5s{7&My6Ywbmf#OS`3=cRe_wy8LA7^ zA_suFQ?Q5yA38%KHxx@Zg>{EnAO%!WAC+%#!n@dAGO4>C!|MDoDG; ztt$+Y_Pzw&a<6^_L@XTA-3 zq%EPgD-dY{1J}B#iB_R=P35W%{nEvt0aNv5U_Pp|UU!V)@V|H8Pe$F|X?HXT;~uPG z+z(HugE#bkBc@iilP36##^Q^MY&X%% z;dn<@Az^?cZeZNlt?}t71|*O!G^J6(C49C@k}KYJkZS2SW=>4kn8wN(08~8>0DCVF zFze!5FxNv+08C{rX+1DGj+kmm13`Z}!m8DwgyB)v#AE3^X^4m>#YRIo!gkCPW;NkJ zqvlWyOhXCz?zZUg&(6FJ1e!26wxiU_gB;hAFbh z8Oj?*93&6Go`02)DilT%>G?qNVf^hmeHhpuanweJ1ms53g`t)3c$2dv53wc5pfRVX z^ld}{MbpOMsXIJxVoMGgjf(TmhWQxRfd&?(twgFGrqYEVq`8H-d~Wf~uml~=b3Q?~ z4x^~9Iq<8c)q)Rz!KYZ^5Or4P4%dq&$EUmZ(x(VDNFL%e5tRIcMXvw=D$5qz<~TsT zbBZJ#J^8(Qwb>m zS>l_*#rX_}clxFSfRR`@wxMNe^j!L;0x2CC(E`2vow)L;)pLp1c3F9^#PQJ zBuS*_1IdT6g2I4FaM6Ar_U|<%sxT|q1jM{>fhg0nnwaYoiH&8_yQI#|dM49Yr$abr z$Kf$qeZqzI$<&Ku*aQYx#xBdEvG37kAGEce#kBV)$b>WNNHNf6zd^Z_N}+$jqH_&) zM048UiuF<-lLDAkQ0=oT0L`?8S^_WhV0|u>6b7REVouKok`F@_#^p$Yje*w5ogc!F z2xF?-@f;Qg){?ZRubQY}KeE?;JkwkhvkbD@wV-xd$vB*Vlfb2DANLmEl z!F8iGNAn7UnOCL*mMvZUxYPTc%}oaG49A!)a7rXv&X}dz4&x3+-7-eA)TwR<)KsSl zD$_)H)E2y11Erwi&w9uMRzh>YqU&eydva(M=y=d|*BJi8%wT*g&dmJB=8Q-sL^>hL zgnoh49k9NjB-pHU+5`qj(Qh;a5p#rNmOvfM8<{JZ+5`qGRXu+6SHPgGFw#g*$%ny> z?&0dXY*{Jt+ zfm$S0YXSqy6_z98&Ao57!xzDScD})GF1XBox1ZvgudI)Ot)F{r2*BMHZcBt1ZcyPK zW1&6=eF=h@I|ug_1BQ=kgp~x&=3_Tzn=tEFA>qhMr&ky_8&@KqepGgPVhiPLNFw<# zux#TDEu5PM+eYIE1V8JIm;tQa>2wj2l{=s?Ao)%1t19-qY`@kL6N4Kub1Tua(OY&j z*nwr1jbXCBnXSY0QOl8eJfC^+)X#pBtB?Xfn50Hn9bw6t`bBp!DDun<-r{b;{g|KD z6*lSecD5wFS?6oYz}&EbzXmW)q6{q9W3t(B`F0lDyJ z6R`@dW$vxd#ZkaOlVGrT)}e|@%#d;KbKNODKZlFPclzaO1v6okcO_8q~ER3Cf&A6pQ5{^I?8GPiy_|^J?l7xnzcd{4^p2yH|TYbuV zT0?P|C=S>eC1&K{u5v;LN6&v>%8q}%;S{4StXzdU%3fQ)3Yb>Cn@p>obIeZfO?tc} zk=xV$B;d&_ByfXw^y$$z@=6mJ*r&o5xNFds;)v;)sX_iE_xSO zLTm4}!d6s_>$8bA&enOXc`V~oD8?*~Y1iG4d2-;&G1#%UZSxP&CbfhDXgjpT;Ij6P{wOMe`T#|OQ~(-FXMPL| zf3T}Gxh`fW3R4^ofW{u!%q|cjrQ81C`rQaypW#Nyd`xPi7`SNQBS4vqu<~T%{hh&Q zwE~(!PymeWlUU8m-ULnL5K|7l@IQmbnVa~F+;Ib=yyz)_4B*md0Dzo385>U!yOLck z0ImrP7AR)MD_0mml*<-I66uMkJ-qNw={>?fJKPi`;I}_Szg~ZEmSnH_I1EDrkyA3Y zcERKd&>EVAn~u*rG%s$H{h!KbtV;H^;WzIdry(5mHL)iEpgzk-N{Kk{p9Oy;&?~?x z2Jl&C3qVZOB(6=a21(qMIWPe5=eyg)_3TpMY>4B5d8|+xWXtkz-p!>8RMP&+@Uxnl zDu5hWmb(A|tAYveh6|5%KFmXGi;XHFD+V|3K1rn~lYwWMgt@o2z)t|Esa$1w<(o~= zpbT}HI~58eiS*o;d>H@K-QUAMZS&yp&oRc&+$80n>>^5mvL8xe7#gXlQe#wWiG&DB zY7zoKL2PQ@GnHSM5J z!Lap4`EEi~6$2NZjZl&J!zotrs~FtO@hszsGu4`C#5)1hTop|0#dE9PcNDKvXg7Br zrs^aq9;a4?C`f7aod}gLWG^V12n7JDY8Ic*Jz1XyB?|+-wK%Q1&wLo+pM&misvY2j zUEugo3PaH_4|`M-8LRfVsKli`!L!Jw|IY0l<7Czh&7D)r>Tgfme3oiIAplO520n#* zbFU_)#xIzG(HYJB=MG?L(q&*i0$IL`D))}6)B#H)AJ$LpEWhD`n1DHVE9_mFYRy^fVRaz)@GXXUcxpzU%)|M zJV0gLj7}aP-BssQnj0YC^t{)_ej0FxbhtfUe&BA9)@Rd8_yb4C4Wxx3J*fBxH~YQ8 z3?e4=xCV!+9y`HFalQqIp&po>z?SHkGR_ra59KGT!fpbqVn;QA zNe>a4iyaw&y`&1`-tS8Qh_g!x5g8-OBd+W_y#ukR!YRX`>gfXat{G^}O$wjRL~mqS zTIT?93@nqW&Js%q^^eO#lDkQy=f32_*w_+XA;iYqDyP)oFswgdVIZ&d z@Xe&LwIoQv>!rrHYBCi~o{mp69dezs&^DcyLr#grdFm)HUx_!t+;bRADoE z^26KGBL$!na>*oBrO-Lnx!(#4BZ>6fmwXuKNMepH0KwqyLIyM~4BPpvp^RJ5>xx6Z zSIcoJSFPNI5~)hBlXb41ZB~=7iK&u+PylAfxSS_~6V(}3f}L-PV%yExU<$ys+ip&~ zwYYxld`oQe+(!ulCMXVIuL^*S4(0&ZwHdEORA@@Yo@vI`;aY_hrzOvu03cpdmBWp2 zrdC;EY0kk&G03v1WBayP^IyX8XGtcMUwqfh97qK~ANQ9X?3E5l$u*5HlPz-S`hEt0 z`AHWA;L+{wr@gtS+do>q$;^@aOI(BCXc&Opbek+BP%kM<&D`%qGU2o+1qI;XR`{(@ z7)hk(zU0H`pR<35I>b*0KTvk9Sw+$5`9Rl_G@>wG+H4pD7*H-cc;9J2Qf!-ThwlD{ zyn((x6AI#aE!pab(;eVroIWcukMEZbrE*NQee-V4yP7c=8K`|_$x+3=qLKd@Pm`I} zjO7)KUZ2l4rRcmY649Dnq+lHlVxy{UZMnIX1WXfEn2e^~%-7HzVi>Z-(F6wQy0jI< z@fcR=V?H0K%(O8TO~nBH5rVrfF{T`wDZE3qZLHC3tr((I_4*A}L0fQ9=cYBWep8h* z`xL1)P^wTENu($C9l;Czb7XFz!oZIyjM|=zgn`1qe$tIEKKrLcIL%TRWLaKU2%oO4 zq$T82{iAHk6viGW3*vN4rZ6frLJ9!-B+KRnXfhpP)3PNcktjLz8;Sw6P#90)kMq1@ zwoWatYs@oq%(a4VhyA{UU^O9W(!aYf)M%XgR%1krB&gFkbqXgj#}n2pa|#U5-c^Vt z9Y4k<{g$ER@6f{7ZPe*0qUvZsF>>I@Jw#>6DrGe5v(d-vYR?QOr7~Na&KMrrmg~o1 zBpKt1*JNLEz-K=aq1AsNB&tF2;XA$5O z58s68#T~@6RrO6xNSbiLg+LZgkq_cd$~Kx+;u)26U9Dai5wYeCF{V`PqYi(ecMCV_ zNZAY#tMLy`zt5|P=j?2Phz@JD-;V%;vePq-^pt!U=b|WDFfrt0rgcF&lzbR}{^BzX z=4{OYRXf`jM4dm-HdN}{U&Zk9hox~}1AUv!lDNLLAPN?5eO!Kw#hZnmS_Op6GWF6hJ%VL>`LNa~s=6z-y5Q!!+5ECJ;&nE#OP@v0meM0FVD9<)7*OkG69&ObFcH)_Du~M$89?Q;OfJ2E?aA(77d>h=4Xaj$uhZ_1xCAym z6hH>Pg@=^87QE~Tp6axi4KD=MH*%*SuL{6s!gQ|d=FU?a&ai*C85o=U0<6LT02+H1 z8_c32W`Gof0@P(L0YG?w6@Y_oe`_p*IfNc1*DX3$Z8Hd+P)rMG0)s!>RHYNkHRCFYS&Prv=hJ*L)9(GI>07~SdZQ!Pbw5f8tEzdFpNYT zrL)l>I7%1q*h;KYF|;stvFN!M;5235rWVGkDKVNLlDe8?)r)sVTC0WHT{9SD^pmhK z@8;C`5j#4)gcPH4QaQ~;L?AQ*q|d~z^b%-e1M)$y z6nCfq)TW5BIATw{xb>@>m|x4(eKj%>1DnC%qSdyz%MnwGQBAiqh1rydW)X}6DBfM- z8UUa)$v;2LELR03^qtvio53Io53xvApJmFFjOJU`DhpHcOcfIDC-rc&#MCaK?l%+zvP=4Ok790lPC2=2;dzy*L9!~8ytZN! zY=89#1I?5ma4SnfKqEp1z;RmgS0X)+M{f`CosEsLc*zEfotCzUNb(Bc>tjIAhhT6> zB#?VWufEZ%UA@BmJ&(J3g$exZ00w({8#~qWxTjZ7_3FM}{hMAr(5r8A0Lls@iS&FZ z`7rwD<2EwRVfyQBSH~ngv%F^+F7b>Cqv^FIjsqH8eo7&W(k@IaM0CuaC+1?7SRVRq zPw5m|zfY7wgnq6{6rsIqplpxr5!c#m^M0SwNu)3`%ra>c$lY z7#x=sMiS}yQ1W5C?RDQ_Ba($_ONEgO4PVn&^#>C1Lz<#Pjrdq^x)4rH@EJM3F4}Lp zEE;7d-Rlw>XPB}c3RW;){eLN#c}i_%g8LgRI0c1os};WwtTSLYuWN3?JyWcn(_Eu+EB2Tu_N z!w8s!8dC{D$c3ci+plCD2=C%msf45^h#IO|uTtT2*D&xeu^1FNw?Q|6Ps zRUCaJb;(YlFfdCZt5s8{=c;Ld#SpxuRF;-X4?PHs9v)T?&TSZ;AC%J;utSOTLUu#> z741f)R{3Th&7MvfP__X0VSnVAD}pTAKGl~xRP!(|V75ySz6sU>7PFW3=aphPl!-$wb1>`R%9qh9fDE*LmDF+GsRHmZAl~+J zsTf#x2D{~6bqubvA)aC2bIDl9WGp2B>&F~?bi}8vqr$>SB0V2UK8$ZpuopA83D@nS zHMixAs?ox@kCDTr&yvh|cY#N!qr@0;x9OJk?g)DaQ)BKNgbU)|Z`=eJ`vCcV6AoL6 zl*?$8raHno{>iugMd8-~e66{)ZU=0gp)sR~Wb6##M@+M9RfTjafCAKIE&%|$yE3-b zSGOxQZgj^TODL;r5bA)IF@UCJmnJ*G-V0kG9W#FFnF)B>man~hSqFQu`@kTw5h_Pi zziO4p#+@|c{uu04jv9QeLdIU$QCY^rZ0l`{wXI-7nFfnt9^djR$b$M!kc<82%_Eq2 zSSes4ku4OcK%@x_VC#}mN0Hz8sVlMjGjfd>B#YRy?@^&;*-SB!2wtiVIgbody (find IF found exit THEN false ; -10 -11 3 &27 thru Onlyforth savesystem meta.com -12 -13 cr .( Metacompiler saved as META.COM ) -14 -15 -Screen 2 not modified - 0 \ Predefinitions loadscreen ks 30 apr 88 - 1 - 2 &28 load - 3 - 4 cr .( Predefinitions geladen ...) cr - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ Target header pointers ks 29 jun 87 - 1 - 2 Variable tfile tfile off \ handle of target file - 3 Variable tdp tdp off \ target dp - 4 Variable displace displace off \ diplacement of code - 5 Variable ?thead ?thead off \ for headerless code - 6 Variable tlast tlast off \ last name in target - 7 Variable glast' glast' off \ acf of latest ghost - 8 Variable tdoes> tdoes> off \ code addr of last does - 9 Variable tdodo tdodo off \ location of dodo -10 Variable >in: >in: off \ last :-def -11 Variable tvoc tvoc off \ -12 Variable tvoc-link tvoc-link off \ voc-link in target -13 Variable tnext-link tnext-link off \ link for tracer -14 -15 -Screen 4 not modified - 0 \ Target header pointers ks 10 okt 87 - 1 - 2 : there ( -- taddr ) tdp @ ; - 3 - 4 : new pushfile makefile isfile@ tfile ! - 5 tvoc-link off tnext-link off - 6 $100 tdp ! $100 displace ! ; - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ Ghost-creating ks 07 dez 87 - 1 - 2 0 | Constant 0 | Constant - 3 - 4 | Create gname $21 allot - 5 - 6 | : >heap ( from quan -- ) \ heap over - 1 and + \ align - 7 dup hallot heap swap cmove ; - 8 - 9 : symbolic ( string -- cfa.ghost ) -10 count dup 1 $1F uwithin not Abort" invalid Gname" -11 gname place BL gname append align here >r makeview , -12 state @ IF context ELSE current THEN @ @ dup @ , -13 gname count under here place 1+ allot align -14 here r@ - , 0 , 0 , r@ here over - >heap -15 heap 2+ rot ! r> dp ! heap + ; -Screen 6 not modified - 0 \ ghost words ks 07 dez 87 - 1 - 2 : gfind ( string -- cfa tf / string ff ) - 3 >r 1 r@ c+! r@ find -1 r> c+! ; - 4 - 5 : ghost ( -- cfa ) name gfind ?exit symbolic ; - 6 - 7 : gdoes> ( cfa.ghost -- cfa.does ) - 8 4 + dup @ IF @ exit THEN - 9 here , 0 , dup 4 >heap -10 dp ! heap swap ! heap ; -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ ghost utilities ks 29 jun 87 - 1 - 2 : g' ( -- acf ) name gfind 0= Abort" ?T?" ; - 3 - 4 : '. g' dup @ case? - 5 IF ." forw" ELSE - Abort" ??" ." res" THEN - 6 2+ dup @ 5 u.r 2+ @ ?dup - 7 IF dup @ case? - 8 IF ." fdef" ELSE - Abort" ??" ." rdef" THEN - 9 2+ @ 5 u.r THEN ; -10 -11 ' ' Alias h' -12 -13 -14 -15 -Screen 8 not modified - 0 \ .unresolved ks 29 jun 87 - 1 - 2 | : forward? ( cfa -- cfa / exit&true ) - 3 dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; - 4 - 5 | : unresolved? ( addr -- f ) 2+ - 6 dup count $1F and + 1- c@ bl = - 7 IF name> forward? 4+ @ dup IF forward? THEN - 8 THEN drop false ; - 9 -10 | : unresolved-words ( thread -- ) -11 BEGIN @ ?dup WHILE dup unresolved? -12 IF dup 2+ .name ?cr THEN REPEAT ; -13 -14 : .unresolved voc-link @ -15 BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; -Screen 9 not modified - 0 \ Extending Vocabularys for Target-Compilation ks 29 jun 87 - 1 - 2 Vocabulary Ttools - 3 Vocabulary Defining - 4 - 5 : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; - 6 - 7 Vocabulary Transient tvoc off - 8 - 9 Root definitions -10 -11 : T Transient ; immediate -12 : H Forth ; immediate -13 : D Defining ; immediate -14 -15 Forth definitions -Screen 10 not modified - 0 \ Image and byteorder ks 02 jul 87 - 1 - 2 | Code >byte ( 16b -- 8b- 8b+ ) A A xor - 3 D- A- xchg D+ D- xchg A push Next end-code - 4 - 5 | Code byte> ( 8b- 8b+ -- 16b ) - 6 A pop D- D+ mov A- D- xchg Next end-code - 7 - 8 | : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; - 9 -10 Transient definitions -11 -12 : c@ ( addr -- 8b ) [ Dos ] -13 >target file@ dup 0< Abort" nie abgespeichert" ; -14 -15 : c! ( 8b addr -- ) [ Dos ] >target file! ; -Screen 11 not modified - 0 \ Transient primitives ks 09 jul 87 - 1 : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; - 2 : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; - 3 - 4 : cmove ( from.mem to.target quan -- ) [ Dos ] - 5 >r >target fseek ds@ swap r> tfile @ lfputs ; - 6 \ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; - 7 - 8 : here ( -- taddr ) H tdp @ ; - 9 : here! ( taddr -- ) H tdp ! ; -10 : allot ( n -- ) H tdp +! ; -11 : c, ( 8b -- ) T here c! 1 allot H ; -12 : , ( 16b -- ) T here ! 2 allot H ; -13 : align ( -- ) H ; immediate -14 : even ( addr1 -- addr2 ) H ; immediate -15 : halign H ; immediate -Screen 12 not modified - 0 \ Transient primitives ks 29 jun 87 - 1 - 2 : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; - 3 - 4 : ," H here ," here over dp ! - 5 over - T here swap dup allot cmove H ; - 6 - 7 : fill ( addr quan 8b -- ) H - 8 -rot bounds ?DO dup I T c! H LOOP drop ; - 9 : erase ( addr quan -- ) H 0 T fill H ; -10 : blank ( addr quan -- ) H bl T fill H ; -11 -12 : move-threads H tvoc @ tvoc-link @ -13 BEGIN over ?dup -14 WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT -15 Error" some undef. Target-Vocs left" drop ; -Screen 13 not modified - 0 \ Resolving ks 29 jun 87 - 1 Forth definitions - 2 - 3 : resolve ( cfa.ghost cfa.target -- ) over dup @ = - 4 IF space dup >name .name ." exists " ?cr - 5 2+ ! drop exit THEN >r >r 2+ @ ?dup - 6 IF BEGIN dup T @ H 2dup = Abort" resolve loop" - 7 r@ rot T ! H ?dup 0= UNTIL - 8 THEN r> r> over ! 2+ ! ; - 9 -10 : resdoes> ( acf.ghost acf.target -- ) swap gdoes> -11 dup @ = IF 2+ ! exit THEN swap resolve ; -12 -13 here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! -14 here 2+ 0 ] Does> @ T , H ; ' >body ! -15 -Screen 14 not modified - 0 \ compiling names into targ. ks 10 okt 87 - 1 - 2 | : tlatest ( -- addr ) current @ 6 + ; - 3 - 4 : (theader ?thead @ IF 1 ?thead +! exit THEN - 5 >in @ bl word swap >in ! dup count upper - 6 dup c@ 1 $20 uwithin not Abort" inval. Tname" - 7 blk @ $8400 or T align , H - 8 there tlatest @ T , H tlatest ! there tlast ! - 9 there over c@ 1+ dup T allot cmove align H ; -10 -11 : theader tlast off -12 (theader ghost dup glast' ! there resolve ; -13 -14 -15 -Screen 15 not modified - 0 \ prebuild defining words ks 29 jun 87 - 1 - 2 | : (prebuild >in @ Create >in ! - 3 r> dup 2+ >r @ here 2- ! ; - 4 - 5 | : tpfa, there , ; - 6 - 7 : prebuild ( addr check# -- check# ) 0 ?pairs - 8 dup IF compile (prebuild dup , THEN - 9 compile theader ghost gdoes> , -10 IF compile tpfa, THEN 0 ; immediate -11 -12 : dummy 0 ; -13 -14 : DO> [compile] Does> here 3 - compile @ 0 ] ; -15 -Screen 16 not modified - 0 \ Constructing defining words in Host kks 07 dez 87 - 1 - 2 | : defcomp ( string -- ) dup ['] Defining search ?dup - 3 IF 0> IF nip execute exit THEN drop dup THEN - 4 find ?dup IF 0< IF nip , exit THEN THEN - 5 drop ['] Forth search ?dup - 6 IF 0< IF , exit THEN execute exit THEN - 7 number? ?dup 0= Abort" ?" - 8 0> IF swap [compile] Literal THEN [compile] Literal ; - 9 -10 | : definter ( string -- ) dup ['] Defining search ?dup -11 IF 0< IF nip execute exit THEN THEN drop -12 find ?dup IF 1 and 0= Abort" compile only" execute exit -13 THEN number? 0= Error" ?" ; -14 -15 -Screen 17 not modified - 0 \ Constructing defining words in Host ks 22 dez 87 - 1 - 2 | : (;tcode r> @ tlast @ T count + ! H ; - 3 - 4 Defining definitions - 5 - 6 : ] H ] ['] defcomp Is parser ; - 7 - 8 : [ H [compile] [ ['] definter Is parser ; immediate - 9 -10 : ; H [compile] ; [compile] \\ ; immediate -11 -12 : Does> H compile (;tcode tdoes> @ , -13 [compile] ; -2 allot [compile] \\ ; immediate -14 D ' Does> Alias ;Code immediate H -15 -Screen 18 not modified - 0 \ reinterpreting defining words ks 22 dez 87 - 1 Forth definitions - 2 - 3 : ?reinterpret ( f -- ) 0=exit - 4 state @ >r >in @ >r adr parser @ >r - 5 >in: @ >in ! : D ] H interpret - 6 r> Is parser r> >in ! r> state ! ; - 7 - 8 : undefined? ( -- f ) glast' @ 4+ @ 0= ; - 9 -10 | : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN -11 dup T c@ rot or swap c! H ; -12 -13 | : nfa? ( acf alf -- anf / acf ff ) -14 BEGIN dup WHILE 2dup 2+ T count $1F and + even H = -15 IF 2+ nip exit THEN T @ H REPEAT ; -Screen 19 not modified - 0 \ the 8086 Assembler ks 29 jun 87 - 1 - 2 | Create relocate ] T c, , here ! c! H [ - 3 - 4 Transient definitions - 5 - 6 : Assembler H [ Assembler ] relocate >codes ! Assembler ; - 7 - 8 : >label ( 16b -- ) H >in @ name gfind rot >in ! - 9 IF over resolve dup THEN drop Constant ; -10 -11 : Label T here >label Assembler H ; -12 -13 : Code H theader T here 2+ , Assembler H ; -14 -15 -Screen 20 not modified - 0 ( Transient primitives ks 17 dec 83 ) - 1 - 2 ' exit Alias exit ' load Alias load - 3 ' / Alias / ' thru Alias thru - 4 ' swap Alias swap ' * Alias * - 5 ' dup Alias dup ' drop Alias drop - 6 ' /mod Alias /mod ' rot Alias rot - 7 ' -rot Alias -rot ' over Alias over - 8 ' 2* Alias 2* ' + Alias + - 9 ' - Alias - ' 1+ Alias 1+ -10 ' 2+ Alias 2+ ' 1- Alias 1- -11 ' 2- Alias 2- ' negate Alias negate -12 ' 2swap Alias 2swap ' 2dup Alias 2dup -13 -14 -15 -Screen 21 not modified - 0 \ Transient primitives kks 29 jun 87 - 1 - 2 ' also Alias also ' words Alias words - 3 ' definitions Alias definitions ' hex Alias hex - 4 ' decimal Alias decimal ' ( Alias ( immediate - 5 ' \ Alias \ immediate ' \\ Alias \\ immediate - 6 ' .( Alias .( immediate ' [ Alias [ immediate - 7 ' cr Alias cr - 8 ' end-code Alias end-code ' Transient Alias Transient - 9 ' +thru Alias +thru ' +load Alias +load -10 ' .s Alias .s -11 -12 Tools ' trace Alias trace immediate -13 -14 -15 -Screen 22 not modified - 0 \ immediate words and branch primitives ks 29 jun 87 - 1 - 2 : >mark ( -- addr ) T here 0 , H ; - 3 : >resolve ( addr -- ) T here over - swap ! H ; - 4 : name ks 29 jun 87 - 1 - 2 : ' ( -- acf ) H g' dup @ - - 3 IF Error" undefined" THEN 2+ @ ; - 4 - 5 : compile H ghost , ; immediate restrict - 6 - 7 : >name ( acf -- anf / ff ) H tvoc - 8 BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN - 9 swap REPEAT nip ; -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 \ >name Alias ks 29 jun 87 - 1 - 2 : >body ( acf -- apf ) H 2+ ; - 3 - 4 : Alias ( n -- ) H tlast off - 5 (theader ghost over resolve T , H $20 flag! ; - 6 - 7 : on ( addr -- ) H true swap T ! H ; - 8 : off ( addr -- ) H false swap T ! H ; - 9 -10 -11 -12 -13 -14 -15 -Screen 25 not modified - 0 \ Target tools ks 9 sep 86 - 1 Onlyforth - 2 - 3 | : .tfield ( taddr len quan -) >r under Pad swap - 4 bounds ?DO dup T c@ I H c! 1+ LOOP drop - 5 Pad over type r> swap - 0 max spaces ; - 6 - 7 ' view Alias hview - 8 - 9 Ttools also definitions -10 -11 | : ?: ( addr -- addr ) dup 4 u.r ." :" ; -12 | : @? ( addr -- addr ) dup T @ H 6 u.r ; -13 | : c? ( addr -- addr ) dup T c@ H 3 .r ; -14 -15 -Screen 26 not modified - 0 \ Ttools for decompiling ks 9 sep 86 - 1 - 2 : s ( addr -- addr+ ) ?: space c? 4 spaces - 3 T count 2dup + even -rot 18 .tfield ; - 4 - 5 : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H - 6 ?dup IF T count H ELSE 0 0 THEN - 7 $1F and $18 .tfield 2+ ; - 8 - 9 : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces -10 swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; -11 -12 : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; -13 -14 : c ( addr -- addr+1 ) 1 d 15 spaces ; -15 -Screen 27 not modified - 0 \ Tools for decompiling ks 29 jun 87 - 1 - 2 : b ( addr -- addr+2 ) ?: @? dup T @ H - 3 over + 6 u.r 2+ 14 spaces ; - 4 - 5 : dump ( addr n -- ) - 6 bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; - 7 - 8 : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; - 9 -10 -11 -12 -13 -14 -15 -Screen 28 not modified - 0 \ Predefinitions loadscreen ks 29 jun 87 - 1 Onlyforth - 2 - 3 : clear H true Abort" There are ghosts" ; - 4 - 5 - 6 1 $B +thru - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 29 not modified - 0 \ Literal ['] ?" ." " ks 29 jun 87 - 1 Transient definitions Forth - 2 - 3 : Literal ( n -- ) H dup $FF00 and - 4 IF T compile lit , H exit THEN T compile clit c, H ; - 5 immediate - 6 - 7 : Ascii H bl word 1+ c@ state @ 0=exit - 8 T [compile] Literal H ; immediate - 9 -10 : ['] T compile lit H ; immediate -11 : ." T compile (." ," align H ; immediate -12 : " T compile (" ," align H ; immediate -13 -14 -15 -Screen 30 not modified - 0 \ Target compilation ] ks 07 dez 87 - 1 Forth definitions - 2 - 3 | : tcompile ( string -- ) dup find ?dup - 4 IF 0> IF nip execute exit THEN THEN - 5 drop gfind IF execute exit THEN number? ?dup - 6 IF 0> IF swap T [compile] Literal THEN - 7 [compile] Literal H exit THEN - 8 symbolic execute ; - 9 -10 Transient definitions -11 -12 : ] H ] ['] tcompile Is parser ; -13 -14 -15 -Screen 31 not modified - 0 \ Target conditionals ks 10 sep 86 - 1 - 2 : IF T compile ?branch >mark H 1 ; immediate restrict - 3 : THEN abs 1 ?pairs T >resolve H ; immediate restrict - 4 : ELSE 1 ?pairs T compile branch >mark - 5 swap >resolve H -1 ; immediate restrict - 6 - 7 : BEGIN T mark H -2 2swap ; - 9 immediate restrict -10 -11 | : (repeat 2 ?pairs T resolve H REPEAT ; -13 -14 : UNTIL T compile ?branch (repeat H ; immediate restrict -15 : REPEAT T compile branch (repeat H ; immediate restrict -Screen 32 not modified - 0 \ Target conditionals Abort" etc. ks 09 feb 88 - 1 - 2 : DO T compile (do >mark H 3 ; immediate restrict - 3 : ?DO T compile (?do >mark H 3 ; immediate restrict - 4 : LOOP 3 ?pairs T compile (loop - 5 compile endloop >resolve H ; immediate restrict - 6 : +LOOP 3 ?pairs T compile (+loop - 7 compile endloop >resolve H ; immediate restrict - 8 - 9 : Abort" T compile (abort" ," align H ; immediate restrict -10 : Error" T compile (error" ," align H ; immediate restrict -11 -12 -13 -14 -15 -Screen 33 not modified - 0 \ Target does> ;code ks 29 jun 87 - 1 - 2 | : dodoes> T compile (;code - 3 H glast' @ there resdoes> there tdoes> ! ; - 4 - 5 : Does> H undefined? T dodoes> - 6 $E9 c, H tdodo @ there - 2- T , - 7 H ?reinterpret ; immediate restrict - 8 - 9 : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret -10 T [compile] [ Assembler H ; immediate restrict -11 -12 -13 -14 -15 -Screen 34 not modified - 0 \ User ks 09 jul 87 - 1 Forth definitions - 2 - 3 Variable torigin torigin off \ cold boot vector - 4 Variable tudp tudp off \ user variable counter - 5 : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; - 6 - 7 Transient definitions Forth - 8 - 9 : origin! ( taddr -- ) H torigin ! tudp off ; -10 : uallot ( n -- offset ) H tudp @ swap tudp +! ; -11 -12 DO> >user ; -13 : User T prebuild User 2 uallot c, H ; -14 -15 -Screen 35 not modified - 0 \ Variable Constant Create ks 01 okt 87 - 1 - 2 DO> ; - 3 : Variable T prebuild Create 2 allot H ; - 4 - 5 DO> T @ H ; - 6 : Constant T prebuild Constant , H ; - 7 - 8 DO> ; - 9 : Create T prebuild Create H ; -10 -11 : Create: T Create ] H end-code 0 ; -12 -13 -14 -15 -Screen 36 not modified - 0 \ Defer Is Vocabulary ks 29 jun 87 - 1 - 2 DO> ; - 3 : Defer T prebuild Defer 2 allot ; - 4 : Is T ' >body H state @ - 5 IF T compile (is , H exit THEN T ! H ; immediate - 6 - 7 dummy - 8 : Vocabulary H >in @ Vocabulary >in ! - 9 T prebuild Vocabulary 0 , 0 , -10 H there tvoc-link @ T , H tvoc-link ! ; -11 -12 -13 -14 -15 -Screen 37 not modified - 0 \ File ks 19 m„r 88 - 1 Forth definitions - 2 - 3 Variable tfile-link tfile-link off - 4 Variable tfileno tfileno off - 5 &45 Constant tb/fcb - 6 - 7 Transient definitions Forth - 8 - 9 dummy -10 : File T prebuild File here tb/fcb 0 fill -11 here H tfile-link @ T , H tfile-link ! -12 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , -13 here dup >r 1+ tb/fcb &13 - allot H tlast @ -14 T count dup r> c! -15 H bounds ?DO I T c@ over c! H 1+ LOOP drop ; -Screen 38 not modified - 0 \ : ; compile Host [compile] ks 29 jun 87 - 1 - 2 dummy - 3 : : H >in @ >in: ! T prebuild : ] H end-code 0 ; - 4 - 5 : ; 0 ?pairs T compile unnest - 6 [compile] [ H ; immediate restrict - 7 - 8 : compile T compile compile H ; immediate restrict - 9 -10 : Host H Onlyforth ; -11 -12 : Compiler H Onlyforth Transient also definitions ; -13 -14 : [compile] H ghost execute ; immediate restrict -15 -Screen 39 not modified - 0 \ Target ks 29 jun 87 - 1 - 2 Onlyforth - 3 - 4 : Target H vp off Transient also definitions ; - 5 - 6 Transient definitions - 7 - 8 ghost c, drop - 9 -10 -11 -12 -13 -14 -15 -Screen 40 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 41 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 42 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 43 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 44 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 45 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 46 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 47 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 48 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 49 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 50 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 51 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 52 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/meta.fth b/sources/msdos/meta.fth new file mode 100644 index 0000000..caa6811 --- /dev/null +++ b/sources/msdos/meta.fth @@ -0,0 +1,901 @@ +\ *** Block No. 0 Hexblock 0 + + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Target compiler loadscr ks cas 09jun20 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + : c+! ( 8b addr -- ) dup c@ rot + swap c! ; + + ' find $22 + @ Alias found + + : search ( string 'vocab -- acf n / string ff ) + dup @ [ ' Forth @ ] Literal - Abort" no vocabulary" + >body (find IF found exit THEN false ; + + 3 &27 thru Onlyforth savesystem meta.com + +cr .( Metacompiler saved as META.COM ) + + +\ *** Block No. 2 Hexblock 2 +\ Predefinitions loadscreen ks 30 apr 88 + + &28 load + +cr .( Predefinitions geladen ...) cr + + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ Target header pointers ks 29 jun 87 + + Variable tfile tfile off \ handle of target file + Variable tdp tdp off \ target dp + Variable displace displace off \ diplacement of code + Variable ?thead ?thead off \ for headerless code + Variable tlast tlast off \ last name in target + Variable glast' glast' off \ acf of latest ghost + Variable tdoes> tdoes> off \ code addr of last does + Variable tdodo tdodo off \ location of dodo + Variable >in: >in: off \ last :-def + Variable tvoc tvoc off \ + Variable tvoc-link tvoc-link off \ voc-link in target + Variable tnext-link tnext-link off \ link for tracer + + +\ *** Block No. 4 Hexblock 4 +\ Target header pointers ks 10 okt 87 + + : there ( -- taddr ) tdp @ ; + + : new pushfile makefile isfile@ tfile ! + tvoc-link off tnext-link off + $100 tdp ! $100 displace ! ; + + + + + + + + + +\ *** Block No. 5 Hexblock 5 +\ Ghost-creating ks 07 dez 87 + +0 | Constant 0 | Constant + +| Create gname $21 allot + +| : >heap ( from quan -- ) \ heap over - 1 and + \ align + dup hallot heap swap cmove ; + + : symbolic ( string -- cfa.ghost ) + count dup 1 $1F uwithin not Abort" invalid Gname" + gname place BL gname append align here >r makeview , + state @ IF context ELSE current THEN @ @ dup @ , + gname count under here place 1+ allot align + here r@ - , 0 , 0 , r@ here over - >heap + heap 2+ rot ! r> dp ! heap + ; +\ *** Block No. 6 Hexblock 6 +\ ghost words ks 07 dez 87 + + : gfind ( string -- cfa tf / string ff ) + >r 1 r@ c+! r@ find -1 r> c+! ; + + : ghost ( -- cfa ) name gfind ?exit symbolic ; + + : gdoes> ( cfa.ghost -- cfa.does ) + 4 + dup @ IF @ exit THEN + here , 0 , dup 4 >heap + dp ! heap swap ! heap ; + + + + + +\ *** Block No. 7 Hexblock 7 +\ ghost utilities ks 29 jun 87 + + : g' ( -- acf ) name gfind 0= Abort" ?T?" ; + + : '. g' dup @ case? + IF ." forw" ELSE - Abort" ??" ." res" THEN + 2+ dup @ 5 u.r 2+ @ ?dup + IF dup @ case? + IF ." fdef" ELSE - Abort" ??" ." rdef" THEN + 2+ @ 5 u.r THEN ; + + ' ' Alias h' + + + + +\ *** Block No. 8 Hexblock 8 +\ .unresolved ks 29 jun 87 + +| : forward? ( cfa -- cfa / exit&true ) + dup @ = 0=exit dup 2+ @ 0=exit drop true rdrop ; + +| : unresolved? ( addr -- f ) 2+ + dup count $1F and + 1- c@ bl = + IF name> forward? 4+ @ dup IF forward? THEN + THEN drop false ; + +| : unresolved-words ( thread -- ) + BEGIN @ ?dup WHILE dup unresolved? + IF dup 2+ .name ?cr THEN REPEAT ; + + : .unresolved voc-link @ + BEGIN dup 4 - unresolved-words @ ?dup 0= UNTIL ; +\ *** Block No. 9 Hexblock 9 +\ Extending Vocabularys for Target-Compilation ks 29 jun 87 + + Vocabulary Ttools + Vocabulary Defining + + : Vocabulary Vocabulary 0 , here tvoc @ , tvoc ! ; + + Vocabulary Transient tvoc off + + Root definitions + + : T Transient ; immediate + : H Forth ; immediate + : D Defining ; immediate + + Forth definitions +\ *** Block No. 10 Hexblock A +\ Image and byteorder ks 02 jul 87 + +| Code >byte ( 16b -- 8b- 8b+ ) A A xor + D- A- xchg D+ D- xchg A push Next end-code + +| Code byte> ( 8b- 8b+ -- 16b ) + A pop D- D+ mov A- D- xchg Next end-code + +| : >target ( addr1 -- daddr fcb ) displace @ - 0 tfile @ ; + + Transient definitions + + : c@ ( addr -- 8b ) [ Dos ] + >target file@ dup 0< Abort" nie abgespeichert" ; + + : c! ( 8b addr -- ) [ Dos ] >target file! ; +\ *** Block No. 11 Hexblock B +\ Transient primitives ks 09 jul 87 + : @ ( addr -- n ) H dup T c@ swap 1+ c@ byte> ; + : ! ( n addr -- ) H >r >byte r@ 1+ T c! r> c! H ; + + : cmove ( from.mem to.target quan -- ) [ Dos ] + >r >target fseek ds@ swap r> tfile @ lfputs ; +\ bounds ?DO dup c@ I T c! H 1+ LOOP drop ; + + : here ( -- taddr ) H tdp @ ; + : here! ( taddr -- ) H tdp ! ; + : allot ( n -- ) H tdp +! ; + : c, ( 8b -- ) T here c! 1 allot H ; + : , ( 16b -- ) T here ! 2 allot H ; + : align ( -- ) H ; immediate + : even ( addr1 -- addr2 ) H ; immediate + : halign H ; immediate +\ *** Block No. 12 Hexblock C +\ Transient primitives ks 29 jun 87 + + : count ( addr1 -- addr2 len ) H dup 1+ swap T c@ H ; + + : ," H here ," here over dp ! + over - T here swap dup allot cmove H ; + + : fill ( addr quan 8b -- ) H + -rot bounds ?DO dup I T c! H LOOP drop ; + : erase ( addr quan -- ) H 0 T fill H ; + : blank ( addr quan -- ) H bl T fill H ; + + : move-threads H tvoc @ tvoc-link @ + BEGIN over ?dup + WHILE 2- @ over 2- T ! @ H swap @ swap REPEAT + Error" some undef. Target-Vocs left" drop ; +\ *** Block No. 13 Hexblock D +\ Resolving ks 29 jun 87 + Forth definitions + + : resolve ( cfa.ghost cfa.target -- ) over dup @ = + IF space dup >name .name ." exists " ?cr + 2+ ! drop exit THEN >r >r 2+ @ ?dup + IF BEGIN dup T @ H 2dup = Abort" resolve loop" + r@ rot T ! H ?dup 0= UNTIL + THEN r> r> over ! 2+ ! ; + + : resdoes> ( acf.ghost acf.target -- ) swap gdoes> + dup @ = IF 2+ ! exit THEN swap resolve ; + +here 2+ 0 ] Does> dup @ there rot ! T , H ; ' >body ! +here 2+ 0 ] Does> @ T , H ; ' >body ! + +\ *** Block No. 14 Hexblock E +\ compiling names into targ. ks 10 okt 87 + +| : tlatest ( -- addr ) current @ 6 + ; + + : (theader ?thead @ IF 1 ?thead +! exit THEN + >in @ bl word swap >in ! dup count upper + dup c@ 1 $20 uwithin not Abort" inval. Tname" + blk @ $8400 or T align , H + there tlatest @ T , H tlatest ! there tlast ! + there over c@ 1+ dup T allot cmove align H ; + + : theader tlast off + (theader ghost dup glast' ! there resolve ; + + + +\ *** Block No. 15 Hexblock F +\ prebuild defining words ks 29 jun 87 + +| : (prebuild >in @ Create >in ! + r> dup 2+ >r @ here 2- ! ; + +| : tpfa, there , ; + + : prebuild ( addr check# -- check# ) 0 ?pairs + dup IF compile (prebuild dup , THEN + compile theader ghost gdoes> , + IF compile tpfa, THEN 0 ; immediate + + : dummy 0 ; + + : DO> [compile] Does> here 3 - compile @ 0 ] ; + +\ *** Block No. 16 Hexblock 10 +\ Constructing defining words in Host kks 07 dez 87 + +| : defcomp ( string -- ) dup ['] Defining search ?dup + IF 0> IF nip execute exit THEN drop dup THEN + find ?dup IF 0< IF nip , exit THEN THEN + drop ['] Forth search ?dup + IF 0< IF , exit THEN execute exit THEN + number? ?dup 0= Abort" ?" + 0> IF swap [compile] Literal THEN [compile] Literal ; + +| : definter ( string -- ) dup ['] Defining search ?dup + IF 0< IF nip execute exit THEN THEN drop + find ?dup IF 1 and 0= Abort" compile only" execute exit + THEN number? 0= Error" ?" ; + + +\ *** Block No. 17 Hexblock 11 +\ Constructing defining words in Host ks 22 dez 87 + +| : (;tcode r> @ tlast @ T count + ! H ; + +Defining definitions + + : ] H ] ['] defcomp Is parser ; + + : [ H [compile] [ ['] definter Is parser ; immediate + + : ; H [compile] ; [compile] \\ ; immediate + + : Does> H compile (;tcode tdoes> @ , + [compile] ; -2 allot [compile] \\ ; immediate +D ' Does> Alias ;Code immediate H + +\ *** Block No. 18 Hexblock 12 +\ reinterpreting defining words ks 22 dez 87 + Forth definitions + + : ?reinterpret ( f -- ) 0=exit + state @ >r >in @ >r adr parser @ >r + >in: @ >in ! : D ] H interpret + r> Is parser r> >in ! r> state ! ; + + : undefined? ( -- f ) glast' @ 4+ @ 0= ; + +| : flag! ( 8b -- ) tlast @ ?dup 0= IF drop exit THEN + dup T c@ rot or swap c! H ; + +| : nfa? ( acf alf -- anf / acf ff ) + BEGIN dup WHILE 2dup 2+ T count $1F and + even H = + IF 2+ nip exit THEN T @ H REPEAT ; +\ *** Block No. 19 Hexblock 13 +\ the 8086 Assembler ks 29 jun 87 + +| Create relocate ] T c, , here ! c! H [ + +Transient definitions + + : Assembler H [ Assembler ] relocate >codes ! Assembler ; + + : >label ( 16b -- ) H >in @ name gfind rot >in ! + IF over resolve dup THEN drop Constant ; + + : Label T here >label Assembler H ; + + : Code H theader T here 2+ , Assembler H ; + + +\ *** Block No. 20 Hexblock 14 +( Transient primitives ks 17 dec 83 ) + +' exit Alias exit ' load Alias load +' / Alias / ' thru Alias thru +' swap Alias swap ' * Alias * +' dup Alias dup ' drop Alias drop +' /mod Alias /mod ' rot Alias rot +' -rot Alias -rot ' over Alias over +' 2* Alias 2* ' + Alias + +' - Alias - ' 1+ Alias 1+ +' 2+ Alias 2+ ' 1- Alias 1- +' 2- Alias 2- ' negate Alias negate +' 2swap Alias 2swap ' 2dup Alias 2dup + + + +\ *** Block No. 21 Hexblock 15 +\ Transient primitives kks 29 jun 87 + + ' also Alias also ' words Alias words +' definitions Alias definitions ' hex Alias hex +' decimal Alias decimal ' ( Alias ( immediate + ' \ Alias \ immediate ' \\ Alias \\ immediate + ' .( Alias .( immediate ' [ Alias [ immediate + ' cr Alias cr +' end-code Alias end-code ' Transient Alias Transient + ' +thru Alias +thru ' +load Alias +load + ' .s Alias .s + +Tools ' trace Alias trace immediate + + + +\ *** Block No. 22 Hexblock 16 +\ immediate words and branch primitives ks 29 jun 87 + + : >mark ( -- addr ) T here 0 , H ; + : >resolve ( addr -- ) T here over - swap ! H ; + : name ks 29 jun 87 + + : ' ( -- acf ) H g' dup @ - + IF Error" undefined" THEN 2+ @ ; + + : compile H ghost , ; immediate restrict + + : >name ( acf -- anf / ff ) H tvoc + BEGIN @ dup WHILE under 2- @ nfa? ?dup IF nip exit THEN + swap REPEAT nip ; + + + + + + +\ *** Block No. 24 Hexblock 18 +\ >name Alias ks 29 jun 87 + + : >body ( acf -- apf ) H 2+ ; + + : Alias ( n -- ) H tlast off + (theader ghost over resolve T , H $20 flag! ; + + : on ( addr -- ) H true swap T ! H ; + : off ( addr -- ) H false swap T ! H ; + + + + + + + +\ *** Block No. 25 Hexblock 19 +\ Target tools ks 9 sep 86 + Onlyforth + +| : .tfield ( taddr len quan -) >r under Pad swap + bounds ?DO dup T c@ I H c! 1+ LOOP drop + Pad over type r> swap - 0 max spaces ; + + ' view Alias hview + + Ttools also definitions + +| : ?: ( addr -- addr ) dup 4 u.r ." :" ; +| : @? ( addr -- addr ) dup T @ H 6 u.r ; +| : c? ( addr -- addr ) dup T c@ H 3 .r ; + + +\ *** Block No. 26 Hexblock 1A +\ Ttools for decompiling ks 9 sep 86 + + : s ( addr -- addr+ ) ?: space c? 4 spaces + T count 2dup + even -rot 18 .tfield ; + + : n ( addr -- addr+2 ) ?: @? 2 spaces dup T @ >name H + ?dup IF T count H ELSE 0 0 THEN + $1F and $18 .tfield 2+ ; + + : d ( addr n -- addr+n ) 2dup swap ?: 3 spaces + swap 0 DO c? 1+ LOOP 4 spaces -rot dup .tfield ; + + : l ( addr -- addr+2 ) ?: 6 spaces @? 2+ 14 spaces ; + + : c ( addr -- addr+1 ) 1 d 15 spaces ; + +\ *** Block No. 27 Hexblock 1B +\ Tools for decompiling ks 29 jun 87 + + : b ( addr -- addr+2 ) ?: @? dup T @ H + over + 6 u.r 2+ 14 spaces ; + + : dump ( addr n -- ) + bounds ?DO cr I 10 d drop stop? IF LEAVE THEN 10 +LOOP ; + + : view T ' >name H ?dup 0=exit 4 - T @ H ?dup 0=exit edit ; + + + + + + + +\ *** Block No. 28 Hexblock 1C +\ Predefinitions loadscreen ks 29 jun 87 + Onlyforth + + : clear H true Abort" There are ghosts" ; + + + 1 $B +thru + + + + + + + + + +\ *** Block No. 29 Hexblock 1D +\ Literal ['] ?" ." " ks 29 jun 87 + Transient definitions Forth + + : Literal ( n -- ) H dup $FF00 and + IF T compile lit , H exit THEN T compile clit c, H ; + immediate + + : Ascii H bl word 1+ c@ state @ 0=exit + T [compile] Literal H ; immediate + + : ['] T compile lit H ; immediate + : ." T compile (." ," align H ; immediate + : " T compile (" ," align H ; immediate + + + +\ *** Block No. 30 Hexblock 1E +\ Target compilation ] ks 07 dez 87 + Forth definitions + +| : tcompile ( string -- ) dup find ?dup + IF 0> IF nip execute exit THEN THEN + drop gfind IF execute exit THEN number? ?dup + IF 0> IF swap T [compile] Literal THEN + [compile] Literal H exit THEN + symbolic execute ; + + Transient definitions + + : ] H ] ['] tcompile Is parser ; + + + +\ *** Block No. 31 Hexblock 1F +\ Target conditionals ks 10 sep 86 + + : IF T compile ?branch >mark H 1 ; immediate restrict + : THEN abs 1 ?pairs T >resolve H ; immediate restrict + : ELSE 1 ?pairs T compile branch >mark + swap >resolve H -1 ; immediate restrict + + : BEGIN T mark H -2 2swap ; + immediate restrict + +| : (repeat 2 ?pairs T resolve H REPEAT ; + + : UNTIL T compile ?branch (repeat H ; immediate restrict + : REPEAT T compile branch (repeat H ; immediate restrict +\ *** Block No. 32 Hexblock 20 +\ Target conditionals Abort" etc. ks 09 feb 88 + + : DO T compile (do >mark H 3 ; immediate restrict + : ?DO T compile (?do >mark H 3 ; immediate restrict + : LOOP 3 ?pairs T compile (loop + compile endloop >resolve H ; immediate restrict + : +LOOP 3 ?pairs T compile (+loop + compile endloop >resolve H ; immediate restrict + + : Abort" T compile (abort" ," align H ; immediate restrict + : Error" T compile (error" ," align H ; immediate restrict + + + + + +\ *** Block No. 33 Hexblock 21 +\ Target does> ;code ks 29 jun 87 + +| : dodoes> T compile (;code + H glast' @ there resdoes> there tdoes> ! ; + + : Does> H undefined? T dodoes> + $E9 c, H tdodo @ there - 2- T , + H ?reinterpret ; immediate restrict + + : ;Code H 0 ?pairs undefined? T dodoes> H ?reinterpret + T [compile] [ Assembler H ; immediate restrict + + + + + +\ *** Block No. 34 Hexblock 22 +\ User ks 09 jul 87 + Forth definitions + + Variable torigin torigin off \ cold boot vector + Variable tudp tudp off \ user variable counter + : >user ( addr1 -- addr2 ) T c@ H torigin @ + ; + + Transient definitions Forth + + : origin! ( taddr -- ) H torigin ! tudp off ; + : uallot ( n -- offset ) H tudp @ swap tudp +! ; + + DO> >user ; + : User T prebuild User 2 uallot c, H ; + + +\ *** Block No. 35 Hexblock 23 +\ Variable Constant Create ks 01 okt 87 + + DO> ; + : Variable T prebuild Create 2 allot H ; + + DO> T @ H ; + : Constant T prebuild Constant , H ; + + DO> ; + : Create T prebuild Create H ; + + : Create: T Create ] H end-code 0 ; + + + + +\ *** Block No. 36 Hexblock 24 +\ Defer Is Vocabulary ks 29 jun 87 + + DO> ; + : Defer T prebuild Defer 2 allot ; + : Is T ' >body H state @ + IF T compile (is , H exit THEN T ! H ; immediate + + dummy + : Vocabulary H >in @ Vocabulary >in ! + T prebuild Vocabulary 0 , 0 , + H there tvoc-link @ T , H tvoc-link ! ; + + + + + +\ *** Block No. 37 Hexblock 25 +\ File ks 19 m„r 88 + Forth definitions + + Variable tfile-link tfile-link off + Variable tfileno tfileno off + &45 Constant tb/fcb + + Transient definitions Forth + + dummy + : File T prebuild File here tb/fcb 0 fill + here H tfile-link @ T , H tfile-link ! + 1 tfileno +! tfileno @ T c, 0 , 0 , 0 , 0 , 0 , + here dup >r 1+ tb/fcb &13 - allot H tlast @ + T count dup r> c! + H bounds ?DO I T c@ over c! H 1+ LOOP drop ; +\ *** Block No. 38 Hexblock 26 +\ : ; compile Host [compile] ks 29 jun 87 + + dummy + : : H >in @ >in: ! T prebuild : ] H end-code 0 ; + + : ; 0 ?pairs T compile unnest + [compile] [ H ; immediate restrict + + : compile T compile compile H ; immediate restrict + + : Host H Onlyforth ; + + : Compiler H Onlyforth Transient also definitions ; + + : [compile] H ghost execute ; immediate restrict + +\ *** Block No. 39 Hexblock 27 +\ Target ks 29 jun 87 + + Onlyforth + + : Target H vp off Transient also definitions ; + + Transient definitions + + ghost c, drop + + + + + + + +\ *** Block No. 40 Hexblock 28 + + + + + + + + + + + + + + + + +\ *** Block No. 41 Hexblock 29 + + + + + + + + + + + + + + + + +\ *** Block No. 42 Hexblock 2A + + + + + + + + + + + + + + + + +\ *** Block No. 43 Hexblock 2B + + + + + + + + + + + + + + + + +\ *** Block No. 44 Hexblock 2C + + + + + + + + + + + + + + + + +\ *** Block No. 45 Hexblock 2D + + + + + + + + + + + + + + + + +\ *** Block No. 46 Hexblock 2E + + + + + + + + + + + + + + + + +\ *** Block No. 47 Hexblock 2F + + + + + + + + + + + + + + + + +\ *** Block No. 48 Hexblock 30 + + + + + + + + + + + + + + + + +\ *** Block No. 49 Hexblock 31 + + + + + + + + + + + + + + + + +\ *** Block No. 50 Hexblock 32 + + + + + + + + + + + + + + + + +\ *** Block No. 51 Hexblock 33 + + + + + + + + + + + + + + + + +\ *** Block No. 52 Hexblock 34 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/minimal.fth b/sources/msdos/minimal.fth new file mode 100644 index 0000000..551d30c --- /dev/null +++ b/sources/msdos/minimal.fth @@ -0,0 +1,102 @@ +\ *** Block No. 0 Hexblock 0 +\\ Startup: Load Standard System cas 11nov05 + +This file can be used to create a minimal volksFORTH from +a plain KERNEL.COM. + +The System will be saved as "MINIMAL.COM". + +The minimal volksFORTH contains a simple line editor from +the book "Starting Forth". The minimal system can be used to +adapt EDITOR.FB and VOLKS4TH.SYS for special hardware. + + + + + + +\ *** Block No. 1 Hexblock 1 +\ System LOAD-Screen for MS-DOS volksFORTH cas 11nov05 + Onlyforth warning off + + include extend.fb + include tools.fb + include rfe.fb \ retro forth editor + + : initial rfe.fb 0 list restart ; ' initial Is 'cold + + warning on clear + savesystem MINIMAL.COM bell + + .( New System saved as "MINIMAL.COM". ) cr + + + +\ *** Block No. 2 Hexblock 2 + + + + + + + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 + + + + + + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + +\ *** Block No. 5 Hexblock 5 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/minimal.sys.src b/sources/msdos/minimal.sys.src deleted file mode 100644 index 0e34778..0000000 --- a/sources/msdos/minimal.sys.src +++ /dev/null @@ -1,102 +0,0 @@ -Screen 0 not modified - 0 \\ Startup: Load Standard System cas 11nov05 - 1 - 2 This file can be used to create a minimal volksFORTH from - 3 a plain KERNEL.COM. - 4 - 5 The System will be saved as "MINIMAL.COM". - 6 - 7 The minimal volksFORTH contains a simple line editor from - 8 the book "Starting Forth". The minimal system can be used to - 9 adapt EDITOR.FB and VOLKS4TH.SYS for special hardware. -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ System LOAD-Screen for MS-DOS volksFORTH cas 11nov05 - 1 Onlyforth warning off - 2 - 3 include extend.fb - 4 include tools.fb - 5 include rfe.fb \ retro forth editor - 6 - 7 : initial rfe.fb 0 list restart ; ' initial Is 'cold - 8 - 9 warning on clear -10 savesystem MINIMAL.COM bell -11 -12 .( New System saved as "MINIMAL.COM". ) cr -13 -14 -15 -Screen 2 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/miniterm.fth b/sources/msdos/miniterm.fth new file mode 100644 index 0000000..e97ce08 --- /dev/null +++ b/sources/msdos/miniterm.fth @@ -0,0 +1,340 @@ +\ *** Block No. 0 Hexblock 0 +\\ Terminalprogramm mit Blockinterface ( 08.03.91/KK ) + + Autor: Klaus Kohl, 30.01.89 aus FG-FORTH des RTX entnommen + + Beschreibung: + + Kleines Beispiel zur Implementation eines Fileinterfaces ber + die serielle Schnittstelle (Achtung: immer 8 Datenbits) + + Die Schnittstellenbefehle stammen aus dem PC-volksFORTH 3.81 + von Klaus Schleisiek. Sie wurden weitgehend unver„ndert ber- + nommen, sind aber auf 4KByte-Puffer erweitert. + File: SERIAL.SCR + + Umstellung des Ports durch Ausmaskierung der entsprechenden + Zeilen in Screen 2 (momentan COM1 aktiviert). +\ *** Block No. 1 Hexblock 1 +\ LOADSCREEN cas 28jun20 + +Onlyforth \ Suchreihenfolge: FORTH FORTH ONLY +\needs Assembler 2 loadfrom asm.fb \ Assembler nachladen + + FROM source.img ( File for SAVESYSTEM ) + + $20 >label I_ctrl \ 8259-Register + $21 >label I_mask \ 8259-Mask + + &02 &11 THRU ( SIO-Terminalroutines ) + &12 &17 THRU ( extended command words ) + &18 LOAD ( Terminalprogram ) + + + +\ *** Block No. 2 Hexblock 2 +\ Addresses and Constants cas 28jun20 + +| $C 4 * Constant SINT@ \ SIO-Interuptvector COM 1/3 +\ $B 4 * Constant SINT@ \ SIO-Interuptvector COM 2/4 +| $10 Constant I_level \ 8259-Interuptlevel COM 1/3 +\ $08 Constant I_level \ 8259-Interuptlevel COM 2/4 +( Port address) +| $3F8 >label Portadr \ Portaddress COM1: +\ $2F8 >label Portadr \ Portaddress COM2: +\ $3E8 >label Portadr \ Portaddress COM3: +\ $2E8 >label Portadr \ Portaddress COM4: +( Selection of Baud rate ) +\ &96 >label baud .( 1200 Baud ) +\ &48 >label baud .( 2400 Baud ) +| &12 >label baud .( 9600 Baud ) +\ &02 >label baud .( 57600 Baud ) +\ *** Block No. 3 Hexblock 3 +\ Queue and required commands cas 28jun20 + +( Dataqueue with 128 bytes and two pointer for IRQ service ) +( Queue+0: Number of saved characters ) +( Queue+1: offset to next char to be send ) + Create Queue 0 , 0 , $1000 allot + +\ send byte to port address ( b adr -- ) +\needs pc! Code pc! A pop D byte out D pop Next + +\ Read Byte from port address ( adr -- b ) +\needs pc@ Code pc@ D byte in A- D- mov D+ D+ xor Next + + + + +\ *** Block No. 4 Hexblock 4 +\ tx? = Request status for sending char cas 28jun20 + +( test if a char cn be send ) + Code tx? ( -- f ) \ f=-1, ready to send + D push \ TOS to datastack (TOS=Top Of Stack) + Portadr 5 + # D mov \ move status address into D reg + D in \ get port into register A + D D xor \ set D register to 0 + $1020 # A and \ mask % 0001 0000 0010 0000 + $1020 # A cmp \ tes if these bits are set + 0= ?[ D dec ]? \ char output permitted ? + Next \ compiling "Next" wurg macro + end-code + + + +\ *** Block No. 5 Hexblock 5 +\ (tx tx = transmit cas 28jun20 + +( unconditional send byte directly to 8250-Port ) + Code (tx ( char -- ) + D- A- xchg \ load char into AL-register + Portadr # D mov \ load port address in D-register + D byte out \ transmit AL + D pop \ load next stack value into D-register + Next \ compiling "Next" + end-code + +( wait until last char has been send ) + : tx ( char -- ) + BEGIN tx? UNTIL \ wait until SIO ready + (tx ; \ now write to port + +\ *** Block No. 6 Hexblock 6 +\ -DTR +DTR = Data Terminal Ready on/off cas 28jun20 +( DTR-Line to +12 V = logical zero ) + Code -DTR ( -- ) + D push \ save TOS + Portadr 4 + # D mov \ get Address of Port Controllregister + D byte in \ move content to AL register + $1C # A- and \ DTR and RTS to 0 = +12 V + D byte out \ write AL back into port register + D pop \ restore TOS + Next \ next FORTH words + end-code +( set DTR and RTS back to 1 = -12 V ) + Code +DTR ( -- ) + D push Portadr 4 + # D mov + D byte in 3 # A- or D byte out + D pop Next end-code +\ *** Block No. 7 Hexblock 7 +\ receive queue and interrupt service routine ( 21.02.89/KK ) + +| Label S_INT + D push I push A push + Queue # I mov C: seg I ) A mov + A D mov A inc $FFF # A and C: seg A I ) mov D I ADD + Portadr # D mov D byte in C: seg A- 4 I D) mov + $20 # A- mov I_ctrl #) byte out \ EOI for 8259 + A pop I pop D pop iret + end-code + + + + + + +\ *** Block No. 8 Hexblock 8 +\ rx? = request status for reading from Queue cas 28jun20 +| Code rx? ( -- f ) D push + Queue #) D mov Queue 2+ #) D XOR + Next end-code + +\\ Query if a char can be read from the queue + Code rx? ( -- f ) ( f<>0, if char ready ) + D push \ TOS to datastack + D D xor \ D-register to 0 + Queue #) D- mov \ get number if DL and + D- D- or \ test for 0 + 0= ?[ [[ D push \ if queue empty + Portadr 4 + # D mov \ activate S8 again + D byte in $B # A- or D byte out \ without changing + D pop \ D register +swap ]? Next end-code +\ *** Block No. 9 Hexblock 9 +\ (rx rx = receive char from queue cas 28jun20 + +( get char from queue, adjust pointer ) + Code (rx ( -- char ) + D push I push + Queue 2+ # I mov C: seg I ) A mov + A D mov A inc $FFF # A and C: seg A I ) mov D I ADD + C: seg 2 I D) A- mov 0 # A+ mov A D mov + I pop Next end-code + +( get char, wait for char available ) + : rx ( -- char ) + BEGIN rx? UNTIL (rx ; + + + +\ *** Block No. 10 Hexblock A +\ S_init = initialize serial interface cas 28jun20 +| Code S_init ( -- ) + D push D: push \ save TOS and DS register + A A xor A D: mov C: A mov \ 0 -> DS ; CS -> A + SINT@ # W mov S_INT # W ) mov \ set IRQ vector + A 2 W D) mov D: pop \ and restore DS register + Portadr 3 + # D mov + $80 # A- mov D byte out \ enable Baud-rate register + 2 # D sub baud # A mov A- A+ xchg D byte out \ set the + D dec A- A+ xchg D byte out \ BAUD rate + 3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT + 2 # D sub 1 # A- mov D byte out \ enable RX IRQ + I_mask #) byte in + I_level Forth not Assembler # A- and \ activate 8259 + I_mask #) byte out + D pop Next end-code +\ *** Block No. 11 Hexblock B +\ init -init = Initialization / Reset cas 28jun20 + +\needs init | : init ; + +( clear queue pointer and initialize port and interrupt ) + : init ( -- ) + init Queue off Queue 2+ off S_init ; + +( block IRQ, disable RTS and DTR ) + : -init ( -- ) + 0 [ Portadr 1+ ] Literal pc! \ disable 8259 IRQ + 0 [ Portadr 4 + ] Literal pc! \ -RTS/-rts/-out2 + I_mask pc@ I_level or I_mask pc! ; \ block 8259 + + + +\ *** Block No. 12 Hexblock C +\ rxto rxwto = receive char with timeout cas 28jun20 + +| &1000 Constant Timeout \ exit after 1000 iterations + +( get a char ) +| : rxto ( -- char 0 | f ) ( f=-1 signals error ) + Timeout \ number iterations + BEGIN rx? IF drop (rx 0 exit THEN \ char available? + 1- DUP 0= \ Timeout ? + UNTIL DROP -1 ; + +( get a word, Highbyte first ) +| : rxwto ( -- n 0 | f ) + rxto ?dup ?exit \ exit when Timeout in 1st byte + &256 * rxto \ move to highbyte, get lowbyte + if drop -1 else OR 0 then ; \ Timeout -> error flag +\ *** Block No. 13 Hexblock D +\ info. blk>sio sio>blk = Forth Block I/O cas 28jun20 +: info. ." Block: " dup . cr ; +: blk>sio ( b -- f ) ( Block to target machine ) + dup capacity u< + if cr ." HOST -> TA -" info. block 0 tx + &1024 0 DO dup c@ tx 1+ LOOP drop + else drop 9 tx + then 0 ; +: sio>blk ( b -- f ) ( Block from Target ) + dup capacity u< + if cr ." TA -> HOST -" info. flush block 0 tx + &1024 0 do rxto if drop &1234 leave + else over c! 1+ then loop &1234 = + if empty-buffers -1 else update flush 0 then + else drop 9 tx 0 then ; + +\ *** Block No. 14 Hexblock E +\ Extension for img>file cas 28jun20 + +VARIABLE TSEG TSEG OFF ( Segment-Address of Target-RAM ) + +: TINIT ( len -- ) + 0 B/SEG UM/MOD SWAP IF 1+ THEN ( number of blocks ) + LALLOCATE ABORT" No RAM" ( reserve ) + TSEG ! ; ( save address ) +: TFREE ( -- ) ( release memory ) + TSEG @ LFREE ABORT" RAM allocated" ; + +: TC! ( c addr -- ) ( write byte ) + TSEG @ SWAP LC! ; +: R >R TSEG @ SWAP DS@ R> R> LMOVE ; + +\ *** Block No. 15 Hexblock F +\ Terminal part for SAVESYSTEM cas 28jun20 + +: img>file ( len -- f ) ( save image file ) + DUP TINIT DUP 0 0 tx + ?DO rxto ABORT" Savesystem-Error" I TC! LOOP + PUSHFILE SOURCE.IMG + CAPACITY 1- 0 DO I BLOCK &1024 -1 FILL UPDATE LOOP + 0 $400 UM/MOD DUP 0 + ?DO I $400 * I BLOCK $400 sio exit then \ Transmit + 2 case? if rxwto ?dup ?exit sio>blk exit then \ Receive + 3 case? if rxwto ?dup ?exit img>file exit then \ ROM + 4 case? if rxwto ?dup ?exit drop page 0 exit then \ PAGE + 5 case? if rxto ?dup ?exit rxto ?dup if nip exit then + swap at 0 exit then \ AT + $1B case? if $1B tx 0 exit then \ ESCAPE + drop -1 ; \ error unknown command + + + +\ *** Block No. 17 Hexblock 11 +\ ?rx = char from terminal cas 28jun20 + +( receive and interpret char ) +| : ?rx ( -- ) + pause rx? 0=exit (rx \ return if no char wainting + dup $20 u< \ is control char? + if + $1B case? if tbu abort" Command-Error" exit THEN \ ESCAPE + #LF case? IF cr exit THEN \ CRLF + #CR case? IF Row 0 at exit THEN \ only CR + #BS case? IF del exit THEN \ Backspace + drop \ better ignore these + else + Col &78 u> if cr then \ next line? + emit \ directly emit char + then ; +\ *** Block No. 18 Hexblock 12 +\ T - Main Terminal command cas 28jun20 + +( send char if possible ) +| : ?tx ( c -- ) + BEGIN ?rx tx? UNTIL \ receive unil SIO is free + tx ; \ then transmit +( Terminal Interpreter Loop ) +| : (T ( -- ) + BEGIN BEGIN ?rx key? UNTIL \ receive until key pressed + key $1B case? IF -DTR exit THEN ?tx \ exit on ESC + REPEAT ; +( Main program, en-/disables interrupt ) + : T ( -- ) + CR ." TA-Terminal (Exit with ESC)" CR + INIT (T -INIT + CR ." VolksForth " ; +\ *** Block No. 19 Hexblock 13 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/multi.fth b/sources/msdos/multi.fth new file mode 100644 index 0000000..de3a9d2 --- /dev/null +++ b/sources/msdos/multi.fth @@ -0,0 +1,306 @@ +\ *** Block No. 0 Hexblock 0 + +This display interface uses BIOS call $10 functions for a fast +display interface. A couple of state variables is contained +in a vector that is task specific such that different tasks +may use different windows. For simplicity windows always +span the whole width of the screen. They can be defined by +top and bottom line. This mechanism is used for a convenient +status display line on the bottom of the screen. + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Multitsking display interface loadscreen ks cas 10nov05 + Onlyforth \needs Assembler 2 loadfrom asm.scr + + User area area off \ points at active window + Variable status \ to switch status on/off +| Variable cursor \ points at area with active cursor + + 1 8 +thru .( Multitasking display driver loaded ) cr + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ Multitsking display interface ks 6 sep 86 + + : Area: Create 0 , 0 , 7 c, Does> area ! ; +\ | col | row | top | bot | att | + +Area: terminal terminal area @ cursor ! + + : (area Create dup c, 1+ Does> c@ area @ + ; + +0 | (area ccol | (area crow | (area ctop + | (area cbot (area catt drop + + : window ( topline botline -- ) cbot c! ctop c! ; + + : full 0 c/col 2- window ; full + +\ *** Block No. 3 Hexblock 3 +\ Multitask (type (emit ks 20 dez 87 + + Code (type ( addr len -- ) W pop I push R push + u' area U D) I mov U push D U mov + $F # A+ mov $10 int u' catt I D) R- mov + 3 # A+ mov $10 int C push D push $E0E # C mov + 1 # A+ mov $10 int I ) D mov 1 # C mov + U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int + D- inc ' c/row >body #) D- cmp 0= not + ?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]? + D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]? + 2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop + R pop I pop D pop ' pause #) jmp end-code + + : (emit ( char -- ) sp@ 1 (type drop ; + +\ *** Block No. 4 Hexblock 4 +\ Multitask (at (at? ks 04 aug 87 + Code (at ( row col -- ) A pop A- D+ mov + u' area U D) W mov D W ) mov cursor #) W cmp 0= + ?[ R push U push $F # A+ mov $10 int + 2 # A+ mov $10 int U pop R pop + ]? D pop Next end-code + + Code (at? ( -- row col ) + D push u' area U D) W mov W ) D mov + D+ A- mov 0 # A+ mov A+ D+ mov A push Next + end-code + + Code curat? ( -- row col ) D push R push + $F # A+ mov $10 int 3 # A+ mov $10 int + R pop 0 # A mov D+ A- xchg A push Next + end-code +\ *** Block No. 5 Hexblock 5 +\ cur! curshape setpage ks 28 jun 87 + + : cur! \ set cursor into current task's window + area @ cursor ! (at? (at ; cur! + + Code curshape ( top bot -- ) D C mov D pop + D- C+ mov 1 # A+ mov $10 int D pop Next + end-code + + Code setpage ( n -- ) + $503 # A mov D- A- and $10 int D pop Next + end-code + + + + +\ *** Block No. 6 Hexblock 6 +\ Multitask normal invers blankline ks 01 nov 88 + : normal 7 catt c! ; : invers $70 catt c! ; + : underline 1 catt c! ; : bright $F catt c! ; + + Code blankline D push R push U push $F # A+ mov + $10 int u' area U D) W mov u' catt W D) R- mov + 3 # A+ mov $10 int C push D push + $E0E # C mov 1 # A+ mov $10 int W ) D mov + 2 # A+ mov $10 int ' c/row >body #) C mov + D- C- sub bl # A- mov 9 # A+ mov + C- C- or 0= not ?[ $10 int ]? + D pop 2 # A+ mov $10 int \ set cursor back + C pop 1 # A+ mov $10 int \ cursor visible again + U pop R pop D pop ' pause #) jmp end-code + +| : lineerase ( line# -- ) 0 (at blankline ; +\ *** Block No. 7 Hexblock 7 +\ Multitask (del scroll (cr (page ks 04 okt 87 + + : (del (at? ?dup + IF 1- 2dup (at bl (emit (at exit THEN drop ; + + Code scroll D push R push U push + u' area U D) W mov u' catt W D) R+ mov + u' ctop W D) D mov D- C+ mov 0 # C- mov + ' c/row >body #) D- mov D- dec $601 # A mov + $10 int U pop R pop D pop Next + end-code + + : (cr (at? drop 1+ dup cbot c@ u> + IF scroll drop cbot c@ THEN lineerase ; + + : (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ; +\ *** Block No. 8 Hexblock 8 +\ Multitask status display ks 10 okt 87 + + ' (emit ' display 2 + ! ' (cr ' display 4 + ! + ' (type ' display 6 + ! ' (del ' display 8 + ! + ' (page ' display &10 + ! + ' (at ' display &12 + ! ' (at? ' display &14 + ! + + : .base base @ decimal dup 2 .r base ! ; + : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; + : (.drv ( n -- ) Ascii A + emit ." : " ; + : .dr ." " drv (.drv ; + : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN + @ 5 .r ; + : .space ." Dic" s0 @ here $100 + - 6 u.r ; + + +\ *** Block No. 9 Hexblock 9 +\ statuszeile ks ks 04 aug 87 + +| : fstat ( n -- ) .base .sp + .space .scr .dr file? 2 spaces order ; + +| Area: statusline + statusline c/col 1- dup window page invers terminal + + : (.status output @ display area @ statusline + status @ IF (at? drop 0 (at 2 fstat blankline + ELSE normal page invers + THEN area ! output ! ; + ' (.status Is .status + + : bye status off .status bye ; + +\ *** Block No. 10 Hexblock A + + + + + + + + + + + + + + + + +\ *** Block No. 11 Hexblock B + + + + + + + + + + + + + + + + +\ *** Block No. 12 Hexblock C + + + + + + + + + + + + + + + + +\ *** Block No. 13 Hexblock D + + + + + + + + + + + + + + + + +\ *** Block No. 14 Hexblock E + + + + + + + + + + + + + + + + +\ *** Block No. 15 Hexblock F + + + + + + + + + + + + + + + + +\ *** Block No. 16 Hexblock 10 + + + + + + + + + + + + + + + + +\ *** Block No. 17 Hexblock 11 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/multi.vid.src b/sources/msdos/multi.vid.src deleted file mode 100644 index a6e442b..0000000 --- a/sources/msdos/multi.vid.src +++ /dev/null @@ -1,306 +0,0 @@ -Screen 0 not modified - 0 - 1 This display interface uses BIOS call $10 functions for a fast - 2 display interface. A couple of state variables is contained - 3 in a vector that is task specific such that different tasks - 4 may use different windows. For simplicity windows always - 5 span the whole width of the screen. They can be defined by - 6 top and bottom line. This mechanism is used for a convenient - 7 status display line on the bottom of the screen. - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Multitsking display interface loadscreen ks cas 10nov05 - 1 Onlyforth \needs Assembler 2 loadfrom asm.scr - 2 - 3 User area area off \ points at active window - 4 Variable status \ to switch status on/off - 5 | Variable cursor \ points at area with active cursor - 6 - 7 1 8 +thru .( Multitasking display driver loaded ) cr - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ Multitsking display interface ks 6 sep 86 - 1 - 2 : Area: Create 0 , 0 , 7 c, Does> area ! ; - 3 \ | col | row | top | bot | att | - 4 - 5 Area: terminal terminal area @ cursor ! - 6 - 7 : (area Create dup c, 1+ Does> c@ area @ + ; - 8 - 9 0 | (area ccol | (area crow | (area ctop -10 | (area cbot (area catt drop -11 -12 : window ( topline botline -- ) cbot c! ctop c! ; -13 -14 : full 0 c/col 2- window ; full -15 -Screen 3 not modified - 0 \ Multitask (type (emit ks 20 dez 87 - 1 - 2 Code (type ( addr len -- ) W pop I push R push - 3 u' area U D) I mov U push D U mov - 4 $F # A+ mov $10 int u' catt I D) R- mov - 5 3 # A+ mov $10 int C push D push $E0E # C mov - 6 1 # A+ mov $10 int I ) D mov 1 # C mov - 7 U inc [[ U dec 0= not ?[[ 2 # A+ mov $10 int - 8 D- inc ' c/row >body #) D- cmp 0= not - 9 ?[[ W ) A- mov W inc 9 # A+ mov $10 int ]]? ]? -10 D I ) mov D pop cursor #) I cmp 0= ?[ I ) D mov ]? -11 2 # A+ mov $10 int C pop 1 # A+ mov $10 int U pop -12 R pop I pop D pop ' pause #) jmp end-code -13 -14 : (emit ( char -- ) sp@ 1 (type drop ; -15 -Screen 4 not modified - 0 \ Multitask (at (at? ks 04 aug 87 - 1 Code (at ( row col -- ) A pop A- D+ mov - 2 u' area U D) W mov D W ) mov cursor #) W cmp 0= - 3 ?[ R push U push $F # A+ mov $10 int - 4 2 # A+ mov $10 int U pop R pop - 5 ]? D pop Next end-code - 6 - 7 Code (at? ( -- row col ) - 8 D push u' area U D) W mov W ) D mov - 9 D+ A- mov 0 # A+ mov A+ D+ mov A push Next -10 end-code -11 -12 Code curat? ( -- row col ) D push R push -13 $F # A+ mov $10 int 3 # A+ mov $10 int -14 R pop 0 # A mov D+ A- xchg A push Next -15 end-code -Screen 5 not modified - 0 \ cur! curshape setpage ks 28 jun 87 - 1 - 2 : cur! \ set cursor into current task's window - 3 area @ cursor ! (at? (at ; cur! - 4 - 5 Code curshape ( top bot -- ) D C mov D pop - 6 D- C+ mov 1 # A+ mov $10 int D pop Next - 7 end-code - 8 - 9 Code setpage ( n -- ) -10 $503 # A mov D- A- and $10 int D pop Next -11 end-code -12 -13 -14 -15 -Screen 6 not modified - 0 \ Multitask normal invers blankline ks 01 nov 88 - 1 : normal 7 catt c! ; : invers $70 catt c! ; - 2 : underline 1 catt c! ; : bright $F catt c! ; - 3 - 4 Code blankline D push R push U push $F # A+ mov - 5 $10 int u' area U D) W mov u' catt W D) R- mov - 6 3 # A+ mov $10 int C push D push - 7 $E0E # C mov 1 # A+ mov $10 int W ) D mov - 8 2 # A+ mov $10 int ' c/row >body #) C mov - 9 D- C- sub bl # A- mov 9 # A+ mov -10 C- C- or 0= not ?[ $10 int ]? -11 D pop 2 # A+ mov $10 int \ set cursor back -12 C pop 1 # A+ mov $10 int \ cursor visible again -13 U pop R pop D pop ' pause #) jmp end-code -14 -15 | : lineerase ( line# -- ) 0 (at blankline ; -Screen 7 not modified - 0 \ Multitask (del scroll (cr (page ks 04 okt 87 - 1 - 2 : (del (at? ?dup - 3 IF 1- 2dup (at bl (emit (at exit THEN drop ; - 4 - 5 Code scroll D push R push U push - 6 u' area U D) W mov u' catt W D) R+ mov - 7 u' ctop W D) D mov D- C+ mov 0 # C- mov - 8 ' c/row >body #) D- mov D- dec $601 # A mov - 9 $10 int U pop R pop D pop Next -10 end-code -11 -12 : (cr (at? drop 1+ dup cbot c@ u> -13 IF scroll drop cbot c@ THEN lineerase ; -14 -15 : (page ctop c@ cbot c@ DO I lineerase -1 +LOOP ; -Screen 8 not modified - 0 \ Multitask status display ks 10 okt 87 - 1 - 2 ' (emit ' display 2 + ! ' (cr ' display 4 + ! - 3 ' (type ' display 6 + ! ' (del ' display 8 + ! - 4 ' (page ' display &10 + ! - 5 ' (at ' display &12 + ! ' (at? ' display &14 + ! - 6 - 7 : .base base @ decimal dup 2 .r base ! ; - 8 : .sp ( n -- ) ." s" depth swap 1+ - 2 .r ; - 9 : (.drv ( n -- ) Ascii A + emit ." : " ; -10 : .dr ." " drv (.drv ; -11 : .scr blk @ IF ." Blk" blk ELSE ." Scr" scr THEN -12 @ 5 .r ; -13 : .space ." Dic" s0 @ here $100 + - 6 u.r ; -14 -15 -Screen 9 not modified - 0 \ statuszeile ks ks 04 aug 87 - 1 - 2 | : fstat ( n -- ) .base .sp - 3 .space .scr .dr file? 2 spaces order ; - 4 - 5 | Area: statusline - 6 statusline c/col 1- dup window page invers terminal - 7 - 8 : (.status output @ display area @ statusline - 9 status @ IF (at? drop 0 (at 2 fstat blankline -10 ELSE normal page invers -11 THEN area ! output ! ; -12 ' (.status Is .status -13 -14 : bye status off .status bye ; -15 -Screen 10 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 11 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 12 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 14 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 17 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/primed.fb.src b/sources/msdos/primed.fb.src deleted file mode 100644 index f53723d..0000000 --- a/sources/msdos/primed.fb.src +++ /dev/null @@ -1,119 +0,0 @@ -Screen 0 not modified - 0 \\ Simple Editor for Installation cas 10nov05 - 1 - 2 If the Full-Screen Editor cannot be used during installation - 3 (incompatible display hardware), the screens must be altered - 4 with this Simple Editor "PRIMED", which contains only one word - 5 definition:: - 6 - 7 Usage: Select Screen nn with command "nn LIST", - 8 and edit a screen with "ll NEW". It is only possible to - 9 rewrite whole lines. ll is the first line where the editing -10 should start. The editing can be terminated by entering an -11 empty line (just RETURN). Each RETURN will store the editied -12 line and the whole screen will be reprinted. -13 -14 -15 -Screen 1 not modified - 0 \ primitivst Editor PRIMED cas 10nov05 - 1 Vocabulary Editor - 2 - 3 | : !line ( adr count line# -- ) - 4 scr @ block swap c/l * + dup c/l bl fill - 5 swap cmove update ; - 6 - 7 : new ( n -- ) - 8 l/s 1+ swap - 9 ?DO cr I . -10 pad c/l expect span @ 0= IF leave THEN -11 pad span @ I !line cr scr @ list LOOP ; -12 -13 ' scr | Alias scr' -14 -15 .( Simple Editor loaded ) cr -Screen 2 not modified - 0 \ PRIMED Demo-Screen cas 10nov05 - 1 - 2 - 3 - 4 This text was created by: "2 LIST 4 NEW" and then entering - 5 this text - 6 The headerline (Line 0) was added later after leaving "NEW" - 7 with an empty line (just RETURN) and a new editing command - 8 "0 NEW". - 9 Ulrich Hoffmann -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/primed.fth b/sources/msdos/primed.fth new file mode 100644 index 0000000..b377591 --- /dev/null +++ b/sources/msdos/primed.fth @@ -0,0 +1,119 @@ +\ *** Block No. 0 Hexblock 0 +\\ Simple Editor for Installation cas 10nov05 + +If the Full-Screen Editor cannot be used during installation +(incompatible display hardware), the screens must be altered +with this Simple Editor "PRIMED", which contains only one word +definition:: + +Usage: Select Screen nn with command "nn LIST", + and edit a screen with "ll NEW". It is only possible to + rewrite whole lines. ll is the first line where the editing + should start. The editing can be terminated by entering an + empty line (just RETURN). Each RETURN will store the editied + line and the whole screen will be reprinted. + + + +\ *** Block No. 1 Hexblock 1 +\ primitivst Editor PRIMED cas 10nov05 + Vocabulary Editor + +| : !line ( adr count line# -- ) + scr @ block swap c/l * + dup c/l bl fill + swap cmove update ; + +: new ( n -- ) + l/s 1+ swap + ?DO cr I . + pad c/l expect span @ 0= IF leave THEN + pad span @ I !line cr scr @ list LOOP ; + + ' scr | Alias scr' + + .( Simple Editor loaded ) cr +\ *** Block No. 2 Hexblock 2 +\ PRIMED Demo-Screen cas 10nov05 + + + +This text was created by: "2 LIST 4 NEW" and then entering +this text +The headerline (Line 0) was added later after leaving "NEW" +with an empty line (just RETURN) and a new editing command +"0 NEW". + Ulrich Hoffmann + + + + + + +\ *** Block No. 3 Hexblock 3 + + + + + + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + +\ *** Block No. 5 Hexblock 5 + + + + + + + + + + + + + + + + +\ *** Block No. 6 Hexblock 6 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/rfe.fb.src b/sources/msdos/rfe.fb.src deleted file mode 100644 index e7a6a71..0000000 --- a/sources/msdos/rfe.fb.src +++ /dev/null @@ -1,51 +0,0 @@ -Screen 0 not modified - 0 \ Retro Forth Editor - 1 - 2 a simple forth-style editor - 3 - 4 use filename.fb :: open forth block file - 5 block# list :: list block - 6 v :: view current block - 7 x :: clear/zero block - 8 line# i text :: insert text at line - 9 line# d :: delete line -10 n :: load next block -11 p :: load previous block -12 block# s :: load block -13 e :: evaluate/load block -14 -15 -Screen 1 not modified - 0 \ RetroForth Editor for VolksForth 1/2 19july2020 - 1 - 2 16 constant l/b - 3 - 4 : (block) scr @ block ; : (line) c/l * (block) + ; - 5 : row dup c/l -trailing type c/l + cr ; - 6 : .rows l/s 0 do i . row loop ; - 7 : .block ." BLOCK: " scr @ . space ; - 8 : +--- ." +---" ; : :--- ." :---" ; - 9 : x--- +--- :--- +--- :--- ; -10 : --- space space x--- x--- x--- x--- cr ; -11 : vb --- scr @ block .rows drop --- ; -12 : .stack ." Stack: " .s ; -13 : status .block .stack ; -14 : v cr vb status ; -15 --> -Screen 2 not modified - 0 \ RetroForth Editor for VolksForth 2/2 - 1 - 2 : v* update v ; - 3 : s dup scr ! block drop v ; - 4 : ia (line) + >r 10 parse r> swap move v* ; - 5 : i 0 swap ia ; - 6 : d (line) c/l bl fill v* ; - 7 : x (block) l/b c/l * bl fill v* ; - 8 : p -1 scr +! v ; - 9 : n 1 scr +! v ; -10 : e scr @ load ; -11 -12 -13 -14 .( Retro Forth Editor loaded ) -15 diff --git a/sources/msdos/scratch.fth b/sources/msdos/scratch.fth new file mode 100644 index 0000000..87ca179 --- /dev/null +++ b/sources/msdos/scratch.fth @@ -0,0 +1,578 @@ +\ *** Block No. 0 Hexblock 0 + + + + + + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ bla blug cas 20jun20 + +asdsakljfds +sdfdsfdsfkdjsfdsf + +fjdklsf +sdfldskfdsl;fk;dslf +s;flkdsl;fkds;fkds;fkds;fk;dsf +sfkdsf;kds;fkds;fkds;fkds;fk;dsfk;dskf;dskf;dksf + +sdfds + + + + + +\ *** Block No. 2 Hexblock 2 + + + + + + + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 + + + + + + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + +\ *** Block No. 5 Hexblock 5 + + + + + + + + + + + + + + + + +\ *** Block No. 6 Hexblock 6 + + + + + + + + + + + + + + + + +\ *** Block No. 7 Hexblock 7 + + + + + + + + + + + + + + + + +\ *** Block No. 8 Hexblock 8 + + + + + + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 + + + + + + + + + + + + + + + + +\ *** Block No. 10 Hexblock A + + + + + + + + + + + + + + + + +\ *** Block No. 11 Hexblock B + + + + + + + + + + + + + + + + +\ *** Block No. 12 Hexblock C + + + + + + + + + + + + + + + + +\ *** Block No. 13 Hexblock D + + + + + + + + + + + + + + + + +\ *** Block No. 14 Hexblock E + + + + + + + + + + + + + + + + +\ *** Block No. 15 Hexblock F + + + + + + + + + + + + + + + + +\ *** Block No. 16 Hexblock 10 + + + + + + + + + + + + + + + + +\ *** Block No. 17 Hexblock 11 + + + + + + + + + + + + + + + + +\ *** Block No. 18 Hexblock 12 + + + + + + + + + + + + + + + + +\ *** Block No. 19 Hexblock 13 + + + + + + + + + + + + + + + + +\ *** Block No. 20 Hexblock 14 + + + + + + + + + + + + + + + + +\ *** Block No. 21 Hexblock 15 + + + + + + + + + + + + + + + + +\ *** Block No. 22 Hexblock 16 + + + + + + + + + + + + + + + + +\ *** Block No. 23 Hexblock 17 + + + + + + + + + + + + + + + + +\ *** Block No. 24 Hexblock 18 + + + + + + + + + + + + + + + + +\ *** Block No. 25 Hexblock 19 + + + + + + + + + + + + + + + + +\ *** Block No. 26 Hexblock 1A + + + + + + + + + + + + + + + + +\ *** Block No. 27 Hexblock 1B + + + + + + + + + + + + + + + + +\ *** Block No. 28 Hexblock 1C + + + + + + + + + + + + + + + + +\ *** Block No. 29 Hexblock 1D + + + + + + + + + + + + + + + + +\ *** Block No. 30 Hexblock 1E + + + + + + + + + + + + + + + + +\ *** Block No. 31 Hexblock 1F + + + + + + + + + + + + + + + + +\ *** Block No. 32 Hexblock 20 + + + + + + + + + + + + + + + + +\ *** Block No. 33 Hexblock 21 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/see.fb.src b/sources/msdos/see.fb.src deleted file mode 100644 index e90d22c..0000000 --- a/sources/msdos/see.fb.src +++ /dev/null @@ -1,2074 +0,0 @@ -Screen 0 not modified - 0 \ Extended-Decompiler for VolksForth cas 10nov05 - 1 - 2 This file contains the volksFORTH decompiler. The decompiler - 3 will convert FORTH code back to Sourcecode. - 4 Conditional words like IF THEN ELSE, BEGIN WHILE REPEAT UNTIL - 5 and DO LOOP +LOOP are identified and converted. - 6 - 7 The Decompiler cannot re-create comments, so please use - 8 comments in screens and view. - 9 -10 -11 Because: There is always one more bug! -12 And to correct bug, nothing beats good commented sourcecode. -13 -14 -15 Usage: SEE -Screen 1 not modified - 0 \ Extended-Decompiler for VolksForth LOAD-SCREEN ks 22 dez 87 - 1 Onlyforth Tools also definitions - 2 - 3 | : internal 1 ?head ! ; - 4 | : external ?head off ; - 5 - 6 1 &18 +thru - 7 - 8 \\ - 9 Produces compilable Forth source from normal compiled Forth. -10 -11 These source blocks are based on the works of -12 -13 Henry Laxen, Mike Perry and Wil Baden -14 -15 volksFORTH version: U. Hoffmann -Screen 2 not modified - 0 \ detecting does> ks 22 dez 87 - 1 - 2 internal - 3 - 4 ' Forth @ 1+ dup @ + 2+ Constant (dodoes> - 5 - 6 : does? ( IP - f ) - 7 dup c@ $E9 ( jmp ) = - 8 swap 1+ dup @ + 2+ (dodoes> = and ; - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ indentation. 04Jul86 - 1 Variable #spaces #spaces off - 2 - 3 : +in ( -- ) 3 #spaces +! ; - 4 - 5 : -in ( -- ) -3 #spaces +! ; - 6 - 7 : ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; - 8 - 9 : ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ case defining words 01Jul86 - 1 - 2 : Case: ( -- ) - 3 Create: Does> swap 2* + perform ; - 4 - 5 : Associative: ( n -- ) - 6 Constant Does> ( n - index ) - 7 dup @ -rot dup @ 0 - 8 DO 2+ 2dup @ = - 9 IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 \ branching 04Jul86 - 1 - 2 Variable #branches Variable #branch - 3 - 4 : branch-type ( n -- a ) 6 * pad + ; - 5 : branch-from ( n -- a ) branch-type 2+ ; - 6 : branch-to ( n -- a ) branch-type 4+ ; - 7 - 8 : branched ( adr type -- ) \ Make entry in branch-table. - 9 #branches @ branch-type ! dup #branches @ branch-from ! -10 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; -11 -12 \\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } -13 -14 -15 -Screen 6 not modified - 0 \ branching 01Jul86 - 1 - 2 : branch-back ( adr type -- ) - 3 \ : make entry in branch-table & reclassify branch-type.) - 4 over swap branched - 5 2+ dup dup @ + swap 2+ ( loop-start,-end.) - 6 0 #branches @ 1- - 7 ?DO - 8 over I branch-from @ u> IF LEAVE THEN - 9 dup I branch-to @ = IF ['] while I branch-type ! THEN -10 -1 +LOOP 2drop ; -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ branching 01Jul86 - 1 : forward? ( ip -- f ) 2+ @ 0> ; - 2 - 3 : ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? - 4 IF ['] if branched exit THEN ['] until branch-back ; - 5 - 6 : branch+ ( ip -- ip' ) dup 4+ swap dup forward? - 7 IF ['] else branched exit THEN ['] repeat branch-back ; - 8 - 9 : (loop)+ ( ip -- ip' ) -10 dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; -11 -12 : string+ ( ip -- ip' ) 2+ count + even ; -13 -14 : (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; -15 -Screen 8 not modified - 0 \ classify each word 25Aug86 - 1 Forth - 2 - 3 &15 Associative: execution-class - 4 ] clit lit ?branch branch - 5 (do (." (abort" (;code - 6 (" (?do (loop - 7 (+loop unnest (is compile [ - 8 - 9 Case: execution-class+ -10 3+ 4+ ?branch+ branch+ -11 2+ string+ string+ (;code+ -12 string+ 2+ 4+ -13 4+ 0= 4+ 4+ 2+ ; -14 -15 Tools -Screen 9 not modified - 0 \ first pass ks 22 dez 87 - 1 - 2 : pass1 ( cfa -- ) #branches off >body - 3 BEGIN dup @ execution-class execution-class+ - 4 dup 0= stop? or - 5 UNTIL drop ; - 6 - 7 : thru.branchtable ( -- limit start ) #branches @ 0 ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 \ identify branch destinations. ks 22 dez 87 - 1 : ?.then ( ip -- ) thru.branchtable - 2 ?DO I branch-to @ over = - 3 IF I branch-from @ over u< - 4 IF I branch-type @ dup ['] else = swap ['] if = or - 5 IF -in ." THEN " ind-cr LEAVE THEN THEN THEN - 6 LOOP ; - 7 - 8 : ?.begin ( ip -- ) thru.branchtable - 9 ?DO I branch-to @ over = -10 IF I branch-from @ over u< not -11 IF I branch-type @ dup -12 ['] repeat = swap ['] until = or -13 IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN -14 LOOP ; -15 ( put "BEGIN" and "THEN" where used.) -Screen 11 not modified - 0 \ decompile each type of word 01Jul86 - 1 - 2 : .word ( ip -- ip' ) dup @ >name .name 2+ ; - 3 - 4 : .(word ( ip -- ip' ) dup @ >name - 5 ?dup 0= IF ." ??? " ELSE - 6 count $1f and swap 1+ swap 1- type space THEN 2+ ; - 7 : .inline ( val16b -- ) - 8 dup >name ?dup IF ." ['] " .name drop exit THEN . ; - 9 -10 : .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; -11 : .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; -12 : .string ( ip -- ip' ) -13 .(word count 2dup type Ascii " emit space + even ?.then ; -14 -15 : .unnest ( ip -- 0 ) ." ; " 0= ; -Screen 12 not modified - 0 \ decompile each type of word 01Jul86 - 1 - 2 : .default ( ip -- ip' ) dup @ >name ?dup IF - 3 c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; - 4 - 5 : .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; - 6 - 7 : .compile ( ip -- ip' ) .word .word ?.then ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 \ decompiling conditionals 04Jul86 - 1 - 2 : .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; - 3 : .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; - 4 : .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; - 5 : .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; - 6 : .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; - 7 - 8 5 Associative: branch-class - 9 ' if , ' while , ' else , ' repeat , ' until , -10 Case: .branch-class -11 .if .else .else .repeat .repeat ; -12 -13 : .branch ( ip -- ip' ) -14 #branch @ branch-type @ 1 #branch +! -15 dup >name swap branch-class .branch-class ; -Screen 14 not modified - 0 \ decompile Does> ;code 04Jul86 - 1 - 2 : .(;code ( IP - IP' f) - 3 2+ dup does? - 4 IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 \ classify word's output 01Jul86 - 1 - 2 Case: .execution-class - 3 .clit .lit .branch .branch - 4 .do .string .string .(;code - 5 .string .do .loop - 6 .loop .unnest .['] .compile - 7 .default ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 \ decompile colon-definitions 04Jul86 - 1 - 2 : pass2 ( cfa -- ) #branch off >body - 3 BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class - 4 dup 0= stop? or - 5 UNTIL drop ; - 6 - 7 : .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; - 8 - 9 : .immediate ( cfa - ) >name c@ dup -10 ?ind-cr 40 and IF ." IMMEDIATE " THEN -11 ?ind-cr 80 and IF ." RESTRICT" THEN ; -12 -13 : .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; -14 -15 -Screen 17 not modified - 0 \ display category of word 01Jul86 - 1 external Defer (see internal - 2 - 3 : .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; - 4 - 5 : .user-variable ( cfa - ) ." USER " dup >name dup .name - 6 3 spaces swap execute @ u. .name ." ! " ; - 7 - 8 : .defer ( cfa - ) - 9 ." deferred " dup >name .name ." Is " >body @ (see ; -10 -11 : .other ( cfa - ) dup >name .name -12 dup @ over >body = IF drop ." is Code " exit THEN -13 dup @ does? IF .does> exit THEN -14 drop ." is unknown " ; -15 -Screen 18 not modified - 0 \ decompiling variables and constants ks 22 dez 87 - 1 - 2 : .constant ( cfa - ) - 3 dup >body @ u. ." CONSTANT " >name .name ; - 4 - 5 : .variable ( cfa - ) ." VARIABLE " - 6 dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; - 7 - 8 5 Associative: definition-class - 9 ' quit @ , ' 0 @ , ' scr @ , ' base @ , -10 ' 'cold @ , -11 -12 Case: .definition-class -13 .: .constant .variable .user-variable -14 .defer .other ; -15 -Screen 19 not modified - 0 \ Top level of Decompiler ks 20dez87 - 1 - 2 external - 3 - 4 : ((see ( cfa -) - 5 #spaces off cr - 6 dup dup @ - 7 definition-class .definition-class .immediate ; - 8 - 9 ' ((see Is (see -10 -11 Forth definitions -12 : see ' (see ; -13 -14 -15 -Screen 20 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 21 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 22 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 23 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 24 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 25 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 26 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 27 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 28 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 29 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 30 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 31 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 32 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 33 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 34 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 35 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 36 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 37 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 38 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 39 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 40 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 41 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 42 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 43 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 44 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 45 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 46 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 47 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 48 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 49 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 50 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 51 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 52 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 53 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 54 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 55 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 56 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 57 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 58 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 59 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 60 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 61 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 62 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 63 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 64 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 65 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 66 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 67 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 68 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 69 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 70 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 71 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 72 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 73 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 74 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 75 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 76 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 77 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 78 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 79 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 80 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 81 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 82 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 83 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 84 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 85 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 86 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 87 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 88 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 89 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 90 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 91 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 92 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 93 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 94 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 95 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 96 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 97 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 98 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 99 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 100 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 101 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 102 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 103 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 104 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 105 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 106 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 107 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 108 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 109 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 110 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 111 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 112 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 113 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 114 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 115 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 116 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 117 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 118 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 119 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 120 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 121 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/see.fth b/sources/msdos/see.fth new file mode 100644 index 0000000..6207c3b --- /dev/null +++ b/sources/msdos/see.fth @@ -0,0 +1,2074 @@ +\ *** Block No. 0 Hexblock 0 +\ Extended-Decompiler for VolksForth cas 10nov05 + +This file contains the volksFORTH decompiler. The decompiler +will convert FORTH code back to Sourcecode. +Conditional words like IF THEN ELSE, BEGIN WHILE REPEAT UNTIL +and DO LOOP +LOOP are identified and converted. + +The Decompiler cannot re-create comments, so please use +comments in screens and view. + + +Because: There is always one more bug! +And to correct bug, nothing beats good commented sourcecode. + + +Usage: SEE +\ *** Block No. 1 Hexblock 1 +\ Extended-Decompiler for VolksForth LOAD-SCREEN ks 22 dez 87 +Onlyforth Tools also definitions + +| : internal 1 ?head ! ; +| : external ?head off ; + +1 &18 +thru + +\\ +Produces compilable Forth source from normal compiled Forth. + + These source blocks are based on the works of + + Henry Laxen, Mike Perry and Wil Baden + + volksFORTH version: U. Hoffmann +\ *** Block No. 2 Hexblock 2 +\ detecting does> ks 22 dez 87 + +internal + +' Forth @ 1+ dup @ + 2+ Constant (dodoes> + +: does? ( IP - f ) + dup c@ $E9 ( jmp ) = + swap 1+ dup @ + 2+ (dodoes> = and ; + + + + + + + +\ *** Block No. 3 Hexblock 3 +\ indentation. 04Jul86 +Variable #spaces #spaces off + +: +in ( -- ) 3 #spaces +! ; + +: -in ( -- ) -3 #spaces +! ; + +: ind-cr ( -- ) ( col #spaces @ = ?exit ) cr #spaces @ spaces ; + +: ?ind-cr ( -- ) col c/l u> IF ind-cr THEN ; + + + + + + +\ *** Block No. 4 Hexblock 4 +\ case defining words 01Jul86 + +: Case: ( -- ) + Create: Does> swap 2* + perform ; + +: Associative: ( n -- ) + Constant Does> ( n - index ) + dup @ -rot dup @ 0 + DO 2+ 2dup @ = + IF 2drop drop I 0 0 LEAVE THEN LOOP 2drop ; + + + + + + +\ *** Block No. 5 Hexblock 5 +\ branching 04Jul86 + +Variable #branches Variable #branch + +: branch-type ( n -- a ) 6 * pad + ; +: branch-from ( n -- a ) branch-type 2+ ; +: branch-to ( n -- a ) branch-type 4+ ; + +: branched ( adr type -- ) \ Make entry in branch-table. + #branches @ branch-type ! dup #branches @ branch-from ! + 2+ dup @ + #branches @ branch-to ! 1 #branches +! ; + +\\ branch-table: { type0|from0|to0 | type1|from1|to1 ... } + + + +\ *** Block No. 6 Hexblock 6 +\ branching 01Jul86 + +: branch-back ( adr type -- ) + \ : make entry in branch-table & reclassify branch-type.) + over swap branched + 2+ dup dup @ + swap 2+ ( loop-start,-end.) + 0 #branches @ 1- + ?DO + over I branch-from @ u> IF LEAVE THEN + dup I branch-to @ = IF ['] while I branch-type ! THEN + -1 +LOOP 2drop ; + + + + + +\ *** Block No. 7 Hexblock 7 +\ branching 01Jul86 +: forward? ( ip -- f ) 2+ @ 0> ; + +: ?branch+ ( ip -- ip' ) dup 4+ swap dup forward? + IF ['] if branched exit THEN ['] until branch-back ; + +: branch+ ( ip -- ip' ) dup 4+ swap dup forward? + IF ['] else branched exit THEN ['] repeat branch-back ; + +: (loop)+ ( ip -- ip' ) + dup dup @ ( loop,+loop ) branch-back -1 #branches +! 4+ ; + +: string+ ( ip -- ip' ) 2+ count + even ; + +: (;code+ ( ip -- ip' ) 2+ dup does? not IF 0= exit THEN 3+ ; + +\ *** Block No. 8 Hexblock 8 +\ classify each word 25Aug86 +Forth + +&15 Associative: execution-class + ] clit lit ?branch branch + (do (." (abort" (;code + (" (?do (loop + (+loop unnest (is compile [ + +Case: execution-class+ + 3+ 4+ ?branch+ branch+ + 2+ string+ string+ (;code+ + string+ 2+ 4+ + 4+ 0= 4+ 4+ 2+ ; + +Tools +\ *** Block No. 9 Hexblock 9 +\ first pass ks 22 dez 87 + +: pass1 ( cfa -- ) #branches off >body + BEGIN dup @ execution-class execution-class+ + dup 0= stop? or + UNTIL drop ; + +: thru.branchtable ( -- limit start ) #branches @ 0 ; + + + + + + + + +\ *** Block No. 10 Hexblock A +\ identify branch destinations. ks 22 dez 87 +: ?.then ( ip -- ) thru.branchtable + ?DO I branch-to @ over = + IF I branch-from @ over u< + IF I branch-type @ dup ['] else = swap ['] if = or + IF -in ." THEN " ind-cr LEAVE THEN THEN THEN + LOOP ; + +: ?.begin ( ip -- ) thru.branchtable + ?DO I branch-to @ over = + IF I branch-from @ over u< not + IF I branch-type @ dup + ['] repeat = swap ['] until = or + IF ind-cr ." BEGIN " +in LEAVE THEN THEN THEN + LOOP ; +( put "BEGIN" and "THEN" where used.) +\ *** Block No. 11 Hexblock B +\ decompile each type of word 01Jul86 + +: .word ( ip -- ip' ) dup @ >name .name 2+ ; + +: .(word ( ip -- ip' ) dup @ >name + ?dup 0= IF ." ??? " ELSE + count $1f and swap 1+ swap 1- type space THEN 2+ ; +: .inline ( val16b -- ) + dup >name ?dup IF ." ['] " .name drop exit THEN . ; + +: .lit ( ip -- ip' ) 2+ dup @ .inline 2+ ?.then ; +: .clit ( ip -- ip' ) 2+ dup c@ . 1+ ?.then ; +: .string ( ip -- ip' ) + .(word count 2dup type Ascii " emit space + even ?.then ; + +: .unnest ( ip -- 0 ) ." ; " 0= ; +\ *** Block No. 12 Hexblock C +\ decompile each type of word 01Jul86 + +: .default ( ip -- ip' ) dup @ >name ?dup IF + c@ $40 and IF ." [COMPILE] " THEN THEN .word ?.then ; + +: .['] ( ip -- ip' ) .(word dup @ 2- >name .name 2+ ?.then ; + +: .compile ( ip -- ip' ) .word .word ?.then ; + + + + + + + + +\ *** Block No. 13 Hexblock D +\ decompiling conditionals 04Jul86 + +: .if ( ip nfa -- ip' ) ind-cr .name +in 4+ ?.then ; +: .repeat ( ip nfa -- ip' ) -in .name ind-cr 4+ ?.then ; +: .else ( ip nfa -- ip' ) -in ind-cr .name +in 4+ ; +: .do ( ip nfa -- ip' ) ind-cr .(word +in 2+ ?.then ; +: .loop ( ip nfa -- ip' ) -in .(word ind-cr 2+ ?.then ; + +5 Associative: branch-class + ' if , ' while , ' else , ' repeat , ' until , +Case: .branch-class + .if .else .else .repeat .repeat ; + +: .branch ( ip -- ip' ) + #branch @ branch-type @ 1 #branch +! + dup >name swap branch-class .branch-class ; +\ *** Block No. 14 Hexblock E +\ decompile Does> ;code 04Jul86 + +: .(;code ( IP - IP' f) + 2+ dup does? + IF ind-cr ." DOES> " 3+ ELSE ." ;CODE " 0= THEN ; + + + + + + + + + + + +\ *** Block No. 15 Hexblock F +\ classify word's output 01Jul86 + +Case: .execution-class + .clit .lit .branch .branch + .do .string .string .(;code + .string .do .loop + .loop .unnest .['] .compile + .default ; + + + + + + + + +\ *** Block No. 16 Hexblock 10 +\ decompile colon-definitions 04Jul86 + +: pass2 ( cfa -- ) #branch off >body + BEGIN ?.begin ?ind-cr dup @ execution-class .execution-class + dup 0= stop? or + UNTIL drop ; + +: .pfa ( cfa -- ) #spaces off +in dup pass1 pass2 ; + +: .immediate ( cfa - ) >name c@ dup + ?ind-cr 40 and IF ." IMMEDIATE " THEN + ?ind-cr 80 and IF ." RESTRICT" THEN ; + +: .: ( cfa - ) ." : " dup >name .name 3 spaces .pfa ; + + +\ *** Block No. 17 Hexblock 11 +\ display category of word 01Jul86 +external Defer (see internal + +: .does> ( cfa - ) ." DOES> " @ 1+ .pfa ; + +: .user-variable ( cfa - ) ." USER " dup >name dup .name + 3 spaces swap execute @ u. .name ." ! " ; + +: .defer ( cfa - ) + ." deferred " dup >name .name ." Is " >body @ (see ; + +: .other ( cfa - ) dup >name .name + dup @ over >body = IF drop ." is Code " exit THEN + dup @ does? IF .does> exit THEN + drop ." is unknown " ; + +\ *** Block No. 18 Hexblock 12 +\ decompiling variables and constants ks 22 dez 87 + +: .constant ( cfa - ) + dup >body @ u. ." CONSTANT " >name .name ; + +: .variable ( cfa - ) ." VARIABLE " + dup >name dup .name 3 spaces swap >body @ u. .name ." ! " ; + +5 Associative: definition-class + ' quit @ , ' 0 @ , ' scr @ , ' base @ , + ' 'cold @ , + +Case: .definition-class + .: .constant .variable .user-variable + .defer .other ; + +\ *** Block No. 19 Hexblock 13 +\ Top level of Decompiler ks 20dez87 + +external + +: ((see ( cfa -) + #spaces off cr + dup dup @ + definition-class .definition-class .immediate ; + +' ((see Is (see + +Forth definitions + : see ' (see ; + + + +\ *** Block No. 20 Hexblock 14 + + + + + + + + + + + + + + + + +\ *** Block No. 21 Hexblock 15 + + + + + + + + + + + + + + + + +\ *** Block No. 22 Hexblock 16 + + + + + + + + + + + + + + + + +\ *** Block No. 23 Hexblock 17 + + + + + + + + + + + + + + + + +\ *** Block No. 24 Hexblock 18 + + + + + + + + + + + + + + + + +\ *** Block No. 25 Hexblock 19 + + + + + + + + + + + + + + + + +\ *** Block No. 26 Hexblock 1A + + + + + + + + + + + + + + + + +\ *** Block No. 27 Hexblock 1B + + + + + + + + + + + + + + + + +\ *** Block No. 28 Hexblock 1C + + + + + + + + + + + + + + + + +\ *** Block No. 29 Hexblock 1D + + + + + + + + + + + + + + + + +\ *** Block No. 30 Hexblock 1E + + + + + + + + + + + + + + + + +\ *** Block No. 31 Hexblock 1F + + + + + + + + + + + + + + + + +\ *** Block No. 32 Hexblock 20 + + + + + + + + + + + + + + + + +\ *** Block No. 33 Hexblock 21 + + + + + + + + + + + + + + + + +\ *** Block No. 34 Hexblock 22 + + + + + + + + + + + + + + + + +\ *** Block No. 35 Hexblock 23 + + + + + + + + + + + + + + + + +\ *** Block No. 36 Hexblock 24 + + + + + + + + + + + + + + + + +\ *** Block No. 37 Hexblock 25 + + + + + + + + + + + + + + + + +\ *** Block No. 38 Hexblock 26 + + + + + + + + + + + + + + + + +\ *** Block No. 39 Hexblock 27 + + + + + + + + + + + + + + + + +\ *** Block No. 40 Hexblock 28 + + + + + + + + + + + + + + + + +\ *** Block No. 41 Hexblock 29 + + + + + + + + + + + + + + + + +\ *** Block No. 42 Hexblock 2A + + + + + + + + + + + + + + + + +\ *** Block No. 43 Hexblock 2B + + + + + + + + + + + + + + + + +\ *** Block No. 44 Hexblock 2C + + + + + + + + + + + + + + + + +\ *** Block No. 45 Hexblock 2D + + + + + + + + + + + + + + + + +\ *** Block No. 46 Hexblock 2E + + + + + + + + + + + + + + + + +\ *** Block No. 47 Hexblock 2F + + + + + + + + + + + + + + + + +\ *** Block No. 48 Hexblock 30 + + + + + + + + + + + + + + + + +\ *** Block No. 49 Hexblock 31 + + + + + + + + + + + + + + + + +\ *** Block No. 50 Hexblock 32 + + + + + + + + + + + + + + + + +\ *** Block No. 51 Hexblock 33 + + + + + + + + + + + + + + + + +\ *** Block No. 52 Hexblock 34 + + + + + + + + + + + + + + + + +\ *** Block No. 53 Hexblock 35 + + + + + + + + + + + + + + + + +\ *** Block No. 54 Hexblock 36 + + + + + + + + + + + + + + + + +\ *** Block No. 55 Hexblock 37 + + + + + + + + + + + + + + + + +\ *** Block No. 56 Hexblock 38 + + + + + + + + + + + + + + + + +\ *** Block No. 57 Hexblock 39 + + + + + + + + + + + + + + + + +\ *** Block No. 58 Hexblock 3A + + + + + + + + + + + + + + + + +\ *** Block No. 59 Hexblock 3B + + + + + + + + + + + + + + + + +\ *** Block No. 60 Hexblock 3C + + + + + + + + + + + + + + + + +\ *** Block No. 61 Hexblock 3D + + + + + + + + + + + + + + + + +\ *** Block No. 62 Hexblock 3E + + + + + + + + + + + + + + + + +\ *** Block No. 63 Hexblock 3F + + + + + + + + + + + + + + + + +\ *** Block No. 64 Hexblock 40 + + + + + + + + + + + + + + + + +\ *** Block No. 65 Hexblock 41 + + + + + + + + + + + + + + + + +\ *** Block No. 66 Hexblock 42 + + + + + + + + + + + + + + + + +\ *** Block No. 67 Hexblock 43 + + + + + + + + + + + + + + + + +\ *** Block No. 68 Hexblock 44 + + + + + + + + + + + + + + + + +\ *** Block No. 69 Hexblock 45 + + + + + + + + + + + + + + + + +\ *** Block No. 70 Hexblock 46 + + + + + + + + + + + + + + + + +\ *** Block No. 71 Hexblock 47 + + + + + + + + + + + + + + + + +\ *** Block No. 72 Hexblock 48 + + + + + + + + + + + + + + + + +\ *** Block No. 73 Hexblock 49 + + + + + + + + + + + + + + + + +\ *** Block No. 74 Hexblock 4A + + + + + + + + + + + + + + + + +\ *** Block No. 75 Hexblock 4B + + + + + + + + + + + + + + + + +\ *** Block No. 76 Hexblock 4C + + + + + + + + + + + + + + + + +\ *** Block No. 77 Hexblock 4D + + + + + + + + + + + + + + + + +\ *** Block No. 78 Hexblock 4E + + + + + + + + + + + + + + + + +\ *** Block No. 79 Hexblock 4F + + + + + + + + + + + + + + + + +\ *** Block No. 80 Hexblock 50 + + + + + + + + + + + + + + + + +\ *** Block No. 81 Hexblock 51 + + + + + + + + + + + + + + + + +\ *** Block No. 82 Hexblock 52 + + + + + + + + + + + + + + + + +\ *** Block No. 83 Hexblock 53 + + + + + + + + + + + + + + + + +\ *** Block No. 84 Hexblock 54 + + + + + + + + + + + + + + + + +\ *** Block No. 85 Hexblock 55 + + + + + + + + + + + + + + + + +\ *** Block No. 86 Hexblock 56 + + + + + + + + + + + + + + + + +\ *** Block No. 87 Hexblock 57 + + + + + + + + + + + + + + + + +\ *** Block No. 88 Hexblock 58 + + + + + + + + + + + + + + + + +\ *** Block No. 89 Hexblock 59 + + + + + + + + + + + + + + + + +\ *** Block No. 90 Hexblock 5A + + + + + + + + + + + + + + + + +\ *** Block No. 91 Hexblock 5B + + + + + + + + + + + + + + + + +\ *** Block No. 92 Hexblock 5C + + + + + + + + + + + + + + + + +\ *** Block No. 93 Hexblock 5D + + + + + + + + + + + + + + + + +\ *** Block No. 94 Hexblock 5E + + + + + + + + + + + + + + + + +\ *** Block No. 95 Hexblock 5F + + + + + + + + + + + + + + + + +\ *** Block No. 96 Hexblock 60 + + + + + + + + + + + + + + + + +\ *** Block No. 97 Hexblock 61 + + + + + + + + + + + + + + + + +\ *** Block No. 98 Hexblock 62 + + + + + + + + + + + + + + + + +\ *** Block No. 99 Hexblock 63 + + + + + + + + + + + + + + + + +\ *** Block No. 100 Hexblock 64 + + + + + + + + + + + + + + + + +\ *** Block No. 101 Hexblock 65 + + + + + + + + + + + + + + + + +\ *** Block No. 102 Hexblock 66 + + + + + + + + + + + + + + + + +\ *** Block No. 103 Hexblock 67 + + + + + + + + + + + + + + + + +\ *** Block No. 104 Hexblock 68 + + + + + + + + + + + + + + + + +\ *** Block No. 105 Hexblock 69 + + + + + + + + + + + + + + + + +\ *** Block No. 106 Hexblock 6A + + + + + + + + + + + + + + + + +\ *** Block No. 107 Hexblock 6B + + + + + + + + + + + + + + + + +\ *** Block No. 108 Hexblock 6C + + + + + + + + + + + + + + + + +\ *** Block No. 109 Hexblock 6D + + + + + + + + + + + + + + + + +\ *** Block No. 110 Hexblock 6E + + + + + + + + + + + + + + + + +\ *** Block No. 111 Hexblock 6F + + + + + + + + + + + + + + + + +\ *** Block No. 112 Hexblock 70 + + + + + + + + + + + + + + + + +\ *** Block No. 113 Hexblock 71 + + + + + + + + + + + + + + + + +\ *** Block No. 114 Hexblock 72 + + + + + + + + + + + + + + + + +\ *** Block No. 115 Hexblock 73 + + + + + + + + + + + + + + + + +\ *** Block No. 116 Hexblock 74 + + + + + + + + + + + + + + + + +\ *** Block No. 117 Hexblock 75 + + + + + + + + + + + + + + + + +\ *** Block No. 118 Hexblock 76 + + + + + + + + + + + + + + + + +\ *** Block No. 119 Hexblock 77 + + + + + + + + + + + + + + + + +\ *** Block No. 120 Hexblock 78 + + + + + + + + + + + + + + + + +\ *** Block No. 121 Hexblock 79 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/serial.fb.src b/sources/msdos/serial.fb.src deleted file mode 100644 index 7e8b462..0000000 --- a/sources/msdos/serial.fb.src +++ /dev/null @@ -1,374 +0,0 @@ -Screen 0 not modified - 0 \ Serial interface for IBM-PC using 8250 chip cas 11nov05 - 1 - 2 INCLUDE SERIAL.FB will load code for COM1, - 3 2 LOADFROM SERIAL.FB for COM2 - 4 - 5 Bytes recieved will be buffered in a 128 Byte deep Queue - 6 by an interrupt Routine. - 7 - 8 The DTR Line will be used to signal that new bytes can be - 9 recieved. -10 The Sender will recognize CTS, a full Handshake is implemented -11 -12 Xon/Xoff Protocoll using ^S/^Q is _not_ implemented. -13 -14 Sender: TX? ( -- f ) TX ( -- char ) -15 Empf„nger: RX? ( -- f ) RX ( char -- ) -Screen 1 not modified - 0 \ Driver for IBM-PC Serial card using 8250 cas 11nov05 - 1 Onlyforth \needs Assembler 2 loadfrom asm.fb - 2 - 3 cr .( COM1: ) - 4 - 5 | $C 4 * Constant SINT@ \ absolute loc. of serial interrupt - 6 - 7 $3F8 >label Portadr - 8 - 9 | $10 Constant I_level \ 8259 priority -10 -11 2 7 +thru -12 -13 -14 -15 -Screen 2 not modified - 0 \ Driver for IBM-PC Serial card using 8250 cas 11nov05 - 1 Onlyforth \needs Assembler 2 loadfrom asm.fb - 2 - 3 cr .( COM2: ) - 4 - 5 | $B 4 * Constant SINT@ \ absolute loc. of serial interrupt - 6 - 7 $2F8 >label Portadr - 8 - 9 | 8 Constant I_level \ 8259 priority -10 -11 1 6 +thru -12 -13 -14 -15 -Screen 3 not modified - 0 \ Driver for IBM-PC Serial card using 8250 ks 11 mai 88 - 1 \ 3 .( 38.4 kbaud ) - 2 \ &6 .( 19.2 kbaud ) - 3 &12 .( 9.6 kbaud ) - 4 \ &24 .( 4.8 kbaud ) - 5 \ &96 .( 1200 baud ) - 6 >label baud - 7 - 8 $20 >label I_ctrl $21 >label I_mask \ 8259 addresses - 9 -10 Create Queue 0 , $80 allot -11 \ 0 1 2 130 byte address -12 \ | len | out |<-- 128 byte Queue -->| -13 \ len ::= number of characters queued -14 \ out ::= relativ address of next output character -15 \ (len+out)mod(128) ::= relative address of first empty byte -Screen 4 not modified - 0 \ transmit to 8250 ks 11 dez 87 - 1 - 2 Code tx? ( -- f ) D push Portadr 5 + # D mov - 3 D in D D xor $1020 # A and $1020 # A cmp - 4 0= ?[ D dec ]? Next end-code - 5 - 6 Code tx ( c -- ) D- A- xchg Portadr # D mov - 7 D byte out D pop Next end-code - 8 - 9 Code -dtr D push Portadr 4 + # D mov -10 D byte in $1E # A- and D byte out D pop Next -11 end-code -12 -13 Code +dtr D push Portadr 4 + # D mov -14 D byte in 1 # A- or D byte out D pop Next -15 end-code -Screen 5 not modified - 0 \ receive queue and interrupt service routine ks 11 dez 87 - 1 - 2 Label S_INT D push I push A push - 3 Portadr # D mov D byte in A- D+ mov - 4 Queue # I mov C: seg I ) A mov A- D- mov D- inc - 5 C: seg D- I ) mov A+ A- add $7F # A and A I add - 6 C: seg D+ 2 I D) mov $68 # D- cmp CS not - 7 ?[ Portadr 4 + # D mov - 8 D byte in $1E # A- and D byte out ]? \ -DTR - 9 $20 # A- mov I_ctrl #) byte out \ EOI for 8259 -10 A pop I pop D pop iret -11 end-code -12 -13 -14 -15 -Screen 6 not modified - 0 \ rx? rx ks 30 dez 87 - 1 - 2 Code rx? ( -- f ) D push D D xor - 3 Queue #) D- mov D- D- or 0= - 4 ?[ [[ D push Portadr 4 + # D mov \ +DTR - 5 D byte in 9 # A- or D byte out D pop - 6 swap ]? Next end-code - 7 - 8 Code rx ( -- 8b ) I W mov Queue # I mov - 9 D push D D xor cli lods A- A- or 0= not -10 ?[ A+ C- mov A- dec A+ inc $7F # A+ and -11 A -2 I D) mov D- C+ mov C I add I ) D- mov -12 ]? sti W I mov $18 # A- cmp CS not ?] Next -13 end-code -14 -15 -Screen 7 not modified - 0 \ Serial initialization ks 25 apr 86 - 1 - 2 | Code S_init D push D: push A A xor A D: mov C: A mov - 3 SINT@ # W mov S_INT # W ) mov A 2 W D) mov D: pop - 4 Portadr 3 + # D mov $80 # A- mov D byte out \ DLAB = 1 - 5 2 # D sub baud # A mov A- A+ xchg D byte out - 6 D dec A- A+ xchg D byte out \ baudrate - 7 3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT - 8 2 # D sub 1 # A- mov D byte out \ +rxINT - 9 I_mask #) byte in I_level Forth not Assembler # A- and -10 I_mask #) byte out D pop Next -11 end-code -12 -13 -14 -15 -Screen 8 not modified - 0 \ init bye ks 11 dez 87 - 1 \needs init : init ; - 2 - 3 : init init Queue off S_init ; init - 4 - 5 : bye 0 [ Portadr 1+ ] Literal pc! \ -rxINT - 6 0 [ Portadr 4 + ] Literal pc! \ -dtr/-rts/-out2 - 7 I_mask pc@ I_level or I_mask pc! bye ; - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 \ dumb terminal via 8250 ks 11 dez 87 - 1 - 2 Variable Fkeys Fkeys on - 3 - 4 | : ?rx ( -- ) pause rx? 0=exit rx - 5 Fkeys @ 0= IF emit ?cr exit THEN - 6 #LF case? IF cr exit THEN - 7 #CR case? IF Row 0 at exit THEN - 8 #BS case? IF del exit THEN emit ; - 9 -10 | : ?tx ( c -- ) BEGIN ?rx tx? UNTIL tx ; -11 -12 : dumb BEGIN BEGIN ?rx key? UNTIL key -13 $1B case? IF -dtr exit THEN ?tx REPEAT ; -14 -15 -Screen 10 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 11 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 12 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 13 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 14 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 15 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 16 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 17 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 18 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 19 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 20 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 21 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/serial.fth b/sources/msdos/serial.fth new file mode 100644 index 0000000..bad2109 --- /dev/null +++ b/sources/msdos/serial.fth @@ -0,0 +1,374 @@ +\ *** Block No. 0 Hexblock 0 +\ Serial interface for IBM-PC using 8250 chip cas 11nov05 + + INCLUDE SERIAL.FB will load code for COM1, + 2 LOADFROM SERIAL.FB for COM2 + +Bytes recieved will be buffered in a 128 Byte deep Queue +by an interrupt Routine. + +The DTR Line will be used to signal that new bytes can be +recieved. +The Sender will recognize CTS, a full Handshake is implemented + +Xon/Xoff Protocoll using ^S/^Q is _not_ implemented. + +Sender: TX? ( -- f ) TX ( -- char ) +Empf„nger: RX? ( -- f ) RX ( char -- ) +\ *** Block No. 1 Hexblock 1 +\ Driver for IBM-PC Serial card using 8250 cas 11nov05 + Onlyforth \needs Assembler 2 loadfrom asm.fb + +cr .( COM1: ) + +| $C 4 * Constant SINT@ \ absolute loc. of serial interrupt + + $3F8 >label Portadr + +| $10 Constant I_level \ 8259 priority + + 2 7 +thru + + + + +\ *** Block No. 2 Hexblock 2 +\ Driver for IBM-PC Serial card using 8250 cas 11nov05 + Onlyforth \needs Assembler 2 loadfrom asm.fb + +cr .( COM2: ) + +| $B 4 * Constant SINT@ \ absolute loc. of serial interrupt + + $2F8 >label Portadr + +| 8 Constant I_level \ 8259 priority + + 1 6 +thru + + + + +\ *** Block No. 3 Hexblock 3 +\ Driver for IBM-PC Serial card using 8250 ks 11 mai 88 +\ 3 .( 38.4 kbaud ) +\ &6 .( 19.2 kbaud ) + &12 .( 9.6 kbaud ) +\ &24 .( 4.8 kbaud ) +\ &96 .( 1200 baud ) + >label baud + + $20 >label I_ctrl $21 >label I_mask \ 8259 addresses + + Create Queue 0 , $80 allot +\ 0 1 2 130 byte address +\ | len | out |<-- 128 byte Queue -->| +\ len ::= number of characters queued +\ out ::= relativ address of next output character +\ (len+out)mod(128) ::= relative address of first empty byte +\ *** Block No. 4 Hexblock 4 +\ transmit to 8250 ks 11 dez 87 + + Code tx? ( -- f ) D push Portadr 5 + # D mov + D in D D xor $1020 # A and $1020 # A cmp + 0= ?[ D dec ]? Next end-code + + Code tx ( c -- ) D- A- xchg Portadr # D mov + D byte out D pop Next end-code + + Code -dtr D push Portadr 4 + # D mov + D byte in $1E # A- and D byte out D pop Next + end-code + + Code +dtr D push Portadr 4 + # D mov + D byte in 1 # A- or D byte out D pop Next + end-code +\ *** Block No. 5 Hexblock 5 +\ receive queue and interrupt service routine ks 11 dez 87 + + Label S_INT D push I push A push + Portadr # D mov D byte in A- D+ mov + Queue # I mov C: seg I ) A mov A- D- mov D- inc + C: seg D- I ) mov A+ A- add $7F # A and A I add + C: seg D+ 2 I D) mov $68 # D- cmp CS not + ?[ Portadr 4 + # D mov + D byte in $1E # A- and D byte out ]? \ -DTR + $20 # A- mov I_ctrl #) byte out \ EOI for 8259 + A pop I pop D pop iret + end-code + + + + +\ *** Block No. 6 Hexblock 6 +\ rx? rx ks 30 dez 87 + + Code rx? ( -- f ) D push D D xor + Queue #) D- mov D- D- or 0= + ?[ [[ D push Portadr 4 + # D mov \ +DTR + D byte in 9 # A- or D byte out D pop +swap ]? Next end-code + + Code rx ( -- 8b ) I W mov Queue # I mov + D push D D xor cli lods A- A- or 0= not + ?[ A+ C- mov A- dec A+ inc $7F # A+ and + A -2 I D) mov D- C+ mov C I add I ) D- mov + ]? sti W I mov $18 # A- cmp CS not ?] Next + end-code + + +\ *** Block No. 7 Hexblock 7 +\ Serial initialization ks 25 apr 86 + +| Code S_init D push D: push A A xor A D: mov C: A mov + SINT@ # W mov S_INT # W ) mov A 2 W D) mov D: pop + Portadr 3 + # D mov $80 # A- mov D byte out \ DLAB = 1 + 2 # D sub baud # A mov A- A+ xchg D byte out + D dec A- A+ xchg D byte out \ baudrate + 3 # D add $A07 # A mov D out \ 8bit, noP, +RTS +OUT + 2 # D sub 1 # A- mov D byte out \ +rxINT + I_mask #) byte in I_level Forth not Assembler # A- and + I_mask #) byte out D pop Next + end-code + + + + +\ *** Block No. 8 Hexblock 8 +\ init bye ks 11 dez 87 + \needs init : init ; + + : init init Queue off S_init ; init + + : bye 0 [ Portadr 1+ ] Literal pc! \ -rxINT + 0 [ Portadr 4 + ] Literal pc! \ -dtr/-rts/-out2 + I_mask pc@ I_level or I_mask pc! bye ; + + + + + + + + +\ *** Block No. 9 Hexblock 9 +\ dumb terminal via 8250 ks 11 dez 87 + + Variable Fkeys Fkeys on + +| : ?rx ( -- ) pause rx? 0=exit rx + Fkeys @ 0= IF emit ?cr exit THEN + #LF case? IF cr exit THEN + #CR case? IF Row 0 at exit THEN + #BS case? IF del exit THEN emit ; + +| : ?tx ( c -- ) BEGIN ?rx tx? UNTIL tx ; + + : dumb BEGIN BEGIN ?rx key? UNTIL key + $1B case? IF -dtr exit THEN ?tx REPEAT ; + + +\ *** Block No. 10 Hexblock A + + + + + + + + + + + + + + + + +\ *** Block No. 11 Hexblock B + + + + + + + + + + + + + + + + +\ *** Block No. 12 Hexblock C + + + + + + + + + + + + + + + + +\ *** Block No. 13 Hexblock D + + + + + + + + + + + + + + + + +\ *** Block No. 14 Hexblock E + + + + + + + + + + + + + + + + +\ *** Block No. 15 Hexblock F + + + + + + + + + + + + + + + + +\ *** Block No. 16 Hexblock 10 + + + + + + + + + + + + + + + + +\ *** Block No. 17 Hexblock 11 + + + + + + + + + + + + + + + + +\ *** Block No. 18 Hexblock 12 + + + + + + + + + + + + + + + + +\ *** Block No. 19 Hexblock 13 + + + + + + + + + + + + + + + + +\ *** Block No. 20 Hexblock 14 + + + + + + + + + + + + + + + + +\ *** Block No. 21 Hexblock 15 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/stream.fb.src b/sources/msdos/stream.fb.src deleted file mode 100644 index 633c909..0000000 --- a/sources/msdos/stream.fb.src +++ /dev/null @@ -1,187 +0,0 @@ -Screen 0 not modified - 0 \ cas 11nov05 - 1 The word STREAM>BLK convert a sequiential file with CR lineend - 2 into a screenfile with 64 Chars per line. - 3 - 4 Example: - 5 FORTH.TXT is a Forth-Sourceode in a sequiential file - 6 - 7 MAKEFILE FORTH.FB will create an empty screenfile - 8 FROM FORTH.TXT will define the inputfile - 9 STREAM>BLK will convert FORTH.TXT into FORTH.FB -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ ks 06 jul 88 - 1 Onlyforth Dos also - 2 - 3 | : in ( -- fcb ) fromfile @ ; - 4 | : out ( -- fcb ) isfile @ ; - 5 - 6 | : padd ( cnt -- ) dup IF c/l mod ?dup 0=exit THEN - 7 c/l swap ?DO BL out fputc LOOP ; - 8 - 9 | : skipctrl ( -- char ) -10 BEGIN in fgetc dup #cr = ?exit -11 dup 0 BL uwithin 0=exit drop REPEAT ; -12 -13 2 3 thru -14 -15 Onlyforth -Screen 2 not modified - 0 \ ks 06 jul 88 - 1 - 2 | : lastline? ( -- f ) false 0 skipctrl - 3 BEGIN -1 case? IF ?dup IF padd THEN 0= exit THEN - 4 #cr case? 0= WHILE out fputc 1+ in fgetc REPEAT - 5 padd ; - 6 - 7 : stream>blk open out freset - 8 out f.size 2@ out fseek \ append to end of file - 9 BEGIN lastline? stop? or UNTIL close out fclose ; -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 \ absolute blocks in file eintragen ks 11 aug 87 - 1 - 2 | : >stream ( blk -- ) - 3 fromfile @ (block b/blk bounds - 4 DO ds@ I C/L -trailing out lfputs - 5 #cr out fputc #lf out fputc C/L +LOOP ; - 6 - 7 : blk>stream ( from.blk to.blk -- ) emptyfile - 8 1+ swap DO I >stream LOOP close ; - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 5 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 6 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 7 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 8 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 9 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 10 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/stream.fth b/sources/msdos/stream.fth new file mode 100644 index 0000000..bf4cd9c --- /dev/null +++ b/sources/msdos/stream.fth @@ -0,0 +1,187 @@ +\ *** Block No. 0 Hexblock 0 +\ cas 11nov05 +The word STREAM>BLK convert a sequiential file with CR lineend +into a screenfile with 64 Chars per line. + +Example: +FORTH.TXT is a Forth-Sourceode in a sequiential file + +MAKEFILE FORTH.FB will create an empty screenfile +FROM FORTH.TXT will define the inputfile +STREAM>BLK will convert FORTH.TXT into FORTH.FB + + + + + + +\ *** Block No. 1 Hexblock 1 +\ ks 06 jul 88 + Onlyforth Dos also + +| : in ( -- fcb ) fromfile @ ; +| : out ( -- fcb ) isfile @ ; + +| : padd ( cnt -- ) dup IF c/l mod ?dup 0=exit THEN + c/l swap ?DO BL out fputc LOOP ; + +| : skipctrl ( -- char ) + BEGIN in fgetc dup #cr = ?exit + dup 0 BL uwithin 0=exit drop REPEAT ; + + 2 3 thru + + Onlyforth +\ *** Block No. 2 Hexblock 2 +\ ks 06 jul 88 + +| : lastline? ( -- f ) false 0 skipctrl + BEGIN -1 case? IF ?dup IF padd THEN 0= exit THEN + #cr case? 0= WHILE out fputc 1+ in fgetc REPEAT + padd ; + + : stream>blk open out freset + out f.size 2@ out fseek \ append to end of file + BEGIN lastline? stop? or UNTIL close out fclose ; + + + + + + +\ *** Block No. 3 Hexblock 3 +\ absolute blocks in file eintragen ks 11 aug 87 + +| : >stream ( blk -- ) + fromfile @ (block b/blk bounds + DO ds@ I C/L -trailing out lfputs + #cr out fputc #lf out fputc C/L +LOOP ; + + : blk>stream ( from.blk to.blk -- ) emptyfile + 1+ swap DO I >stream LOOP close ; + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + +\ *** Block No. 5 Hexblock 5 + + + + + + + + + + + + + + + + +\ *** Block No. 6 Hexblock 6 + + + + + + + + + + + + + + + + +\ *** Block No. 7 Hexblock 7 + + + + + + + + + + + + + + + + +\ *** Block No. 8 Hexblock 8 + + + + + + + + + + + + + + + + +\ *** Block No. 9 Hexblock 9 + + + + + + + + + + + + + + + + +\ *** Block No. 10 Hexblock A + + + + + + + + + + + + + + + + diff --git a/sources/msdos/tasker.fb.src b/sources/msdos/tasker.fb.src deleted file mode 100644 index d3c5351..0000000 --- a/sources/msdos/tasker.fb.src +++ /dev/null @@ -1,85 +0,0 @@ -Screen 0 not modified - 0 \ ks 22 dez 87 - 1 The multitasker is a simple yet powerful round robin scheme - 2 with explicit task switching. This has the major advantage - 3 that the system switches tasks only in known states. - 4 Hence the difficulties in synchronizing tasks and locking - 5 critical portions of code are greatly minimized or simply - 6 do not exist at all. - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Multitasker loadscreen ks 03 apr 88 - 1 Onlyforth \needs Assembler 2 loadfrom asm.scr - 2 - 3 Code stop $E990 # U ) mov ' pause @ # jmp end-code - 4 - 5 : singletask [ ' noop @ ] Literal ['] pause ! ; - 6 : multitask [ ' pause @ ] Literal ['] pause ! ; - 7 - 8 1 3 +thru .( Multitasker geladen) cr - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ pass activate ks 1 jun 87 - 1 - 2 : pass ( n0 ... nr-1 Taddr r -- ) - 3 BEGIN [ rot ] - 4 swap $E9CD over ! \ awake Task - 5 r> -rot \ Stack: IP r addr - 6 8 + >r \ s0 of Task - 7 r@ 2+ @ swap \ Stack: IP r0 r - 8 2+ 2* \ bytes on Taskstack incl. r0 & IP - 9 r@ @ over - \ new SP -10 dup r> 2- ! \ into Ssave -11 swap bounds ?DO I ! 2 +LOOP ; restrict -12 -13 : activate ( Taddr -- ) 0 \ [ ' pass >body ] Literal >r ; -14 [ -rot ] REPEAT ; restrict -15 -Screen 3 not modified - 0 ( Building a Task ks 8 may 84 ) - 1 - 2 | : taskerror ( string -- ) standardi/o singletask - 3 ." Task error: " count type multitask stop ; - 4 - 5 : sleep ( addr -- ) $90 swap c! ; - 6 - 7 : wake ( addr -- ) $CD swap c! ; - 8 - 9 : rendezvous ( semaphoraddr -- ) -10 dup unlock pause lock ; -11 -12 -13 -14 -15 -Screen 4 not modified - 0 \ Task ks 1 jun 87 - 1 - 2 : Task ( rlen slen -- ) clear - 3 0 Constant here 2- >r \ addr of task constant - 4 here -rot \ here for Task dp - 5 even allot even \ allot dictionary area - 6 here r> ! \ set task constant addr - 7 up@ here $100 cmove \ init user area - 8 here $E990 , \ JMP opcode - 9 up@ 2+ dup dup @ + here - , -10 2dup - 2- swap ! \ link task -11 0 , dup 2- dup , , \ ssave and s0 -12 2dup + , \ here + rlen = r0 -13 rot , \ dp -14 under + dp ! 0 , \ allot rstack -15 ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; diff --git a/sources/msdos/tasker.fth b/sources/msdos/tasker.fth new file mode 100644 index 0000000..e8e23df --- /dev/null +++ b/sources/msdos/tasker.fth @@ -0,0 +1,85 @@ +\ *** Block No. 0 Hexblock 0 +\ ks 22 dez 87 +The multitasker is a simple yet powerful round robin scheme +with explicit task switching. This has the major advantage +that the system switches tasks only in known states. +Hence the difficulties in synchronizing tasks and locking +critical portions of code are greatly minimized or simply +do not exist at all. + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Multitasker loadscreen ks 03 apr 88 + Onlyforth \needs Assembler 2 loadfrom asm.scr + + Code stop $E990 # U ) mov ' pause @ # jmp end-code + + : singletask [ ' noop @ ] Literal ['] pause ! ; + : multitask [ ' pause @ ] Literal ['] pause ! ; + + 1 3 +thru .( Multitasker geladen) cr + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ pass activate ks 1 jun 87 + + : pass ( n0 ... nr-1 Taddr r -- ) +BEGIN [ rot ] + swap $E9CD over ! \ awake Task + r> -rot \ Stack: IP r addr + 8 + >r \ s0 of Task + r@ 2+ @ swap \ Stack: IP r0 r + 2+ 2* \ bytes on Taskstack incl. r0 & IP + r@ @ over - \ new SP + dup r> 2- ! \ into Ssave + swap bounds ?DO I ! 2 +LOOP ; restrict + + : activate ( Taddr -- ) 0 \ [ ' pass >body ] Literal >r ; +[ -rot ] REPEAT ; restrict + +\ *** Block No. 3 Hexblock 3 +( Building a Task ks 8 may 84 ) + +| : taskerror ( string -- ) standardi/o singletask + ." Task error: " count type multitask stop ; + + : sleep ( addr -- ) $90 swap c! ; + + : wake ( addr -- ) $CD swap c! ; + + : rendezvous ( semaphoraddr -- ) + dup unlock pause lock ; + + + + + +\ *** Block No. 4 Hexblock 4 +\ Task ks 1 jun 87 + + : Task ( rlen slen -- ) clear + 0 Constant here 2- >r \ addr of task constant + here -rot \ here for Task dp + even allot even \ allot dictionary area + here r> ! \ set task constant addr + up@ here $100 cmove \ init user area + here $E990 , \ JMP opcode + up@ 2+ dup dup @ + here - , + 2dup - 2- swap ! \ link task + 0 , dup 2- dup , , \ ssave and s0 + 2dup + , \ here + rlen = r0 + rot , \ dp + under + dp ! 0 , \ allot rstack + ['] taskerror [ ' errorhandler >body c@ ] Literal rot + ! ; diff --git a/sources/msdos/tester.fth b/sources/msdos/tester.fth new file mode 100644 index 0000000..06c79ea --- /dev/null +++ b/sources/msdos/tester.fth @@ -0,0 +1,136 @@ +\ *** Block No. 0 Hexblock 0 +\ ANS Forth Compatibility Tester cas 25jun20 + +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST + +\ (C)1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE +\ REMAINS. +\ VERSION 1.2 + + + + + + +\ *** Block No. 1 Hexblock 1 +\ ANS Forth Compatibility Tester cas 25jun20 + +: \vf [compile] \ ; immediate + +1 5 +thru .( ANS Forth Tester Loaded ... ) + + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ Test Unit Tools cas 25jun20 + +HEX + +\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; +\ THIS MAY +\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. +VARIABLE VERBOSE + FALSE VERBOSE ! + +\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. +: EMPTY-STACK + DEPTH ?DUP IF DUP 0< IF + NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN + THEN ; + +\ *** Block No. 3 Hexblock 3 +\ Unit Test Tools cas 25jun20 + +VARIABLE #ERRORS 0 #ERRORS ! + +\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY +\ THE LINE THAT HAD THE ERROR. + +: ERROR + CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR + EMPTY-STACK \ THROW AWAY EVERY THING ELSE + #ERRORS @ 1 + #ERRORS ! + \ QUIT \ *** Uncomment this line to QUIT on an error +; + + + +\ *** Block No. 4 Hexblock 4 +\ Unit Test Tools cas 25jun20 + +VARIABLE ACTUAL-DEPTH \ STACK RECORD +CREATE ACTUAL-RESULTS 20 CELLS ALLOT + +: T{ \ ( -- ) SYNTACTIC SUGAR. + ; + +: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. + DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH + ?DUP IF \ IF THERE IS SOMETHING ON STACK + 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM + THEN ; + + + +\ *** Block No. 5 Hexblock 5 +\ Unit Test Tools cas 25jun20 + +\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED +\ (ACTUAL) CONTENTS. +: }T + DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH + DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE + \ STACK + 0 DO \ FOR EACH STACK ITEM + ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN + LOOP + THEN +ELSE \ DEPTH MISMATCH + S" WRONG NUMBER OF RESULTS: " ERROR +THEN ; +\ *** Block No. 6 Hexblock 6 +\ Unit Test Tools cas 25jun20 + +: TESTING \ ( -- ) TALKING COMMENT. + SOURCE VERBOSE @ + IF DUP >R TYPE CR R> >IN ! + ELSE >IN ! DROP [CHAR] * EMIT + THEN ; + + + + + + + + + +\ *** Block No. 7 Hexblock 7 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/timer.fb.src b/sources/msdos/timer.fb.src deleted file mode 100644 index c72cdf8..0000000 --- a/sources/msdos/timer.fb.src +++ /dev/null @@ -1,85 +0,0 @@ -Screen 0 not modified - 0 \ ks 22 dez 87 - 1 - 2 The timer utilizes the memory cell at $46C that is incremented - 3 by an interrupt. A couple of words allow this timer to be - 4 used for time delays. - 5 - 6 time-of-day and date are accessed via MS-DOS calls. - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ BIMomat BIOS Timer ks 03 apr 88 - 1 Onlyforth \needs Assembler 2 loadfrom asm.scr - 2 - 3 $46C >label Counter - 4 - 5 \ 1193180 / 65536 = 18,206 Hz - 6 - 7 1 2 +thru .( Timer geladen) cr - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ BIMomat BIOS Timer ks 22 dez 87 - 1 - 2 Code ticks ( -- n ) D push D: C mov A A xor - 3 A D: mov Counter #) D mov C D: mov Next end-code - 4 - 5 : timeout? ( ticks -- ticks f ) pause dup ticks - 0< ; - 6 - 7 : till ( n -- ) BEGIN timeout? UNTIL drop ; - 8 - 9 : time ( n -- time ) ticks + ; -10 -11 : wait ( n -- ) time till ; -12 -13 : seconds ( sec -- ticks ) &18206 &1000 */ ; -14 -15 : minutes ( min -- ticks ) &1092 * ; -Screen 3 not modified - 0 \ MS-DOS time and date ks 22 dez 87 - 1 - 2 Code date@ ( -- dd mm yy ) - 3 D push $2A # A+ mov $21 int A A xor D+ A- xchg - 4 D push A push C D mov &1900 # D sub Next - 5 end-code - 6 - 7 Code time@ ( -- ss mm hh ) - 8 D push $2C # A+ mov $21 int D+ D- mov 0 # D+ mov - 9 D push D+ D- mov C+ D- xchg C push Next -10 end-code -11 -12 -13 -14 -15 -Screen 4 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/timer.fth b/sources/msdos/timer.fth new file mode 100644 index 0000000..2bee657 --- /dev/null +++ b/sources/msdos/timer.fth @@ -0,0 +1,85 @@ +\ *** Block No. 0 Hexblock 0 +\ ks 22 dez 87 + +The timer utilizes the memory cell at $46C that is incremented +by an interrupt. A couple of words allow this timer to be +used for time delays. + +time-of-day and date are accessed via MS-DOS calls. + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ BIMomat BIOS Timer ks 03 apr 88 + Onlyforth \needs Assembler 2 loadfrom asm.scr + + $46C >label Counter + +\ 1193180 / 65536 = 18,206 Hz + + 1 2 +thru .( Timer geladen) cr + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ BIMomat BIOS Timer ks 22 dez 87 + + Code ticks ( -- n ) D push D: C mov A A xor + A D: mov Counter #) D mov C D: mov Next end-code + + : timeout? ( ticks -- ticks f ) pause dup ticks - 0< ; + + : till ( n -- ) BEGIN timeout? UNTIL drop ; + + : time ( n -- time ) ticks + ; + + : wait ( n -- ) time till ; + + : seconds ( sec -- ticks ) &18206 &1000 */ ; + + : minutes ( min -- ticks ) &1092 * ; +\ *** Block No. 3 Hexblock 3 +\ MS-DOS time and date ks 22 dez 87 + + Code date@ ( -- dd mm yy ) + D push $2A # A+ mov $21 int A A xor D+ A- xchg + D push A push C D mov &1900 # D sub Next + end-code + + Code time@ ( -- ss mm hh ) + D push $2C # A+ mov $21 int D+ D- mov 0 # D+ mov + D push D+ D- mov C+ D- xchg C push Next + end-code + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/tools.fb.src b/sources/msdos/tools.fb.src deleted file mode 100644 index 4156d7f..0000000 --- a/sources/msdos/tools.fb.src +++ /dev/null @@ -1,221 +0,0 @@ -Screen 0 not modified - 0 \ ks 22 dez 87 - 1 - 2 Some simple tools for debugging. - 3 A state-of-the-art, interactive single step tracer - 4 and a couple of tools for decompiling and dumping - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ Programming-Tools word set cas 19july2020 - 1 Onlyforth \needs Assembler 2 loadfrom asm.fb - 2 - 3 Vocabulary Tools Tools also definitions - 4 - 5 1 11 +thru Onlyforth .( Tools loaded ) cr - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 2 not modified - 0 \ trace - next ks 11 jun 87 - 1 - 2 | Variable nest? nest? off - 3 - 4 Label tracenext 0 # nest? #) byte cmp 0= - 5 ?[ $5555 # I cmp here 2- >label (ip >= - 6 ?[ [[ swap lods A W xchg W ) jmp ]? - 7 $5555 # I cmp here 2- >label ip) CS ?] - 8 ][ 0 # nest? #) byte mov - 9 ]? $5555 # W mov here 2- >label >tracing W ) jmp -10 end-code -11 -12 | (ip Constant -13 -14 | : (debug ( addr -- ) dup ! ; -Screen 3 not modified - 0 \ install Tracer ks 11 jun 87 - 1 - 2 Label (do-trace next-link # W mov D push - 3 $E9 # A- mov tracenext 1+ # C mov - 4 [[ W ) W mov W W or 0= not - 5 ?[[ A- -4 W D) mov C D mov W D sub - 6 D -3 W D) mov ]]? D pop ret end-code - 7 - 8 Code do-trace (do-trace # call Next end-code - 9 -10 ' end-trace Alias end-trace -11 -12 | Code (step (do-trace # call -13 R ) I mov R inc R inc lods A W xchg W ) jmp -14 -15 | Create: nextstep (step ; -Screen 4 not modified - 0 \ tracer display ks 20 sep 88 - 1 - 2 | Variable nest# nest# off - 3 - 4 | Variable 'ip 'ip off - 5 - 6 | Create: -nest r> ip> ! r> r0 ! r> dup #tib ! -12 rp@ over tib swap cmove rp@ + rp! -13 r> Is parser r> adr 'quit ! r> >in ! -14 r> blk ! r> state ! r> output ! r> input ! ; -15 -Screen 5 not modified - 0 \ tracer display ks 16 sep 88 - 1 - 2 | : tracing end-trace nest? @ - 3 IF r> r ip> @ >r -nest >r >r - 4 1 nest# +! r@ 2- (debug nest? off THEN r@ 'ip ! - 5 nextstep >r input @ >r output @ >r state @ >r - 6 blk @ >r >in @ >r adr 'quit @ >r adr parser @ >r - 7 tib #tib @ rp@ over - under rp! cmove #tib @ >r - 8 r0 @ >r rp@ r0 ! standardi/o - 9 cr nest# @ spaces 'ip @ dup 5 u.r @ dup 5 u.r -10 2 spaces >name .name &30 nest# @ + tab .s -11 $20 allot ['] oneline Is 'quit quit ; -12 ' tracing >tracing ! -13 -14 -15 -Screen 6 not modified - 0 \ test traceability ks 07 dez 87 - 1 - 2 | : traceable ( cfa -- cfa' ) recursive dup @ - 3 [ ' : @ ] Literal case? ?exit - 4 [ ' key @ ] Literal case? IF >body c@ Input @ + - 5 @ traceable exit THEN - 6 [ ' type @ ] Literal case? IF >body c@ Output @ + - 7 @ traceable exit THEN - 8 [ ' r/w @ ] Literal case? IF >body @ traceable exit THEN - 9 c@ $E9 = IF @ 1+ exit THEN \ Does> word -10 >name .name ." can't be DEBUGged" quit ; -11 -12 -13 -14 -15 -Screen 7 not modified - 0 \ user words for tracing ks 16 sep 88 - 1 | : do_debug ( addr -- ) - 2 traceable (debug nest? off nest# off do-trace ; - 3 - 4 : nest \ trace next high-level word executed - 5 'ip @ @ traceable drop nest? on ; - 6 - 7 : unnest \ ends tracing of actual word - 8 off ; unnest \ clears trap range - 9 -10 : endloop \ stop tracing loop -11 'ip @ r do_debug r> execute end-trace unnest ; -Screen 8 not modified - 0 \ tools for decompiling, interactive use ks 04 jul 87 - 1 - 2 | : ?: ( addr -- addr ) dup 5 u.r ." :" ; - 3 | : @? ( addr -- addr ) dup @ 6 u.r ; - 4 | : c? ( addr -- addr ) dup c@ 3 .r ; - 5 | : end $28 tab ; - 6 - 7 : s ( addr1 -- addr2 ) - 8 ?: 3 spaces c? 2 spaces count 2dup type + even end ; - 9 : n ( addr1 -- addr2 ) -10 ?: @? 2 spaces dup @ >name .name 2+ end ; -11 : d ( addr1 n -- addr2 ) 2dup swap ?: 3 spaces -12 swap 0 DO c? 1+ LOOP 2 spaces -rot type end ; -13 : l ( addr1 -- addr2 ) ?: 6 spaces @? 2+ end ; -14 : c ( addr1 -- addr2 ) 1 d end ; -15 : b ( addr1 -- addr2 ) ?: @? dup @ over + 6 u.r 2+ end ; -Screen 9 not modified - 0 \ often times ks 29 jun 87 - 1 Onlyforth - 2 - 3 : often stop? ?exit >in off ; - 4 - 5 | Variable #times #times off - 6 - 7 : times ( n -- ) ?dup - 8 IF #times @ 2+ u< stop? or - 9 IF #times off exit THEN 1 #times +! -10 ELSE stop? ?exit -11 THEN >in off ; -12 -13 -14 -15 -Screen 10 not modified - 0 \ dump ks 04 jul 87 - 1 - 2 : dump ( addr n -- ) base push hex - 3 bounds ?DO cr I $10 [ Tools ] d [ Forth ] drop - 4 stop? IF LEAVE THEN $10 +LOOP ; - 5 - 6 | : ld ( seg:addr -- ) - 7 over 4 u.r ." :" dup 0 <# # # # # #> type - 8 3 spaces ds@ pad $10 lmove pad $10 bounds - 9 DO I c@ 3 u.r LOOP 2 spaces pad $10 type ; -10 -11 : ldump ( seg:addr quan -- ) base push hex -12 0 DO cr 2dup ld $10 + stop? IF LEAVE THEN -13 $10 +LOOP 2drop ; -14 -15 -Screen 11 not modified - 0 \ N>R NR> cr - 1 - 2 : N>R ( i * n +n -- ) ( R: -- j * x +n ) - 3 \ Transfer N items and count to the return stack. - 4 DUP BEGIN DUP WHILE - 5 ROT R> SWAP >R >R - 6 1- - 7 REPEAT DROP R> SWAP >R >R ; - 8 - 9 : NR> ( -- i * x +n ) ( R: j * x +n -- ) -10 \ Pull N items and count off the return stack. -11 R> R> SWAP >R DUP -12 BEGIN DUP WHILE -13 R> R> SWAP >R -ROT -14 1- -15 REPEAT DROP ; -Screen 12 not modified - 0 \ ? - 1 : ? ( a-addr -- ) - 2 \ Display the value stored at a-addr. - 3 @ . ; - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/sources/msdos/tools.fth b/sources/msdos/tools.fth new file mode 100644 index 0000000..38aa4e3 --- /dev/null +++ b/sources/msdos/tools.fth @@ -0,0 +1,221 @@ +\ *** Block No. 0 Hexblock 0 +\ ks 22 dez 87 + +Some simple tools for debugging. +A state-of-the-art, interactive single step tracer +and a couple of tools for decompiling and dumping + + + + + + + + + + + +\ *** Block No. 1 Hexblock 1 +\ Programming-Tools word set cas 19july2020 + Onlyforth \needs Assembler 2 loadfrom asm.fb + + Vocabulary Tools Tools also definitions + + 1 11 +thru Onlyforth .( Tools loaded ) cr + + + + + + + + + + +\ *** Block No. 2 Hexblock 2 +\ trace - next ks 11 jun 87 + +| Variable nest? nest? off + + Label tracenext 0 # nest? #) byte cmp 0= + ?[ $5555 # I cmp here 2- >label (ip >= + ?[ [[ swap lods A W xchg W ) jmp ]? + $5555 # I cmp here 2- >label ip) CS ?] + ][ 0 # nest? #) byte mov + ]? $5555 # W mov here 2- >label >tracing W ) jmp + end-code + +| (ip Constant + +| : (debug ( addr -- ) dup ! ; +\ *** Block No. 3 Hexblock 3 +\ install Tracer ks 11 jun 87 + + Label (do-trace next-link # W mov D push + $E9 # A- mov tracenext 1+ # C mov + [[ W ) W mov W W or 0= not + ?[[ A- -4 W D) mov C D mov W D sub + D -3 W D) mov ]]? D pop ret end-code + + Code do-trace (do-trace # call Next end-code + + ' end-trace Alias end-trace + +| Code (step (do-trace # call + R ) I mov R inc R inc lods A W xchg W ) jmp + +| Create: nextstep (step ; +\ *** Block No. 4 Hexblock 4 +\ tracer display ks 20 sep 88 + +| Variable nest# nest# off + +| Variable 'ip 'ip off + +| Create: -nest r> ip> ! r> r0 ! r> dup #tib ! + rp@ over tib swap cmove rp@ + rp! + r> Is parser r> adr 'quit ! r> >in ! + r> blk ! r> state ! r> output ! r> input ! ; + +\ *** Block No. 5 Hexblock 5 +\ tracer display ks 16 sep 88 + +| : tracing end-trace nest? @ + IF r> r ip> @ >r -nest >r >r + 1 nest# +! r@ 2- (debug nest? off THEN r@ 'ip ! + nextstep >r input @ >r output @ >r state @ >r + blk @ >r >in @ >r adr 'quit @ >r adr parser @ >r + tib #tib @ rp@ over - under rp! cmove #tib @ >r + r0 @ >r rp@ r0 ! standardi/o + cr nest# @ spaces 'ip @ dup 5 u.r @ dup 5 u.r + 2 spaces >name .name &30 nest# @ + tab .s + $20 allot ['] oneline Is 'quit quit ; + ' tracing >tracing ! + + + +\ *** Block No. 6 Hexblock 6 +\ test traceability ks 07 dez 87 + +| : traceable ( cfa -- cfa' ) recursive dup @ + [ ' : @ ] Literal case? ?exit + [ ' key @ ] Literal case? IF >body c@ Input @ + + @ traceable exit THEN + [ ' type @ ] Literal case? IF >body c@ Output @ + + @ traceable exit THEN + [ ' r/w @ ] Literal case? IF >body @ traceable exit THEN + c@ $E9 = IF @ 1+ exit THEN \ Does> word + >name .name ." can't be DEBUGged" quit ; + + + + + +\ *** Block No. 7 Hexblock 7 +\ user words for tracing ks 16 sep 88 +| : do_debug ( addr -- ) + traceable (debug nest? off nest# off do-trace ; + + : nest \ trace next high-level word executed + 'ip @ @ traceable drop nest? on ; + + : unnest \ ends tracing of actual word + off ; unnest \ clears trap range + + : endloop \ stop tracing loop + 'ip @ r do_debug r> execute end-trace unnest ; +\ *** Block No. 8 Hexblock 8 +\ tools for decompiling, interactive use ks 04 jul 87 + +| : ?: ( addr -- addr ) dup 5 u.r ." :" ; +| : @? ( addr -- addr ) dup @ 6 u.r ; +| : c? ( addr -- addr ) dup c@ 3 .r ; +| : end $28 tab ; + + : s ( addr1 -- addr2 ) + ?: 3 spaces c? 2 spaces count 2dup type + even end ; + : n ( addr1 -- addr2 ) + ?: @? 2 spaces dup @ >name .name 2+ end ; + : d ( addr1 n -- addr2 ) 2dup swap ?: 3 spaces + swap 0 DO c? 1+ LOOP 2 spaces -rot type end ; + : l ( addr1 -- addr2 ) ?: 6 spaces @? 2+ end ; + : c ( addr1 -- addr2 ) 1 d end ; + : b ( addr1 -- addr2 ) ?: @? dup @ over + 6 u.r 2+ end ; +\ *** Block No. 9 Hexblock 9 +\ often times ks 29 jun 87 + Onlyforth + + : often stop? ?exit >in off ; + +| Variable #times #times off + + : times ( n -- ) ?dup + IF #times @ 2+ u< stop? or + IF #times off exit THEN 1 #times +! + ELSE stop? ?exit + THEN >in off ; + + + + +\ *** Block No. 10 Hexblock A +\ dump ks 04 jul 87 + + : dump ( addr n -- ) base push hex + bounds ?DO cr I $10 [ Tools ] d [ Forth ] drop + stop? IF LEAVE THEN $10 +LOOP ; + +| : ld ( seg:addr -- ) + over 4 u.r ." :" dup 0 <# # # # # #> type + 3 spaces ds@ pad $10 lmove pad $10 bounds + DO I c@ 3 u.r LOOP 2 spaces pad $10 type ; + + : ldump ( seg:addr quan -- ) base push hex + 0 DO cr 2dup ld $10 + stop? IF LEAVE THEN + $10 +LOOP 2drop ; + + +\ *** Block No. 11 Hexblock B +\ N>R NR> cr + +: N>R ( i * n +n -- ) ( R: -- j * x +n ) +\ Transfer N items and count to the return stack. + DUP BEGIN DUP WHILE + ROT R> SWAP >R >R + 1- + REPEAT DROP R> SWAP >R >R ; + +: NR> ( -- i * x +n ) ( R: j * x +n -- ) +\ Pull N items and count off the return stack. + R> R> SWAP >R DUP + BEGIN DUP WHILE + R> R> SWAP >R -ROT + 1- + REPEAT DROP ; +\ *** Block No. 12 Hexblock C +\ ? +: ? ( a-addr -- ) +\ Display the value stored at a-addr. + @ . ; + + + + + + + + + + + + diff --git a/sources/msdos/volks4th.fth b/sources/msdos/volks4th.fth new file mode 100644 index 0000000..2956068 --- /dev/null +++ b/sources/msdos/volks4th.fth @@ -0,0 +1,85 @@ +\ *** Block No. 0 Hexblock 0 +\\ Startup: Load Standard System cas 10nov05 + +This file contains commands to create a full volksFORTH from the +KERNEL.COM file. + +The new system will be saved as "VOLKS4TH.COM". + +If needed this file must be adapted with the simple editor in +MINIMAL.COM to create a volksFORTH that can work with not +100% compatible display hardware. + + + + + + +\ *** Block No. 1 Hexblock 1 +\ System LOAD-Screen for MS-DOS volksFORTH cas 19jun20 + Onlyforth warning off + + include asm.fb + include extend.fb + include multi.vid + include dos.fb + include tasker.fb + include timer.fb + include tools.fb + include editor.fb + include graphic.prn + + warning on clear status on .status + savesystem volks4th.com bell + .( new system saved as VOLKS4TH.COM ) cr +\ *** Block No. 2 Hexblock 2 + + + + + + + + + + + + + + + + +\ *** Block No. 3 Hexblock 3 + + + + + + + + + + + + + + + + +\ *** Block No. 4 Hexblock 4 + + + + + + + + + + + + + + + + diff --git a/sources/msdos/volks4th.sys.src b/sources/msdos/volks4th.sys.src deleted file mode 100644 index 2f3f259..0000000 --- a/sources/msdos/volks4th.sys.src +++ /dev/null @@ -1,85 +0,0 @@ -Screen 0 not modified - 0 \\ Startup: Load Standard System cas 10nov05 - 1 - 2 This file contains commands to create a full volksFORTH from the - 3 KERNEL.COM file. - 4 - 5 The new system will be saved as "VOLKS4TH.COM". - 6 - 7 If needed this file must be adapted with the simple editor in - 8 MINIMAL.COM to create a volksFORTH that can work with not - 9 100% compatible display hardware. -10 -11 -12 -13 -14 -15 -Screen 1 not modified - 0 \ System LOAD-Screen for MS-DOS volksFORTH cas 19jun20 - 1 Onlyforth warning off - 2 - 3 include asm.fb - 4 include extend.fb - 5 include multi.vid - 6 include dos.fb - 7 include tasker.fb - 8 include timer.fb - 9 include tools.fb -10 include editor.fb -11 include graphic.prn -12 -13 warning on clear status on .status -14 savesystem volks4th.com bell -15 .( new system saved as VOLKS4TH.COM ) cr -Screen 2 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 3 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 -Screen 4 not modified - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 -10 -11 -12 -13 -14 -15 diff --git a/tools/dumpblock.fth b/tools/dumpblock.fth new file mode 100755 index 0000000..eb2e1d0 --- /dev/null +++ b/tools/dumpblock.fth @@ -0,0 +1,14 @@ +: fb2fth ( u -- ) + dup scr ! + ." \ *** Block No. " base @ decimal scr @ dup . ." Hexblock " hex . base ! cr + l/s 0 ?do + scr @ block i c/l * chars + c/l type cr + loop ; + +: bdump 0 do i fb2fth loop ; + +get-block-fid file-size drop drop 1024 / +bdump + +bye + diff --git a/tools/dumpblock.sh b/tools/dumpblock.sh index c507968..76e721a 100755 --- a/tools/dumpblock.sh +++ b/tools/dumpblock.sh @@ -1,6 +1,6 @@ #!/bin/sh # small tool to dump all screens of a block-file -# on screen. Used to create source files for fossil +# on screen. Used to create source files for git/fossil # checkin. Depends on GNU-Forth (gforth) -gforth -e ": bdump 0 do i list loop ; use $1 get-block-fid file-size drop drop 1024 / bdump bye" +gforth -e "use ${1} require dumpblock.fth" diff --git a/tools/gensourcefiles.sh b/tools/gensourcefiles.sh index ffffd79..de1442e 100755 --- a/tools/gensourcefiles.sh +++ b/tools/gensourcefiles.sh @@ -3,39 +3,39 @@ d=$(dirname $0) mkdir -p $d/../sources/msdos for i in $d/../msdos/*.{fb,vid,sys}; do b=$(basename $i) - /bin/echo -n "write $d/../sources/msdos/$b.src ..." - $d/dumpblock.sh "$i" > $d/../sources/msdos/$b.src + /bin/echo -n "write $d/../sources/msdos/"${b%.*}.fth" ..." + $d/dumpblock.sh "$i" > $d/../sources/msdos/${b%.*}.fth echo " Done." done mkdir -p $d/../sources/cpm for i in $d/../8080/CPM/*.fb; do b=$(basename $i) - /bin/echo -n "write $d/../sources/cpm/$b.src ..." - $d/dumpblock.sh "$i" > $d/../sources/cpm/$b.src + /bin/echo -n "write $d/../sources/cpm/${b%.*}.fth ..." + $d/dumpblock.sh "$i" > $d/../sources/cpm/${b%.*}.fth echo " Done." done mkdir -p $d/../sources/AtariST for i in $d/../AtariST/*.FB; do b=$(basename $i) - /bin/echo -n "write $d/../sources/AtariST/$b.src ..." - $d/dumpblock.sh "$i" > $d/../sources/AtariST/$b.src + /bin/echo -n "write $d/../sources/AtariST/${b%.*}.fth ..." + $d/dumpblock.sh "$i" > $d/../sources/AtariST/${b%.*}.fth echo " Done." done mkdir -p $d/../sources/AtariST/GEM for i in $d/../AtariST/GEM/*.FB; do b=$(basename $i) - /bin/echo -n "write $d/../sources/AtariST/GEM/$b.src ..." - $d/dumpblock.sh "$i" > $d/../sources/AtariST/GEM/$b.src + /bin/echo -n "write $d/../sources/AtariST/GEM/${b%.*}.fth ..." + $d/dumpblock.sh "$i" > $d/../sources/AtariST/GEM/${b%.*}.fth echo " Done." done mkdir -p $d/../sources/Apple1 for i in $d/../6502/Apple1/source/*.fb; do b=$(basename $i) - /bin/echo -n "write $d/../source/Apple1/$b.src ..." - $d/dumpblock.sh "$i" > $d/../sources/Apple1/$b.src + /bin/echo -n "write $d/../source/Apple1/${b%.*}.fth ..." + $d/dumpblock.sh "$i" > $d/../sources/Apple1/${b%.*}.fth echo " Done." done