Initial commit

This commit is contained in:
slederer 2024-09-10 23:57:08 +02:00
commit 65ee0cd1f4
80 changed files with 27856 additions and 0 deletions

20
.gitignore vendored Normal file
View file

@ -0,0 +1,20 @@
*.s
*.o
*.exe
*.bin
*.sym
*.swp
*.prog
*.out
*.dis
*.sasmout
*.lib
*.img
*.lsym
*.zip
sine.pas
graph.pas
graph2.pas
chase.pas
*.img
!runtime.s

17
LICENSE.md Normal file
View file

@ -0,0 +1,17 @@
# Copyright and Licensing
All files, except where explicitly stated otherwise, are licensed according to the BSD-3-Clause license as follows:
------------------------------------------------------------------------------
Copyright 2024 Sebastian Lederer
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

58
README.md Normal file
View file

@ -0,0 +1,58 @@
# Tridora
- the Tridora CPU and the Tridora System
- creating everything from the ground up (except soldering stuff)
- make it useful, but as simple as possible
## Overview
- Homebrew CPU
- Verilog/FPGA SoC
- 32-bit word-oriented stack machine architecture
- has its own instruction set architecture, compatible with nothing
- additional IO controllers on FPGA: UART (serial console), SD-Card, VGA
- Pascal compiler written from zero
- CPU and compiler were designed together
- minimal operating system
- editor, compiler, assembler run natively
- so you can develop programs directly on the machine
- small: CPU has 760 lines of verilog, compiler ~9000 LoC
- Compiler written in Pascal and can compile itself
- Cross-compiler/-assembler can be compiled with FPC
- Compiler does its own Pascal dialect with some restrictions and some extensions
- Emulator available
## Demo
- (Video hello world)
- (Video lines)
- (Screenshot mandelbrot)
- (Screenshot conway)
- (Screenshot image viewer)
## Supported Boards
- Arty A7
- Nexys A7?
## Pascal Language
- Wirth Pascal
- no function types/parameters
- arbitrary length strings (2GB)
- safe strings (runtime information about max/current size)
- tiny sets (machine word sized), that means no SET OF CHAR
- array literals with IN-operator, which can replace most uses of SET OF CHAR
- nested procedures with some limitations
- 32 bit software floating point with low precision (5-6 digits)
- break and exit statements, no continue yet
- static variable initialization for global variables
- non-standard file i/o (because the standard sucks, obl. XKCD reference)
## Standard Library
- everything from Wirth Pascal
- some things from TP3.0
- some graphics functionality (to be expanded in the future)
## Operating System
- not a real operating system, more of a program loader
- some assembly routines for I/O resident in memory
- one program image loaded at a time at a fixed address
- most parts of the operating system are contained in the program image
- file system is very primitive: only contiguous blocks, no subdirectories
- Simple shell reminiscent of TP3.0, edit, compile, run programs

48
doc/irqctrl.md Normal file
View file

@ -0,0 +1,48 @@
# Interrupt Controller
The interrupt controller uses a single register at address: $980
## Reading the status register
|_bit_ |31|30|29|28|27|26|25|24|23|22|21|20|19|18|17|16|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|t |t |t |t |t |t |t |t |t |t|t |t |t |t |t |t |
|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|t |t |t |t |t |t |t |t |- |- |- |- |- |- |p1 |p0 |
|Bitfields|Description|
|---------|-----------|
| _t_ | unsigned 24 bit counter of timer ticks since reset
| _p1_ | IRQ 1 (timer tick) interrupt pending if 1
| _p0_ | IRQ 0 (UART) interrupt pending if 1
## Writing the status register
|_bit_ |31|30|29|28|27|26|25|24|23|22|21|20|19|18|17|16|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |- |- |- |- |- |- |- |i |- |- |- |- |- |- |- |
|Bitfields|Description|
|---------|-----------|
| _i_ | 1 = interrupts enabled, 0 = interrupts disabled
## Notes
Interrupt processing is disabled on reset and needs to be enabled by writing a value with
bit 7 set to the status register (i.e. 127).
An interrupt is only signaled once to the CPU whenever one of the IRQ signals becomes active.
Reading the status register will reflect all pending interrupts since enabling interrupt processing.
Interrupt processing needs to be re-enabled after an interrupt occurs by setting bit 7 in the status register again. This will also clear all pending interrupts.

37
doc/mem.md Normal file
View file

@ -0,0 +1,37 @@
# Memory Layout
The Tridora system uses the following memory layout:
|Address (hex) |Address (decimal)|Description|
|-------|-----------|------------------------|
|$00000000| 0 | ROM |
|$00000800| 2048 | I/O area|
|$00001000| 4096 | RAM (SRAM)|
|$00010000| 65536 | RAM (DRAM)|
## Accessing Words and Bytes
Memory is word-oriented, so there is no access to individual bytes. Memory transfers always use 32 bits.
Word addresses in RAM and ROM use an increment of 4, so the first memory word is at address 0, the second is at address 4 etc.
This way, you can express a pointer to a specific byte within a word.
The lower two bits of the address are ignored when accessing RAM or ROM. So if you use 1 as a memory address, you still get the memory word at address 0.
The lower two bits of the address can be viewed as a byte address (0-3) within the word.
The _BSEL_ and _BPLC_ instructions are designed to assist with accessing bytes within a word.
Because memory is always accessed in words, the CPU is neither big-endian nor little-endian. However, the _BSEL_ and _BPLC_
instructions are big-endian when accessing bytes within a word, so the system can be considered big-endian.
## Accessing the I/O Area
The I/O area organizes memory slightly different. Here, pointing out individual bytes is not very useful, so the I/O controllers use register addresses with increments of one. In practice, there is only the VGA framebuffer controller which uses multiple registers.
The individual I/O controllers each have a memory area of 128 bytes, so there is a maximum number of 16 I/O controllers.
Currently, only I/O slots 0-3 are being used.
|I/O slot| Address | Controller |
|--------|---------|------------|
| 0 | $800 | UART |
| 1 | $880 | VGA |
| 2 | $900 | SPI-SD |
| 3 | $980 | IRQC |

67
doc/spisd.md Normal file
View file

@ -0,0 +1,67 @@
# SPI SD-Card Controller
The SPI-SD-Card controller uses a single register at address $880.
## Reading the register
|_bit_ |31|30|29|28|27|26|25|24|23|22|21|20|19|18|17|16|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |- |- |- |- |- |- |- |- |-|- |- |- |- |- |- |
|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |cd |cc |cb |tr |te |ra |ro |d |d |d |d |d |d |d |d |
|Bitfields|Description|
|---------|-----------|
| _cd_ | card detect |
| _cc_ | card changed |
| _cb_ | card busy |
| _tr_ | transmitter ready |
| _te_ | transmitter fifo empty |
| _ra_ | received byte available |
| _ro_ | receiver overrun |
| _d_ | received byte data |
Reading the register does not advance to the next byte in the read fifo. This is done by using the DR bit on a register write (see below).
## Writing the register
|_bit_ |31|30|29|28|27|26|25|24|23|22|21|20|19|18|17|16|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |- |- |- |- |- |- |- |- |-|- |- |- |- |- |- |
|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |CW |CF |Cx |Cc |Cd |DR |DW |D |D |D |D |D |D |D |D |
|Bitfields|Description|
|---------|-----------|
| _CW_ | control write |
| _CF_ | enable receive filter |
| _Cx_ | enable transceiver |
| _Cc_ | force spi clock on |
| _Cd_ | write clock divider |
| _DR_ | read acknowledge |
| _DW_ | data write |
| _D_ | byte data |
* CF, Cx and Cc flags are used together with CW
* Cd together with d sets the clock divider
* DW together with d writes a data byte
* if the receive filter is set, all received bytes are ignored until a byte is received that is not $FF
* receiving a byte that is not $FF disables the receive filter
* Cc is used to enable the clock without sending/receiving anything - used for card initialization
Example transaction:
1. read register, loop until _te_ is set
1. write command bytes to register (_DW_ | data)
1. write _Cx_|_CF_ to register
1. read register, loop until _ra_ is set
1. process data byte
1. write _DR_ to register
1. repeat last three steps until complete response has been read
1. wait a bit/send a few more $FF bytes
1. disable transceiver, write _CW_ to register (Cx = 0)

1300
doc/tridoracpu.md Normal file

File diff suppressed because it is too large Load diff

83
doc/vga.md Normal file
View file

