6502/PLASMA
1
0
Fork 0
mirror of https://github.com/dschmenk/PLASMA.git synced 2025-04-09 01:37:17 +00:00
Code Issues Projects Releases Wiki Activity

Merge pull request from dschmenk/master

Browse Source 
Merge latest upstream changes
This commit is contained in:
ZornsLemma 2018-02-10 23:40:04 +00:00 committed by GitHub
commit 5b9212be82
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
46 changed files with 2985 additions and 1781 deletions

BIN
HTTPD.PO

Binary file not shown.

BIN
PLASMA-BLD1.PO

Binary file not shown.

BIN
PLASMA-DEM1.PO

Binary file not shown.

BIN
PLASMA-PRE1.PO

Binary file not shown.

BIN
PLASMA-PRE2.PO

Binary file not shown.

BIN
PLASMA-SOS1.PO Normal file

Binary file not shown.

BIN
PLASMA-PRE3.PO → PLASMA-SYS1.PO

Binary file not shown.

6
README.md

@ -1,5 +1,5 @@
# 1/24/2018 Developer Preview #3 1.0 Available
[Download and read the Release Notes](https://github.com/dschmenk/PLASMA/blob/master/doc/Preview%20Version%201.0.md)
# 2/6/2018 PLASMA 1.0 Available!
[Download and read the Release Notes](https://github.com/dschmenk/PLASMA/blob/master/doc/Version%201.0.md)
# The PLASMA Programming Language
@ -189,6 +189,8 @@ and just like with the cross-compiled module, you will get the `Hello, word.` me
# Tutorial
I've created a YouTube playlist of PLASMA tutorial videos. Best viewed when you follow along on a live Apple II or emulator. They are brief segments to highlight one feature of PLASMA at a time: [Modern Retrogramming with PLASMA](https://www.youtube.com/playlist?list=PLlPKgUMQbJ79VJvZRfv1CJQf4SP2Gw3yU)
During KansasFest 2015, I gave a PLASMA introduction using the Apple II PLASMA sandbox IDE. You can play along using your favorite Apple II emulator, or one that runs directly in your browser: [Apple II Emulator in Javascript](https://www.scullinsteel.com/apple/e). Download [SANDBOX.PO](https://github.com/dschmenk/PLASMA/blob/master/SANDBOX.PO?raw=true) and load it into Drive 1 of the emulator. Start the [KansasFest PLASMA Code-along video](https://www.youtube.com/watch?v=RrR79WVHwJo?t=11m24s) and follow along.
To use this tutorial, make sure you have a working PLASMA installation as described in the previous section.

BIN
ROGUE.PO

Binary file not shown.

BIN
RPNCALC.PO

Binary file not shown.

BIN
SDFAT.PO

Binary file not shown.

146
doc/Editor.md Normal file

@ -0,0 +1,146 @@
WELCOME TO THE PLASMA EDITOR!
=============================
FIRST THINGS FIRST:
TO NAVIGATE, USE THE ARROW KEYS. ON THE
APPLE ][:
CTRL-K = UP
CTRL-J = DOWN.
TO JUMP AROUND THE TEXT FILE USE:
CTRL-W = JUMP UP
CTRL-Z = JUMP DOWN
CTRL-A = JUMP LEFT
CTRL-S = JUMP RIGHT
CTRL-Q = JUMP BEGINNING
CTRL-E = JUMP END
THE 'ESCAPE' KEY WILL PUT YOU IN COMMAND
MODE. FROM THERE YOU CAN EXIT BY
ENTERING 'Q' AND 'RETURN'. YOU CAN ALSO
RETURN TO THE EDITOR BY JUST PRESSING
'RETURN'.
-------
THE PLASMA EDITOR IS A SIMPLE TEXT
EDITOR FOR ENTERING AND MANIPULATING
TEXT AND SOURCE CODE FILES. THE EDITOR
ONLY SUPPORTS 40 COLUMN TEXT ALTHOUGH
LINES CAN BE UP TO 79 CHARACTERS LONG.
THE SCREEN WILL SCROLL HORIZONTALLY
AS THE CURSOR MOVES. THERE IS 16K OF
MEMORY FOR THE TEXT BUFFER.
IT HAS TWO MODES, COMMAND AND EDIT.
EDIT COMMANDS:
LEFT ARROW = MOVE CHAR LEFT
RIGHT ARROW = MOVE CHAR RIGHT
UP ARROW = MOVE LINE UP
DOWN ARROW = MOVE LINE DOWN
CTRL-K = MOVE LINE UP
CTRL-J = MOVE LINE DOWN
CTRL-A = JUMP LEFT
CTRL-S = JUMP RIGHT
CTRL-W = JUMP UP
CTRL-Z = JUMP DOWN
CTRL-Q = JUMP BEGIN
CTRL-E = JUMP END
CTRL-D = DELETE CHAR
CTRL-X = DELETE/CUT LINE
CTRL-V = COPY DELETED LINE
CTRL-O = OPEN NEW LINE
CTRL-F = OPEN A FOLLOWING NEW LINE
CTRL-T = JOIN LINES
CTRL-B = TOGGLE INSERT/OVERWRITE
TAB/CTRL-I = INSERT SPACES TO NEXT TAB
ESCAPE = SWITCH TO COMMAND MODE
DELETE = DELETE CHAR LEFT
APPLE ][ FEATURES:
------------------
SHIFT-M = ]
CTRL-N = [
SHIFT-CTRL-N = ~
CTRL-P = \
SHIFT-CTRL-P = |
CTRL-G = _
CTRL-L = SHIFT LOCK
SHIFT-LEFT ARROW = DELETE (SHIFT-MOD)
WITH THE SHIFT-KEY MOD ON AN
APPLE ][, UPPER AND LOWER CASE
ENTRY WORKS AS EXPECTED.
CTRL-C = FORCE LOWER-CASE CHARS
If you have a lower-case character
generator installed, you can force
lower-case display. Otherwise,
upper case will be displayed normally
but lower-case will be displayed in
inverse. This is the default.
Apple //e AND //c FEATURES:
---------------------------
The 'SOLID-APPLE' key will modify
theese keys:
SA-RETURN = OPEN LINE
SA-LEFT ARROW = JUMP LEFT
SA-RIGHT ARROW = JUMP RIGHT
SA-UP ARROR = JUMP UP
SA-DOWN ARROW = JUMP DOWN
Apple /// FEATURES:
-------------------
The 'OPEN-APPLE' key will modify
these keys:
OA-\ = DELETE CHAR LEFT
OA-RETURN = OPEN LINE
OA-LEFT ARROW = JUMP LEFT
OA-RIGHT ARROW = JUMP RIGHT
OA-UP ARROR = JUMP UP
OA-DOWN ARROW = JUMP DOWN
On the keypad, 'OPEN-APPLE' allows
the keys for navigation and misc:
OA-4 = MOVE CHAR LEFT
OA-6 = MOVE CHAR RIGHT
OA-8 = MOVE LINE UP
OA-2 = MOVE LINE DOWN
OA-9 = JUMP UP
OA-3 = JUMP DOWN
OA-7 = JUMP BEGIN
OA-1 = JUMP END
OA-5 = DELETE CHAR
OA-- = DELETE/CUT LINE
OA-0 = COPY DELETED LINE
OA-ENTER = OPEN NEW LINE
OA-. = TOGGLE INSERT/OVERWRITE
COMMAND MODE:
<REQUIRED PARAMETER>
[OPTIONAL PARAMETER]
Q = QUIT
R <FILENAME> = READ FILE
W [FILENAME] = WRITE FILE (OPTIONAL FILENAME)
A [FILENAME] = APPEND FILE
C [PREFIX] = CATALOG FILES
P <PREFIX> = SET PREFIX
H [SLOT] = HARDCOPY TO DEVICE IN SLOT (DEFAULT 1)
N = CLEAR TEXT IN MEMORY
E = EDIT MODE
'RETURN' = EDIT MODE

60
doc/Preview Version 1.0.md → doc/Version 1.0.md

@ -1,32 +1,46 @@
# Developer Preview #3 Version 1.0
# PLASMA Version 1.0
PLASMA is approaching a 1.0 release after _only_ 12 years. Hopefully it was worth the wait. To work out the remaining kinks, this Developer Preview will allow programmers to kick the tires, so to speak, to provide feedback on the system.
Welcome to PLASMA: the Grand Unifying Platform for the Apple 1, ][, and ///.
Download the three disk images:
Download the four disk images (three if you don't plan to boot an Apple ///):
[PLASMA Preview #3 1.0 System](https://github.com/dschmenk/PLASMA/blob/master/PLASMA-PRE3.PO?raw=true)
[PLASMA 1.0 System](https://github.com/dschmenk/PLASMA/blob/master/PLASMA-SYS1.PO?raw=true)
[PLASMA 1.0 Build System](https://github.com/dschmenk/PLASMA/blob/master/PLASMA-BLD1.PO?raw=true)
[PLASMA 1.0 Build Tools](https://github.com/dschmenk/PLASMA/blob/master/PLASMA-BLD1.PO?raw=true)
[PLASMA 1.0 Demos](https://github.com/dschmenk/PLASMA/blob/master/PLASMA-DEM1.PO?raw=true)
PLASMA can be run from floppies, System in drive 1, and Build in drive 2. All Apple II computers are supported, from the earliest Rev 0 to the last Apple IIGS. However, an accelerator and hard disk/CFFA are highly recommended. The recommended mass storage installation looks like:
[PLASMA 1.0 Apple /// SOS Boot ](https://github.com/dschmenk/PLASMA/blob/master/PLASMA-SOS1.PO?raw=true)
System Files => /HARDISK/PLASMA.PRE3/
PLASMA can be run from floppies, System in Drive 1, and Build or Demos in Drive 2. Mass storage is the recommended installation that looks like (replacing HARDISK with your volume name of choice):
Build Files => /HARDISK/BLD/
System Files => /HARDISK/PLASMA/
Demo Files => /HARDISK/DEMOS/
Build Files => /HARDISK/PLASMA/BLD/
Keeping the system files seperate from the build directory will make upgrading to the final 1.0 Release later a little easier. To boot directly into PLASMA, you will need to put the system files in the root prefix of the boot device and make sure PLASMA.SYSTEM is the first SYSTEM file in the directory. Otherwise, start PLASMA.SYSTEM from your program launcher of choice.
Demo Files => /HARDISK/PLASMA/DEMOS/
## 65802/65816 Support
Use the System Utilities to copy the floppy images into the above mentioned directories.
## Apple 1
The Apple 1 is a very constrained system compared to the ][ and ///. It is required to have the CFFA1 disk adapter installed to provide file storage and a full 32K od RAM. To get the files onto the CF card required the use of [CiderPress](http://a2ciderpress.com) and they must be placed in one directory. Most PLASMA programs won't work on the Apple 1 due to limited filesystem support, video/graphics capabilities, and lack of audio output. It does, however, make a good place to start when porting PLASMA to a new platform.
## Apple ][
To boot directly into PLASMA, you will need to put the system files in the root prefix of the boot device and make sure PLASMA.SYSTEM is the first SYSTEM file in the directory. Otherwise, start PLASMA.SYSTEM from your program launcher of choice. All Apple ][ models with 64K and two floppy drives are supported up to a maxed out IIGS with accelerator and hard drive.
#### 65802/65816 Support
PLASMA can utilize the 16 bit features of the 65802 and 65816 processors to improve performance of the PLASMA VM operation. This is transparent to the programmer/user and doesn't make any additional memory or capabilities available to PLASMA. Launch `PLASMA16.SYSTEM` to use the 16 bit PLASMA VM. If you don't have the right CPU, it will print a message and restart.
## Apple ///
The Apple /// gets the environment it always wanted: The ability to navigate the filesystem with a command line interface. The Apple /// always boots from the floppy drive, even if a hard disk is installed. The PLASMA.SOS floppy should be updated with the SOS.DRIVER configured for your machine. Once booted, type `S /HARDISK/PLASMA` (or your install directory of choice) to change to, and set, the system directory. This can be automated by creating an `AUTORUN` file on the boot floppy with the above command in it.
## PLASMA Command Line Shell
PLASMA incorporates a very basic command line shell to facilitate navigating the filesystem and executing both SYSTEM programs and PLASMA modules. It has a few built-in commands:
PLASMA incorporates a very basic command line shell to facilitate navigating the filesystem and executing both SYSTEM/SOS programs and PLASMA modules. It has a few built-in commands:
| Command | Operation |
|:----------------------------:|-------------------------|
@ -34,23 +48,27 @@ PLASMA incorporates a very basic command line shell to facilitate navigating the
| P \<PREFIX\> | change to Prefix
| / | change to parent prefix
| V | show online Volumes
| -\<SYSTEM PROGRAM\> [PARAMS] | launch SYSTEM program
| S \<PREFIX\> | set System prefix*
| +SOS \<SOS.INTERP\> [PREFIX] | launch SOS interpreter*
| -\<SYSTEM PROGRAM\> [PARAMS] | launch SYSTEM program**
| +\<PLASMA MODULE\> [PARAMS] | exec PLASMA module
```
[Optional parameters]
<Required parameters>
* Apple /// only
** Apple ][ only
```
The shell is very brief with error messages. It is meant solely as a way to run programs that accept command line parameters and take up as little memory as possible. It does, however, provide a rich runtime for PLASMA modules.
## Included Modules
The Developers Preview comes with a basic set of system modules. When PLASMA is launched, the SYS/ directory immediately below where PLASMA.SYSTEM was launched contains the modules. The system volume (where PLASMA was started) must remain in place for the duration of PLASMAs run. Otherwise it won't be able to find CMD or the system libraries. Probably the most useful included module is the editor. It is used for editing PLASMA source file, assembly source files, or any ProDOS text file. Execute it with:
PLASMA comes with many library modules used by the tools, demos and sample code. The PLASMA system volume must remain in place for the duration of PLASMAs run otherwise it won't be able to find CMD or the system libraries. Probably the most useful included module is the editor. It is used for editing PLASMA source file, assembly source files, or any text file. Execute it with:
```
+ED [TEXT FILE]
```
### Compiler Modules
## Compiler Modules
The build disk includes sample source, include files for the system modules, and the PLASMA compiler+optimizer modules. The compiler is invoked with:
```
@ -58,13 +76,17 @@ The build disk includes sample source, include files for the system modules, and
```
Compiler warnings are enabled with `-W`. The optional optimizer is enabled with `-O` and extra optimizations are enabled with `-O2`. The source code for a few sample programs are included. The big one, `RPNCALC.PLA`, is the sample RPN calculator that uses many of PLASMA's advanced features. The self-hosted compiler is the same compiler as the cross-compiler, just transcribed from C to PLASMA (yes, the self-hosted PLASMA compiler is written in PLASMA). It requires patience when compiling: it is a fairly large and extensive program.
### Demos
## Demos
There are some demo programs included for your perusal. Check out `ROGUE` for some diversion. You can find the documentation here: https://github.com/dschmenk/PLASMA/blob/master/doc/Rogue%20Instructions.md. A music sequencer to play through a MockingBoard if it is detected, or the built-in speaker if not. There may be problems if there is a CP/M card present when detecting the MockingBoard. A minimal Web server if you have an Uthernet2 card (required). Bug reports appreciated.
There are some demo programs included for your perusal. Check out `ROGUE` for some diversion. You can find the documentation here: https://github.com/dschmenk/PLASMA/blob/master/doc/Rogue%20Instructions.md. A music sequencer to play through a MockingBoard if it is detected, or the built-in speaker if not. A minimal Web server if you have an Uthernet2 card (required). Bug reports appreciated.
## Source Code
This is a Developers Preview, all sample source code is included from the project. It builds without alteration and should be a good starting point for further explorations. The header files for the included library modules are in the INC directory. Previously, examples from the sandbox were included but they have been removed to make room for all the project samples and include files.
Most sample source code is included from the project. They build without alteration and should be a good starting point for further explorations. The header files for the included library modules are in the INC directory.
## Video Playlist
There is a [YouTube playlist](https://www.youtube.com/playlist?list=PLlPKgUMQbJ79VJvZRfv1CJQf4SP2Gw3yU) created for learning PLASMA. It is a WIP, with updates every week or so
## Issues
@ -72,6 +94,8 @@ This is a Developers Preview, all sample source code is included from the projec
- All the project modules are included. They have been tested, with the exception of the Uthernet2 driver. I seem to have misplaced mine. If someone can try the Web Server demo in /PLASMA.DEMOS/NET and leave feedback would be very appreciated.
- The Apple /// may not always report errors properly or at all.
- The documentation is sparse and incomplete. Yep, could use your help...
# Changes in PLASMA for 1.0

12
src/inc/conio.plh

@ -1,9 +1,13 @@
import conio
const NORMAL = $FF
const INVERSE = $3F
const FLASH = $7F
const NORMAL = $FF
const INVERSE = $3F
const FLASH = $7F
const ECHO_ON = $80
const ECHO_OFF = $00
struc t_conio
word keypressed
word getkey
word echo
word home
word gotoxy
word viewport
@ -12,5 +16,7 @@ import conio
word grmode
word grcolor
word grplot
word tone
word rnd
end
end

2
src/inc/fileio.plh

@ -38,7 +38,7 @@ import fileio
word setpfx
word getfileinfo
word geteof
word openbuf
word iobufalloc
word open
word close
word read

6
src/inc/sndseq.plh

@ -1,4 +1,6 @@
import sndseq
predef spkrTone(pitch, duration)#0, spkrPWM(sample, speed, len)#0
predef musicPlay(track, rept)#0, musicStop#0, musicGetKey(backgroundProc)#1
word musicSequence // musicSequence(yield, backgroundProc)#0
word spkrTone // spkrTone(pitch, duration)#0
word spkrPWM // spkrPWM(sample, speed, len)#0
predef musicPlay(track, rept)#0, musicStop#0, musicGetKey(yield, backgroundProc)#1
end

111
src/libsrc/conio.pla

@ -5,6 +5,12 @@ include "inc/cmdsys.plh"
const FULLMODE = 0
const MIXMODE = 1
//
// Apple II ZP locations.
//
const a2rndnum = $4E // ZP location of RND
const a2rndl = $4E
const a2rndh = $4F
//
// Apple II hardware constants.
//
const speaker = $C030
@ -23,10 +29,16 @@ const hgr2 = $4000
const page1 = 0
const page2 = 1
//
// External interface
// Apple III hardware constants.
//
const ENV_REG = $FFDF
//
// External interface.
//
struc t_conio
word keypressed
word getkey
word echo
word home
word gotoxy
word viewport
@ -35,12 +47,14 @@ struc t_conio
word grmode
word grcolor
word grplot
word tone
word rnd
end
//
// Predefined functions.
//
predef a2keypressed,a2home,a2gotoxy(x,y),a2viewport(left, top, width, height),a2texttype(type)
predef a2textmode(cols),a2grmode(mix),a2grcolor(color),a2grplot(x,y)
predef a2keypressed,a2home,a12echo(state),a2gotoxy(x,y),a2viewport(left, top, width, height),a2texttype(type)
predef a2textmode(cols),a2grmode(mix),a2grcolor(color),a2grplot(x,y),a2tone(duration, delay),a2rnd
//
// Exported function table.
//
@ -49,6 +63,8 @@ word conio[]
// Function pointers.
//
word = @a2keypressed
word = @getc
word = @a12echo
word = @a2home
word = @a2gotoxy
word = @a2viewport
@ -57,6 +73,8 @@ word = @a2textmode
word = @a2grmode
word = @a2grcolor
word = @a2grplot
word = @a2tone
word = @a2rnd
//
// Screen row address arrays.
//
@ -79,6 +97,10 @@ byte textbwmode[] = 2, 16, 0
byte textclrmode[] = 2, 16, 1
byte grcharset[] = 1, 0, $7F, $7F, $7F, $7F, $00, $00, $00, $00
//
// Random number for Apple 1 and III.
//
word randnum = 12345
//
// Native routines.
//
asm equates
@ -147,6 +169,9 @@ end
def a1keypressed
return ^$D011 >= 128
end
def a12echo(state)
return 0
end
def a1home
byte l
for l = 0 to 23
@ -176,6 +201,15 @@ end
def a1grmode(mix)
return 0 // not supported
end
def a1tone(duration, delay)
byte i
while duration
for i = delay downto 0; next
duration--
loop
return 0
end
//
// Apple II routines.
//
@ -223,6 +257,20 @@ def a2grmode(mix)
a2home
return a2grscrn(@txt1scrn) // point to lo-res screen
end
def a2tone(duration, delay)
byte i
while duration
^speaker // toggle speaker
for i = delay downto 0; next
duration--
loop
return 0
end
def a2rnd
*a2rndnum = (*a2rndnum << 1) + *a2rndnum + 123
return *a2rndnum & $7FFF
end
//
// Apple III routines.
//
@ -249,6 +297,9 @@ def a3keypressed
dev_status(cmdsys.devcons, 5, @count)
return count
end
def a3echo(state)
return dev_control(cmdsys.devcons, 11, @state)
end
def a3home
//curshpos = 0
//cursvpos = 0
@ -308,34 +359,64 @@ def a3grmode(mix)
puts(@textclrmode)
dev_control(cmdsys.devcons, 17, @grcharset)
a3viewport(0, 20, 40, 4)
putc(28)
for i = 0 to mix
memset(txt1scrn[i], 40, $0000) // text screen
memset(txt2scrn[i], 40, $0000) // color screen
memset(txt1scrn[i], $0000, 40) // text screen
memset(txt2scrn[i], $0000, 40) // color screen
next
return a2grscrn(@txt2scrn) // point to color screen
end
def a3tone(duration, pitch)
byte env
env = ^ENV_REG
^ENV_REG = env | $C0
a2tone(duration, pitch)
^ENV_REG = env
return 0
end
//
// Apple 1 and III combined routines.
//
def a13getkey
while not conio:keypressed()
randnum = randnum + 123
loop
return getc()
end
def a13rnd
randnum = (randnum << 1) + randnum + 123
return randnum & $7FFF
end
//
// Machine specific initialization.
//
when MACHID & MACHID_MODEL
is MACHID_I
conio:keypressed = @a1keypressed
conio:home = @a1home
conio:gotoxy = @a1gotoxy
conio:viewport = @a1viewport
conio:texttype = @a1texttype
conio:textmode = @a1textmode
conio:grmode = @a1grmode
break
is MACHID_III
conio:keypressed = @a3keypressed
conio:getkey = @a13getkey
conio:echo = @a3echo
conio:home = @a3home
conio:gotoxy = @a3gotoxy
conio:viewport = @a3viewport
conio:texttype = @a3texttype
conio:textmode = @a3textmode
conio:grmode = @a3grmode
conio:tone = @a3tone
conio:rnd = @a13rnd
break
//otherwise // MACHID_II
is MACHID_I
conio:keypressed = @a1keypressed
conio:getkey = @a13getkey
conio:home = @a1home
conio:gotoxy = @a1gotoxy
conio:viewport = @a1viewport
conio:texttype = @a1texttype
conio:textmode = @a1textmode
conio:grmode = @a1grmode
conio:tone = @a1tone
conio:rnd = @a13rnd
break
otherwise // MACHID_II puts("Found MACHID_MODEL = $"); putb(MACHID & MACHID_MODEL); putln
wend
done

143
src/libsrc/fileio.pla

@ -27,7 +27,7 @@ struc t_fileio
word setpfx
word getfileinfo
word geteof
word openbuf
word iobufalloc
word open
word close
word read
@ -38,21 +38,27 @@ struc t_fileio
word readblock
word writeblock
end
predef a2getpfx(path), a23setpfx(path), a2getfileinfo(path, fileinfo), a23geteof(refnum), a2openbuf(path, iobuf), a2open(path), a23close(refnum)
predef a2getpfx(path), a23setpfx(path), a2getfileinfo(path, fileinfo), a23geteof(refnum), a2iobufs(iobufs), a2open(path), a2close(refnum)
predef a23read(refnum, buf, len), a2write(refnum, buf, len), a2create(path, type, aux), a23destroy(path)
predef a23newline(refnum, emask, nlchar), a2readblock(unit, buf, block), a2writeblock(unit, buf, block)
predef a2newline(refnum, emask, nlchar), a2readblock(unit, buf, block), a2writeblock(unit, buf, block)
//
// Exported function table.
//
word fileio[]
word = @a2getpfx, @a23setpfx, @a2getfileinfo, @a23geteof, @a2openbuf, @a2open, @a23close
word = @a2getpfx, @a23setpfx, @a2getfileinfo, @a23geteof, @a2iobufs, @a2open, @a2close
word = @a23read, @a2write, @a2create, @a23destroy
word = @a23newline, @a2readblock, @a2writeblock
word = @a2newline, @a2readblock, @a2writeblock
//
// SOS/ProDOS error code
//
export byte perr
//
// I/O buffers
//
const MAX_IOBUFS = 4
byte iobuf_ref[MAX_IOBUFS]
word iobuf_addr[MAX_IOBUFS] = sysbuf
//
// ProDOS/SOS routines
//
def a1getpfx(path)
@ -128,34 +134,54 @@ def a1open(path)
*CFFA1FileName = path
return 0
end
def a2openbuf(path, iobuf)
byte params[6]
params.0 = 3
params:1 = path
params:3 = iobuf
params.5 = 0
perr = syscall($C8, @params)
return params.5
def a2iobufs(iobufs)
byte i
word freebuf, bufaddr
if iobufs > MAX_IOBUFS
iobufs = MAX_IOBUFS
fin
if iobufs
iobufs-- // Subtract off system I/O buffer
if iobufs
bufaddr = heapallocalign(1024 * iobufs, 8, @freebuf)
for i = 1 to MAX_IOBUFS-1
if not iobuf_addr[i]
iobuf_addr[i] = bufaddr
bufaddr = bufaddr + 1024
iobufs--
if not iobufs
return freebuf
fin
fin
next
return freebuf
fin
else
for i = 1 to MAX_IOBUFS-1
iobuf_addr[i] = 0 // Free I/O buffers if 0 passed in
next
fin
return 0
end
def a13iobufs(iobufs)
return 0
end
def a2open(path)
byte params[6]
params.0 = 3
params:1 = path
params:3 = sysbuf
params.5 = 0
perr = syscall($C8, @params)
return params.5
end
def a3openbuf(path, iobuf)
byte params[7]
params.0 = 4
params:1 = path
params.3 = 0
params:4 = iobuf
params.6 = 0
perr = syscall($C8, @params)
return params.3
byte i, params[6]
for i = 0 to MAX_IOBUFS-1
if iobuf_addr[i] and not iobuf_ref[i]
params.0 = 3
params:1 = path
params:3 = iobuf_addr[i]
params.5 = 0
perr = syscall($C8, @params)
iobuf_ref[i] = params.5
return params.5
fin
next
return 0
end
def a3open(path)
byte params[7]
@ -171,7 +197,22 @@ end
def a1close(refnum)
return perr
end
def a23close(refnum)
def a2close(refnum)
byte i, params[2]
for i = 0 to MAX_IOBUFS-1
if refnum == iobuf_ref[i]
iobuf_ref[i] = 0
params.0 = 1
params.1 = refnum
perr = syscall($CC, @params)
return perr
fin
next
perr = $45
return perr
end
def a3close(refnum)
byte params[2]
params.0 = 1
@ -263,7 +304,7 @@ end
def a1newline(refnum, emask, nlchar)
return perr
end
def a23newline(refnum, emask, nlchar)
def a2newline(refnum, emask, nlchar)
byte params[4]
params.0 = 3
@ -273,6 +314,16 @@ def a23newline(refnum, emask, nlchar)
perr = syscall($C9, @params)
return perr
end
def a3newline(refnum, emask, nlchar)
byte params[4]
params.0 = 3
params.1 = refnum
params.2 = emask ?? $FF :: $00
params.3 = nlchar
perr = syscall($C9, @params)
return perr
end
def a13readblock(unit, buf, block)
perr = $27 // IOERR
return perr
@ -304,12 +355,25 @@ end
//
// Machine specific initialization.
//
when MACHID & $C8
is $08 // Apple 1
when MACHID & MACHID_MODEL
is MACHID_III
fileio:getpfx = @a3getpfx
fileio:getfileinfo = @a3getfileinfo
fileio:iobufalloc = @a13iobufs
fileio:open = @a3open
fileio:close = @a3close
fileio:write = @a3write
fileio:create = @a3create
fileio:newline = @a3newline
fileio:readblock = @a13readblock
fileio:writeblock = @a13writeblock
break
is MACHID_I
fileio:getpfx = @a1getpfx
fileio:setpfx = @a1setpfx
fileio:getfileinfo = @a1getfileinfo
fileio:geteof = @a1geteof
fileio:iobufalloc = @a13iobufs
fileio:open = @a1open
fileio:close = @a1close
fileio:read = @a1read
@ -320,15 +384,6 @@ when MACHID & $C8
fileio:readblock = @a13readblock
fileio:writeblock = @a13writeblock
break
is $C0 // Apple ///
fileio:getpfx = @a3getpfx
fileio:getfileinfo = @a3getfileinfo
fileio:open = @a3open
fileio:write = @a3write
fileio:create = @a3create
fileio:readblock = @a13readblock
fileio:writeblock = @a13writeblock
break
otherwise // Apple ][
wend
done

8
src/libsrc/longjmp.pla

@ -1,5 +1,12 @@
asm incs
!SOURCE "vmsrc/plvmzp.inc"
XPAGE = $1600
NEXTOP = $F0
FETCHOP = NEXTOP+1
IP = FETCHOP+1
IPL = IP
IPH = IPL+1
IPX = XPAGE+IPH
end
//
// Save environment (PLASMA ZP and stack) for below and return 0
@ -65,3 +72,4 @@ export asm throw(env, retval)
STA ESTKH,X
RTS
end
done

6
src/libsrc/sane.pla

@ -837,8 +837,10 @@ def fpInit()
fpzpsave = heapalloc($0034*2)
(@fixupXS)=>1 = fpzpsave+$34
(@fixupXR)=>1 = fpzpsave+$34
sane[9] = @zpSaveX
sane[10] = @zpRestoreX
zpSaveX // Clear XBYTEs
heaprelease(fpzpsave)
sane[9] = @zpNopSave//zpSaveX
sane[10] = @zpNopRestore//zpRestoreX
else // Apple II
fpzpsave = heapalloc($0034)
sane[9] = @zpSave

143
src/libsrc/sndseq.pla

@ -48,6 +48,10 @@ struc t_PSG
byte ENVSHAPE // Envelope Shape
end
//
// Apple III hardware constants.
//
const ENV_REG = $FFDF
//
// Sequence event
//
struc t_event
@ -60,10 +64,17 @@ end
//
predef musicPlay(track, rept)#0
predef musicStop#0
predef spkrSequence(yield, func)#0
predef a2spkrTone(pitch, duration)#0
predef a2spkrPWM(sample, speed, len)#0
//
// Static sequencer values
//
export word musicSequence
export word musicSequence = @spkrSequence
export word spkrTone = @a2spkrTone
export word spkrPWM = @a2spkrPWM
word instr[] // Overlay with other variables
word seqTrack, seqEvent, seqTime, eventTime, updateTime
byte numNotes, seqRepeat
byte indexA[2], indexB[2], indexC[2]
@ -76,8 +87,8 @@ word periods[2] = @periods1, @periods2
// MockingBoard data.
//
word[] mbVIAs // Treat this as an array of VIA ptrs
word mbVIA1 = -1 // Init to "discover MockingBoard flag" value
word mbVIA2 = 0
word mbVIA1, mbVIA2
word mbSlot = -1
//
// Octave basis frequency periods (starting at MIDI note #12)
// Notes will be encoded as basis note (LSNibble) and octave (MSNibble))
@ -203,7 +214,7 @@ end
//
// Apple II speaker tone generator routines
//
export asm spkrTone(pitch, duration)#0
asm a2spkrTone(pitch, duration)#0
STX ESP
LDY ESTKH,X
LDA ESTKL,X
@ -277,7 +288,7 @@ TONEXIT PLP
INX
RTS
end
export asm spkrPWM(sample, speed, len)#0
asm a2spkrPWM(sample, speed, len)#0
STX ESP
LDY ESTKH,X
LDA ESTKL,X
@ -317,6 +328,22 @@ export asm spkrPWM(sample, speed, len)#0
INX
RTS
end
def a3spkrTone(pitch, duration)#0
byte env
env = ^ENV_REG
^ENV_REG = env | $C0
a2spkrTone(pitch, duration)
^ENV_REG = env
end
def a3spkrPWM(sample, speed, len)#0
byte env
env = ^ENV_REG
^ENV_REG = env | $C0
a2spkrPWM(sample, speed, len)
^ENV_REG = env
end
//
// Search slots for MockingBoard
//
@ -344,25 +371,27 @@ def mbTicklePSG(pVIA)
return 0
end
def mbSearch(slot)
if slot
mbVIA1 = mbTicklePSG($C000 + (slot << 8))
if mbVIA1
mbVIA2 = mbTicklePSG(mbVIA1 + $80)
return slot
fin
else
for slot = 1 to 7
if slot == 3 or slot == 6
continue
fin
if slot >= 0 and slot <= 7
if slot
mbVIA1 = mbTicklePSG($C000 + (slot << 8))
if mbVIA1
mbVIA2 = mbTicklePSG(mbVIA1 + $80)
return slot
fin
next
else
for slot = 1 to 7
if slot == 3 or slot == 6
continue
fin
mbVIA1 = mbTicklePSG($C000 + (slot << 8))
if mbVIA1
mbVIA2 = mbTicklePSG(mbVIA1 + $80)
return slot
fin
next
fin
fin
return 0
return -1
end
def psgSetup(pVIA)#0
psgWrite(pVIA, MIXER, $3F) // Turn everything off
@ -672,7 +701,7 @@ def spkrSequence(yield, func)#0
if numNotes > 1
for i = 0 to MAX_SPKR_NOTES-1
if notes1[i]
spkrTone(periods1[i], arpeggioDuration[numNotes])
spkrTone(periods1[i], arpeggioDuration[numNotes])#0
fin
*rndseed++
next
@ -688,7 +717,7 @@ def spkrSequence(yield, func)#0
next
duration = eventTime - seqTime
seqTime = duration + seqTime
spkrTone(period, DUR16TH * duration)
spkrTone(period, DUR16TH * duration)#0
fin
if ^$C000 > 127; return; fin
if yieldTime <= seqTime; func()#0; yieldTime = seqTime + yield; fin
@ -709,7 +738,7 @@ def noSequence(yield, func)#0
seqTime++
if seqTime < 0; seqTime = 1; fin // Capture wrap-around
*rndseed++
spkrTone(0, DUR16TH) // Waste 16th of a second playing silence
a2spkrTone(0, DUR16TH) // Waste 16th of a second playing silence
if ^$C000 > 127; return; fin
if yield == seqTime; func()#0; seqTime = 0; fin
until FALSE
@ -721,22 +750,17 @@ export def musicPlay(track, rept)#0
byte i
//
// First time search for MockingBoard
// Select proper sequencer based on hardware
//
if mbVIA1 == -1
if !mbSearch(0)
//
// No MockingBoard - scale octave0 for speaker
//
for i = 0 to 11
spkrOctave0[i] = mbOctave0[i]/NOTEDIV
next
fin
if mbSlot > 0
musicSequence = @mbSequence
else
musicSequence = @spkrSequence
fin
//
// Zero out active notes
//
for i = 0 to MAX_MBCH_NOTES-1; notes1[i] = 0; notes2[i] = 0; next
for i = 0 to MAX_MBCH_NOTES-1; notes1[i] = 0; notes2[i] = 0; next
for i = 0 to MAX_MBCH_NOTES-1; periods1[i] = 0; periods2[i] = 0; next
//
// Start sequencing
@ -747,14 +771,6 @@ export def musicPlay(track, rept)#0
seqTime = 0
eventTime = seqEvent->deltatime
numNotes = 0
//
// Select proper sequencer based on hardware
//
if mbVIA1
musicSequence = @mbSequence
else
musicSequence = @spkrSequence
fin
end
//
// Stop sequencing music track
@ -763,18 +779,45 @@ export def musicStop#0
musicSequence = @noSequence
end
//
// Get a keystroke and convert it to upper case
// Play until keystroke
//
export def musicGetKey(backgroundProc)#1
byte key
export def musicGetKey(yield, backgroundProc)#1
while ^$C000 < 128
musicSequence($08, backgroundProc)#0 // Call background proc every half second
musicSequence(yield, backgroundProc)#0 // Call background proc every half second
loop
key = ^$C000 & $7F
^$C010
return key
return ^$C000
end
when MACHID & MACHID_MODEL
is MACHID_III
spkrTone = @a3spkrTone
spkrPWM = @a3spkrPWM
break
is MACHID_I
puts("Sound unsupported.\n")
return -1
break
otherwise
puts("MockingBoard Slot:\n")
puts("ENTER = None\n")
puts("0 = Scan\n")
puts("1-7 = Slot #\n")
instr = gets('>'|$80)
if ^instr
mbSlot = mbSearch(^(instr + 1) - '0')
fin
break
wend
if mbSlot < 0
//
// No MockingBoard - scale octave0 for speaker
//
for instr = 0 to 11
spkrOctave0[instr] = mbOctave0[instr]/NOTEDIV
next
fin
done
////////////////////////////////////////////////////////////////////////////////
@ -798,7 +841,7 @@ musicStop()
The getUpperKey routine will call a dummy sequence routine that will
keep the correct timing for any background processing
getKey()
musicGetKey(yieldtime, yieldproc)
Wait for a keypress and return the character
While waiting for the keypress, the track sequence will be played though
either the MockingBoard (if present) or the internal speaker. Optionally,
@ -808,13 +851,13 @@ getKey()
The low level internal speaker routines used to generate tones and waveforms
can be called for warnings, sound effects, etc:
spkrTone(period, duration)
spkrTone(period, duration)#0
Play a tone
Params:
(1020000 / 64 / period) Hz
(duration * 32 * 256 / 1020000) seconds
spkrPWM(samples, speed, len)
spkrPWM(samples, speed, len)#0
Play a Pulse Width Modulated waveform
Params:
Pointer to 8 bit pulse width samples

155
src/libsrc/sos.pla Normal file

@ -0,0 +1,155 @@
include "inc/cmdsys.plh"
include "inc/args.plh"
include "inc/fileio.plh"
word arg, ref, interp
asm equates
!SOURCE "vmsrc/plvmzp.inc"
end
//
// Exec SOS.INTERP image
//
asm sosexec(addr)#0
LDA ESTKL,X ; PULL ADDRESSES FROM INTERP HEADER
STA SRCL
LDA ESTKH,X
STA SRCH
LDY #$0A
LDA (SRC),Y
INY
STA DSTL
PHA
LDA (SRC),Y
INY
STA DSTH
PHA
LDA (SRC),Y
INY
STA TMPL
LDA (SRC),Y
STA TMPH
TYA ; SKIP INTERP HEADER FOR SRC
SEC
ADC SRCL
STA SRCL
BCC +
INC SRCH
+ LDA DSTL
CMP SRCL
LDA DSTH
SBC SRCH
BCC REVCPY
;
; FORWARD COPY
;
LDY TMPL
BEQ FORCPYLP
INC TMPH
LDY #$00
FORCPYLP LDA (SRC),Y
STA (DST),Y
INY
BNE +
INC DSTH
INC SRCH
+ DEC TMPL
BNE FORCPYLP
DEC TMPH
BNE FORCPYLP
BEQ CPYMEX
;
; REVERSE COPY
;
REVCPY ;CLC
LDA TMPL
ADC DSTL
STA DSTL
LDA TMPH
ADC DSTH
STA DSTH
CLC
LDA TMPL
ADC SRCL
STA SRCL
LDA TMPH
ADC SRCH
STA SRCH
DEC DSTH
DEC SRCH
LDY #$FF
LDA TMPL
BEQ REVCPYLP
INC TMPH
REVCPYLP LDA (SRC),Y
STA (DST),Y
DEY
CPY #$FF
BNE +
DEC DSTH
DEC SRCH
+ DEC TMPL
BNE REVCPYLP
DEC TMPH
BNE REVCPYLP
CPYMEX PLA
STA DSTH
PLA
STA DSTL
JMP (DST) ; JUMP TO INTERP
end
def seg_release(segnum)#1
byte params[2]
params.0 = 1
params.1 = segnum
perr = syscall($45, @params)
return perr
end
def strcmp(str1, str2)
byte i
if (^str1 == ^str2)
for i = ^str1 downto 1
if ^(str1 + i) <> ^(str2 + i)
return FALSE
fin
next
return TRUE
fin
return FALSE
end
if MACHID <> $F2
puts("Apple /// SOS required.\n")
return -1
fin
arg = argNext(argFirst)
if ^arg
ref = fileio:open(arg)
if ref
arg = argNext(arg)
if ^arg
fileio:setpfx(arg)
puts(arg); puts("/:\n")
fin
interp = heapmark()+1
fileio:read(ref, interp, heapavail())
fileio:close(ref)
^(interp - 1) = 8
if strcmp(interp - 1, "SOS NTRP")
//puts("INTERP opt hdr: $"); puth(interp=>$08); putln
//puts("INTERP address: $"); puth(interp=>$0A); putln
//puts("INTERP size: $"); puth(interp=>$0C); putln
fileio:close(0) // Close all files
seg_release(0) // Free all segments
sosexec(interp)
else
puts("Not a SOS.INTERP file.\n")
fin
else
puts("File not found.\n")
fin
else
puts("Usage: +SOS <SOS.INTERP> [PREFIX]\n")
fin
done

12
src/makefile

@ -8,6 +8,7 @@ PLVM03 = SOS.INTERP\#050000
CMD = CMD\#061000
ED = ED\#FE1000
SB = SB\#FF2000
SOS = SOS\#FE1000
ROD = ROD\#FE1000
SIEVE = SIEVE\#FE1000
ARGS = ARGS\#FE1000
@ -38,7 +39,6 @@ DGR = DGR\#FE1000
TONE = TONE\#FE1000
PORTIO = PORTIO\#FE1000
ROGUE = ROGUE\#FE1000
ROGUEIO = ROGUEIO\#FE1000
ROGUEMAP= ROGUEMAP\#FE1000
ROGUECOMBAT= ROGUECOMBAT\#FE1000
HELLO = HELLO\#FE1000
@ -73,7 +73,7 @@ TXTTYPE = .TXT
#SYSTYPE = \#FF2000
#TXTTYPE = \#040000
all: $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM802) $(PLVM03) $(CMD) $(PLASMAPLASM) $(CODEOPT) $(ARGS) $(MEMMGR) $(MEMTEST) $(FIBER) $(FIBERTEST) $(LONGJMP) $(ED) $(MON) $(ROD) $(SIEVE) $(UTHERNET2) $(UTHERNET) $(ETHERIP) $(INET) $(DHCP) $(HTTPD) $(ROGUE) $(ROGUEMAP) $(ROGUECOMBAT) $(ROGUEIO) $(TONE) $(DGR) $(DGRTEST) $(FILEIO) $(CONIO) $(PORTIO) $(SPIPORT) $(SDFAT) $(FATCAT) $(FATGET) $(FATPUT) $(FATWDSK) $(FATRDSK) $(SANE) $(FPSTR) $(FPU) $(SANITY) $(RPNCALC) $(SNDSEQ) $(PLAYSEQ)
all: $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM802) $(PLVM03) $(CMD) $(PLASMAPLASM) $(CODEOPT) $(ARGS) $(MEMMGR) $(MEMTEST) $(FIBER) $(FIBERTEST) $(LONGJMP) $(ED) $(MON) $(SOS) $(ROD) $(SIEVE) $(UTHERNET2) $(UTHERNET) $(ETHERIP) $(INET) $(DHCP) $(HTTPD) $(ROGUE) $(ROGUEMAP) $(ROGUECOMBAT) $(TONE) $(DGR) $(DGRTEST) $(FILEIO) $(CONIO) $(PORTIO) $(SPIPORT) $(SDFAT) $(FATCAT) $(FATGET) $(FATPUT) $(FATWDSK) $(FATRDSK) $(SANE) $(FPSTR) $(FPU) $(SANITY) $(RPNCALC) $(SNDSEQ) $(PLAYSEQ)
clean:
-rm *FE1000 *FF2000 $(PLASM) $(PLVM) $(PLVM01) $(PLVM02) $(PLVM03)
@ -177,6 +177,10 @@ $(MON): samplesrc/mon.pla $(PLVM02) $(PLASM)
./$(PLASM) -AMOW < samplesrc/mon.pla > samplesrc/mon.a
acme --setpc 4094 -o $(MON) samplesrc/mon.a
$(SOS): libsrc/sos.pla $(PLVM02) $(PLASM)
./$(PLASM) -AMO < libsrc/sos.pla > libsrc/sos.a
acme --setpc 4094 -o $(SOS) libsrc/sos.a
$(ROD): samplesrc/rod.pla $(PLVM02) $(PLASM)
./$(PLASM) -AMO < samplesrc/rod.pla > samplesrc/rod.a
acme --setpc 4094 -o $(ROD) samplesrc/rod.a
@ -285,10 +289,6 @@ $(ROGUE): samplesrc/rogue.pla $(PLVM02) $(PLASM)
./$(PLASM) -AMOW < samplesrc/rogue.pla > samplesrc/rogue.a
acme --setpc 4094 -o $(ROGUE) samplesrc/rogue.a
$(ROGUEIO): samplesrc/rogue.io.pla $(PLVM02) $(PLASM)
./$(PLASM) -AMOW < samplesrc/rogue.io.pla > samplesrc/rogue.io.a
acme --setpc 4094 -o $(ROGUEIO) samplesrc/rogue.io.a
$(ROGUECOMBAT): samplesrc/rogue.combat.pla $(PLVM02) $(PLASM)
./$(PLASM) -AMOW < samplesrc/rogue.combat.pla > samplesrc/rogue.combat.a
acme --setpc 4094 -o $(ROGUECOMBAT) samplesrc/rogue.combat.a

9
src/mkrel

@ -1,6 +1,8 @@
cp CMD#061000 prodos/CMD.BIN
cp PLASMA.SYSTEM#FF2000 prodos/PLASMA.SYSTEM.SYS
cp PLASMA16.SYSTEM#FF2000 prodos/PLASMA16.SYSTEM.SYS
cp SOS.INTERP#050000 prodos/SOS.INTERP.\$05
cp ../doc/Editor.md prodos/EDITOR.README.TXT
rm -rf prodos/sys
mkdir prodos/sys
@ -24,6 +26,7 @@ cp SPIPORT#FE1000 prodos/sys/SPIPORT.REL
cp SNDSEQ#FE1000 prodos/sys/SNDSEQ.REL
cp UTHERNET#FE1000 prodos/sys/UTHERNET.REL
cp UTHERNET2#FE1000 prodos/sys/UTHERNET2.REL
cp SOS#FE1000 prodos/sys/SOS.REL
cp ../sysfiles/FP6502.CODE#060000 prodos/sys/FP6502.CODE.BIN
cp ../sysfiles/ELEMS.CODE#060000 prodos/sys/ELEMS.CODE.BIN
@ -36,7 +39,6 @@ cp ROD#FE1000 prodos/demos/ROD.REL
mkdir prodos/demos/rogue
cp ROGUE#FE1000 prodos/demos/rogue/ROGUE.REL
cp ROGUECOMBAT#FE1000 prodos/demos/rogue/ROGUECOMBAT.REL
cp ROGUEIO#FE1000 prodos/demos/rogue/ROGUEIO.REL
cp ROGUEMAP#FE1000 prodos/demos/rogue/ROGUEMAP.REL
cp samplesrc/LEVEL0#040000 prodos/demos/rogue/LEVEL0.TXT
cp samplesrc/LEVEL1#040000 prodos/demos/rogue/LEVEL1.TXT
@ -73,6 +75,11 @@ cp samplesrc/test.pla prodos/bld/TEST.PLA.TXT
cp samplesrc/testlib.pla prodos/bld/TESTLIB.PLA.TXT
cp samplesrc/playseq.pla prodos/bld/PLAYSEQ.PLA.TXT
cp samplesrc/rpncalc.pla prodos/bld/RPNCALC.PLA.TXT
cp samplesrc/httpd.pla prodos/bld/HTTPD.PLA.TXT
cp samplesrc/fatcat.pla prodos/bld/FATCAT.PLA.TXT
cp samplesrc/rogue.pla prodos/bld/ROGUE.PLA.TXT
cp samplesrc/rogue.map.pla prodos/bld/ROGUE.MAP.PLA.TXT
cp samplesrc/rogue.combat.pla prodos/bld/ROGUE.COMBAT.PLA.TXT
mkdir prodos/bld/inc
cp inc/args.plh prodos/bld/inc/ARGS.PLH.TXT

2
src/samplesrc/playseq.pla

@ -22,7 +22,7 @@ if ^arg
fileio:read(ref, heapmark(), heapavail())
fileio:close(ref)
musicPlay(heapmark(), TRUE)
musicGetKey(@backgroundProc)
musicGetKey(8, @backgroundProc) // Yield every 8/16 second
musicStop
else
puts("File not found.\n")

22
src/samplesrc/rogue.combat.pla

@ -1,9 +1,6 @@
include "inc/cmdsys.plh"
include "inc/conio.plh"
import rogueio
word rnd, getkb, tone
end
import roguemap
predef moveplayer
end
@ -129,15 +126,16 @@ export word entities = 0
//
def win#0
tone(30, 15)
tone(5, 15)
tone(5, 15)
tone(30, 5)
conio:tone(30, 15)
conio:tone(5, 15)
conio:tone(5, 15)
conio:tone(30, 5)
end
export def fight(player, enemy)
word p_atck, e_atck
conio:echo(ECHO_ON)
repeat
conio:home()
conio:gotoxy(0, 0)
@ -161,18 +159,19 @@ export def fight(player, enemy)
puts(ascii_entity[enemy->kind] + e_atck * 11)
next
conio:gotoxy(12, 8); puts("F)ight or R)un?")
if toupper(getkb()) == 'R'
if toupper(conio:getkey()) == 'R'
conio:echo(ECHO_OFF)
return 1
else
//
// Turn player in random direction
//
player->angle = rnd() & 7
player->angle = conio:rnd() & 7
//
// Calculate attack (with a little random variation)
//
p_atck = player->skill + player->energy / 10 - enemy->power / 25 + (rnd() & 7)
e_atck = enemy->power - player->skill / 5 - player->energy / 20 + (rnd() & 7)
p_atck = player->skill + player->energy / 10 - enemy->power / 25 + (conio:rnd() & 7)
e_atck = enemy->power - player->skill / 5 - player->energy / 20 + (conio:rnd() & 7)
if enemy->life > p_atck
enemy->life = enemy->life - p_atck
else
@ -207,6 +206,7 @@ export def fight(player, enemy)
fin
fin
until player->health == 0 or enemy->life == 0
conio:echo(ECHO_OFF)
return 0
end

111
src/samplesrc/rogue.io.pla

@ -1,111 +0,0 @@
include "inc/cmdsys.plh"
include "inc/conio.plh"
byte[] initstr
byte = " ( )\n"
byte = " )\\ ) ( /( (\n"
byte = "(()/( )\\()) )\\ ) ( (\n"
byte = " /(_))((_)\\ (()/( )\\ )\\\n"
byte = "(_)) ((_) /(_))_ _ ((_)((_)\n"
byte = "| _ \\ / _ \\(_)) __|| | | || __|\n"
byte = "| / | (_) | | (_ || |_| || _|\n"
byte = "|_|_\\ \\___/ \\___| \\___/ |___|\n"
byte = "\n"
byte = " By Resman\n"
byte = " Artwork by Seth Sternberger\n"
byte = ""
word titlestr = @initstr
//
// Machine specific routines
//
export word rnd, getkb, tone
const ENV_REG = $FFDF
const SPEAKER = $C030
const a2rndnum = $4E // ZP location of RND
const a2rndl = $4E
const a2rndh = $4F
word a3rndnum = 12345
def a3rnd
a3rndnum = (a3rndnum << 1) + a3rndnum + 123
return *a3rndnum & $7FFF
end
def a2rnd
*a2rndnum = (*a2rndnum << 1) + *a2rndnum + 123
return *a2rndnum & $7FFF
end
def a2getkb
return getc()
end
def a2tone(duration, delay)
byte i
while duration
^SPEAKER
for i = 0 to delay
next
duration--
loop
return 0
end
def a3tone(duration, pitch)
byte env
env = ^ENV_REG
^ENV_REG = env | $C0
a2tone(duration, pitch)
^ENV_REG = env
return 0
end
//
// Apple /// console routines
//
def a3getkb
while not conio:keypressed()
a3rndnum = a3rndnum + 123
loop
return getc()
end
//
// Set machine specific routines
//
when MACHID & $C8
is $08 // Apple 1
puts("APPLE 1 NOT SUPPORTED.")
return -1
is $C0 // Apple ///
rnd = @a3rnd
getkb = @a3getkb
tone = @a3tone
break
otherwise // Apple ][
rnd = @a2rnd
getkb = @a2getkb
tone = @a2tone
wend
//
// Print title page
//
conio:home()
while ^titlestr
puts(titlestr)
titlestr = titlestr + ^titlestr + 1
loop
done

33
src/samplesrc/rogue.map.pla

@ -5,13 +5,24 @@ include "inc/cmdsys.plh"
include "inc/conio.plh"
include "inc/fileio.plh"
import rogueio
const O_READ = 1
const O_WRITE = 2
const O_READ_WRITE = 3
//
// Title page
//
word rnd, getkb, tone
end
byte[] initstr
byte = " ( )\n"
byte = " )\\ ) ( /( (\n"
byte = "(()/( )\\()) )\\ ) ( (\n"
byte = " /(_))((_)\\ (()/( )\\ )\\\n"
byte = "(_)) ((_) /(_))_ _ ((_)((_)\n"
byte = "| _ \\ / _ \\(_)) __|| | | || __|\n"
byte = "| / | (_) | | (_ || |_| || _|\n"
byte = "|_|_\\ \\___/ \\___| \\___/ |___|\n"
byte = "\n"
byte = " By Resman\n"
byte = " Artwork by Seth Sternberger\n"
byte = ""
word titlestr = @initstr
//
// Octant beam parameters
@ -760,4 +771,14 @@ export def drawvisentity(xofst, yofst, tile)#0
fin
end
//
// Print title page
//
conio:home()
while ^titlestr
puts(titlestr)
titlestr = titlestr + ^titlestr + 1
loop
done

41
src/samplesrc/rogue.pla

@ -41,10 +41,6 @@ import roguecombat
word entity, entities
end
import rogueio
word rnd, getkb, tone
end
const maxlight = 10
const maxview = 19
@ -54,6 +50,7 @@ byte vplayer = '^', '\\', '>', '/', 'v', '\\', '<', '/'
byte totaldarkness = 0
byte level = 0
word free_entities
//
// Power-ups
//
@ -157,42 +154,42 @@ end
//
def ouch#0
tone(128,5)
conio:tone(128,5)
end
def gotit#0
tone(10,8)
tone(80,2)
conio:tone(10,8)
conio:tone(80,2)
end
def fall#0
byte i
for i = 0 to 10
tone(50, i)
conio:tone(50, i)
next
end
def drown#0
word i
tone(10,20)
tone(10,1)
conio:tone(10,20)
conio:tone(10,1)
for i = 0 to 1000
next
tone(10,25)
tone(10,2)
conio:tone(10,25)
conio:tone(10,2)
for i = 0 to 1000
next
tone(10,30)
tone(10,3)
conio:tone(10,30)
conio:tone(10,3)
end
def groan#0
byte i
for i = 0 to 5
tone(5, 40 + i)
conio:tone(5, 40 + i)
next
end
@ -463,10 +460,10 @@ def play
return FALSE
fin
conio:gotoxy(xcentr, ycentr)
when toupper(getkb())
when toupper(conio:getkey())
is 'I'
if totaldarkness
player.angle = rnd() & 7
player.angle = conio:rnd() & 7
else
player.angle = 0
fin
@ -474,7 +471,7 @@ def play
break
is 'J'
if totaldarkness
player.angle = rnd() & 7
player.angle = conio:rnd() & 7
else
player.angle = 6
fin
@ -482,7 +479,7 @@ def play
break
is 'K'
if totaldarkness
player.angle = rnd() & 7
player.angle = conio:rnd() & 7
else
player.angle = 2
fin
@ -490,7 +487,7 @@ def play
break
is 'M'
if totaldarkness
player.angle = rnd() & 7
player.angle = conio:rnd() & 7
else
player.angle = 4
fin
@ -601,7 +598,7 @@ def play
clearstatus
conio:gotoxy(0, statusline)
puts(@quitstr)
if toupper(getkb()) == 'Y'
if toupper(conio:getkey()) == 'Y'
player.health = 0
return FALSE
fin
@ -628,6 +625,7 @@ if ^instr > 15
^instr = 15
fin
memcpy(@player.name, instr, ^instr + 1)
conio:echo(ECHO_OFF)
while loadmap(level)
puts(@prepstr)
free_entities = heapmark()
@ -653,6 +651,7 @@ while loadmap(level)
break
fin
loop
conio:echo(ECHO_ON)
if player.health > 0
puts(@youmadeitstr)
puti(player.gold)

660
src/samplesrc/rpncalc.pla

@ -12,14 +12,14 @@ const ZEROSTR = $3001
// Keypad structure
//
struc t_keypad
byte keychar
byte xpos
byte ypos
byte keystr[8]
byte keychar
byte xpos
byte ypos
byte keystr[8]
end
struc t_keyinput
byte keyinfo[t_keypad]
word phandler
byte keyinfo[t_keypad]
word phandler
end
predef delKey(pkey)#0, cmdKey(pkey)#0, dropKey(pkey)#0, clearKey(pkey)#0
predef digitKey(pkey)#0, pointKey(pkey)#0, opKey(pkey)#0
@ -46,401 +46,403 @@ byte memory[10*t_fpureg]
// Key values
//
byte[t_keypad] keypad = $08, 0, 0, ""
word = @delKey
byte[t_keypad] = $1B, 0, 0, ""
word = @cmdKey
byte[t_keypad] = '=', 0, 0, ""
word = @copyKey
byte[t_keypad] = 'Z', 0, 0, ""
word = @clearKey
byte[t_keypad] = '7', 3, 10, "[7]"
word = @digitKey
byte[t_keypad] = '8', 7, 10, "[8]"
word = @digitKey
byte[t_keypad] = '9', 11, 10, "[9]"
word = @digitKey
byte[t_keypad] = '/', 15, 10, "[/]"
word = @opKey
byte[t_keypad] = '4', 3, 12, "[4]"
word = @digitKey
byte[t_keypad] = '5', 7, 12, "[5]"
word = @digitKey
byte[t_keypad] = '6', 11, 12, "[6]"
word = @digitKey
byte[t_keypad] = '*', 15, 12, "[*]"
word = @opKey
byte[t_keypad] = '1', 3, 14, "[1]"
word = @digitKey
byte[t_keypad] = '2', 7, 14, "[2]"
word = @digitKey
byte[t_keypad] = '3', 11, 14, "[3]"
word = @digitKey
byte[t_keypad] = '-', 15, 14, "[-]"
word = @opKey
byte[t_keypad] = '0', 3, 16, "[0]"
word = @digitKey
byte[t_keypad] = '.', 7, 16, "[.]"
word = @pointKey
byte[t_keypad] = 'X', 11, 16, "[X]"
word = @dropKey
byte[t_keypad] = '+', 15, 16, "[+]"
word = @opKey
byte[t_keypad] = $0D, 3, 18, "[ENTER]"
word = @enterKey
byte[t_keypad] = '<', 11, 18, "[<]"
word = @memKey
byte[t_keypad] = '>', 15, 18, "[>]"
word = @memKey
byte[t_keypad] = 'R', 3, 20, "[SQ(R)]"
word = @opKey
byte[t_keypad] = 'H', 11, 20, "[C(H)S]"
word = @chsKey
byte[t_keypad] = 'C', 22, 14, "[(C)OS]"
word = @elemsKey
byte[t_keypad] = 'S', 22, 16, "[(S)IN]"
word = @elemsKey
byte[t_keypad] = 'T', 22, 18, "[(T)AN]"
word = @elemsKey
byte[t_keypad] = 'A', 22, 20, "[(A)TN]"
word = @elemsKey
byte[t_keypad] = '^', 30, 14, "[X(^)Y]"
word = @elemsKey
byte[t_keypad] = 'L', 30, 16, "[(L)G2]"
word = @elemsKey
byte[t_keypad] = 'E', 30, 18, "[(E)^X]"
word = @elemsKey
byte[t_keypad] = 'N', 30, 20, "[L(N)X]"
word = @elemsKey
byte = 0
word = @delKey
byte[t_keypad] = $1B, 0, 0, ""
word = @cmdKey
byte[t_keypad] = '=', 0, 0, ""
word = @copyKey
byte[t_keypad] = 'Z', 0, 0, ""
word = @clearKey
byte[t_keypad] = '7', 3, 10, "[7]"
word = @digitKey
byte[t_keypad] = '8', 7, 10, "[8]"
word = @digitKey
byte[t_keypad] = '9', 11, 10, "[9]"
word = @digitKey
byte[t_keypad] = '/', 15, 10, "[/]"
word = @opKey
byte[t_keypad] = '4', 3, 12, "[4]"
word = @digitKey
byte[t_keypad] = '5', 7, 12, "[5]"
word = @digitKey
byte[t_keypad] = '6', 11, 12, "[6]"
word = @digitKey
byte[t_keypad] = '*', 15, 12, "[*]"
word = @opKey
byte[t_keypad] = '1', 3, 14, "[1]"
word = @digitKey
byte[t_keypad] = '2', 7, 14, "[2]"
word = @digitKey
byte[t_keypad] = '3', 11, 14, "[3]"
word = @digitKey
byte[t_keypad] = '-', 15, 14, "[-]"
word = @opKey
byte[t_keypad] = '0', 3, 16, "[0]"
word = @digitKey
byte[t_keypad] = '.', 7, 16, "[.]"
word = @pointKey
byte[t_keypad] = 'X', 11, 16, "[X]"
word = @dropKey
byte[t_keypad] = '+', 15, 16, "[+]"
word = @opKey
byte[t_keypad] = $0D, 3, 18, "[ENTER]"
word = @enterKey
byte[t_keypad] = '<', 11, 18, "[<]"
word = @memKey
byte[t_keypad] = '>', 15, 18, "[>]"
word = @memKey
byte[t_keypad] = 'R', 3, 20, "[SQ(R)]"
word = @opKey
byte[t_keypad] = 'H', 11, 20, "[C(H)S]"
word = @chsKey
byte[t_keypad] = 'C', 22, 14, "[(C)OS]"
word = @elemsKey
byte[t_keypad] = 'S', 22, 16, "[(S)IN]"
word = @elemsKey
byte[t_keypad] = 'T', 22, 18, "[(T)AN]"
word = @elemsKey
byte[t_keypad] = 'A', 22, 20, "[(A)TN]"
word = @elemsKey
byte[t_keypad] = '^', 30, 14, "[X(^)Y]"
word = @elemsKey
byte[t_keypad] = 'L', 30, 16, "[(L)G2]"
word = @elemsKey
byte[t_keypad] = 'E', 30, 18, "[(E)^X]"
word = @elemsKey
byte[t_keypad] = 'N', 30, 20, "[L(N)X]"
word = @elemsKey
byte = 0
//
// Utility routines
//
def repc(rep, c)#0
while rep > 0
putc(c)
rep--
loop
while rep > 0
putc(c)
rep--
loop
end
def rect(x, y, width, height, frame, title)#0
byte i
byte i
conio:gotoxy(x + 1, y)
repc(width - 2, frame ?? '#' :: '-')
conio:gotoxy(x + 1, y + height - 1)
repc(width - 2, frame ?? '#' :: '-')
for i = 1 to height - 1
conio:gotoxy(x, y + i)
putc(frame ?? '#' :: '!')
conio:gotoxy(x + width - 1, y + i)
putc(frame ?? '#' :: '!')
next
conio:gotoxy(x, y)
putc(frame ?? '/' :: '+')
conio:gotoxy(x + width - 1, y)
putc(frame ?? '\\' :: '+')
conio:gotoxy(x, y + height - 1)
putc(frame ?? '\\' :: '+')
conio:gotoxy(x + width - 1, y + height - 1)
putc(frame ?? '/' :: '+')
if title
conio:gotoxy(x + (width - ^title) / 2, y)
puts(title)
fin
conio:gotoxy(x + 1, y)
repc(width - 2, frame ?? '#' :: '-')
conio:gotoxy(x + 1, y + height - 1)
repc(width - 2, frame ?? '#' :: '-')
for i = 1 to height - 1
conio:gotoxy(x, y + i)
putc(frame ?? '#' :: '!')
conio:gotoxy(x + width - 1, y + i)
putc(frame ?? '#' :: '!')
next
conio:gotoxy(x, y)
putc(frame ?? '/' :: '+')
conio:gotoxy(x + width - 1, y)
putc(frame ?? '\\' :: '+')
conio:gotoxy(x, y + height - 1)
putc(frame ?? '\\' :: '+')
conio:gotoxy(x + width - 1, y + height - 1)
putc(frame ?? '/' :: '+')
if title
conio:gotoxy(x + (width - ^title) / 2, y)
puts(title)
fin
end
def showStack#0
byte s
byte strFP[displayWidth+1]
byte s
byte strFP[displayWidth+1]
for s = 0 to 3
fpu:storStr(@strFP, displayInt, displayFix, FPSTR_FIXED, s)
conio:gotoxy(4, 5 - s)
repc(displayWidth - strFP - 1, ' ')
puts(@strFP)
next
for s = 0 to 3
fpu:storStr(@strFP, displayInt, displayFix, FPSTR_FIXED, s)
conio:gotoxy(4, 5 - s)
repc(displayWidth - strFP - 1, ' ')
puts(@strFP)
next
end
def showMem#0
byte m
byte strFP[displayWidth+1]
byte m
byte strFP[displayWidth+1]
for m = 0 to 9
ext2str(@memory[m*t_fpureg], @strFP, displayInt, displayFix, FPSTR_FIXED)
conio:gotoxy(23, 2 + m)
repc(displayWidth - strFP - 1, ' ')
puts(@strFP)
next
for m = 0 to 9
ext2str(@memory[m*t_fpureg], @strFP, displayInt, displayFix, FPSTR_FIXED)
conio:gotoxy(23, 2 + m)
repc(displayWidth - strFP - 1, ' ')
puts(@strFP)
next
end
def showInput#0
conio:gotoxy(2,7)
repc(17 - inputStr, ' ')
puts(@inputStr)
conio:gotoxy(2,7)
repc(17 - inputStr, ' ')
puts(@inputStr)
end
def showStatus(pstr)#0
conio:gotoxy(0,23)
puts(pstr)
conio:gotoxy(0,23)
puts(pstr)
end
def clearStatus#0
conio:gotoxy(0,23)
repc(39, ' ')
conio:gotoxy(0,23)
repc(39, ' ')
end
def initInput#0
inputStr = 0
inputStr = 0
end
def updateInput#0
//
// Lift stack if something input
//
if inputStr
fpu:pushStr(@inputStr)
fin
initInput
showInput
//
// Lift stack if something input
//
if inputStr
fpu:pushStr(@inputStr)
fin
initInput
showInput
end
def initDisplay#0
byte i
word pkeys
byte i
word pkeys
conio:home()
rect(0, 0, 40, 23, 1, "<RPN Calculator>")
rect(1, 1, 19, 6, 0, ":Stack:")
rect(1, 6, 19, 3, 0, 0)
conio:gotoxy(2, 2); puts("T:")
conio:gotoxy(2, 3); puts("Z:")
conio:gotoxy(2, 4); puts("Y:")
conio:gotoxy(2, 5); puts("X:")
rect(20, 1, 19, 12, 0, ":Memory:")
for i = 0 to 9
conio:gotoxy(21, 2 + i); puti(i); putc(':')
next
pkeys = @keypad
while ^pkeys
conio:gotoxy(pkeys->xpos, pkeys->ypos)
puts(pkeys + keystr)
pkeys = pkeys + t_keyinput
loop
conio:home()
rect(0, 0, 40, 23, 1, "<RPN Calculator>")
rect(1, 1, 19, 6, 0, ":Stack:")
rect(1, 6, 19, 3, 0, 0)
conio:gotoxy(2, 2); puts("T:")
conio:gotoxy(2, 3); puts("Z:")
conio:gotoxy(2, 4); puts("Y:")
conio:gotoxy(2, 5); puts("X:")
rect(20, 1, 19, 12, 0, ":Memory:")
for i = 0 to 9
conio:gotoxy(21, 2 + i); puti(i); putc(':')
next
pkeys = @keypad
while ^pkeys
conio:gotoxy(pkeys->xpos, pkeys->ypos)
puts(pkeys + keystr)
pkeys = pkeys + t_keyinput
loop
end
def initState#0
byte m
byte m
//
// Init FPU
//
fpu:reset()
//
// Fill memory
//
for m = 2 to 9
fpu:storExt(@memory[m*t_fpureg], X_REG)
next
//
// Put some useful constants in there
//
fpu:constPi()
fpu:pullExt(@memory[0*t_fpureg])
fpu:constE()
fpu:pullExt(@memory[1*t_fpureg])
//
// Init FPU
//
fpu:reset()
//
// Fill memory
//
for m = 2 to 9
fpu:storExt(@memory[m*t_fpureg], X_REG)
next
//
// Put some useful constants in there
//
fpu:constPi()
fpu:pullExt(@memory[0*t_fpureg])
fpu:constE()
fpu:pullExt(@memory[1*t_fpureg])
end
//
// Keypress input handlers
//
def delKey(pkey)#0
if inputStr
inputStr--
fin
if inputStr:0 == 1 | ('-' << 8) //inputStr == 1 and inputStr.1 == '-'
inputStr--
fin
showInput
if inputStr
inputStr--
fin
if inputStr:0 == 1 | ('-' << 8) //inputStr == 1 and inputStr.1 == '-'
inputStr--
fin
showInput
end
def dropKey(pkey)#0
fpu:pullStr(@inputStr, displayInt, displayFix, FPSTR_STRIP|FPSTR_FLOAT)
if inputStr.1 == ' '
inputStr--
memcpy(@inputStr.1, @inputStr.2, inputStr)
fin
showInput
showStack
fpu:pullStr(@inputStr, displayInt, displayFix, FPSTR_STRIP|FPSTR_FLOAT)
if inputStr.1 == ' '
inputStr--
memcpy(@inputStr.1, @inputStr.2, inputStr)
fin
showInput
showStack
end
def copyKey(pkey)#0
fpu:storStr(@inputStr, displayInt, displayFix, FPSTR_STRIP|FPSTR_FLOAT, X_REG)
if inputStr.1 == ' '
inputStr--
memcpy(@inputStr.1, @inputStr.2, inputStr)
fin
showInput
fpu:storStr(@inputStr, displayInt, displayFix, FPSTR_STRIP|FPSTR_FLOAT, X_REG)
if inputStr.1 == ' '
inputStr--
memcpy(@inputStr.1, @inputStr.2, inputStr)
fin
showInput
end
def clearKey(pkey)#0
initInput
showInput
initInput
showInput
end
def digitKey(pkey)#0
if inputStr < inputLen
if inputStr:0 <> ZEROSTR
inputStr++
fin
inputStr[inputStr] = ^pkey
showInput
if inputStr < inputLen
if inputStr:0 <> ZEROSTR
inputStr++
fin
inputStr[inputStr] = ^pkey
showInput
fin
end
def pointKey(pkey)#0
byte c
byte c
if !inputStr
//
// Start off with '0' if blank input
//
inputStr:0 = ZEROSTR
else
//
// Check for existing decimal point
//
for c = 1 to inputStr
if inputStr[c] == '.'
return
fin
next
fin
inputStr++
inputStr[inputStr] = '.'
showInput
if !inputStr
//
// Start off with '0' if blank input
//
inputStr:0 = ZEROSTR
else
//
// Check for existing decimal point
//
for c = 1 to inputStr
if inputStr[c] == '.'
return
fin
next
fin
inputStr++
inputStr[inputStr] = '.'
showInput
end
def chsKey(pkey)#0
if inputStr
if inputStr.1 <> '-'
memcpy(@inputStr.2, @inputStr.1, inputStr)
inputStr++
inputStr.1 = '-'
else
inputStr--
memcpy(@inputStr.1, @inputStr.2, inputStr)
fin
showInput
if inputStr
if inputStr.1 <> '-'
memcpy(@inputStr.2, @inputStr.1, inputStr)
inputStr++
inputStr.1 = '-'
else
inputStr--
memcpy(@inputStr.1, @inputStr.2, inputStr)
fin
showInput
fin
end
def enterKey(pkey)#0
fpu:pushStr(@inputStr)
showStack
initInput
showInput
fpu:pushStr(@inputStr)
showStack
initInput
showInput
end
def opKey(pkey)#0
updateInput
when ^pkey
is '+'
fpu:addXY()
break
is '-'
fpu:subXY()
break
is '*'
fpu:mulXY()
break
is '/'
fpu:divXY()
break
is 'R'
fpu:sqrtX()
break
wend
showStack
updateInput
when ^pkey
is '+'
fpu:addXY()
break
is '-'
fpu:subXY()
break
is '*'
fpu:mulXY()
break
is '/'
fpu:divXY()
break
is 'R'
fpu:sqrtX()
break
wend
showStack
end
def memKey(pkey)#0
word r
word r
showStatus("Press 0-9 for memory register:")
r = getc - '0'
clearStatus
if r >= 0 and r <= 9
if ^pkey == '<'
fpu:pushExt(@memory[r*t_fpureg])
showStack
else
fpu:storExt(@memory[r*t_fpureg], X_REG)
showMem
fin
showStatus("Press 0-9 for memory register:")
r = getc - '0'
clearStatus
if r >= 0 and r <= 9
if ^pkey == '<'
fpu:pushExt(@memory[r*t_fpureg])
showStack
else
fpu:storExt(@memory[r*t_fpureg], X_REG)
showMem
fin
fin
end
def elemsKey(pkey)#0
updateInput
when ^pkey
is 'C'
fpu:cosX()
break
is 'S'
fpu:sinX()
break
is 'T'
fpu:tanX()
break
is 'A'
fpu:atanX()
break
is '^'
fpu:powXY()
break
is 'L'
fpu:log2X()
break
is 'E'
fpu:powEX()
break
is 'N'
fpu:lnX()
break
wend
showStack
updateInput
when ^pkey
is 'C'
fpu:cosX()
break
is 'S'
fpu:sinX()
break
is 'T'
fpu:tanX()
break
is 'A'
fpu:atanX()
break
is '^'
fpu:powXY()
break
is 'L'
fpu:log2X()
break
is 'E'
fpu:powEX()
break
is 'N'
fpu:lnX()
break
wend
showStack
end
//
// Command line handler
//
def cmdKey(pkey)#0
// word cmdLine
// word cmdLine
// showStatus("Command")
// cmdLine = gets(':'|$80)
word d
// showStatus("Command")
// cmdLine = gets(':'|$80)
word d
showStatus("Press 1-9 for fix point digits(Q=Quit):")
d = toupper(getc) - '0'
if d >= 1 and d <= 9
displayFix = d
displayInt = displayWidth - displayFix - 1
elsif d == 'Q' - '0'
quit = TRUE
fin
clearStatus
//
// Do something
//
initDisplay
showStack
showMem
showInput
showStatus("Press 1-9 for fix point digits(Q=Quit):")
d = toupper(getc) - '0'
if d >= 1 and d <= 9
displayFix = d
displayInt = displayWidth - displayFix - 1
elsif d == 'Q' - '0'
quit = TRUE
fin
clearStatus
//
// Do something
//
initDisplay
showStack
showMem
showInput
end
//
// Keypress handler
//
def inputKey#0
byte inkey
word pkeys
while not quit
pkeys = @keypad
conio:gotoxy(18, 7)
inkey = toupper(getc)
while ^pkeys
if inkey == ^pkeys
conio:texttype(INVERSE)
conio:gotoxy(pkeys->xpos, pkeys->ypos)
puts(pkeys + keystr)
conio:texttype(NORMAL)
pkeys=>phandler(pkeys)#0
conio:gotoxy(pkeys->xpos, pkeys->ypos)
puts(pkeys + keystr)
break
fin
pkeys = pkeys + t_keyinput
loop
byte inkey
word pkeys
conio:echo(ECHO_OFF)
while not quit
pkeys = @keypad
conio:gotoxy(18, 7)
inkey = toupper(getc)
while ^pkeys
if inkey == ^pkeys
conio:texttype(INVERSE)
conio:gotoxy(pkeys->xpos, pkeys->ypos)
puts(pkeys + keystr)
conio:texttype(NORMAL)
pkeys=>phandler(pkeys)#0
conio:gotoxy(pkeys->xpos, pkeys->ypos)
puts(pkeys + keystr)
break
fin
pkeys = pkeys + t_keyinput
loop
loop
conio:echo(ECHO_ON)
end
initDisplay
initState

10
src/toolsrc/codegen.c

@ -232,6 +232,14 @@ void idglobal_size(int type, int size, int constsize)
else if (size)
emit_data(0, 0, 0, size);
}
void idlocal_size(int size)
{
localsize += size;
if (localsize > 255)
{
parse_error("Local variable size overflow\n");
}
}
int id_tag(char *name, int len)
{
int i;
@ -512,7 +520,7 @@ void emit_lambdafunc(int tag, char *name, int cparams, t_opseq *lambda_seq)
emit_seq(lambda_seq);
emit_pending_seq();
if (cparams)
printf("\t%s\t$5A\t\t\t; LEAVE\n", DB);
printf("\t%s\t$5A,$%02X\t\t\t; LEAVE\t%d\n", DB, cparams*2, cparams*2);
else
printf("\t%s\t$5C\t\t\t; RET\n", DB);
}

2
src/toolsrc/codegen.pla

@ -508,7 +508,7 @@ def init_idglobal#0
fixup_addr = heapalloc(fixup_num*2)
idglobal_tbl = heapalloc(globalbufsz)
idlocal_tbl = heapalloc(localbufsz)
codebufsz = heapavail - 4096
codebufsz = heapavail - 2048
codebuff = heapalloc(codebufsz)
codeptr = codebuff
lastglobal = idglobal_tbl

157
src/toolsrc/ed.pla

@ -33,6 +33,7 @@ const keyctrlc = $83
const keyctrld = $84
const keyctrle = $85
const keyctrlf = $86
const keyctrlg = $87
const keyctrli = $89
const keyctrlk = $8B
const keyctrll = $8C
@ -84,6 +85,8 @@ word strplsize = MAXSTRPLSIZE
word strpool, strplmapsize, strlinbuf, strpoolmap
byte cursx, cursy, scrnleft, curscol, underchr, curschr
word keyin, cursrow, scrntop, cursptr
byte a3echo = $80
byte a3noecho = $00
//
// Predeclared functions
//
@ -313,12 +316,13 @@ end
//
// File routines
//
def readtxt(filename)#0
def readtxt(filename, startline)#0
byte txtbuf[81], refnum, i, j
if refnum
refnum = fileio:open(filename)
if refnum
fileio:newline(refnum, $7F, $0D)
numlines = startline
repeat
txtbuf = fileio:read(refnum, @txtbuf + 1, MAXLNLEN)
if txtbuf
@ -370,7 +374,11 @@ end
// Screen routines
//
def clrscrn#0
call($FC58, 0, 0, 0, 0)
if MACHID == $F2 // Apple 3
putc(28)
else
call($FC58, 0, 0, 0, 0)
fin
end
def drawrow(row, ofst, strptr)#0
byte numchars
@ -562,6 +570,92 @@ end
//
// Keyboard routines
//
def dev_control(devnum, code, list)#1
byte params[5]
params.0 = 3
params.1 = devnum
params.2 = code
params:3 = list
perr = syscall($83, @params)
return perr
end
def cons_keyavail
byte params[5]
byte count
params.0 = 3
params.1 = cmdsys.devcons
params.2 = 5
params:3 = @count
return syscall($82, @params) ?? 0 :: count
end
def cons_keyread
byte params[8]
byte key
params.0 = 4
params.1 = cmdsys.refcons
params:2 = @key
params:4 = 1
params:6 = 0
syscall($CA, @params)
return params:6 ?? key :: 0
end
def keyin3
byte key
repeat
cursflash
until cons_keyavail
key = cons_keyread
if key & $80 // Open Apple modifier
when key
is keyarrowleft
key = keyctrla; break
is keyarrowright
key = keyctrls; break
is keyarrowup
key = keyctrlw; break
is keyarrowdown
key = keyctrlz; break
is keyenter
key = keyctrlf; break
is $80 | '\\'
key = keydelete; break // Delete
is keyenter
key = keyctrlf; break
//
// Map OA+keypad
//
is $80 | '4'
key = keyarrowleft; break
is $80 | '6'
key = keyarrowright; break
is $80 | '8'
key = keyarrowup; break
is $80 | '2'
key = keyarrowdown; break
is $80 | '7'
key = keyctrlq; break // Top
is $80 | '1'
key = keyctrle; break // Bottom
is $80 | '9'
key = keyctrlw; break // Pg Up
is $80 | '3'
key = keyctrlz; break // Pg Dn
is $80 | '5'
key = keyctrld; break // Del
is $80 | '.'
key = keyctrlb; break // Ins
is $80 | '0'
key = keyctrlv; break // Copy
is $80 | '-'
key = keyctrlx; break // Cut
wend
fin
return key | $80
end
def keyin2e
byte key
repeat
@ -599,14 +693,18 @@ def keyin2
until key >= 128
^keystrobe
if key == keyctrln
key = $DB // [
key = $DB // '['
elsif key == $9E // SHIFT+CTRL+N
key = $FE // '~'
elsif key == keyctrlp
key = $DF // _
elsif key == keyctrlb
key = $DC // \
key = $DC // '\'
elsif key == $80 // SHIFT+CTRL+P -> CTRL+@
key = $FC // '|'
elsif key == keyctrlg
key = $DF // '_'
elsif key == keyarrowleft
if ^pushbttn3 < 128
key = $FF
key = keydelete
fin
elsif key >= $C0 and flags < shiftlock
if ^pushbttn3 < 128
@ -623,6 +721,19 @@ def keyin2
fin
return key
end
def setkeyin#0
when MACHID & MACHID_MODEL
is MACHID_IIE
is MACHID_IIC
keyin = @keyin2e
break
is MACHID_III
keyin = @keyin3
break
otherwise // ][ or ][+
keyin = @keyin2
wend
end
def tabkeyin
return curscol < MAXLNLEN and curscol & $01 ?? keyspace :: 0
end
@ -827,6 +938,9 @@ def editline(key)
return key
end
def editmode#0
if MACHID == $F2 // Apple 3
dev_control(cmdsys.devcons, 11, @a3noecho)
fin
repeat
when editline(keyin())
is keyarrowup
@ -877,7 +991,7 @@ def editmode#0
is keyctrli
keyin = @tabkeyin
editline(keyspace)
keyin = !(MACHID & $80) ?? @keyin2 :: @keyin2e
setkeyin
break
is keyctrlb
if flags & insmode
@ -897,9 +1011,15 @@ def editmode#0
redraw
break
is keyescape
if MACHID == $F2 // Apple 3
dev_control(cmdsys.devcons, 11, @a3echo)
fin
cursoff
cmdmode
if not exit
if MACHID == $F2 // Apple 3
dev_control(cmdsys.devcons, 11, @a3noecho)
fin
redraw
fin
break
@ -1003,22 +1123,20 @@ def cmdmode#0
word cmdptr
clrscrn
puts("PLASMA Editor, Version 1.0\n")
puts("PLASMA Editor, Version 1.01\n")
while not exit
puts(@filename)
cmdptr = gets($BA)
when toupper(parsecmd(cmdptr))
is 'A'
readtxt(cmdptr)
readtxt(cmdptr, numlines)
flags = flags | changed
break
is 'R'
if chkchng
inittxtbuf
numlines = 0
strstripcpy(@filename, cmdptr)
readtxt(@filename)
if numlines == 0; numlines = 1; fin
readtxt(@filename, 0)
flags = flags & ~changed
fin
break
@ -1060,7 +1178,7 @@ def cmdmode#0
wend
if perr
puts("ERROR: $")
call($FDDA, perr, 0, 0, 0)
putb(perr)
else
puts("OK")
fin
@ -1070,19 +1188,16 @@ end
//
// Init editor
//
if !(MACHID & $80)
setkeyin
if not (MACHID & $80) // ][ or ][+
flags = uppercase | shiftlock
keyin = @keyin2
else
keyin = @keyin2e
fin
inittxtbuf
arg = argNext(argFirst)
if ^arg
strcpy(@filename, arg)
puts(@filename)
numlines = 0
readtxt(@filename)
readtxt(@filename, 0)
fin
curschr = '+'
flags = flags | insmode

4
src/toolsrc/lex.pla

@ -343,8 +343,7 @@ def nextln
if incref; puts("Nested INCLUDEs not allowed\n"); exit_err(0); fin
if scan <> STR_TKN; puts("Missing INCLUDE file\n"); exit_err(0); fin
strcpy(@incfile, constval)
sysincbuf = heapallocalign(1024, 8, @sysincfre)
incref = fileio:openbuf(@incfile, sysincbuf)
incref = fileio:open(@incfile)
if not incref
puts("Unable to open INCLUDE file: ")
puts(@incfile)
@ -362,7 +361,6 @@ def nextln
else
if refnum == incref
fileio:close(incref)
heaprelease(sysincfre)
incref = 0
refnum = srcref
parsefile = @srcfile

9
src/toolsrc/parse.c

@ -1170,8 +1170,13 @@ int parse_var(int type, long basesize)
{
if (idlen)
id_add(idstr, idlen, type, size);
else
emit_data(0, 0, 0, size);
else if (!(type & EXTERN_TYPE))
{
if (type & LOCAL_TYPE)
idlocal_size(size);
else
emit_data(0, 0, 0, size);
}
}
return (1);
}

15
src/toolsrc/parse.pla

@ -402,7 +402,7 @@ def parse_value(codeseq, r_val)#2
else
deref++
fin
type = (type & PTR_TYPE) | token == PTRB_TKN ?? BYTE_TYPE :: WORD_TYPE
type = token == PTRB_TKN ?? BYTE_TYPE :: WORD_TYPE
if not parse_const(@const_offset)
rewind(tknptr) // Setting type override for following operations
elsif const_offset <> 0
@ -421,7 +421,7 @@ def parse_value(codeseq, r_val)#2
elsif not (type & VAR_TYPE)
deref++
fin
type = (type & VAR_TYPE) | (token == DOT_TKN ?? BYTE_TYPE :: WORD_TYPE)
type = token == DOT_TKN ?? BYTE_TYPE :: WORD_TYPE
if not parse_const(@const_offset)
rewind(tknptr) // Setting type override for following operations
elsif const_offset <> 0
@ -941,8 +941,12 @@ def parse_var(type, basesize)#0
else
new_iddata(idptr, idlen, type, size)
fin
elsif not (type & (EXTERN_TYPE|LOCAL_TYPE))
emit_fill(size)
elsif not type & EXTERN_TYPE
if type & LOCAL_TYPE
framesize = framesize + size
else
size_iddata(type, size, 0)
fin
fin
fin
end
@ -1024,8 +1028,9 @@ def parse_vars(type)
is EXPORT_TKN
if type & (EXTERN_TYPE|LOCAL_TYPE); exit_err(ERR_INVAL|ERR_LOCAL|ERR_SYNTAX); fin
type = EXPORT_TYPE
idptr = tknptr
if scan <> BYTE_TKN and token <> WORD_TKN // This could be an exported definition
rewind(tknptr)
rewind(idptr)
scan
return FALSE
fin

9
src/toolsrc/plasm.pla

@ -278,7 +278,6 @@ byte outflags
byte refnum, srcref, incref
byte[32] srcfile, incfile, relfile
word parsefile // Pointer to current file
word sysincbuf, sysincfre // System I/O buffer for include files
word srcline // Saved source line number
//
// Scanner variables
@ -387,7 +386,10 @@ def exit_err(err)#0
if err & ERR_TABLE; puts("table"); fin
if err & ERR_SYNTAX; puts("syntax"); fin
putcurln
fileio:close(0) // Close all open files
if incref
fileio:close(incref) // Close include file if open
fin
fileio:close(srcref) // Close source file
throw(exit, TRUE)
end
//
@ -409,7 +411,7 @@ include "toolsrc/parse.pla"
//
// Look at command line arguments and compile module
//
puts("PLASMA Compiler, Version 1.0\n")
puts("PLASMA Compiler, Version 1.02\n")
arg = argNext(argFirst)
if ^arg and ^(arg + 1) == '-'
opt = arg + 2
@ -464,6 +466,7 @@ if ^arg
fin
fin
if srcfile and relfile
fileio:iobufalloc(2) // Reserve two I/O buffers
srcref = fileio:open(@srcfile)
if srcref
fileio:newline(srcref, $7F, $0D)

2
src/toolsrc/symbols.h

@ -46,4 +46,6 @@ int id_tag(char *name, int len);
int id_const(char *name, int len);
int id_type(char *name, int len);
void idglobal_size(int type, int size, int constsize);
void idlocal_size(int size);
void idlocal_size(int size);
int tag_new(int type);

849
src/vmsrc/a1cmd.pla

File diff suppressed because it is too large Load Diff

22
src/vmsrc/cmd.pla

@ -808,7 +808,7 @@ asm reloc(modfix, modofst, bytecode, rld)#3
PLA
AND #$10 ; EXTERN REF - EXIT
BNE RLDEX
LDY #$00 ; FIXUP=*ADDR+MODOFST
TAY ; FIXUP=*ADDR+MODOFST
LDA (DST),Y
INY
CLC
@ -1058,7 +1058,7 @@ def loadmod(mod)#1
moddep = @header.1
defofst = modsize + RELADDR
init = 0
if rdlen > 4 and header:2 == $6502 // DAVE+1 = magic number :-)
if rdlen > 4 and header:2 == $6502 // magic number
//
// This is an EXTended RELocatable (data+bytecode) module.
//
@ -1271,24 +1271,19 @@ def volumes()#0
strbuf = strbuf + 16
next
end
def catalog(optpath)#1
byte path[64]
def catalog(path)#0
byte refnum
byte firstblk
byte entrylen, entriesblk
byte i, type, len
word entry, filecnt
if ^optpath
strcpy(@path, optpath)
else
pfxop(@path, GET_PFX)
prstr(@path)
crout()
if !^path
path = @prefix
fin
refnum = open(@path)
refnum = open(path)
if perr
return perr
return
fin
firstblk = 1
repeat
@ -1332,7 +1327,6 @@ def catalog(optpath)#1
until !filecnt
close(refnum)
crout()
return 0
end
def stripchars(strptr)#1
while ^strptr and ^(strptr + 1) > ' '
@ -1439,7 +1433,7 @@ heap = *freemem
//
// Print PLASMA version
//
prstr("PLASMA Pre3 "); prbyte(version.1); cout('.'); prbyte(version.0); crout
prstr("PLASMA "); prbyte(version.1); cout('.'); prbyte(version.0); crout
//
// Init symbol table.
//

4
src/vmsrc/plvm.c

@ -499,12 +499,14 @@ void call(uword pc)
PUSH(getchar());
break;
case 8: // LIBRARY STDLIB::GETS
c = POP;
putchar(c);
gets(sz);
for (i = 0; sz[i]; i++)
mem_data[0x200 + i] = sz[i];
mem_data[0x200 + i] = 0;
mem_data[0x1FF] = i;
PUSH(i);
PUSH(0x1FF);
break;
default:
printf("\nUnimplemented call code:$%02X\n", mem_data[pc - 1]);

425
src/vmsrc/plvm01.s

@ -5,7 +5,6 @@
;* SYSTEM ROUTINES AND LOCATIONS
;*
;**********************************************************
SELFMODIFY = 1
;*
;* VM ZERO PAGE LOCATIONS
;*
@ -20,18 +19,6 @@ IPH = IPL+1
OPIDX = FETCHOP+6
OPPAGE = OPIDX+1
;*
;* INTERPRETER INSTRUCTION POINTER INCREMENT MACRO
;*
!MACRO INC_IP {
INY
BPL +
INC IPH
TYA
AND #$7F
TAY
+
}
;*
;* INTERPRETER HEADER+INITIALIZATION
;*
*= $0280
@ -92,21 +79,21 @@ MULLP LSR TMPH ; MULTPLRH
BNE MULLP
STA ESTKH+1,X ; PRODH
LDY IPY
JMP DROP
JMP DROP
;*
;* INCREMENT TOS
;*
INCR INC ESTKL,X
BNE INCR1
BNE +
INC ESTKH,X
INCR1 JMP NEXTOP
+ JMP NEXTOP
;*
;* DECREMENT TOS
;*
DECR LDA ESTKL,X
BNE DECR1
BNE +
DEC ESTKH,X
DECR1 DEC ESTKL,X
+ DEC ESTKL,X
JMP NEXTOP
;*
;* BITWISE COMPLIMENT TOS
@ -121,7 +108,7 @@ COMP LDA #$FF
;*
;* OPCODE TABLE
;*
!ALIGN 255,0
!ALIGN 255,0
OPTBL !WORD ZERO,ADD,SUB,MUL,DIV,MOD,INCR,DECR ; 00 02 04 06 08 0A 0C 0E
!WORD NEG,COMP,BAND,IOR,XOR,SHL,SHR,IDXW ; 10 12 14 16 18 1A 1C 1E
!WORD LNOT,LOR,LAND,LA,LLA,CB,CW,CS ; 20 22 24 26 28 2A 2C 2E
@ -154,10 +141,9 @@ MOD JSR _DIV
DIVMOD JSR _DIV
LSR DVSIGN ; SIGN(RESULT) = (SIGN(DIVIDEND) + SIGN(DIVISOR)) & 1
BCC +
INX
JSR _NEG
DEX
+ LDA TMPL ; REMNDRL
+ DEX
LDA TMPL ; REMNDRL
STA ESTKL,X
LDA TMPH ; REMNDRH
STA ESTKH,X
@ -292,24 +278,24 @@ XOR LDA ESTKL+1,X
;*
;* SHIFT TOS-1 LEFT BY TOS
;*
SHL STY IPY
SHL STY IPY
LDA ESTKL,X
CMP #$08
BCC SHL1
BCC +
LDY ESTKL+1,X
STY ESTKH+1,X
LDY #$00
STY ESTKL+1,X
SBC #$08
SHL1 TAY
BEQ SHL3
+ TAY
BEQ +
LDA ESTKL+1,X
SHL2 ASL
- ASL
ROL ESTKH+1,X
DEY
BNE SHL2
BNE -
STA ESTKL+1,X
SHL3 LDY IPY
+ LDY IPY
JMP DROP
;*
;* SHIFT TOS-1 RIGHT BY TOS
@ -317,51 +303,40 @@ SHL3 LDY IPY
SHR STY IPY
LDA ESTKL,X
CMP #$08
BCC SHR2
BCC ++
LDY ESTKH+1,X
STY ESTKL+1,X
CPY #$80
LDY #$00
BCC SHR1
BCC +
DEY
SHR1 STY ESTKH+1,X
+ STY ESTKH+1,X
SEC
SBC #$08
SHR2 TAY
BEQ SHR4
++ TAY
BEQ +
LDA ESTKH+1,X
SHR3 CMP #$80
- CMP #$80
ROR
ROR ESTKL+1,X
DEY
BNE SHR3
BNE -
STA ESTKH+1,X
SHR4 LDY IPY
+ LDY IPY
JMP DROP
;*
;* LOGICAL NOT
;*
LNOT LDA ESTKL,X
ORA ESTKH,X
BEQ LNOT1
LDA #$FF
LNOT1 EOR #$FF
STA ESTKL,X
STA ESTKH,X
JMP NEXTOP
;*
;* LOGICAL AND
;*
LAND LDA ESTKL+1,X
ORA ESTKH+1,X
BEQ LAND2
BEQ ++
LDA ESTKL,X
ORA ESTKH,X
BEQ LAND1
BEQ +
LDA #$FF
LAND1 STA ESTKL+1,X
+ STA ESTKL+1,X
STA ESTKH+1,X
LAND2 JMP DROP
++ JMP DROP
;*
;* LOGICAL OR
;*
@ -369,11 +344,11 @@ LOR LDA ESTKL,X
ORA ESTKH,X
ORA ESTKL+1,X
ORA ESTKH+1,X
BEQ LOR1
BEQ +
LDA #$FF
STA ESTKL+1,X
STA ESTKH+1,X
LOR1 JMP DROP
+ JMP DROP
;*
;* DUPLICATE TOS
;*
@ -384,10 +359,20 @@ DUP DEX
STA ESTKH,X
JMP NEXTOP
;*
;* LOGICAL NOT
;*
LNOT LDA ESTKL,X
ORA ESTKH,X
BNE +
LDA #$FF
STA ESTKL,X
STA ESTKH,X
JMP NEXTOP
;*
;* CONSTANT
;*
ZERO DEX
LDA #$00
+ LDA #$00
STA ESTKL,X
STA ESTKH,X
JMP NEXTOP
@ -396,19 +381,34 @@ CFFB LDA #$FF
CB LDA #$00
DEX
STA ESTKH,X
+INC_IP
INY ;+INC_IP
LDA (IP),Y
STA ESTKL,X
JMP NEXTOP
;*
;* LOAD ADDRESS & LOAD CONSTANT WORD (SAME THING, WITH OR WITHOUT FIXUP)
;*
LA = *
CW DEX
INY ;+INC_IP
- TYA ; RENORMALIZE IP
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ LDY #$FF
LA INY ;+INC_IP
BMI -
DEX
LDA (IP),Y
STA ESTKL,X
+INC_IP
INY
LDA (IP),Y
STA ESTKH,X
JMP NEXTOP
CW DEX
INY ;+INC_IP
LDA (IP),Y
STA ESTKL,X
INY
LDA (IP),Y
STA ESTKH,X
JMP NEXTOP
@ -416,9 +416,9 @@ CW DEX
;* CONSTANT STRING
;*
CS DEX
INY ;+INC_IP
TYA ; NORMALIZE IP AND SAVE STRING ADDR ON ESTK
CLC
;INY ;+INC_IP
TYA ; NORMALIZE IP AND SAVE STRING ADDR ON ESTK
SEC
ADC IPL
STA IPL
STA ESTKL,X
@ -433,46 +433,38 @@ CS DEX
;*
;* LOAD VALUE FROM ADDRESS TAG
;*
!IF SELFMODIFY {
LB LDA ESTKL,X
STA LBLDA+1
LDA ESTKH,X
STA LBLDA+2
LBLDA LDA $FFFF
STA ESTKH-1,X
LDA (ESTKH-1,X)
STA ESTKL,X
LDA #$00
STA ESTKH,X
JMP NEXTOP
} ELSE {
LB LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
STY IPY
LDY #$00
LDA (TMP),Y
STA ESTKL,X
STY ESTKH,X
LDY IPY
JMP NEXTOP
}
LW LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
STY IPY
LDY #$00
LDA (TMP),Y
STA ESTKH-1,X
LDA (ESTKH-1,X)
STA ESTKL,X
INY
LDA (TMP),Y
INC ESTKH-1,X
BEQ +
LDA (ESTKH-1,X)
STA ESTKH,X
JMP NEXTOP
+ INC ESTKH,X
LDA (ESTKH-1,X)
STA ESTKH,X
LDY IPY
JMP NEXTOP
;*
;* LOAD ADDRESS OF LOCAL FRAME OFFSET
;*
LLA +INC_IP
- TYA ; RENORMALIZE IP
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ LDY #$FF
LLA INY ;+INC_IP
BMI -
LDA (IP),Y
DEX
CLC
@ -485,7 +477,7 @@ LLA +INC_IP
;*
;* LOAD VALUE FROM LOCAL FRAME OFFSET
;*
LLB +INC_IP
LLB INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -496,7 +488,7 @@ LLB +INC_IP
STA ESTKH,X
LDY IPY
JMP NEXTOP
LLW +INC_IP
LLW INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -511,39 +503,22 @@ LLW +INC_IP
;*
;* LOAD VALUE FROM ABSOLUTE ADDRESS
;*
!IF SELFMODIFY {
LAB INY ;+INC_IP
LAB INY ;+INC_IP
LDA (IP),Y
STA LABLDA+1
+INC_IP
STA ESTKH-2,X
INY ;+INC_IP
LDA (IP),Y
STA LABLDA+2
LABLDA LDA $FFFF
STA ESTKH-1,X
LDA (ESTKH-2,X)
DEX
STA ESTKL,X
LDA #$00
STA ESTKH,X
JMP NEXTOP
} ELSE {
LAB INY ;+INC_IP
LAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
LDY #$00
LDA (TMP),Y
DEX
STA ESTKL,X
STY ESTKH,X
LDY IPY
JMP NEXTOP
}
LAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
@ -559,54 +534,39 @@ LAW INY ;+INC_IP
;*
;* STORE VALUE TO ADDRESS
;*
!IF SELFMODIFY {
SB LDA ESTKL,X
STA SBSTA+1
LDA ESTKH,X
STA SBSTA+2
STA ESTKH-1,X
LDA ESTKL+1,X
SBSTA STA $FFFF
STA (ESTKH-1,X)
INX
JMP DROP
} ELSE {
SB LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
LDA ESTKL+1,X
STY IPY
LDY #$00
STA (TMP),Y
LDY IPY
INX
JMP DROP
}
SW LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
STY IPY
LDY #$00
STA ESTKH-1,X
LDA ESTKL+1,X
STA (TMP),Y
INY
STA (ESTKH-1,X)
LDA ESTKH+1,X
STA (TMP),Y
LDY IPY
INC ESTKH-1,X
BEQ +
STA (ESTKH-1,X)
INX
JMP DROP
+ INC ESTKH,X
STA (ESTKH-1,X)
INX
JMP DROP
;*
;* STORE VALUE TO LOCAL FRAME OFFSET
;*
SLB +INC_IP
SLB INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
LDA ESTKL,X
STA (IFP),Y
LDY IPY
BMI FIXDROP
JMP DROP
SLW +INC_IP
SLW INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -616,11 +576,20 @@ SLW +INC_IP
LDA ESTKH,X
STA (IFP),Y
LDY IPY
BMI FIXDROP
JMP DROP
FIXDROP TYA
LDY #$00
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ JMP DROP
;*
;* STORE VALUE TO LOCAL FRAME OFFSET WITHOUT POPPING STACK
;*
DLB +INC_IP
DLB INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -628,7 +597,7 @@ DLB +INC_IP
STA (IFP),Y
LDY IPY
JMP NEXTOP
DLW +INC_IP
DLW INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -642,34 +611,27 @@ DLW +INC_IP
;*
;* STORE VALUE TO ABSOLUTE ADDRESS
;*
!IF SELFMODIFY {
SAB INY ;+INC_IP
- TYA ; RENORMALIZE IP
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ LDY #$FF
SAB INY ;+INC_IP
BMI -
LDA (IP),Y
STA SABSTA+1
+INC_IP
STA ESTKH-2,X
INY ;+INC_IP
LDA (IP),Y
STA SABSTA+2
STA ESTKH-1,X
LDA ESTKL,X
SABSTA STA $FFFF
STA (ESTKH-2,X)
JMP DROP
} ELSE {
SAB INY ;+INC_IP
SAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
LDA (IP),Y
STA TMPH
LDA ESTKL,X
STY IPY
LDY #$00
STA (TMP),Y
LDY IPY
JMP DROP
}
SAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
@ -680,38 +642,24 @@ SAW INY ;+INC_IP
LDA ESTKH,X
STA (TMP),Y
LDY IPY
BMI FIXDROP
JMP DROP
;*
;* STORE VALUE TO ABSOLUTE ADDRESS WITHOUT POPPING STACK
;*
!IF SELFMODIFY {
DAB INY ;+INC_IP
DAB INY ;+INC_IP
LDA (IP),Y
STA DABSTA+1
+INC_IP
STA ESTKH-2,X
INY ;+INC_IP
LDA (IP),Y
STA DABSTA+2
STA ESTKH-1,X
LDA ESTKL,X
DABSTA STA $FFFF
STA (ESTKH-2,X)
JMP NEXTOP
} ELSE {
DAB INY ;+INC_IP
DAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
LDY #$00
LDA ESTKL,X
STA (TMP),Y
LDY IPY
JMP NEXTOP
}
DAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
@ -752,37 +700,41 @@ ISGE LDA ESTKL+1,X
CMP ESTKL,X
LDA ESTKH+1,X
SBC ESTKH,X
BVC ISGE1
EOR #$80
ISGE1 BPL ISTRU
BVS +
BPL ISTRU
BMI ISFLS
+ BPL ISFLS
BMI ISTRU
;
ISGT LDA ESTKL,X
CMP ESTKL+1,X
LDA ESTKH,X
SBC ESTKH+1,X
BVC ISGT1
EOR #$80
ISGT1 BMI ISTRU
BVS +
BMI ISTRU
BPL ISFLS
+ BMI ISFLS
BPL ISTRU
;
ISLE LDA ESTKL,X
CMP ESTKL+1,X
LDA ESTKH,X
SBC ESTKH+1,X
BVC ISLE1
EOR #$80
ISLE1 BPL ISTRU
BVS +
BPL ISTRU
BMI ISFLS
+ BPL ISFLS
BMI ISTRU
;
ISLT LDA ESTKL+1,X
CMP ESTKL,X
LDA ESTKH+1,X
SBC ESTKH,X
BVC ISLT1
EOR #$80
ISLT1 BMI ISTRU
BVS +
BMI ISTRU
BPL ISFLS
+ BMI ISFLS
BPL ISTRU
;*
;* BRANCHES
;*
@ -790,9 +742,18 @@ BRTRU INX
LDA ESTKH-1,X
ORA ESTKL-1,X
BNE BRNCH
NOBRNCH INY ;+INC_IP
+INC_IP
NOBRNCH INY ;+INC_IP
INY ;+INC_IP
BMI FIXNEXT
JMP NEXTOP
FIXNEXT TYA
LDY #$00
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ JMP NEXTOP
BRFLS INX
LDA ESTKH-1,X
ORA ESTKL-1,X
@ -836,20 +797,34 @@ BRGT INX
CMP ESTKL,X
LDA ESTKH-1,X
SBC ESTKH,X
BVS +
BPL NOBRNCH
BMI BRNCH
+ BPL BRNCH
BMI NOBRNCH
BRLT INX
LDA ESTKL,X
CMP ESTKL-1,X
LDA ESTKH,X
SBC ESTKH-1,X
BVS +
BPL NOBRNCH
BMI BRNCH
IBRNCH LDA IPL
+ BPL BRNCH
BMI NOBRNCH
IBRNCH TYA ; FLATTEN IP
CLC
ADC IPL
STA TMPL
LDA #$00
TAY
ADC IPH
STA TMPH ; ADD BRANCH OFFSET
LDA TMPL
;CLC ; BETTER NOT CARRY OUT OF IP+Y
ADC ESTKL,X
STA IPL
LDA IPH
LDA TMPH
ADC ESTKH,X
STA IPH
JMP DROP
@ -857,36 +832,20 @@ IBRNCH LDA IPL
;* INDIRECT CALL TO ADDRESS (NATIVE CODE)
;*
ICAL LDA ESTKL,X
!IF SELFMODIFY {
STA CALLADR+1
} ELSE {
STA TMPL
}
LDA ESTKH,X
!IF SELFMODIFY {
STA CALLADR+2
} ELSE {
STA TMPH
}
INX
BNE _CALL
;*
;* CALL INTO ABSOLUTE ADDRESS (NATIVE CODE)
;*
CALL INY ;+INC_IP
CALL INY ;+INC_IP
LDA (IP),Y
!IF SELFMODIFY {
STA CALLADR+1
} ELSE {
STA TMPL
}
INY ;+INC_IP
INY ;+INC_IP
LDA (IP),Y
!IF SELFMODIFY {
STA CALLADR+2
} ELSE {
STA TMPH
}
_CALL TYA
CLC
ADC IPL
@ -894,11 +853,7 @@ _CALL TYA
LDA IPH
ADC #$00
PHA
!IF SELFMODIFY {
CALLADR JSR $FFFF
} ELSE {
JSR JMPTMP
}
PLA
STA IPH
PLA
@ -938,14 +893,14 @@ ENTER INY
;*
;* LEAVE FUNCTION
;*
LEAVE INY ;+INC_IP
LEAVE INY ;+INC_IP
LDA (IP),Y
CLC
ADC IFPL
STA IFPL
BCS LIFPH
BCS +
RTS
LIFPH INC IFPH
+ INC IFPH
RET RTS
A1CMD !SOURCE "vmsrc/a1cmd.a"
SEGEND = *
@ -954,6 +909,8 @@ VMINIT LDY #$10 ; INSTALL PAGE 0 FETCHOP ROUTINE
STA DROP-1,Y
DEY
BNE -
LDA #$4C ; SET JMPTMP OPCODE
STA JMPTMP
STY IFPL ; INIT FRAME POINTER
LDA #$80
STA IFPH
@ -962,7 +919,7 @@ VMINIT LDY #$10 ; INSTALL PAGE 0 FETCHOP ROUTINE
LDA #>SEGEND
STA SRCH
LDX #ESTKSZ/2 ; INIT EVAL STACK INDEX
JMP A1CMD
JMP A1CMD
PAGE0 = *
!PSEUDOPC DROP {
;*

474
src/vmsrc/plvm02.s

@ -5,6 +5,7 @@
;* SYSTEM ROUTINES AND LOCATIONS
;*
;**********************************************************
!CPU 65C02
;*
;* MONITOR SPECIAL LOCATIONS
;*
@ -127,9 +128,31 @@ RAMDONE ;CLI UNTIL I KNOW WHAT TO DO WITH THE UNENHANCED IIE
INY
BNE -
;*
;* INSERT 65C02 OPS IF APPLICABLE
;*
LDA #$00
INC
BEQ +
JSR C02OPS
;*
;* SET 64K ENTER/LEAVE (NO NEED FOR STRING POOL)
;*
+ LDA MACHID
AND #$30
CMP #$30
BEQ +
LDA #<ENTER64
STA OPTBL+$58
LDA #>ENTER64
STA OPTBL+$59
LDA #<LEAVE64
STA OPTBL+$5A
LDA #>LEAVE64
STA OPTBL+$5B
;*
;* SAVE DEFAULT COMMAND INTERPRETER PATH IN LC
;*
JSR PRODOS ; GET PREFIX
+ JSR PRODOS ; GET PREFIX
!BYTE $C7
!WORD GETPFXPARMS
LDY STRBUF ; APPEND "CMD"
@ -175,7 +198,7 @@ OPTBL !WORD ZERO,ADD,SUB,MUL,DIV,MOD,INCR,DECR ; 00 02 04 06 08
!WORD LNOT,LOR,LAND,LA,LLA,CB,CW,CS ; 20 22 24 26 28 2A 2C 2E
!WORD DROP,DUP,NEXTOP,DIVMOD,BRGT,BRLT,BREQ,BRNE ; 30 32 34 36 38 3A 3C 3E
!WORD ISEQ,ISNE,ISGT,ISLT,ISGE,ISLE,BRFLS,BRTRU ; 40 42 44 46 48 4A 4C 4E
!WORD BRNCH,IBRNCH,CALL,ICAL,ENTER,LEAVE,RET,CFFB ; 50 52 54 56 58 5A 5C 5E
!WORD BRNCH,IBRNCH,CALL,ICAL,ENTER,LEAVE,RET,CFFB ; 50 52 54 56 58 5A 5C 5E
!WORD LB,LW,LLB,LLW,LAB,LAW,DLB,DLW ; 60 62 64 66 68 6A 6C 6E
!WORD SB,SW,SLB,SLW,SAB,SAW,DAB,DAW ; 70 72 74 76 78 7A 7C 7E
;*
@ -382,7 +405,7 @@ OPXTBL !WORD ZERO,ADD,SUB,MUL,DIV,MOD,INCR,DECR ; 00 02 04 06 08
!WORD LNOT,LOR,LAND,LA,LLA,CB,CW,CSX ; 20 22 24 26 28 2A 2C 2E
!WORD DROP,DUP,NEXTOP,DIVMOD,BRGT,BRLT,BREQ,BRNE ; 30 32 34 36 38 3A 3C 3E
!WORD ISEQ,ISNE,ISGT,ISLT,ISGE,ISLE,BRFLS,BRTRU ; 40 42 44 46 48 4A 4C 4E
!WORD BRNCH,IBRNCH,CALLX,ICALX,ENTER,LEAVEX,RETX,CFFB ; 50 52 54 56 58 5A 5C 5E
!WORD BRNCH,IBRNCH,CALLX,ICALX,ENTER,LEAVEX,RETX,CFFB; 50 52 54 56 58 5A 5C 5E
!WORD LBX,LWX,LLBX,LLWX,LABX,LAWX,DLB,DLW ; 60 62 64 66 68 6A 6C 6E
!WORD SB,SW,SLB,SLW,SAB,SAW,DAB,DAW ; 70 72 74 76 78 7A 7C 7E
;*
@ -501,7 +524,8 @@ _DIVLP ROL TMPL ; REMNDRL
ROL ESTKH+1,X ; DVDNDH
DEY
BNE _DIVLP
_DIVEX LDY IPY
_DIVEX INX
LDY IPY
RTS
;*
;* NEGATE TOS
@ -518,7 +542,6 @@ NEG LDA #$00
;* DIV TOS-1 BY TOS
;*
DIV JSR _DIV
INX
LSR DVSIGN ; SIGN(RESULT) = (SIGN(DIVIDEND) + SIGN(DIVISOR)) & 1
BCS NEG
JMP NEXTOP
@ -526,7 +549,6 @@ DIV JSR _DIV
;* MOD TOS-1 BY TOS
;*
MOD JSR _DIV
INX
LDA TMPL ; REMNDRL
STA ESTKL,X
LDA TMPH ; REMNDRH
@ -540,10 +562,9 @@ MOD JSR _DIV
DIVMOD JSR _DIV
LSR DVSIGN ; SIGN(RESULT) = (SIGN(DIVIDEND) + SIGN(DIVISOR)) & 1
BCC +
INX
JSR _NEG
DEX
+ LDA TMPL ; REMNDRL
+ DEX
LDA TMPL ; REMNDRL
STA ESTKL,X
LDA TMPH ; REMNDRH
STA ESTKH,X
@ -554,18 +575,18 @@ DIVMOD JSR _DIV
;* INCREMENT TOS
;*
INCR INC ESTKL,X
BEQ INCR1
BEQ +
JMP NEXTOP
INCR1 INC ESTKH,X
+ INC ESTKH,X
JMP NEXTOP
;*
;* DECREMENT TOS
;*
DECR LDA ESTKL,X
BEQ DECR1
BEQ +
DEC ESTKL,X
JMP NEXTOP
DECR1 DEC ESTKL,X
+ DEC ESTKL,X
DEC ESTKH,X
JMP NEXTOP
;*
@ -614,21 +635,21 @@ XOR LDA ESTKL+1,X
SHL STY IPY
LDA ESTKL,X
CMP #$08
BCC SHL1
BCC +
LDY ESTKL+1,X
STY ESTKH+1,X
LDY #$00
STY ESTKL+1,X
SBC #$08
SHL1 TAY
BEQ SHL3
+ TAY
BEQ +
LDA ESTKL+1,X
SHL2 ASL
- ASL
ROL ESTKH+1,X
DEY
BNE SHL2
BNE -
STA ESTKL+1,X
SHL3 LDY IPY
+ LDY IPY
JMP DROP
;*
;* SHIFT TOS-1 RIGHT BY TOS
@ -636,40 +657,40 @@ SHL3 LDY IPY
SHR STY IPY
LDA ESTKL,X
CMP #$08
BCC SHR2
BCC ++
LDY ESTKH+1,X
STY ESTKL+1,X
CPY #$80
LDY #$00
BCC SHR1
BCC +
DEY
SHR1 STY ESTKH+1,X
+ STY ESTKH+1,X
SEC
SBC #$08
SHR2 TAY
BEQ SHR4
++ TAY
BEQ +
LDA ESTKH+1,X
SHR3 CMP #$80
- CMP #$80
ROR
ROR ESTKL+1,X
DEY
BNE SHR3
BNE -
STA ESTKH+1,X
SHR4 LDY IPY
+ LDY IPY
JMP DROP
;*
;* LOGICAL AND
;*
LAND LDA ESTKL+1,X
ORA ESTKH+1,X
BEQ LAND2
BEQ ++
LDA ESTKL,X
ORA ESTKH,X
BEQ LAND1
BEQ +
LDA #$FF
LAND1 STA ESTKL+1,X
+ STA ESTKL+1,X
STA ESTKH+1,X
LAND2 JMP DROP
++ JMP DROP
;*
;* LOGICAL OR
;*
@ -677,11 +698,11 @@ LOR LDA ESTKL,X
ORA ESTKH,X
ORA ESTKL+1,X
ORA ESTKH+1,X
BEQ LOR1
BEQ +
LDA #$FF
STA ESTKL+1,X
STA ESTKH+1,X
LOR1 JMP DROP
+ JMP DROP
;*
;* DUPLICATE TOS
;*
@ -709,12 +730,17 @@ ZERO DEX
STA ESTKL,X
STA ESTKH,X
JMP NEXTOP
CFFB LDA #$FF
!BYTE $2C ; BIT $00A9 - effectively skips LDA #$00, no harm in reading this address
CB LDA #$00
DEX
CFFB DEX
LDA #$FF
STA ESTKH,X
INY
INY ;+INC_IP
LDA (IP),Y
STA ESTKL,X
JMP NEXTOP
CB DEX
LDA #$00
STA ESTKH,X
INY ;+INC_IP
LDA (IP),Y
STA ESTKL,X
JMP NEXTOP
@ -749,9 +775,9 @@ CW DEX
;* CONSTANT STRING
;*
CS DEX
INY ;+INC_IP
;INY ;+INC_IP
TYA ; NORMALIZE IP AND SAVE STRING ADDR ON ESTK
CLC
SEC
ADC IPL
STA IPL
STA ESTKL,X
@ -765,9 +791,9 @@ CS DEX
JMP NEXTOP
;
CSX DEX
INY ;+INC_IP
;INY ;+INC_IP
TYA ; NORMALIZE IP
CLC
SEC
ADC IPL
STA IPL
LDA #$00
@ -1133,8 +1159,9 @@ SAW INY ;+INC_IP
LDA ESTKH,X
STA (TMP),Y
LDY IPY
BMI FIXDROP
BMI +
JMP DROP
JMP FIXDROP
;*
;* STORE VALUE TO ABSOLUTE ADDRESS WITHOUT POPPING STACK
;*
@ -1437,6 +1464,29 @@ ICALX LDA ESTKL,X
;*
;* ENTER FUNCTION WITH FRAME SIZE AND PARAM COUNT
;*
ENTER64 INY
LDA (IP),Y
EOR #$FF
SEC
ADC IFPL
STA IFPL
BCS +
DEC IFPH
+ INY
LDA (IP),Y
BEQ +
ASL
TAY
- LDA ESTKH,X
DEY
STA (IFP),Y
LDA ESTKL,X
INX
DEY
STA (IFP),Y
BNE -
+ LDY #$03
JMP FETCHOP
ENTER LDA IFPH
PHA ; SAVE ON STACK FOR LEAVE
LDA IFPL
@ -1487,6 +1537,15 @@ RETX STA ALTRDOFF
PHA
PLP
RTS
LEAVE64 INY ;+INC_IP
LDA (IP),Y
CLC
ADC IFPL
STA IFPL
BCS +
RTS
+ INC IFPH
RTS
LEAVE INY ;+INC_IP
LDA (IP),Y
CLC
@ -1502,3 +1561,332 @@ LEAVE INY ;+INC_IP
RET RTS
VMEND = *
}
;***************************************
;* *
;* 65C02 OPS TO OVERWRITE STANDARD OPS *
;* *
;***************************************
C02OPS LDA #<DINTRP
LDX #>DINTRP
LDY #(CDINTRPEND-CDINTRP)
JSR OPCPY
CDINTRP PLY
PLA
INY
BNE +
INC
+ STY IPL
STA IPH
LDY #$00
LDA #>OPTBL
STA OPPAGE
JMP FETCHOP
CDINTRPEND
;
LDA #<ZERO
LDX #>ZERO
LDY #(CZEROEND-CZERO)
JSR OPCPY
CZERO DEX
STZ ESTKL,X
STZ ESTKH,X
JMP NEXTOP
CZEROEND
;
LDA #<CB
LDX #>CB
LDY #(CCBEND-CCB)
JSR OPCPY
CCB DEX
STZ ESTKH,X
INY
LDA (IP),Y
STA ESTKL,X
JMP NEXTOP
CCBEND
;
LDA #<CS
LDX #>CS
LDY #(CCSEND-CCS)
JSR OPCPY
CCS DEX
;INY ;+INC_IP
TYA ; NORMALIZE IP AND SAVE STRING ADDR ON ESTK
SEC
ADC IPL
STA IPL
STA ESTKL,X
LDA #$00
ADC IPH
STA IPH
STA ESTKH,X
LDA (IP)
TAY
JMP NEXTOP
CCSEND
;
LDA #<SHL
LDX #>SHL
LDY #(CSHLEND-CSHL)
JSR OPCPY
CSHL STY IPY
LDA ESTKL,X
CMP #$08
BCC +
LDY ESTKL+1,X
STY ESTKH+1,X
STZ ESTKL+1,X
SBC #$08
+ TAY
BEQ +
LDA ESTKL+1,X
- ASL
ROL ESTKH+1,X
DEY
BNE -
STA ESTKL+1,X
+ LDY IPY
JMP DROP
CSHLEND
;
LDA #<LB
LDX #>LB
LDY #(CLBEND-CLB)
JSR OPCPY
CLB LDA ESTKL,X
STA ESTKH-1,X
LDA (ESTKH-1,X)
STA ESTKL,X
STZ ESTKH,X
JMP NEXTOP
CLBEND
;
LDA #<LBX
LDX #>LBX
LDY #(CLBXEND-CLBX)
JSR OPCPY
CLBX LDA ESTKL,X
STA ESTKH-1,X
STA ALTRDOFF
LDA (ESTKH-1,X)
STA ESTKL,X
STZ ESTKH,X
STA ALTRDON
JMP NEXTOP
CLBXEND
;
LDA #<LLB
LDX #>LLB
LDY #(CLLBEND-CLLB)
JSR OPCPY
CLLB INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
DEX
LDA (IFP),Y
STA ESTKL,X
STZ ESTKH,X
LDY IPY
JMP NEXTOP
CLLBEND
;
LDA #<LLBX
LDX #>LLBX
LDY #(CLLBXEND-CLLBX)
JSR OPCPY
CLLBX INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
DEX
STA ALTRDOFF
LDA (IFP),Y
STA ESTKL,X
STZ ESTKH,X
STA ALTRDON
LDY IPY
JMP NEXTOP
CLLBXEND
;
LDA #<LAB
LDX #>LAB
LDY #(CLABEND-CLAB)
JSR OPCPY
CLAB INY ;+INC_IP
LDA (IP),Y
STA ESTKH-2,X
INY ;+INC_IP
LDA (IP),Y
STA ESTKH-1,X
LDA (ESTKH-2,X)
DEX
STA ESTKL,X
STZ ESTKH,X
JMP NEXTOP
CLABEND
;
LDA #<LAW
LDX #>LAW
LDY #(CLAWEND-CLAW)
JSR OPCPY
CLAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
LDA (TMP)
DEX
STA ESTKL,X
LDY #$01
LDA (TMP),Y
STA ESTKH,X
LDY IPY
JMP NEXTOP
CLAWEND
;
LDA #<LABX
LDX #>LABX
LDY #(CLABXEND-CLABX)
JSR OPCPY
CLABX INY ;+INC_IP
LDA (IP),Y
STA ESTKH-2,X
INY ;+INC_IP
LDA (IP),Y
STA ESTKH-1,X
STA ALTRDOFF
LDA (ESTKH-2,X)
DEX
STA ESTKL,X
STZ ESTKH,X
STA ALTRDON
JMP NEXTOP
CLABXEND
;
LDA #<LAWX
LDX #>LAWX
LDY #(CLAWXEND-CLAWX)
JSR OPCPY
CLAWX INY ;+INC_IP
LDA (IP),Y
STA TMPL
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
STA ALTRDOFF
LDA (TMP)
DEX
STA ESTKL,X
LDY #$01
LDA (TMP),Y
STA ESTKH,X
STA ALTRDON
LDY IPY
JMP NEXTOP
CLAWXEND
;
LDA #<SAW
LDX #>SAW
LDY #(CSAWEND-CSAW)
JSR OPCPY
CSAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
LDA ESTKL,X
STA (TMP)
LDY #$01
LDA ESTKH,X
STA (TMP),Y
LDY IPY
BMI +
JMP DROP
+ JMP FIXDROP
CSAWEND
;
LDA #<DAW
LDX #>DAW
LDY #(CDAWEND-CDAW)
JSR OPCPY
CDAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
LDA ESTKL,X
STA (TMP)
LDY #$01
LDA ESTKH,X
STA (TMP),Y
LDY IPY
JMP NEXTOP
CDAWEND
;
LDA #<ISFLS
LDX #>ISFLS
LDY #(CISFLSEND-CISFLS)
JSR OPCPY
CISFLS STZ ESTKL+1,X
STZ ESTKH+1,X
JMP DROP
CISFLSEND
;
LDA #<BRNCH
LDX #>BRNCH
LDY #(CBRNCHEND-CBRNCH)
JSR OPCPY
CBRNCH TYA ; FLATTEN IP
SEC
ADC IPL
STA TMPL
LDA #$00
ADC IPH
STA TMPH ; ADD BRANCH OFFSET
LDA (TMP)
;CLC ; BETTER NOT CARRY OUT OF IP+Y
ADC TMPL
STA IPL
LDY #$01
LDA (TMP),Y
ADC TMPH
STA IPH
DEY
JMP FETCHOP
CBRNCHEND
;
RTS
;*
;* COPY OP TO VM
;*
OPCPY STA DST
STX DST+1
PLA
STA SRC
PLA
STA SRC+1
TYA
CLC
ADC SRC
TAX
LDA #$00
ADC SRC+1
PHA
PHX
INC SRC
BNE +
INC SRC+1
+
- LDA (SRC),Y
STA (DST),Y
DEY
BPL -
RTS

512
src/vmsrc/plvm03.s

@ -5,7 +5,6 @@
;* SYSTEM ROUTINES AND LOCATIONS
;*
;**********************************************************
SELFMODIFY = 1
;
; HARDWARE REGISTERS
;
@ -28,6 +27,7 @@ DROPX = XPAGE+DROP
IFPX = XPAGE+IFPH
PPX = XPAGE+PPH
IPX = XPAGE+IPH
JMPTMPX = XPAGE+JMPTMP
TMPX = XPAGE+TMPH
SRCX = XPAGE+SRCH
DSTX = XPAGE+DSTH
@ -40,31 +40,19 @@ DSTX = XPAGE+DSTH
!WORD .LIST
}
;*
;* INTERPRETER INSTRUCTION POINTER INCREMENT MACRO
;*
!MACRO INC_IP {
INY
BPL +
INC IPH
TYA
AND #$7F
TAY
+
}
;*
;* INTERPRETER HEADER+INITIALIZATION
;*
SEGSTART = $A000
SEGSTART = $2000
*= SEGSTART-$0E
!TEXT "SOS NTRP"
!WORD $0000
!WORD SEGSTART
!WORD SEGEND-SEGSTART
+SOS $40, SEGREQ ; ALLOCATE SEG 1 AND MAP IT
BNE FAIL ; PRHEX
LDA #$01
STA MEMBANK
; +SOS $40, SEGREQ ; ALLOCATE SEG 1 AND MAP IT
; BNE FAIL ; PRHEX
; LDA #$00
; STA MEMBANK
LDY #$0F ; INSTALL PAGE 0 FETCHOP ROUTINE
LDA #$00
- LDX PAGE0,Y
@ -72,17 +60,40 @@ DSTX = XPAGE+DSTH
STA DROPX,Y
DEY
BPL -
LDX #$4C ; SET JMPTMP OPCODE
STX JMPTMP
STA TMPX ; CLEAR ALL EXTENDED POINTERS
STA SRCX
STA DSTX
STA PPX ; INIT FRAME & POOL POINTERS
STA IFPX
LDA #<SEGSTART
LDA #$00
STA PPL
STA IFPL
LDA #>SEGSTART
LDA #$A0
STA PPH
STA IFPH
!IF 1 {
LDA #<VMCORE ; COPY VM+CMD INTO SBANK
STA SRCL
LDA #>VMCORE
STA SRCH
LDY #$00
STY DSTL
LDA #$A0
STA DSTH
- LDA (SRC),Y
STA (DST),Y
INY
BNE -
INC SRCH
INC DSTH
LDA DSTH
CMP #$B8
BNE -
}
LDX #$FF ; INIT STACK POINTER
TXS
LDX #ESTKSZ/2 ; INIT EVAL STACK INDEX
JMP SOSCMD
;PRHEX PHA
@ -103,13 +114,13 @@ DSTX = XPAGE+DSTH
; BCC +
; ADC #6
;+ STA $481 ;$880
FAIL STA $0480
RTS
SEGREQ !BYTE 4
!WORD $2001
!WORD $9F01
!BYTE $10
!BYTE $00
;FAIL STA $0480
; RTS
;SEGREQ !BYTE 4
; !WORD $2000
; !WORD $9F00
; !BYTE $10
; !BYTE $00
PAGE0 = *
!PSEUDOPC DROP {
;*
@ -121,6 +132,8 @@ PAGE0 = *
STA OPIDX
JMP (OPTBL)
}
VMCORE = *
!PSEUDOPC $A000 {
;*
;* SYSTEM INTERPRETER ENTRYPOINT
;*
@ -131,16 +144,6 @@ INTERP PLA
PLA
ADC #$00
STA IPH
LDA IFPH
PHA ; SAVE ON STACK FOR LEAVE/RET
LDA IFPL
PHA ; SAVE ON STACK FOR LEAVE/RET
LDA PPL ; SET FP TO PP
STA IFPL
LDA PPH
STA IFPH
LDY #$00
STY IPX
JMP FETCHOP
@ -161,16 +164,6 @@ XINTERP PLA
LDA (TMP),Y
STA IPL
DEY
LDA IFPH
PHA ; SAVE ON STACK FOR LEAVE/RET
LDA IFPL
PHA ; SAVE ON STACK FOR LEAVE/RET
LDA PPL ; SET FP TO PP
STA IFPL
LDA PPH
STA IFPH
JMP FETCHOP
;*
;* INTERNAL DIVIDE ALGORITHM
@ -227,6 +220,21 @@ _DIVEX INX
LDY IPY
RTS
;*
;* INCREMENT TOS
;*
INCR INC ESTKL,X
BNE +
INC ESTKH,X
+ JMP NEXTOP
;*
;* DECREMENT TOS
;*
DECR LDA ESTKL,X
BNE +
DEC ESTKH,X
+ DEC ESTKL,X
JMP NEXTOP
;*
;* OPCODE TABLE
;*
!ALIGN 255,0
@ -267,8 +275,6 @@ MULLP LSR TMPH ; MULTPLRH
BNE MULLP
STA ESTKH+1,X ; PRODH
LDY IPY
; INX
; JMP NEXTOP
JMP DROP
;*
;* NEGATE TOS
@ -299,10 +305,9 @@ MOD JSR _DIV
DIVMOD JSR _DIV
LSR DVSIGN ; SIGN(RESULT) = (SIGN(DIVIDEND) + SIGN(DIVISOR)) & 1
BCC +
INX
JSR _NEG
DEX
+ LDA TMPL ; REMNDRL
+ DEX
LDA TMPL ; REMNDRL
STA ESTKL,X
LDA TMPH ; REMNDRH
STA ESTKH,X
@ -319,8 +324,6 @@ ADD LDA ESTKL,X
LDA ESTKH,X
ADC ESTKH+1,X
STA ESTKH+1,X
; INX
; JMP NEXTOP
JMP DROP
;*
;* SUB TOS FROM TOS-1
@ -332,8 +335,6 @@ SUB LDA ESTKL+1,X
LDA ESTKH+1,X
SBC ESTKH,X
STA ESTKH+1,X
; INX
; JMP NEXTOP
JMP DROP
;
;*
@ -348,25 +349,8 @@ IDXW LDA ESTKL,X
LDA ESTKH,X
ADC ESTKH+1,X
STA ESTKH+1,X
; INX
; JMP NEXTOP
JMP DROP
;*
;* INCREMENT TOS
;*
INCR INC ESTKL,X
BNE INCR1
INC ESTKH,X
INCR1 JMP NEXTOP
;*
;* DECREMENT TOS
;*
DECR LDA ESTKL,X
BNE DECR1
DEC ESTKH,X
DECR1 DEC ESTKL,X
JMP NEXTOP
;*
;* BITWISE COMPLIMENT TOS
;*
COMP LDA #$FF
@ -385,8 +369,6 @@ BAND LDA ESTKL+1,X
LDA ESTKH+1,X
AND ESTKH,X
STA ESTKH+1,X
; INX
; JMP NEXTOP
JMP DROP
;*
;* INCLUSIVE OR TOS TO TOS-1
@ -397,8 +379,6 @@ IOR LDA ESTKL+1,X
LDA ESTKH+1,X
ORA ESTKH,X
STA ESTKH+1,X
; INX
; JMP NEXTOP
JMP DROP
;*
;* EXLUSIVE OR TOS TO TOS-1
@ -409,8 +389,6 @@ XOR LDA ESTKL+1,X
LDA ESTKH+1,X
EOR ESTKH,X
STA ESTKH+1,X
; INX
; JMP NEXTOP
JMP DROP
;*
;* SHIFT TOS-1 LEFT BY TOS
@ -418,21 +396,21 @@ XOR LDA ESTKL+1,X
SHL STY IPY
LDA ESTKL,X
CMP #$08
BCC SHL1
BCC +
LDY ESTKL+1,X
STY ESTKH+1,X
LDY #$00
STY ESTKL+1,X
SBC #$08
SHL1 TAY
BEQ SHL3
+ TAY
BEQ +
LDA ESTKL+1,X
SHL2 ASL
- ASL
ROL ESTKH+1,X
DEY
BNE SHL2
BNE -
STA ESTKL+1,X
SHL3 LDY IPY
+ LDY IPY
JMP DROP
;*
;* SHIFT TOS-1 RIGHT BY TOS
@ -440,53 +418,40 @@ SHL3 LDY IPY
SHR STY IPY
LDA ESTKL,X
CMP #$08
BCC SHR2
BCC ++
LDY ESTKH+1,X
STY ESTKL+1,X
CPY #$80
LDY #$00
BCC SHR1
BCC +
DEY
SHR1 STY ESTKH+1,X
+ STY ESTKH+1,X
SEC
SBC #$08
SHR2 TAY
BEQ SHR4
++ TAY
BEQ +
LDA ESTKH+1,X
SHR3 CMP #$80
- CMP #$80
ROR
ROR ESTKL+1,X
DEY
BNE SHR3
BNE -
STA ESTKH+1,X
SHR4 LDY IPY
+ LDY IPY
JMP DROP
;*
;* LOGICAL NOT
;*
LNOT LDA ESTKL,X
ORA ESTKH,X
BEQ LNOT1
LDA #$FF
LNOT1 EOR #$FF
STA ESTKL,X
STA ESTKH,X
JMP NEXTOP
;*
;* LOGICAL AND
;*
LAND LDA ESTKL+1,X
ORA ESTKH+1,X
BEQ LAND2
BEQ ++
LDA ESTKL,X
ORA ESTKH,X
BEQ LAND1
BEQ +
LDA #$FF
LAND1 STA ESTKL+1,X
+ STA ESTKL+1,X
STA ESTKH+1,X
;LAND2 INX
; JMP NEXTOP
LAND2 JMP DROP
++ JMP DROP
;*
;* LOGICAL OR
;*
@ -494,13 +459,11 @@ LOR LDA ESTKL,X
ORA ESTKH,X
ORA ESTKL+1,X
ORA ESTKH+1,X
BEQ LOR1
BEQ +
LDA #$FF
STA ESTKL+1,X
STA ESTKH+1,X
;LOR1 INX
; JMP NEXTOP
LOR1 JMP DROP
+ JMP DROP
;*
;* DUPLICATE TOS
;*
@ -511,10 +474,20 @@ DUP DEX
STA ESTKH,X
JMP NEXTOP
;*
;* LOGICAL NOT
;*
LNOT LDA ESTKL,X
ORA ESTKH,X
BNE +
LDA #$FF
STA ESTKL,X
STA ESTKH,X
JMP NEXTOP
;*
;* CONSTANT
;*
ZERO DEX
LDA #$00
+ LDA #$00
STA ESTKL,X
STA ESTKH,X
JMP NEXTOP
@ -523,19 +496,34 @@ CFFB LDA #$FF
CB LDA #$00
DEX
STA ESTKH,X
+INC_IP
INY ;+INC_IP
LDA (IP),Y
STA ESTKL,X
JMP NEXTOP
;*
;* LOAD ADDRESS & LOAD CONSTANT WORD (SAME THING, WITH OR WITHOUT FIXUP)
;*
LA = *
CW DEX
INY ;+INC_IP
- TYA ; RENORMALIZE IP
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ LDY #$FF
LA INY ;+INC_IP
BMI -
DEX
LDA (IP),Y
STA ESTKL,X
+INC_IP
INY
LDA (IP),Y
STA ESTKH,X
JMP NEXTOP
CW DEX
INY ;+INC_IP
LDA (IP),Y
STA ESTKL,X
INY
LDA (IP),Y
STA ESTKH,X
JMP NEXTOP
@ -543,9 +531,9 @@ CW DEX
;* CONSTANT STRING
;*
CS DEX
INY ;+INC_IP
;INY ;+INC_IP
TYA ; NORMALIZE IP
CLC
SEC
ADC IPL
STA IPL
LDA #$00
@ -609,46 +597,38 @@ _CEXS LDA (IP),Y ; SKIP TO NEXT OP ADDR AFTER STRING
;*
;* LOAD VALUE FROM ADDRESS TAG
;*
!IF SELFMODIFY {
LB LDA ESTKL,X
STA LBLDA+1
LDA ESTKH,X
STA LBLDA+2
LBLDA LDA $FFFF
STA ESTKH-1,X
LDA (ESTKH-1,X)
STA ESTKL,X
LDA #$00
STA ESTKH,X
JMP NEXTOP
} ELSE {
LB LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
STY IPY
LDY #$00
LDA (TMP),Y
STA ESTKL,X
STY ESTKH,X
LDY IPY
JMP NEXTOP
}
LW LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
STY IPY
LDY #$00
LDA (TMP),Y
STA ESTKH-1,X
LDA (ESTKH-1,X)
STA ESTKL,X
INY
LDA (TMP),Y
INC ESTKH-1,X
BEQ +
LDA (ESTKH-1,X)
STA ESTKH,X
JMP NEXTOP
+ INC ESTKH,X
LDA (ESTKH-1,X)
STA ESTKH,X
LDY IPY
JMP NEXTOP
;*
;* LOAD ADDRESS OF LOCAL FRAME OFFSET
;*
LLA +INC_IP
- TYA ; RENORMALIZE IP
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ LDY #$FF
LLA INY ;+INC_IP
BMI -
LDA (IP),Y
DEX
CLC
@ -661,7 +641,7 @@ LLA +INC_IP
;*
;* LOAD VALUE FROM LOCAL FRAME OFFSET
;*
LLB +INC_IP
LLB INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -672,7 +652,7 @@ LLB +INC_IP
STA ESTKH,X
LDY IPY
JMP NEXTOP
LLW +INC_IP
LLW INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -687,39 +667,22 @@ LLW +INC_IP
;*
;* LOAD VALUE FROM ABSOLUTE ADDRESS
;*
!IF SELFMODIFY {
LAB INY ;+INC_IP
LAB INY ;+INC_IP
LDA (IP),Y
STA LABLDA+1
+INC_IP
STA ESTKH-2,X
INY ;+INC_IP
LDA (IP),Y
STA LABLDA+2
LABLDA LDA $FFFF
STA ESTKH-1,X
LDA (ESTKH-2,X)
DEX
STA ESTKL,X
LDA #$00
STA ESTKH,X
JMP NEXTOP
} ELSE {
LAB INY ;+INC_IP
LAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
LDY #$00
LDA (TMP),Y
DEX
STA ESTKL,X
STY ESTKH,X
LDY IPY
JMP NEXTOP
}
LAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
@ -735,56 +698,39 @@ LAW INY ;+INC_IP
;*
;* STORE VALUE TO ADDRESS
;*
!IF SELFMODIFY {
SB LDA ESTKL,X
STA SBSTA+1
LDA ESTKH,X
STA SBSTA+2
STA ESTKH-1,X
LDA ESTKL+1,X
SBSTA STA $FFFF
INX
; INX
; JMP NEXTOP
JMP DROP
} ELSE {
SB LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
LDA ESTKL+1,X
STY IPY
LDY #$00
STA (TMP),Y
LDY IPY
STA (ESTKH-1,X)
INX
JMP DROP
}
SW LDA ESTKL,X
STA TMPL
LDA ESTKH,X
STA TMPH
STY IPY
LDY #$00
STA ESTKH-1,X
LDA ESTKL+1,X
STA (TMP),Y
INY
STA (ESTKH-1,X)
LDA ESTKH+1,X
STA (TMP),Y
LDY IPY
INC ESTKH-1,X
BEQ +
STA (ESTKH-1,X)
INX
JMP DROP
+ INC ESTKH,X
STA (ESTKH-1,X)
INX
JMP DROP
;*
;* STORE VALUE TO LOCAL FRAME OFFSET
;*
SLB +INC_IP
SLB INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
LDA ESTKL,X
STA (IFP),Y
LDY IPY
BMI FIXDROP
JMP DROP
SLW +INC_IP
SLW INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -794,11 +740,20 @@ SLW +INC_IP
LDA ESTKH,X
STA (IFP),Y
LDY IPY
BMI FIXDROP
JMP DROP
FIXDROP TYA
LDY #$00
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ JMP DROP
;*
;* STORE VALUE TO LOCAL FRAME OFFSET WITHOUT POPPING STACK
;*
DLB +INC_IP
DLB INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -806,7 +761,7 @@ DLB +INC_IP
STA (IFP),Y
LDY IPY
JMP NEXTOP
DLW +INC_IP
DLW INY ;+INC_IP
LDA (IP),Y
STY IPY
TAY
@ -820,34 +775,27 @@ DLW +INC_IP
;*
;* STORE VALUE TO ABSOLUTE ADDRESS
;*
!IF SELFMODIFY {
SAB INY ;+INC_IP
- TYA ; RENORMALIZE IP
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ LDY #$FF
SAB INY ;+INC_IP
BMI -
LDA (IP),Y
STA SABSTA+1
+INC_IP
STA ESTKH-2,X
INY ;+INC_IP
LDA (IP),Y
STA SABSTA+2
STA ESTKH-1,X
LDA ESTKL,X
SABSTA STA $FFFF
STA (ESTKH-2,X)
JMP DROP
} ELSE {
SAB INY ;+INC_IP
SAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
LDA (IP),Y
STA TMPH
LDA ESTKL,X
STY IPY
LDY #$00
STA (TMP),Y
LDY IPY
JMP DROP
}
SAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
@ -858,38 +806,24 @@ SAW INY ;+INC_IP
LDA ESTKH,X
STA (TMP),Y
LDY IPY
BMI FIXDROP
JMP DROP
;*
;* STORE VALUE TO ABSOLUTE ADDRESS WITHOUT POPPING STACK
;*
!IF SELFMODIFY {
DAB INY ;+INC_IP
DAB INY ;+INC_IP
LDA (IP),Y
STA DABSTA+1
+INC_IP
STA ESTKH-2,X
INY ;+INC_IP
LDA (IP),Y
STA DABSTA+2
STA ESTKH-1,X
LDA ESTKL,X
DABSTA STA $FFFF
STA (ESTKH-2,X)
JMP NEXTOP
} ELSE {
DAB INY ;+INC_IP
DAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
LDY #$00
LDA ESTKL,X
STA (TMP),Y
LDY IPY
JMP NEXTOP
}
DAW INY ;+INC_IP
LDA (IP),Y
STA TMPL
+INC_IP
INY ;+INC_IP
LDA (IP),Y
STA TMPH
STY IPY
@ -913,8 +847,6 @@ ISEQ LDA ESTKL,X
ISTRU LDA #$FF
STA ESTKL+1,X
STA ESTKH+1,X
; INX
; JMP NEXTOP
JMP DROP
;
ISNE LDA ESTKL,X
@ -926,45 +858,58 @@ ISNE LDA ESTKL,X
ISFLS LDA #$00
STA ESTKL+1,X
STA ESTKH+1,X
; INX
; JMP NEXTOP
JMP DROP
;
ISGE LDA ESTKL+1,X
CMP ESTKL,X
LDA ESTKH+1,X
SBC ESTKH,X
BVC ISGE1
EOR #$80
ISGE1 BPL ISTRU
BVS +
BPL ISTRU
BMI ISFLS
+ BPL ISFLS
BMI ISTRU
;
ISGT LDA ESTKL,X
CMP ESTKL+1,X
LDA ESTKH,X
SBC ESTKH+1,X
BVC ISGT1
EOR #$80
ISGT1 BMI ISTRU
BVS +
BMI ISTRU
BPL ISFLS
+ BMI ISFLS
BPL ISTRU
;
ISLE LDA ESTKL,X
CMP ESTKL+1,X
LDA ESTKH,X
SBC ESTKH+1,X
BVC ISLE1
EOR #$80
ISLE1 BPL ISTRU
BVS +
BPL ISTRU
BMI ISFLS
+ BPL ISFLS
BMI ISTRU
;
ISLT LDA ESTKL+1,X
CMP ESTKL,X
LDA ESTKH+1,X
SBC ESTKH,X
BVC ISLT1
EOR #$80
ISLT1 BMI ISTRU
BVS +
BMI ISTRU
BPL ISFLS
+ BMI ISFLS
BPL ISTRU
;*
;* NORMALIZE IP+Y BEFORE CALLING NEXTOP
;*
FIXNEXT TYA
LDY #$00
CLC
ADC IPL
STA IPL
BCC +
INC IPH
+ JMP NEXTOP
;*
;* BRANCHES
;*
@ -972,8 +917,9 @@ BRTRU INX
LDA ESTKH-1,X
ORA ESTKL-1,X
BNE BRNCH
NOBRNCH INY ;+INC_IP
+INC_IP
NOBRNCH INY ;+INC_IP
INY ;+INC_IP
BMI FIXNEXT
JMP NEXTOP
BRFLS INX
LDA ESTKH-1,X
@ -987,6 +933,8 @@ BRNCH TYA ; FLATTEN IP
TAY
ADC IPH
STA TMPH ; ADD BRANCH OFFSET
LDA IPX ; COPY XBYTE FROM IP
STA TMPX
LDA (TMP),Y
;CLC ; BETTER NOT CARRY OUT OF IP+Y
ADC TMPL
@ -996,6 +944,7 @@ BRNCH TYA ; FLATTEN IP
ADC TMPH
STA IPH
DEY
STY TMPX ; CLEAR TMPX
JMP FETCHOP
BREQ INX
LDA ESTKL-1,X
@ -1018,20 +967,34 @@ BRGT INX
CMP ESTKL,X
LDA ESTKH-1,X
SBC ESTKH,X
BVS +
BPL NOBRNCH
BMI BRNCH
+ BPL BRNCH
BMI NOBRNCH
BRLT INX
LDA ESTKL,X
CMP ESTKL-1,X
LDA ESTKH,X
SBC ESTKH-1,X
BVS +
BPL NOBRNCH
BMI BRNCH
IBRNCH LDA IPL
+ BPL BRNCH
BMI NOBRNCH
IBRNCH TYA ; FLATTEN IP
CLC
ADC IPL
STA TMPL
LDA #$00
TAY
ADC IPH
STA TMPH ; ADD BRANCH OFFSET
LDA TMPL
;CLC ; BETTER NOT CARRY OUT OF IP+Y
ADC ESTKL,X
STA IPL
LDA IPH
LDA TMPH
ADC ESTKH,X
STA IPH
JMP DROP
@ -1107,7 +1070,7 @@ ENTER LDA IFPH
;*
;* LEAVE FUNCTION
;*
LEAVE INY ;+INC_IP
LEAVE INY ;+INC_IP
LDA (IP),Y
CLC
ADC IFPL
@ -1122,4 +1085,5 @@ LEAVE INY ;+INC_IP
RET RTS
SOSCMD = *
!SOURCE "vmsrc/soscmd.a"
}
SEGEND = *

16
src/vmsrc/plvm802.s

@ -685,26 +685,26 @@ XOR PLA
;*
SHL PLA
TAX
BEQ SHLEX
BEQ +
LDA TOS,S
- ASL
DEX
BNE -
STA TOS,S
SHLEX JMP NEXTOP
+ JMP NEXTOP
;*
;* SHIFT TOS-1 RIGHT BY TOS
;*
SHR PLA
TAX
BEQ SHREX
BEQ +
LDA TOS,S
- CMP #$8000
ROR
DEX
BNE -
STA TOS,S
SHREX JMP NEXTOP
+ JMP NEXTOP
;*
;* LOGICAL AND
;*
@ -770,9 +770,9 @@ CW INY ;+INC_IP
;*
;* CONSTANT STRING
;*
CS INY ;+INC_IP
CS ;INY ;+INC_IP
TYA ; NORMALIZE IP AND SAVE STRING ADDR ON ESTK
CLC
SEC
ADC IP
STA IP
PHA
@ -780,9 +780,9 @@ CS INY ;+INC_IP
TAY
JMP NEXTOP
;
CSX INY ;+INC_IP
CSX ;INY ;+INC_IP
TYA ; NORMALIZE IP
CLC
SEC
ADC IP
STA IP
LDA PP ; SCAN POOL FOR STRING ALREADY THERE

568
src/vmsrc/soscmd.pla

@ -17,26 +17,21 @@ const resxhgr2 = $0080
const modkeep = $2000
const modinitkeep = $4000
//
// SOS flags
//
const O_READ = 1
const O_WRITE = 2
const O_READ_WRITE = 3
//
// Pedefined functions.
//
predef syscall(cmd,params)#1, call(addr,areg,xreg,yreg,status)#1
predef crout()#0, cout(c)#0, prstr(s)#0, print(i)#0, cin()#1, rdstr(p)#1, toupper(c)#1
predef crout()#0, cout(c)#0, prstr(s)#0, print(i)#0, prbyte(b)#0, prword(w)#0
predef cin()#1, rdstr(p)#1, toupper(c)#1, strcpy(dst,src)#1, strcat(dst,src)#1
predef markheap()#1, allocheap(size)#1, allocalignheap(size, pow2, freeaddr), releaseheap(newheap)#1, availheap()#1
predef memset(addr,value,size)#0, memcpy(dst,src,size)#0
predef uword_isgt(a,b)#1, uword_isge(a,b)#1, uword_islt(a,b)#1, uword_isle(a,b)#1, sext(a)#1, divmod(a,b)#2
predef execmod(modfile)#1
//
// System variables.
// Exported CMDSYS table
//
word version = $0100 // 01.00
word version = $0102 // 01.02
word syspath
word cmdptr
word cmdlnptr
word = @execmod
byte refcons = 0
byte devcons = 0
@ -44,7 +39,6 @@ byte devcons = 0
// String pool.
//
byte console[] = ".CONSOLE"
byte autorun[] = "AUTORUN"
byte textmode[] = 16, 0, 15
byte hexchar[] = '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
//
@ -52,6 +46,11 @@ byte hexchar[] = '0','1','2','3','4','5','6','7','8','9','A','B','C','D','E',
//
byte machid = $F2 // Apple ///, 80 columns
//
// Working input buffer overlayed with strings table
//
word cmdptr
byte cmdln = ""
//
// Standard Library exported functions.
//
byte sysmodstr[] = "CMDSYS"
@ -62,27 +61,29 @@ byte putcstr[] = "PUTC"
byte putlnstr[] = "PUTLN"
byte putsstr[] = "PUTS"
byte putistr[] = "PUTI"
byte putbstr[] = "PUTB"
byte putwstr[] = "PUTH"
byte getcstr[] = "GETC"
byte getsstr[] = "GETS"
byte toupstr[] = "TOUPPER"
byte strcpystr[] = "STRCPY"
byte strcatstr[] = "STRCAT"
byte hpmarkstr[] = "HEAPMARK"
byte hpalignstr[] = "HEAPALLOCALIGN"
byte hpallocstr[] = "HEAPALLOC"
byte hprelstr[] = "HEAPRELEASE"
byte hpavlstr[] = "HEAPAVAIL"
byte sysmods[] = "" // overlay with exported strings
byte memsetstr[] = "MEMSET"
byte memcpystr[] = "MEMCPY"
byte uisgtstr[] = "ISUGT"
byte uisgestr[] = "ISUGE"
byte uisltstr[] = "ISULT"
byte uislestr[] = "ISULE"
byte sysmods[] // overlay with exported strings
byte sextstr[] = "SEXT"
byte divmodstr[] = "DIVMOD"
byte loadstr[] = "MODLOAD"
byte execstr[] = "MODEXEC"
byte modadrstr[] = "RELADDR"
byte prefix[] // Overlay with exported symbols table
byte autorun[] = "AUTORUN"
byte prefix[] = "" // Overlay with exported symbols table
word exports[] = @sysmodstr, @version
word = @sysstr, @syscall
word = @callstr, @call
@ -90,6 +91,8 @@ word = @putcstr, @cout
word = @putlnstr, @crout
word = @putsstr, @prstr
word = @putistr, @print
word = @putbstr, @prbyte
word = @putwstr, @prword
word = @getcstr, @cin
word = @getsstr, @rdstr
word = @toupstr, @toupper
@ -100,6 +103,8 @@ word = @hprelstr, @releaseheap
word = @hpavlstr, @availheap
word = @memsetstr, @memset
word = @memcpystr, @memcpy
word = @strcpystr, @strcpy
word = @strcatstr, @strcat
word = @uisgtstr, @uword_isgt
word = @uisgestr, @uword_isge
word = @uisltstr, @uword_islt
@ -119,6 +124,16 @@ byte modseg[15]
word symtbl, lastsym
byte perr, terr, lerr
//
// Utility functions
//
asm saveX#0
STX XREG+1
end
asm restoreX#0
XREG LDX #$00
RTS
end
//
// CALL SOS
// SYSCALL(CMD, PARAMS)
//
@ -308,9 +323,9 @@ asm memxcpy(dst,src,size)#0
ADC #$60
STA DSTH
LDA ESTKL+2,X
ORA #$80
CLC
ADC #$7F
STA DSTX
DEC DSTX
LDA ESTKL+1,X
STA SRCL
LDA ESTKH+1,X
@ -346,9 +361,9 @@ asm xpokeb(seg, dst, byteval)#0
ADC #$60
STA DSTH
LDA ESTKL+2,X
ORA #$80
CLC
ADC #$7F
STA DSTX
DEC DSTX
LDY #$00
LDA ESTKL,X
STA (DST),Y
@ -529,43 +544,6 @@ TOUPR AND #$7F
RTS
end
//
// Module symbols are entered into the symbol table
// pre-pended with a '#' to differentiate them
// from normal symbols.
//
//def modtosym(mod, dci)
// byte len, c
// (dci).0 = '#'|$80
// len = 0
// repeat
// c = (mod).[len]
// len = len + 1
// (dci).[len] = c
// until !(c & $80)
// return dci
//end
//asm modtosym(mod, dci)#1
// LDA ESTKL+1,X
// STA SRCL
// LDA ESTKH+1,X
// STA SRCH
// LDA ESTKL,X
// STA ESTKL+1,X
// STA DSTL
// LDA ESTKH,X
// STA ESTKH+1,X
// STA DSTH
// INX
// LDY #$00
// LDA #'#'+$80
//- STA (DST),Y
// ASL
// LDA (SRC),Y
// INY
// BCS -
// RTS
//end
//
// Lookup routines.
//
//def lookuptbl(dci, tbl)
@ -593,9 +571,9 @@ asm lookuptbl(dci, tbl)#1
ADC #$60
STA DSTH
LDA ESTKL,X
ORA #$80
CLC
ADC #$7F
STA DSTX
DEC DSTX
LDA ESTKL+1,X
STA SRCL
LDA ESTKH+1,X
@ -634,6 +612,176 @@ asm lookuptbl(dci, tbl)#1
+ INC DSTH
BNE ---
end
// def lookupidx(esd, index)
// word sym
// while ^esd
// sym = esd
// esd = sym + dcitos(sym, @str)
// if esd->0 & $10 and esd->1 == index
// return sym
// fin
// esd = esd + 3
// loop
//end
asm lookupidx(esd, index)#1
LDA ESTKL,X
STA TMPL
INX
--- LDA ESTKH,X
STA SRCH
LDA ESTKL,X
-- STA SRCL
LDY #$00
- LDA (SRC),Y
BPL +
INY
BNE -
+ BEQ ++ ; END OF ESD
INY
LDA (SRC),Y
INY
AND #$10 ; EXTERN FLAG?
BEQ +
LDA (SRC),Y
CMP TMPL
BEQ +++ ; MATCH
+ INY
TYA
SEC
ADC SRCL
STA ESTKL,X ; SYM PTRL
BCC --
INC ESTKH,X ; SYM PTRH
BNE ---
++ STA ESTKL,X ; END OF ESD
STA ESTKH,X
+++ RTS
end
//def lookupdef(addr, deftbl)#1
// while deftbl->0 == $20
// if deftbl=>3 == addr
// return deftbl
// fin
// deftbl = deftbl + 6
// loop
// return 0
//end
asm lookupdef(addr, deftbl)#1
LDA ESTKH,X
STA SRCH
LDA ESTKL,X
STA SRCL
INX
- LDY #$00
LDA (SRC),Y
CMP #$20 ; JSR OPCODE?
BNE ++
LDY #$03
LDA (SRC),Y
CMP ESTKL,X
BNE +
INY
LDA (SRC),Y
CMP ESTKH,X
BNE +
LDA SRCL ; MATCH
STA ESTKL,X
LDA SRCH
STA ESTKH,X
RTS
+ LDA #$06
CLC
ADC SRCL
STA SRCL
BCC -
INC SRCH
BNE -
++ STY ESTKL,X
STY ESTKH,X
RTS
end
//
// Reloc internal data
//
//def reloc(modfix, modofst, bytecode, rld)#3
// word addr, fixup
// while ^rld
// if ^rld & $10 // EXTERN reference.
// return rld, addr, fixup
// fin
// addr = rld=>1 + modfix
// fixup = *addr + modofst
// if uword_isge(fixup, bytecode) // Bytecode address.
// return rld, addr, fixup
// fin
// *addr = fixup
// rld = rld + 4
// loop
// return rld, addr, fixup
//end
asm reloc(modfix, modofst, bytecode, rld)#3
LDA ESTKL,X
STA SRCL
LDA ESTKH,X
STA SRCH
LDY #$00
- LDA (SRC),Y
BEQ RLDEX ; END OF RLD
PHA
INY
LDA (SRC),Y
INY
CLC
ADC ESTKL+3,X ; ADDR=ENTRY=>1+MODFIX
STA DSTL
LDA (SRC),Y
ADC ESTKH+3,X
STA DSTH
PLA
AND #$10 ; EXTERN REF - EXIT
BNE RLDEX
TAY ; FIXUP=*ADDR+MODOFST
LDA (DST),Y
INY
CLC
ADC ESTKL+2,X
STA TMPL
LDA (DST),Y
ADC ESTKH+2,X
CMP ESTKH+1,X ; FIXUP >= BYTECODE?
BCC +
STA TMPH
BNE RLDEX ; YEP, EXIT
LDA TMPL
CMP ESTKL+1,X
BCS RLDEX ; YEP, EXIT
LDA TMPH
+ STA (DST),Y ; *ADDR=FIXUP
DEY
LDA TMPL
STA (DST),Y
LDA SRCL ; NEXT ENTRY
; CLC
ADC #$04
STA SRCL
BCC -
INC SRCH
BNE -
RLDEX INX
LDA TMPL
STA ESTKL,X
LDA TMPH
STA ESTKH,X
LDA DSTL
STA ESTKL+1,X
LDA DSTH
STA ESTKH+1,X
LDA SRCL
STA ESTKL+2,X
LDA SRCH
STA ESTKH+2,X
RTS
end
//
// SOS routines
// FILE I/O
@ -649,14 +797,24 @@ def getpfx(path)#1
return path
end
def setpfx(path)#1
byte params[3]
byte params[6]
byte fileinfo[2]
params.0 = 1
params.0 = 3
params:1 = path
perr = syscall($C6, @params)
params:3 = @fileinfo
params.5 = 2
perr = syscall($C4, @params) // Get file info
if not perr and (fileinfo.1 == $00 or fileinfo.1 == $0F) // Make sure it's a directory
params.0 = 1
params:1 = path
perr = syscall($C6, @params)
else
perr = $44
fin
return path
end
def volume(devname, volname, ttlblks, freblks)#1
def volume(devname, volname)#1
byte params[9]
params.0 = 4
@ -665,8 +823,6 @@ def volume(devname, volname, ttlblks, freblks)#1
params:5 = 0
params:7 = 0
perr = syscall($C5, @params)
*ttlblks = params:5
*freblks = params:7
return perr
end
def open(path)#1
@ -745,18 +901,7 @@ end
//
// MEMORY CALLS
//
def seg_request(base, limit, id)#1
byte params[7]
params.0 = 4
params:1 = base
params:3 = limit
params.5 = id
params.6 = 0
perr = syscall($40, @params)
return params.6
end
def seg_find(search, base, limit, pages, id)#1
def seg_find(search, pages, id)#3
byte params[10]
params.0 = 6
@ -767,9 +912,7 @@ def seg_find(search, base, limit, pages, id)#1
params:7 = 0
params.9 = 0
perr = syscall($41, @params)
*base = params:5
*limit = params:7
return params.9
return params.9, params:5, params:7
end
def seg_release(segnum)#1
byte params[2]
@ -779,17 +922,6 @@ def seg_release(segnum)#1
perr = syscall($45, @params)
return perr
end
//
// Other SOS calls.
//
def quit()#0
byte params[1]
close(0)
params.0 = 0
perr = syscall($65, @params)
end
//
// CONSOLE I/O
//
@ -800,8 +932,9 @@ def init_cons()#0
fin
write(refcons, @textmode, 3)
devcons = dev_getnum(@console)
nlmode.0 = $80
nlmode.1 = $0D
nlmode:0 = $0D80
//nlmode.0 = $80
//nlmode.1 = $0D
dev_control(devcons, $02, @nlmode)
end
def cout(ch)#0
@ -812,6 +945,9 @@ def cout(ch)#0
write(refcons, @ch, 1)
fin
end
def crout()#0
cout($0D)
end
def cin()#1
byte ch
read(refcons, @ch, 1)
@ -832,14 +968,11 @@ def rdstr(prompt)#1
cout(prompt)
^heap = read(refcons, heap + 1, 128)
if heap->[^heap] == $0D
^heap = ^heap - 1
^heap--
fin
cout($0D)
crout
return heap
end
def crout()#0
cout($0D)
end
def prbyte(v)#0
cout(hexchar[(v >> 4) & $0F])
cout(hexchar[v & $0F])
@ -915,32 +1048,19 @@ end
//
// Module routines.
//
//def lookupmod(mod)#1
// byte dci[17]
// return lookuptbl(modtosym(mod, @dci), symtbl)
//end
//def addmod(mod, addr)#0
// byte dci[17]
// addsym(modtosym(mod, @dci), addr)
//end
def lookupextern(esd, index)#1
word sym, addr
byte str[16]
while ^esd
sym = esd
esd = sym + dcitos(sym, @str)
if esd->0 & $10 and esd->1 == index
addr = lookuptbl(sym, symtbl)
if !addr
lerr = $81
cout('?')
prstr(@str)
crout
fin
return addr
sym = lookupidx(esd, index)
if sym
addr = lookuptbl(sym, symtbl)
if !addr
perr = $81
dcitos(sym, @str)
cout('?'); prstr(@str); crout
fin
esd = esd + 3
loop
return addr
fin
return 0
end
def adddef(ext, addr, deflast)#1
@ -953,15 +1073,6 @@ def adddef(ext, addr, deflast)#1
defentry=>5 = ext // ext is byte, so this nulls out next entry
return defentry
end
def lookupdef(addr, deftbl)#1
while deftbl->0 == $20
if deftbl=>3 == addr
return deftbl
fin
deftbl = deftbl + 6
loop
return 0
end
def loadmod(mod)#1
word refnum, rdlen, modsize, bytecode, codefix, defofst, defcnt, init, fixup
word addr, defaddr, modaddr, modfix, modofst, modend
@ -986,16 +1097,17 @@ def loadmod(mod)#1
modsize = header:0
moddep = @header.1
defofst = modsize + RELADDR
defext = 0
init = 0
if rdlen > 4 and header:2 == $DA7F // DAVE+1 = magic number :-)
if rdlen > 4 and header:2 == $6502 // magic number
//
// This is an EXTended RELocatable (data+bytecode) module.
//
systemflags = header:4 | systemflags
defofst = header:6
defcnt = header:8
init = header:10
moddep = @header.12
defofst = header:6
defcnt = header:8
init = header:10
moddep = @header.12
//
// Load module dependencies.
//
@ -1028,7 +1140,7 @@ def loadmod(mod)#1
//
// Alloc heap space for relocated module (data + bytecode).
//
moddep = moddep + 1
moddep++
modfix = moddep - @header.2 // Adjust to skip header
modsize = modsize - modfix
rdlen = rdlen - modfix - 2
@ -1059,19 +1171,21 @@ def loadmod(mod)#1
while ^esd // Scan to end of ESD
esd = esd + 4
loop
esd = esd + 1
//
// Locate bytecode defs in allocated segment.
//
modseg[modid] = seg_find($00, @codeseg, @defaddr, (rld - bytecode + 255) >> 8, modid + $12)
if perr
return -perr
esd++
if defcnt
//
// Locate bytecode defs in allocated segment.
//
modseg[modid], codeseg, drop = seg_find($00, (rld - bytecode + 255) >> 8, modid + $12)
if perr
return -perr
fin
modid++
defext = codeseg.0 + $7F // (codeseg.0 | $80) - 1
defaddr = (codeseg & $FF00) + $6000
codefix = defaddr - bytecode
defofst = defaddr - defofst
fin
modid = modid + 1
defext = (codeseg.0 | $80) - 1
defaddr = (codeseg & $FF00) + $6000
codefix = defaddr - bytecode
defofst = defaddr - defofst
//
// Run through the DeFinition Dictionary.
//
@ -1086,31 +1200,36 @@ def loadmod(mod)#1
// Run through the Re-Location Dictionary.
//
while ^rld
addr = rld=>1 + modfix
if uword_isge(addr, modaddr) // Skip fixups to header
//if ^rld & $80 // WORD sized fixup.
fixup = *addr
//else // BYTE sized fixup.
// fixup = ^addr
//fin
if ^rld & $10 // EXTERN reference.
fixup = fixup + lookupextern(esd, rld->3)
else // INTERN fixup.
fixup = fixup + modofst
if uword_isge(fixup, bytecode)
//
// Bytecode address - replace with call def directory.
//
fixup = lookupdef(fixup + codefix, deftbl)
fin
fin
//if ^rld & $80 // WORD sized fixup.
*addr = fixup
//else // BYTE sized fixup.
// ^addr = fixup
//fin
rld, addr, fixup = reloc(modfix, modofst, bytecode, rld)
if ^rld
*addr = ^rld & $10 ?? *addr + lookupextern(esd, rld->3) :: lookupdef(fixup + codefix, deftbl)
rld = rld + 4
fin
rld = rld + 4
//addr = rld=>1 + modfix
//if uword_isge(addr, modaddr) // Skip fixups to header
// if type & $80 // WORD sized fixup.
// fixup = *addr
// else // BYTE sized fixup.
// fixup = ^addr
// fin
// if ^rld & $10 // EXTERN reference.
// fixup = fixup + lookupextern(esd, rld->3)
// else // INTERN fixup.
// fixup = fixup + modofst
// if uword_isge(fixup, bytecode)
// //
// // Bytecode address - replace with call def directory.
// //
// fixup = lookupdef(fixup + codefix, deftbl)
// fin
// fin
// if type & $80 // WORD sized fixup.
// *addr = fixup
// else // BYTE sized fixup.
// ^addr = fixup
// fin
//fin
//rld = rld + 4
loop
//
// Run through the External/Entry Symbol Directory.
@ -1139,17 +1258,15 @@ def loadmod(mod)#1
//
memxcpy(codeseg, bytecode, modsize - (bytecode - modaddr))
fin
//
// Free up end-of-module main memory.
//
releaseheap(bytecode)
else
return -perr
fin
if lerr
return -lerr
fin
//
// Free up end-of-module main memory.
//
releaseheap(bytecode)
//
// Call init routine if it exists.
//
fixup = 0
@ -1169,13 +1286,12 @@ def volumes()#0
byte devname[17]
byte volname[17]
byte i
word ttlblks, freblks
for i = $01 to $18
if dev_info(i, @devname, @info, 11) == 0
prstr(@devname)
if volume(@devname, @volname, @ttlblks, @freblks) == 0
prstr(" => ")
if volume(@devname, @volname) == 0
prstr(" => /")
prstr(@volname)
cout('/')
fin
@ -1184,24 +1300,19 @@ def volumes()#0
next
perr = 0
end
def catalog(optpath)#1
byte path[64]
def catalog(path)#0
byte refnum
byte firstblk
byte entrylen, entriesblk
byte i, type, len
word entry, filecnt
if ^optpath
memcpy(@path, optpath, ^optpath + 1)
else
getpfx(@path)
prstr(@path)
crout()
if !^path
path = @prefix
fin
refnum = open(@path)
refnum = open(path)
if perr
return perr
return
fin
firstblk = 1
repeat
@ -1215,24 +1326,26 @@ def catalog(optpath)#1
fin
for i = firstblk to entriesblk
type = ^entry
if type <> 0
if type
len = type & $0F
^entry = len
prstr(entry)
if type & $F0 == $D0 // Is it a directory?
cout('/')
len = len + 1
elsif entry->$10 == $FF
cout('-')
len = len + 1
elsif entry->$10 == $FE
cout('+')
len = len + 1
fin
for len = 19 - len downto 0
type = ' '
when entry->$10
is $0F // Is it a directory?
type = '/'
break
is $FF // SYSTEM file
type = '-'
break
is $FE // REL file
type = '+'
wend
cout(type)
for len = 18 - len downto 0
cout(' ')
next
filecnt = filecnt - 1
filecnt--
fin
entry = entry + entrylen
next
@ -1243,29 +1356,28 @@ def catalog(optpath)#1
until filecnt == 0
close(refnum)
crout()
return 0
end
def stripchars(strptr)#1
while ^strptr and ^(strptr + 1) <> ' '
while ^strptr and ^(strptr + 1) > ' '
memcpy(strptr + 1, strptr + 2, ^strptr)
^strptr = ^strptr - 1
^strptr--
loop
return ^strptr
end
def stripspaces(strptr)#0
while ^strptr and ^(strptr + ^strptr) <= ' '
^strptr = ^strptr - 1
^strptr--
loop
while ^strptr and ^(strptr + 1) <= ' '
memcpy(strptr + 1, strptr + 2, ^strptr)
^strptr = ^strptr - 1
^strptr--
loop
end
def striptrail(strptr)#1
byte i
for i = 1 to ^strptr
if (strptr)[i] <= ' '
if ^(strptr + i) <= ' '
^strptr = i - 1
break
fin
@ -1280,7 +1392,7 @@ def parsecmd(strptr)#1
if ^strptr
cmd = ^(strptr + 1)
memcpy(strptr + 1, strptr + 2, ^strptr)
^strptr = ^strptr - 1
^strptr--
fin
stripspaces(strptr)
return cmd
@ -1298,7 +1410,7 @@ def execmod(modfile)#1
lastsym = savesym
heap = saveheap
while modid
modid = modid - 1
modid--
seg_release(modseg[modid])
loop
else
@ -1320,7 +1432,7 @@ prstr("PLASMA "); prbyte(version.1); cout('.'); prbyte(version.0); crout
//
// Init 2K symbol table.
//
seg_find($00, @symtbl, @lastsym, $08, $11)
drop, symtbl, drop = seg_find($00, $08, $11)
lastsym = symtbl & $FF00
xpokeb(symtbl.0, lastsym, 0)
while *sysmodsym
@ -1336,9 +1448,10 @@ syspath = @sysmods
//
// Try to load autorun.
//
cmdptr = heap
^cmdptr = 0
autorun = open(@autorun)
cmdlnptr = @cmdln
cmdptr = heap
^cmdptr = 0
autorun = open(@autorun)
if autorun > 0
^cmdptr = read(autorun, cmdptr + 1, 64)
close(autorun)
@ -1357,13 +1470,24 @@ perr = 0
while 1
if ^cmdptr
when toupper(parsecmd(cmdptr))
is 'Q'
quit
is 'C'
catalog(cmdptr)
break
is 'P'
setpfx(cmdptr)
if ^cmdptr and ^(cmdptr + 1) <> '/'
strcat(@prefix, cmdptr)
else
strcpy(@prefix, cmdptr)
fin
setpfx(@prefix)
break
is '/'
repeat
prefix--
until prefix[prefix] == '/'
if prefix > 1
setpfx(@prefix)
fin
break
is 'S'
setpfx(cmdptr)
@ -1373,8 +1497,11 @@ while 1
volumes
break
is '+'
saveX
execmod(striptrail(cmdptr))
write(refcons, @textmode, 3)
restoreX
//close(0)
init_cons
break
otherwise
prstr("?\n")
@ -1385,11 +1512,12 @@ while 1
prbyte(terr)
perr = 0
else
prstr("OK\n")
prstr("OK")
fin
crout()
fin
prstr(getpfx(@prefix))
cmdptr = rdstr($BA)
strcpy(@cmdln, cmdptr)
loop
done