@ -0,0 +1,83 @@
# VGA Controller
Registers
|Name|Address|Description|
|----|-------|-----------|
|_FB_RA_ | $900 | Read Address |
|_FB_WA_ | $901 | Write Address |
| _FB_IO_ | $902 | I/O Register |
| _FB_PS_ | $903 | Palette Select |
| _FB_PD_ | $904 | Palette Data |
| _FB_CTL_ | $905 | Control Register |
## Pixel Data
Pixel data is organized in 32-bit-words. With four bits per pixel, one word
contains eight pixels.
|_bit_ |31|30|29|28|27|26|25|24|23|22|21|20|19|18|17|16|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|p0 | p0 | p0 | p0 | p1 | p1 | p1 | p1 | p2 | p2 | p2 | p2 | p3 | p3 | p3 | p3 |
|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|p4 | p4 | p4 | p4 | p5 | p5 | p5 | p5 | p6 | 62 | p6 | p6 | p7 | p7 | p7 | p7 |
|Bitfields|Description|
|---------|-----------|
| _p0_ | 4 bits color value (leftmost pixel) |
| _p1_ | 4 bits color value |
| _p2_ | 4 bits color value |
| _p3_ | 4 bits color value |
| _p4_ | 4 bits color value |
| _p5_ | 4 bits color value |
| _p6_ | 4 bits color value |
| _p7_ | 4 bits color value (rightmost pixel) |
Video memory uses a linear layout, with words using an address increment of one.
The first word (horizontal pixel coordinates 0-3) is at address 0, the second (coordinates 4-7) at address 1 etc.
The first line starts at address 0, the second at address 80 etc.
To access video memory, the corresponding video memory address must be written to a latch register, then pixel data can be read or written by the I/O register. Reading and writing uses separate latch registers (the "Read Adress" and "Write Address" registers. To read the same word and write it back, both addresses need to be set.
Both registers have an auto-increment function. After reading the I/O register, the FB_RA register is ingremented by one. After writing to the I/O register, the FB_WA register is incremented by one.
## Palette Data
The VGA controller uses a 16 color palette. The palette can be changed with the FB_PS and FB_PD registers. Writing to the FB_PS register selects a palette slot. Valid values are 0-15. After a palette slot is selected, color data can be read from and written to the FB_PD register. Color data is organized as follows:
|_bit_ |31|30|29|28|27|26|25|24|23|22|21|20|19|18|17|16|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |- |- |- |r |r |r |r |g |g |g |g |b |b |b |b |
| _Bitfields_| Description |
|------------|--------------|
| _r_ | 4 bits red intensity |
| _g_ | 4 bits green intensity |
| _b_ | 4 bits blue intensity |
The FB_PS and PB_FD registers cannot be read.
## Control Register
The control register contains status information. It can only be read.
|_bit_ |31|30|29|28|27|26|25|24|23|22|21|20|19|18|17|16|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|m |m |m |m |- |- |- |- |- |- |- |- |- |- |- |- |
|_bit_ |15|14|13|12|11|10|09|08|07|06|05|04|03|02|01|00|
|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |
|_Value_|- |- |- |- |- |- |- |- |- |- |- |- |- |- |- |vb |
| _Bitfields_| Description |
|------------|--------------|
| _m_ | 4 bits mode indicator |
| _vb_ | vertical blank |
The _m_ field indicates the current graphics mode. At the time of writing, it is
always 1 which denotes a 640x400x4 mode.
The _vb_ bit is 1 when the video signal generator is in its vertical blank phase.

81
examples/3dcube.pas Normal file
View file

@ -0,0 +1,81 @@
program cube;
const Cw = 640;
Ch = 400;
Vw = 4;
Vh = 3;
D = 3.5;
RED = 2;
GREEN = 3;
BLUE = 4;
type point2d = record x,y:real; end;
point3d = record x,y,z:real; end;
var vAf,vBf,vCf,vDf:point3d;
vAb,vBb,vCb,vDb:point3d;
function viewportToCanvas(x,y:real):point2d;
begin
viewportToCanvas.x := x * Cw/Vw;
viewportToCanvas.y := y * Ch/Vh;
end;
function projectVertex(v:point3d):point2d;
begin
projectVertex := viewportToCanvas(v.x * D / v.z, v.y * D / v.z);
end;
procedure initPoint3d(var p:point3d;x,y,z:real);
begin
p.x := x;
p.y := y;
p.z := z;
end;
procedure DrawLine2d(p1,p2:point2d; color:integer);
begin
drawline(Cw div 2 + trunc(p1.x),Ch div 2 + trunc(p1.y),
Cw div 2 + trunc(p2.x), Ch div 2 + trunc(p2.y),
color);
end;
begin
initGraphics;
(* The four "front" vertices *)
initPoint3d(vAf,-2.0, -0.5, 5.0);
initPoint3d(vBf,-2.0, 0.5, 5.0);
initPoint3d(vCf,-1.0, 0.5, 5.0);
initPoint3d(vDf,-1.0, -0.5, 5.0);
(* The four "back" vertices *)
(*
vAb = [-2, -0.5, 6]
vBb = [-2, 0.5, 6]
vCb = [-1, 0.5, 6]
vDb = [-1, -0.5, 6] *)
initPoint3d(vAb,-2.0, -0.5, 6.0);
initPoint3d(vBb,-2.0, 0.5, 6.0);
initPoint3d(vCb,-1.0, 0.5, 6.0);
initPoint3d(vDb,-1.0, -0.5, 6.0);
(* The front face *)
DrawLine2d(ProjectVertex(vAf), ProjectVertex(vBf), BLUE);
DrawLine2d(ProjectVertex(vBf), ProjectVertex(vCf), BLUE);
DrawLine2d(ProjectVertex(vCf), ProjectVertex(vDf), BLUE);
DrawLine2d(ProjectVertex(vDf), ProjectVertex(vAf), BLUE);
(* The back face *)
DrawLine2d(ProjectVertex(vAb), ProjectVertex(vBb), RED);
DrawLine2d(ProjectVertex(vBb), ProjectVertex(vCb), RED);
DrawLine2d(ProjectVertex(vCb), ProjectVertex(vDb), RED);
DrawLine2d(ProjectVertex(vDb), ProjectVertex(vAb), RED);
(* The front-to-back edges *)
DrawLine2d(ProjectVertex(vAf), ProjectVertex(vAb), GREEN);
DrawLine2d(ProjectVertex(vBf), ProjectVertex(vBb), GREEN);
DrawLine2d(ProjectVertex(vCf), ProjectVertex(vCb), GREEN);
DrawLine2d(ProjectVertex(vDf), ProjectVertex(vDb), GREEN);
end.

253
examples/5cubes.pas Normal file
View file

@ -0,0 +1,253 @@
program five_cubes_in_a_row;
const MAX_Y = 400;
pi = 3.1415926;
type pointtype = record x,y:integer end;
var cube:array[1..6] of record
position:array[1..5] of record x,y,z:real end;
end;
c:char;
pcos,ncos,psin,nsin:real;
procedure rotx(dir:integer);
var y1,z1:real;i,o:integer;
begin
if dir=1 then
for i:=1 to 6 do
for o:=1 to 5 do
begin
y1:=pcos*cube[i].position[o].y-psin*cube[i].position[o].z;
z1:=psin*cube[i].position[o].y+pcos*cube[i].position[o].z;
cube[i].position[o].y:=y1;
cube[i].position[o].z:=z1;
end
else
for i:=1 to 6 do
for o:=1 to 5 do
begin
y1:=ncos*cube[i].position[o].y-nsin*cube[i].position[o].z;
z1:=nsin*cube[i].position[o].y+ncos*cube[i].position[o].z;
cube[i].position[o].y:=y1;
cube[i].position[o].z:=z1
end
end;
procedure roty(dir:integer);
var x1,z1:real;i,o:integer;
begin
if dir=1 then
for i:=1 to 6 do
for o:=1 to 5 do
begin
x1:=pcos*cube[i].position[o].x-psin*cube[i].position[o].z;
z1:=psin*cube[i].position[o].x+pcos*cube[i].position[o].z;
cube[i].position[o].x:=x1;
cube[i].position[o].z:=z1;
end
else
for i:=1 to 6 do
for o:=1 to 5 do
begin
x1:=ncos*cube[i].position[o].x-nsin*cube[i].position[o].z;
z1:=nsin*cube[i].position[o].x+ncos*cube[i].position[o].z;
cube[i].position[o].x:=x1;
cube[i].position[o].z:=z1
end
end;
procedure rotz(dir:integer);
var y1,x1:real;i,o:integer;
begin
if dir=1 then
for i:=1 to 6 do
for o:=1 to 5 do
begin
y1:=pcos*cube[i].position[o].y-psin*cube[i].position[o].x;
x1:=psin*cube[i].position[o].y+pcos*cube[i].position[o].x;
cube[i].position[o].y:=y1;
cube[i].position[o].x:=x1;
end
else
for i:=1 to 6 do
for o:=1 to 5 do
begin
y1:=ncos*cube[i].position[o].y-nsin*cube[i].position[o].x;
x1:=nsin*cube[i].position[o].y+ncos*cube[i].position[o].x;
cube[i].position[o].y:=y1;
cube[i].position[o].x:=x1
end
end;
procedure display_cube(col:integer);
var i,o,a:integer;c:integer;
stran:array[1..4] of pointtype;
color:integer;
begin
for i:=1 to 6 do
if cube[i].position[5].z>0 then
with cube[i] do
begin
for a:=1 to 5 do
begin
if col>0 then c:=a else c:=0;
if((a=4)and(c>0))then color :=6 else color:= c;
for o:=1 to 4 do
begin
stran[o].x:=a*100+round(position[o].x);
stran[o].y:=MAX_Y div 2+round(position[o].y);
end;
drawline(stran[1].x,stran[1].y,stran[2].x,stran[2].y,color);
drawline(stran[2].x,stran[2].y,stran[3].x,stran[3].y,color);
drawline(stran[3].x,stran[3].y,stran[4].x,stran[4].y,color);
drawline(stran[4].x,stran[4].y,stran[1].x,stran[1].y,color);
end;
end;
end;
procedure init;
var i,gm,gd:integer;
entrance:array[1..11]of integer;
begin
entrance := [ 1,2,3,4,5,20,7,56,57,58,59 ];
InitGraphics;
ClearGraphics;
pcos:=cos(6*2*pi/360);
ncos:=cos(-6*2*pi/360);
psin:=sin(6*2*pi/360);
nsin:=sin(-6*2*pi/360);
setpalette(1,$700);
with cube[1] do
begin
position[1].x:=-25;
position[1].y:=-25;
position[1].z:=+25;
position[2].x:=+25;
position[2].y:=-25;
position[2].z:=+25;
position[3].x:=+25;
position[3].y:=+25;
position[3].z:=+25;
position[4].x:=-25;
position[4].y:=+25;
position[4].z:=+25;
position[5].x:=0;
position[5].y:=0;
position[5].z:=25;
end;
with cube[2] do
begin
position[1].x:=-25;
position[1].y:=-25;
position[1].z:=-25;
position[2].x:=+25;
position[2].y:=-25;
position[2].z:=-25;
position[3].x:=+25;
position[3].y:=-25;
position[3].z:=+25;
position[4].x:=-25;
position[4].y:=-25;
position[4].z:=+25;
position[5].x:=0;
position[5].z:=0;
position[5].y:=-25;
end;
with cube[3] do
begin
position[1].x:=-25;
position[1].y:=+25;
position[1].z:=+25;
position[2].x:=+25;
position[2].y:=+25;
position[2].z:=+25;
position[3].x:=+25;
position[3].y:=+25;
position[3].z:=-25;
position[4].x:=-25;
position[4].y:=+25;
position[4].z:=-25;
position[5].x:=0;
position[5].z:=0;
position[5].y:=25;
end;
with cube[4] do
begin
position[1].x:=-25;
position[1].y:=-25;
position[1].z:=-25;
position[2].x:=-25;
position[2].y:=-25;
position[2].z:=+25;
position[3].x:=-25;
position[3].y:=+25;
position[3].z:=+25;
position[4].x:=-25;
position[4].y:=+25;
position[4].z:=-25;
position[5].y:=0;
position[5].z:=0;
position[5].x:=-25;
end;
with cube[5] do
begin
position[1].x:=+25;
position[1].y:=-25;
position[1].z:=+25;
position[2].x:=+25;
position[2].y:=-25;
position[2].z:=-25;
position[3].x:=+25;
position[3].y:=+25;
position[3].z:=-25;
position[4].x:=+25;
position[4].y:=+25;
position[4].z:=+25;
position[5].x:=25;
position[5].y:=0;
position[5].z:=0;
end;
with cube[6] do
begin
position[1].x:=-25;
position[1].y:=+25;
position[1].z:=-25;
position[2].x:=+25;
position[2].y:=+25;
position[2].z:=-25;
position[3].x:=+25;
position[3].y:=-25;
position[3].z:=-25;
position[4].x:=-25;
position[4].y:=-25;
position[4].z:=-25;
position[5].x:=0;
position[5].y:=0;
position[5].z:=-25;
end;
end;
begin
init;
repeat
display_cube(1);
repeat
c:=conin;
until(upcase(c)in['E','Q','S','W','D','A','J','K','L','U','I','O'])or(c=#27);
display_cube(0);
case upcase(c) of
'E':rotz(0);
'Q':rotz(1);
'S':rotx(0);
'W':rotx(1);
'D':roty(0);
'A':roty(1);
'J':begin rotx(1);roty(1);rotz(1);end;
'L':begin rotx(0);roty(0);rotz(0);end;
'K':begin rotx(1);roty(0);rotz(1);end;
'I':begin rotx(0);roty(1);rotz(0);end;
'U':begin rotx(0);roty(1);rotz(1);end;
'O':begin rotx(1);roty(0);rotz(0);end;
end;
until c=#27;
end.

8
examples/LICENSES.md Normal file
View file

@ -0,0 +1,8 @@
# Attributions for included media files
* ara.pict: Tuxyso / Wikimedia Commons / CC-BY-SA-3.0
https://commons.wikimedia.org/wiki/File:Ara-Zoo-Muenster-2013.jpg
* snow_leopard.pict: Tambako The Jaguar, CC BY-SA 2.0 <https://creativecommons.org/licenses/by-sa/2.0>, via Wikimedia Commons
https://commons.wikimedia.org/wiki/File:Snow_leopard_portrait.jpg
* shinkansen.pict: 投稿者が撮影, CC BY-SA 3.0 <http://creativecommons.org/licenses/by-sa/3.0/>, via Wikimedia Commons
https://commons.wikimedia.org/wiki/File:0key22-86.JPG

BIN
examples/ara.pict Normal file

Binary file not shown.

116
examples/conway.pas Normal file
View file

@ -0,0 +1,116 @@
program conway;
const cellwidth = 4;
cellheight = 4;
cols = 40;
rows = 25;
WHITE = 1;
BLACK = 0;
type gridType = array [1..rows, 1..cols] of integer;
var grid:gridType;
ch:char;
procedure initGrid(var g:gridType);
var x,y:integer;
begin
randomize;
for y := 1 to rows do
for x := 1 to cols do
if (random and 1024) > 512 then
grid[y,x] := 1;
end;
procedure updateGrid;
var oldGrid:gridType;
neighbors:integer;
x,y:integer;
wasAlive:boolean;
isAlive:boolean;
gen:integer;
begin
oldGrid := grid;
for y := 1 to rows do
for x := 1 to cols do
begin
wasAlive := oldGrid[y,x] > 0;
isAlive := false;
neighbors := 0;
if y > 1 then
begin
if x > 1 then
if oldGrid[y-1,x-1] > 0 then neighbors := neighbors + 1;
if oldGrid[y-1,x] > 0 then neighbors := neighbors + 1;
if x < cols then
if oldGrid[y-1,x+1] > 0 then neighbors := neighbors + 1;
end;
if x > 1 then
if oldGrid[y,x-1] > 0 then neighbors := neighbors + 1;
if x < cols then
if oldGrid[y,x+1] > 0 then neighbors := neighbors + 1;
if y < rows then
begin
if x > 1 then
if oldGrid[y+1,x-1] > 0 then neighbors := neighbors + 1;
if oldGrid[y+1,x] > 0 then neighbors := neighbors + 1;
if x < cols then
if oldGrid[y+1,x+1] > 0 then neighbors := neighbors + 1;
end;
if wasAlive then
begin
if (neighbors = 2) or (neighbors = 3) then
isAlive := true;
end
else
if neighbors = 3 then
isAlive := true;
if isAlive then
begin
gen := grid[y,x];
if gen < 8 then gen := gen + 1;
grid[y,x] := gen;
end
else
grid[y,x] := 0;
end;
end;
procedure drawGrid;
var x,y:integer;
color:integer;
screenx,screeny:integer;
begin
for x := 1 to cols do
for y := 1 to rows do
begin
color := grid[y,x];
screenx := x * cellwidth;
screeny := y * cellheight;
putpixel(screenx,screeny,color);
putpixel(screenx+1,screeny,color);
putpixel(screenx,screeny+1,color);
putpixel(screenx+1,screeny+1,color);
end;
end;
begin
initGraphics;
initGrid(grid);
repeat
drawGrid;
updateGrid;
{ delay(100); }
until conavail;
read(ch);
end.

19
examples/graph1.pas Normal file
View file

@ -0,0 +1,19 @@
{ program 4.9
graphic representation of a function
f(x) = exp(-x) * sin(2*pi*x) }
program graph1;
const d = 0.0625; {1/16, 16 lines for interval [x,x+1]}
s = 32; {32 character widths for interval [y,y+1]}
h = 34; {character position of x-axis}
c = 6.28318; {2*pi} lim = 32;
var x,y : real; i,n : integer;
begin
for i := 0 to lim do
begin x := d*i; y := exp(-x)*sin(c*x);
n := round(s*y) + h;
repeat write(' '); n := n-1
until n=0;
writeln('*')
end
end.

15
examples/hellop.pas Normal file
View file

@ -0,0 +1,15 @@
(* a simple test program to say
hello to the world *)
program hello;
begin
(* if there is an argument, use it *)
if ParamCount > 0 then
writeln('Hello ', ParamStr(1))
else
writeln('Hello World!');
end.
{ Note that the last END needs to be followed by the . character,
not by a ; character. This is because ; means that there is
another statement. It does not mark the end of the statement
like in other languages. The . marks the end of the program text. }

70
examples/lines.pas Normal file
View file

@ -0,0 +1,70 @@
PROGRAM lines;
PROCEDURE movinglines(max_x, max_y, max_col, ms:INTEGER);
VAR x1,y1:INTEGER;
VAR x2,y2:INTEGER;
VAR delta_x1, delta_y1:INTEGER;
VAR delta_x2, delta_y2:INTEGER;
VAR col:INTEGER;
BEGIN
x1 := 120;
y1 := 90;
x2 := 340;
y2 := 220;
delta_x1 := 9;
delta_y1 := 4;
delta_x2 := 3;
delta_y2 := 7;
col := 1;
WHILE NOT CONAVAIL DO
BEGIN
x1 := x1 + delta_x1;
y1 := y1 + delta_y1;
x2 := x2 + delta_x2;
y2 := y2 + delta_y2;
IF (x1 > max_x) OR (x1 < 0) THEN
BEGIN
delta_x1 := -delta_x1;
x1 := x1 + delta_x1;
END;
IF (y1 > max_y) OR (y1 < 0) THEN
BEGIN
delta_y1 := -delta_y1;
y1 := y1 + delta_y1;
END;
IF (x2 > max_x) OR (x2 < 0) THEN
BEGIN
delta_x2 := -delta_x2;
x2 := x2 + delta_x2;
END;
IF (y2 > max_y) OR (y2 < 0) THEN
BEGIN
delta_y2 := -delta_y2;
y2 := y2 + delta_y2;
END;
col := col + 1;
IF col > max_col THEN col := 1;
DRAWLINE(x1,y1,x2,y2,col);
delay(ms);
END;
END;
BEGIN
initgraphics;
movinglines(639,399,15,0);
END.

63
examples/mandelbrot.pas Normal file
View file

@ -0,0 +1,63 @@
program mandelbrot;
const width = 459; height = 405;
xstart = -2.02; xend = 0.7;
ystart = -1.2; yend = 1.2;
maxIterations = 25;
maxColors = 15;
var dx,dy:real;
col,row:integer;
cx,cy:real;
iterations:integer;
colors:array[0..15] of integer = { ($000, $020, $031, $042,
$053, $064, $075, $086,
$097, $0A8, $0B9, $0CA,
$0DB, $0EC, $0FD, $0FF); }
($000, $100, $200, $411,
$522, $633, $744, $855,
$966, $A77, $B88, $C99,
$DAA, $EBB, $FCC, $FDD);
c:integer;
function iterate(x,y:real):integer;
var zx,zy:real;
tmp:real;
count:integer;
begin
zx := 0.0; zy := 0.0; count := 0;
repeat
tmp := zx*zx - zy*zy + x;
zy := 2.0*zx*zy + cy;
zx := tmp;
count := count + 1;
until (zx*zx + zy*zy > 4.0) or (count = MaxIterations);
iterate := count;
end;
begin
initgraphics;
for c:=0 to 15 do
setpalette(c, colors[c]);
dx := (xend - xstart) / (width - 1);
dy := (yend - ystart) / (height - 1);
for col := 0 to width - 1 do
begin
cx := xstart + col * dx;
for row := 0 to height - 1 do
begin
cy := yend - row * dy;
iterations := iterate(cx, cy);
if iterations = MaxIterations then
c := 0
else
c := iterations mod MaxColors + 1;
putpixel(col, row, c);
end;
end;
end.

110
examples/rtpair.pas Normal file
View file

@ -0,0 +1,110 @@
{ Raytracer for a scene with a pair of spheres and multiple reflections }
program RtPair;
const MaxX = 639;
MaxY = 399;
HalfX = 320;
HalfY = 200;
var
gd, gm: Integer;
N, M: Integer;
X, Y, Z: Real;
U, V, W: Real;
I, E, F, P, D, T, R, G: Real;
stopReflection: Boolean;
C: Integer;
function Sign(x: Real): Real;
begin
if x>0 then
Sign := 1
else
Sign := -1;
end;
begin
InitGraphics;
SetPalette(0, $000);
SetPalette(4, $A00);
SetPalette(11, $0FF);
SetPalette(15, $FFF);
for N:=0 to MaxY do
for M:=0 to MaxX do
begin
{ Rays' origin point }
X := 0;
Y := -0.1;
Z := 3;
U := (M - 318) / HalfX;
V := (HalfY - N) / 321.34;
W := 1 / Sqrt(U*U + V*V + 1);
U := U*W;
V := V*W;
{ I is the horizontal direction of ray }
{ based on whether it is in left (U<0) or right (U>0) half of the screen }
I := Sign(U);
G := 1;
{ Start the reflection cycle. }
{ A ray may reflect between one sphere and another multiple times before hitting floor or sky. }
repeat
stopReflection := True;
E := X-I;
F := Y-I;
P := U*E + V*F - W*Z;
D := P*P - E*E - F*F - Z*Z + 1;
{ If ray reflects from a sphere one more time }
if D>0 then
begin
T := -P - Sqrt(D);
if T>0 then
begin
X := X + T*U;
Y := Y + T*V;
Z := Z - T*W;
E := X - I;
F := Y - I;
G := Z;
P := 2*(U*E + V*F - W*G);
U := U - P*E;
V := V - P*F;
W := W + P*G;
{ Invert ray's direction and continue the reflection cycle }
I := -I;
stopReflection := False;
end;
end;
until stopReflection;
{ If Y<0 (V<0) a ray hits the floor }
if V<0 then
begin
P := (Y+2)/V;
{ Select checkers floor with Black (0) and Red (4) tiles }
C := (1 And (Round(X - U*P) + Round(Z + W*P))) * 4;
end else begin
{ If Y>0 (V>0) a ray hits the sky }
{ Default sky color is Cyan (11) }
C := 11;
{ Condition for using color White (15) to create fancy Cyan-White horizon }
R := ArcTan(U/W);
R := 0.2+0.1*Cos(3*R)*Abs(Sin(5*R));
if Abs(G)<0.35 then
R := R + 1;
if V<R then
C := 15;
end;
{ Draw current pixel }
PutPixel(M, N, C);
end;
repeat until ConAvail;
end.

BIN
examples/shinkansen.pict Normal file

Binary file not shown.

BIN
examples/snow_leopard.pict Normal file

Binary file not shown.

143
examples/test.txt Normal file
View file

@ -0,0 +1,143 @@
THE ELEMENTS OF STYLE
BY
WILLIAM STRUNK, Jr.
PROFESSOR OF ENGLISH
IN
CORNELL UNIVERSITY
NEW YORK
HARCOURT, BRACE AND COMPANY
COPYRIGHT, 1918, 1919, BY
WILLIAM STRUNK, JR.
COPYRIGHT, 1920, BY
HARCOURT, BRACE AND HOWE, INC.
THE MAPLE PRESS YORK PA
CONTENTS
Page
I. Introductory 5
II. Elementary Rules of Usage 7
1. Form the possessive singular of nouns by adding _'s_ 7
2. In a series of three or more terms with a single
conjunction, use a comma after each term except the last 7
3. Enclose parenthetic expressions between commas 8
4. Place a comma before a conjunction introducing a
co-ordinate clause 10
5. Do not join independent clauses by a comma 11
6. Do not break sentences in two 12
7. A participial phrase at the beginning of a sentence must
refer to the grammatical subject 13
III. Elementary Principles of Composition 15
8. Make the paragraph the unit of composition: one paragraph
to each topic 15
9. As a rule, begin each paragraph with a topic sentence; end
it in conformity with the beginning 17
10. Use the active voice 19
11. Put statements in positive form 21
12. Use definite, specific, concrete language 22
13. Omit needless words 24
14. Avoid a succession of loose sentences 25
15. Express co-ordinate ideas in similar form 26
16. Keep related words together 28
17. In summaries, keep to one tense 29
18. Place the emphatic words of a sentence at the end 31
IV. A Few Matters of Form 33
V. Words and Expressions Commonly Misused 36
VI. Spelling 48
VII. Exercises on Chapters II and III 50
I. INTRODUCTORY
This book aims to give in brief space the principal requirements of
plain English style. It aims to lighten the task of instructor and
student by concentrating attention (in Chapters II and III) on a few
essentials, the rules of usage and principles of composition most
commonly violated. In accordance with this plan it lays down three rules
for the use of the comma, instead of a score or more, and one for the
use of the semicolon, in the belief that these four rules provide for
all the internal punctuation that is required by nineteen sentences out
of twenty. Similarly, it gives in Chapter III only those principles of
the paragraph and the sentence which are of the widest application. The
book thus covers only a small portion of the field of English style. The
experience of its writer has been that once past the essentials,
students profit most by individual instruction based on the problems of
their own work, and that each instructor has his own body of theory,
which he may prefer to that offered by any textbook.
The numbers of the sections may be used as references in correcting
manuscript.
The writer's colleagues in the Department of English in Cornell
University have greatly helped him in the preparation of his manuscript.
Mr. George McLane Wood has kindly consented to the inclusion under
Rule 10 of some material from his _Suggestions to Authors_.
The following books are recommended for reference or further study: in
connection with Chapters II and IV, F. Howard Collins, _Author and
Printer_ (Henry Frowde); Chicago University Press, _Manual of Style_;
T. L. De Vinne, _Correct Composition_ (The Century Company); Horace
Hart, _Rules for Compositors and Printers_ (Oxford University Press);
George McLane Wood, _Extracts from the Style-Book of the Government
Printing Office_ (United States Geological Survey); in connection with
Chapters III and V, _The King's English_ (Oxford University Press); Sir
Arthur Quiller-Couch, _The Art of Writing_ (Putnam), especially the
chapter, Interlude on Jargon; George McLane Wood, _Suggestions to
Authors_ (United States Geological Survey); John Lesslie Hall, _English
Usage_ (Scott, Foresman and Co.); James P. Kelley, _Workmanship in
Words_ (Little, Brown and Co.). In these will be found full discussions
of many points here briefly treated and an abundant store of
illustrations to supplement those given in this book.
It is an old observation that the best writers sometimes disregard the
rules of rhetoric. When they do so, however, the reader will usually
find in the sentence some compensating merit, attained at the cost of
the violation. Unless he is certain of doing as well, he will probably
do best to follow the rules. After he has learned, by their guidance, to
write plain English adequate for everyday uses, let him look, for the
secrets of style, to the study of the masters of literature.

44
examples/viewpict.pas Normal file
View file

@ -0,0 +1,44 @@
program viewpict;
type PictData = record
magic, mode:integer;
palette: array [0..15] of integer;
pixeldata: array [0..31999] of integer;
end;
var pic:PictData;
filename:string;
infile:file;
ch:char;
procedure loadPalette(var pic:PictData);
var i:integer;
begin
for i := 0 to 15 do
setpalette(i, pic.palette[i]);
end;
procedure loadPic(var pic:PictData);
begin
PutScreen(pic.pixeldata);
end;
begin
if ParamCount > 0 then
filename := ParamStr(1)
else
begin
write('Filename> ');
readln(filename);
end;
open(infile, filename, ModeReadonly);
read(infile, pic);
close(infile);
writeln('magic: ', pic.magic, ' mode:', pic.mode);
loadPalette(pic);
loadPic(pic);
read(ch);
end.

1939
lib/runtime.s Normal file

File diff suppressed because it is too large Load diff

285
lib/stdlib.inc Normal file
View file

@ -0,0 +1,285 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
{ const pi = 3.14169253; }
const MaxInt = 2147483647;
const MaxVolumes = 32;
DefaultBufSize = 4096;
DefaultBufBlocks = 8;
DirSlotSize = 64;
const IONoError = 0;
IOFileNotFound = 1;
IOVolNotFound = 2;
IOPathInvalid = 3;
IOFileExists = 4;
IOFileClosed = 5;
IOSeekInvalid = 6;
IONoSpace = 7;
IOReadOnly = 8;
IOInvalidOp = 9;
IOInvalidFormat = 10;
IOUserIntr = 11;
IOMaxErr = 11;
const PArgMax = 7;
type IOBlock = array [0..127] of integer;
type IOBuffer = array [0..7] of IOBlock;
type filetype = (IOChannel, IODiskFile);
type filemode = (ModeReadonly, ModeCreate, ModeModify, ModeOverwrite, ModeAppend);
type file = record
mode: filemode;
lastError: integer;
errorAck: boolean;
ateoln:boolean;
case typ:filetype of
IOChannel: (channelid:integer;
bufchar:char; buflen:integer;
ateof:boolean;
noecho:boolean; (* read chars are not echoed *)
raw:boolean; (* turn off backspace processing on input, CR processing on output *)
nointr: boolean); (* turn off keyboard interrupt character processing *)
IODiskFile: (volumeid: integer;fileno: integer; filpos:integer; bufStart:integer;
size:integer; sizeExtents:integer;
bufBlocks, extentBlocks:integer;
changed: boolean;
buffer: ^IOBuffer;
bufpos: integer;
bufsize: integer;
needsflush: boolean;
);
end;
type text = file;
type fscanmode = (ScanInteger, ScanReal, ScanString);
type filenamestr = string[32];
type pathnamestr = string[68];
type volumenamestr = string[32];
type PartFlags = set of (PartEnabled, PartBoot, PartLast, PartPhysical, PartDefault);
type Partition = record
name: volumenamestr;
flags: PartFlags;
startBlock: integer;
blocks: integer;
extentSize: integer; (* size of an extent in bytes, power of two > 512 *)
dirSize: integer; (* number of directory slots *)
bootBlocks: integer;
end;
type PartitionTableBlock = array[0..7] of Partition;
type Volume = record
part: Partition;
deviceId: integer;
partitionId: integer;
startSlot: integer; (* first directory slot known to be in use *)
freeSlot: integer; (* a directory slot that is probably free *)
(* dirFile: ^file; (* pseudo-file for accessing the directory *)
dirCache: ^DirBlock;
cachedBlock: integer; (* cached volume block number in dirCache *)
cacheDirty: boolean;
openFilesCount: integer;
end;
type DirSlotFlags = set of (SlotFree, SlotReserved, SlotDeleted, SlotEndScan, SlotFirst, SlotExtent, SlotReadonly);
type Timestamp = integer;
type DirectorySlot = record
name: filenamestr; (* the name of the file *)
flags: DirSlotFlags; (* see above *)
sizeBytes: integer; (* the size of the file in bytes *)
createTime: Timestamp; (* creation time of the file *)
modTime: Timestamp; (* time of last file modification *)
generation: integer; (* increased each time a file is overwritten *)
owner: integer; (* unused *)
end;
DirBlock = array [0..7] of DirectorySlot;
type PArgVec = array[0..PArgMax] of string;
type DateTime = record
year:integer;
month: 1..12;
day: 1..31;
hours: 0..23;
minutes: 0..59;
seconds: 0..59;
end;
var input,output:file external;
var DefaultVolumeId:integer external; (* do we need this here? *)
VolumeTable: array [1..MaxVolumes] of Volume external; (* and this *)
VolumeCount: integer external; (* and this *)
DefaultVolume: volumenamestr external;
SysBootTicks, SysLastTicks:integer external;
SysClock:DateTime external;
(* from graphics.s *)
PROCEDURE DRAWLINE(x1,y1,x2,y2, color:INTEGER); EXTERNAL;
PROCEDURE PUTPIXEL(x,y, color:INTEGER); EXTERNAL;
PROCEDURE CLEARGRAPHICS; EXTERNAL;
PROCEDURE INITGRAPHICS; EXTERNAL;
PROCEDURE SETPALETTE(slot, color:INTEGER);EXTERNAL;
PROCEDURE PUTSCREEN(VAR pixeldata: ARRAY [0..31999] OF INTEGER); EXTERNAL;
function conin():char; external;
procedure conout(c:char); external;
FUNCTION CONAVAIL:BOOLEAN; EXTERNAL;
PROCEDURE WAIT1MSEC; EXTERNAL;
function upcase(aChar:char):char; external;
function getticks():integer; external;
(* from float32.s *)
function shiftfloat32(aReal:real; shiftCount:integer):real; external;
function getfloat32exp(aReal:real):integer; external;
(* from runtime.s *)
FUNCTION LENGTH(s:STRING):INTEGER; EXTERNAL;
FUNCTION MAXLENGTH(s:STRING):INTEGER; EXTERNAL;
procedure appendchar(var s:string; aChar:char); external;
procedure strmoveup(var s:string;index,length,delta:integer); external;
procedure strmovedown(var s:string;index,length,delta:integer); external;
procedure RuntimeError(var s:string); external;
(* from stdlib *)
function copy(s:string;index,count:integer):string; external;
procedure insert(ins: string; var dest: string; position:integer); external;
procedure delete(var s:string; from:integer; count:integer); external;
function pos(substr:string;var s:string):integer; external;
function pwroften(exp:integer):real; external;
function exp(exponent:real):real; external;
function ln(power:real):real; external;
function sqrt(n:real):real; external;
function floor(x:real):integer; external;
function round(x:real):integer; external;
function sin(x:real):real; external;
function cos(x:real):real; external;
function arctan(x:real):real; external;
function tan(x:real):real; external;
function cotan(x:real):real; external;
procedure fillchar(var s:string; startpos,count:integer; theChar:char); external;
procedure cardinitv2; external;
function cardsize:integer; external;
function cardchanged:boolean; external;
procedure readpartblk(blkno:integer;var partblk:PartitionTableBlock;
var error:integer;devid: integer); external;
procedure readdirblk(blkno:integer;var dirblk:DirBlock;
var error:integer;devid: integer); external;
procedure readblock(blkno:integer;var buf:IOBlock;
var error:integer; devid: integer); external;
procedure writedirblk(blkno:integer;var dirblk:DirBlock;
var error:integer;devid: integer); external;
procedure writepartblk(blkno:integer;var partblk:PartitionTableBlock;
var error:integer;devid: integer); external;
procedure writeblock(blkno:integer;var buf:IOBlock;
var error:integer; devid: integer); external;
procedure copybuf(dest:^IOBuffer;destOffset:integer; src:^IOBuffer; srcOffset:integer; length: integer); external;
function readfschar(var f:file):char; external;
procedure writefschar(var f:file; aChar:char); external;
procedure writefsstring(var f:file; var s:string); external;
procedure conoutw(w:integer); external;
function coninw():integer; external;
procedure SetDefaultVolume(volname:volumenamestr); external;
procedure addPartitions(devid:integer; var partblk:PartitionTableBlock; var isLast:boolean); external;
procedure readPartitions(devid: integer); external;
procedure initDevices; external;
procedure readdevice(deviceId:integer;blockNo:integer;var buf:IOBlock; var error:integer); external;
procedure writedevice(deviceId:integer;blockNo:integer;var buf:IOBlock; var error:integer); external;
procedure readvolumeblks(volumeid:integer; destbuf:^iobuffer; blkno:integer; blkCount: integer; var error:integer);
external;
procedure writevolumeblks(volumeid:integer; srcbuf:^iobuffer; blkno:integer; blkCount: integer; var error:integer);
external;
function findvolume(name:string):integer; external;
procedure openvolumeid(volid:integer); external;
procedure closevolumeid(volid:integer); external;
function IOResult(var fil:file):integer; external;
function ErrorStr(err:integer):string; external;
function eof(var fil:file):boolean; external;
function eoln(var fil:file):boolean; external;
procedure readfs(var fil:file; destbuf:^IOBuffer; len:integer); external;
procedure flushfile(var fil:file); external;
procedure seek(var fil:file; position:integer); external;
function filepos(var fil:file):integer; external;
function filesize(var fil:file):integer; external;
procedure extendfile(var fil:file; newSize:integer); external;
procedure writefs(var fil:file; srcbuf:^IOBuffer; len:integer); external;
procedure close(var aFile:file); external;
procedure readdirnext(volid:integer; var index:integer; var dirslot:DirectorySlot; var error:integer); external;
procedure readdirfirst(volid:integer; var index:integer; var dirslot:DirectorySlot; var error:integer); external;
function charpos(searchChar:char; var s:string):integer; external;
procedure rename(oldname:filenamestr; newname:filenamestr; var error:integer); external;
procedure erase(name:pathnamestr; var error:integer); external;
function readchannel(var f:file):char; external;
procedure writechannel(var f:file; aChar:char); external;
function freadchar(var f:file):char; external;
procedure fwritechar(aChar:char; var f:file); external;
procedure fwritestring(var aString:string; var f:file; w:integer); external;
procedure fwriteint(v:integer; var f:file; w:integer); external;
procedure fwritereal(v:real; var f:file; w,d:integer); external;
procedure pushback(var aFile:file; aChar:char); external;
procedure skipeoln(var aFile:file); external;
procedure fscanbuf(var aFile:file; mode: fscanmode; var buf:string); external;
procedure freadint(var v:integer;var f:file); external;
procedure freadreal(var v:real;var f:file); external;
procedure openchannel(name:filenamestr; var f:file; mode:filemode; var error:integer); external;
procedure open(var f:file; name:pathnamestr; mode: filemode); external;
procedure noecho(var f:file; noecho:boolean; var old:boolean); external;
procedure intstr(v:integer; fieldWith:integer; var rbuf:string);
external;
procedure realstr(x:real; w, d: integer; var s: string[30]); external;
procedure intval(s:string; var value,code:integer); external;
procedure realval(s:string; var value:real;var code:integer); external;
function isdigit(aChar:char):boolean; external;
function iswhite(aChar:char):boolean; external;
procedure halt; external;
function random:integer; external;
procedure randomize; external;
(* from stdterm.inc *)
procedure ClrScr; external;
procedure ClrEol; external;
procedure CrtInit; external;
procedure GotoXY(x,y:integer); external;
procedure InsLine; external;
procedure DelLine; external;
procedure GetCursorPos(var x,y:integer); external;
procedure GetTermSize(var maxx,maxy:integer); external;
procedure TextColor(col:integer); external;
procedure TextBackground(bgcol:integer); external;
procedure TextDefault; external;
procedure PTerm; external; (* from runtime.s *)
procedure PExec(prgfile:pathnamestr; var args:PArgVec; argCount:integer;var error:integer); external;
procedure PExec2(prgfile:pathnamestr; arg1:string; var error:integer); external;
procedure PExec3(prgfile:pathnamestr; arg1, arg2:string; var error:integer); external;
function ParamStr(i:integer):string; external;
function ParamCount():integer; external;
procedure SetShellCmd(cmd:string[40];arg:integer); external;
function GetTime:DateTime; external;
function TimeStr(d:DateTime;showSeconds:boolean):string; external;
function DateStr(d:DateTime):string; external;
function GetTimestamp(var d:DateTime):integer; external;
function GetDateTime(ts:Timestamp):DateTime; external;
procedure delay(ms:integer); external;

2710
lib/stdlib.pas Normal file

File diff suppressed because it is too large Load diff

57
lib/stdterm.inc Normal file
View file

@ -0,0 +1,57 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
procedure ClrScr;
begin
write(#27, '[2J');
write(#27, '[H');
end;
procedure ClrEol;
begin
write(#27, '[K');
end;
procedure CrtInit;
begin
write(#27, 'c');
end;
procedure GotoXY(x,y:integer);
begin
write(#27,'[', y, ';', x, 'H');
end;
procedure InsLine;
begin
write(#27,'[L');
end;
procedure DelLine;
begin
write(#27,'[M');
end;
procedure GetCursorPos(var x,y:integer); external; (* from corelib.s *)
procedure GetTermSize(var maxx,maxy:integer);
var x,y:integer;
begin
GetCursorPos(x,y);
GotoXY(9999,9999);
GetCursorPos(maxx,maxy);
GotoXY(x,y);
end;
procedure TextColor(col:integer);
begin
write(#27,'[38;5;',col,'m');
end;
procedure TextBackground(bgcol:integer);
begin
write(#27,'[48;5;',bgcol,'m');
end;
procedure TextDefault;
begin
write(#27,'[0m');
end;

17
pcomp/.vscode/tasks.json vendored Normal file
View file

@ -0,0 +1,17 @@
{
// See https://go.microsoft.com/fwlink/?LinkId=733558
// for the documentation about the tasks.json format
"version": "2.0.0",
"tasks": [
{
"label": "pcomp",
"type": "shell",
"command": "fpc -Mobjfpc -gl pcomp.pas",
"problemMatcher": [],
"group": {
"kind": "build",
"isDefault": true
}
}
]
}

1620
pcomp/emit.pas Normal file

File diff suppressed because it is too large Load diff

95
pcomp/float32+.pas Normal file
View file

@ -0,0 +1,95 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
function encodefloat32(r:real):integer;
var intpart:real;
fract: real;
exponent:integer;
sign:integer;
i:integer;
digit, bitpos:integer;
intlength,fractlength:integer;
intbin:integer;
fractbin:integer;
floatbin:integer;
begin
intbin := 0; fractbin := 0; floatbin := 0;
if r<0 then
begin
r := abs(r);
sign := 1;
end
else
sign := 0;
if r = 0.0 then
begin
intpart := 0.0;
fract := 0.0;
intlength := 0;
fractlength := 0;
intbin := 0;
fractbin := 0;
floatbin := 0;
end
else
begin
intpart := r;
fract := frac(r);
exponent := floor(log2(intpart));
intlength := exponent+1;
fractlength := wordbits - intlength - Float32ExpBits - 1;
end;
(* FIXME: log2 gives division by zero on zero arg *)
(* process bits before the point *)
for i := 1 to intlength do
begin
(* digit := round(intpart mod 2.0); *)
(* calculate real remainder in a portable way *)
digit := floor(intpart - 2 * Int(intpart / 2));
(* if we used up all the bits in the fraction part of
the float32 encoding, shift everything right
and put bit at the top *)
if i > Float32FractBits then
begin
bitpos := Float32FractBits-1;
intbin := intbin shr 1;
end
else
bitpos := i - 1;
if digit > 0 then intbin := intbin + (1 << bitpos);
intpart := intpart / 2.0;
end;
(* limit the integer bits *)
if intlength > Float32FractBits then intlength := Float32FractBits;
(* process bits after the point, if we have any bits left *)
if fractlength > 0 then
begin
for i := 1 to fractlength do
begin
fract := fract * 2;
digit := trunc(fract) and 1;
fractbin := (fractbin shl 1) + digit;
end;
end;
floatbin := (intbin << (Float32FractBits - intlength)) + fractbin;
if floatbin = 0 then (* if mantissa is zero, return a clean zero value *)
encodefloat32 := 0
else
begin
exponent := exponent + Float32ExpBias;
if (exponent > Float32ExpMax) or (exponent < 0) then
errorExit2('float exponent overflow','');
encodefloat32 := (sign shl (wordBits-1)) + (floatbin << Float32ExpBits) + exponent;
end;
end;

2
pcomp/float32+tdr.pas Normal file
View file

@ -0,0 +1,2 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
function encodefloat32(r:real):integer; external;

304
pcomp/libgen.pas Normal file
View file

@ -0,0 +1,304 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
program libgen;
const shortcutChar = '`';
firstShCChar = 'A';
lastShCChar = 'i';
OutfileSuffix = '.lib';
{$I 'platfile-types+.pas'}
type
InsString = string[24];
var shortcuts:array [firstShCChar..lastShCChar] of InsString;
infile:TextFile;
outfile:TextFile;
infileName:string;
outfileName:string;
lineCount:integer;
procedure errorExit2(reason:string;arg:string); forward;
{$I 'platfile+.pas'}
procedure errorExit2(reason:string;arg:string);
begin
writeln;
writeln('Error: ', reason, ' ', arg);
halt;
end;
procedure addShortcut(ch:char; dest:InsString);
begin
shortcuts[ch] := dest;
end;
function findShortcut(ins:InsString):char;
var ch:char;
begin
findShortCut := #0;
for ch := firstShCChar to lastShCChar do
begin
if shortcuts[ch] = ins then
begin
findShortcut := ch;
break;
end;
end;
{ if findShortCut = #0 then writeln('findShortcut:#0'); }
end;
procedure initShortcuts;
begin
addShortcut('A', 'ADD');
addShortcut('B', 'BRANCH');
addShortcut('C', 'CALL');
addShortcut('D', 'DUP');
addShortcut('E', 'LOADREL');
addShortcut('F', 'LOAD');
addShortcut('G', 'LOADREG');
addShortcut('H', 'SHL');
addShortcut('I', 'LOADI');
addShortcut('J', 'JUMP');
addShortcut('K', 'LOADC');
addShortcut('L', 'LOADCP');
addShortcut('M', 'STORE');
addShortcut('N', 'NIP');
addShortcut('O', 'OR');
addShortcut('P', 'DROP');
(* Q is unused *)
addShortcut('R', 'RET');
addShortcut('S', 'STOREI');
addShortcut('T', 'NOT');
addShortcut('U', 'CMPU');
addShortcut('V', 'OVER');
addShortcut('W', 'SWAP');
addShortcut('X', 'XOR');
(* Y is ununsed *)
addShortcut('Z', 'SUB');
addShortcut('a', 'AND');
addShortcut('b', 'CBRANCH');
addShortcut('c', 'CMP');
addShortcut('d', 'DEC');
(* e is unused *)
addShortcut('f', 'FPADJ');
addShortcut('g', 'STOREREG');
addShortcut('h', 'SHR');
addShortcut('i', 'INC');
end;
procedure processLine(var linebuf:string);
var labelEnd:integer;
dotPos:integer;
endPos:integer;
insStart:integer;
insEnd:integer;
labelBuf:string;
insBuf:string;
restBuf:string;
short:char;
procedure scanLine;
var c:char;
i:integer;
begin
labelEnd := 0;
dotPos := 0;
endPos := 0;
insStart := 0;
insEnd := 0;
i := 1;
for c in linebuf do
begin
if (labelEnd = 0) and (c = ':') then
begin
insStart := 0;
insEnd := 0;
labelEnd := i;
end
else
if (dotPos = 0) and (c = '.') then
begin
insEnd := i - 1;
dotPos := i;
end
else
if c = ';' then break
else
if c in [ ' ', #9 ] then
begin
if (insStart <> 0 ) and (insEnd = 0) then
insEnd := i - 1;
end
else
if c in [ '''', '"' ] then
begin
(* we do not want to deal with string quoting,
so if we encounter some quotes,
just do nothing *)
insStart := 0;
insEnd := 0;
labelEnd := 0;
endPos := length(linebuf);
break;
end
else
begin
if insStart = 0 then
insStart := i;
endPos := i;
{ writeln('c:', c, ' i:', i, ' insStart:', insStart); }
end;
i := i + 1;
end;
if insEnd = 0 then insEnd := endPos;
end;
begin
if length(linebuf) > 0 then
if linebuf[1] <> '%' then
begin
scanLine;
if labelEnd > 0 then
labelBuf := copy(linebuf,1,labelEnd)
else
labelBuf := '';
if insStart > 0 then
insBuf := copy(linebuf, insStart, insEnd - insStart + 1)
else
insBuf := '';
if endPos <> insEnd then
restBuf := copy(linebuf, insEnd + 1, endPos - insEnd + 1)
else
restBuf := '';
{
writeln('ins ', insBuf);
writeln('label ', labelBuf);
writeln('rest ', restBuf);
writeln('insStart ', insStart);
writeln('insEnd ', insEnd);
writeln('dotPos ', dotPos);
writeln('endPos ', endPos);
}
short := #0;
if length(insBuf) > 0 then
begin
(* if we found an instruction, try to find a shortcut *)
short := findShortcut(insBuf);
if short <> #0 then
writeln(outfile, labelBuf, '`', short, restBuf)
else
(* if no shortcut, we still remove comments and whitespace *)
writeln(outfile, labelBuf, ' ', insBuf, restBuf);
end
else
(* no instruction found, probably a directive, so
no change *)
writeln(outfile, linebuf);
end
else
writeln(outfile, linebuf);
end;
procedure processAllLines;
var linebuf:string;
begin
while not eof(infile) do
begin
readln(infile, linebuf);
lineCount := lineCount + 1;
if (lineCount and 255) = 1 then
write(lineCount, ' lines', #13);
processLine(linebuf);
end;
writeln(lineCount, ' lines');
end;
procedure test;
var buf:string;
begin
outfile := output;
buf := 'LABEL: SOMEINS.MOD1.MOD2 ARG ; a comment';
processLine(buf);
buf := ' SOMEINS.MOD1.MOD2 ARG ; a comment';
processLine(buf);
buf := ' LOADCP 1';
processLine(buf);
buf := ' JUMP';
processLine(buf);
buf := 'LABEL: FPADJ -20';
processLine(buf);
buf := 'LABEL: .BYTE ":;123"';
processLine(buf);
buf := 'LABEL: .LCBRANCH SOMEWHERE';
processLine(buf);
buf := 'LABEL: LOADC '';''';
processLine(buf);
end;
function changeSuffix(var fname:string):string;
var dotPos:integer;
found:boolean;
begin
found := false;
for dotPos := length(fname) downto 1 do
if fname[dotPos] = '.' then
begin
found := true;
break;
end;
if found then
changeSuffix := copy(fname,1, dotPos - 1) + OutfileSuffix
else
changeSuffix := fname + OutfileSuffix;
end;
begin
initShortcuts;
{ test;
halt; }
outfileName := '';
case ParamCount of
0: begin
write('Source file: ');
readln(infileName);
end;
1: infileName := ParamStr(1);
2: begin
infileName := ParamStr(1);
outfileName := ParamStr(2);
end
else
begin
writeln('Invalid arguments.');
halt;
end;
end;
if length(outfileName) = 0 then
outfileName := changeSuffix(infileName);
writeln('Output file: ', outfileName);
openTextFile(infile, infileName);
overwriteTextFile(outfile, outfileName);
processAllLines;
close(infile);
close(outfile);
end.

111
pcomp/lsymgen.pas Normal file
View file

@ -0,0 +1,111 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
program lsymgen;
const OutfileSuffix = '.lsym';
{$I 'platfile-types+.pas'}
var
outfile:TextFile;
infile:TextFile;
lineno:integer;
procedure errorExit2(reason:string;arg:string); forward;
{$I 'platfile+.pas'}
procedure errorExit2(reason:string;arg:string);
begin
writeln;
writeln('Error: ', reason, ' ', arg);
writeln('at ', lineno);
halt;
end;
function rpos(c:char; var s:string):integer;
var i:integer;
begin
for i := length(s) downto 1 do
if s[i] = '.' then break;
if i = 1 then
rpos := 0
else
rpos := i;
end;
function strcontains(var s:string; c:char):boolean;
begin
strcontains := pos(c, s) > 0;
end;
function getOutfileName(infileName:string):string;
var p:integer;
begin
p := rpos('.', infileName);
if p > 1 then
getOutfileName := copy(infileName, 1, p - 1)
else
getOutfileName := infileName;
getOutfileName := getOutfileName + OutfileSuffix;
end;
procedure splitLine(var line:string; var addr:string; var name:string;
var clean:boolean);
var n,l:integer;
begin
n := pos(' ', line);
if n <= 1 then
errorExit2('invalid syntax:', line);
addr := copy(line, 1, n - 1);
l := length(line);
while (n < l) and (line[n] = ' ') do
n := n + 1;
name := copy(line, n, l - n + 1);
(* symbols starting with '!' are explicitly exported *)
if name[1] = '!' then
begin
clean := true;
name := copy(name, 2, length(name) - 1);
end
else
clean := (not strcontains( name, '_')) and (name[1] <> '=');
end;
procedure processFile(inpath,outpath:string);
var line:string;
addr,name:string;
clean:boolean;
begin
lineno := 0;
writeln('writing file ', outpath);
openTextFile(infile, inpath);
overwriteTextFile(outfile, outpath);
while not eof(infile) do
begin
readln(infile, line);
splitLine(line, addr, name, clean);
if clean then
writeln(outfile, #9, '.EQU ', name, ' $', addr);
end;
close(infile);
close(outfile);
end;
begin
if ParamCount > 0 then
begin
processFile(ParamStr(1), getOutfileName(ParamStr(1)));
end
else
writeln('No file name given.');
end.

34
pcomp/make.bat Normal file
View file

@ -0,0 +1,34 @@
fpc -Mobjfpc -gl pcomp.pas
fpc -gl sasm.pas
fpc -gl lsymgen.pas
sasm ..\lib\coreloader.s
lsymgen ..\lib\coreloader.sym
py pcomp.py -n stdlib.pas
libgen ..\lib\stdlib.s
libgen ..\lib\runtime.s
libgen ..\lib\float32.s
py pcomp.py sasm.pas
py pcomp.py pcomp.pas
py pcomp.py lsymgen.pas
py pcomp.py libgen.pas
rem exit /b
py pcomp.py ..\progs\shell.pas
py pcomp.py ..\progs\editor.pas
py pcomp.py ..\progs\reclaim.pas
py pcomp.py ..\progs\dumpdir.pas
py pcomp.py ..\progs\partmgr.pas
py pcomp.py ..\progs\xfer.pas
rem exit /b
py pcomp.py ..\tests\readtest.pas
py pcomp.py ..\tests\readchartest.pas
py pcomp.py ..\tests\timetest.pas
py pcomp.py ..\tests\test133.pas
py pcomp.py ..\tests\chase.pas
py pcomp.py ..\tests\cchangetest.pas
py pcomp.py ..\tests\tree.pas

6452
pcomp/pcomp.pas Normal file

File diff suppressed because it is too large Load diff

102
pcomp/pcomp.py Normal file
View file

@ -0,0 +1,102 @@
#!/usr/bin/python3
# vim: tabstop=8 expandtab shiftwidth=4 softtabstop=4
# Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
import sys
import subprocess
import os
suffixes = [ '.teeny', '.pas' ]
compiler = 'pcomp'
#assembler = '..\sasm\sasm.py'
assembler = 'sasm'
emulator = 's4emu.py'
asm_include_path = '../lib'
def run_compiler(filename, opts):
print("compiling {}...".format(filename))
args = [compiler]
args.extend(opts)
args.append(filename)
#print("args:",args)
status = subprocess.call(args)
if status != 0:
sys.exit(2)
def run_assembler(filename):
print("assembling {}...".format(filename))
args = [assembler]
# args.extend([ '-I', asm_include_path])
args.append(filename)
status = subprocess.call(args)
if status != 0:
sys.exit(3)
def run_emulator(filename, extra_args):
args = ['py', emulator, '-a', '24576', filename ]
args.extend(extra_args)
status = subprocess.call(args)
if status != 0:
sys.exit(4)
def get_compiler_options():
comp_options = [ "-n", "-s", "-e", "-R", "-S", "-H" ]
result = []
while len(sys.argv) > 1 and sys.argv[1] in comp_options:
result.append(sys.argv[1])
if sys.argv[1] == "-H":
sys.argv.pop(1)
result.append(sys.argv[1])
sys.argv.pop(1)
# print("Compiler options:",result, sys.argv[1])
return result
def main():
do_compile = True
do_assemble = True
do_emulator = False
if len(sys.argv) < 2:
print("Usage: {} <input file>".format(sys.argv[0]))
sys.exit(1)
compiler_options = get_compiler_options()
infilename = sys.argv[1]
basename = infilename
if infilename.endswith('.s'):
do_compile = False
basename = infilename[:-2]
elif infilename.endswith('.bin') or infilename.endswith('.prog'):
do_compile = False
do_assemble = False
do_emulator = True
basename = infilename[:-4]
else:
fname, suffix = os.path.splitext(infilename)
if suffix in suffixes:
print("#############",fname, "####",suffix)
basename = fname
asmfilename = basename + '.s'
#binfilename = basename + '.bin'
binfilename = basename + '.prog'
if "-n" in compiler_options:
# Assembling stdlib won't work
do_assemble = False
do_emulator = False
if do_compile:
run_compiler(infilename, compiler_options)
if do_assemble:
run_assembler(asmfilename)
if do_emulator:
run_emulator(binfilename, sys.argv[2:])
if __name__ == '__main__':
main()

17
pcomp/platfile+.pas Normal file
View file

@ -0,0 +1,17 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
procedure openTextFile(var f:TextFile; filename:string);
begin
{$I-}
assign(f, filename);
reset(f);
if IOResult <> 0 then
errorExit2('cannot open file', filename);
{$I+}
end;
procedure overwriteTextFile(var f:TextFile; filename:string);
begin
assign(f, filename);
rewrite(f);
end;

12
pcomp/platfile+tdr.pas Normal file
View file

@ -0,0 +1,12 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
procedure openTextFile(var f:TextFile; filename:string);
begin
open(f, filename, ModeReadOnly);
if IOResult(f) <> 0 then
errorExit2('cannot open file', filename);
end;
procedure overwriteTextFile(var f:TextFile; filename:string);
begin
open(f, filename, ModeOverwrite);
end;

View file

@ -0,0 +1,2 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
type TextFile = text;

View file

@ -0,0 +1,2 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
type TextFile = file;

53
pcomp/platform+.pas Normal file
View file

@ -0,0 +1,53 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
procedure initPlatform;
begin
outputPrefix := '';
includePrefix := '..\lib\';
end;
procedure newString(var s:StringRef;len:integer);
begin
new(s);
end;
procedure openFileWithDefault(var f:InputFileType; filename:string);
begin
{$I-}
assign(f, filename);
reset(f);
if IOResult <> 0 then
begin
assign(f, includePrefix + '/' + filename);
reset(f);
if IOResult <> 0 then
errorExit2('cannot open file', filename);
end;
{$I+}
end;
procedure overwriteFile(var f:OutputFileType; filename:string);
begin
assign(f, outputPrefix + filename);
rewrite(f);
end;
function isdigit(aChar:char):boolean;
begin
isdigit := (ord(aChar) >= ord('0')) and (ord(aChar) <= ord('9'));
end;
procedure ExecEditor(var filename:string; lineno:integer; errormsg:string);
begin
halt;
end;
procedure ExecAssembler(var filename:string; doRun:boolean; editOnError:boolean);
begin
halt;
end;
procedure ExecProgram(var filename:string);
begin
halt;
end;

76
pcomp/platform+tdr.pas Normal file
View file

@ -0,0 +1,76 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
procedure initPlatform;
begin
outputPrefix := '';
includePrefix := '#SYSTEM:';
end;
procedure newString(var s:StringRef;len:integer);
begin
new(s,len);
end;
procedure openFileWithDefault(var f:InputFileType; filename:string);
begin
open(f, filename, ModeReadOnly);
if IOResult(f) <> 0 then
begin
open(f, includePrefix + filename, ModeReadOnly);
if IOResult(f) <> 0 then
errorExit2('cannot open file', filename);
end;
end;
procedure overwriteFile(var f:OutputFileType; filename:string);
begin
open(f, outputPrefix + filename, ModeOverwrite);
end;
procedure printExecErr(filename:string; error:integer);
begin
writeln('PExec failed for ', filename, ': ', ErrorStr(error));
end;
procedure ExecEditor(var filename:string; lineno:integer; errormsg:string);
var args:PArgVec;
error:integer;
digits:string[12];
begin
str(lineno, digits);
args[0] := '-l'; args[1] := digits;
args[2] := '-E'; args[3] := errormsg;
args[4] := filename;
PExec('#SYSTEM:editor.prog', args, 5, error);
printExecErr('#SYSTEM:editor.prog', error);
end;
procedure ExecAssembler(var filename:string; doRun:boolean; editOnError:boolean);
var args:PArgVec;
argPos:integer;
error:integer;
begin
if doRun then
begin
args[0] := '-R';
argPos := 1;
end
else
argPos := 0;
if editOnError then
begin
args[argPos] := '-e';
argPos := argPos + 1;
end;
args[argPos] := filename;
PExec('#SYSTEM:sasm.prog', args, argPos + 1, error);
printExecErr('#SYSTEM:editor.prog', error);
end;
procedure ExecProgram(var filename:string);
var args:PArgVec;
error:integer;
begin
writeln('Running ', filename, '...');
PExec(filename, args, 0, error);
printExecErr(filename, error);
end;

View file

@ -0,0 +1,7 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
type
OutputFileType = text;
InputFileType = file of char;
SymFileType = text;
ExecAction = (Edit, Assemble, Run);

View file

@ -0,0 +1,6 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
OutputFileType = file;
InputFileType = file;
SymFileType = file;
ExecAction = (Edit, Assemble, Run);

2650
pcomp/sasm.pas Normal file

File diff suppressed because it is too large Load diff

884
pcomp/sdis.pas Normal file
View file

@ -0,0 +1,884 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
program sdis;
{$R+}
{$MODE objfpc}
type
InputFileType = file of char;
OutputFileType = text;
KeywordString = string[128];
IdentString = string[80];
SymbolType = (ConstSymbol, LabelSymbol, SpecialSymbol);
Symbol = record
name:KeywordString;
value:integer;
typ:SymbolType;
end;
HashEntry = record
key:integer;
data:IdentString;
next:^HashEntry;
end;
HashRef = ^HashEntry;
HashBucket = ^HashEntry;
HashTable = array [0..255] of HashBucket;
var infile:InputfileType;
filename:string;
pc:integer;
symbolTable: HashTable;
procedure errorExit;
begin
close(infile);
halt;
end;
procedure errorExit2(message1, message2: string);
begin
writeln;
writeln('Error: ', message1, ' ', message2);
errorExit;
end;
procedure openFile(var f:InputFileType;var filename:string);
begin
{$I-}
assign(f, filename);
reset(f);
if IOResult <> 0 then
errorExit2('cannot open file ', filename);
{$I+}
end;
function readChar:char;
var c:char;
begin
read(infile,c);
readChar := c;
end;
procedure readEol;
var c:char;
begin
c := readChar;
if c = #13 then
begin
c := readChar;
end;
end;
function readBin(len:integer):integer;
var i,v:integer;
c:char;
begin
v := 0;
for i := 1 to len do
begin
c := readChar;
v := v shl 8;
v := v or ord(c);
end;
readBin := v;
end;
function readAsciiBin(len:integer):integer;
var i:integer;
w:integer;
c:char;
bits:integer;
begin
bits := len * 8;
w := 0;
for i := 1 to bits do
begin
w := w shl 1;
c := readChar;
if c = '1' then
w := w or 1
else
if c = '0' then begin end;
end;
readAsciiBin := w;
(* read end of line *)
if (pc and 3) = 2 then
readEol;
end;
function readBytes(len:integer):integer;
var w:integer;
c:char;
i:integer;
begin
w := 0;
for i := 1 to len do
begin
read(infile, c);
w := (w shl 8) or ord(c);
end;
readBytes := w;
writeln('readBytes ',len, ': ', w);
end;
function readInstruction:integer;
begin
(* readInstruction := readBytes(2); *)
readInstruction := readBin(2);
end;
function readWord:integer;
begin
readWord := readBin(4);
end;
function convertHex(var digits:KeywordString):integer;
var i,v,len:integer;
c:char;
begin
len := length(digits);
i := 1;
convertHex := 0;
while i <= len do
begin
convertHex := convertHex shl 4;
c := UpCase(digits[i]);
if (c >= 'A') and (c <= 'F') then
v := ord(c) - ord('A') + 10
else
if (c >= '0') and (c <= '9') then
v := ord(c) - ord('0')
else
errorExit2('invalid number',digits);
convertHex := convertHex + v;
i := i + 1;
end;
end;
procedure hexstr(value:integer;var output:string);
var i:integer;
nibble:integer;
c:char;
begin
output := '00000000';
for i := 8 downto 1 do
begin
nibble := value and $F;
if nibble > 9 then
c := chr( ord('A') + nibble - 10)
else
c := chr( ord('0') + nibble);
output[i] := c;
value := value shr 4;
if value = 0 then break;
end;
end;
procedure writeHex(value:integer);
var s:string;
begin
hexstr(value,s);
write('$',s);
end;
procedure printAsciiWord(w:integer);
var i:integer;
c:char;
begin
write('"');
for i := 1 to 4 do
begin
c := chr(((w shr 24) and $FF));
w := w shl 8;
if (c < ' ') or (c > '~') then
c := '.';
write(c);
end;
write('"');
end;
{$R-}
(* disable range checks for 32-bit hash functions *)
(* hash a 32-bit integer into an 8-bit integer *)
function hashint(value:integer):integer;
var i:integer;
begin
hashint := 0;
value := value xor $B298AB49; (* some random 32-bit constant *)
for i := 1 to 4 do
begin
hashint := hashint xor (value and $FF);
value := value shr 8;
end;
end;
{$R+}
procedure putHashed(var t:HashTable;key:integer;var data:KeywordString);
var i:integer;
newEntry:^HashEntry;
bucket:HashBucket;
begin
new(newEntry);
newEntry^.data := data;
newEntry^.key := key;
i := hashint(key);
bucket := t[i];
newEntry^.next := bucket;
t[i] := newEntry;
end;
function getHashed(var t:HashTable;key:integer):HashRef;
var bucket:HashBucket;
current:^HashEntry;
found:boolean;
begin
getHashed := nil;
bucket := t[hashint(key)];
current := bucket;
found := false;
while (current <> nil) and not found do
begin
if current^.key = key then
begin
getHashed := current;
found := true;
end;
current := current^.next;
end;
end;
function getHashBucket(var t:HashTable;key:integer):HashRef;
begin
getHashBucket := t[hashint(key)];
end;
procedure dumpHash(var t:HashTable);
var i:integer;
bucket:HashBucket;
current:HashRef;
begin
for i := 0 to 255 do
begin
write('bucket ',i:4, ' ');
bucket := t[i];
current := bucket;
while current <> nil do
begin
write(current^.key, ':', current^.data, ' ');
current := current^.next;
end;
writeln;
end;
end;
procedure printEol;
begin
writeln;
end;
procedure printHex(value:integer);
var s:string[8];
begin
write('$');
hexstr(value, s);
write(s);
end;
procedure printOperand(operand:integer);
var sym:HashRef;
begin
sym := getHashed(symbolTable, operand);
if sym <> nil then
begin
write(sym^.data);
write(' ; ');
end;
printHex(operand);
end;
procedure printSpacedOperand(operand:integer);
begin
write(' ');
printOperand(operand);
end;
(* operates on numbers with less than 32 bits, signmask indicates the
highest bit which is the sign *)
function makepositive(operand, signmask:integer):integer;
begin
if (operand and signmask) <> 0 then
makepositive := signmask - (operand and (not signmask))
else
makepositive := operand;
end;
function signExtend(operand, signmask:integer):integer;
begin
if (operand and signmask) <> 0 then
signExtend := -(signmask - (operand and (not signmask)))
else
signExtend := operand;
end;
procedure printSignedOperand(operand, signmask:integer);
var sym:HashRef;
begin
write(' ');
sym := getHashed(symbolTable, operand);
if sym <> nil then
write(sym^.data)
else
begin
if operand and signmask <> 0 then
begin
write('-');
operand := makepositive(operand, signmask);
end;
printHex(operand);
end;
end;
procedure decodeBranch(operand:integer);
begin
write('BRANCH');
printSpacedOperand(pc + signExtend(operand, $1000));
end;
procedure decodeCbranch(operand:integer);
begin
write('CBRANCH');
if (operand and 1) = 1 then
write('.NZ')
else
write('.Z');
printSpacedOperand(pc + signExtend((operand and $FFFE), $100));
end;
procedure decodeLoadc(operand:integer);
begin
write('LOADC');
printSignedOperand(operand, $1000);
end;
procedure decodeLoadStore(name:string; operand:integer);
begin
write(name);
if (operand and 1) = 1 then
write('.B');
printSpacedOperand(operand and $FFFE);
end;
procedure decodeModifier(name:string;value, mask:integer; operand:integer; visible:boolean);
begin
if (operand and mask) = value then
if visible then
write('.',name);
end;
procedure decodeXfer(operand:integer);
begin
write('XFER');
decodeModifier('RSM1', $0300, $0300, operand, true);
decodeModifier('RS0', $0000, $0300, operand, false);
decodeModifier('RS1', $0100, $0300, operand, true);
decodeModifier('R2P', $0080, $0080, operand, true);
decodeModifier('P2R', $0040, $0040, operand, true);
decodeModifier('SM1', $0030, $0030, operand, true);
decodeModifier('S0', $0000, $0030, operand, false);
decodeModifier('S1', $0010, $0030, operand, true);
decodeModifier('X2P', $0001, $0001, operand, true);
end;
procedure printCmpOperand(operand:integer);
begin
case operand of
2: write('EQ');
6: write('NE');
1: write('LT');
3: write('LE');
5: write('GE');
7: write('GT');
else write('<unknown:',operand,'>');
end;
end;
procedure decodeAlu(operand:integer);
var aluop:integer;
begin
write('ALU');
decodeModifier('ADD', $0000, $1e00, operand, true);
decodeModifier('SUB', $0200, $1e00, operand, true);
decodeModifier('NOT', $0400, $1e00, operand, true);
decodeModifier('AND', $0600, $1e00, operand, true);
decodeModifier('OR', $0800, $1e00, operand, true);
decodeModifier('XOR', $0a00, $1e00, operand, true);
decodeModifier('CMP', $0c00, $1e00, operand, true);
decodeModifier('Y', $0e00, $1e00, operand, true);
decodeModifier('SHR', $1000, $1e00, operand, true);
decodeModifier('SHL', $1200, $1e00, operand, true);
decodeModifier('INC', $1400, $1e00, operand, true);
decodeModifier('DEC', $1600, $1e00, operand, true);
decodeModifier('BPLC', $1a00, $1e00, operand, true);
decodeModifier('BROT', $1c00, $1e00, operand, true);
decodeModifier('BSEL', $1e00, $1e00, operand, true);
decodeModifier('CMPU', $1800, $1e00, operand, true);
decodeModifier('SM1', $0030, $0030, operand, true);
decodeModifier('S0', $0000, $0030, operand, false);
decodeModifier('S1', $0010, $0030, operand, true);
decodeModifier('X2Y', $0040, $0040, operand, true);
decodeModifier('NX2Y', $0000, $0040, operand, false);
decodeModifier('XT', $0080, $0080, operand, true);
aluop := operand and $1e00;
operand := operand and 15;
if (aluop = $1800) or (aluop = $0c00) then
begin
write(' ');
printCmpOperand(operand);
end
else
if operand > 0 then
printSpacedOperand(operand);
end;
procedure decodeLoadrel(offset:integer);
begin
write('LOADREL');
printSpacedOperand(pc + offset);
end;
procedure decodeMem(operand:integer);
begin
if (operand and $0200) <> 0 then
begin
write('STOREI');
decodeModifier('SM1', $0030, $0030, operand, false);
decodeModifier('S0', $0000, $0030, operand, true);
decodeModifier('S1', $0010, $0030, operand, true);
decodeModifier('X2Y', $0040, $0040, operand, true);
decodeModifier('NX2Y', $0000, $0040, operand, false);
decodeModifier('XT', $0080, $0080, operand, true);
end
else
begin
write('LOADI');
decodeModifier('SM1', $0030, $0030, operand, true);
decodeModifier('S0', $0000, $0030, operand, false);
decodeModifier('S1', $0010, $0030, operand, true);
decodeModifier('X2Y', $0040, $0040, operand, true);
decodeModifier('NX2Y', $0000, $0040, operand, false);
decodeModifier('XT', $0080, $0080, operand, true);
end;
operand := operand and 15;
if operand > 0 then
printSpacedOperand(operand);
end;
procedure printRegOperand(operand:integer);
begin
case operand of
0: write('FP');
1: write('BP');
2: write('RP');
3: write('IV');
4: write('IR');
5: write('ESP');
else write('<unknown:',operand,'>');
end;
end;
procedure decodeReg(operand:integer);
begin
if (operand and $0200) <> 0 then
write('STOREREG ')
else
write('LOADREG ');
operand := operand and 15;
printRegOperand(operand);
end;
procedure decodeExt(operand:integer);
var extop:integer;
begin
extop := (operand and $1C00) shr 10;
if extop = 0 then
decodeReg(operand)
else
if extop = 1 then
decodeMem(operand)
(*
else
if extop = 2 then
begin
{ unused }
end *)
else
if extop = 3 then
begin
write('FPADJ ');
printSignedOperand(operand and $03FF, $200);
end
else
if extop = 5 then
decodeLoadrel(operand and $03FF)
else
write('<EXT unknown:', extop,'>');
end;
procedure decodeInstruction(w:integer);
var baseIns:integer;
baseOperand:integer;
begin
baseIns := (w and $E000) shr 13;
baseOperand := (w and $1FFF);
(* writeln(baseIns, ' ', baseOperand); *)
if baseIns = 0 then
decodeBranch(baseOperand)
else
if baseIns = 1 then
decodeAlu(baseOperand)
else
if baseIns = 2 then
decodeLoadStore('STORE', baseOperand)
else
if baseIns = 3 then
decodeXfer(baseOperand)
else
if baseIns = 4 then
decodeLoadStore('LOAD', baseOperand)
else
if baseIns = 5 then
decodeCbranch(baseOperand)
else
if baseIns = 6 then
decodeLoadc(baseOperand)
else
if baseIns = 7 then
decodeExt(baseOperand)
else
write('???');
pc := pc + 2;
(* write(' (', baseIns, ')');
writeHex(w); *)
printEol;
end;
function isConstantPool(sym:HashRef):boolean;
begin
isConstantPool := false;
if sym <> nil then
begin
if length(sym^.data) >= 4 then
isConstantPool :=
(sym^.data[1] = '_') and
(sym^.data[2] = 'C') and
(sym^.data[3] = 'P') and
(sym^.data[4] = '_');
end;
end;
function isStringConstant(sym:HashRef):boolean;
begin
isStringConstant := false;
if sym <> nil then
begin
if length(sym^.data) >= 5 then
isStringConstant :=
(sym^.data[1] = '_') and
(sym^.data[2] = 'C') and
(sym^.data[3] = '_') and
(sym^.data[4] = 'S') and
(sym^.data[5] = '_');
end;
end;
procedure decodeIntConstant(upperHalf:integer);
var lowerHalf:integer;
w:integer;
begin
{$R-}
pc := pc + 2;
(* need to increment pc in two steps
because readBin uses the pc to detect line endings
(which is probably a bad idea *)
lowerHalf := readInstruction;
w := (upperHalf shl 16) or lowerHalf;
pc := pc + 2;
write('.WORD ');
printOperand(w);
writeln;
{$R+}
end;
procedure printPaddedLabel(sym:HashRef); forward;
procedure printPc; forward;
procedure printLeadin;
begin
printPc;
printPaddedLabel(nil);
end;
procedure decodeString(upperHalf:integer);
var lowerHalf:integer;
curLength,maxLength:integer;
i,wordCount:integer;
w:integer;
begin
pc := pc + 2;
lowerHalf := readInstruction;
pc := pc + 2;
curLength := (upperHalf shl 16) or lowerHalf;
maxLength := readWord;
write('.WORD ');
printHex(curLength);
writeln;
printLeadin;
write('.WORD ');
printHex(maxLength);
writeln;
pc := pc + 4;
wordCount := curLength;
if maxLength > curLength then
wordCount := maxLength;
wordCount := (wordCount + 3) shr 2;
for i := 1 to wordCount do
begin
w := readWord;
printLeadin;
write('.BYTE ');
printAsciiWord(w);
writeln;
pc := pc + 4;
end;
end;
procedure printPaddedLabel(sym:HashRef);
var pad:integer;
begin
pad := 24;
if sym <> nil then
begin
write(sym^.data);
write(':');
pad := pad - length(sym^.data) - 1;
end;
while pad > 0 do
begin
write(' ');
pad := pad - 1;
end;
write(' ');
end;
procedure printPc;
var hexaddr:string[8];
begin
hexstr(pc, hexaddr);
write(hexaddr, ' ');
end;
procedure printLabels(adr:integer);
var bucket:HashBucket;
current:HashRef;
first:boolean;
begin
(* there can be multiple labels
at an instruction address,
so go through all elements
in the corresponding hash bucket *)
first := true;
bucket := getHashBucket(symbolTable, adr);
current := bucket;
while current <> nil do
begin
if current^.key = adr then
begin
if not first then
begin
writeln;
(* printPc; *)
write(' ');
end
else
first := false;
printPaddedLabel(current);
end;
current := current^.next;
end;
if first then
printPaddedLabel(nil);
end;
procedure decodeFile;
var w:integer;
sym:HashRef;
begin
while not eof(infile) do
begin
printPc;
printLabels(pc);
w := readInstruction;
sym := getHashed(symbolTable, pc);
if isConstantPool(sym) then
decodeIntConstant(w)
else
if isStringConstant(sym) then
decodeString(w)
else
decodeInstruction(w);
end;
end;
procedure testHash;
var s:string;
result:HashRef;
i:integer;
begin
s := 'einszweidrei';
putHashed(symbolTable, 123, s);
s := 'vierfuenf';
putHashed(symbolTable, 45, s);
s := 'null';
putHashed(symbolTable, 0, s);
s := '0x7FFF1234';
putHashed(symbolTable, $7FFF1234, s);
result := getHashed(symbolTable, 123);
writeln('getHashed 123:', result^.data);
result := getHashed(symbolTable, 45);
writeln('getHashed 45:', result^.data);
result := getHashed(symbolTable, 0);
writeln('getHashed 0:', result^.data);
result := getHashed(symbolTable, $7FFF1234);
writeln('getHashed $7FFF1234:', result^.data);
for i := 1 to 5000 do
begin
str(i,s);
putHashed(symbolTable,i,s);
end;
end;
procedure readKeyword(var fil:InputFileType; var wordBuf:string);
var c:char;
skipWhite:boolean;
done:boolean;
begin
wordBuf := '';
done := false;
skipWhite := true;
repeat
read(fil,c);
if c in [ ' ', #9, #13, #10, #0 ] then
begin
if not skipWhite then
done := true;
end
else
begin
wordBuf := wordBuf + c;
skipWhite := false;
end;
until done or eof(fil);
if c = #13 then (* skip over CR/LF *)
read(fil,c);
end;
procedure readSymbolTable(var filename:string);
var buf:string;
fil:InputFileType;
symStr:string;
num:integer;
begin
openFile(fil, filename);
while not eof(fil) do
begin
readKeyword(fil,buf);
readKeyword(fil,symStr);
num := convertHex(buf);
putHashed(symbolTable, num, symStr);
end;
close(fil);
end;
function parseOrigin(s:string):integer;
var i,c:integer;
begin
val(s,i,c);
if c > 0 then
errorExit2('invalid number',s);
parseOrigin := i;
end;
begin
if paramCount < 1 then halt;
if paramCount >= 2 then
begin
filename := paramStr(2);
readSymbolTable(filename);
end;
if paramCount >= 3 then
pc := parseOrigin(paramStr(3));
filename := paramStr(1);
openFile(infile, filename);
decodeFile;
close(infile);
(* dumpHash(symbolTable); *)
end.

289
pcomp/treeimpl.pas Normal file
View file

@ -0,0 +1,289 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
function makeTreeNode(var d:TreeData;var key:string;nparent:TreeRef):TreeRef;
var newNode:TreeRef;
newKey:^string;
begin
new(newNode);
{ new(newKey,length(key)); }
newString(newKey, length(key));
new(newNode^.data);
newKey^ := key;
with newNode^ do
begin
key := newKey;
parent := nparent;
left := nil;
right := nil;
height := 1;
data^ := d;
end;
makeTreeNode := newNode;
end;
function MeasureTree(root:TreeRef):integer;
var leftHeight, rightHeight:integer;
begin
if root = nil then
MeasureTree := 0
else
begin
if root^.left <> nil then
leftHeight := root^.left^.height
else
leftHeight := 0;
if root^.right <> nil then
rightHeight := root^.right^.height
else
rightHeight := 0;
if rightHeight > leftHeight then
MeasureTree := rightHeight + 1
else
MeasureTree := leftHeight + 1;
end;
end;
function GetTreeBalance(root:TreeRef):integer;
begin
if root = nil then
GetTreeBalance := 0
else
GetTreeBalance := MeasureTree(root^.left) - MeasureTree(root^.right);
end;
function RotateTreeRight(x:TreeRef):TreeRef;
var z,tmp:TreeRef;
begin
(* writeln('RotateTreeRight at ', x^.key^); *)
z := x^.left;
tmp := z^.right;
z^.right := x;
z^.parent := x^.parent;
x^.parent := z;
x^.left := tmp;
if tmp <> nil then
tmp^.parent := x;
x^.height := MeasureTree(x);
z^.height := MeasureTree(z);
RotateTreeRight := z;
end;
function RotateTreeLeft(x:TreeRef):TreeRef;
var z,tmp:TreeRef;
begin
(* writeln('RotateTreeLeft at ', x^.key^); *)
z := x^.right;
tmp := z^.left;
z^.left := x;
z^.parent := x^.parent;
x^.parent := z;
x^.right := tmp;
if tmp <> nil then
tmp^.parent := x;
x^.height := MeasureTree(x);
z^.height := MeasureTree(z);
RotateTreeLeft := z;
end;
function TreeInsert4(root:TreeRef;var key:string;var data:TreeData;
parent:TreeRef):TreeRef;
var balance:integer;
begin
if root = nil then
root := makeTreeNode(data, key, parent)
else
if key < root^.key^ then
root^.left := TreeInsert4(root^.left, key, data, root)
else
root^.right := TreeInsert4(root^.right, key, data, root);
root^.height := MeasureTree(root);
balance := GetTreeBalance(root);
if balance > 1 then
begin
if key < root^.left^.key^ then
root := RotateTreeRight(root)
else
begin
root^.left := RotateTreeLeft(root^.left);
root := RotateTreeRight(root);
end;
end
else
if balance < -1 then
begin
if key > root^.right^.key^ then
root := RotateTreeLeft(root)
else
begin
root^.right := RotateTreeRight(root^.right);
root := RotateTreeLeft(root);
end;
end;
TreeInsert4 := root;
end;
procedure TreeInsert(var root:TreeRef;var key:string;var data:TreeData);
begin
root := TreeInsert4(root,key,data,nil);
end;
procedure DisposeTreeNode(node:TreeRef);
begin
dispose(node^.key);
dispose(node^.data);
dispose(node);
end;
function TreeLeftmost(node:TreeRef):TreeRef;
begin
TreeLeftmost := nil;
if node <> nil then
begin
repeat
TreeLeftmost := node;
node := node^.left;
until node = nil;
end;
end;
function TreeDeleteFn(root:TreeRef;var key:string):TreeRef;
var tmp,oldParent:TreeRef;
balance:integer;
begin
if root <> nil then
begin
if key < root^.key^ then
root^.left := TreeDeleteFn(root^.left, key)
else
if key > root^.key^ then
root^.right := TreeDeleteFn(root^.right, key)
else
begin
if root^.left = nil then
begin
tmp := root;
oldParent := root^.parent;
root := root^.right;
if root <> nil then
root^.parent := oldParent;
DisposeTreeNode(tmp);
end
else
if root^.right = nil then
begin
tmp := root;
oldParent := root^.parent;
root := root^.left;
if root <> nil then
root^.parent := oldParent;
DisposeTreeNode(tmp);
end
else
begin
tmp := TreeLeftmost(root^.right);
root^.key^ := tmp^.key^;
root^.data^ := tmp^.data^;
oldParent := tmp^.parent;
if oldParent^.left = tmp then
oldParent^.left := TreeDeleteFn(oldParent^.left, tmp^.key^)
else
if oldParent^.right = tmp then
oldParent^.right := TreeDeleteFn(oldParent^.right, tmp^.key^)
else
begin
writeln('TreeDelete internal error at', root^.key^);
end;
end;
if root <> nil then
begin
root^.height := MeasureTree(root);
balance := GetTreeBalance(root);
if balance > 1 then
begin
if GetTreeBalance(root^.left) >=0 then
root := RotateTreeRight(root)
else
begin
root^.left := RotateTreeLeft(root^.left);
root := RotateTreeRight(root);
end;
end
else
if balance < -1 then
begin
if GetTreeBalance(root^.right) <= 0 then
root := RotateTreeLeft(root)
else
begin
root^.right := RotateTreeRight(root^.right);
root := RotateTreeLeft(root);
end;
end;
end;
end;
end;
TreeDeleteFn := root;
end;
procedure TreeDelete(var root:TreeRef;var key:string);
begin
root := TreeDeleteFn(root,key);
end;
function TreeSearch(root:TreeRef;var key:string):TreeDataRef;
begin
if root <> nil then
begin
if key = root^.key^ then
TreeSearch := root^.data
else
if key < root^.key^ then
TreeSearch := TreeSearch(root^.left, key)
else
TreeSearch := TreeSearch(root^.right, key);
end
else
TreeSearch := nil;
end;
procedure TreeWalkStart(t:TreeRef; var state:TreeWalkState);
begin
(* start at leftmost node of the tree *)
state.currentNode := TreeLeftmost(t);
end;
procedure TreeWalkNext(var state:TreeWalkState;var res:TreeRef);
var last,current,right:TreeRef;
begin
current := state.currentNode;
res := current;
if current <> nil then
begin
(* descending right *)
if current^.right <> nil then
begin
state.currentNode := TreeLeftmost(current^.right);
end
else (* ascending *)
begin
repeat
last := current;
current := current^.parent;
if current <> nil then
right := current^.right;
until (right <> last) or (current = nil); (* ascend left edges *)
state.currentNode := current;
end;
end;
end;
procedure TreeWalkFirst(t:TreeRef; var state:TreeWalkState; var first:TreeRef);
begin
TreeWalkStart(t, state);
TreeWalkNext(state, first);
end;

26
pcomp/treetypes.pas Normal file
View file

@ -0,0 +1,26 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
{
type TreedataType = (TDString, TDInteger);
type Treedata = record
case typ:Treedatatype of
TDString:(stringdata:string);
TDInteger:(intdata:integer);
end;
}
type StringRef = ^string;
type TreeNode = record
parent: ^TreeNode;
left,right: ^TreeNode;
height: integer;
key: StringRef;
data: ^Treedata;
end;
type TreeRef = ^TreeNode;
TreeDataRef = ^Treedata;
type TreeWalkState = record
currentNode:TreeRef;
end;

52
progs/dumpdir.pas Normal file
View file

@ -0,0 +1,52 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
program dumpdir;
var volname:string;
volid:integer;
(* we use some stuff internal to stdlib.pas *)
procedure getdirslot(volumeid:integer;slotNo:integer;var result:DirectorySlot;var error:integer);
external;
procedure dumpdir(volid:integer);
var dirs:DirectorySlot;
i:integer;
lastSlot:integer;
error:integer;
begin
lastSlot := volumeTable[volid].part.dirSize - 1;
openvolumeid(volid);
for i := 0 to lastSlot do
begin
getdirslot(volid, i, dirs, error);
with dirs do
begin
write('slot ', i, ' ', name, ' ', sizeBytes, ' G', generation);
if SlotFirst in flags then write(' First');
if SlotExtent in flags then write(' Extent');
if SlotReserved in flags then write(' Resvd');
if SlotDeleted in flags then write(' Del');
if SlotFree in flags then write(' Free');
if SlotEndScan in flags then write(' End');
writeln;
if SlotEndScan in flags then break;
end;
end;
closevolumeid(volid);
end;
begin
if ParamCount > 0 then
volname := ParamStr(1)
else
begin
write('Volume name> ');
readln(volname);
end;
volid := findvolume(volname);
if volid < 1 then
writeln('Volume not found.')
else
dumpdir(volid);
end.

2491
progs/editor.pas Normal file

File diff suppressed because it is too large Load diff

742
progs/partmgr.pas Normal file
View file

@ -0,0 +1,742 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
program partmgr;
const MaxPartitions = 32;
LastPartBlock = 7;
PartsPerBlock = 8;
var partTable:array[0..LastPartBlock] of PartitionTableBlock;
changed:array[0..LastPartBlock] of boolean;
detectedCardSize:integer;
cmd:char;
done:boolean;
lastPartNo:integer;
function flags2str(flags:PartFlags):string;
begin
flags2str := '';
if PartEnabled in flags then flags2str := flags2str + 'E ';
if PartBoot in flags then flags2str := flags2str + 'B ';
if PartLast in flags then flags2str := flags2str + 'L ';
if PartPhysical in flags then flags2str := flags2str + 'P ';
if PartDefault in flags then flags2str := flags2str + 'D ';
end;
function str2flags(var s:string):PartFlags;
begin
str2flags := [];
if 'E' in s then str2flags := str2flags + [PartEnabled];
if 'B' in s then str2flags := str2flags + [PartBoot];
if 'L' in s then str2flags := str2flags + [PartLast];
if 'P' in s then str2flags := str2flags + [PartPhysical];
if 'D' in s then str2flags := str2flags + [PartDefault];
end;
function sanitizeName(var name:string):string;
begin
if (length(name) <= 32) and (maxlength(name) = 32) then
sanitizeName := name
else
sanitizeName := '<invalid>';
end;
procedure changeNumber(prompt:string; var num:integer);
var buf:string;
err:integer;
digits:string;
begin
str(num, digits);
buf := prompt + ' [' + digits + ']> ';
write(buf:30);
readln(buf);
val(buf,num,err);
end;
procedure readPartTable;
var done:boolean;
curblk:integer;
error:integer;
devid:integer;
begin
done := false;
curblk := 0;
devid := 0; (* we only support one device *)
while not done do
begin
changed[curBlk] := false;
readPartBlk(curblk, partTable[curblk], error, devid);
if error <> 0 then
begin
done := true;
writeln('Error ', error,
' reading partition block ', curblk);
end
else
curblk := curblk + 1;
if curBlk > LastPartBlock then
done := true;
end;
end;
procedure writePartBlock(no:integer);
var error:integer;
devid:integer;
begin
devid := 0;
writePartBlk(no, partTable[no], error, devid);
if error <> 0 then
writeln('Error ', error,
' reading partition block ', no);
end;
procedure writePartitions;
var blkNo:integer;
begin
for blkNo := 0 to LastPartBlock do
begin
if changed[blkNo] then
begin
writeln('Writing back partition block ',blkNo);
writePartBlock(blkNo);
end;
end;
end;
function getPartition(partNo:integer):Partition;
var blkNo:integer;
begin
blkNo := partNo div PartsPerBlock;
if (blkNo < 0) or (blkNo > LastPartBlock) then
writeln('internal error: invalid part no in getPartition')
else
getPartition := partTable[blkNo][partNo mod PartsPerBlock];
{ writeln('** getPartition: ', blkNo, ' ', partNo mod PartsPerBlock); }
end;
procedure putPartition(var part:Partition; partNo:integer);
var blkNo:integer;
begin
blkNo := partNo div PartsPerBlock;
{ writeln('** putPartition: ', blkNo, ' ', partNo mod PartsPerBlock); }
if (blkNo < 0) or (blkNo > LastPartBlock) then
writeln('internal error: invalid part no in getPartition')
else
begin
partTable[blkNo][partNo mod PartsPerBlock] := part;
changed[blkNo] := true;
end;
end;
function isEmptyPart(var part:Partition):boolean;
begin
isEmptyPart := (part.startBlock = 0) and (part.blocks = 0);
end;
procedure printPartTable;
var blkNo, partNo:integer;
partBlk:PartitionTableBlock;
part:Partition;
totalPartNo:integer;
begin
totalPartNo := 0;
writeln('Partition Table:');
writeln('No. ', 'Flags':11, 'Name':32, 'Start':10, 'Size':10);
for blkNo := 0 to LastPartBlock do
begin
partBlk := partTable[blkNo];
for partNo := 0 to PartsPerBlock - 1 do
begin
part := partBlk[partNo];
if not isEmptyPart(part) then
begin
write(totalPartNo:3, ': ', flags2Str(part.flags):11,
sanitizeName(part.name):32,
part.startBlock:10,
part.blocks:10);
if PartBoot in part.flags then write(' ', part.bootBlocks);
writeln;
lastPartNo := totalPartNo;
end;
totalPartNo := totalPartNo + 1;
end;
end;
writeln('Flags: P=Physical B=Boot E=Enabled L=Last D=Default');
end;
function askPartNo:integer;
var i:integer;
s:string;
begin
askPartNo := -1;
write('Enter partition number (0-', lastPartNo, ')> ');
readln(s);
if length(s) > 0 then
begin
val(s,askPartNo,i);
if i > 0 then
writeln('Invalid partition number');
end;
end;
function askConfirmPartNo:integer;
var partNo:integer;
part:Partition;
answer:char;
begin
askConfirmPartNo := -1;
partNo := askPartNo;
if partNo >= 0 then
begin
part := getPartition(partNo);
write('Any data on partition ', partNo,
' (', sanitizeName(part.name), ') ',
'will be destroyed. Sure [y/n]? ');
readln(answer);
if upcase(answer) = 'Y' then
askConfirmPartNo := partNo;
end;
end;
function guessExtentSize(blocks:integer):integer;
begin
if blocks >= 4194304 then (* 2 GB *)
guessExtentSize := 1048576 (* use 1MB extents *)
else
if blocks >= 1048576 then (* 512 MB *)
guessExtentSize := 524288 (* use 512K extents *)
else
if blocks >= 524288 then (* 256 MB *)
guessExtentSize := 131072
else
if blocks >= 262144 then (* 128 MB *)
guessExtentSize := 65536
else
if blocks >= 32768 then (* 16 MB *)
guessExtentSize := 16384
else
guessExtentSize := 8192;
end;
function getDirSize(extentSize,blocks:integer):integer;
begin
getDirSize := blocks div (extentSize div 512);
end;
procedure createFilesystem(partNo:integer); forward;
procedure addVolume;
var nextFreeBlock:integer;
nextBlock:integer;
extentSize:integer;
size:integer;
i:integer;
part:Partition;
maxBlocks:integer;
freeBlocks:integer;
newPartNo:integer;
newPart:Partition;
begin
part := getPartition(0);
maxBlocks := part.blocks;
nextFreeBlock := 0;
(* read all partitions *)
for i := 1 to lastPartNo do
begin
part := getPartition(i);
nextBlock := part.startBlock + part.blocks;
if nextBlock > nextFreeBlock then
nextFreeBlock := nextBlock;
end;
(* remember last used block *)
writeln('next free partition: ', lastPartNo + 1,
' next free block: ', nextFreeBlock);
freeBlocks := maxBlocks - nextFreeBlock;
if freeBlocks < 1 then
writeln('Cannot add partition - no free blocks after last partition.')
else
begin
newPartNo := lastPartNo + 1;
(* remove last partition flag on previous last partition *)
part.flags := part.flags - [PartLast];
putPartition(part, lastPartNo);
(* create new partition *)
size := freeBlocks;
changeNumber('Size (blocks)', size);
write('Name> ':30);
readln(newPart.name);
newPart.startBlock := nextFreeBlock;
newPart.blocks := size;
newPart.extentSize := guessExtentSize(size);
newPart.dirSize := getDirSize(newPart.extentSize, size);
newPart.bootBlocks := 0;
(* mark new partition as last partition *)
newPart.flags := [ PartEnabled, PartLast ];
putPartition(newPart, newPartNo);
writeln('Partition ', newPartNo, ' created, extent size:', newPart.extentSize,
' directory size: ', newPart.dirSize);
createFilesystem(newPartNo);
lastPartNo := lastPartNo + 1;
end;
end;
procedure renameVolume;
var partNo:integer;
newName:string;
part:Partition;
begin
partNo := askPartNo;
if partNo >= 0 then
begin
part := getPartition(partNo);
writeln('Old partition/volume name: ', sanitizeName(part.name));
write('New partion/volume name: ');
readln(newName);
if length(newName) > 0 then
begin
part.name := newName;
putPartition(part, partNo);
end;
end;
end;
procedure toggleDefaultFlag;
var partNo:integer;
part:Partition;
begin
partNo := askPartNo;
if partNo >= 0 then
begin
part := getPartition(partNo);
write('Default flag ');
if PartDefault in part.flags then
begin
part.flags := part.flags - [PartDefault];
write('cleared');
end
else
begin
part.flags := part.flags + [PartDefault];
write('set');
end;
writeln(' on partition ', partNo, ' (', sanitizeName(part.name), ').');
putPartition(part, partNo);
end;
end;
procedure deleteVolume;
var partNo:integer;
part:Partition;
begin
partNo := askConfirmPartNo;
if partNo >= 0 then
begin
part := getPartition(partNo);
part.flags := [];
part.name := '';
part.startBlock := 0;
part.blocks := 0;
part.extentSize := 0;
part.dirSize := 0;
part.bootBlocks := 0;
putPartition(part, partNo);
writeln('Partition ', partNo, ' deleted.');
(* try to fix last partition flag *)
(* only works if the previous entry has
a valid partition *)
if partNo = lastPartNo then
begin
lastPartNo := lastPartNo - 1;
part := getPartition(lastPartNo);
part.flags := part.flags + [PartLast];
putPartition(part, lastPartNo);
end;
end;
end;
procedure validatePartTable;
var partNo:integer;
phys:Partition;
part,part2:Partition;
answer:char;
p,p2:integer;
valid:boolean;
begin
valid := true;
phys := getPartition(0);
if not (PartPhysical in phys.flags) then
begin
writeln('PHYS partition missing, initialize card first!');
exit;
end;
if phys.blocks <> detectedCardSize then
begin
write('PHYS partition size does not match detected card size, fix? [y/n]');
readln(answer);
if upcase(answer) = 'Y' then
begin
phys.blocks := detectedCardSize;
putPartition(phys,0);
end
else
valid := false;
end;
for p := 1 to lastPartNo do
begin
part := getPartition(p);
if (part.startBlock < 0) or (part.startBlock + part.blocks > phys.blocks) then
begin
writeln('Partition ', p, ' outside of physical bounds.');
valid := false;
end;
if PartEnabled in part.flags then
if part.dirSize <> getDirSize(part.extentSize, part.blocks) then
begin
write('Partition ', p, ' has an invalid directory size (is ');
writeln(part.dirSize, ', should be ',
getDirSize(part.extentSize, part.blocks), ').');
valid := false;
end;
for p2 := 1 to lastPartNo do
begin
part2 := getPartition(p2);
if (p <> p2) then
begin
if ((part.startBlock >= part2.startBlock) and
(part.startBlock < part2.startBlock + part2.blocks)) or
((part2.startBlock > part.startBlock) and
(part2.startBlock < part.startBlock + part.blocks))
then
begin
writeln('Partition ',p ,' overlaps with partition ', p2);
valid := false;
end;
if (part.name = part2.name) and (p > p2) then
begin
writeln('Duplicate volume name ', part.name);
valid := false;
end;
end;
end;
end;
write('Partition table is ');
if not valid then write('in');
writeln('valid.');
end;
procedure checkNewCard; forward;
procedure initializeCard;
var part:Partition;
answer:char;
p:integer;
begin
writeln('Initializing a card will create an empty partition table with');
writeln('the standard PHYS and BOOT partitions.');
write('This will likely destroy any data on the card - sure? [y/n] ');
readln(answer);
if upcase(answer) <> 'Y' then exit;
(* create PHYS partition using detectedcardblocks *)
part.name := 'PHYS';
part.startBlock := 0;
part.blocks := detectedCardSize;
part.flags := [PartPhysical];
part.extentSize := 0;
part.dirSize := 0;
part.bootBlocks := 0;
putPartition(part,0);
(* create BOOT partition without PartBoot flag *)
part.name := 'BOOT';
part.startBlock := 16; (* 16 possible partition blocks with 8 partitions each *)
part.blocks := 8192 - 16; (* align first volume to 4MB *)
part.flags := [PartBoot, PartLast];
putPartition(part,1);
part.name := '';
part.startBlock := 0;
part.blocks := 0;
part.flags := [];
for p := 2 to 7 do
putPartition(part,p);
writeln('Empty partition table created.');
end;
procedure createFilesystem(partNo:integer);
var firstDirBlock:integer;
slot:DirectorySlot;
dirblk:DirBlock;
dirblockCount:integer;
metaSlotsCount:integer;
dirSlotsPerBlock:integer;
dirSlotsPerExtent:integer;
part:Partition;
ts:Timestamp;
i,b:integer;
error,devid:integer;
begin
devid := 0;
ts := 0;
part := getPartition(partNo);
firstDirBlock := part.startBlock;
dirSlotsPerBlock := 512 div 64;
dirSlotsPerExtent := part.extentSize div 64;
dirblockCount := (part.dirSize - 1) div dirSlotsPerBlock + 1;
metaSlotsCount := (part.dirSize - 1) div dirSlotsPerExtent + 1;
writeln('partition size: ', part.blocks);
writeln('extent size: ', part.extentSize);
writeln('directory size: ', part.dirSize);
{ writeln('dirslots per extent:', dirSlotsPerExtent);
writeln('dirblocks: ', dirblockCount);
writeln('metaslots: ', metaSlotsCount);
writeln('first dir block: ', firstDirBlock);
}
for b := firstDirBlock to firstDirBlock + dirblockCount - 1 do
begin
for i := 0 to dirSlotsPerBlock - 1 do
begin
if metaSlotsCount > 0 then
begin
(* write DIR/Reserved directory slots *)
slot.name := 'DIR';
slot.flags := [ SlotReserved ];
metaSlotsCount := metaSlotsCount - 1;
end
else
begin
(* write Free + EndScan directory slots *)
slot.name := '';
slot.flags := [ SlotFree , SlotEndScan ];
end;
slot.sizeBytes := 0;
slot.createTime := ts;
slot.modTime := ts;
slot.generation := 0;
slot.owner := 0;
dirBlk[i] := slot;
end;
writedirblk(b, dirBlk, error, devid);
if error > 0 then
writeln('error writing block ', b, ': ', error);
end;
writeln('Volume ', part.name, ' initialized.');
end;
procedure initializeVolume;
var partNo:integer;
part:Partition;
begin
partNo := askConfirmPartNo;
if partNo >= 0 then
begin
part := getPartition(partNo);
if not (PartEnabled in part.flags) then
writeln('Wrong partition flags (must be Enabled)')
else
createFilesystem(partNo);
end;
end;
procedure rawEdit;
var partNo:integer;
newName:string;
part:Partition;
buf:string;
begin
writeln('Raw editing partition entry - use caution!');
partNo := askPartNo;
if partNo >= 0 then
begin
part := getPartition(partNo);
writeln('Volume name: ', sanitizeName(part.name));
write('Flags> ':30);
readln(buf);
if length(buf) > 0 then
part.flags := str2flags(buf);
changeNumber('Start block', part.startBlock);
changeNumber('Size (blocks)', part.blocks);
changeNumber('Extent size (blocks)', part.extentSize);
changeNumber('Dir size (slots)', part.dirSize);
changeNumber('Boot blocks', part.bootBlocks);
putPartition(part, partNo);
end;
end;
procedure installBoot;
var bootfile:file;
name:string;
part:Partition;
partNo:integer;
buf:IOBlock;
b,blkCount:integer;
devId:integer;
error:integer;
procedure readWordsIntoBuf;
var i:integer;
w:integer;
c1,c2,c3,c4:char;
begin
for i := 0 to 127 do
begin
if not eof(bootfile) then
begin
read(bootfile, c1, c2, c3, c4);
w := (ord(c1) shl 24) or
(ord(c2) shl 16) or
(ord(c3) shl 8) or
ord(c4);
end
else
w := 0;
buf[i] := w;
end;
end;
begin
devId := 0; (* only one device supported *)
partNo := 1; (* BOOT partition is always at position 1 *)
part := getPartition(partNo);
if part.name <> 'BOOT' then
begin
writeln('No BOOT partition at position 1.');
exit;
end;
write('Boot file name> ');
readln(name);
if length(name) > 0 then
begin
open(bootfile, name, ModeReadonly);
if IOResult(bootfile) <> 0 then
writeln('Error opening file: ', ErrorStr(IOResult(bootfile)))
else
begin
blkCount := filesize(bootfile) div 512 + 1;
if blkCount > part.blocks then
writeln('Boot partition too small, need ', blkCount)
else
begin
part.bootBlocks := blkCount;
if not (PartBoot in part.flags) then
begin
write('Boot flag set');
writeln(' on partition ', partNo,
' (', sanitizeName(part.name), ').');
part.flags := part.flags + [PartBoot];
end;
putPartition(part, partNo);
for b := 0 to blkCount - 1 do
begin
readWordsIntoBuf;
writeblock(part.startBlock + b, buf, error, devId);
if error <> 0 then
writeln('Error in writeblock ', b, ': ', error);
end;
writeln(blkCount, ' boot blocks written.');
end;
close(bootfile);
end;
end;
end;
procedure showMenu;
begin
writeln;
writeln('L)ist partitions V)alidate partition table T)oggle default volume flag');
writeln('A)dd volume R)ename volume D)elete volume I)nitialize volume');
writeln('Read N)ew card Initialize C)ard');
writeln('E)dit partition Install B)oot file eX)it');
write('> ');
end;
procedure invalidCommand;
begin
writeln('Invalid command.');
end;
procedure command(cmd:char; var done:boolean);
begin
case cmd of
'L': printPartTable;
'A': addVolume;
'R': renameVolume;
'D': deleteVolume;
'V': validatePartTable;
'T': toggleDefaultFlag;
'I': initializeVolume;
'N': checkNewCard;
'C': initializeCard;
'B': installBoot;
'E': rawEdit;
'X',#24: done := true;
else invalidCommand;
end;
end;
function changesPending:boolean;
var i:integer;
begin
changesPending := false;
for i := 0 to LastPartBlock do
if changed[i] then changesPending := true;
end;
procedure checkNewCard;
begin
if changesPending then
writeln('WARNING: Discarding partition table changes.');
initDevices;
detectedCardSize := cardsize;
writeln('Detected card size: ', detectedCardSize);
readPartTable;
printPartTable;
end;
begin
checkNewCard;
repeat
showMenu;
read(cmd);
writeln;
command(Upcase(cmd), done);
until done;
writePartitions;
end.

221
progs/reclaim.pas Normal file
View file

@ -0,0 +1,221 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
program reclaim;
var volname:string;
ch:char;
count:integer;
(* we use some stuff internal to stdlib.pas *)
procedure getdirslot(volumeid:integer;slotNo:integer;var result:DirectorySlot;var error:integer);
external;
procedure putdirslot(volumeid:integer;slotNo:integer;var dirslot:DirectorySlot;var error:integer);
external;
procedure scanVolume(volname:string;dryrun:boolean;verbose:boolean;var reclaimCount:integer);
var volid:integer;
i:integer;
error:integer;
dirslot:DirectorySlot;
done:boolean;
fileCount, deletedCount:integer;
freeCount:integer;
fileSlotCount:integer;
reservedCount:integer;
freeAreaCount:integer;
inFreeArea:boolean;
endSlot:integer;
lastUsed:integer;
deletedExtent:boolean;
procedure clearDirSlot;
begin
reclaimCount := reclaimCount + 1;
if not dryrun then
begin
dirslot.name := '';
dirslot.flags := [SlotFree];
dirslot.sizeBytes := 0;
dirslot.createTime := 0;
dirslot.modTime := 0;
dirslot.generation := 0;
putdirslot(volid, i, dirslot, error);
if error <> IONoError then
begin
write('Error writing directory slot ',i);
writeln(': ', ErrorStr(error));
done := true;
end;
end;
end;
procedure markLastSlot;
var slotNo:integer;
begin
(* we actually mark the slot after the last used slot *)
if not dryrun then
begin
if lastUsed < endSlot then
begin
writeln('Updating directory...');
slotNo := lastUsed + 1;
getdirslot(volid, slotNo, dirslot, error);
if error <> IONoError then
begin
write('Error reading directory slot ', slotNo);
writeln(': ', ErrorStr(error));
end;
if not (SlotEndScan in dirslot.flags) then
dirslot.flags := dirslot.flags + [SlotEndScan];
putdirslot(volid, slotNo, dirslot, error);
if error <> IONoError then
begin
write('Error writing directory slot ', lastUsed);
writeln(': ', ErrorStr(error));
end;
end;
end;
end;
procedure beginFreeArea;
begin
freeCount := freeCount + 1;
if not inFreeArea then
begin
inFreeArea := true;
freeAreaCount := freeAreaCount + 1;
end;
end;
procedure endFreeArea;
begin
if inFreeArea then
inFreeArea := false;
end;
begin
volid := findvolume(volname);
if volid < 1 then
writeln('Volume ', volname, ' not found.')
else
begin
done := false;
deletedExtent := false;
inFreeArea := false;
fileCount := 0;
deletedCount := 0;
reclaimCount := 0;
freeCount := 0;
reservedCount := 0;
fileSlotCount := 0;
freeAreaCount := 0;
lastUsed := 0;
openvolumeid(volid);
i := volumeTable[volid].startSlot;
endSlot := volumeTable[volid].part.dirSize - 1;
if verbose then
begin
write('Volume ', volname);
write(' start slot:', i);
write(' dir size: ', endSlot + 1);
writeln(' extent size: ', volumeTable[volid].part.extentSize);
end;
writeln('Reading directory...');
repeat
getdirslot(volid, i, dirslot, error);
if error <> IONoError then
begin
write('Error reading directory slot ',i);
writeln(': ', ErrorStr(error));
done := true;
end
else
begin
if SlotEndScan in dirslot.flags then
done := true;
if SlotFirst in dirslot.flags then
begin
lastUsed := i;
fileCount := fileCount + 1;
deletedExtent := false;
endFreeArea;
end
else
if SlotDeleted in dirslot.flags then
begin
deletedCount := deletedCount + 1;
deletedExtent := true;
clearDirSlot;
(* we consider a deleted file
as a free area here *)
if not dryrun then
beginFreeArea;
end
else
if SlotExtent in dirslot.flags then
begin
if deletedExtent then
clearDirSlot
else
lastUsed := i;
end
else
if SlotReserved in dirslot.flags then
reservedCount := reservedCount + 1
else
if SlotFree in dirslot.flags then
beginFreeArea;
end;
if i = endSlot then
done := true;
i := i + 1;
until done;
markLastSlot;
closevolumeid(volid);
i := i - 1;
if verbose then
begin
writeln('last used slot: ', lastUsed);
writeln('max slots: ', endSlot + 1);
writeln('free slots: ', endSlot - i + freeCount);
writeln('reserved slots: ', reservedCount);
writeln;
end;
write(fileCount, ' files, ', deletedCount, ' deleted files, ');
write(reclaimCount);
if dryrun then
writeln(' reclaimable slots, ', freeAreaCount, ' free regions.')
else
writeln(' reclaimed slots, ', freeAreaCount, ' free regions.');
end;
end;
begin
if ParamCount > 0 then
volname := ParamStr(1)
else
begin
write('Volume name> ');
readln(volname);
end;
initDevices;
scanVolume(volname, true, true, count);
if count > 0 then
begin
write('Proceed with reclaim (y/n)? ');
read(ch);
writeln;
if upcase(ch) = 'Y' then
scanVolume(volname, false, false, count);
end;
end.

481
progs/shell.pas Normal file
View file

@ -0,0 +1,481 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
program shell;
const EDITORPROG = '#SYSTEM:editor.prog';
COMPILERPROG = '#SYSTEM:pcomp.prog';
ASMPROG = '#SYSTEM:sasm.prog';
RECLAIMPROG = '#SYSTEM:reclaim.prog';
const PageMargin = 3;
MenuHeight = 6;
var cmd:char;
ShellWorkfile:pathnamestr external;
ShellCmd:string[40] external;
ShellArg:integer external;
procedure checkClock;
var line:string;
digits:string[4];
error:integer;
yy,mm,dd,h,m,s:integer;
isValid:boolean;
function lineIsValid:boolean;
var c:char;
begin
lineIsValid := false;
if length(line) = 14 then
begin
for c in line do
if not isDigit(c) then
break;
lineIsValid := true;
end;
end;
function isInRange(v,lo,hi:integer):boolean;
begin
isInRange := (v>=lo) and (v<=hi);
end;
begin
if SysClock.year = 0 then
begin
writeln('System clock not set - please enter date and time:');
repeat
isValid := false;
write('YYYYMMDDHHMMSS> ');
readln(line);
if lineIsValid then
begin
isValid := true;
digits := copy(line,1,4);
val(digits, yy, error);
isValid := isValid and isInRange(yy, 1950, 3000);
digits := copy(line,5,2);
val(digits, mm, error);
isValid := isValid and isInRange(mm, 1, 12);
digits := copy(line,7,2);
val(digits, dd, error);
isValid := isValid and isInRange(dd, 1, 31);
digits := copy(line,9,2);
val(digits, h, error);
isValid := isValid and isInRange(h, 0, 23);
digits := copy(line,11,2);
val(digits, m, error);
isValid := isValid and isInRange(m, 0, 59);
digits := copy(line,13,2);
val(digits, s, error);
isValid := isValid and isInRange(s, 0, 59);
end;
until isValid;
SysClock.year := yy;
SysClock.month := mm;
SysClock.day := dd;
SysClock.hours := h;
SysClock.minutes := m;
SysClock.seconds := s;
writeln('System clock is ', DateStr(SysClock), ' ', TimeStr(SysClock, true));
end;
end;
procedure writew(s:string;width:integer);
var w,i:integer;
begin
write(s);
w := width - length(s);
if w > 0 then
for i := 1 to w do
write(' ');
end;
procedure splitFilename(var n:filenamestr;
var basename:filenamestr;var extension:filenamestr);
var i:integer;
begin
for i := length(n) downto 1 do
begin
if n[i] = '.' then
break;
end;
if i > 1 then
begin
basename := copy(n, 1, i - 1);
extension := copy(n, i, length(n) - i + 1);
{ writeln('** splitFilename ',basename, ' ', extension); }
end
else
begin
basename := n;
extension := '';
end;
end;
function replaceExtension(var n:pathnamestr; newExt:filenamestr):pathnamestr;
var basename:filenamestr;
ext:filenamestr;
begin
splitFilename(n, basename, ext);
replaceExtension := basename + newExt;
end;
procedure waitForKey; forward;
procedure listDirectory;
var volid:integer;
error:integer;
index:integer;
dirs:DirectorySlot;
ftime:DateTime;
screenW,screenH:integer;
count:integer;
begin
GetTermSize(screenW, screenH);
volid := findvolume(DefaultVolume);
if volid < 1 then
writeln('Volume ', DefaultVolume, ' not found.')
else
begin
count := PageMargin;
writeln('reading directory of ', DefaultVolume);
openvolumeid(volid);
readdirfirst(volid, index, dirs, error);
while index > 0 do
begin
if dirs.modTime = 0 then
begin
ftime.year := 1970;
ftime.month := 1;
ftime.day := 1;
ftime.hours := 0;
ftime.minutes := 0;
ftime.seconds := 0;
end
else
ftime := GetDateTime(dirs.modTime);
writew(dirs.name, 34);
writew(DateStr(ftime) + ' ' + TimeStr(ftime,false), 22);
writeln(dirs.sizeBytes:12, ' ', dirs.generation);
count := count + 1;
if count >= screenH then
begin
count := PageMargin;
waitForKey;
end;
readdirnext(volid, index, dirs, error);
end;
closevolumeid(volid);
if count + MenuHeight >= screenH then
waitForKey;
end;
end;
function volumeExists(var n:volumenamestr):boolean;
var volid:integer;
begin
volid := findvolume(n);
if volid < 1 then
volumeExists := false
else
begin
closevolumeid(volid);
volumeExists := true;
end;
end;
procedure listVolumes;
var i:integer;
begin
InitDevices;
writeln('Available volumes:');
for i := 1 to VolumeCount do
writeln(VolumeTable[i].part.name);
end;
procedure changeVolume;
var n:volumenamestr;
begin
listVolumes;
write('Enter volume name: ');
readln(n);
if length(n) > 0 then
if volumeExists(n) then
SetDefaultVolume(n)
else
writeln('Volume ', n , ' not found.');
end;
procedure removeFile;
var n:filenamestr;
error:integer;
begin
write('File to delete: ');
readln(n);
if length(n) > 0 then
begin
erase(n, error);
if error <> 0 then
writeln('Error deleting ', n, ': ', ErrorStr(error));
end;
end;
procedure renameFile;
var n1,n2:filenamestr;
error:integer;
begin
write('File to rename: ');
readln(n1);
write('New name: ');
readln(n2);
rename(n1, n2, error);
if error <> 0 then
writeln('Error renaming ', n1, ': ', ErrorStr(error));
end;
procedure copyFile;
var n1,n2:filenamestr;
error:integer;
src,dst:file;
ch:char;
count:integer;
begin
write('File to copy: ');
readln(n1);
write('New file name: ');
readln(n2);
open(src, n1, ModeReadonly);
if IOResult(src) <> 0 then
begin
writeln('Error opening ', n1, ': ', ErrorStr(IOResult(src)));
exit;
end;
open(dst, n2, ModeCreate);
if IOResult(dst) <> 0 then
begin
writeln('Error opening ', n2, ': ', ErrorStr(IOResult(dst)));
close(src);
exit;
end;
write('Copying ',n1, ' to ', n2, '...');
count := 0;
while not eof(src) do
begin
read(src,ch); (* not efficient but keep it simple *)
write(dst,ch);
count := count + 1;
if (count and 8191) = 0 then write('.');
end;
close(dst);
close(src);
writeln;
end;
procedure setWorkfile;
var n:filenamestr;
begin
write('Enter workfile name: ');
readln(n);
ShellWorkfile := n;
ShellCmd := '';
ShellArg := 0;
end;
procedure requireWorkfile;
begin
while length(ShellWorkFile) = 0 do
setWorkfile;
end;
procedure edit(gotoLine:integer);
var error:integer;
digits:string[10];
args:PArgVec;
begin
requireWorkfile;
if gotoLine > 0 then
begin
str(gotoLine,digits);
args[0] := '-l';
args[1] := digits;
args[2] := ShellWorkFile;
PExec(EDITORPROG, args, 3, error);
end
else
PExec2(EDITORPROG, ShellWorkFile, error);
writeln('PExec error ', error);
end;
procedure assemble;
var filename:filenamestr;
error:integer;
begin
requireWorkfile;
filename := replaceExtension(ShellWorkFile, '.s');
PExec2(ASMPROG, filename, error);
writeln('PExec error ', error);
end;
procedure compile;
var filename:filenamestr;
error:integer;
begin
requireWorkfile;
filename := replaceExtension(ShellWorkFile, '.pas');
PExec3(COMPILERPROG, '-S', filename, error);
writeln('PExec error ', error);
end;
procedure build;
var filename:filenamestr;
error:integer;
begin
requireWorkfile;
filename := replaceExtension(ShellWorkFile, '.pas');
PExec2(COMPILERPROG, filename, error);
writeln('PExec error ', error);
end;
procedure run;
var args:PArgVec;
error:integer;
prgname:pathnamestr;
begin
requireWorkfile;
prgname := replaceExtension(ShellWorkfile, '.prog');
writeln('Running ', prgname);
PExec(prgname, args, 0, error);
writeln('Pexec failed, error ', error);
end;
procedure krunch;
var error:integer;
begin
PExec2(RECLAIMPROG, DefaultVolume, error);
writeln('PExec error ', error);
end;
procedure runProgram;
var args:PArgVec;
argCount:integer;
error:integer;
prgname:pathnamestr;
a:string;
begin
write('Enter program file name: ');
readln(prgname);
if length(prgname) > 0 then
begin
if pos('.', prgname) = 0 then prgname := prgname + '.prog';
writeln('Enter program arguments line-by-line, empty line to finish.');
(* entering the arguments line by line is ugly, but it saves us from
the hassle of dealing with word boundary detection and quoting *)
argCount := 0;
repeat
write('arg ', argCount + 1, ': ');
readln(a);
if length(a) > 0 then
begin
args[argCount] := a;
argCount := argCount + 1;
end;
until (length(a) = 0) or (argCount > PArgMax);
writeln('Running ', prgname);
PExec(prgname, args, argCount, error);
writeln('Pexec failed, error ', error);
end;
end;
procedure showMenu;
begin
writeln;
writeln('W)orkfile: ', ShellWorkfile);
writeln('V)olume: ', DefaultVolume);
writeln('L)ist directory K)runch volume O)ther program');
writeln('D)elete file RenaM)e file coP)y file');
writeln('E)dit C)ompile A)ssemble B)uild R)un');
write('> ');
end;
procedure command(cmd:char;arg:integer);
begin
case cmd of
'L': listDirectory;
'V': changeVolume;
'W': setWorkfile;
'R': run;
'A': assemble;
'C': compile;
'B': build;
'E': edit(arg);
'D': removeFile;
'M': renameFile;
'P': copyFile;
'K': krunch;
'O': runProgram;
else ;
end;
end;
procedure waitForKey;
var c:char;
begin
writeln;
writeln('-- press any key to continue --');
c := conin;
end;
begin
if length(DefaultVolume) = 0 then
SetDefaultVolume('SYSTEM');
checkClock;
if length(ShellCmd) > 0 then
begin
if ShellCmd[1] = 'W' then
begin
waitForKey;
delete(Shellcmd,1,1);
end;
if length(ShellCmd) > 0 then
command(ShellCmd[1], ShellArg);
ShellCmd := '';
end;
while true do
begin
showMenu;
read(cmd);
writeln;
command(Upcase(cmd), ShellArg);
end;
end.

431
progs/xfer.pas Normal file
View file

@ -0,0 +1,431 @@
(* Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details *)
program xfer;
const CksumPattern = $AFFECAFE;
SOH = #1;
STX = #2;
EOT = #4;
ENQ = #5;
ACK = #6;
BEL = #7;
NAK = #21;
TimeoutTicks = 200;
var blockNo:integer;
buf:^string;
invalid:boolean;
cmd:char;
filename:string;
size:integer;
done:boolean;
xferFile:file;
function calcChksum(last,this:integer):integer;
begin
calcChksum := ((last + this) xor CksumPattern) shl 1;
end;
function readword:integer;
var b3,b2,b1,b0:char;
begin
b3 := conin;
b2 := conin;
b1 := conin;
b0 := conin;
readword := (ord(b3) shl 24) or
(ord(b2) shl 16) or
(ord(b1) shl 8) or
ord(b0);
end;
procedure serReadBlock(var success:boolean);
var w0,w1,w2,w3,w4,w5,w6,w7,w8:integer;
chksum:integer;
s:integer;
procedure writeByte(b:char);
begin
if size <> 0 then
begin
write(xferFile,b);
size := size - 1;
end;
end;
procedure appendWordToFile(w:integer);
var b3,b2,b1,b0:char;
begin
b0 := chr(w and 255);
w := w shr 8;
b1 := chr(w and 255);
w := w shr 8;
b2 := chr(w and 255);
w := w shr 8;
b3 := chr(w);
writeByte(b3);
writeByte(b2);
writeByte(b1);
writeByte(b0);
end;
procedure calcChksum(d:integer);
begin
chksum := ((chksum + d) xor CksumPattern) shl 1;
end;
begin
chksum := 0;
w0 := readword;
w1 := readword;
w2 := readword;
w3 := readword;
w4 := readword;
w5 := readword;
w6 := readword;
w7 := readword;
s := readword;
calcChksum(w0);
calcChksum(w1);
calcChksum(w2);
calcChksum(w3);
calcChksum(w4);
calcChksum(w5);
calcChksum(w6);
calcChksum(w7);
if s <> chksum then
begin
success := false;
write(NAK);
{ writeln('invalid chksum ', s, ' ', chksum); }
end
else
begin
success := true;
appendWordToFile(w0);
appendWordToFile(w1);
appendWordToFile(w2);
appendWordToFile(w3);
appendWordToFile(w4);
appendWordToFile(w5);
appendWordToFile(w6);
appendWordToFile(w7);
blockNo := blockNo + 1;
write(ACK);
end;
end;
procedure waitForByte(var byteReceived:char; var timeoutReached:boolean);
var ticks:integer;
done:boolean;
begin
timeoutReached := true;
ticks := getticks;
done := false;
repeat
if conavail then
begin
done := true;
timeoutReached := false;
byteReceived := conin;
end;
until done or (getticks > ticks + TimeoutTicks);
end;
procedure waitForHeader(var invalid:boolean);
var done:boolean;
timedOut:boolean;
ch:char;
begin
waitForByte(ch, timedOut);
invalid := (ch <> STX) or timedOut;
end;
procedure receiveHeader(var invalid:boolean);
var ch:char;
timedOut:boolean;
w:integer;
cksum:integer;
begin
{ send protocol version, then wait for size header }
write('1');
waitForByte(ch, timedOut);
if timedOut or (ch <> SOH) then
begin
invalid := true;
exit;
end;
cksum := 0;
w := readword;
cksum := readword;
if w <> (not cksum) then
begin
write(NAK);
w := 0;
writeln('h chksum error');
end
else
write(ACK);
if w > 0 then
begin
size := w;
waitForHeader(invalid);
end
else
invalid := true;
end;
procedure receiveFile;
var ch:char;
invalid, timedOut:boolean;
ok:boolean;
done:boolean;
errorCount:integer;
begin
if length(filename) = 0 then
begin
writeln('Filename not set.');
exit;
end;
errorCount := 0;
waitForByte(ch, timedOut);
if timedOut then
begin
writeln('Timeout waiting for transmission start (ENQ or STX).');
exit;
end;
if ch = ENQ then
receiveHeader(invalid)
else
if ch = STX then
begin
size := -1;
invalid := false;
end
else
invalid := true;
if not invalid then
begin
open(xferFile, filename, ModeOverwrite);
done := false;
repeat
serReadBlock(ok);
if not ok then errorCount := errorCount + 1;
waitForByte(ch, timedOut);
if timedOut then
writeln('Timeout waiting for next block (STX)');
if ch = EOT then
done := true
else
if ch <> STX then
begin
writeln('Invalid header byte (expected STX)');
done := true;
end;
until done or timedOut;
close(xferFile);
writeln(blockNo, ' blocks received, ', errorCount, ' checksum errors. ', ord(ch));
end
else
writeln('Invalid or no header received.', size);
end;
function getWordFromFile:integer;
function getCharFromFile:integer;
var c:char;
begin
if size > 0 then
begin
read(xferFile,c);
size := size - 1;
end
else
c := #0;
getCharFromFile := ord(c);
end;
begin
getWordFromFile := getCharFromFile shl 8;
getWordFromFile := (getWordFromFile or getCharFromFile) shl 8;
getWordFromFile := (getWordFromFile or getCharFromFile) shl 8;
getWordFromFile := (getWordFromFile or getCharFromFile);
end;
procedure sendword(w:integer);
var b3,b2,b1,b0:char;
begin
b0 := chr(w and 255);
w := w shr 8;
b1 := chr(w and 255);
w := w shr 8;
b2 := chr(w and 255);
w := w shr 8;
b3 := chr(w and 255);
write(b3,b2,b1,b0);
end;
procedure sendFile;
var ch:char;
w,cksum:integer;
wordCount:integer;
lastSize,lastPos:integer;
timedOut:boolean;
done:boolean;
begin
if length(filename) = 0 then
begin
writeln('Filename not set.');
exit;
end;
{ wait for start byte }
ch := conin;
if ch <> BEL then
begin
writeln('Invalid start character received.');
exit;
end;
open(xferFile, filename, ModeReadonly);
if IOResult(xferFile) <> 0 then
begin
writeln('Error opening file: ', ErrorStr(IOResult(xferFile)));
exit;
end;
size := filesize(xferFile);
done := false;
{ send size header: SOH, size word, inverted size word }
write(SOH);
sendword(size);
sendword(not size);
{ check for ACK }
waitForByte(ch, timedOut);
if timedOut then
writeln('Timeout sending size header ')
else
if ch <> ACK then
writeln('Error sending size header ', ord(ch))
else
repeat
lastPos := filepos(xferFile);
lastSize := size;
write(STX);
{ send a block: STX, 8 words, checksum word }
cksum := 0;
for wordCount := 1 to 8 do
begin
w := getWordFromFile;
cksum := calcChkSum(cksum, w);
sendword(w);
end;
sendword(cksum);
{ check for ACK/NAK }
waitForByte(ch, timedOut);
if timedOut then
begin
writeln('Timeout waiting for ACK');
done := true;
end
else
if ch = NAK then
begin
seek(xferFile, lastPos);
size := lastSize;
end
else
if ch = ACK then
begin
if size = 0 then done := true;
end
else
begin
writeln('Invalid reply after sending block');
done := true;
end;
until done;
write(EOT);
close(xferFile);
end;
procedure setFilename;
begin
write('Filename> ');
readln(filename);
end;
procedure listDirectory;
var volid:integer;
error:integer;
index:integer;
dirs:DirectorySlot;
begin
volid := findvolume(DefaultVolume);
if volid < 1 then
writeln('Volume ', DefaultVolume, ' not found.')
else
begin
openvolumeid(volid);
readdirfirst(volid, index, dirs, error);
while (index > 0) and (error = 0) do
begin
writeln(dirs.name);
readdirnext(volid, index, dirs, error);
end;
end;
writeln;
end;
begin
writeln('L) upload (receive) D) download (send).');
writeln('S) set filename Y) directory X) exit');
done := false;
repeat
write('> ');
read(cmd);
writeln;
case upcase(cmd) of
'L': receiveFile;
'D': sendFile;
'S': setFilename;
'X': done := true;
'Y': listDirectory;
else writeln('?');
end;
until done;
end.

8
tests/cchangetest.pas Normal file
View file

@ -0,0 +1,8 @@
program cchangetest;
var c:char;
begin
repeat
writeln('cardchanged: ', cardchanged);
read(c);
until c = #27;
end.

12
tests/readchartest.pas Normal file
View file

@ -0,0 +1,12 @@
program readchartest;
var c:char;
kbd:file;
begin
open(kbd, '%KBD', ModeReadonly);
while true do
begin
read(kbd, c);
writeln(ord(c));
end;
close(kbd);
end.

25
tests/readtest.pas Normal file
View file

@ -0,0 +1,25 @@
program readtest;
var filename:string;
buf:char;
f:file;
count:integer;
t:DateTime;
begin
write('Enter filename: ');
readln(filename);
t := GetTime;
writeln('start:', TimeStr(t, true));
open(f, filename, ModeReadOnly);
count := 0;
while not eof(f) do
begin
read(f,buf);
count := count + 1;
end;
close(f);
t := GetTime;
writeln('end:', TimeStr(t, true));
writeln(count, ' bytes read.');
end.

111
tests/test109.pas Normal file
View file

@ -0,0 +1,111 @@
program test109;
const screenwidth = 640;
screenheight = 400;
screenmidx = 319;
screenmidy = 199;
xrange = 14.0;
yrange = 3.0;
xmin = -7.0;
xmax = 7.0;
ymin = -1.5;
ymax = 1.5;
xstep = 0.005;
var scalex,scaley: real;
value:real;
curx:real;
testcounter:integer;
function screenx(x:real):integer;
begin
screenx := trunc((x + xmax) * scalex);
{ writeln(x, ' -x-> ', screenx);}
end;
function screeny(y:real):integer;
begin
screeny := trunc((ymax - y) * scaley);
{ writeln(y, ' -y-> ', screeny); }
end;
procedure drawCoords;
begin
drawline(screenx(xmin), screeny(0), screenx(xmax), screeny(0), 8);
drawline(screenx(0), screeny(ymin), screenx(0), screeny(ymax), 8);
end;
procedure plot(x,y:real;nr:integer);
begin
if (x>=xmin) and (x<=xmax)
and (y>=ymin) and (y<=ymax) then
putpixel( screenx(x), screeny(y), 3 + nr);
end;
procedure test(x:real; delta:real);
begin
writeln('-----------test-----------------');
end;
function squareroot(x:real):real;
begin
if x = 0.0 then
squareroot := 0.0
else
squareroot := sqrt(x);
end;
function logn(x:real):real;
begin
if x <= 0.0 then
logn := 0.0
else
logn := ln(x);
end;
function dafunc(x:real;nr:integer):real;
begin
{
testcounter := testcounter + 1;
if testcounter = 20 then
test(x, xstep); }
{ writeln('dafunc ', testcounter, ' x:', x, ' + 0.1:', x + 0.1); }
case nr of
0: dafunc := sin(x);
1: dafunc := cos(x);
2: dafunc := arctan(x);
3: dafunc := tan(x);
4: dafunc := cotan(x);
5: dafunc := logn(x);
end;
end;
procedure graph(nr:integer);
begin
curx := xmin;
{ curx := 0.0; }
while curx < xmax do
begin
value := dafunc(curx, nr);
plot(curx, value, nr);
curx := curx + xstep;
end;
end;
begin
initgraphics;
scalex := screenwidth / xrange;
scaley := screenheight / yrange;
drawCoords;
graph(0);
graph(1);
graph(2);
graph(3);
graph(4);
graph(5);
end.

17
tests/test133.pas Normal file
View file

@ -0,0 +1,17 @@
program test133;
var f:file;
buf:string;
begin
open(f, 'newfile.text', ModeOverwrite);
writeln(f,'This is a test file created by a Pascal program.');
writeln(f,'There is nothing else of interest here.');
close(f);
open(f, 'newfile.text', ModeReadonly);
while not eof(f) do
begin
readln(f,buf);
writeln(buf);
end;
close(f);
end.

28
tests/test159.pas Normal file
View file

@ -0,0 +1,28 @@
program test159;
var s:string[131072];
i:integer;
c:char;
buf:string;
begin
writeln('creating test string...');
c := 'A';
for i := 1 to maxlength(s) do
begin
appendchar(s,c);
c := succ(c);
if c = 'z' then
c := 'A';
end;
writeln('string length: ', length(s));
writeln(s[1], s[2], s[3]);
writeln('moving stuff...');
repeat
write('>');
readln(buf);
strmoveup(s, 1,100000,1);
writeln(s[1], s[2], s[3]);
until buf = 'x';
end.

12
tests/timetest.pas Normal file
View file

@ -0,0 +1,12 @@
program timetest;
var time:DateTime;
begin
while true do
begin
writeln('ticks: ', GetTicks);
time := GetTime;
writeln('h:', time.hours, ' m:', time.minutes, ' s:', time.seconds);
writeln(DateStr(time), ' ', TimeStr(time,true));
readln;
end;
end.

479
tests/tree.pas Normal file
View file

@ -0,0 +1,479 @@
program tree;
type TreedataType = (TDString, TDInteger);
type Treedata = record
case typ:Treedatatype of
TDString:(stringdata:string);
TDInteger:(intdata:integer);
end;
type TreeNode = record
parent: ^TreeNode;
left,right: ^TreeNode;
height: integer;
key: ^string;
data: ^Treedata;
end;
type TreeRef = ^TreeNode;
type TreeWalkState = record
currentNode:TreeRef;
end;
var t:TreeRef;
k:string;
d:TreeData;
i:integer;
searchres:^Treedata;
walkState:TreeWalkState;
walkRes:TreeRef;
procedure mem_dump; external;
function makeTreeNode(var d:TreeData;var key:string;nparent:TreeRef):TreeRef;
var newNode:TreeRef;
newKey:^string;
begin
new(newNode);
new(newKey,length(key));
{ new(newKey); }
new(newNode^.data);
newKey^ := key;
with newNode^ do
begin
key := newKey;
parent := nparent;
left := nil;
right := nil;
height := 1;
data^ := d;
end;
makeTreeNode := newNode;
end;
function MeasureTree(root:TreeRef):integer;
var leftHeight, rightHeight:integer;
begin
if root = nil then
MeasureTree := 0
else
begin
if root^.left <> nil then
leftHeight := root^.left^.height
else
leftHeight := 0;
if root^.right <> nil then
rightHeight := root^.right^.height
else
rightHeight := 0;
if rightHeight > leftHeight then
MeasureTree := rightHeight + 1
else
MeasureTree := leftHeight + 1;
end;
end;
function GetTreeBalance(root:TreeRef):integer;
begin
if root = nil then
GetTreeBalance := 0
else
GetTreeBalance := MeasureTree(root^.left) - MeasureTree(root^.right);
end;
function RotateTreeRight(x:TreeRef):TreeRef;
var z,tmp:TreeRef;
begin
writeln('RotateTreeRight at ', x^.key^);
z := x^.left;
tmp := z^.right;
z^.right := x;
z^.parent := x^.parent;
x^.parent := z;
x^.left := tmp;
if tmp <> nil then
tmp^.parent := x;
x^.height := MeasureTree(x);
z^.height := MeasureTree(z);
RotateTreeRight := z;
end;
function RotateTreeLeft(x:TreeRef):TreeRef;
var z,tmp:TreeRef;
begin
writeln('RotateTreeLeft at ', x^.key^);
z := x^.right;
tmp := z^.left;
z^.left := x;
z^.parent := x^.parent;
x^.parent := z;
x^.right := tmp;
if tmp <> nil then
tmp^.parent := x;
x^.height := MeasureTree(x);
z^.height := MeasureTree(z);
RotateTreeLeft := z;
end;
function TreeInsert4(root:TreeRef;var key:string;var data:TreeData;
parent:TreeRef):TreeRef;
var balance:integer;
begin
if root = nil then
root := makeTreeNode(data, key, parent)
else
if key < root^.key^ then
root^.left := TreeInsert4(root^.left, key, data, root)
else
root^.right := TreeInsert4(root^.right, key, data, root);
root^.height := MeasureTree(root);
balance := GetTreeBalance(root);
if balance > 1 then
begin
if key < root^.left^.key^ then
root := RotateTreeRight(root)
else
begin
root^.left := RotateTreeLeft(root^.left);
root := RotateTreeRight(root);
end;
end
else
if balance < -1 then
begin
if key > root^.right^.key^ then
root := RotateTreeLeft(root)
else
begin
root^.right := RotateTreeRight(root^.right);
root := RotateTreeLeft(root);
end;
end;
TreeInsert4 := root;
end;
procedure TreeInsert(var root:TreeRef;var key:string;var data:TreeData);
begin
root := TreeInsert4(root,key,data,nil);
end;
procedure DisposeTreeNode(node:TreeRef);
begin
dispose(node^.key);
dispose(node^.data);
dispose(node);
end;
function TreeLeftmost(node:TreeRef):TreeRef;
begin
TreeLeftmost := nil;
if node <> nil then
begin
repeat
TreeLeftmost := node;
node := node^.left;
until node = nil;
end;
end;
procedure PrintTreeRef(node:TreeRef);
begin
if node = nil then
write('nil')
else
write(node^.key^);
end;
procedure PrintTreeNode(node:TreeRef);
begin
write(' -');
PrintTreeRef(node);
if node <> nil then
begin
write(' ^');
PrintTreeRef(node^.parent);
write(' <');
PrintTreeRef(node^.left);
write(' >');
PrintTreeRef(node^.right);
end;
writeln;
end;
function TreeDeleteFn(root:TreeRef;var key:string):TreeRef;
var tmp,oldParent:TreeRef;
balance:integer;
begin
if root <> nil then
begin
if key < root^.key^ then
root^.left := TreeDeleteFn(root^.left, key)
else
if key > root^.key^ then
root^.right := TreeDeleteFn(root^.right, key)
else
begin
if root^.left = nil then
begin
tmp := root;
oldParent := root^.parent;
root := root^.right;
if root <> nil then
root^.parent := oldParent;
DisposeTreeNode(tmp);
end
else
if root^.right = nil then
begin
tmp := root;
oldParent := root^.parent;
root := root^.left;
if root <> nil then
root^.parent := oldParent;
DisposeTreeNode(tmp);
end
else
begin
writeln('TreeDelete search leftmost from ', root^.key^);
PrintTreeNode(root);
tmp := TreeLeftmost(root^.right);
if maxlength(tmp^.key^) <> maxlength(root^.key^) then
begin (* reallocate key, the swapped key might have a different length *)
write('reallocating key ', length(root^.key^));
dispose(root^.key);
new(root^.key, length(tmp^.key^));
writeln(' -> ', maxlength(root^.key^));
end;
root^.key^ := tmp^.key^;
root^.data^ := tmp^.data^;
writeln('TreeDelete delete leftmost ', tmp^.key^);
PrintTreeNode(tmp);
writeln('oldParent: ');
PrintTreeNode(tmp^.parent);
oldParent := tmp^.parent;
if oldParent^.left = tmp then
oldParent^.left := TreeDeleteFn(oldParent^.left, tmp^.key^)
else
if oldParent^.right = tmp then
oldParent^.right := TreeDeleteFn(oldParent^.right, tmp^.key^)
else
writeln('TreeDelete internal error');
end;
if root <> nil then
begin
root^.height := MeasureTree(root);
balance := GetTreeBalance(root);
if balance > 1 then
begin
if GetTreeBalance(root^.left) >=0 then
root := RotateTreeRight(root)
else
begin
root^.left := RotateTreeLeft(root^.left);
root := RotateTreeRight(root);
end;
end
else
if balance < -1 then
begin
if GetTreeBalance(root^.right) <= 0 then
root^.right := RotateTreeLeft(root)
else
begin
root^.right := RotateTreeRight(root^.right);
root := RotateTreeLeft(root);
end;
end;
end;
end;
end;
TreeDeleteFn := root;
end;
procedure TreeDelete(var root:TreeRef;var key:string);
begin
root := TreeDeleteFn(root,key);
end;
function TreeSearch(root:TreeRef;var key:string):^TreeData;
begin
if root <> nil then
begin
if key = root^.key^ then
TreeSearch := root^.data
else
if key < root^.key^ then
TreeSearch := TreeSearch(root^.left, key)
else
TreeSearch := TreeSearch(root^.right, key);
end
else
TreeSearch := nil;
end;
procedure TreeWalkStart(t:TreeRef; var state:TreeWalkState);
begin
(* start at leftmost node of the tree *)
state.currentNode := TreeLeftmost(t);
end;
procedure TreeWalkNext(var state:TreeWalkState;var res:TreeRef);
var last,current,old,right:TreeRef;
begin
current := state.currentNode;
res := current;
if current <> nil then
begin
(* descending right *)
if current^.right <> nil then
begin
state.currentNode := TreeLeftmost(current^.right);
end
else (* ascending *)
begin
old := current;
repeat
last := current;
current := current^.parent;
if current <> nil then
right := current^.right;
until (right <> last) or (current = nil); (* ascend left edges *)
state.currentNode := current;
end;
end;
end;
procedure indent(i:integer);
var c:integer;
begin
for c := 1 to i do
write(' ');
end;
procedure PrintStringTree(node:TreeRef;level:integer);
begin
if node <> nil then
begin
if node^.left <> nil then
PrintStringTree(node^.left, level + 1);
indent(level);
PrintTreeNode(node);
if node^.right <> nil then
PrintStringTree(node^.right, level + 1);
end;
end;
procedure DoASearch(t:TreeRef; s:string);
var res:^TreeData;
begin
res := TreeSearch(t, s);
write('searching for ',s);
if res = nil then
writeln(' nil')
else
writeln(res^.stringdata);
end;
begin
mem_dump;
{
t := nil;
k := 'test1';
d.typ := TDString;
d.stringdata := 'data1';
TreeInsert(t,k,d);
k := 'test0';
d.typ := TDString;
d.stringdata := 'data0';
TreeInsert(t,k,d);
k := 'test3';
d.typ := TDString;
d.stringdata := 'data3';
TreeInsert(t,k,d);
k := 'test2';
d.typ := TDString;
d.stringdata := 'data2';
TreeInsert(t,k,d);
k := 'test4';
d.typ := TDString;
d.stringdata := 'data4';
TreeInsert(t,k,d);
writeln('root: ', t^.key^);
PrintStringTree(t,1);
}
writeln('------------');
t := nil;
d.typ := TDString;
d.stringdata := 'data';
for i := 1 to 30 do
begin
str(i,k);
d.stringdata := 'data' + k;
k := 'test' + k;
TreeInsert(t,k,d);
if i >99 then
begin
writeln('root: ', t^.key^);
PrintStringTree(t,1);
writeln('------------');
readln;
end;
end;
writeln('root: ', t^.key^);
PrintStringTree(t,1);
writeln('------------');
DoASearch(t,'test21');
DoASearch(t,'test2');
DoASearch(t,'test17');
k := 'test17';
TreeDelete(t,k);
writeln('root: ', t^.key^);
PrintStringTree(t,1);
writeln('------------');
DoASearch(t,'test17');
TreeWalkStart(t, walkState);
repeat
TreeWalkNext(walkState, walkRes);
if walkRes <> nil then
writeln(walkRes^.data^.stringdata);
until walkRes = nil;
for i := 1 to 30 do
begin
str(i,k);
k := 'test' + k;
writeln('deleting ', k);
TreeDelete(t,k);
end;
if t <> nil then
writeln('root: ', t^.key^)
else
writeln('root: nil');
PrintStringTree(t,1);
writeln('------------');
mem_dump;
end.

288
tests/treeimpl.pas Normal file
View file

@ -0,0 +1,288 @@
function makeTreeNode(var d:TreeData;var key:string;nparent:TreeRef):TreeRef;
var newNode:TreeRef;
newKey:^string;
begin
new(newNode);
{ new(newKey,length(key)); }
newString(newKey, length(key));
new(newNode^.data);
newKey^ := key;
with newNode^ do
begin
key := newKey;
parent := nparent;
left := nil;
right := nil;
height := 1;
data^ := d;
end;
makeTreeNode := newNode;
end;
function MeasureTree(root:TreeRef):integer;
var leftHeight, rightHeight:integer;
begin
if root = nil then
MeasureTree := 0
else
begin
if root^.left <> nil then
leftHeight := root^.left^.height
else
leftHeight := 0;
if root^.right <> nil then
rightHeight := root^.right^.height
else
rightHeight := 0;
if rightHeight > leftHeight then
MeasureTree := rightHeight + 1
else
MeasureTree := leftHeight + 1;
end;
end;
function GetTreeBalance(root:TreeRef):integer;
begin
if root = nil then
GetTreeBalance := 0
else
GetTreeBalance := MeasureTree(root^.left) - MeasureTree(root^.right);
end;
function RotateTreeRight(x:TreeRef):TreeRef;
var z,tmp:TreeRef;
begin
(* writeln('RotateTreeRight at ', x^.key^); *)
z := x^.left;
tmp := z^.right;
z^.right := x;
z^.parent := x^.parent;
x^.parent := z;
x^.left := tmp;
if tmp <> nil then
tmp^.parent := x;
x^.height := MeasureTree(x);
z^.height := MeasureTree(z);
RotateTreeRight := z;
end;
function RotateTreeLeft(x:TreeRef):TreeRef;
var z,tmp:TreeRef;
begin
(* writeln('RotateTreeLeft at ', x^.key^); *)
z := x^.right;
tmp := z^.left;
z^.left := x;
z^.parent := x^.parent;
x^.parent := z;
x^.right := tmp;
if tmp <> nil then
tmp^.parent := x;
x^.height := MeasureTree(x);
z^.height := MeasureTree(z);
RotateTreeLeft := z;
end;
function TreeInsert4(root:TreeRef;var key:string;var data:TreeData;
parent:TreeRef):TreeRef;
var balance:integer;
begin
if root = nil then
root := makeTreeNode(data, key, parent)
else
if key < root^.key^ then
root^.left := TreeInsert4(root^.left, key, data, root)
else
root^.right := TreeInsert4(root^.right, key, data, root);
root^.height := MeasureTree(root);
balance := GetTreeBalance(root);
if balance > 1 then
begin
if key < root^.left^.key^ then
root := RotateTreeRight(root)
else
begin
root^.left := RotateTreeLeft(root^.left);
root := RotateTreeRight(root);
end;
end
else
if balance < -1 then
begin
if key > root^.right^.key^ then
root := RotateTreeLeft(root)
else
begin
root^.right := RotateTreeRight(root^.right);
root := RotateTreeLeft(root);
end;
end;
TreeInsert4 := root;
end;
procedure TreeInsert(var root:TreeRef;var key:string;var data:TreeData);
begin
root := TreeInsert4(root,key,data,nil);
end;
procedure DisposeTreeNode(node:TreeRef);
begin
dispose(node^.key);
dispose(node^.data);
dispose(node);
end;
function TreeLeftmost(node:TreeRef):TreeRef;
begin
TreeLeftmost := nil;
if node <> nil then
begin
repeat
TreeLeftmost := node;
node := node^.left;
until node = nil;
end;
end;
function TreeDeleteFn(root:TreeRef;var key:string):TreeRef;
var tmp,oldParent:TreeRef;
balance:integer;
begin
if root <> nil then
begin
if key < root^.key^ then
root^.left := TreeDeleteFn(root^.left, key)
else
if key > root^.key^ then
root^.right := TreeDeleteFn(root^.right, key)
else
begin
if root^.left = nil then
begin
tmp := root;
oldParent := root^.parent;
root := root^.right;
if root <> nil then
root^.parent := oldParent;
DisposeTreeNode(tmp);
end
else
if root^.right = nil then
begin
tmp := root;
oldParent := root^.parent;
root := root^.left;
if root <> nil then
root^.parent := oldParent;
DisposeTreeNode(tmp);
end
else
begin
tmp := TreeLeftmost(root^.right);
root^.key^ := tmp^.key^;
root^.data^ := tmp^.data^;
oldParent := tmp^.parent;
if oldParent^.left = tmp then
oldParent^.left := TreeDeleteFn(oldParent^.left, tmp^.key^)
else
if oldParent^.right = tmp then
oldParent^.right := TreeDeleteFn(oldParent^.right, tmp^.key^)
else
begin
writeln('TreeDelete internal error at', root^.key^);
end;
end;
if root <> nil then
begin
root^.height := MeasureTree(root);
balance := GetTreeBalance(root);
if balance > 1 then
begin
if GetTreeBalance(root^.left) >=0 then
root := RotateTreeRight(root)
else
begin
root^.left := RotateTreeLeft(root^.left);
root := RotateTreeRight(root);
end;
end
else
if balance < -1 then
begin
if GetTreeBalance(root^.right) <= 0 then
root := RotateTreeLeft(root)
else
begin
root^.right := RotateTreeRight(root^.right);
root := RotateTreeLeft(root);
end;
end;
end;
end;
end;
TreeDeleteFn := root;
end;
procedure TreeDelete(var root:TreeRef;var key:string);
begin
root := TreeDeleteFn(root,key);
end;
function TreeSearch(root:TreeRef;var key:string):TreeDataRef;
begin
if root <> nil then
begin
if key = root^.key^ then
TreeSearch := root^.data
else
if key < root^.key^ then
TreeSearch := TreeSearch(root^.left, key)
else
TreeSearch := TreeSearch(root^.right, key);
end
else
TreeSearch := nil;
end;
procedure TreeWalkStart(t:TreeRef; var state:TreeWalkState);
begin
(* start at leftmost node of the tree *)
state.currentNode := TreeLeftmost(t);
end;
procedure TreeWalkNext(var state:TreeWalkState;var res:TreeRef);
var last,current,right:TreeRef;
begin
current := state.currentNode;
res := current;
if current <> nil then
begin
(* descending right *)
if current^.right <> nil then
begin
state.currentNode := TreeLeftmost(current^.right);
end
else (* ascending *)
begin
repeat
last := current;
current := current^.parent;
if current <> nil then
right := current^.right;
until (right <> last) or (current = nil); (* ascend left edges *)
state.currentNode := current;
end;
end;
end;
procedure TreeWalkFirst(t:TreeRef; var state:TreeWalkState; var first:TreeRef);
begin
TreeWalkStart(t, state);
TreeWalkNext(state, first);
end;

25
tests/treetypes.pas Normal file
View file

@ -0,0 +1,25 @@
{
type TreedataType = (TDString, TDInteger);
type Treedata = record
case typ:Treedatatype of
TDString:(stringdata:string);
TDInteger:(intdata:integer);
end;
}
type StringRef = ^string;
type TreeNode = record
parent: ^TreeNode;
left,right: ^TreeNode;
height: integer;
key: StringRef;
data: ^Treedata;
end;
type TreeRef = ^TreeNode;
TreeDataRef = ^Treedata;
type TreeWalkState = record
currentNode:TreeRef;
end;

15
tests/umlaut.pas Normal file
View file

@ -0,0 +1,15 @@
(*
test program for
multibyte characters
and tabs
*)
program umlaut;
var s:string = 'ÄÖÜß';
begin
writeln('Falsches Üben von');
writeln('Xylophonmusik quält jeden');
writeln('größeren Zwerg.');
writeln;
writeln(s);
writeln(length(s));
end.

BIN
tridoraemu.zip Normal file

Binary file not shown.

7
tridoraemu/IOHandler.go Normal file
View file

@ -0,0 +1,7 @@
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
type IOHandler interface {
read(byteaddr word) (word, error)
write(value word, byteaddr word) (error)
}

17
tridoraemu/LICENSE.md Normal file
View file

@ -0,0 +1,17 @@
# Copyright and Licensing
All files, except where explicitly stated otherwise, are licensed according to the BSD-3-Clause license as follows:
------------------------------------------------------------------------------
Copyright 2024 Sebastian Lederer
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

53
tridoraemu/README.md Normal file
View file

@ -0,0 +1,53 @@
# Tridora Emulator
- an emulator for the Tridora CPU / System
- emulates the CPU, UART, SD-Card controller, VGA controller
- supports reading the tick counter from the interrupt controller, but does not support any interrupts
- written in Golang
## Getting started
From the command line, run the *tridoraemu* or *tridoraemu.exe* program inside the *tridoraemu* directory (see below for details).
A precompiled binary for Windows is provided.
To build the program yourself, you need to have the Go language installed on your system. Building has been tested on Windows and Linux.
## Building
Run the following commands inside the *tridoraemu* directory:
go get
go build
On the first run, this may take a while as the go build system fetches some external libraries and compiles them.
## Running the emulator
Start the *tridoraemu* binary in the same directory as the SD-Card image file (*sdcard.img*) and the ROM file (*rommon.prog*). It needs to be started on the command line as it uses the terminal window for the serial console. On startup, the emulator opens the VGA framebuffer window which is only used for graphics output.
The Tridora software (esp. the editor) requires a decent vt100-compatible (plus colors) terminal emulator. It has been successfully tested with (new) Windows Terminal, WezTerm and xterm.
The color scheme in the editor is meant for a dark terminal background.
The runtime system expects the Backspace key to send the DEL character (ASCII 127).
## Stopping the emulator
To stop the emulator, close the VGA framebuffer window.
The emulator will also stop if it encounters an infinite loop (a BRANCH @+0 instruction).
## Things to try out
On the ROM monitor prompt, press *B* to boot from the SD-card image. This should boot into the shell, which will first require you to enter the current date and time.
In the shell, try the *L* command to list directories and the *V* command to change volumes. The *Example* volume contains some example programs in source form.
The programs *lines*, *conway* and *mandelbrot*, among others, show some (hopefully) interesting VGA graphics. The *viewpict* program can show image files (*.pict files) which contain 640x400x4 bitmaps. A few sample image files are provided.
To compile a program, set the file name (e.g. *lines.pas*) with the *W* command in the shell. Then, use *B* and *R* to build and run the program.
To edit the source file, have the name set with *W* and then use the *E* shell command. Inside the editor, press F1 for the help screen (and RETURN to leave the help screen). Control-X exits the editor, abandoning any changes.
The volume *Testvolume 1* (note the space) contains a precompiled game called *chase*. This is a game that was written for UCSD Pascal around 1980, and compiles with a few lines of changes with the Tridora Pascal compiler. The source code is also provided on that volume.
You can run the program with the *O* command in the shell (just press Return for the program arguments), or you can set the workfile name with *W* and then use the *R* command.
The *K* command in the shell is used to reclaim the space occupied by deleted or overwritten files.
A running program can be terminated by pressing Control-C, but only if the program is expecting keyboard input at that time.

35
tridoraemu/console.go Normal file
View file

@ -0,0 +1,35 @@
// +build !windows
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
"os"
"golang.org/x/term"
)
type ConsoleState struct {
state term.State
}
func SetRawConsole() (*ConsoleState, error) {
oldState, err := term.MakeRaw(int(os.Stdin.Fd()))
return &ConsoleState{*oldState}, err
}
func RestoreConsole(st *ConsoleState) error {
return term.Restore(int(os.Stdin.Fd()), &st.state)
}
func ConsoleRead(buf []byte) (count int, err error) {
n, e := os.Stdin.Read(buf)
return n, e
}
func ConsoleWrite(char byte) (err error) {
buf := make([] byte, 1)
buf[0] = char
_ , e := os.Stdout.Write(buf)
return e
}

View file

@ -0,0 +1,75 @@
// +build windows
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
"io"
"os"
"golang.org/x/sys/windows"
)
type ConsoleState struct {
modeStdin uint32
modeStdout uint32
}
func SetRawConsole() (*ConsoleState, error) {
var stIn uint32
var stOut uint32
stdinFd := os.Stdin.Fd()
if err := windows.GetConsoleMode(windows.Handle(stdinFd), &stIn); err != nil {
return nil, err
}
raw := stIn &^ (windows.ENABLE_ECHO_INPUT | windows.ENABLE_PROCESSED_INPUT | windows.ENABLE_LINE_INPUT | windows.ENABLE_PROCESSED_OUTPUT)
raw |= windows.ENABLE_VIRTUAL_TERMINAL_INPUT
if err := windows.SetConsoleMode(windows.Handle(stdinFd), raw); err != nil {
return nil, err
}
/*
stdoutFd := os.Stdout.Fd()
if err := windows.GetConsoleMode(windows.Handle(stdoutFd), &stOut); err != nil {
return nil, err
}
raw = stOut | windows.ENABLE_VIRTUAL_TERMINAL_INPUT | windows.ENABLE_PROCESSED_OUTPUT
if err := windows.SetConsoleMode(windows.Handle(stdoutFd), raw); err != nil {
return nil, err
}
*/
return &ConsoleState{stIn,stOut}, nil
}
func RestoreConsole(st *ConsoleState) error {
stdinFd := os.Stdin.Fd()
stdoutFd := os.Stdout.Fd()
err := windows.SetConsoleMode(windows.Handle(stdinFd), st.modeStdin)
if err != nil { return err }
err = windows.SetConsoleMode(windows.Handle(stdoutFd), st.modeStdin)
return err
}
func ConsoleRead(buf []byte) (count int, err error) {
n, e := os.Stdin.Read(buf)
if e == io.EOF { // ugly hack to handle ^Z on windows
// this can probably be done in a better way
// but tbh I am glad it works and I don't
// have to dig deeper into that windows
// console i/o crap
n = 1; buf[0] = 26
return n, nil
}
return n, e
}
func ConsoleWrite(char byte) (err error) {
buf := make([] byte, 1)
buf[0] = char
_ , err = os.Stdout.Write(buf)
return err
}

467
tridoraemu/cpu.go Normal file
View file

@ -0,0 +1,467 @@
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
"fmt"
"strings"
)
type word uint32
const wordbits = 32
const wordbytes = 4
const wordmask = 0xFFFFFFFF
const hsbmask = 0x80000000
const estackDepth = 64
type CPU struct {
ESP word;
X word;
PC, FP,BP,RP word;
IR,IV word;
estack [estackDepth] word;
mem *Mem;
stopped bool
trace bool
singlestep bool
}
func sign_extend(bits word, wordbits int) int {
signmask := word(1 << (wordbits - 1))
signbit := (bits & signmask) != 0
// fmt.Printf("sign_extend %b %v signmask %08X signbit %v\n", bits, wordbits, signmask, signbit)
if signbit {
return int(bits & ^signmask) - int(signmask)
} else {
return int(bits)
}
}
func (c *CPU) initialize() {
c.ESP = 0
c.PC = 0
c.X = 0
c.FP = 65020 // these are the values set by the ROM monitor
c.RP = 65024 // for FP and RP
c.singlestep = false
}
func (c *CPU) printEstack() {
fmt.Printf("[")
for i := word(1); i <= c.ESP; i++ {
fmt.Printf(" %08X", c.estack[i])
}
fmt.Printf(" %08X ] (%v)\n", c.X, c.ESP)
}
func (c *CPU) showStep(desc string, operand int, opWidth int) {
if !c.trace { return }
var opStr string
if opWidth == 0 {
opStr = ""
} else {
opStr = fmt.Sprintf(" %04X", operand)
}
fmt.Printf("%08x %-10s%5s ", c.PC, desc, opStr)
c.printEstack()
}
func (c *CPU) getOperand(insWord word, bits int) int {
return int(insWord & word((1 << bits) - 1))
}
func (c *CPU) getSignedOperand(insWord word, bits int) int {
bitValue := (1 << (bits - 1))
signBit := insWord & word(bitValue)
bitMask := (bitValue << 1) - 1
//fmt.Printf("getSignedOperand bitValue: %v, bitMask: %v\n", bitValue, bitMask)
o := int(insWord & word(bitMask))
if signBit != 0 {
o = int(o) - (bitValue << 1)
}
//fmt.Printf("getSignedOperand: %v %v -> %d\n",insWord, bits, o)
return o
}
func (c *CPU) getBit(insWord word, bitnum int) int {
return int(insWord >> bitnum) & 1
}
func (c *CPU) getBits(insWord word, mask word, shiftCount int) word {
return (insWord & mask) >> shiftCount
}
func (c *CPU) getSignedBits(insWord word, mask word, shiftCount int) int {
result := (insWord & mask) >> shiftCount
signMask := ((mask >> shiftCount) + 1) >> 1
//fmt.Printf("getSignedBits %016b signMask %v signBit %v\n", insWord, signMask, insWord & signMask)
if result & signMask != 0 {
return - int(result & ^signMask)
} else {
return int(result)
}
}
func (c * CPU) addToWord(v word, offset int) word {
if offset < 0 {
v -= word(-offset)
} else {
v += word(offset)
}
return v
}
func (c *CPU) step() error {
nPC := c.PC
nFP := c.FP
nBP := c.BP
nRP := c.RP
nX := c.X
nESP := c.ESP
Y := c.estack[c.ESP]
insWord, err := c.mem.read(c.PC)
if err != nil { return err }
if c.PC % 4 == 0 {
insWord = insWord >> 16
} else {
insWord = insWord & 0xFFFF
}
baseIns := insWord >> 13
nPC += 2
x2y := false
deltaESP := 0
oplen := 0
switch baseIns {
// BRANCH
case 0b000:
operand := c.getSignedOperand(insWord, 13)
c.showStep("BRANCH", operand, 13)
nPC = word(int(c.PC) + operand)
if operand == 0 {
fmt.Printf("BRANCH 0 encountered - stopped at PC %08X\n", nPC)
c.stopped = true
}
// ALU
case 0b001:
aluop := c.getBits(insWord, 0b0001111000000000, 9)
deltaESP = c.getSignedBits(insWord, 0b0000000000110000, 4)
ext := c.getBit(insWord, 7) != 0
x2y = c.getBit(insWord, 6) != 0
operand := c.getOperand(insWord, 4)
// fmt.Printf("aluop %v %v %v %v %v\n", aluop, s, ext, x2y, operand)
name := "ALU"
switch aluop {
case 0:
name = "ADD"
nX = c.X + Y
case 1:
name = "SUB"
nX = Y - c.X
case 2:
name = "NOT"
nX = ^ c.X
case 3:
name = "AND"
nX = c.X & Y
case 4:
name = "OR"
nX = c.X | Y
case 5:
name = "XOR"
nX = c.X ^ Y
case 6:
name = "CMP"
oplen = 2
cmp_i := c.getBit(insWord,2) != 0
cmp_eq := c.getBit(insWord,1) != 0
cmp_lt := c.getBit(insWord,0) != 0
s_x := sign_extend(c.X, wordbits)
s_y := sign_extend(Y, wordbits)
result := (cmp_eq && (s_x == s_y)) || (cmp_lt && (s_y < s_x))
if cmp_i { result = !result }
if result { nX = 1 } else { nX = 0 }
case 7:
name = "Y"
if !x2y && (deltaESP == -1) { name = "DROP" }
if x2y && (deltaESP == 0) { name = "SWAP" }
nX = Y
case 8:
name = "SHR"
nX = c.X >> 1
if ext {
nX = nX | (c.X & hsbmask)
}
case 9:
name = "SHL"
nX = c.X << 1
if operand & 2 != 0 {
nX = nX << 1
}
oplen = 2
case 10:
name = "INC"
oplen = 4
if (operand == 0) && (deltaESP == 1) && x2y { name = "DUP" }
nX = c.X + word(operand)
case 11:
name = "DEC"
oplen = 4
nX = c.X - word(operand)
case 12:
name = "CMPU"
oplen = 2
cmp_i := c.getBit(insWord,2) != 0
cmp_eq := c.getBit(insWord,1) != 0
cmp_lt := c.getBit(insWord,0) != 0
result := (cmp_eq && (c.X == Y)) || (cmp_lt && (Y < c.X))
if cmp_i { result = !result }
if result { nX = 1 } else { nX = 0 }
case 13:
name = "BPLC"
nX = (c.X & 0xFF) << ((3 - (Y & 3)) * 8)
case 14:
name = "BROT"
nX = ((c.X & 0x00FFFFFF) << 8 ) | ((c.X & 0xFF000000) >> 24)
case 15:
name = "BSEL"
shift := (3 - (Y & 3)) * 8
nX = (c.X >> shift) & 0xFF
}
c.showStep(name, operand, oplen)
// STORE
case 0b010:
operand := c.getOperand(insWord, 13)
var ea word
var name string
if (insWord & 1) == 1 {
name = "STORE.B"
ea = c.BP + word(operand)
} else {
name = "STORE"
ea = c.FP + word(operand)
}
c.showStep(name, operand, oplen)
err = c.mem.write(c.X, ea)
if err != nil { return err }
deltaESP = -1
nX = Y
// XFER
case 0b011:
var name string
deltaRP := c.getSignedBits(insWord, 0b0000001100000000, 8)
deltaESP = c.getSignedBits(insWord, 0b0000000000110000, 4)
r2p := c.getBit(insWord, 7) != 0
p2r := c.getBit(insWord, 6) != 0
x2p := c.getBit(insWord, 0) != 0
if deltaRP >= 0 {
nRP = c.RP + word(deltaRP * wordbytes)
} else {
nRP = c.RP - word(-deltaRP * wordbytes)
}
if (deltaRP == 1) && (deltaESP == -1) && p2r && x2p {
name = "CALL"
} else
if (deltaRP == -1) && (deltaESP == 0) && r2p {
name = "RET"
} else
if (deltaRP == 0) && (deltaESP == -1) && x2p && !p2r {
name = "JUMP"
} else {
var b strings.Builder
b.WriteString("XFER")
if deltaRP == -1 { b.WriteString(".RSM1") }
if deltaRP == 1 { b.WriteString(".RS1") }
if deltaESP == -1 { b.WriteString(".SM1") }
if deltaESP == 1 { b.WriteString(".S1") }
if r2p { b.WriteString(".R2P") }
if p2r { b.WriteString(".P2R") }
if x2p { b.WriteString(".X2P") }
name = b.String()
}
c.showStep(name, 0, 0)
if r2p {
nPC, err = c.mem.read(c.RP)
if err != nil { return err }
}
if p2r {
err = c.mem.write(nPC, nRP)
if err != nil { return err }
}
if x2p {
nPC = c.X
nX = Y
}
// LOAD
case 0b100:
operand := c.getOperand(insWord, 13)
var ea word
var name string
if (insWord & 1) == 1 {
name = "LOAD.B"
operand &= ^1
ea = c.BP + word(operand)
} else {
name = "LOAD"
ea = c.FP + word(operand)
}
c.showStep(name, operand, oplen)
deltaESP = 1
x2y = true
nX, err = c.mem.read(ea)
if err != nil { return err }
// CBRANCH
case 0b101:
operand := c.getSignedOperand(insWord, 13)
var name string
invert := (operand & 1) == 0
operand = operand & -2 // clear bit 0
if invert { name = "CBRANCH.Z" } else { name = "CBRANCH" }
c.showStep(name, operand, 13)
deltaESP = -1
nX = Y
if (c.X != 0 && !invert) || (c.X == 0 && invert) {
nPC = word(int(c.PC) + operand)
}
// LOADC
case 0b110:
operand := c.getSignedOperand(insWord, 13)
oplen = 13
c.showStep("LOADC", operand, oplen)
deltaESP = 1
x2y = true
nX = word(operand)
// EXT
case 0b111:
extop := c.getBits(insWord, 0b0001111000000000, 10)
deltaESP = c.getSignedBits(insWord, 0b0000000000110000, 4)
writeFlag := c.getBit(insWord, 9) != 0
// signExtend := c.getBit(insWord,7) != 0
x2y = c.getBit(insWord, 6) != 0
operand := c.getOperand(insWord, 4)
var name string
switch extop {
// LOADREG/STOREREG
case 0:
oplen = 4
if writeFlag {
name = "STOREREG"
switch operand {
case 0: nFP = c.X
case 1: nBP = c.X
case 2: nRP = c.X
case 3: c.IV = c.X // should be nIV
case 4: c.IR = c.X // should be nIR
default: fmt.Errorf("Invalid STOREREG operand %v at %08X", operand, c.PC)
}
c.showStep(name, operand, oplen)
deltaESP = -1
x2y = false
nX = Y
} else {
name = "LOADREG"
switch operand {
case 0: nX = c.FP
case 1: nX = c.BP
case 2: nX = c.RP
case 3: nX = c.IV
case 4: nX = c.IR
case 5: nX = c.ESP
default: fmt.Errorf("Invalid LOADREG operand %v at %08X", operand, c.PC)
}
c.showStep(name, operand, oplen)
deltaESP = 1
x2y = true
}
// LOADI/STOREI
case 1:
if writeFlag { name = "STOREI" } else { name = "LOADI" }
c.showStep(name, operand, oplen)
if writeFlag {
oplen = 4
err = c.mem.write(c.X, Y)
if err != nil { return err }
nX = Y + word(operand)
} else {
nX, err = c.mem.read(c.X)
if err != nil { return err }
}
// FPADJ
case 3:
operand := c.getSignedOperand(insWord, 10)
oplen = 10
nFP = c.FP + word(operand)
deltaESP = 0
x2y = false
c.showStep("FPADJ", operand, oplen)
// LOADREL
case 5:
offset := c.getOperand(insWord, 10)
c.showStep("LOADREL", offset, 10)
nX, err = c.mem.read(c.PC + word(offset))
if err != nil { return err }
x2y = true
deltaESP = 1
default:
return fmt.Errorf("Invalid EXT instruction %v at %08X", extop, c.PC)
}
default:
return fmt.Errorf("Invalid instruction %04X at %08X", insWord, c.PC)
}
nESP = c.addToWord(nESP, deltaESP)
if nESP < 0 || nESP >= estackDepth {
return fmt.Errorf("estack overflow %v at %08X", nESP, c.PC)
}
if x2y {
c.estack[nESP] = c.X
}
c.PC = nPC
c.FP = nFP
c.BP = nBP
c.X = nX
c.RP = nRP
c.ESP = nESP
return nil
}

131
tridoraemu/framebuffer.go Normal file
View file

@ -0,0 +1,131 @@
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
// "fmt"
"image/color"
"github.com/hajimehoshi/ebiten/v2"
)
const VmemWords = 32768
const PaletteSlots = 16
const FB_RA = 0
const FB_WA = 1
const FB_IO = 2
const FB_PS = 3
const FB_PD = 4
const FB_CTL= 5
const PixelMask = 0b11110000000000000000000000000000
const PixelPerWord = 8
const VmemWidth = 32
const BitsPerPixel = 4
const ScreenWidth = 640
const ScreenHeight = 400
const WordsPerLine = ScreenWidth / PixelPerWord
type Framebuffer struct {
framebuffer *ebiten.Image
palette [PaletteSlots] color.Color
readAddr word
writeAddr word
paletteSlot word
vmem [VmemWords]word
readCount int
}
func (f *Framebuffer) initialize() {
f.framebuffer = ebiten.NewImage(ScreenWidth, ScreenHeight)
for i := 0; i <PaletteSlots; i++ {
f.palette[i] = color.RGBA{0,0,0,0}
}
}
func (f *Framebuffer) read(byteaddr word) (word, error) {
result := word(0)
addr := byteaddr & 0x7F
switch addr {
case FB_RA: result = f.readAddr
case FB_WA: result = f.writeAddr
case FB_IO: result = f.readVmem()
case FB_PS: result = f.paletteSlot
case FB_PD: result = f.readPalette()
case FB_CTL: result = f.readCtl()
default:
}
return result, nil
}
func (f *Framebuffer) write(value word, byteaddr word) (error) {
addr := byteaddr & 0x7F
switch addr {
case FB_RA: f.readAddr = value
case FB_WA: f.writeAddr = value
case FB_IO: f.writeVmem(value)
case FB_PS: f.paletteSlot = value
case FB_PD: f.writePalette(value)
case FB_CTL: f.writeCtl(value)
default:
}
idle(false)
return nil
}
func (f *Framebuffer) readVmem() word {
result := f.vmem[f.readAddr]
f.readAddr += 1
return result
}
func (f *Framebuffer) writeVmem(value word) {
f.vmem[f.writeAddr] = value
y := f.writeAddr / WordsPerLine
x := f.writeAddr % WordsPerLine * PixelPerWord
for i := 0; i < PixelPerWord; i++ {
pixel := (value & PixelMask) >> (VmemWidth - BitsPerPixel)
value = value << BitsPerPixel
col := f.palette[pixel]
//fmt.Printf("set pixel %v, %v\n", x,y)
f.framebuffer.Set(int(x), int(y), col)
x = x + 1
}
f.writeAddr += 1
}
func (f *Framebuffer) readPalette() word {
return word(0)
}
func (f *Framebuffer) writePalette(value word) {
// 4 bits per color channel
r := uint8((value & 0b111100000000) >> 8)
g := uint8((value & 0b000011110000) >> 4)
b := uint8((value & 0b000000001111) >> 0)
// scale to 0-255
r = r << 4
g = g << 4
b = b << 4
f.palette[f.paletteSlot] = color.RGBA{r,g,b,0}
}
func (f *Framebuffer) readCtl() word {
if f.readCount == 0 {
f.readCount = 1000
return word(0)
} else {
f.readCount -= 1
return word(1)
}
}
func (f *Framebuffer) writeCtl(value word) {
}

30
tridoraemu/go.mod Normal file
View file

@ -0,0 +1,30 @@
module tridoraemu
go 1.22.5
require (
atomicgo.dev/keyboard v0.2.9
github.com/eiannone/keyboard v0.0.0-20220611211555-0d226195f203
github.com/gopxl/pixel v1.0.0
github.com/hajimehoshi/ebiten/v2 v2.7.8
github.com/nsf/termbox-go v1.1.1
golang.org/x/image v0.18.0
golang.org/x/sys v0.22.0
golang.org/x/term v0.22.0
)
require (
github.com/containerd/console v1.0.3 // indirect
github.com/ebitengine/gomobile v0.0.0-20240518074828-e86332849895 // indirect
github.com/ebitengine/hideconsole v1.0.0 // indirect
github.com/ebitengine/purego v0.7.0 // indirect
github.com/faiface/glhf v0.0.0-20211013000516-57b20770c369 // indirect
github.com/faiface/mainthread v0.0.0-20171120011319-8b78f0a41ae3 // indirect
github.com/go-gl/gl v0.0.0-20211210172815-726fda9656d6 // indirect
github.com/go-gl/glfw/v3.3/glfw v0.0.0-20221017161538-93cebf72946b // indirect
github.com/go-gl/mathgl v1.1.0 // indirect
github.com/jezek/xgb v1.1.1 // indirect
github.com/mattn/go-runewidth v0.0.13 // indirect
github.com/pkg/errors v0.9.1 // indirect
golang.org/x/sync v0.7.0 // indirect
)

96
tridoraemu/go.sum Normal file
View file

@ -0,0 +1,96 @@
atomicgo.dev/keyboard v0.2.9 h1:tOsIid3nlPLZ3lwgG8KZMp/SFmr7P0ssEN5JUsm78K8=
atomicgo.dev/keyboard v0.2.9/go.mod h1:BC4w9g00XkxH/f1HXhW2sXmJFOCWbKn9xrOunSFtExQ=
github.com/MarvinJWendt/testza v0.1.0/go.mod h1:7AxNvlfeHP7Z/hDQ5JtE3OKYT3XFUeLCDE2DQninSqs=
github.com/MarvinJWendt/testza v0.2.1/go.mod h1:God7bhG8n6uQxwdScay+gjm9/LnO4D3kkcZX4hv9Rp8=
github.com/MarvinJWendt/testza v0.2.8/go.mod h1:nwIcjmr0Zz+Rcwfh3/4UhBp7ePKVhuBExvZqnKYWlII=
github.com/MarvinJWendt/testza v0.2.10/go.mod h1:pd+VWsoGUiFtq+hRKSU1Bktnn+DMCSrDrXDpX2bG66k=
github.com/MarvinJWendt/testza v0.2.12/go.mod h1:JOIegYyV7rX+7VZ9r77L/eH6CfJHHzXjB69adAhzZkI=
github.com/MarvinJWendt/testza v0.3.0/go.mod h1:eFcL4I0idjtIx8P9C6KkAuLgATNKpX4/2oUqKc6bF2c=
github.com/MarvinJWendt/testza v0.4.2/go.mod h1:mSdhXiKH8sg/gQehJ63bINcCKp7RtYewEjXsvsVUPbE=
github.com/atomicgo/cursor v0.0.1/go.mod h1:cBON2QmmrysudxNBFthvMtN32r3jxVRIvzkUiF/RuIk=
github.com/containerd/console v1.0.3 h1:lIr7SlA5PxZyMV30bDW0MGbiOPXwc63yRuCP0ARubLw=
github.com/containerd/console v1.0.3/go.mod h1:7LqA/THxQ86k76b8c/EMSiaJ3h1eZkMkXar0TQ1gf3U=
github.com/davecgh/go-spew v1.1.0/go.mod h1:J7Y8YcW2NihsgmVo/mv3lAwl/skON4iLHjSsI+c5H38=
github.com/davecgh/go-spew v1.1.1/go.mod h1:J7Y8YcW2NihsgmVo/mv3lAwl/skON4iLHjSsI+c5H38=
github.com/ebitengine/gomobile v0.0.0-20240518074828-e86332849895 h1:48bCqKTuD7Z0UovDfvpCn7wZ0GUZ+yosIteNDthn3FU=
github.com/ebitengine/gomobile v0.0.0-20240518074828-e86332849895/go.mod h1:XZdLv05c5hOZm3fM2NlJ92FyEZjnslcMcNRrhxs8+8M=
github.com/ebitengine/hideconsole v1.0.0 h1:5J4U0kXF+pv/DhiXt5/lTz0eO5ogJ1iXb8Yj1yReDqE=
github.com/ebitengine/hideconsole v1.0.0/go.mod h1:hTTBTvVYWKBuxPr7peweneWdkUwEuHuB3C1R/ielR1A=
github.com/ebitengine/purego v0.7.0 h1:HPZpl61edMGCEW6XK2nsR6+7AnJ3unUxpTZBkkIXnMc=
github.com/ebitengine/purego v0.7.0/go.mod h1:ah1In8AOtksoNK6yk5z1HTJeUkC1Ez4Wk2idgGslMwQ=
github.com/eiannone/keyboard v0.0.0-20220611211555-0d226195f203 h1:XBBHcIb256gUJtLmY22n99HaZTz+r2Z51xUPi01m3wg=
github.com/eiannone/keyboard v0.0.0-20220611211555-0d226195f203/go.mod h1:E1jcSv8FaEny+OP/5k9UxZVw9YFWGj7eI4KR/iOBqCg=
github.com/faiface/glhf v0.0.0-20211013000516-57b20770c369 h1:gv4BgP50atccdK/1tZHDyP6rMwiiutR2HPreR/OyLzI=
github.com/faiface/glhf v0.0.0-20211013000516-57b20770c369/go.mod h1:dDdUO+G9ZnJ9sc8nIUvhLkE45k8PEKW6+A3TdWsfpV0=
github.com/faiface/mainthread v0.0.0-20171120011319-8b78f0a41ae3 h1:baVdMKlASEHrj19iqjARrPbaRisD7EuZEVJj6ZMLl1Q=
github.com/faiface/mainthread v0.0.0-20171120011319-8b78f0a41ae3/go.mod h1:VEPNJUlxl5KdWjDvz6Q1l+rJlxF2i6xqDeGuGAxa87M=
github.com/go-gl/gl v0.0.0-20210905235341-f7a045908259/go.mod h1:wjpnOv6ONl2SuJSxqCPVaPZibGFdSci9HFocT9qtVYM=
github.com/go-gl/gl v0.0.0-20211210172815-726fda9656d6 h1:zDw5v7qm4yH7N8C8uWd+8Ii9rROdgWxQuGoJ9WDXxfk=
github.com/go-gl/gl v0.0.0-20211210172815-726fda9656d6/go.mod h1:9YTyiznxEY1fVinfM7RvRcjRHbw2xLBJ3AAGIT0I4Nw=
github.com/go-gl/glfw v0.0.0-20210727001814-0db043d8d5be/go.mod h1:vR7hzQXu2zJy9AVAgeJqvqgH9Q5CA+iKCZ2gyEVpxRU=
github.com/go-gl/glfw/v3.3/glfw v0.0.0-20221017161538-93cebf72946b h1:GgabKamyOYguHqHjSkDACcgoPIz3w0Dis/zJ1wyHHHU=
github.com/go-gl/glfw/v3.3/glfw v0.0.0-20221017161538-93cebf72946b/go.mod h1:tQ2UAYgL5IevRw8kRxooKSPJfGvJ9fJQFa0TUsXzTg8=
github.com/go-gl/mathgl v1.0.0/go.mod h1:yhpkQzEiH9yPyxDUGzkmgScbaBVlhC06qodikEM0ZwQ=
github.com/go-gl/mathgl v1.1.0 h1:0lzZ+rntPX3/oGrDzYGdowSLC2ky8Osirvf5uAwfIEA=
github.com/go-gl/mathgl v1.1.0/go.mod h1:yhpkQzEiH9yPyxDUGzkmgScbaBVlhC06qodikEM0ZwQ=
github.com/gookit/color v1.4.2/go.mod h1:fqRyamkC1W8uxl+lxCQxOT09l/vYfZ+QeiX3rKQHCoQ=
github.com/gookit/color v1.5.0/go.mod h1:43aQb+Zerm/BWh2GnrgOQm7ffz7tvQXEKV6BFMl7wAo=
github.com/gopxl/pixel v1.0.0 h1:ZON6ll6/tI6sO8fwrlj93GVUcXReTST5//iKv6lcd8g=
github.com/gopxl/pixel v1.0.0/go.mod h1:kPUBG2He7/+alwmi5z0IwnpAc6pw2N7eA08cdBfoE/Q=
github.com/hajimehoshi/ebiten/v2 v2.7.8 h1:QrlvF2byCzMuDsbxFReJkOCbM3O2z1H/NKQaGcA8PKk=
github.com/hajimehoshi/ebiten/v2 v2.7.8/go.mod h1:Ulbq5xDmdx47P24EJ+Mb31Zps7vQq+guieG9mghQUaA=
github.com/jezek/xgb v1.1.1 h1:bE/r8ZZtSv7l9gk6nU0mYx51aXrvnyb44892TwSaqS4=
github.com/jezek/xgb v1.1.1/go.mod h1:nrhwO0FX/enq75I7Y7G8iN1ubpSGZEiA3v9e9GyRFlk=
github.com/klauspost/cpuid/v2 v2.0.9/go.mod h1:FInQzS24/EEf25PyTYn52gqo7WaD8xa0213Md/qVLRg=
github.com/klauspost/cpuid/v2 v2.0.10/go.mod h1:g2LTdtYhdyuGPqyWyv7qRAmj1WBqxuObKfj5c0PQa7c=
github.com/klauspost/cpuid/v2 v2.0.12/go.mod h1:g2LTdtYhdyuGPqyWyv7qRAmj1WBqxuObKfj5c0PQa7c=
github.com/kr/pretty v0.1.0/go.mod h1:dAy3ld7l9f0ibDNOQOHHMYYIIbhfbHSm3C4ZsoJORNo=
github.com/kr/pty v1.1.1/go.mod h1:pFQYn66WHrOpPYNljwOMqo10TkYh1fy3cYio2l3bCsQ=
github.com/kr/text v0.1.0/go.mod h1:4Jbv+DJW3UT/LiOwJeYQe1efqtUx/iVham/4vfdArNI=
github.com/mattn/go-runewidth v0.0.9 h1:Lm995f3rfxdpd6TSmuVCHVb/QhupuXlYr8sCI/QdE+0=
github.com/mattn/go-runewidth v0.0.9/go.mod h1:H031xJmbD/WCDINGzjvQ9THkh0rPKHF+m2gUSrubnMI=
github.com/mattn/go-runewidth v0.0.13/go.mod h1:Jdepj2loyihRzMpdS35Xk/zdY8IAYHsh153qUoGf23w=
github.com/nsf/termbox-go v1.1.1 h1:nksUPLCb73Q++DwbYUBEglYBRPZyoXJdrj5L+TkjyZY=
github.com/nsf/termbox-go v1.1.1/go.mod h1:T0cTdVuOwf7pHQNtfhnEbzHbcNyCEcVU4YPpouCbVxo=
github.com/pkg/errors v0.9.1 h1:FEBLx1zS214owpjy7qsBeixbURkuhQAwrK5UwLGTwt4=
github.com/pkg/errors v0.9.1/go.mod h1:bwawxfHBFNV+L2hUp1rHADufV3IMtnDRdf1r5NINEl0=
github.com/pmezard/go-difflib v1.0.0/go.mod h1:iKH77koFhYxTK1pcRnkKkqfTogsbg7gZNVY4sRDYZ/4=
github.com/pterm/pterm v0.12.27/go.mod h1:PhQ89w4i95rhgE+xedAoqous6K9X+r6aSOI2eFF7DZI=
github.com/pterm/pterm v0.12.29/go.mod h1:WI3qxgvoQFFGKGjGnJR849gU0TsEOvKn5Q8LlY1U7lg=
github.com/pterm/pterm v0.12.30/go.mod h1:MOqLIyMOgmTDz9yorcYbcw+HsgoZo3BQfg2wtl3HEFE=
github.com/pterm/pterm v0.12.31/go.mod h1:32ZAWZVXD7ZfG0s8qqHXePte42kdz8ECtRyEejaWgXU=
github.com/pterm/pterm v0.12.33/go.mod h1:x+h2uL+n7CP/rel9+bImHD5lF3nM9vJj80k9ybiiTTE=
github.com/pterm/pterm v0.12.36/go.mod h1:NjiL09hFhT/vWjQHSj1athJpx6H8cjpHXNAK5bUw8T8=
github.com/pterm/pterm v0.12.40/go.mod h1:ffwPLwlbXxP+rxT0GsgDTzS3y3rmpAO1NMjUkGTYf8s=
github.com/rivo/uniseg v0.2.0/go.mod h1:J6wj4VEh+S6ZtnVlnTBMWIodfgj8LQOQFoIToxlJtxc=
github.com/sergi/go-diff v1.2.0/go.mod h1:STckp+ISIX8hZLjrqAeVduY0gWCT9IjLuqbuNXdaHfM=
github.com/stretchr/objx v0.1.0/go.mod h1:HFkY916IF+rwdDfMAkV7OtwuqBVzrE8GR6GFx+wExME=
github.com/stretchr/testify v1.4.0/go.mod h1:j7eGeouHqKxXV5pUuKE4zz7dFj8WfuZ+81PSLYec5m4=
github.com/stretchr/testify v1.6.1/go.mod h1:6Fq8oRcR53rry900zMqJjRRixrwX3KX962/h/Wwjteg=
github.com/stretchr/testify v1.7.0/go.mod h1:6Fq8oRcR53rry900zMqJjRRixrwX3KX962/h/Wwjteg=
github.com/xo/terminfo v0.0.0-20210125001918-ca9a967f8778/go.mod h1:2MuV+tbUrU1zIOPMxZ5EncGwgmMJsa+9ucAQZXxsObs=
golang.org/x/image v0.0.0-20190321063152-3fc05d484e9f/go.mod h1:kZ7UVZpmo3dzQBMxlp+ypCbDeSB+sBbTgSJuh5dn5js=
golang.org/x/image v0.18.0 h1:jGzIakQa/ZXI1I0Fxvaa9W7yP25TqT6cHIHn+6CqvSQ=
golang.org/x/image v0.18.0/go.mod h1:4yyo5vMFQjVjUcVk4jEQcU9MGy/rulF5WvUILseCM2E=
golang.org/x/sync v0.7.0 h1:YsImfSBoP9QPYL0xyKJPq0gcaJdG3rInoqxTWbfQu9M=
golang.org/x/sync v0.7.0/go.mod h1:Czt+wKu1gCyEFDUtn0jG5QVvpJ6rzVqr5aXyt9drQfk=
golang.org/x/sys v0.0.0-20201119102817-f84b799fce68/go.mod h1:h1NjWce9XRLGQEsW7wpKNCjG9DtNlClVuFLEZdDNbEs=
golang.org/x/sys v0.0.0-20210124154548-22da62e12c0c/go.mod h1:h1NjWce9XRLGQEsW7wpKNCjG9DtNlClVuFLEZdDNbEs=
golang.org/x/sys v0.0.0-20210330210617-4fbd30eecc44/go.mod h1:h1NjWce9XRLGQEsW7wpKNCjG9DtNlClVuFLEZdDNbEs=
golang.org/x/sys v0.0.0-20210615035016-665e8c7367d1/go.mod h1:oPkhp1MJrh7nUepCBck5+mAzfO9JrbApNNgaTdGDITg=
golang.org/x/sys v0.0.0-20211013075003-97ac67df715c/go.mod h1:oPkhp1MJrh7nUepCBck5+mAzfO9JrbApNNgaTdGDITg=
golang.org/x/sys v0.0.0-20220319134239-a9b59b0215f8/go.mod h1:oPkhp1MJrh7nUepCBck5+mAzfO9JrbApNNgaTdGDITg=
golang.org/x/sys v0.22.0 h1:RI27ohtqKCnwULzJLqkv897zojh5/DwS/ENaMzUOaWI=
golang.org/x/sys v0.22.0/go.mod h1:/VUhepiaJMQUp4+oa/7Zr1D23ma6VTLIYjOOTFZPUcA=
golang.org/x/term v0.0.0-20210220032956-6a3ed077a48d/go.mod h1:bj7SfCRtBDWHUb9snDiAeCFNEtKQo2Wmx5Cou7ajbmo=
golang.org/x/term v0.0.0-20210615171337-6886f2dfbf5b/go.mod h1:jbD1KX2456YbFQfuXm/mYQcufACuNUgVhRMnK/tPxf8=
golang.org/x/term v0.0.0-20210927222741-03fcf44c2211/go.mod h1:jbD1KX2456YbFQfuXm/mYQcufACuNUgVhRMnK/tPxf8=
golang.org/x/term v0.22.0 h1:BbsgPEJULsl2fV/AT3v15Mjva5yXKQDyKf+TbDz7QJk=
golang.org/x/term v0.22.0/go.mod h1:F3qCibpT5AMpCRfhfT53vVJwhLtIVHhB9XDjfFvnMI4=
golang.org/x/text v0.3.0/go.mod h1:NqM8EUOU14njkJ3fqMW+pc6Ldnwhi/IjpwHt7yyuwOQ=
gopkg.in/check.v1 v0.0.0-20161208181325-20d25e280405/go.mod h1:Co6ibVJAznAaIkqp8huTwlJQCZ016jof/cbN4VW5Yz0=
gopkg.in/check.v1 v1.0.0-20190902080502-41f04d3bba15/go.mod h1:Co6ibVJAznAaIkqp8huTwlJQCZ016jof/cbN4VW5Yz0=
gopkg.in/yaml.v2 v2.2.2/go.mod h1:hI93XBmqTisBFMUTm0b8Fm+jr3Dg1NNxqwp+5A1VGuI=
gopkg.in/yaml.v2 v2.2.4/go.mod h1:hI93XBmqTisBFMUTm0b8Fm+jr3Dg1NNxqwp+5A1VGuI=
gopkg.in/yaml.v3 v3.0.0-20200313102051-9f266ea9e77c/go.mod h1:K4uyk7z7BCEPqu6E+C64Yfv1cQ7kz7rIZviUmN+EgEM=
gopkg.in/yaml.v3 v3.0.0-20210107192922-496545a6307b/go.mod h1:K4uyk7z7BCEPqu6E+C64Yfv1cQ7kz7rIZviUmN+EgEM=

29
tridoraemu/irqc.go Normal file
View file

@ -0,0 +1,29 @@
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
"time"
// "fmt"
)
const MSecsPerTick = 50
type IRQC struct {
start time.Time
}
func (i *IRQC) initialize() {
i.start = time.Now()
}
func (i *IRQC) read(byteaddr word) (word, error) {
elapsedms := time.Since(i.start).Milliseconds()
elapsedTicks := elapsedms / MSecsPerTick
result := word((elapsedTicks & 0x0FFFFFFF) << 8)
//fmt.Printf("** IRQC read: %08X (%v)\n", result, elapsedms)
return result, nil
}
func (i *IRQC) write(value word, byteaddr word) (error) {
return nil
}

117
tridoraemu/mem.go Normal file
View file

@ -0,0 +1,117 @@
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
"fmt"
"log"
"os"
"io"
"bufio"
"encoding/binary"
)
const IOStartAddr = 2048
const RAMStartAddr = 4096
const IOSlotSize = 128
const IOSlotCount = 16
type Mem struct {
ram [] word
iohandler [IOSlotCount] IOHandler
}
func (m *Mem) wordAddr(byteaddr word) (int, error) {
wordaddr := int(byteaddr / 4)
if wordaddr >= len(m.ram) {
return 0, fmt.Errorf("Invalid address %08X", byteaddr)
}
return wordaddr, nil
}
func (m *Mem) initialize(sizewords int) {
m.ram = make([] word, sizewords)
for i := 0; i < len(m.ram); i++ {
m.ram[i] = 0
}
}
func (m *Mem) loadFromFile(path string, startAddr int) {
f, err := os.Open(path)
if err != nil {
panic(err)
}
defer f.Close()
buf := make([]byte,4)
reader := bufio.NewReader(f)
count := 0
wordaddr := startAddr / 4
for {
n, e := reader.Read(buf)
if e != nil && e != io.EOF {
panic(e)
}
if n < 4 {
if n == 2 {
m.ram[wordaddr] = word(binary.BigEndian.Uint32(buf) & 0xFFFF0000)
count += 2
}
fmt.Printf("%v bytes read at %08X from %v\n", count, startAddr, path)
break
} else {
m.ram[wordaddr] = word(binary.BigEndian.Uint32(buf))
// fmt.Printf("%08X %08X\n", addr, m.ram[addr])
count += 4
wordaddr += 1
}
}
}
func (m *Mem) attachIO(h IOHandler, slot int) {
if m.iohandler[slot] != nil {
log.Panicf("I/O handler %d already attached", slot)
}
m.iohandler[slot] = h
}
func (m *Mem) read(byteaddr word) (word, error) {
if byteaddr >= IOStartAddr && byteaddr < RAMStartAddr {
ioslot := (byteaddr - IOStartAddr) / IOSlotSize
if m.iohandler[ioslot] != nil {
return m.iohandler[ioslot].read(byteaddr)
}
return 42, nil
}
wordaddr, err := m.wordAddr(byteaddr)
if err == nil {
return m.ram[wordaddr], err
} else {
return 0, err
}
}
func (m *Mem) write(value word, byteaddr word) error {
if byteaddr < IOStartAddr {
return fmt.Errorf("Write to ROM area at %08X value %08X", byteaddr, value)
}
if byteaddr >= IOStartAddr && byteaddr < RAMStartAddr {
ioslot := (byteaddr - IOStartAddr) / IOSlotSize
if m.iohandler[ioslot] != nil {
return m.iohandler[ioslot].write(value, byteaddr)
}
return nil
}
wordaddr, err := m.wordAddr(byteaddr)
if err == nil {
m.ram[wordaddr] = value
}
return err
}

272
tridoraemu/sdspi.go Normal file
View file

@ -0,0 +1,272 @@
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
"os"
"io"
"encoding/binary"
"fmt"
)
type SDState uint
const (
IDLE SDState = iota
WRCMD
WRDATA
RDDATA
)
const (
CTRL_WRITE = 0b100000000000000
RX_FILTER_EN = 0b010000000000000
TXRX_EN = 0b001000000000000
CLK_F_EN = 0b000100000000000
CLK_DIV_WR = 0b000010000000000
RX_RD = 0b000001000000000
TX_WR = 0b000000100000000
C_D = 0b100000000000000
C_CHG = 0b010000000000000
C_BUSY = 0b001000000000000
TX_RDY = 0b000100000000000
TX_EMPTY = 0b000010000000000
RX_AVAIL = 0b000001000000000
RX_OVR = 0b000000100000000
)
type SDSPI struct {
state SDState
ksectors uint
lastSector uint
imgfile *os.File
cmd uint
cmdcount uint
arg uint
receiving bool
blockaddr uint
readbuf []byte
readpos int
writebuf []byte
writepos int
debug bool
dbgwaiten bool
}
func (s *SDSPI) openImage(filename string) error {
var err error
s.imgfile, err = os.OpenFile(filename, os.O_RDWR, 0644)
if err != nil { return err }
buf := make([]byte,4)
_, err = s.imgfile.ReadAt(buf, 48)
if err != nil { return err }
blocks := binary.BigEndian.Uint32(buf)
s.ksectors = uint(blocks / 1024)
s.lastSector = uint(blocks - 1)
fmt.Printf("opened SD card image %v, PHYS blocks: %v\n", filename, blocks)
return nil
}
func (s *SDSPI) closeImage() {
s.imgfile.Close()
}
func (s *SDSPI) read(byteaddr word) (word, error) {
result := word(0)
// always detect a card, transmitter always ready
result = C_D | TX_RDY
if s.debug {
fmt.Printf("** SDSPI read readbuf len: %v receiving: %v readpos: %v\n",
len(s.readbuf), s.receiving, s.readpos)
}
if s.receiving && len(s.readbuf) > 0 {
if s.debug { fmt.Printf(" byte: %02X\n", s.readbuf[s.readpos]) }
result |= RX_AVAIL // there is data to be read
result |= word(s.readbuf[s.readpos])
// the read position is advanced only by writing RX_RD to the
// SDSPI register
} else {
result |= 0xFF
}
// always signal TX_EMPTY since we immediately process
// all written data
result |= TX_EMPTY
return result, nil
}
func (s *SDSPI) sendIdleResponse() {
s.readbuf = []byte{0x01}
}
func (s *SDSPI) sendOkResponse() {
s.readbuf = []byte{0x00}
}
func (s *SDSPI) sendDataResponse() {
s.readbuf = []byte{0b00101}
}
func (s *SDSPI) sendBusy() {
s.readbuf = append(s.readbuf, 0xFF, 0x00, 0xFF)
}
func (s *SDSPI) sendDataPkt(dataBytes []byte) {
s.readbuf = append(s.readbuf, 0xFE) // data token
s.readbuf = append(s.readbuf, dataBytes...) // data block
s.readbuf = append(s.readbuf, 0, 0) // crc/unused in SPI mode
}
func (s *SDSPI) sendCSD() {
size := s.ksectors - 1
sizehi := byte((size & 0b1111110000000000000000) >> 16)
sizemid := byte((size & 0b0000001111111100000000) >> 8)
sizelow := byte((size & 0b0000000000000011111111))
s.sendDataPkt( []byte{0b01000000,
0xC1, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6,
sizehi, sizemid, sizelow,
0xCA, 0xCB, 0xCC, 0xCD, 0xCE, 0xCF})
}
func (s *SDSPI) readSendBlock() {
buf := make([]byte, 512)
if s.arg <= s.lastSector {
s.imgfile.Seek(int64(s.arg) * 512, 0)
_, err := s.imgfile.Read(buf)
if err != nil && err != io.EOF { panic(err) }
}
s.sendDataPkt(buf)
}
func (s *SDSPI) writeBlock() {
if s.arg <= s.lastSector {
s.imgfile.Seek(int64(s.arg) * 512, 0)
_, err := s.imgfile.Write(s.writebuf)
if err != nil { panic(err) }
}
s.writebuf = make([]byte, 0)
s.writepos = 0
}
func (s *SDSPI) write(value word, byteaddr word) (error) {
if (value & CTRL_WRITE) != 0 {
s.receiving = (value & TXRX_EN) != 0
}
if s.debug { fmt.Printf("** SDSPI write %032b\n", value) }
if (value & CLK_DIV_WR) != 0 {
if s.debug {
fmt.Printf("** SDSPI clock divider set to %v\n", value & 0xFF)
}
}
if (value & RX_RD) != 0 {
// advance read position when RX_RD i set
s.readpos += 1
if s.readpos >= len(s.readbuf) {
s.readbuf = make([]byte, 0)
s.readpos = 0
// if in WRDATA state, do not go IDLE when all data has been read.
// In that case, we just read the R1 response for the write command
// and after that the data packet will be written.
if s.state != WRDATA { s.state = IDLE }
}
}
if (value & TX_WR) != 0 {
// we ignore the TXRX_EN flag for the transmitter and
// always process data written with TX_WR
value8 := value & 0xFF
switch s.state {
case IDLE:
if value8 != 0xFF {
s.state = WRCMD
s.cmd = uint(value & 0x3F)
s.arg = 0
s.cmdcount = 5
if s.debug {
fmt.Printf(" cmd: %02d\n", s.cmd)
}
}
case WRCMD:
if s.cmdcount > 0 { // any more argument bytes to be received?
s.cmdcount -= 1
if s.cmdcount == 0 {
s.state = RDDATA
switch s.cmd {
case 0: s.sendIdleResponse() // GO_IDLE_STATE
case 8: s.readbuf = []byte{0x01, 0xA1, 0xA2, 0xA3, 0xA4} // SEND_IF_COND
case 9: s.sendOkResponse() // SEND_CSD
s.sendCSD()
case 16: s.sendOkResponse() // SET_BLOCKLEN, ignored
case 17: s.sendOkResponse() // READ_SINGLE_BLOCK
s.readSendBlock()
case 24: s.sendOkResponse() // WRITE_SINGLE_BLOCK
s.sendOkResponse()
s.state = WRDATA
case 58: s.readbuf = []byte{0x01, 0xB1, 0xB2, 0xB3, 0xB4} // READ_OCR
case 55: s.sendIdleResponse() // APP_CMD, we just ignore it and treat CMD41 as ACMD41
case 41: s.sendOkResponse() // APP_SEND_OP_COND
default:
if s.debug {
fmt.Printf("** SDSPI invalid CMD %v\n", s.cmd)
}
}
} else {
// process an argument byte
s.arg = uint((s.arg << 8)) | uint(value8)
}
} else {
if s.debug {
fmt.Printf("** SDSPI extra bytes in command %v\n", value8)
}
}
case WRDATA:
if len(s.writebuf) == 0 {
// wait for data token
if value8 == 0xFE { // data token found
s.writebuf = make([]byte, 512)
s.writepos = 0
}
} else { // collecting data bytes to write
if s.writepos < 512 {
s.writebuf[s.writepos] = byte(value8)
}
s.writepos += 1
// after getting and ignoring two crc bytes, write block
// and return to idle state
if s.writepos >= 514 {
s.state = IDLE
s.writeBlock()
s.sendDataResponse()
s.sendBusy()
}
}
default:
if value8 != 0xFF {
if s.debug {
fmt.Printf("** SDSPI invalid state %v on TX_WR byte %v\n", s.state, value8)
}
}
}
}
return nil
}

159
tridoraemu/tridoraemu.go Normal file
View file

@ -0,0 +1,159 @@
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
"fmt"
"log"
"errors"
"flag"
"time"
"github.com/hajimehoshi/ebiten/v2"
// "github.com/hajimehoshi/ebiten/v2/ebitenutil"
// "image/color"
)
const IdleTicks = 1000
var consoleChan chan byte
var cpu CPU
var mem Mem
var uart UART
var framebuffer Framebuffer
var sdspi SDSPI
var irqc IRQC
var Terminated = errors.New("terminated")
var idleCounter int = IdleTicks
func idle(canGoIdle bool) {
if canGoIdle {
if idleCounter > 0 { idleCounter -= 1 }
} else {
if idleCounter != IdleTicks { idleCounter = IdleTicks }
}
}
type Game struct{
x,y int
stepsPerFrame int
lastFrameDuration time.Duration
}
func (g *Game) Update() error {
startTime := time.Now()
for i := 0; i < g.stepsPerFrame; i++ {
err := cpu.step()
if err != nil {
log.Printf("Stopped by error at PC %08X",cpu.PC)
log.Print(err)
return Terminated
}
if cpu.stopped { return Terminated }
if idleCounter == 0 { break }
}
g.lastFrameDuration = time.Since(startTime)
return nil
}
func (g *Game) Draw(screen *ebiten.Image) {
screen.DrawImage(framebuffer.framebuffer, nil)
/*
buf := fmt.Sprintf("PC: %08X FP: %08X RP: %08X ESP: %2X\n%v", cpu.PC, cpu.FP, cpu.RP, cpu.ESP, g.lastFrameDuration)
ebitenutil.DebugPrint(screen, buf)
screen.Set(g.x, g.y, color.RGBA{255,0,0,0})
screen.Set(g.x, g.y+1, color.RGBA{0,255,0,0})
screen.Set(g.x, g.y+2, color.RGBA{0,255,255,0})
screen.Set(g.x, g.y+3, color.RGBA{255,255,255,0})
g.x += 1
if g.x > 319 { g.x = 0 }
*/
// if idleCounter == 0 { ebitenutil.DebugPrint(screen, "idle") }
}
func (g *Game) Layout(outsideWidth, outsideHeight int) (screenWidth, screenHeight int) {
return 640, 400
}
func main() {
var codefile string = ""
addrPtr := flag.Int("a",0,"starting address")
tracePtr := flag.Bool("t",false,"trace")
cardImgPtr := flag.String("i", "sdcard.img", "SD card image file")
flag.Parse()
if len(flag.Args()) > 0 {
codefile = flag.Args()[0]
} else {
codefile = "rommon.prog"
}
log.SetFlags(0)
oldState, err := SetRawConsole()
if err != nil {
panic(err)
}
defer RestoreConsole(oldState)
cpu.initialize()
mem.initialize(4096 * 1024 / 4)
uart.cpu = &cpu
mem.attachIO(&uart, 0)
err = sdspi.openImage(*cardImgPtr)
if err != nil {
panic(err)
}
defer sdspi.closeImage()
//sdspi.debug = true
mem.attachIO(&sdspi, 1)
framebuffer.initialize()
mem.attachIO(&framebuffer, 2)
irqc.initialize()
mem.attachIO(&irqc, 3)
cpu.mem = &mem
cpu.PC = word(*addrPtr)
if codefile != "" {
mem.loadFromFile(codefile, *addrPtr)
}
consoleChan = make(chan byte)
uart.consoleChan = make(chan byte)
ebiten.SetWindowSize(800, 600)
ebiten.SetWindowTitle("Tridora Framebuffer")
g := Game{}
cpu.trace = *tracePtr
g.stepsPerFrame = 166666
// g.stepsPerFrame = 1
go func(ch chan byte) {
for {
buf := make([] byte,1);
n, err := ConsoleRead(buf)
if err != nil {
fmt.Println("read error on stdin, closing channel")
close(ch)
return
}
if n > 0 {ch <- buf[0] }
}
}(uart.consoleChan)
if err := ebiten.RunGame(&g); err != Terminated && err != nil {
log.Panic(err)
}
}

59
tridoraemu/uart.go Normal file
View file

@ -0,0 +1,59 @@
// Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
package main
import (
// "fmt"
"os"
"errors"
)
type UART struct {
available bool
buf [] byte
consoleChan chan byte
cpu *CPU
}
func (u *UART) read(byteaddr word) (word, error) {
var result word = 0
if len(u.buf) > 0 {
result = word(u.buf[0])
result |= 512
} else {
select {
case inbyte, ok := <-u.consoleChan:
if ! ok {
return 0, errors.New("console channel error")
} else {
u.buf = make([]byte, 1)
u.buf[0] = inbyte
// fmt.Println("Read input:", inbyte)
idle(false)
}
default:
idle(true)
}
}
return result, nil
}
func (u *UART) write(value word, byteaddr word) (error) {
var err error = nil
idle(false)
if value & 512 != 0 {
u.buf = u.buf[1:]
// fmt.Println("rx_clear: len ", len(u.buf))
}
if value & 1024 != 0 {
buf := make([] byte, 1)
buf[0] = byte(value & 255)
_ , err = os.Stdout.Write(buf)
}
return err
}

567
utils/tdrimg.py Normal file
View file

@ -0,0 +1,567 @@
#!/usr/bin/python3
# vim: tabstop=8 expandtab shiftwidth=4 softtabstop=4
# Copyright 2021-2024 Sebastian Lederer. See the file LICENSE.md for details
import struct
import sys
from collections import namedtuple
import os
MaxPartitions = 8
SlotFree = 1
SlotReserved = 2
SlotDeleted = 4
SlotEndScan = 8
SlotFirst = 16
SlotExtent = 32
SlotReadonly = 64
PartEnabled = 1
PartBoot = 2
PartLast = 4
PartPhysical = 8
PartDefault = 16
part_fmt = ">ii32siiiiii"
dirslot_fmt = ">ii32siiiiii"
PartSlot = namedtuple("PartSlot", "namelength maxlength name flags startBlock blocks extentSize dirSize bootBlocks")
DirSlot = namedtuple("DirSlot", "namelength maxlength name flags sizeBytes createTime modTime generation owner")
def createpart(name, flags, start_block, blocks, extent_size, dir_size, boot_blocks=0):
b = struct.pack(part_fmt, len(name), 32, bytes(name, 'utf8'), flags, start_block, blocks,
extent_size, dir_size, boot_blocks)
return b
def decodepart(data):
return struct.unpack(part_fmt, data)
def getpartslot(img, partno):
img.seek(partno * 64)
fields = decodepart(img.read(64))
name = getname(fields)
fields = list(fields)
fields[2] = name
return PartSlot._make(fields)
def createdirslot(name, flags, size, create_time, mod_time, generation, owner):
return struct.pack(dirslot_fmt, len(name), 32, bytes(name, 'utf8'), flags, size, create_time,
mod_time, generation, owner)
def decodedirslot(data):
return struct.unpack(dirslot_fmt, data)
def putdirslot(img, partstart, slotno, slotdata):
img.seek(partstart * 512 + slotno * 64)
img.write(slotdata)
def getdirslot(img, part, slotno):
partstart = part.startBlock
img.seek(partstart * 512 + slotno * 64)
fields = decodedirslot(img.read(64))
name = getname(fields)
fields = list(fields)
fields[2] = name
return DirSlot._make(fields)
def writefile(img, part, slotno, databytes):
partstart = part.startBlock
extent_size = part.extentSize
pos = partstart * 512 + slotno * extent_size
print("writefile: slot", slotno, len(databytes), "bytes at block", partstart + slotno * extent_size // 512, " pos",
pos)
img.seek(pos)
img.write(databytes)
extendfile(img, part, slotno, len(databytes))
def write_bootimage(img, startblock, data):
pos = startblock * 512
img.seek(pos)
img.write(data)
def extendfile(img, part, slotno, newSize):
dirslot = getdirslot(img, part, slotno)
extent_size = part.extentSize
old_extents = dirslot.sizeBytes // extent_size + 1
new_extents = newSize // extent_size + 1
old_last_slot = slotno + 1
new_last_slot = slotno + new_extents - 1
print("extendfile old_last_slot {} new_last_slot {} old_ext {} new_ext {} ".format(
old_last_slot, new_last_slot, old_extents, new_extents), end="")
for i in range(old_last_slot, new_last_slot + 1):
d = getdirslot(img, part, i)
if d.flags & SlotFree:
print(i," ", sep="", end="")
d = createdirslot("", SlotExtent, 0, 0, 0, 0, 0)
putdirslot(img, part.startBlock, i, d)
else:
print("Cannot extend file at dirslot",i, "- wanted size:", newSize)
listdir(img, part)
sys.exit(3)
print()
if old_extents != new_extents:
print("file at dirslot",slotno, "extended to", new_extents, "extents")
firstslot = createdirslot(dirslot.name, dirslot.flags, newSize, dirslot.createTime, dirslot.modTime,
dirslot.generation, dirslot.owner)
putdirslot(img, part.startBlock, slotno, firstslot)
def findslots(img, part, size):
size_in_extents = (size + part.extentSize - 1) // part.extentSize
last_slot = part.dirSize - 1
found = False
firstslot = 0
slotno = 0
while slotno <= last_slot and not found:
dirslot = getdirslot(img, part, slotno)
if dirslot.flags & SlotFree:
found = True
firstslot = slotno
print("found free slot at",slotno, ":", dirslot)
if size_in_extents > 1:
print("checking slot ", end='')
for s in range(1, size_in_extents):
slotno += 1
print(slotno, " ", end='')
dirslot = getdirslot(img, part, slotno)
if not (dirslot.flags & SlotFree):
print("wanted slot",slotno,"not free")
found = False
break
print()
else:
slotno += 1
if found:
return firstslot
else:
return 0
def putfile(infilename, filename, img, part, partstart, slotnr):
if filename is None:
filename = os.path.basename(infilename)
try:
extent_size = part.extentSize
with open(infilename,"rb") as infile:
print("creating file", filename, "at slot", slotnr)
content = infile.read()
d = createdirslot(filename, SlotFirst, len(content), 0, 0, 0, 0)
putdirslot(img, partstart, slotnr, d)
writefile(img, part, slotnr, content)
slotnr += len(content) // extent_size + 1
except Exception as e:
print("error reading file", infilename, "skipping", e)
return slotnr
def getname(data):
length = data[0]
name = data[2][:length].decode('utf8')
return name
def flags2str(flags):
result = ""
if flags & SlotFree:
result += "F"
if flags & SlotReserved:
result += "R"
if flags & SlotDeleted:
result += "D"
if flags & SlotEndScan:
result += "E"
if flags & SlotFirst:
result += "1"
if flags & SlotExtent:
result += "+"
if flags & SlotReadonly:
result += "o"
return result
def findvolume(img, volname):
part = None
partno = 0
while True:
part = getpartslot(img, partno)
if part.flags & PartEnabled:
if part.name == volname:
break
partno += 1
if (part.flags & PartLast) or partno >= MaxPartitions:
part = None
break
return part
def listvolumes(img):
firstvolume = None
partno = 0
done = False
while not done:
part = getpartslot(img, partno)
print(part)
if part.flags & PartEnabled:
print("part", partno, " enabled")
print("\tvolume name\t", part.name)
print("\tstart block\t", part.startBlock)
print("\tblocks\t\t", part.blocks)
print("\textentSize\t", part.extentSize)
print("\tdirSize\t\t", part.dirSize)
if firstvolume is None :
firstvolume = part
partno += 1
if (part.flags & PartLast) or partno >= MaxPartitions:
done = True
return firstvolume
def listdir(img, part, verbose=False):
print("Directory of {}:".format(part.name))
slotno = 0
done = False
while not done:
slot = getdirslot(img, part, slotno)
if (slot.flags & SlotFirst):
print(slot.name, slot.sizeBytes, slotno)
else:
if verbose:
print(flags2str(slot.flags))
slotno += 1
#if (slot.flags & SlotEndScan) or (slotno >= part.dirSize):
# done = True
if (slotno >= part.dirSize):
done = True
def findfile(img, part, name):
slotno = 0
done = False
while not done:
slot = getdirslot(img, part, slotno)
if (slot.flags & SlotFirst) and not (slot.flags & SlotDeleted):
if slot.name == name:
return slotno
slotno += 1
if (slot.flags & SlotEndScan) or (slotno >= part.dirSize):
done = True
return None
def readfile(img, part, slotno):
pos = part.startBlock * 512 + slotno * part.extentSize
dirslot = getdirslot(img, part, slotno)
size = dirslot.sizeBytes
print("readfile", dirslot.name, size,"bytes from",pos)
img.seek(pos)
return img.read(size)
def parsepath(img, pathname):
volname = "SYSTEM"
if pathname.startswith("#"):
volname, filename = pathname.split(':')
volname = volname[1:]
vol = findvolume(img, volname)
if vol is None:
print("Volume {} not found".format(volname))
return (None, None)
else:
filename = pathname
vol = listvolumes(img)
return (vol, filename)
def readfromimg(img, pathname,outfilepath):
vol, filename = parsepath(img, pathname)
if vol is None:
return
listdir(img, vol)
slotno = findfile(img, vol, filename)
if slotno is None:
print("File", filename,"not found")
return
data = readfile(img, vol, slotno)
with open(outfilepath, "wb") as f:
f.write(data)
def writetoimg(img, pathname, infilepath):
vol, filename = parsepath(img, pathname)
if vol is None:
return
existing_slot = findfile(img, vol, filename)
if existing_slot is not None:
print("Filename", filename, "already exists on", vol.name)
return
filesize = os.path.getsize(infilepath)
slotno = findslots(img, vol, filesize)
if slotno < 1:
print("No space on volume", vol.name)
return
putfile(infilepath, filename, img, vol, vol.startBlock, slotno)
def create_image_with_stuff():
imgfile = "sdcard.img"
bootimage = "../lib/coreloader.prog"
dir_slots = 256
extent_size = 8192
slots_per_extent = extent_size // 64
reserved_slots = dir_slots // slots_per_extent
f = open(imgfile,"w+b")
b = createpart("PHYS", PartPhysical, 0, 12288, 4096, 0, 0)
#print(b)
f.write(b)
with open(bootimage, "rb") as bf:
bootdata = bf.read()
bootBlocks = len(bootdata) // 512 + 1
b = createpart("BOOT", PartBoot, 16, 112, 0, 0, bootBlocks)
f.write(b)
b = createpart("Testvolume 1", PartEnabled, 128, 3968, 8192, 248)
f.write(b)
b = createpart("SYSTEM", PartEnabled, 4096, 4096, 8192, 256)
f.write(b)
b = createpart("Examples", PartEnabled + PartLast, 8192, 4096, 8192, 256)
f.write(b)
part = getpartslot(f, 2)
partstart = part.startBlock
dir_slots = part.dirSize
print("creating",reserved_slots, "reserved directory slots")
for a in range(0,reserved_slots):
d = createdirslot("DIR", SlotReserved, 0, 0, 0, 0, 0)
putdirslot(f, partstart, a, d)
print("creating", dir_slots - reserved_slots, "free slots")
for a in range(reserved_slots, dir_slots):
d = createdirslot("", SlotFree, 0, 0, 0, 0, 0)
putdirslot(f, partstart, a, d)
#d = createdirslot("obstacle", SlotFirst , 0, 0, 0, 0, 0)
#putdirslot(f, partstart, reserved_slots + 2, d)
slotnr = reserved_slots
if True:
data = bytes("ABCDEFGHIJKLMNOPQRST", "ASCII") * 410 + bytes('1234','ASCII')
d = createdirslot("A Testfile.text", SlotFirst, 0, 0, 0, 0, 0)
putdirslot(f, partstart, slotnr, d)
writefile(f, part, slotnr, data)
slotnr += len(data) // extent_size + 1
d = createdirslot("", SlotFree, 0, 0, 0, 0, 0)
putdirslot(f, partstart, slotnr, d)
slotnr += 1
d = createdirslot("Another_file.text", SlotFirst, 20, 0, 0, 0, 0)
putdirslot(f, partstart, slotnr, d)
slotnr += 1
for a in range(0,20):
d = createdirslot("", SlotFree, 0, 0, 0, 0, 0)
putdirslot(f, partstart, slotnr, d)
slotnr += 1
if True:
d = createdirslot("test3.text", SlotFirst, 20, 0, 0, 0, 0)
putdirslot(f, partstart, slotnr, d)
slotnr += 1
d = createdirslot("test1.text", SlotFirst, 20, 0, 0, 0, 0)
putdirslot(f, partstart, slotnr, d)
slotnr += 1
d = createdirslot("test2.text", SlotFirst, 20, 0, 0, 0, 0)
putdirslot(f, partstart, slotnr, d)
slotnr += 1
slotnr = putfile("../examples/test.txt", "sometext.text" , f, part, partstart, slotnr)
# slotnr = putfile("chase.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/chase.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/sine.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/graph2.pas", None , f, part, partstart, slotnr)
while slotnr < dir_slots:
d = createdirslot("", SlotFree + SlotEndScan , 0, 0, 0, 0, 0)
putdirslot(f, partstart, slotnr, d)
slotnr += 1
# second partition (SYSTEM)
part = getpartslot(f, 3)
partstart = part.startBlock
dir_slots = part.dirSize
print()
print("Partition {} at {}".format(part.name, part.startBlock))
print("creating",reserved_slots, "reserved directory slots")
for a in range(0,reserved_slots):
d = createdirslot("DIR", SlotReserved, 0, 0, 0, 0, 0)
putdirslot(f, partstart, a, d)
print("creating", dir_slots - reserved_slots, "free slots")
for a in range(reserved_slots, dir_slots):
d = createdirslot("", SlotFree + SlotEndScan, 0, 0, 0, 0, 0)
putdirslot(f, partstart, a, d)
slotnr = reserved_slots
slotnr = putfile("../progs/shell.prog", "shell.prog", f, part, partstart, slotnr)
slotnr = putfile("../lib/coreloader.lsym", "coreloader.lsym", f, part, partstart, slotnr)
slotnr = putfile("../lib/coreloader.prog", "coreloader.prog", f, part, partstart, slotnr)
slotnr = putfile("../lib/float32.lib", "float32.lib", f, part, partstart, slotnr)
slotnr = putfile("../lib/runtime.lib", "runtime.lib", f, part, partstart, slotnr)
slotnr = putfile("../lib/stdlib.lib", None, f, part, partstart, slotnr)
slotnr = putfile("../lib/stdlib.inc", None, f, part, partstart, slotnr)
slotnr = putfile("../pcomp/sasm.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../pcomp/pcomp.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../pcomp/lsymgen.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../pcomp/libgen.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../progs/reclaim.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../progs/dumpdir.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../progs/partmgr.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../progs/editor.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../progs/editor.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../progs/xfer.prog", None , f, part, partstart, slotnr)
listdir(f, part)
# third partition
part = getpartslot(f, 4)
partstart = part.startBlock
dir_slots = part.dirSize
print()
print("Partition {} at {}".format(part.name, part.startBlock))
print("creating",reserved_slots, "reserved directory slots")
for a in range(0,reserved_slots):
d = createdirslot("DIR", SlotReserved, 0, 0, 0, 0, 0)
putdirslot(f, partstart, a, d)
slotnr = reserved_slots
print("creating", dir_slots - reserved_slots, "free slots")
for a in range(reserved_slots, dir_slots):
d = createdirslot("", SlotFree + SlotEndScan, 0, 0, 0, 0, 0)
putdirslot(f, partstart, a, d)
slotnr = putfile("../examples/helloasm.s", None, f, part, partstart, slotnr)
# slotnr = putfile("helloasm.prog", "helloasm.prog", f, part, partstart, slotnr)
# slotnr = putfile("hello.prog", None , f, part, partstart, slotnr)
# slotnr = putfile("hellop.s", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/hellop.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/timetest.pas", None , f, part, partstart, slotnr)
# slotnr = putfile("../tests/timetest.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/readtest.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/readtest.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/readchartest.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/readchartest.prog", None , f, part, partstart, slotnr)
# slotnr = putfile("cchangetest.pas", None , f, part, partstart, slotnr)
# slotnr = putfile("cchangetest.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/test109.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/test133.pas", None , f, part, partstart, slotnr)
# slotnr = putfile("../tests/test133.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/test159.pas", None , f, part, partstart, slotnr)
# slotnr = putfile("../tests/test159.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../tests/umlaut.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/rtpair.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/5cubes.pas", None , f, part, partstart, slotnr)
# slotnr = putfile("../examples/5cubes.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/3dcube.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/conway.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/mandelbrot.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/lines.pas", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/viewpict.pas", None , f, part, partstart, slotnr)
# slotnr = putfile("viewpict.prog", None , f, part, partstart, slotnr)
slotnr = putfile("../examples/ara.pict", "ara.pict" , f, part, partstart, slotnr)
slotnr = putfile("../examples/shinkansen.pict", "shinkansen.pict" , f, part, partstart, slotnr)
slotnr = putfile("../examples/snow_leopard.pict", "snow_leopard.pict" , f, part, partstart, slotnr)
listdir(f, part)
write_bootimage(f, 16, bootdata)
f.close()
if __name__ == "__main__":
if len(sys.argv) > 1:
if sys.argv[1] == "get":
f = open(sys.argv[2], "rb")
readfromimg(f, sys.argv[3], sys.argv[4])
elif sys.argv[1] == "put":
imgfile = open(sys.argv[2], "r+b")
infilepath = sys.argv[3]
destfilename = sys.argv[4]
writetoimg(imgfile, destfilename, infilepath)
elif sys.argv[1] == "createimg":
create_image_with_stuff()
sys.exit(0)